v23i087: ABC interactive programming environment, Part08/25
Rich Salz
rsalz at bbn.com
Wed Dec 19 06:36:21 AEST 1990
Submitted-by: Steven Pemberton <steven at 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 at uunet.uu.net if you want that tool.
# Contents: abc/bed/e1getc.c abc/bed/e1supr.c abc/bint3/i3sta.c
# Wrapped by rsalz at 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 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