rsalz@bbn.com (Rich Salz) (12/19/90)
Submitted-by: Steven Pemberton <steven@cwi.nl> Posting-number: Volume 23, Issue 87 Archive-name: abc/part08 #! /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@uunet.uu.net if you want that tool. # Contents: abc/bed/e1getc.c abc/bed/e1supr.c abc/bint3/i3sta.c # Wrapped by rsalz@litchi.bbn.com on Mon Dec 17 13:27:58 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 8 (of 25)."' if test -f 'abc/bed/e1getc.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1getc.c'\" else echo shar: Extracting \"'abc/bed/e1getc.c'\" \(12081 characters\) sed "s/^X//" >'abc/bed/e1getc.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* B editor -- read key definitions from file */ X X#include "b.h" X#include "feat.h" X#include "bmem.h" X#include "bobj.h" X#include "bfil.h" X#include "keys.h" X#include "getc.h" X#include "args.h" X X#define ESC '\033' X X/* XThis file contains a little parser for key definition files. XTo allow sufficient freedom in preparing such a file, a simple Xgrammar has been defined according to which the file is parsed. XThe parsing process is extremely simple, as it can be done Xtop-down using recursive descent. X X XLexical conventions: X X- Blanks between lexical symbols are ignored. X- From '#' to end of line is comment (except inside strings). X- Strings are delimited by double quotes and X use the same escape sequences as C strings, plus: X \e or \E means an ESCape ('\033'). X- Commandnames are like C identifiers ([a-zA-Z_][a-zA-Z0-9_]*). X Upper/lower case distinction is significant. X- Key representations are delimited by double quotes, and may use X any printable characters. X XSyntax in modified BNF ([] mean 0 or 1, * means 0 or more, + means 1 or more): X X file: line* X line: [def] [comment] X def: '[' commandname ']' '=' definition '=' representation X definition: string X X XNotes: X X- A definition for command "[term-init]" defines a string to be sent X TO the terminal at initialization time, e.g. to set programmable X function key definitions. Similar for "[term-done]" on exiting. X- Command names are conventional editor operations. X- Some bindings are taken from tty-settings, and should not be changed. X (interrupt and suspend). X*/ X X#define COMMENT '#' /* Not B-like but very UNIX-like */ X#define QUOTE '"' X XHidden FILE *keysfp; /* File from which to read */ XHidden char nextc; /* Next character to be analyzed */ XHidden bool eof; /* EOF seen? */ XHidden int lcount; /* Current line number */ X#ifndef KEYS XHidden int errcount= 0; /* Number of errors detected */ X#else XVisible int errcount= 0; /* Number of errors detected */ X#endif X XVisible int ndefs; X XHidden Procedure err1(m) X string m; X{ X static char errbuf[MESSBUFSIZE]; X /* since putmess() below overwrites argument m via getmess() */ X X sprintf(errbuf, "%s (%d): %s\n", keysfile, lcount, m); X X if (errcount == 0) { X putmess(errfile, MESS(6500, "Errors in key definitions file:\n")); X } X ++errcount; X X putstr(errfile, errbuf); X} X XHidden Procedure err(m) X int m; X{ X err1(getmess(m)); X} X XHidden Procedure adv() X{ X int c; X X if (eof) X return; X c= getc(keysfp); X if (c == EOF) { X nextc= '\n'; X eof= Yes; X } X else { X nextc= c; X } X} X XHidden Procedure skipspace() X{ X while (nextc == ' ' || nextc == '\t') X adv(); X} X XHidden int lookup(name) X string name; X{ X int i; X X for (i= 0; i < ndefs; ++i) { X if (deftab[i].name != NULL && strcmp(name, deftab[i].name) == 0) X return i; X } X return -1; X} X X/* X * Undefine conflicting definitions, i.e. strip them from other commands. X * Conflicts arise when a command definition is X * an initial subsequence of another, or vice versa. X * String definitions (code < 0) are not undefined. X * The special commands (like interrupt) should not be undefined. X */ XVisible Procedure undefine(code, def) X int code; X string def; X{ X struct tabent *d, *last= deftab+ndefs; X string p, q; X X if (code < 0) X return; X for (d= deftab; d < last; ++d) { X if (d->code > 0 && d->def != NULL) { X for (p= def, q= d->def; *p == *q; ++p, ++q) { X if (*p == '\0') break; X } X if (*p == '\0' || *q == '\0') { X d->def= NULL; X d->rep= NULL; X#ifdef KEYS X bind_changed(d->code); X#endif X } X } X } X} X XHidden bool store(code, name, def, rep) /* return whether stored */ X int code; X string name; X string def; X string rep; X{ X struct tabent *d, *last= deftab+ndefs; X char *pc; X X if (code < 0) { X /* find the place matching name to replace definition */ X for (d= deftab; d < last; ++d) { X if (strcmp(name, d->name) == 0) X break; X } X } X else { X /* Check for illegal definition: X If a command definition starts with a printable character X OR it contains one of the special chars that are, or X must be handled as signals (like interrupt, suspend, quit). X */ X if (isascii(*def) && (isprint(*def) || *def==' ')) { X sprintf(messbuf, X GMESS(6501, "Definition for command %s starts with '%c'."), X name, *def); X err1(messbuf); X return No; X } X for (pc= def; *pc != '\0'; pc++) { X if (is_spchar(*pc)) { X sprintf(messbuf, X#ifdef CANSUSPEND X XGMESS(6502, "Definition for command %s would produce an interrupt or suspend."), X X#else X XGMESS(6503, "Definition for command %s would produce an interrupt."), X X#endif X name, *def); X err1(messbuf); X return No; X } X } X X undefine(code, def); X /* New definitions are added at the end, so the last one can be X used in the HELP blurb. */ X d= last; X /* Extend definition table */ X if (ndefs >= MAXDEFS) { X err(MESS(6504, "Too many key definitions")); X return No; X } X ndefs++; X } X d->code= code; X d->name= name; X d->def= def; X d->rep= rep; X#ifdef MEMTRACE X fixmem((ptr) name); X fixmem((ptr) def); X fixmem((ptr) rep); X#endif X return Yes; X} X XHidden string getname() X{ X char buffer[20]; X string bp; X X if (nextc != '[') { X err(MESS(6505, "no '[' before name")); X return NULL; X } X bp= buffer; X *bp++= nextc; X adv(); X if (!isascii(nextc) X || X (!isalpha(nextc) && nextc != '_' && nextc != '-') X ) { X err(MESS(6506, "No name after '['")); X return NULL; X } X while ((isascii(nextc) && isalnum(nextc)) X || nextc == '_' || nextc == '-' X ) { X if (bp < buffer + sizeof buffer - 1) X *bp++= (nextc == '_' ? '-' : nextc); X adv(); X } X if (nextc != ']') { X err(MESS(6507, "no ']' after name")); X return NULL; X } X *bp++= nextc; X adv(); X *bp= '\0'; X return (string) savestr(buffer); X} X XHidden string getstring() X{ X char buf[256]; /* Arbitrary limit */ X char c; X int len= 0; X X if (nextc != QUOTE) { X err(MESS(6508, "opening string quote not found")); X return NULL; X } X adv(); X while (nextc != QUOTE) { X if (nextc == '\n') { X err(MESS(6509, "closing string quote not found in definition")); X return NULL; X } X if (nextc != '\\') { X c= nextc; X adv(); X } X else { X adv(); X switch (nextc) { X X case 'r': c= '\r'; adv(); break; X case 'n': c= '\n'; adv(); break; X case 'b': c= '\b'; adv(); break; X case 't': c= '\t'; adv(); break; X case 'f': c= '\f'; adv(); break; X X case 'E': X case 'e': c= ESC; adv(); break; X X case '0': case '1': case '2': case '3': X case '4': case '5': case '6': case '7': X c= nextc-'0'; X adv(); X if (nextc >= '0' && nextc < '8') { X c= 8*c + nextc-'0'; X adv(); X if (nextc >= '0' && nextc < '8') { X c= 8*c + nextc-'0'; X adv(); X } X } X break; X X default: c=nextc; adv(); break; X X } X } X if (len >= sizeof buf) { X err(MESS(6510, "definition string too long")); X return NULL; X } X buf[len++]= c; X } X adv(); X buf[len]= '\0'; X return (string) savestr(buf); X} X XHidden string getrep() X{ X char buf[256]; /* Arbitrary limit */ X char c; X int len= 0; X X if (nextc != QUOTE) { X err(MESS(6511, "opening string quote not found in representation")); X return NULL; X } X adv(); X while (nextc != QUOTE) { X if (nextc == '\\') X adv(); X if (nextc == '\n') { X err(MESS(6512, "closing string quote not found in representation")); X return NULL; X } X c= nextc; X adv(); X if (!isprint(c) && c != ' ') { X err(MESS(6513, "unprintable character in representation")); X return NULL; X } X if (len >= sizeof buf) { X err(MESS(6514, "representation string too long")); X return NULL; X } X buf[len++]= c; X } X adv(); X buf[len]= '\0'; X return savestr(buf); X} X XHidden Procedure get_definition() X{ X string name; X int d; X int code; X string def; X string rep; X X name= getname(); X if (name == NULL) X return; X skipspace(); X if (nextc != '=') { X sprintf(messbuf, GMESS(6515, "Name %s not followed by '='"), name); X err1(messbuf); X freemem((ptr) name); X return; X } X d = lookup(name); X if (d < 0) { X sprintf(messbuf, X getmess(MESS(6516, "Unknown command name: %s")), name); X err1(messbuf); X freemem((ptr) name); X return; X } X code = deftab[d].code; X if (code == CANCEL || code == SUSPEND) { X sprintf(messbuf, X getmess(MESS(6517, "Cannot rebind %s in keysfile")), name); X err1(messbuf); X freemem((ptr) name); X return; X } X X adv(); X skipspace(); X def= getstring(); X if (def == NULL) { X freemem((ptr) name); X return; X } X X skipspace(); X if (nextc != '=') { X sprintf(messbuf, GMESS(6518, "No '=' after definition for name %s"), name); X err1(messbuf); X freemem((ptr) name); X freemem((ptr) def); X return; X } X X adv(); X skipspace(); X rep= getrep(); X if (rep == NULL) { X freemem((ptr) name); X freemem((ptr) def); X return; X } X X if (!store(code, name, def, rep)) { X freemem((ptr) name); X freemem((ptr) def); X freemem((ptr) rep); X } X} X XHidden Procedure get_line() X{ X adv(); X skipspace(); X if (nextc != COMMENT && nextc != '\n') X get_definition(); X while (nextc != '\n') X adv(); X} X X#ifdef DUMPKEYS XVisible Procedure dumpkeys(where) X string where; X{ X int i; X int w; X string s; X X putSstr(stdout, "\nDump of key definitions %s.\n\n", where); X putstr(stdout, "Code Name Definition Representation\n"); X for (i= 0; i < ndefs; ++i) { X putDstr(stdout, "%04o ", deftab[i].code); X if (deftab[i].name != NULL) X putSstr(stdout, "%-15s ", deftab[i].name); X else X putstr(stdout, " "); X s= deftab[i].def; X w= 0; X if (s != NULL) { X for (; *s != '\0'; ++s) { X if (isascii(*s) && (isprint(*s) || *s == ' ')) { X putchr(stdout, *s); X w++; X } X else { X putDstr(stdout, "\\%03o", (int)(*s&0377)); X w+= 4; X } X } X } X else { X putstr(stdout, "NULL"); X w= 4; X } X while (w++ < 25) X putchr(stdout, ' '); X s= deftab[i].rep; X putSstr(stdout, "%s\n", s!=NULL ? s : "NULL"); X } X putnewline(stdout); X fflush(stdout); X} X#endif /* DUMPKEYS */ X X#ifdef KEYS Xextern int nharddefs; X#endif X XVisible Procedure countdefs() X{ X struct tabent *d; X X d= deftab; X while (d->name != NULL) { X ++d; X if (d >= deftab+MAXDEFS) X syserr(MESS(6519, "too many predefined keys")); X } X ndefs= d-deftab; X#ifdef KEYS X nharddefs= ndefs; X#endif X} X XVisible Procedure rd_keysfile() X{ X#ifdef KEYS X saveharddefs(); X#endif X if (keysfile != NULL) X keysfp= fopen(keysfile, "r"); X else X keysfp= NULL; X if (keysfp == NULL) { X return; X } X/* process: */ X errcount= 0; X lcount= 1; X eof= No; X do { X get_line(); X lcount++; X } while (!eof); X/* */ X fclose(keysfp); X if (errcount > 0) X fflush(errfile); X#ifdef DUMPKEYS X if (kflag) X dumpkeys("after reading keysfile"); X#endif X#ifdef KEYS X savefiledefs(); X#endif X} X X#ifndef KEYS X X/* Output a named string to the terminal */ X XHidden Procedure outstring(name) X string name; X{ X int i= lookup(name); X X if (i >= 0) { X string def= deftab[i].def; X if (def != NULL && *def != '\0') { X fputs(def, errfile); X putnewline(errfile); X fflush(errfile); X } X } X} X X/* Output the terminal's initialization sequence, if any. */ X XVisible Procedure initgetc() X{ X outstring("[term-init]"); X} X X X/* Output a sequence, if any, to return the terminal to a 'normal' state. */ X XVisible Procedure endgetc() X{ X outstring("[term-done]"); X} X X X/* Read a command from the keyboard, decoding composite key definitions. */ X XVisible int inchar() X{ X int c; X struct tabent *d, *last; X char buffer[100]; X int len; X X c= trminput(); X if (c == EOF) X return c; X c= cvchar(c); X last= deftab+ndefs; X for (d= deftab; d < last; ++d) { X if (d->code > 0 && d->def != NULL && c == (d->def[0] & 0377)) X break; X } X if (d == last) { X if (isascii(c) && (isprint(c) || c == ' ')) X return c; X else X return 0377; X } X if (d->def[1] == '\0') X return d->code; X buffer[0]= c; X len= 1; X for (;;) { X c= trminput(); X if (c == EOF) X return EOF; X buffer[len]= c; X if (len < sizeof buffer - 1) X ++len; X for (d= deftab; d < last; ++d) { X if (d->code > 0 && d->def != NULL X && strncmp(buffer, d->def, len) == 0) X break; X } X if (d == last) { X return 0377; /* Hope this rings a bell */ X } X if (d->def[len] == '\0') X return d->code; X } X} X#endif /* !KEYS */ END_OF_FILE if test 12081 -ne `wc -c <'abc/bed/e1getc.c'`; then echo shar: \"'abc/bed/e1getc.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1getc.c' fi if test -f 'abc/bed/e1supr.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bed/e1supr.c'\" else echo shar: Extracting \"'abc/bed/e1supr.c'\" \(19545 characters\) sed "s/^X//" >'abc/bed/e1supr.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* X * B editor -- Superroutines. X */ X X#include "b.h" X#include "bedi.h" X#include "etex.h" X#include "feat.h" X#include "bobj.h" X#include "erro.h" X#include "node.h" X#include "supr.h" X#include "gram.h" X#include "tabl.h" X X/* X * Compute the length of the ep->s1'th item of node tree(ep->focus). X */ X XVisible int Xlenitem(ep) X register environ *ep; X{ X register node n = tree(ep->focus); X register node nn; X X if (ep->s1&1) { /* Fixed text */ X string *nr= noderepr(n); X return fwidth(nr[ep->s1/2]); X } X /* Else, variable text or a whole node */ X nn = child(n, ep->s1/2); X return nodewidth(nn); X} X X X/* X * Find the largest possible representation of the focus. X * E.g., a WHOLE can also be represented as a SUBSET of its parent, X * provided it has a parent. X * Also, a SUBSET may be extended with some empty left and right X * items and then look like a WHOLE, etc. X * This process is repeated until no more improvements can be made. X */ X XVisible Procedure Xgrow(ep, deleting) X environ *ep; X bool deleting; X{ X subgrow(ep, Yes, deleting); X} X XVisible Procedure Xsubgrow(ep, ignorespaces, deleting) X register environ *ep; X bool ignorespaces; X bool deleting; X{ X register node n; X register int sym; X register int i; X register int len; X register string repr; X X switch (ep->mode) { X case ATBEGIN: X case ATEND: X case VHOLE: X case FHOLE: X ritevhole(ep); X if (ep->mode != FHOLE && ep->mode != VHOLE || lenitem(ep) == 0) X leftvhole(ep); X else if (ep->mode == FHOLE && ep->s2 == 0 && ep->s1 > 1) { X n= tree(ep->focus); X sym= symbol(n); X repr= (noderepr(n))[ep->s1/2]; X if (symbol(child(n, ep->s1/2)) == Optional) { X /* implicit extra widen from optional hole */ X /* e.g. {>?<} -> >{?}< */ X ep->mode= SUBSET; X ep->s2= --ep->s1; X } X else if (!deleting X || strchr("()[]{}\"'`:;.", repr[0]) != NULL X || (repr[0] == ' ' && sym != Grouped X && sym != Grouped_ff && sym != Keyword_list) X ) X /* widen/extend left before some delimiter */ X /* if deleting: only if this delimiter */ X /* is doomed undeletable */ X leftvhole(ep); X } X } X X for (;;) { X n = tree(ep->focus); X sym = symbol(n); X X switch (ep->mode) { X X case VHOLE: X case FHOLE: X if ((sym == Optional || sym == Hole) && ep->s2 == 0) { X ep->mode = WHOLE; X continue; X } X if (lenitem(ep) <= 0) { X ep->mode = SUBSET; X ep->s2 = ep->s1; X continue; X } X return; X X case ATBEGIN: X case ATEND: X if (sym == Optional || sym == Hole) { X ep->mode = WHOLE; X continue; X } X return; X X case SUBRANGE: X if (ep->s1&1) { X string *nr= noderepr(n); X repr = nr[ep->s1/2]; X len = fwidth(repr); X if (!ignorespaces) { X while (ep->s2 > 0 && repr[ep->s2-1] == ' ') X --ep->s2; X while (ep->s3 < len && repr[ep->s3+1] == ' ') X ++ep->s3; X } X } X else { X value chld= (value) firstchild(n); X len = Length(chld); X } X if (ep->s2 == 0 && ep->s3 >= len - 1) { X ep->mode = SUBSET; X ep->s2 = ep->s1; X continue; X } X return; X X case SUBSET: X subgrsubset(ep, ignorespaces); X if (ep->s1 == 1) { X if (ep->s2 == 2*nchildren(n) + 1) { X ep->mode = WHOLE; X continue; X } X if (ep->s2 == 2*nchildren(n) - 1 && issublist(sym)) { X ep->mode = SUBLIST; X ep->s3 = 1; X return; X } X } X return; X X case SUBLIST: X for (i = ep->s3; i > 0; --i) X n = lastchild(n); X sym = symbol(n); X if (sym == Optional) { X ep->mode = WHOLE; X continue; X } X return; X X case WHOLE: X ep->s1 = 2*ichild(ep->focus); X if (up(&ep->focus)) { X ep->mode = SUBSET; X ep->s2 = ep->s1; X higher(ep); X continue; X } X return; /* Leave as WHOLE if there is no parent */ X X default: X Abort(); X /* NOTREACHED */ X X } X X } X /* Not reached */ X} X X X/* X * Ditto to find smallest possible representation. X */ X XVisible Procedure Xshrink(ep) X register environ *ep; X{ X register node n; X register int sym; X X for (;;) { X n = tree(ep->focus); X sym = symbol(n); X X switch (ep->mode) { X X case WHOLE: X if (sym == Hole || sym == Optional) X return; X ep->mode = SUBSET; X ep->s1 = 1; X ep->s2 = 2*nchildren(n) + 1; X continue; X X case SUBLIST: X if (sym == Hole || sym == Optional) { X ep->mode = WHOLE; X return; X } X if (ep->s3 == 1) { X ep->mode = SUBSET; X ep->s1 = 1; X ep->s2 = 2*nchildren(n) - 1; X continue; X } X return; X X case SUBSET: X if (sym == Hole || sym == Optional) { X ep->mode = WHOLE; X return; X } X shrsubset(ep); X if (ep->s1 == ep->s2) { X if (isunititem(ep)) { X ep->mode = SUBRANGE; X ep->s2 = 0; X ep->s3 = lenitem(ep) - 1; X return; X } X else { X s_downi(ep, ep->s1/2); X ep->mode = WHOLE; X continue; X } X } X return; X X case SUBRANGE: X if (sym == Optional || sym == Hole) X ep->mode = WHOLE; X return; X X case ATBEGIN: X ritevhole(ep); X if (ep->mode == ATBEGIN) { X if (sym == Optional || sym == Hole) X ep->mode = WHOLE; X return; X } X continue; X X case FHOLE: X case VHOLE: X ritevhole(ep); X if (ep->mode != VHOLE && ep->mode != FHOLE) X continue; X sym = symbol(tree(ep->focus)); X if (sym == Optional || sym == Hole && ep->s2 == 0) X ep->mode = WHOLE; X return; X X case ATEND: X return; X X default: X Abort(); X /* NOTREACHED */ X X } X } X /* Not reached */ X X} X X X/* X * Subroutine to find the largest way to describe a SUBSET focus X * (modulo surrounding blanks and newlines). X */ X X#ifdef NOT_USED XVisible Procedure Xgrowsubset(ep) X environ *ep; X{ X subgrsubset(ep, Yes); X} X#endif X XVisible Procedure Xsubgrsubset(ep, ignorespaces) X register environ *ep; X bool ignorespaces; X{ X register node n = tree(ep->focus); X register string *rp = noderepr(n); X register nch21 = nchildren(n)*2 + 1; X register int i; X X Assert(ep->mode == SUBSET); X for (i = ep->s1; i > 1 && subisnull(n, rp, i-1, ignorespaces); --i) X ; X ep->s1 = i; X for (i = ep->s2; i < nch21 && subisnull(n, rp, i+1, ignorespaces); ++i) X ; X ep->s2 = i; X} X X X/* X * Ditto for the smallest way. X */ X XVisible Procedure /* Ought to be Hidden */ Xshrsubset(ep) X register environ *ep; X{ X register node n = tree(ep->focus); X register string *rp = noderepr(n); X register int s1 = ep->s1; X register int s2 = ep->s2; X X for (; s1 < s2 && isnull(n, rp, s1); ++s1) X ; X ep->s1 = s1; X for (; s2 > s1 && isnull(n, rp, s2); --s2) X ; X ep->s2 = s2; X} X X X/* X * Subroutine for grow/shrink to see whether item i is (almost) invisible. X */ X XHidden bool Xsubisnull(n, rp, i, ignorespaces) X register node n; X register string *rp; X register int i; X bool ignorespaces; X{ X register string repr; X register node nn; X X if (i&1) { /* Fixed text */ X repr = rp[i/2]; X return !Fw_positive(repr) || ignorespaces && allspaces(repr); X } X nn = child(n, i/2); X return nodewidth(nn) == 0; X} X X XHidden bool Xisnull(n, rp, i) X node n; X string *rp; X int i; X{ X return subisnull(n, rp, i, Yes); X} X X/* X * Find the rightmost VHOLE which would look the same as the current one. X */ X XVisible Procedure Xritevhole(ep) X register environ *ep; X{ X register node n; X register int ich; X register int len; X register int s1save; X X for (;;) { X n = tree(ep->focus); X X switch (ep->mode) { X X case WHOLE: X ep->mode = ATEND; X break; X X case VHOLE: X case FHOLE: X len = lenitem(ep); X Assert(len >= 0); X if (ep->s2 < len) X return; /* Hole in middle of string */ X s1save = ep->s1; X if (nextitem(ep)) { X if (isunititem(ep)) { X ep->mode = (ep->s1&1) ? FHOLE : VHOLE; X ep->s2 = 0; X } X else if (fwidth(noderepr(child(n, ep->s1/2))[0]) < 0) { X /* Next item begins with newline -- avoid */ X ep->s1 = s1save; X return; X } X else { X s_downi(ep, ep->s1/2); X ep->mode = ATBEGIN; X } X break; X } X ep->mode = ATEND; X /* Fall through */ X case ATEND: X if (!parent(ep->focus) || nodewidth(n) < 0) X return; X ich = ichild(ep->focus); X ep->s1 = 2*ich; X s_up(ep); X if (nextitem(ep)) { X /* Note -- negative width cannot occur X * (see test above) [says Guido] X */ X if (isunititem(ep)) { X ep->mode = (ep->s1&1) ? FHOLE : VHOLE; X ep->s2 = 0; X } X else { X ep->mode = ATBEGIN; X s_downi(ep, ep->s1/2); X } X break; X } X continue; X X case ATBEGIN: X if (fwidth(noderepr(n)[0]) < 0) X return; /* Already at dangerous position */ X ep->mode = FHOLE; X ep->s1 = 1; X ep->s2 = 0; X continue; X X default: X Abort(); X /* NOTREACHED */ X X } X } X} X X X/* X * Ditto to the left. X */ X XVisible Procedure Xleftvhole(ep) X register environ *ep; X{ X register int ich; X X for (;;) { X switch (ep->mode) { X X case WHOLE: X ep->mode = ATBEGIN; X break; X X case VHOLE: X case FHOLE: X if (ep->s2 > 0) X return; X if (previtem(ep)) { X if (isunititem(ep)) { X ep->mode = (ep->s1&1) ? FHOLE : VHOLE; X ep->s2 = lenitem(ep); X } X else { X s_downi(ep, ep->s1/2); X ep->mode = ATEND; X } X } X else if (fwidth(noderepr(tree(ep->focus))[0]) < 0) X return; X else X ep->mode = ATBEGIN; X continue; X X case ATBEGIN: X ich = ichild(ep->focus); X if (!up(&ep->focus)) X return; X higher(ep); X ep->s1 = 2*ich; X if (prevnnitem(ep)) { X if (isunititem(ep)) { X ep->mode = (ep->s1&1) ? FHOLE : VHOLE; X ep->s2 = lenitem(ep); X } X else { X s_downi(ep, ep->s1/2); X ep->mode = ATEND; X } X } X else if (fwidth(noderepr(tree(ep->focus))[0]) < 0) { X s_downi(ep, ich); /* Undo up */ X return; X } X else X ep->mode = ATBEGIN; X continue; X X case ATEND: X lastnnitem(ep); X if (isunititem(ep)) { X ep->s2 = lenitem(ep); X ep->mode = (ep->s1&1) ? FHOLE : VHOLE; X } X else X s_downi(ep, ep->s1/2); X continue; X X default: X Abort(); X X } X } X} X X X/* X * Safe up, downi, left and rite routines: X * 1) Rather die than fail; X * 2) Update ep->highest properly. X */ X XVisible Procedure Xs_up(ep) X register environ *ep; X{ X if (!up(&ep->focus)) X syserr(MESS(7100, "s_up failed")); X higher(ep); X} X XVisible Procedure Xs_downi(ep, i) X register environ *ep; X register int i; X{ X if (!downi(&ep->focus, i)) X syserr(MESS(7101, "s_downi failed")); X} X XVisible Procedure Xs_down(ep) X register environ *ep; X{ X if (!down(&ep->focus)) X syserr(MESS(7102, "s_down failed")); X} X XVisible Procedure Xs_downrite(ep) X register environ *ep; X{ X if (!downrite(&ep->focus)) X syserr(MESS(7103, "s_downrite failed")); X} X X#ifdef NOT_USED XVisible Procedure Xs_left(ep) X register environ *ep; X{ X register int ich = ichild(ep->focus); X X s_up(ep); X s_downi(ep, ich-1); X} X#endif X X#ifdef NOT_USED XVisible Procedure Xs_rite(ep) X register environ *ep; X{ X register int ich = ichild(ep->focus); X X s_up(ep); X s_downi(ep, ich+1); X} X#endif X X/* X * Find next item in a subset, using ep->s1 as index. X * (This used to be less trivial, so it's still a subroutine rather than X * coded in-line or as a macro.) X */ X XHidden bool Xnextitem(ep) X register environ *ep; X{ X if (ep->s1 >= 2*nchildren(tree(ep->focus)) + 1) X return No; /* Already at last item */ X ++ep->s1; X return Yes; X} X X X/* X * Ditto for previous. X */ X XHidden bool Xprevitem(ep) X register environ *ep; X{ X if (ep->s1 <= 1 X || ep->s1 == 2 && fwidth(noderepr(tree(ep->focus))[0]) < 0) X return No; /* Already at first item */ X --ep->s1; X return Yes; X} X X X/* X * Test whether item ep->s1 is "small", i.e., fixed or varying text X * but not a whole subtree. X */ X XHidden bool Xisunititem(ep) X register environ *ep; X{ X if (ep->s1&1) X return Yes; X return Is_etext(child(tree(ep->focus), ep->s1/2)); X} X X X/* X * Check for consistent mode information. X */ X XVisible bool Xcheckep(ep) X register environ *ep; X{ X switch (ep->mode) { X X case FHOLE: X if (!(ep->s1&1)) X break; X if (ep->s2 < 0 || ep->s2 > lenitem(ep)) X break; X return Yes; X X case VHOLE: X if (!(ep->s1&1)) { X if (!Is_etext(child(tree(ep->focus), ep->s1/2))) X break; X } X if (ep->s2 < 0 || ep->s2 > lenitem(ep)) X break; X return Yes; X X case SUBSET: X if (ep->s2 == ep->s1 && isunititem(ep) && lenitem(ep) <= 0) X break; X return Yes; X X default: X return Yes; X X } X#ifndef NDEBUG X dbmess(ep); X#endif /* NDEBUG */ X return No; X} X X X/* X * Like {next,prev,first,last}item, but with empty items skipped X * (i.e., those with length <= 0). X */ X XVisible bool Xnextnnitem(ep) X register environ *ep; X{ X register int s1save = ep->s1; X X while (nextitem(ep)) { X if (lenitem(ep) != 0) X return Yes; X } X ep->s1 = s1save; X return No; X} X XVisible bool Xprevnnitem(ep) X register environ *ep; X{ X register int s1save = ep->s1; X register int len; X X while (previtem(ep)) { X len = lenitem(ep); X if (len > 0 || len < 0 && ep->s1 > 1) X return Yes; X } X ep->s1 = s1save; X return No; X} X X#ifdef NOT_USED XVisible Procedure Xfirstnnitem(ep) X register environ *ep; X{ X ep->s1 = fwidth(noderepr(tree(ep->focus))[0]) < 0 ? 2 : 1; X while (lenitem(ep) == 0) { X if (!nextitem(ep)) X break; X } X return; X} X#endif X XVisible Procedure Xlastnnitem(ep) X register environ *ep; X{ X ep->s1 = 2*nchildren(tree(ep->focus)) + 1; X while (lenitem(ep) == 0) { X if (!previtem(ep)) X break; X } X return; X} X X X/* X * Prepare the focus for insertion. X * If the focus isn't a hole, make a hole just before it which becomes the X * new focus. X * Also repair strange statuses left by moves, so we may have more chance X * to insert a character. X */ X XVisible Procedure Xfixit(ep) X register environ *ep; X{ X /* First, make a hole if it's not already a hole. */ X X switch (ep->mode) { X X case FHOLE: X break; X X case VHOLE: X if (ep->s1&1) X ep->mode = FHOLE; X break; X X case SUBRANGE: X if (ep->s1&1) X ep->mode = FHOLE; X else X ep->mode = VHOLE; X break; X X case SUBSET: X if (ep->s1&1) { X if (ep->s1 == 1) X ep->mode = ATBEGIN; X else { X ep->mode = FHOLE; X ep->s2 = 0; X } X } X else if (Is_etext(child(tree(ep->focus), ep->s1/2))) { X ep->mode = VHOLE; X ep->s2 = 0; X } X else { X s_downi(ep, ep->s1/2); X ep->mode = ATBEGIN; X } X break; X X case ATBEGIN: X case SUBLIST: X case WHOLE: X ep->mode = ATBEGIN; X break; X X case ATEND: X break; X X default: X Abort(); X } X X leftvhole(ep); X if (ep->mode == ATEND && symbol(tree(ep->focus)) == Hole) X ep->mode = WHOLE; /***** Experiment! *****/ X} X X X/* X * Small utility to see if a string contains only spaces X * (this is true for the empty string ""). X * The string pointer must not be null! X */ X XVisible bool Xallspaces(str) X register string str; X{ X Assert(str); X for (; *str; ++str) { X if (*str != ' ') X return No; X } X return Yes; X} X X X/* X * Function to compute the actual width of the focus. X */ X XVisible int Xfocwidth(ep) X register environ *ep; X{ X node nn; X register node n = tree(ep->focus); X register string *rp = noderepr(n); X register int i; X register int w; X int len = 0; X X switch (ep->mode) { X X case VHOLE: X case FHOLE: X case ATEND: X case ATBEGIN: X return 0; X X case WHOLE: X return nodewidth(n); X X case SUBRANGE: X return ep->s3 - ep->s2 + 1; X X case SUBSET: X for (i = ep->s1; i <= ep->s2; ++i) { X if (i&1) X w = fwidth(rp[i/2]); X else { X nn = child(n, i/2); X w = nodewidth(nn); X } X if (w < 0 && len >= 0) X len = w; X else if (w >= 0 && len < 0) X ; X else X len += w; X } X return len; X X case SUBLIST: X len = nodewidth(n); X for (i = ep->s3; i > 0; --i) X n = lastchild(n); X w = nodewidth(n); X if (w < 0 && len >= 0) X return w; X if (w >= 0 && len < 0) X return len; X return len - w; X X default: X Abort(); X /* NOTREACHED */ X } X} X X X/* X * Compute the offset of the focus from the beginning of the current node. X * This may be input again to fixfocus to allow restoration of this position. X */ X XVisible int Xfocoffset(ep) X register environ *ep; X{ X node nn; X register node n; X register string *rp; X register int w; X register int len; X register int i; X X switch (ep->mode) { X X case WHOLE: X case SUBLIST: X return 0; X X case ATBEGIN: X return ep->spflag; X X case ATEND: X w = nodewidth(tree(ep->focus)); X if (w < 0) X return w; X return w + ep->spflag; X X case SUBSET: X case FHOLE: X case VHOLE: X case SUBRANGE: X n = tree(ep->focus); X rp = noderepr(n); X len = 0; X for (i = 1; i < ep->s1; ++i) { X if (i&1) X w = Fwidth(rp[i/2]); X else { X nn = child(n, i/2); X w = nodewidth(nn); X } X if (w < 0) { X if (len >= 0) X len = w; X else X len += w; X } X else if (len >= 0) X len += w; X } X if (ep->mode == SUBSET || len < 0) X return len; X return len + ep->s2 + ep->spflag; X X default: X Abort(); X /* NOTREACHED */ X } X} X X/* X * Return the first character of the focus (maybe '\n'; 0 if zero-width). X */ X XVisible int Xfocchar(ep) X environ *ep; X{ X node n = tree(ep->focus); X string *rp; X int i; X int c; X X switch (ep->mode) { X X case VHOLE: X case FHOLE: X case ATBEGIN: X case ATEND: X return 0; X X case WHOLE: X case SUBLIST: X return nodechar(n); X X case SUBSET: X rp = noderepr(n); X for (i = ep->s1; i <= ep->s2; ++i) { X if (i&1) { X if (!Fw_zero(rp[i/2])) X return rp[i/2][0]; X } X else { X c = nodechar(child(n, i/2)); X if (c) X return c; X } X } X return 0; X X case SUBRANGE: X if (ep->s1&1) { X string *nr= noderepr(n); X return nr[ep->s1/2][ep->s2]; X } X else { X Assert(Is_etext(child(n, ep->s1/2))); X return e_ncharval(ep->s2 + 1, (value) child(n, ep->s1/2)); X } X X default: X Abort(); X /* NOTREACHED */ X X } X} X X X/* X * Subroutine to return first character of node. X */ X XVisible int Xnodechar(n) X node n; X{ X string *rp; X int nch; X int i; X int c; X X if (Is_etext(n)) X/* return strval((value)n)[0]; */ X return e_ncharval(1, (value) n); X rp = noderepr(n); X if (!Fw_zero(rp[0])) X return rp[0][0]; X nch = nchildren(n); X for (i = 1; i <= nch; ++i) { X c = nodechar(child(n, i)); X if (c) X return c; X if (!Fw_zero(rp[i])) X return rp[i][0]; X } X return 0; X} X X X/* X * Function to compute the actual indentation level at the focus. X */ X XVisible int Xfocindent(ep) X environ *ep; X{ X int y = Ycoord(ep->focus); X int x = Xcoord(ep->focus); X int level = Level(ep->focus); X node n = tree(ep->focus); X X switch (ep->mode) { X X case WHOLE: X case ATBEGIN: X case SUBLIST: X break; X X case ATEND: X evalcoord(n, 1 + nchildren(n), &y, &x, &level); X break; X X case SUBSET: X case FHOLE: X case VHOLE: X evalcoord(n, ep->s1/2, &y, &x, &level); X break; X X default: X Abort(); X } X return level; X} X X X/* X * Routines to move 'environ' structures. X */ X Xemove(s, d) X environ *s; X environ *d; X{ X#ifdef STRUCTASS X *d = *s; X#else /* !STRUCTASS */ X d->focus = s->focus; X X d->mode = s->mode; X d->copyflag = s->copyflag; X d->spflag = s->spflag; X d->changed = s->changed; X X d->s1 = s->s1; X d->s2 = s->s2; X d->s3 = s->s3; X X d->highest = s->highest; X X d->copybuffer = s->copybuffer; X#ifdef RECORDING X d->oldmacro = s->oldmacro; X d->newmacro = s->newmacro; X#endif /* RECORDING */ X X d->generation = s->generation; X#endif /* !STRUCTASS */ X} X Xecopy(s, d) X environ *s; X environ *d; X{ X emove(s, d); X VOID pathcopy(d->focus); X VOID copy(d->copybuffer); X#ifdef RECORDING X VOID copy(d->oldmacro); X VOID copy(d->newmacro); X#endif /* RECORDING */ X} X Xerelease(e) X environ *e; X{ X pathrelease(e->focus); X release(e->copybuffer); X#ifdef RECORDING X release(e->oldmacro); X release(e->newmacro); X#endif /* RECORDING */ X} X X/* X * Routines to move 'environ' structures. X */ X XVisible bool ev_eq(l, r) X environ *l; X environ *r; X{ X if (l->focus == r->focus X && l->mode == r->mode X && l->copyflag == r->copyflag X && l->spflag == r->spflag X && l->changed == r->changed X && l->s1 == r->s1 X && l->s2 == r->s2 X && l->s3 == r->s3 X && (l->highest == r->highest || l->highest == Maxintlet) X && l->copybuffer == r->copybuffer X#ifdef RECORDING X && l->oldmacro == r->oldmacro X && l->newmacro == r->newmacro X#endif /* RECORDING */ X ) X return Yes; X else X return No; X} END_OF_FILE if test 19545 -ne `wc -c <'abc/bed/e1supr.c'`; then echo shar: \"'abc/bed/e1supr.c'\" unpacked with wrong size! fi # end of 'abc/bed/e1supr.c' fi if test -f 'abc/bint3/i3sta.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'abc/bint3/i3sta.c'\" else echo shar: Extracting \"'abc/bint3/i3sta.c'\" \(18967 characters\) sed "s/^X//" >'abc/bint3/i3sta.c' <<'END_OF_FILE' X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */ X X/* Stacks used by the interpreter */ X X#include "b.h" X#include "bint.h" X#include "feat.h" /* for EXT_RANGE */ X#include "bmem.h" X#include "bobj.h" X#include "i0err.h" X#include "i1num.h" X#include "i2nod.h" X#include "i3env.h" X#include "i3int.h" X#include "i3in2.h" X#include "i3sou.h" X X/* Fundamental registers: (shared only between this file and b3int.c) */ X XVisible parsetree pc; /* 'Program counter', current parsetree node */ XVisible parsetree next; /* Next parsetree node (changed by jumps) */ XVisible bool report; /* 'Condition code register', outcome of last test */ X XHidden env boundtags; /* Holds bound tags chain */ X X/* Value stack: */ X X/* The run-time value stack grows upward, sp points to the next free entry. X Allocated stack space lies between st_base and st_top. X In the current invocation, the stack pointer (sp) must lie between X st_bottom and st_top. X Stack overflow is corrected by growing st_top, underflow is a fatal X error (generated code is wrong). X*/ X XHidden value *st_base, *st_bottom, *st_top, *sp; XVisible int call_level; /* While run() can be called recursively */ X X#define EmptyStack() (sp == st_bottom) X#define BotOffset() (st_bottom - st_base) X#define SetBotOffset(n) (st_bottom= st_base + (n)) X X#define INCREMENT 100 X XHidden Procedure st_grow(incr) int incr; { X if (st_base == Pnil) { /* First time ever */ X st_bottom= sp= st_base= X (value*) getmem((unsigned) incr * sizeof(value *)); X st_top= st_base + incr; X } X else { X int syze= (st_top - st_base) + incr; X int n_bottom= BotOffset(); X int n_sp= sp - st_base; X regetmem((ptr*) &st_base, (unsigned) syze * sizeof(value *)); X sp = st_base + n_sp; X SetBotOffset(n_bottom); X st_top= st_base + syze; X } X} X XVisible value pop() { X if (sp <= st_bottom) { X syserr(MESS(4100, "stack underflow")); X return Vnil; X } X return *--sp; X} X XVisible Procedure push(v) value v; { X if (sp >= st_top) st_grow(INCREMENT); X *sp++ = (v); X} X X/* - - - */ X X/* Various call types, used as index in array: */ X X#define C_howto 0 X#define C_yield 1 X#define C_test 2 X X#define C_refcmd 3 X#define C_refexp 4 X#define C_reftest 5 X X X/* What can happen to a thing: */ X X#define Old 'o' X#define Cpy 'c' X#define New 'n' X#define Non '-' X Xtypedef struct { X literal do_cur; X literal do_prm; X literal do_bnd; X literal do_for; X literal do_resexp; X} dorecord; X X X/* Table encoding what to save/restore for various call/return types: */ X/* (Special cases are handled elsewhere.) */ X XHidden dorecord doo[] = { X /* cur prm bnd for resexp */ X X /* HOW-TO */ {New, Old, Non, New, Voi}, X /* YIELD */ {New, Cpy, Non, Non, Ret}, X /* TEST */ {New, Cpy, Non, Non, Rep}, X X /* REF-CMD */ {Old, Old, Old, Old, Voi}, X /* ref-expr */ {Cpy, Cpy, Non, Old, Ret}, X /* ref-test */ {Cpy, Cpy, New, Old, Rep} X}; X X#define MAXTYPE ((sizeof doo) / (sizeof doo[0])) X X#define Checksum(type) (12345 - (type)) /* Reversible */ X X X#define Ipush(n) push(MkSmallInt(n)) X#define Ipop() SmallIntVal(pop()) X X XHidden env newenv(tab, inv_env) envtab tab; env inv_env; { X env ev= (env) getmem(sizeof(envchain)); X ev->tab= tab; /* Eats a reference to tab! */ X ev->inv_env= inv_env; X return ev; X} X XHidden Procedure pushenv(pe) env *pe; { X env ev= (env) getmem(sizeof(envchain)); X ev->tab= copy((*pe)->tab); X ev->inv_env= *pe; X *pe= ev; X} X XHidden Procedure popenv(pe) env *pe; { X env ev= *pe; X *pe= ev->inv_env; X release(ev->tab); X freemem((ptr) ev); X} X X XHidden Procedure call(type, new_pc) intlet type; parsetree new_pc; { X if (type < 0 || type >= MAXTYPE) syserr(MESS(4101, "bad call type")); X X /* Push other stacks */ X X if (doo[type].do_bnd != Old) { X boundtags= newenv( X (doo[type].do_bnd == New) ? mk_elt() : Vnil, X boundtags); X bndtgs= &boundtags->tab; X } X switch (doo[type].do_cur) { X X case New: X curnv= newenv(Vnil, curnv); X break; X X case Cpy: X pushenv(&curnv); X break; X X } X switch (doo[type].do_prm) { X X case Old: X break; X X case Cpy: X pushenv(&prmnv); X break; X } X X /* Push those things that depend on the call type: */ X X if (doo[type].do_for != Old) { X push(copy(uname)); X } X X /* Push miscellaneous context info: */ X push(curline); X push(curlino); X Ipush(resexp); resexp= doo[type].do_resexp; X Ipush(cntxt); X resval= Vnil; X X /* Push vital data: */ X push(next); X Ipush(BotOffset()); ++call_level; X Ipush(Checksum(type)); /* Kind of checksum */ X X /* Set st_bottom and jump: */ X st_bottom= sp; X next= new_pc; X} X X XVisible Procedure ret() { X int type; value rv= resval; literal re= resexp; X value oldcurnvtab= Vnil, oldbtl= Vnil; X X /* Clear stack: */ X while (!EmptyStack()) release(pop()); X X /* Pop type and hope it's good: */ X st_bottom= st_base; /* Trick to allow popping the return info */ X type= Checksum(Ipop()); X if (type < 0 || type >= MAXTYPE) syserr(MESS(4102, "stack clobbered")); X X /* Pop vital data: */ X SetBotOffset(Ipop()); --call_level; X next= pop(); X X /* Pop context info: */ X cntxt= Ipop(); X resexp= Ipop(); X curlino= pop(); X curline= pop(); X X /* Variable part: */ X if (doo[type].do_for != Old) { X release(uname); uname= pop(); X /* FP removed */ X } X if (doo[type].do_prm != Old) X popenv(&prmnv); X switch (doo[type].do_cur) { X X case Cpy: X case New: X oldcurnvtab= copy(curnv->tab); X popenv(&curnv); X break; X X } X if (doo[type].do_bnd != Old) { X oldbtl= copy(*bndtgs); X popenv(&boundtags); X bndtgs= &boundtags->tab; X } X X /* Fiddle bound tags */ X if (Valid(oldbtl)) { X extbnd_tags(oldbtl, oldcurnvtab); X release(oldbtl); X } X X /* Put back arguments for commands: */ X if (type == C_howto && still_ok) putbackargs(oldcurnvtab); X X if (Valid(oldcurnvtab)) release(oldcurnvtab); X if (call_level == 0) re_env(); /* Resets bndtgs */ X X /* Push return value (if any): */ X if (re == Ret && still_ok) push(rv); X} X X/* - - - */ X XVisible Procedure call_refinement(name, def, test) X value name; parsetree def; bool test; { X call(test ? C_reftest : C_refexp, X *Branch(Refinement(def)->rp, REF_START)); X} X X#define YOU_TEST MESS(4103, "You haven't told me HOW TO REPORT %s") X#define YOU_YIELD MESS(4104, "You haven't told me HOW TO RETURN %s") X XHidden Procedure udfpr(nd1, name, nd2, isfunc) X value nd1, name, nd2; bool isfunc; { X value *aa; X bool bad = No; X parsetree u; int k, nlocals; funprd *fpr; X int adicity; X X if (isfunc) adicity= nd1 ? Dfd : nd2 ? Mfd : Zfd; X else adicity= nd1 ? Dpd : nd2 ? Mpd : Zpd; X X if (!is_unit(name, adicity, &aa)) bad = Yes; X else if (isfunc) bad = !Is_function(*aa); X else bad= !Is_predicate(*aa); X if (bad) { X interrV(isfunc ? YOU_YIELD : YOU_TEST, name); X return; X } X fpr= Funprd(*aa); X X if (fpr->adic==Zfd || fpr->adic==Zpd) { X if (Valid(nd2)) bad = Yes; X } X else if (fpr->adic==Mfd || fpr->adic==Mpd) { X if (Valid(nd1)) bad = Yes; X } X X if (bad) syserr(MESS(4105, "invoked how-to has other adicity than invoker")); X if (fpr->pre != Use) syserr(MESS(4106, "udfpr with predefined how-to")); X X u= fpr->unit; X if (fpr->unparsed) fix_nodes(&u, &fpr->code); X if (!still_ok) { rem_unit(u); return; } X fpr->unparsed= No; X nlocals= intval(*Branch(u, FPR_NLOCALS)); X call(isfunc ? C_yield : C_test, fpr->code); X curnv->tab= mk_compound(nlocals); X for (k= 0; k < nlocals; ++k) *Field(curnv->tab, k)= Vnil; X if (Valid(nd1)) push(copy(nd1)); X if (Valid(nd2)) push(copy(nd2)); X} X XVisible Procedure formula(nd1, name, nd2, tor) value nd1, name, nd2, tor; { X if (!Valid(tor)) udfpr(nd1, name, nd2, Yes); X else { X if (!Is_function(tor)) X syserr(MESS(4107, "formula called with non-function")); X push(pre_fun(nd1, Funprd(tor)->pre, nd2)); X } X} X XVisible Procedure proposition(nd1, name, nd2, pred) value nd1, name, nd2, pred; { X if (!Valid(pred)) udfpr(nd1, name, nd2, No); X else { X if (!Is_predicate(pred)) X syserr(MESS(4108, "proposition called with non-predicate")); X report= pre_prop(nd1, Funprd(pred)->pre, nd2); X } X} X X/* Temporary code to hack copy/restore parameters. X Note -- this needs extension to the case where an actuals can be X a compound mixture of expressions and locations. */ X XHidden bool is_location(v) value v; { X while (Valid(v) && Is_compound(v)) X v= *Field(v, 0); X return Valid(v) && (Is_simploc(v) || Is_tbseloc(v) || Is_trimloc(v)); X} X XHidden value n_trim(v, B, C) value v; value B, C; { X /* Return v|(#v-C)@(B+1) */ X value B_plus_1= sum(B, one); X value res1= behead(v, B_plus_1); X value sz= size(res1); X value tail= diff(sz, C); X value res= curtail(res1, tail); X release(B_plus_1), release(res1), release(sz), release(tail); X return res; X} X X/* Extract a value from something that may be a location or a value. X If it's a value, return No. X If it's a non-empty location, X return Yes and put a copy of its content in *pv; X if it's an empty location, return Yes and put Vnil in *pv. */ X XHidden bool extract(l, pv) loc l; value *pv; { X value *ll, lv; X *pv= Vnil; X if (l == Lnil) X return No; X else if (Is_simploc(l)) { X lv= locvalue(l, &ll, No); X if (Valid(lv)) X *pv= copy(lv); X return Yes; X } X else if (Is_tbseloc(l)) { X tbseloc *tl= Tbseloc(l); X lv= locvalue(tl->R, &ll, Yes); X if (still_ok) { X if (!Is_table(lv)) X interr(SEL_NO_TABLE); X else { X ll= adrassoc(lv, tl->K); X if (ll != Pnil) X *pv= copy(*ll); X } X } X return Yes; X } X else if (Is_trimloc(l)) { X trimloc *rr= Trimloc(l); X lv= locvalue(rr->R, &ll, Yes); X if (still_ok) X *pv= n_trim(lv, rr->B, rr->C); X return Yes; X } X else if (Is_compound(l)) { X /* Assume that if one field is a location, they all are. X That's not really valid, but for now it works X (until someone fixes the code generation...) */ X value v; X if (!extract(*Field(l, 0), &v)) X return No; X if (Valid(v)) { X bool ok= Yes; X int i; X *pv= mk_compound(Nfields(l)); X *Field(*pv, 0)= v; X for (i= 1; i < Nfields(l) && still_ok; ++i) { X if (!extract(*Field(l, i), Field(*pv, i)) X && still_ok) X syserr(MESS(4109, "extract")); X if (!Valid(*Field(*pv, i))) X ok= No; X } X if (!ok) { X release(*pv); X *pv= Vnil; X } X } X return Yes; X } X return No; X} X X/* Return a copy of the value of something that may be a location or a X value. If it's a location, return a copy of its content X (or Vnil if it's empty); if it's a value, return a copy of it. */ X XHidden value n_content(l) loc l; { X value v; X if (extract(l, &v)) X return v; X else X return copy(l); X} X X/* Put the actuals in the locals representing formals; X save the locations of the actuals, and save their values. X Also (actually, first of all), save the parse tree for the formals. X Return a compound for the initialized locals. X X Input: the actuals are found on the stack; X they have been pushed from left to right so have to be popped off X in reverse order. Each actual corresponds to one 'slot' for a X formal parameter, which may be a multiple identifier. It has to be X unraveled and put in the individual locals. There are a zillion X reasons why this might fail. X X This routine is called 'epibreer' after a famous Dutch nonsense word, X the verb 'epibreren', coined by the Amsterdam writer S. Carmiggelt (?), X which has taken on the meaning or any complicated processing job X (at least in the ABC group). */ X XHidden value epibreer(formals, argcnt, nlocals) X parsetree formals; /* Parse tree for formals */ X int argcnt; /* Nr. of argument slots */ X int nlocals; /* Nr. of local variables */ X{ X value locals= mk_compound(nlocals); /* Local variables */ X value actuals= mk_compound(argcnt); /* Actuals (locs/values) */ X int nextlocal= 0; /* Next formal tag's number */ X int slot; /* Formal slot number */ X X /* Pop actuals from stack, in reverse order. */ X for (slot= argcnt; --slot >= 0; ) X *Field(actuals, slot)= pop(); /* Hope the count's ok... */ X X /* Save parse tree and actuals on stack. X Must push a *copy* of formals because when we stop after an X error, everything on the stack will be popped and released. X Normally the copy is cancelled by a release in putbackargs. */ X push(copy((value)formals)); X push(actuals); X slot= 0; X while (still_ok && Valid(formals)) { X parsetree argtree= *Branch(formals, FML_TAG); X if (Valid(argtree)) { /* Process one parameter slot: */ X sub_epibreer( X argtree, X *Field(actuals, slot), X &locals, X &nextlocal); X ++slot; X } X formals= *Branch(formals, FML_NEXT); X } X for (; nextlocal < nlocals; ++nextlocal) X *Field(locals, nextlocal)= Vnil; X push(copy(locals)); X return locals; X} X X#define NON_COMPOUND MESS(4110, "putting non-compound in compound parameter") X#define WRONG_LENGTH MESS(4111, "parameter has wrong length") X X/* Unravel one actual parameter slot into possibly a collection of locals. X The parse tree has to be traversed in the same order as when X the numbers were assigned to local variables much earlier; X this is a simple left-to right tree traversal. */ X XHidden Procedure sub_epibreer(argtree, vl, plocals, pnextlocal) X parsetree argtree; X value vl; /* Value or location */ X value *plocals; X int *pnextlocal; X{ X value v; X int k; X X switch (Nodetype(argtree)) { X X case TAG: X vl= n_content(vl); X *Field(*plocals, *pnextlocal)= mk_indirect(vl); X release(vl); X ++*pnextlocal; X break; X X case COLLATERAL: X v= *Branch(argtree, COLL_SEQ); X if (!Valid(v) || !Is_compound(v)) X syserr(MESS(4112, "not a compound in sub_epibreer")); X if (Valid(vl) && !Is_compound(vl)) X vl= n_content(vl); X /* If that isn't a simple or table-selection X location whose content is either Vnil or X a compound of the right size, we'll get an X error below. */ X if (Valid(vl)) { X if (!Is_compound(vl)) X interr(NON_COMPOUND); X else if (Nfields(vl) != Nfields(v)) X interr(WRONG_LENGTH); X } X for (k= 0; still_ok && k < Nfields(v); ++k) X sub_epibreer( X *Field(v, k), X Valid(vl) ? *Field(vl, k) : Vnil, X plocals, X pnextlocal); X break; X X case COMPOUND: X sub_epibreer( X *Branch(argtree, COMP_FIELD), X vl, X plocals, X pnextlocal); X break; X X default: X syserr(MESS(4113, "bad nodetype in sub_epibreer")); X break; X X } X} X X/* Put a value in a location, but empty it if the value is Vnil. */ X XHidden Procedure n_put(v, l) value v; loc l; { X if (!Valid(v)) X l_del(l); X else X put(v, l); X} X X/* Put changed formal parameters back in the corresponding locations. X It is an error to put a changed value back in an expression. */ X XHidden Procedure putbackargs(locenv) value locenv; { X value oldlocenv= pop(); /* Original contents of locenv */ X value locs= pop(); /* Corresponding locations */ X parsetree formals= (parsetree) pop(); /* Parse tree of formals */ X X /* Cancel extra ref to formals caused by push(copy(formals)) X in epibreer; this leaves enough refs so we can still use it. */ X release(formals); X X if (locenv != oldlocenv) { X int slot= 0; X int nextlocal= 0; X X while (still_ok && Valid(formals)) { X parsetree argtree= *Branch(formals, FML_TAG); X if (Valid(argtree)) { X /* Process one parameter slot: */ X sub_putback( X argtree, X *Field(locs, slot), X locenv, X &nextlocal); X ++slot; X } X formals= *Branch(formals, FML_NEXT); X } X } X X release(locs); X release(oldlocenv); X} X XHidden Procedure sub_putback(argtree, lv, locenv, pnextlocal) X parsetree argtree; X /*loc-or*/value lv; X value locenv; X int *pnextlocal; X{ X value v; X int k; X X while (Nodetype(argtree) == COMPOUND) X argtree= *Branch(argtree, COMP_FIELD); X switch (Nodetype(argtree)) { X X case TAG: X if (*pnextlocal >= Nfields(locenv)) X syserr(MESS(4114, "too many tags in sub_putback")); X v= *Field(locenv, *pnextlocal); X if (Changed_formal(v)) X put_it_back(v, lv); X ++*pnextlocal; X break; X X case COLLATERAL: X v= *Branch(argtree, COLL_SEQ); X if (!Valid(v) || !Is_compound(v)) X syserr(MESS(4115, "not a compound in sub_putback")); X if (Valid(lv) && Is_compound(lv)) { X if (Nfields(v) != Nfields(lv)) X interr(WRONG_LENGTH); X for (k= 0; still_ok && k < Nfields(v); ++k) X sub_putback( X *Field(v, k), X *Field(lv, k), X locenv, X pnextlocal); X } X else { X if (collect_value( X &v, X v, X locenv, X pnextlocal)) X put_it_back(v, lv); X release(v); X } X break; X X default: X syserr(MESS(4116, "bad node type in sub_putback")); X } X} X X/* Construct the compound value corresponding to the compound of formal X parameters held in 'seq'. X Return Yes if any subvalue has changed. X It is possible that the value is to be deleted; in this case all X components must be Vnil. A mixture of values and Vnil causes an X error. */ X XHidden bool collect_value(pv, seq, locenv, pnextlocal) X value *pv; X value seq; X value locenv; X int *pnextlocal; X{ X bool changed= No; X int k; X int len= Nfields(seq); X int n_value= 0; X X if (!Valid(seq) || !Is_compound(seq)) X syserr(MESS(4117, "not a compound in collect_value")); X *pv= mk_compound(len); X for (k= 0; k < len; ++k) { X parsetree tree= *Field(seq, k); X value v; X X while (Nodetype(tree) == COMPOUND) X tree= *Branch(tree, COMP_FIELD); X X switch (Nodetype(tree)) { X X case TAG: X v= copy(*Field(locenv, *pnextlocal)); X if (Changed_formal(v)) X changed= Yes; X if (Valid(v) && Is_indirect(v)) { X release(v); X v= copy(Indirect(v)->val); X } X ++*pnextlocal; X break; X X case COLLATERAL: X if (collect_value( X &v, X *Branch(tree, COLL_SEQ), X locenv, X pnextlocal)) X changed= Yes; X break; X X default: X syserr(MESS(4118, "bad node type in collect_value")); X X } X *Field(*pv, k)= v; X } X X for (k= 0; k < len; ++k) { X if (Valid(*Field(*pv, k))) X n_value++; X } X X if (n_value < len && n_value > 0) X interr(MESS(4119, "on return, part of compound holds no value")); X if (n_value < len) { X release(*pv); X *pv= Vnil; X } X X return changed; X} X X/* Put a value in something that may be a location or a value. X If it's a value, an error message is issued. */ X XHidden Procedure put_it_back(v, l) value v; loc l; { X if (!is_location(l)) X interr(MESS(4120, "value of expression parameter changed")); X if (still_ok) X n_put(v, l); X} X XVisible Procedure x_user_command(name, actuals, def) X value name; parsetree actuals; value def; X{ X how *h; parsetree u, formals; value *aa; X value v; int len, argcnt; X if (Valid(def)) { X if (!Is_refinement(def)) syserr(MESS(4121, "bad def in x_user_command")); X call(C_refcmd, *Branch(Refinement(def)->rp, REF_START)); X return; X } X if (!is_unit(name, Cmd, &aa)) { X interrV(MESS(4122, "You haven't told me HOW TO %s"), name); X return; X } X u= (h= How_to(*aa))->unit; X if (h->unparsed) fix_nodes(&u, &h->code); X if (!still_ok) { rem_unit(u); return; } X h->unparsed= No; X formals= *Branch(u, HOW_FORMALS); X len= intval(*Branch(u, HOW_NLOCALS)); X argcnt= 0; X while (Valid(actuals)) { /* Count actuals */ X if (Valid(*Branch(actuals, ACT_EXPR))) X ++argcnt; X actuals= *Branch(actuals, ACT_NEXT); X } /* Could just as well count formals... */ X X v= epibreer(formals, argcnt, len); X X call(C_howto, h->code); X X curnv->tab= v; X release(uname); uname= permkey(name, Cmd); X cntxt= In_unit; X} X XVisible Procedure endsta() { X if (st_base != Pnil) { X freemem((ptr) st_base); X st_base= Pnil; X } X} END_OF_FILE if test 18967 -ne `wc -c <'abc/bint3/i3sta.c'`; then echo shar: \"'abc/bint3/i3sta.c'\" unpacked with wrong size! fi # end of 'abc/bint3/i3sta.c' fi echo shar: End of archive 8 \(of 25\). cp /dev/null ark8isdone 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@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.