Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/unix/volume23/abc/part08

Text File | 1991-01-08 | 56KB | 2,649 lines

Subject:  v23i087:  ABC interactive programming environment, Part08/25
Newsgroups: comp.sources.unix
Approved: [e-mail]
X-Checksum-Snefru: a1ae9ff4 cd5ac149 b6653793 231756bf

Submitted-by: Steven Pemberton <[e-mail]>
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 [e-mail] if you want that tool.
# Contents:  abc/bed/e1getc.c abc/bed/e1supr.c abc/bint3/i3sta.c
# Wrapped by [e-mail] 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...