v23i095: ABC interactive programming environment, Part16/25
Rich Salz
rsalz at bbn.com
Thu Dec 20 04:53:49 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
Posting-number: Volume 23, Issue 95
Archive-name: abc/part16
#! /bin/sh
# This is a shell archive. Remove anything before this line, then feed it
# into a shell via "sh file" or similar. To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to comp-sources-unix at uunet.uu.net if you want that tool.
# Contents: abc/bint1/i1nuc.c abc/bint2/i2ana.c abc/bint3/i3err.c
# abc/doc/abcintro.doc abc/ihdrs/i2par.h abc/lin/i1lta.c
# Wrapped by rsalz at litchi.bbn.com on Mon Dec 17 13:28:11 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
echo If this archive is complete, you will see the following message:
echo ' "shar: End of archive 16 (of 25)."'
if test -f 'abc/bint1/i1nuc.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint1/i1nuc.c'\"
else
echo shar: Extracting \"'abc/bint1/i1nuc.c'\" \(8704 characters\)
sed "s/^X//" >'abc/bint1/i1nuc.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X#include "b.h"
X#include "feat.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "i1num.h"
X
X#define MAXDIGITS (MAXNUMDIG)
X /* Max precision for non-integral, non-rounded numbers */
X#define MAXNUMSIZE (MAXDIGITS+MAXNUMDIG+10)
X /* Maximum width of non-rounded number in convnum;
X * occurs for e.g. -0.xxxxxxe-yyy:
X * MAXDIGITS x's and MAXNUMDIG (with EXT_RANGE on) y's
X * 10 is a few extra, not a holy number, but guard against evil:-) */
X
X
X/* Convert an integer to a C character string.
X The character string is overwritten on each next call.
X It assumes BASE is a power of 10. */
X
XHidden char *convint(v) register integer v; {
X static char *buffer, shortbuffer[tenlogBASE+3];
X static char fmt[10];
X register char *cp;
X register int i;
X bool neg = No;
X
X if (IsSmallInt(v)) {
X sprintf(shortbuffer, "%d", SmallIntVal(v));
X return shortbuffer;
X }
X
X if (Digit(v, Length(v)-1) < 0) {
X neg = Yes;
X v = int_neg(v);
X }
X if (buffer) freemem((ptr)buffer);
X buffer = getmem((unsigned)(Length(v)*tenlogBASE + 1 + neg));
X cp = buffer;
X if (neg) *cp++ = '-';
X sprintf(cp, "%d", Msd(v));
X if (!IsSmallInt(v)) {
X if (!*fmt) sprintf(fmt, "%%0%dd", tenlogBASE);
X while (*cp) ++cp;
X for (i = Length(v)-2; i >= 0; --i, cp += tenlogBASE)
X sprintf(cp, fmt, Digit(v, i));
X if (neg) Release(v);
X }
X return buffer;
X}
X
XHidden value tento_d(x) double x; {
X if (x > Maxint || x < -Maxint) {
X value n= (value) mk_int(x);
X value v= power((value) int_10, n);
X release(n);
X return v;
X }
X else return tento((int) x);
X}
X
X/* return number of digits before decimal point,
X * or minus the number of zero's after the decimal point
X */
X
XHidden int digits_in(v) value v; {
X integer p, q;
X struct integer pp, qq;
X double x;
X value t1= Vnil, t2= Vnil;
X
X if (numcomp(v, zero) == 0)
X return 0;
X
X v= absval(v);
X if (Integral(v)) {
X p= (integer) v;
X q= (integer) one;
X }
X else {
X p= Numerator((rational) v);
X q= Denominator((rational) v);
X }
X FreezeSmallInt(p, pp); FreezeSmallInt(q, qq);
X
X x = log10((double) Msd(p));
X x-= log10((double) Msd(q));
X x+= (double) ((Length(p) - Length(q)) * tenlogBASE);
X x= floor(x) + 1;
X
X /* it can be +1 or -1 off!!! */
X if (numcomp(v, t1 = tento_d(x)) >= 0) /* one too low */
X ++x;
X else if (numcomp(v, t2 = tento_d(x-1)) < 0) /* one too high */
X --x;
X
X release(t1); release(t2);
X release(v);
X
X if (x > Maxint)
X return Maxint;
X else if (x < -Maxint)
X return -Maxint;
X else
X return (int) x;
X}
X
X/* Convert a numeric value to a C character string.
X * The character string is released on each next call.
X *
X * prod10n() is a routine with does a fast multiplication with a ten power
X * and does not normalize a rational result sometimes.
X */
X
XVisible string convnum(v) register value v; {
X value r, re, rre;
X int rndsize= 0;
X int num;
X int ndigits;
X int precision= MAXDIGITS;
X register string txt;
X int txtlen;
X static char *numbuf;
X register char *str;
X bool remainder;
X bool rndflag;
X int buflen= MAXNUMSIZE;
X
X if (Integral(v)) return convint((integer)v);
X
X /* Aproximates and rationale are treated alike,
X * using MAXDIGITS precision, and e-notation when
X * necessary.
X * However, rationals resulting from 'n round x' are
X * transformed to f-format, printing n=Roundsize digits
X * after the decimal point. */
X
X if (Rational(v) && Roundsize(v) > 0)
X rndsize= Roundsize(v);
X
X r= Approximate(v) ? exactly(v) : copy(v);
X
X if ((num=numcomp(r, zero)) == 0 && rndsize == 0) {
X release(r);
X return "0";
X }
X else if (num < 0) {
X r= negated(v= r);
X release(v);
X }
X
X ndigits= digits_in(r);
X rndflag= rndsize > 0 && (rndsize > precision - ndigits || num == 0);
X
X re= prod10n(r, rndflag ? rndsize : precision - ndigits, No);
X rre= round1(re);
X txt= convint((integer) rre);
X txtlen= strlen(txt);
X
X if (rndflag) {
X ndigits= txtlen - rndsize;
X precision= (ndigits > 0 ? txtlen : rndsize);
X remainder= No;
X }
X else {
X if (txtlen > precision) {
X /* rounding caused extra digit, e.g. 999.9 ->1000 */
X txtlen--;
X txt[txtlen]= '\0';
X ndigits++;
X }
X remainder= (numcomp(re, rre) != 0);
X if (!remainder) {
X /* delete trailing zero's after decimal point */
X int headlen= ndigits + rndsize;
X int minlen= headlen;
X
X if (headlen <= 0 || headlen > precision)
X minlen= 1;
X while (txtlen > minlen && txt[txtlen-1] == '0') {
X txtlen--;
X }
X txt[txtlen]= '\0';
X if (rndsize > 0 && txtlen == headlen)
X rndflag= Yes;
X }
X }
X
X release(r); release(re); release(rre);
X
X /* now copy to buffer */
X if (numbuf) freemem(numbuf);
X if (rndflag)
X buflen= txtlen + (ndigits < 0 ? -ndigits : ndigits) + 10;
X
X numbuf= getmem((unsigned) buflen);
X
X str= numbuf;
X if (num<0) *str++= '-';
X
X if (ndigits > precision || (ndigits == precision && remainder)) {
X *str++= *txt++;
X if (txtlen > 1) {
X *str++= '.';
X while (*txt) *str++ = *txt++;
X }
X sprintf(str, "e+%d", ndigits-1);
X }
X else if (ndigits == precision && !remainder) {
X while (*txt) *str++ = *txt++;
X *str= '\0';
X }
X else if (ndigits > 0) {
X /* we end up here too for rndflag == Yes, r > 1 */
X while (ndigits-- > 0) *str++ = *txt++;
X if (*txt) *str++= '.';
X while (*txt) *str++ = *txt++;
X *str= '\0';
X }
X else if (ndigits >= -3 || rndflag) {
X /* 3 is about size of exponent,
X * therefore allow upto 3 0's after decimal point
X * giving 0.000ddddd instead
X * of 0.ddddde-3 notation below;
X *
X * also handle rndflag == Yes, 1>r>0 here
X */
X
X *str++= '0'; *str++= '.';
X while (ndigits++ < 0) *str++= '0';
X while (*txt) *str++ = *txt++;
X *str= '\0';
X }
X else {
X *str++= '0'; *str++= '.';
X while (*txt) *str++ = *txt++;
X sprintf(str, "e%d", ndigits); /* ndigits < 0, %d gives -nnn */
X }
X
X return numbuf;
X}
X
X#define E_EXACT ABC
X
X/* Convert a text to a number (assume it's syntactically correct!).
X Again, BASE must be a power of 10.
X ********** NEW **********
X If E_EXACT is undefined, numbers in e-notation are made
X approximate.
X*/
X
XVisible value numconst(v) register value v; {
X string txt, txt0;
X register string tp;
X register int numdigs, fraclen;
X integer a;
X register digit accu;
X value c;
X
X txt= sstrval(v);
X if (*txt == 'e') a = int_1;
X else {
X txt0= txt;
X while (*txt0 && *txt0=='0') ++txt0; /* Skip leading zeros */
X
X for (tp = txt0; isdigit(*tp); ++tp)
X ; /* Count integral digits */
X numdigs = tp-txt0;
X fraclen = 0;
X if (*tp=='.') {
X ++tp;
X for (; isdigit(*tp); ++tp)
X ++fraclen; /* Count fractional digits */
X numdigs += fraclen;
X }
X a = (integer) grab_num((numdigs+tenlogBASE-1) / tenlogBASE);
X if (!a) goto recover;
X accu = 0;
X /* Integer part: */
X for (tp = txt0; isdigit(*tp); ++tp) {
X accu = accu*10 + *tp - '0';
X --numdigs;
X if (numdigs%tenlogBASE == 0) {
X Digit(a, numdigs/tenlogBASE) = accu;
X accu = 0;
X }
X }
X /* Fraction: */
X if (*tp == '.') {
X ++tp;
X for (; isdigit(*tp); ++tp) {
X accu = accu*10 + *tp - '0';
X --numdigs;
X if (numdigs%tenlogBASE == 0) {
X Digit(a, numdigs/tenlogBASE) = accu;
X accu = 0;
X }
X }
X }
X if (numdigs != 0) syserr(MESS(800, "numconst: can't happen"));
X a = int_canon(a);
X }
X
X /* Exponent: */
X if (*tp != 'e') {
X integer b = int_tento(fraclen);
X if (!b) {
X /* Can't happen now; for robustness */
X Release(a);
X goto recover;
X }
X c = mk_exact(a, b, fraclen);
X Release(b);
X }
X else {
X double expo = 0;
X int sign = 1;
X value b;
X ++tp;
X if (*tp == '+') ++tp;
X else if (*tp == '-') {
X ++tp;
X sign = -1;
X }
X for (; isdigit(*tp); ++tp) {
X expo = expo*10 + *tp - '0';
X if (expo > Maxint) {
X interr(MESS(801, "excessive exponent in e-notation"));
X expo = 0;
X break;
X }
X }
X b = tento((int)expo * sign - fraclen);
X if (!b) {
X Release(a);
X goto recover;
X }
X#ifndef E_EXACT
X /* Make approximate number if e-notation used */
X c = approximate(b);
X Release(b);
X b = c;
X#endif
X if (a == int_1) c = b;
X else c = prod((value)a, b), Release(b);
X }
X Release(a);
X fstrval(txt);
X return c;
X
Xrecover:
X /* from failure of grab_num, also indirect (int_tento);
X an error has already been reported */
X fstrval(txt);
X return Vnil;
X}
X
X
X/*
X * printnum(f, v) writes a number v on file f in such a way that it
X * can be read back identically.
X */
X
XVisible Procedure printnum(fp, v) FILE *fp; value v; {
X if (Approximate(v)) {
X app_print(fp, (real) v);
X return;
X }
X if (Rational(v) && Denominator((rational)v) != int_1) {
X int i = Roundsize(v);
X fputs(convnum((value)Numerator((rational)v)), fp);
X if (i > 0) {
X /* The assumption here is that in u/v, the Roundsize
X of the result is the sum of that of the operands. */
X putc('.', fp);
X do putc('0', fp); while (--i > 0);
X }
X putc('/', fp);
X v = (value) Denominator((rational)v);
X }
X fputs(convnum(v), fp);
X}
END_OF_FILE
if test 8704 -ne `wc -c <'abc/bint1/i1nuc.c'`; then
echo shar: \"'abc/bint1/i1nuc.c'\" unpacked with wrong size!
fi
# end of 'abc/bint1/i1nuc.c'
fi
if test -f 'abc/bint2/i2ana.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint2/i2ana.c'\"
else
echo shar: Extracting \"'abc/bint2/i2ana.c'\" \(8705 characters\)
sed "s/^X//" >'abc/bint2/i2ana.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Prepare for code generation -- find out which tags are targets */
X
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i0err.h"
X#include "i2nod.h"
X#include "i2gen.h" /* Must be after i2nod.h */
X#include "i3env.h"
X#include "i3sou.h"
X
X
XVisible int nextvarnumber; /* Counts local targets (including formals) */
XHidden int nformals; /* nr of formals */
XHidden bool bound; /* flag to recognise bound tags */
X
XVisible value locals, globals, mysteries, refinements;
X
X
XVisible value *setup(t) parsetree t; {
X typenode n= Nodetype(t);
X bool in_prmnv= !Unit(n);
X nextvarnumber= 0;
X mysteries= mk_elt();
X if (in_prmnv) {
X globals= copy(prmnv->tab);
X locals= Vnil;
X refinements= mk_elt();
X return Command(n) ? &globals : Pnil;
X } else {
X globals= mk_elt();
X locals= mk_elt();
X refinements= *Branch(t, n == HOW_TO ? HOW_R_NAMES : FPR_R_NAMES);
X VOID copy(refinements);
X unit_context(t);
X return &locals;
X }
X}
X
XHidden Procedure unit_context(t) parsetree t; {
X cntxt= In_unit;
X release(uname); uname= get_pname(t);
X}
X
XVisible Procedure cleanup() {
X release(locals);
X release(globals);
X release(mysteries);
X release(refinements);
X}
X
X/* ******************************************************************** */
X
X/* Analyze parse tree, finding the targets and formal parameters.
X Formal parameters are found in the heading and stored as local targets.
X Global targets are also easily found: they are mentioned in a SHARE command.
X Local targets appear on their own or in collateral forms after PUT IN
X or as bound tags after FOR, SOME, EACH or NO.
X Note that DELETE x, REMOVE e FROM x, or PUT e IN x[k] (etc.) don't
X introduce local targets, because in all these cases x must have been
X initialized first. This speeds up our task of finding targets,
X since we don't have to visit all nodes: only nodes that may contain
X commands or tests, and the positions mentioned here, need be visited.
X (And of course unit headings).
X We don't have to look for refinements since these are already known
X from the unit heading.
X */
X
XHidden Procedure a_tag(name, targs) value name; value *targs; {
X value *aa; int varnumber;
X if (locals != Vnil && envassoc(locals, name) != Pnil);
X else if (envassoc(globals, name) != Pnil);
X else if (envassoc(refinements, name) != Pnil) {
X if (targs != &mysteries)
X fixerr(REF_NO_TARGET);
X }
X else {
X aa= envassoc(mysteries, name);
X if (aa != Pnil && targs == &mysteries);
X else {
X if (aa != Pnil) {
X varnumber= SmallIntVal(*aa);
X e_delete(&mysteries, name);
X }
X else if (targs != &globals)
X varnumber= nextvarnumber++;
X else varnumber= 0;
X e_replace(MkSmallInt(varnumber), targs, name);
X }
X }
X if (bound && locals != Vnil) {
X aa= envassoc(locals, name);
X if (aa == Pnil || SmallIntVal(*aa) < nformals)
X fixerr(MESS(4400, "in ... i IN e, i contains a non-local name"));
X }
X}
X
XHidden Procedure a_fpr_formals(t) parsetree t; {
X typenode n= nodetype(t);
X switch (n) {
X case TAG:
X break;
X case MONF: case MONPRD:
X analyze(*Branch(t, MON_RIGHT), &locals);
X break;
X case DYAF: case DYAPRD:
X analyze(*Branch(t, DYA_LEFT), &locals);
X analyze(*Branch(t, DYA_RIGHT), &locals);
X break;
X default: syserr(MESS(1900, "a_fpr_formals"));
X }
X}
X
XVisible Procedure analyze(t, targs) parsetree t; value *targs; {
X typenode nt; string s; char c; int n, k, len; value v;
X if (!Is_node(t) || !still_ok) return;
X nt= Nodetype(t);
X if (nt < 0 || nt >= NTYPES) syserr(MESS(1901, "analyze bad tree"));
X s= gentab[nt];
X if (s == NULL) return;
X n= First_fieldnr;
X while ((c= *s++) != '\0' && still_ok) {
X switch (c) {
X case '0':
X case '1':
X case '2':
X case '3':
X case '4':
X case '5':
X case '6':
X case '7':
X case '8':
X case '9':
X n= (c - '0') + First_fieldnr;
X break;
X case 'c':
X v= *Branch(t, n);
X if (v != Vnil) {
X len= Nfields(v);
X for (k= 0; k < len; ++k)
X analyze(*Field(v, k), targs);
X }
X ++n;
X break;
X case '#':
X curlino= *Branch(t, n);
X /* Fall through */
X case 'l':
X case 'v':
X ++n;
X break;
X case 'm':
X analyze(*Branch(t, n), &mysteries);
X ++n;
X break;
X case 'g':
X analyze(*Branch(t, n), &globals);
X ++n;
X break;
X case 'b':
X bound= Yes;
X analyze(*Branch(t, n),
X locals != Vnil ? &locals : &globals);
X bound= No;
X ++n;
X break;
X case 'x':
X curline= *Branch(t, n);
X /* Fall through */
X case 'a':
X case 'u':
X analyze(*Branch(t, n), targs);
X ++n;
X break;
X case 't':
X analyze(*Branch(t, n), Pnil);
X ++n;
X break;
X case 'f':
X a_fpr_formals(*Branch(t, n));
X nformals= nextvarnumber;
X ++n;
X break;
X case 'h':
X v= *Branch(t, n);
X analyze(v, &locals);
X nformals= nextvarnumber;
X ++n;
X break;
X case '=':
X *Branch(t, n)= MkSmallInt(nextvarnumber);
X ++n;
X break;
X case ':': /* code for WHILE loop */
X curlino= *Branch(t, WHL_LINO);
X analyze(*Branch(t, WHL_TEST), Pnil);
X v= *Branch(t, WHL_SUITE);
X if (nodetype((parsetree) v) != COLON_NODE)
X syserr(BAD_WHILE);
X analyze(*Branch(v, COLON_SUITE), targs);
X break;
X case ';': /* code for TEST_SUITE */
X curlino= *Branch(t, TSUI_LINO);
X curline= *Branch(t, TSUI_TEST);
X analyze(curline, Pnil);
X v= *Branch(t, TSUI_SUITE);
X if (nodetype((parsetree) v) != COLON_NODE)
X syserr(BAD_TESTSUITE);
X analyze(*Branch(v, COLON_SUITE), targs);
X analyze(*Branch(t, TSUI_NEXT), targs);
X break;
X case 'T':
X if (targs != Pnil)
X a_tag((value)*Branch(t, TAG_NAME), targs);
X break;
X }
X }
X}
X
X/* ******************************************************************** */
X
X/* Table describing the actions of the fixer for each node type */
X
X
X/*
X LIST OF CODES AND THEIR MEANING
X
X char fix n? analyze
X
X 0-9 n= c-'0'
X
X # set curlino ++n set curlino
X = ++n set to nextvarnum
X a locate ++n analyze
X b locate ++n analyze bound tags
X c collateral ++n analyze collateral
X f fpr_formals ++n a_fpr_formals
X g ++n global
X h ++n how'to formal
X l locate ++n
X m actual param ++n mystery
X t test ++n analyze; set targs= 0
X u unit ++n analyze
X v evaluate ++n
X x execute ++n analyze
X
X : special code for WHILE loop
X ; special code for TEST_SUITE
X ? special code for UNPARSED
X @ special check for BEHEAD target
X | special check for CURTAIL target
X C special code for comparison
X D special code for DYAF
X E special code for DYAPRD
X F make number
X G jumpto(l1)
X H here(&l1)
X I if (*Branch(t, n) != NilTree) jump2here(t)
X J jump2here(t)
X K hold(&st)
X L let_go(&st)
X M special code for MONF
X N special code for MONPRD
X Q if (*Branch(t, n) != NilTree) visit(t);
X R if (!reachable()) "command cannot be reached"
X S jumpto(Stop)
X T special code for TAG
X U special code for user-defined-command
X V visit(t)
X W visit2(t, seterr(1))
X X visit(t) or lvisit(t) depending on flag
X Y special code for YIELD/TEST
X Z special code for refinement
X
X*/
X
X
XVisible string gentab[NTYPES]= {
X
X /* HOW_TO */ "1h3xSu6=",
X /* YIELD */ "2fV4xYu7=",
X /* TEST */ "2fV4xYu7=",
X /* REFINEMENT */ "H2xZSu",
X
X /* Commands */
X
X /* SUITE */ "#RQx3x",
X /* PUT */ "vaV",
X /* INSERT */ "vlV",
X /* REMOVE */ "vlV",
X /* SET_RANDOM */ "vV",
X /* DELETE */ "lV",
X /* CHECK */ "tV",
X /* SHARE */ "g",
X /* PASS */ "",
X
X /* WRITE */ "1vV",
X /* WRITE1 */ "1vV",
X /* READ */ "avV",
X /* READ_RAW */ "aV",
X
X /* IF */ "tV2xJ",
X /* WHILE */ ":", /* old: "HtV2xGJ" */
X /* FOR */ "bvHV3xGJ",
X
X /* SELECT */ "1x",
X /* TEST_SUITE */ ";", /* old: "#tW3xKIxL" */
X /* ELSE */ "#2x",
X
X /* QUIT */ "VS",
X /* RETURN */ "vVS",
X /* REPORT */ "tVS",
X /* SUCCEED */ "VS",
X /* FAIL */ "VS",
X
X /* USER_COMMAND */ "1mUV",
X /* EXTENDED_COMMAND */ "1cV",
X
X /* Expressions, targets, tests */
X
X /* TAG */ "T",
X /* COMPOUND */ "a",
X
X /* Expressions, targets */
X
X /* COLLATERAL */ "cX",
X /* SELECTION */ "lvX",
X /* BEHEAD */ "lv at X",
X /* CURTAIL */ "lv|X",
X
X /* Expressions, tests */
X
X /* UNPARSED */ "?",
X
X /* Expressions */
X
X /* MONF */ "M1vV",
X /* DYAF */ "Dv2vV",
X /* NUMBER */ "FV",
X /* TEXT_DIS */ "1v",
X /* TEXT_LIT */ "1vV",
X /* TEXT_CONV */ "vvV",
X /* ELT_DIS */ "V",
X /* LIST_DIS */ "cV",
X /* RANGE_ELEM */ "vvV",
X /* TAB_DIS */ "cV",
X
X /* Tests */
X
X /* AND */ "tVtJ",
X /* OR */ "tVtJ",
X /* NOT */ "tV",
X /* SOME_IN */ "bvHVtGJ",
X /* EACH_IN */ "bvHVtGJ",
X /* NO_IN */ "bvHVtGJ",
X /* MONPRD */ "N1vV",
X /* DYAPRD */ "Ev2vV",
X /* LESS_THAN */ "vvCV",
X /* AT_MOST */ "vvCV",
X /* GREATER_THAN */ "vvCV",
X /* AT_LEAST */ "vvCV",
X /* EQUAL */ "vvCV",
X /* UNEQUAL */ "vvCV",
X /* Nonode */ "",
X
X /* TAGformal */ "T",
X /* TAGlocal */ "T",
X /* TAGglobal */ "T",
X /* TAGrefinement */ "T",
X /* TAGzerfun */ "T",
X /* TAGzerprd */ "T",
X
X /* ACTUAL */ "1mm",
X /* FORMAL */ "1hh",
X
X#ifdef GFX
X /* SPACE */ "vvV",
X /* LINE */ "vvV",
X /* CLEAR */ "V",
X#endif
X
X /* COLON_NODE */ ""
X};
END_OF_FILE
if test 8705 -ne `wc -c <'abc/bint2/i2ana.c'`; then
echo shar: \"'abc/bint2/i2ana.c'\" unpacked with wrong size!
fi
# end of 'abc/bint2/i2ana.c'
fi
if test -f 'abc/bint3/i3err.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/bint3/i3err.c'\"
else
echo shar: Extracting \"'abc/bint3/i3err.c'\" \(8453 characters\)
sed "s/^X//" >'abc/bint3/i3err.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* B error message handling */
X
X/* There are two kinds of errors:
X 1) parsing, when the line in error is in a buffer
X 2) execution, when the line in error is a parse-tree, and must
X therefore be reconstructed.
X*/
X
X#include "b.h"
X#include "bmem.h"
X#include "bint.h"
X#include "feat.h"
X#include "bobj.h"
X#include "i0err.h"
X#include "i2par.h"
X#include "i3env.h"
X#include "i3scr.h"
X#include "i3sou.h"
X
X#ifdef GFX
X#include "bgfx.h"
X#endif
X
XVisible bool still_ok= Yes;
XVisible bool mess_ok= Yes; /* if Yes print error message */
XVisible bool interrupted= No;
XVisible bool can_interrupt= Yes;
X
XVisible parsetree curline= Vnil;
XVisible value curlino;
X
XVisible FILE *errfile= stderr; /* may be changed in initerr() */
X
X/*********************************************************************/
X
XHidden Procedure nline() {
X fflush(stdout); /* should be i3scr.c's ofile, but doesnot matter */
X if (cntxt == In_read && rd_interactive)
X at_nwl= Yes;
X if (!at_nwl)
X putnewline(errfile);
X at_nwl= Yes;
X}
X
XVisible intlet errlino= 0;
X
XHidden intlet pr_line(at) bool at; {
X /*prints the line that tx is in, with an arrow pointing to the column
X that tx is at.
X */
X txptr lx= fcol(); intlet ap= -1, p= 0; char c;
X txptr ax= tx;
X
X if (!at) do ax--; while (Space(Char(ax)));
X while (!Eol(lx) && Char(lx) != Eotc) {
X if (lx == ax) ap= p;
X c= *lx++;
X if (c == '\t') {
X do { putchr(errfile, ' '); } while (((++p)%4)!=0);
X } else { putchr(errfile, c); p++; }
X }
X putnewline(errfile);
X if (ap < 0) ap= p;
X for (p= 0; p < ap+4; p++) putchr(errfile, ' ');
X putstr(errfile, "^\n");
X}
X
X#define IN_COMMAND MESS(3100, " in your command\n")
X#define IN_READ MESS(3101, " in your expression to be read\n")
X#define IN_EDVAL MESS(3102, " in your edited value\n")
X#define IN_TARVAL MESS(3103, " in your location %s\n")
X#define IN_PRMNV MESS(3104, " in your permanent environment\n")
X#define IN_WSGROUP MESS(3105, " in your workspace index\n")
X#define IN_UNIT MESS(3106, " in your how-to %s\n")
X#define IN_UNIT_LINE MESS(3107, " in line %d of your how-to %s\n")
X#define IN_INPUT MESS(3108, "*** (detected after reading 1 line of your input file standard input)\n")
X#define IN_INPUT_LINE MESS(3109, "*** (detected after reading %d lines of your input file standard input)\n")
X#define IN_FILE MESS(3110, "*** (detected after reading 1 line of your input file %s)\n")
X#define IN_FILE_LINE MESS(3111, "*** (detected after reading %d lines of your input file %s)\n")
X
XHidden Procedure show_where(in_node, at, node)
X bool in_node, at; parsetree node; {
X
X int line_no= in_node ? intval(curlino) : lino;
X show_line(in_node, at, node, line_no);
X if (!interactive && ifile == sv_ifile && !unit_file())
X show_f_line();
X}
X
XHidden Procedure show_line(in_node, at, node, line_no)
X bool in_node, at; parsetree node; int line_no; {
X
X switch (cntxt) {
X case In_command: putmess(errfile, IN_COMMAND); break;
X case In_read: putmess(errfile, IN_READ); break;
X case In_edval: putmess(errfile, IN_EDVAL); break;
X case In_tarval:
X putSmess(errfile, IN_TARVAL, strval(errtname));
X break;
X case In_prmnv: putmess(errfile, IN_PRMNV); break;
X case In_wsgroup: putmess(errfile, IN_WSGROUP); break;
X case In_unit: show_howto(line_no); break;
X default:
X putstr(errfile, "???\n");
X return;
X }
X if (!in_node || Valid(node)) putstr(errfile, " ");
X if (in_node) display(errfile, node, Yes);
X else pr_line(at);
X}
X
XHidden value unitname(line_no) int line_no; {
X if (Valid(uname) && Is_text(uname)) {
X def_perm(last_unit, uname);
X errlino= line_no;
X return Permname(uname);
X }
X else free_perm(last_unit);
X return mk_text("");
X}
X
XHidden Procedure show_howto(line_no) int line_no; {
X value name= unitname(line_no);
X if (line_no == 1)
X putSmess(errfile, IN_UNIT, strval(name));
X else
X putDSmess(errfile, IN_UNIT_LINE, line_no, strval(name));
X release(name);
X}
X
XHidden bool unit_file() {
X value *aa;
X return cntxt == In_unit &&
X Valid(uname) && Is_text(uname) && p_exists(uname, &aa);
X}
X
XHidden Procedure show_f_line() {
X if (f_lino == 1 && iname == Vnil)
X putmess(errfile, IN_INPUT);
X else if (f_lino == 1)
X putSmess(errfile, IN_FILE, strval(iname));
X else if (iname == Vnil)
X putDSmess(errfile, IN_INPUT_LINE, f_lino, "");
X else
X putDSmess(errfile, IN_FILE_LINE, f_lino, strval(iname));
X if (iname != Vnil && i_lino > 0) {
X if (i_lino == 1)
X putmess(errfile, IN_INPUT);
X else
X putDSmess(errfile, IN_INPUT_LINE, i_lino, "");
X }
X}
X
X#define PROBLEM MESS(3112, "*** The problem is:")
X
XVisible Procedure syserr(m) int m; {
X static bool beenhere= No;
X if (beenhere) immexit(-1);
X beenhere= Yes;
X nline();
X#ifdef DEBUG
X#ifdef macintosh
X Debugger();
X#endif
X#endif
X putmess(errfile, MESS(3113, "*** Sorry, ABC system malfunction\n"));
X putmess(errfile, PROBLEM);
X putstr(errfile, " ");
X putmess(errfile, m);
X putnewline(errfile);
X bye(-1);
X}
X
X#ifndef macintosh
X /* MacABC uses an alert to make sure the user gets the message */
X
XVisible Procedure memexh() {
X static bool beenhere= No;
X if (beenhere) immexit(-1);
X beenhere= Yes;
X nline();
X putmess(errfile, MESS(3114, "*** Sorry, memory exhausted"));
X/* show_where(Yes, Yes); don't know if in node or not; to fix */
X putnewline(errfile);
X bye(-1);
X}
X
X#endif /*macintosh*/
X
XHidden Procedure message(m1, m2, in_node, at, arg)
X int m1, m2;
X bool in_node, at;
X value arg;
X{
X still_ok= No;
X if (!mess_ok)
X return;
X nline();
X putmess(errfile, m1);
X show_where(in_node, at, curline);
X putmess(errfile, PROBLEM);
X putstr(errfile, " ");
X putSmess(errfile, m2, Valid(arg) ? strval(arg) : "");
X putnewline(errfile);
X fflush(errfile);
X at_nwl=Yes;
X}
X
X#define UNDERSTAND MESS(3115, "*** There's something I don't understand")
X
X#define RESOLVE MESS(3116, "*** There's something I can't resolve")
X
X#define COPE MESS(3117, "*** Can't cope with problem")
X
X#define RECONCILE MESS(3118, "*** Cannot reconcile the types")
X
XVisible Procedure pprerrV(m, v) int m; value v; {
X if (still_ok)
X message(UNDERSTAND, m, No, No, v);
X}
X
XVisible Procedure pprerr(m) int m; {
X if (still_ok)
X message(UNDERSTAND, m, No, No, Vnil);
X}
X
XVisible Procedure parerrV(m, v) int m; value v; {
X if (still_ok)
X message(UNDERSTAND, m, No, Yes, v);
X}
X
XVisible Procedure parerr(m) int m; {
X if (still_ok)
X message(UNDERSTAND, m, No, Yes, Vnil);
X}
X
XVisible Procedure fixerrV(m, v) int m; value v; {
X if (still_ok)
X message(RESOLVE, m, Yes, Yes, v);
X}
X
XVisible Procedure fixerr(m) int m; {
X if (still_ok)
X message(RESOLVE, m, Yes, Yes, Vnil);
X}
X
XVisible Procedure typerrV(m, v) int m; value v; {
X if (still_ok)
X message(RECONCILE, m, Yes, Yes, v);
X}
X
XVisible Procedure interrV(m, v) int m; value v; {
X if (still_ok)
X message(COPE, m, Yes, No, v);
X}
X
XVisible Procedure interr(m) int m; {
X if (still_ok)
X message(COPE, m, Yes, No, Vnil);
X}
X
XVisible Procedure checkerr() {
X still_ok= No;
X nline();
X putmess(errfile, MESS(3119, "*** Your check failed"));
X show_where(Yes, No, curline);
X fflush(errfile);
X at_nwl= Yes;
X}
X
XVisible Procedure int_signal() {
X if (can_interrupt) {
X interrupted= Yes; still_ok= No;
X if (cntxt == In_wsgroup || cntxt == In_prmnv)
X immexit(-1);
X }
X if (!interactive) {
X if (ifile != stdin) fclose(ifile);
X bye(1);
X }
X nline();
X putmess(errfile, MESS(3120, "*** interrupted\n"));
X fflush(errfile);
X if (can_interrupt) {
X if (cntxt == In_read) {
X set_context(&read_context);
X copy(uname);
X }
X }
X at_nwl= Yes;
X}
X
XVisible bool testing= No;
X
XVisible Procedure bye(ex) int ex; {
X#ifdef GFX
X if (gfx_mode != TEXT_MODE)
X exit_gfx();
X#endif
X at_nwl= Yes;
X/* putperm(); */ /* shall be called via endall() */
X endall();
X immexit(ex);
X}
X
Xextern bool in_vtrm;
X
XVisible Procedure immexit(status) int status; {
X if (in_vtrm)
X endterm();
X exit(status);
X}
X
XVisible Procedure initerr() {
X still_ok= Yes; interrupted= No; curline= Vnil; curlino= zero;
X#ifdef TTY_ERRFILE
X /* The idea of the following is, that we cannot use stderr
X * for "abc cmd.file >out 2>err", since errors for READ
X * commands must be visible for the user (who is entering
X * them interactively, as reported in rd_interactive).
X * The current solution is unix dependent; but stderr redirection
X * seems impossible on non-unix anyway.
X * When the first such system shows up it might be necessary
X * to change all fprintf(errfile,...)'s to prerr's that print
X * to the proper device (console or stderr file).
X */
X if (rd_interactive && (errfile= fopen("/dev/tty", "w")) == NULL)
X errfile= stderr;
X#endif
X}
X
END_OF_FILE
if test 8453 -ne `wc -c <'abc/bint3/i3err.c'`; then
echo shar: \"'abc/bint3/i3err.c'\" unpacked with wrong size!
fi
# end of 'abc/bint3/i3err.c'
fi
if test -f 'abc/doc/abcintro.doc' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/doc/abcintro.doc'\"
else
echo shar: Extracting \"'abc/doc/abcintro.doc'\" \(8974 characters\)
sed "s/^X//" >'abc/doc/abcintro.doc' <<'END_OF_FILE'
XA SHORT INTRODUCTION TO THE ABC LANGUAGE
X
XThis article gives a quick overview of the programming language ABC
Xand its implementations, and gives a few examples of ABC programs.
XFull documentation about ABC is in the ABC Programmer's Handbook
X(details below).
X
XTHE LANGUAGE
XABC is an imperative language originally designed as a replacement for
XBASIC: interactive, very easy to learn, but structured, high-level,
Xand easy to use. ABC has been designed iteratively, and the present
Xversion is the 4th iteration. The previous versions were called B (not
Xto be confused with the predecessor of C).
X
XIt is suitable for general everyday programming, the sort of
Xprogramming that you would use BASIC, Pascal, or AWK for. It is not a
Xsystems-programming language. It is an excellent teaching language,
Xand because it is interactive, excellent for prototyping. It is much
Xfaster than Unix 'bc' for doing quick calculations.
X
XABC programs are typically very compact, around a quarter to a fifth
Xthe size of the equivalent Pascal or C program. However, this is not
Xat the cost of readability, on the contrary in fact (see the examples
Xbelow).
X
XABC is simple to learn due to the small number of types in the
Xlanguage (five). If you already know Pascal or something similar you
Xcan learn the whole language in an hour or so. It is easy to use
Xbecause the data-types are very high-level.
X
XThe five types are:
X numbers: unbounded length, with exact arithmetic the rule
X texts (strings): also unbounded length
X compounds: records without field names
X lists: sorted collections of any one type of items (bags or multi-sets)
X tables: generalised arrays with any one type of keys, any one type
X of items (finite mappings).
X
XTHE ENVIRONMENT
XThe implementation includes a programming environment that makes
Xproducing programs very much easier, since it knows a lot about the
Xlanguage, and can therefore do much of the work for you. For instance,
Xif you type a W, the system suggests a command completion for you:
X W?RITE ?
X
XIf that is what you want, you press [tab], and carry on typing the
Xexpression; if you wanted WHILE, you type an H, and the system changes
Xthe suggestion to match:
X WH?ILE ?:
X
XThis mechanism works for commands you define yourself too. Similarly,
Xif you type an open bracket or quote, you get the closing bracket or
Xquote for free. You can ignore the suggestions if you want, and just
Xtype the commands full out.
X
XThere is support for workspaces for developing different programs.
XWithin each workspace variables are persistent, so that if you stop
Xusing ABC and come back later, your variables are still there as you
Xleft them. This obviates the need for file-handling facilities: there
Xis no conceptual difference between a variable and a file in ABC.
X
XThe language is strongly-typed, but without declarations. Types are
Xdetermined from context.
X
XEXAMPLES
XThe (second) best way to appreciate the power of ABC is to see some
Xexamples (the first is to use it). In what follows, >>> is the
Xprompt from ABC:
X
XNUMBERS
X >>> WRITE 2**1000
X 107150860718626732094842504906000181056140481170553360744375038837
X 035105112493612249319837881569585812759467291755314682518714528569
X 231404359845775746985748039345677748242309854210746050623711418779
X 541821530464749835819412673987675591655439460770629145711964776865
X 42167660429831652624386837205668069376
X
X >>> PUT 1/(2**1000) IN x
X >>> WRITE 1 + 1/x
X 107150860718626732094842504906000181056140481170553360744375038837
X 035105112493612249319837881569585812759467291755314682518714528569
X 231404359845775746985748039345677748242309854210746050623711418779
X 541821530464749835819412673987675591655439460770629145711964776865
X 42167660429831652624386837205668069377
X
XTEXTS
X >>> PUT ("ha " ^^ 3) ^ ("ho " ^^ 3) IN laugh
X >>> WRITE laugh
X ha ha ha ho ho ho
X
X >>> WRITE #laugh
X 18
X
X >>> PUT "Hello! "^^1000 IN greeting
X >>> WRITE #greeting
X 7000
X
XLISTS
X >>> WRITE {1..10}
X {1; 2; 3; 4; 5; 6; 7; 8; 9; 10}
X >>> PUT {1..10} IN l
X >>> REMOVE 5 FROM l
X >>> INSERT 4 IN l
X >>> INSERT pi IN l
X >>> WRITE l
X {1; 2; 3; 3.141592653589793; 4; 4; 6; 7; 8; 9; 10}
X
X >>> PUT {} IN ll
X >>> FOR i IN {1..3}:
X INSERT {1..i} IN ll
X >>> WRITE ll
X {{1}; {1; 2}; {1; 2; 3}}
X >>> FOR l IN ll:
X WRITE l /
X {1}
X {1; 2}
X {1; 2; 3}
X >>> WRITE #ll
X 3
X
XCOMPOUNDS
X >>> PUT ("Square root of 2", root 2) IN c
X >>> WRITE c
X ("Square root of 2", 1.414213562373095)
X >>> PUT c IN name, value
X >>> WRITE name
X Square root of 2
X >>> WRITE value
X 1.414213562373095
X
XA TELEPHONE LIST
XThis uses the table data-type. In use, tables resemble arrays:
X
X >>> PUT {} IN tel
X >>> PUT 4054 IN tel["Jennifer"]
X >>> PUT 4098 IN tel["Timo"]
X >>> PUT 4134 IN tel["Guido"]
X
X >>> WRITE tel["Jennifer"]
X 4054
X
XYou can write all ABC values out. Tables are kept sorted on the keys:
X >>> WRITE tel
X {["Guido"]: 4134; ["Jennifer"]: 4054; ["Timo"]: 4098}
X
XThe keys function returns a list:
X >>> WRITE keys tel
X {"Guido"; "Jennifer"; "Timo"}
X
X >>> FOR name IN keys tel:
X WRITE name, ":", tel[name] /
X Guido: 4134
X Jennifer: 4054
X Timo: 4098
X
XYou can define your own commands:
X
X HOW TO DISPLAY t:
X FOR name IN keys t:
X WRITE name<<10, t[name] /
X
X >>> DISPLAY tel
X Guido 4134
X Jennifer 4054
X Timo 4098
X
XTo find the user of a given number, you can use a quantifier:
X >>> IF SOME name IN keys tel HAS tel[name] = 4054:
X WRITE name
X Jennifer
X
XOr create the inverse table:
X >>> PUT {} IN subscriber
X >>> FOR name IN keys tel:
X PUT name IN subscriber[tel[name]]
X
X >>> WRITE subscriber[4054]
X Jennifer
X
X >>> WRITE subscriber
X {[4054]: "Jennifer"; [4098]: "Timo"; [4134]: "Guido"}
X
XCommands and functions are polymorphic:
X >>> DISPLAY subscriber
X 4054 Jennifer
X 4098 Timo
X 4134 Guido
X
XFunctions may return any type. Note that indentation is significant -
Xthere are no BEGIN-END's or { }'s:
X
X HOW TO RETURN inverse t:
X PUT {} IN inv
X FOR k IN keys t:
X PUT k IN inv[t[k]]
X RETURN inv
X
X >>> WRITE inverse tel
X {[4054]: "Jennifer"; [4098]: "Timo"; [4134]: "Guido"}
X
X >>> DISPLAY inverse inverse tel
X Guido 4134
X Jennifer 4054
X Timo 4098
X
XA CROSS-REFERENCE INDEXER
X
X'Text files' are represented as tables of numbers to strings:
X
X >>> DISPLAY poem
X 1 I've never seen a purple cow
X 2 I hope I never see one
X 3 But I can tell you anyhow
X 4 I'd rather see than be one
X
XThe following function takes such a document, and returns the
Xcross-reference index of the document: a table from words to lists of
Xline-numbers:
X
X HOW TO RETURN index doc:
X PUT {} IN where
X FOR line.no IN keys doc:
X TREAT LINE
X RETURN where
X TREAT LINE:
X FOR word IN split doc[line.no]:
X IF word not.in keys where:
X PUT {} IN where[word]
X INSERT line.no IN where[word]
X
XTREAT LINE here is a refinement, directly supporting
Xstepwise-refinement. 'split' is a function that splits a string into
Xits space-separated words:
X
X >>> WRITE split "Hello world"
X {[1]: "Hello"; [2]: "world"}
X
X >>> DISPLAY index poem
X But {3}
X I {2; 2; 3}
X I'd {4}
X I've {1}
X a {1}
X anyhow {3}
X be {4}
X can {3}
X cow {1}
X hope {2}
X never {1; 2}
X one {2; 4}
X purple {1}
X rather {4}
X see {2; 4}
X seen {1}
X tell {3}
X than {4}
X you {3}
X
XMORE INFORMATION
XFull details of ABC and the implementations, along with many example
Xprograms are in the book "The ABC Programmer's Handbook" by Leo Geurts,
XLambert Meertens and Steven Pemberton, published by Prentice-Hall
X(ISBN 0-13-000027-2).
X
XSee also Steven Pemberton, "An Alternative Simple Language and
XEnvironment for PCs", IEEE Software, Vol. 4, No. 1, January 1987, pp.
X56-64.
X
XThere is an irregular newsletter available from us (address below),
Xand a mailing list for discussions; to join send your preferred email
Xaddress to abc-list-request at cwi.nl .
X
XIMPLEMENTATIONS
XThe sources for the Unix version have been posted to the
Xcomp.sources.unix group on Usenet; the binaries to comp.binaries.{mac,
Xibm.pc, atari.st}. They are also available from some servers, for
Xinstance by anonymous ftp from hp4nl.nluug.nl [192.16.202.2],
Xmcsun.eu.net [192.16.202.1], and uunet.uu.net [192.48.96.2], in the
Xdirectory {pub}/{programming}/languages/abc, or send the mail message
X request: programming/languages/abc
X topic: index
Xto info-server at hp4nl.nluug.nl, for a list of the available files, or use
X topic: <filename>
Xto get one of the files.
X
XAs of this writing, the available files are:
X
X index for a list of all files available
X abc.intro for an overview of ABC
X (also included with the implementations below)
X abcst.arc for the Atari ST version
X abcpc.arc for the IBM PC version
X abc.mac.sit.hqx for the Mac version
X abc.unix.tar.Z for the Unix version
X README for an explanation of how to unpack the above files
X
XADDRESS
X ABC Implementations
X CWI/AA
X Kruislaan 413
X 1098 SJ AMSTERDAM
X The Netherlands
X
X Email: abc at cwi.nl
X
END_OF_FILE
if test 8974 -ne `wc -c <'abc/doc/abcintro.doc'`; then
echo shar: \"'abc/doc/abcintro.doc'\" unpacked with wrong size!
fi
# end of 'abc/doc/abcintro.doc'
fi
if test -f 'abc/ihdrs/i2par.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/ihdrs/i2par.h'\"
else
echo shar: Extracting \"'abc/ihdrs/i2par.h'\" \(6116 characters\)
sed "s/^X//" >'abc/ihdrs/i2par.h' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/***********************************************************************/
X
X#ifdef macintosh
X/* Avoid name conflict with standard header files: */
X#define compound b_compound
X#endif
X
X/* General parsing routines */
X
Xtypedef char *txptr;
X
X#define Eotc '\0'
X
X#define Char(tx) (*(tx))
X#define Eol(tx) (Char(tx) == '\n')
X#define Ceol(tx) (Char(tx) == C_COMMENT || Eol(tx))
X#define Text(q) (tx < q)
X
X#define Space(c) ((c) == ' ' || (c) == '\t')
X
X#define Letter(c) (islower(c))
X#define Cap(c) (isupper(c))
X#define Dig(c) (isdigit(c))
X
X#define Tagmark(tx) \
X (Tagletmark(Char(tx)) || (Char(tx) == C_POINT && \
X Tagletmark(Char(tx-1)) && Tagletmark(Char(tx+1)) ))
X#define Tagletmark(c) \
X (Letter(c) || Dig(c) || (c) == C_APOSTROPHE || (c) == C_QUOTE)
X
X#define Keytagmark(tx) \
X (keymark(tx) || Tagmark(tx))
X
X#define Isexpr(c) \
X (Letter(c) || (c) == C_OPEN || Dig(c) || (c) == C_POINT || \
X (c) == C_APOSTROPHE || (c) == C_QUOTE || (c) == C_CUROPEN || \
X (c) == C_ABOUT || (c) == C_TIMES || (c) == C_OVER || \
X (c) == C_PLUS || (c) == C_MINUS || (c) == C_NUMBER)
X
Xtxptr fcol();
Xchar *keyword();
X
Xextern txptr tx, ceol, first_col;
Xextern intlet cur_ilev;
Xintlet ilev();
X
Xextern value res_cmdnames;
X
Xvalue cr_text();
X
X/* contexts: */
X#define In_share 's'
X#define In_ranger 'q'
X#define In_formal 'f'
X#define In_ref 'r'
X
X/* Expressions: */
X
Xparsetree expr();
Xparsetree singexpr();
X
X/* Targets: */
X
Xparsetree targ();
X
X/* Tests: */
X
Xparsetree test();
Xparsetree unp_test();
X
X/* Commands: */
X
Xparsetree cmd_suite();
Xparsetree cmd_seq();
Xparsetree ucmd_seq();
Xvalue tail_line();
X
X/* B units */
X
Xparsetree unit();
Xparsetree collateral();
Xparsetree compound();
Xparsetree idf();
Xextern literal idf_cntxt;
X
X/* signs */
X
X#define C_COLON ':'
X#define S_COLON ":"
X#define C_SEMICOLON ';'
X#define S_SEMICOLON ";"
X#define C_OPEN '('
X#define S_OPEN "("
X#define C_CLOSE ')'
X#define S_CLOSE ")"
X#define C_COMMA ','
X#define S_COMMA ","
X#define C_POINT '.'
X#define S_POINT "."
X#define C_APOSTROPHE '\''
X#define S_APOSTROPHE "'"
X#define C_QUOTE '"'
X#define S_QUOTE "\""
X#define C_CONVERT '`'
X#define S_CONVERT "`"
X#define C_CUROPEN '{'
X#define S_CUROPEN "{"
X#define C_CURCLOSE '}'
X#define S_CURCLOSE "}"
X#define C_SUB '['
X#define S_SUB "["
X#define C_BUS ']'
X#define S_BUS "]"
X#define C_BEHEAD '@'
X#define S_BEHEAD "@"
X#define C_CURTAIL '|'
X#define S_CURTAIL "|"
X#define C_ABOUT '~'
X#define S_ABOUT "~"
X#define C_PLUS '+'
X#define S_PLUS "+"
X#define C_MINUS '-'
X#define S_MINUS "-"
X#define C_TIMES '*'
X#define S_TIMES "*"
X#define C_OVER '/'
X#define S_OVER "/"
X#define C_JOIN '^'
X#define S_JOIN "^"
X#define C_NUMBER '#'
X#define S_NUMBER "#"
X#define C_LESS '<'
X#define S_LESS "<"
X#define C_EQUAL '='
X#define S_EQUAL "="
X#define C_GREATER '>'
X#define S_GREATER ">"
X#define S_POWER "**"
X#define S_NUMERATOR "*/"
X#define S_DENOMINATOR "/\*"
X /* \ is needed, else some C preprocessors see it as comment start! */
X#define S_REPEAT "^^"
X#define S_LEFT_ADJUST "<<"
X#define S_CENTER "><"
X#define S_RIGHT_ADJUST ">>"
X#define S_AT_MOST "<="
X#define S_UNEQUAL "<>"
X#define S_AT_LEAST ">="
X#define S_RANGE ".."
X
X#define C_COMMENT '\\'
X#define S_COMMENT "\\"
X#define C_NEWLINE '/'
X#define S_NEWLINE "/"
X
X#define open_sign _sign_is(C_OPEN)
X#define point_sign _sign_is(C_POINT)
X#define apostrophe_sign _sign_is(C_APOSTROPHE)
X#define quote_sign _sign_is(C_QUOTE)
X#define conv_sign _sign_is(C_CONVERT)
X#define curlyopen_sign _sign_is(C_CUROPEN)
X#define curlyclose_sign _sign_is(C_CURCLOSE)
X#define sub_sign _sign_is(C_SUB)
X#define behead_sign _sign_is(C_BEHEAD)
X#define curtl_sign _sign_is(C_CURTAIL)
X#define about_sign _sign_is(C_ABOUT)
X#define plus_sign _sign_is(C_PLUS)
X#define minus_sign _sign_is(C_MINUS)
X#define number_sign _sign_is(C_NUMBER)
X#define equals_sign _sign_is(C_EQUAL)
X#define greater_sign _sign_is(C_GREATER)
X
X#define comment_sign _sign_is(C_COMMENT)
X
X#define reptext_sign _sign2_is(S_REPEAT)
X#define leftadj_sign _sign2_is(S_LEFT_ADJUST)
X#define center_sign _sign2_is(S_CENTER)
X#define rightadj_sign _sign2_is(S_RIGHT_ADJUST)
X#define at_most_sign _sign2_is(S_AT_MOST)
X#define unequal_sign _sign2_is(S_UNEQUAL)
X#define at_least_sign _sign2_is(S_AT_LEAST)
X
X#define _sign_is(c) \
X (Char(tx) == (c) ? (tx++, Yes) : No)
X#define _sign2_is(s) \
X (Char(tx) == (s[0]) && Char(tx+1) == (s[1]) ? (tx+= 2, Yes) : No)
X
X#define nwl_sign _nwl_sign()
X#define times_sign _times_sign()
X#define over_sign _over_sign()
X#define power_sign _power_sign()
X#define numtor_sign _numtor_sign()
X#define denomtor_sign _denomtor_sign()
X#define join_sign _join_sign()
X#define less_than_sign _less_than_sign()
X#define greater_than_sign _greater_than_sign()
X
X/* keywords */
X
X#define atkw(kw, s) (strcmp(kw, s) == 0)
X
X#define check_keyword(kw) (atkw(kw, K_CHECK))
X#define delete_keyword(kw) (atkw(kw, K_DELETE))
X#define insert_keyword(kw) (atkw(kw, K_INSERT))
X#define pass_keyword(kw) (atkw(kw, K_PASS))
X#define put_keyword(kw) (atkw(kw, K_PUT))
X#define read_keyword(kw) (atkw(kw, K_READ))
X#define remove_keyword(kw) (atkw(kw, K_REMOVE))
X#define setrandom_keyword(kw) (atkw(kw, K_SETRANDOM))
X#define write_keyword(kw) (atkw(kw, K_WRITE))
X#define fail_keyword(kw) (atkw(kw, K_FAIL))
X#define quit_keyword(kw) (atkw(kw, K_QUIT))
X#define return_keyword(kw) (atkw(kw, K_RETURN))
X#define report_keyword(kw) (atkw(kw, K_REPORT))
X#define succeed_keyword(kw) (atkw(kw, K_SUCCEED))
X#define if_keyword(kw) (atkw(kw, K_IF))
X#define select_keyword(kw) (atkw(kw, K_SELECT))
X#define while_keyword(kw) (atkw(kw, K_WHILE))
X#define for_keyword(kw) (atkw(kw, K_FOR))
X#define else_keyword(kw) (atkw(kw, K_ELSE))
X#define not_keyword(kw) (atkw(kw, K_NOT))
X#define some_keyword(kw) (atkw(kw, K_SOME))
X#define each_keyword(kw) (atkw(kw, K_EACH))
X#define no_keyword(kw) (atkw(kw, K_NO))
X#define how_keyword(kw) (atkw(kw, K_HOW))
X#define share_keyword(kw) (atkw(kw, K_SHARE))
X
X#ifdef GFX
X
X#define spacefrom_keyword(kw) (atkw(kw, K_SPACEFROM))
X#define linefrom_keyword(kw) (atkw(kw, K_LINEFROM))
X#define clearscreen_keyword(kw) (atkw(kw, K_CLEARSCREEN))
X
X#endif /* GFX */
END_OF_FILE
if test 6116 -ne `wc -c <'abc/ihdrs/i2par.h'`; then
echo shar: \"'abc/ihdrs/i2par.h'\" unpacked with wrong size!
fi
# end of 'abc/ihdrs/i2par.h'
fi
if test -f 'abc/lin/i1lta.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'abc/lin/i1lta.c'\"
else
echo shar: Extracting \"'abc/lin/i1lta.c'\" \(8268 characters\)
sed "s/^X//" >'abc/lin/i1lta.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Access and update lists and tables */
X
X#include "b.h"
X#include "bint.h"
X#include "bobj.h"
X#include "i1tlt.h"
X
X#define INSERT_LIS MESS(100, "inserting in non-list")
X#define INSERT_RAN MESS(101, "cannot insert in large range")
X
X#define REMOVE_LIS MESS(102, "removing from non-list")
X#define REMOVE_EMPTY MESS(103, "removing from empty list")
X#define REMOVE_ENTRY MESS(104, "removing non-existent list entry")
X#define REMOVE_RAN MESS(105, "cannot remove from large range")
X
X#define RANGE_BIG MESS(107, "exceedingly large range in display")
X
X#define REPLACE_TAB MESS(115, "replacing in non-table")
X
X#define KEYS_TAB MESS(116, "in keys t, t is not a table")
X
X#define SEL_TAB MESS(117, "in t[k], t is not a table")
X#define SEL_EMPTY MESS(118, "in t[k], t is empty")
X#define SEL_KEY MESS(119, "in t[k], k is not a key of t")
X
X/* B lists */
X
X/* Rangedisplays will be set up as rangelists, only holding lwb and upb
X * iff they contain more than Minrange elements.
X * Minrange might even be just 1.
X */
X#define Minrange (2)
X
XForward value spawn_range();
X
XVisible bool is_rangelist(v) value v; {
X return (bool) Is_range(v);
X}
X
XVisible value list_elem(l, i) value l; intlet i; {
X return List_elem(l, i);
X}
X
Xextern bool found_ok;
X
XVisible insert(v, ll) value v, *ll; {
X intlet len; register value *lp, *lq;
X intlet k; register intlet kk;
X if (!Is_list(*ll)) {
X interr(INSERT_LIS);
X return;
X }
X if (Is_range(*ll)) {
X value l = spawn_range(Lwb(*ll), Upb(*ll));
X if (l == Vnil) {
X interr(INSERT_RAN);
X return;
X }
X release((value)(*ll));
X *ll = l;
X }
X len= Length(*ll);
X VOID found(list_elem, *ll, v, &k);
X if (!found_ok) return;
X if (Unique(*ll) && !Is_ELT(*ll)) {
X xtndlt(ll, 1);
X lq= Ats(*ll)+len; lp= lq-1;
X for (kk= len; kk > k; kk--) *lq--= *lp--;
X *lq= copy(v);
X } else {
X value w;
X lp= Ats(*ll);
X release(*ll);
X *ll= grab(Lis, ++len);
X lq= Ats(*ll);
X for (kk= 0; kk < len; kk++) {
X w= kk == k ? v : *lp++;
X *lq++= copy (w);
X }
X }
X}
X
XVisible remove(v, ll) value v; value *ll; {
X register value *lp, *lq;
X intlet k, len;
X if (!Is_list(*ll)) {
X interr(REMOVE_LIS);
X return;
X }
X if (Length(*ll) == 0) {
X interr(REMOVE_EMPTY);
X return;
X }
X if (Is_range(*ll)) {
X value l = spawn_range(Lwb(*ll), Upb(*ll));
X if (l == Vnil) {
X interr(REMOVE_RAN);
X return;
X }
X release((value)(*ll));
X *ll = l;
X }
X if (!found(list_elem, *ll, v, &k))
X interr(REMOVE_ENTRY);
X else {
X len= Length(*ll);
X lp= Ats(*ll); /* lp[k] = v */
X if (Unique(*ll)) {
X release(*(lp+=k));
X for (k= k; k < len; k++) {*lp= *(lp+1); lp++;}
X xtndlt(ll, -1);
X } else {
X intlet kk= k;
X lq= Ats(*ll);
X release(*ll);
X *ll= grab(Lis, --len);
X lp= Ats(*ll);
X for (k= 0; k < len; k++) {
X if (k == kk) lq++;
X *lp++= copy (*lq); lq++;
X }
X }
X }
X}
X
XVisible value rangesize(lwb, upb) value lwb, upb; {
X value d, r;
X d = diff(upb, lwb);
X r = sum(d, one);
X release(d);
X return r;
X}
X
XHidden value spawn_range(lo, hi) value lo, hi; {
X value s;
X value l, *lp;
X value v, w;
X int i;
X intlet k, len;
X bool enough_space();
X
X if (large(s = rangesize(lo, hi))
X ||
X (i = intval(s)) > Maxintlet
X ||
X !enough_space(Lis, len = (intlet) i)
X ) {
X release(s);
X return Vnil;
X }
X release(s);
X l = grab(Lis, len);
X lp = Ats(l);
X v = copy(lo);
X for (k= 0; k < len; k++) {
X *lp++ = copy(v);
X v = sum(w = v, one);
X release(w);
X }
X release(v);
X return l;
X}
X
XHidden value mk_numrange(lo, hi) value lo, hi; {
X value l, r;
X
X if (large(r= rangesize(lo, hi)) || intval(r) >= Minrange) {
X l= grab(Ran, 2);
X Lwb(l)= copy(lo);
X Upb(l)= copy(hi);
X }
X else {
X l= spawn_range(lo, hi);
X if (l == Vnil)
X interr(RANGE_BIG);
X }
X release(r);
X return l;
X}
X
XHidden value i_range(lo, hi) value lo, hi; {
X value r, res= Vnil;
X
X if (compare(r= rangesize(lo, hi), one) < 0)
X res= mk_elt();
X else
X res= mk_numrange(lo, hi);
X release(r);
X
X return res;
X}
X
XHidden value mk_charrange(a, z) char a, z; {
X value l= grab(Lis, (intlet) (z-a+1)); register value *ep= Ats(l);
X char m[2];
X m[1]= '\0';
X for (m[0]= a; m[0] <= z; m[0]++) {
X *ep++= mk_text(m);
X }
X return l;
X}
X
XHidden value c_range(lo, hi) value lo, hi; {
X char a, z;
X
X a= charval(lo); z= charval(hi);
X if (z <= a-1) return mk_elt();
X else return mk_charrange(a, z);
X}
X
XVisible value mk_range(v1, v2) value v1, v2; {
X if (Is_text(v1)) return c_range(v1, v2);
X else return i_range(v1, v2);
X}
X
XVisible relation range_comp(v, w) value v, w; {
X /* Type(v) == Ran || Type(w) == Ran, and other type Is_list */
X relation ci, cs;
X value s, vs, ws, i, vi, wi, k;
X
X if (Is_range(v) && Is_range(w)) {
X ci = compare(Lwb(v), Lwb(w));
X if (ci == 0)
X ci = compare(Upb(v), Upb(w));
X }
X else {
X i = copy(one);
X vs = size(v); ws = size(w);
X if ((cs = compare(vs, ws)) <= 0)
X s = copy(vs);
X else
X s = copy(ws);
X release(vs); release(ws);
X ci = 0; /* for ELT */
X while (numcomp(i, s) <= 0) {
X vi = item(v, i); wi = item(w, i);
X ci = compare(vi, wi);
X release(vi); release(wi);
X if (ci != 0)
X break;
X i = sum(k=i, one);
X release(k);
X }
X release(i); release(s);
X if (ci == 0)
X ci = cs;
X }
X return ci;
X}
X/**********************************************************************/
X
X/* B tables */
X
XVisible value* key(v, k) value v; intlet k; { /* k in {0..size-1}; no copy */
X return Key(v, k);
X}
X
XVisible value* assoc(v, k) value v; intlet k; { /* k in {0..size-1}; no copy */
X return Assoc(v, k);
X}
X
XVisible value associate(v, k) value v; value k; {
X value *p= adrassoc(v, k);
X if (p != Pnil) return copy(*p);
X interr(SEL_KEY);
X return Vnil;
X}
X
XVisible value keys(ta) value ta; {
X
X if(!Is_table(ta)) {
X interr(KEYS_TAB);
X return grab(Lis, 0);
X } else {
X value li= grab(Lis, Length(ta)), *le, *te= (value *)Ats(ta);
X int k, len= Length(ta);
X le= (value *)Ats(li);
X for (k= 0; k < len; k++) { *le++= copy(Cts(*te)); te++; }
X return li;
X }
X}
X
XVisible value key_elem(t, i) value t; intlet i; { /*The key of the i-th entry*/
X return *Key(t, i);
X}
X
X/* adrassoc returns a pointer to the associate, rather than
X the associate itself, so that the caller can decide if a copy
X should be taken or not. If the key is not found, Pnil is returned. */
XVisible value* adrassoc(t, ke) value t, ke; {
X intlet where;
X if (Type(t) != Tab && Type(t) != ELT) {
X interr(SEL_TAB);
X return Pnil;
X }
X return found(key_elem, t, ke, &where) ? Assoc(t, where) : Pnil;
X}
X
XVisible Procedure uniq_assoc(ta, ke) value ta, ke; {
X intlet k;
X if (found(key_elem, ta, ke, &k)) {
X uniql(Ats(ta)+k);
X uniql(Assoc(ta,k));
X } else syserr(MESS(120, "uniq_assoc called for non-existent table entry"));
X}
X
XVisible Procedure replace(v, ta, ke) value *ta, ke, v; {
X intlet len; value *tp, *tq;
X intlet k, kk;
X uniql(ta);
X if (Type(*ta) == ELT) (*ta)->type = Tab;
X else if (Type(*ta) != Tab) {
X interr(REPLACE_TAB);
X return;
X }
X len= Length(*ta);
X if (found(key_elem, *ta, ke, &k)) {
X value *a;
X uniql(Ats(*ta)+k);
X a= Assoc(*ta, k);
X /* uniql(a); */
X release(*a);
X *a= copy(v);
X return;
X } else if (found_ok) {
X xtndlt(ta, 1);
X tq= Ats(*ta)+len; tp= tq-1;
X for (kk= len; kk > k; kk--) *tq--= *tp--;
X *tq= grab(Com, 2);
X Cts(*tq)= copy(ke);
X Dts(*tq)= copy(v);
X }
X}
X
XVisible bool in_keys(ke, tl) value ke, tl; {
X intlet dummy;
X if (Type(tl) == ELT) return No;
X if (Type(tl) != Tab) syserr(KEYS_TAB);
X return found(key_elem, tl, ke, &dummy);
X}
X
XVisible Procedure delete(tl, ke) value *tl, ke; {
X intlet len, k; value *tp;
X if (Type(*tl) == ELT)
X syserr(MESS(121, "deleting table entry from empty table"));
X if (Type(*tl) != Tab)
X syserr(MESS(122, "deleting table entry from non-table"));
X tp= Ats(*tl); len= Length(*tl);
X if (!found(key_elem, *tl, ke, &k))
X syserr(MESS(123, "deleting non-existent table entry"));
X if (Unique(*tl)) {
X release(*(tp+=k));
X for (k= k; k < len; k++) {*tp= *(tp+1); tp++;}
X xtndlt(tl, -1);
X } else {
X intlet kk; value *tq= Ats(*tl);
X release(*tl);
X *tl= grab(Tab, --len);
X tp= Ats(*tl);
X for (kk= 0; kk < len; kk++) {
X *tp++= copy (*tq); tq++;
X if (kk == k) tq++;
X }
X }
X}
X
X#define Len(len) (len < 200 ? len : ((len-1)/8+1)*8)
X
XHidden Procedure
Xxtndlt(a, d)
X value *a; intlet d;
X{
X intlet len= Length(*a); intlet l1= Len(len), l2;
X len+= d; l2= Len(len);
X if (l1 != l2) {
X regrab(a, l2);
X }
X (*a)->len= len;
X}
X
END_OF_FILE
if test 8268 -ne `wc -c <'abc/lin/i1lta.c'`; then
echo shar: \"'abc/lin/i1lta.c'\" unpacked with wrong size!
fi
# end of 'abc/lin/i1lta.c'
fi
echo shar: End of archive 16 \(of 25\).
cp /dev/null ark16isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 25 archives.
rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
echo You still must unpack the following archives:
echo " " ${MISSING}
fi
exit 0 # Just in case...
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list