Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume23/abc/part03

Internet Message Format | 1991-01-08 | 54.2 KB

Subject:  v23i082:  ABC interactive programming environment, Part03/25
Newsgroups: comp.sources.unix
Approved: [e-mail]
X-Checksum-Snefru: 1668a0fa 4836bf62 71769fca ae7f365f

Submitted-by: Steven Pemberton <[e-mail]>
Posting-number: Volume 23, Issue 82
Archive-name: abc/part03

#! /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/keys/keydef.c abc/stc/i2tca.c
# Wrapped by [e-mail] on Mon Dec 17 13:27:52 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 3 (of 25)."'
if test -f 'abc/keys/keydef.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'abc/keys/keydef.c'\"
else
  echo shar: Extracting \"'abc/keys/keydef.c'\" \(29155 characters\)
  sed "s/^X//" >'abc/keys/keydef.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1989. */
X
X/* abckeys -- create a key definitions file interactively */
X
X#include "b.h"
X#include "bfil.h"
X#include "bmem.h"
X#include "feat.h"
X#include "keys.h"
X#include "getc.h"
X#include "trm.h"
X#include "release.h"
X#include "keydef.h"
X
Xchar *getenv();
X
XVisible bool intrflag= No; /* not used; only definition needed here */
X#ifdef SIGNAL
X#include <signal.h>
X#ifdef SIGTSTP
XVisible bool suspflag= No; /* idem */
X#endif
X#endif
XVisible bool in_vtrm= No;
XVisible bool raw_newline= No;
X
XVisible Procedure immexit(status) int status; {
X    endprocess(status);
X}
X
X#ifndef NDEBUG
XVisible bool dflag= No;
X#endif
X
XVisible FILE *errfile= stderr;
X
X#ifdef VTRMTRACE
XVisible FILE *vtrmfp= NULL;
X    /* -V vtrmfile: trace typechecker on vtrmfile; abc only */
X#endif
X
Xextern int errcount; /* Number of errors detected in key definitions */
X
Xextern string intr_char;
X#ifdef CANSUSPEND
Xextern string susp_char;
X#endif
X
X/******************************************************************/
X
X#define SNULL ((string) NULL)
X
X/*
X * definitions in deftab[0..nharddefs-1] are determined in ?1keys.c;
X * hardcoded, read in from termcap, and/or taken from tty-chars
X */
X
XVisible int nharddefs;
X
X/*
X * definitions in deftab[nharddefs..nfiledefs-1] come from current keysfile
X * (read in e1getc.c)
X */
X
XHidden int nfiledefs;
X
X/*
X * The new definitions the user supplies in this program are keep()ed
X * in deftab[nfiledefs..ndefs-1]
X */
X
X
X/*
X * The table can than be written to the new keydefinitions file:
X * first the definitions from the old keydefinitions file
X * that are still valid, in [nharddefs.. nfiledefs-1],
X * then the new ones, in [nfiledefs..ndefs-1].
X */
X
Xtypedef struct oper {
X    int code;        /* returned by inchar */
X    string name;        /* operation name */
X    int allowed;        /* may process */
X    string descr;        /* long description */
X} operation;
X
XHidden operation oplist[]= {
X    {WIDEN,        S_WIDEN,    0, "Widen focus"},
X    {EXTEND,    S_EXTEND,    0, "Extend focus"},
X    {FIRST,        S_FIRST,    0, "Focus to first contained item"},
X    {LAST,        S_LAST,        0, "Focus to last contained item"},
X    {PREVIOUS,    S_PREVIOUS,    0, "Focus to previous item"},
X    {NEXT,        S_NEXT,        0, "Focus to next item"},
X    {UPLINE,    S_UPLINE,    0, "Focus to whole line above"},
X    {DOWNLINE,    S_DOWNLINE,    0, "Focus to whole line below"},
X    {UPARROW,    S_UPARROW,    0, "Make hole, move up"},
X    {DOWNARROW,    S_DOWNARROW,    0, "Make hole, move down"},
X    {LEFTARROW,    S_LEFTARROW,    0, "Make hole, move left"},
X    {RITEARROW,    S_RITEARROW,    0, "Make hole, move right"},
X    {GOTO,        S_GOTO,        0, "New focus at cursor position"},
X    {ACCEPT,    S_ACCEPT,    0, "Accept suggestion, goto hole"},
X    {NEWLINE,    S_NEWLINE,    0, "New line, or decrease indent"},
X    {UNDO,        S_UNDO,        0, "Undo effect of last key pressed"},
X    {REDO,        S_REDO,        0, "Redo last UNDOne key"},
X    {COPY,        S_COPY,        0, "Copy focus to/from buffer"},
X    {DELETE,    S_DELETE,    0, "Delete focus (to buffer if empty)"},
X    {RECORD,    S_RECORD,    0, "Start/stop recording keystrokes"},
X    {PLAYBACK,    S_PLAYBACK,    0, "Play back recorded keystrokes"},
X    {REDRAW,    S_LOOK,        0, "Redisplay the screen"},
X    {HELP,        S_HELP,        0, "Display summary of keys"},
X    {EXIT,        S_EXIT,        0, "Finish unit or execute command"},
X    {CANCEL,    S_INTERRUPT,    0, "Interrupt a computation"},
X    {SUSPEND,    S_SUSPEND,    0, "Suspend the process"},
X    {IGNORE,    S_IGNORE,    0, "Unbind this key sequence"},
X    {TERMINIT,    S_TERMINIT,    0, "string to be sent to the screen at startup"},
X    {TERMDONE,    S_TERMDONE,    0, "string to be sent to the screen upon exit"},
X    /* last entry, op->name == SNULL : */
X    {0,         SNULL,         0, SNULL}
X};
X
X#define ONULL ((operation *) NULL)
X
XHidden operation *findoperation(name) string name; {
X    operation *op;
X
X    for (op= oplist; op->name != SNULL; op++) {
X        if (strcmp(op->name, name) == 0)
X            return op;
X    }
X    return ONULL;
X}
X
XVisible Procedure confirm_operation(code, name) int code; string name; {
X    operation *op;
X
X    for (op= oplist; op->name != SNULL; op++) {
X        if (code == op->code) {
X            op->allowed= 1;
X            op->name= name; /* to be sure */
X        }
X    }
X}
X
X#define Inchar()     (cvchar(trminput()))
X
X#define Printable(c)    (isascii(c) && (isprint(c) || (c) == ' '))
X#define CRLF(c)        (Creturn(c) || Clinefeed(c))
X#define Creturn(c)    ((c) == '\r')
X#define Clinefeed(c)    ((c) == '\n')
X#define Cbackspace(c)    ((c) == '\b')
X#define Ctab(c)        ((c) == '\t')
X#define Cspace(c)    ((c) == ' ')
X
X#define Empty(d)    (strlen(d) == 0)
X#define Val(d)        ((d) != SNULL && !Empty(d))
X
X#define Equal(s1, s2)    (strcmp(s1, s2) == 0)
X
X/****************************************************************************/
X
XHidden string newfile= SNULL;    /* name for new keydefinitions file */
X
Xmain(argc, argv) int argc; char *argv[]; {
X    string arg0= argv[0];
X    string cp;
X    int c;
X
X    cp= strrchr(arg0, DELIM);
X    if (cp)
X        arg0= cp+1;
X
X    initfmt();
X
X    if (argc != 1) /* no arguments allowed */
X        usage(arg0);
X
X    init();
X
X    checking();
X
X    process();
X
X    fini();
X
X    exit(0);
X}
X
X/****************************************************************************/
X
X/* immediate exit */
X
XHidden Procedure usage(name) string name; {
X    putSstr(errfile, "*** Usage: %s\n", name);
X    exit(1);
X}
X
XHidden Procedure endprocess(status) int status; {
X    fini_term();
X    exit(status);
X}
X
XVisible Procedure syserr(s) string s; {
X    putSstr(errfile, "*** System error: %s\n", s);
X    endprocess(-1);
X}
X
XVisible Procedure memexh() {
X    static bool beenhere= No;
X    if (beenhere) endprocess(-1);
X    beenhere= Yes;
X    putstr(errfile, "*** Sorry, memory exhausted\n");
X    endprocess(-1);
X}
X
X/****************************************************************************/
X
XHidden Procedure init() {
X#ifdef MEMTRACE
X    initmem();
X#endif
X
X    initmess();
X    initfile();
X    initkeys();        /* fills deftab and ndefs in e1getc.c */
X    nfiledefs= ndefs;
X
X    init_newfile();
X    init_ignore();
X    init_strings();
X    init_term();
X    init_bindings();
X    init_buffers();
X}
X
XHidden Procedure fini() {
X#ifdef MEMTRACE
X    fini_buffers();
X#endif
X    fini_term();
X}
X
X
X/****************************************************************************/
X
XHidden Procedure checking() {
X    if (!Val(intr_char)) {
X        putdata(E_INTERRUPT, 0);
X        endprocess(1);
X    }
X}
X
X/****************************************************************************/
X
X#define DNULL (tabent *) NULL
X
XHidden tabent *finddefentry(code) int code;  {
X    tabent *d;
X
X    for (d= deftab+ndefs-1; d >= deftab; d--) {
X        if (code == d->code)
X            return d;
X    }
X    return DNULL;
X}
X
XHidden tabent *terminit= DNULL;
XHidden tabent *termdone= DNULL;
X
XHidden Procedure init_strings() {
X    terminit= finddefentry(TERMINIT);
X    termdone= finddefentry(TERMDONE);
X}
X
X/* Output a string to the terminal */
X
XHidden Procedure outstring(str) string str; {
X    fputs(str, stdout);
X    putnewline(stdout);
X    fflush(stdout);
X}
X
XHidden bool inisended= No;
X
XHidden Procedure sendinistring() {
X    if (terminit != DNULL && Val(terminit->def)) {
X        outstring(terminit->def);
X        redrawscreen();
X        inisended= Yes;
X    }
X    else clearwindow();
X}
X
XHidden Procedure sendendstring() {
X    if (!inisended)
X        return;
X    if (termdone != DNULL && Val(termdone->def)) {
X        outstring(termdone->def);
X    }
X}
X
X/****************************************************************************/
X
X/* screen stuff */
X
XHidden struct screen {
X    int yfirst, ylast;
X    int width;
X    int y, x;
X} win;
X
XHidden Procedure init_term() {
X    int height, width, flags;
X    int err;
X
X    err= trmstart(&height, &width, &flags);
X    if (err != TE_OK) {
X        if (err <= TE_DUMB)
X            putstr(errfile,
X"*** Bad $TERM or termcap, or dumb terminal\n");
X        else if (err == TE_BADSCREEN)
X            putstr(errfile,
X"*** Bad SCREEN environment\n");
X        else
X            putstr(errfile,
X"*** Cannot reach keyboard or screen\n");
X
X        exit(1);
X    }
X    in_vtrm= Yes;
X    raw_newline= Yes;
X    win.yfirst= 0;
X    win.ylast= height-1;
X    win.width= width-1;
X    win.y= win.yfirst;
X    win.x= 0;
X
X#define MINWIDTH 75
X#define MINHEIGHT 24
X
X    if (width < MINWIDTH || height < MINHEIGHT) {
X        put2Dstr(errfile,
X"*** Sorry, too small screen size; needed at least %dx%d; giving up\n",
X        MINHEIGHT, MINWIDTH);
X        endprocess(1);
X    }
X
X    if (errcount != 0) /* errors found reading definitions */
X        asktocontinue(win.ylast);
X#ifdef DUMPKEYS
X    if (dflag && errcount == 0)
X        asktocontinue(win.ylast);
X#endif
X    clearscreen();
X}
X
X/*
X * clearing the screen is done by scrolling instead of putting empty data
X * because there are systems (MSDOS, ANSI) where the latter leaves rubbish
X * on the screen
X */
X
XHidden Procedure clearscreen() {
X    trmscrollup(0, win.ylast, win.ylast + 1);
X}
X
XHidden int hlp_yfirst;
XHidden int hlp_nlines;
X
X#define Upd_bindings() putbindings(hlp_yfirst)
X
XHidden Procedure init_bindings() {
X    setup_bindings(win.width, &hlp_nlines);
X}
X
XHidden int nscrolls= 0;
X
XHidden Procedure set_windows(yfirst) int yfirst; {
X    hlp_yfirst= yfirst;
X    win.yfirst= hlp_yfirst + hlp_nlines + 1;
X    win.y= win.yfirst;
X    win.x= 0;
X    nscrolls= 0;
X}
X
XHidden Procedure clearwindow() {
X    trmputdata(win.yfirst, win.ylast, 0, "");
X    win.y= win.yfirst;
X    win.x= 0;
X    nscrolls= 0;
X    trmsync(win.y, win.x);
X}
X
XHidden Procedure redrawscreen() {
X    bind_all_changed();
X    clearscreen();
X    set_windows(0);
X    Upd_bindings();
X}
X
XHidden Procedure fini_term() {
X    if (in_vtrm) {
X#ifdef MEMTRACE
X        fini_bindings();
X#endif
X        nextline();
X        sendendstring();
X        trmend();
X    }
X    in_vtrm= No;
X}
X
X/* TODO: indent > width-1 */
X
X#define Too_width(data, bound) (strlen(data) > (bound))
X
XHidden Procedure putdata(data, indent) string data; int indent; {
X    static string buf= SNULL;
X    int width= win.width;
X    int len;
X    string q;
X
X    if (data == SNULL)
X        return;
X    if (buf == SNULL)
X        buf= (string) getmem((unsigned) width+1);
X
X    if (indent == 0 && strlen(data) > 0 && win.x > 0)
X        nextline();
X
X    while (Too_width(data, width-indent)) {
X        q= data + width-1-indent;
X        while (q - data > 0 && *q != ' ')
X            --q;
X        len= q - data;
X        if (len > 0 && len < width-indent)
X            ++len;
X        else
X            len= width-indent;
X        strncpy(buf, data, len);
X        buf[len]= '\0';
X        data+= len;
X        trmputdata(win.y, win.y, indent, buf);
X        nextline();
X        indent= 0;
X    }
X    trmputdata(win.y, win.y, indent, data);
X    win.x= indent+strlen(data);
X    trmsync(win.y, win.x);
X}
X
X#define CONTINUE_GIVEN (nscrolls == 1)
X
XHidden Procedure nextline() {
X    if (win.y == win.ylast-1) {
X        if (nscrolls == 0 || nscrolls == (win.ylast - win.yfirst)) {
X            asktocontinue(win.ylast);
X            nscrolls= 0;
X        }
X        trmscrollup(win.yfirst, win.ylast, 1);
X        nscrolls++;
X    }
X    else {
X        win.y++;
X        nscrolls= 0;
X    }
X    trmsync(win.y, win.x= 0);
X}
X
X#define SOBIT 0200
X#define MAXBUFFER 81
X
XHidden string mkstandout(data) string data; {
X    static char buffer[MAXBUFFER];
X    string cp;
X
X    strcpy(buffer, data);
X    for (cp= buffer; *cp; cp++)
X        *cp |= SOBIT;
X
X    return (string) buffer;
X}
X
X#define CONTINUE_PROMPT "Press [SPACE] to continue "
X
XHidden Procedure asktocontinue(y) int y; {
X    int c;
X    string data= mkstandout(CONTINUE_PROMPT);
X
X    trmputdata(y, y, 0, data);
X        /*
X         * putdata() isn't called to avoid a call of nextline();
X         * there is no harm in that if the data can fit on one line
X         */
X    trmsync(y, strlen(data));
X    for (;;) {
X        c= Inchar();
X        if (Cspace(c) || c == EOF)
X            break;
X        trmbell();
X    }
X    trmputdata(y, y, 0, "");
X}
X
X/****************************************************************************/
X
X/* buffer stuff */
X
XHidden char fmtbuf[BUFSIZ];    /* to make formatted messages */
X
XHidden bufadm definpbuf;    /* to save definitions from input */
XHidden bufadm repinpbuf;    /* to save representations from input */
XHidden bufadm reprbuf;        /* to save reprs from defs */
X
XHidden Procedure init_buffers() {
X    bufinit(&definpbuf);
X    bufinit(&repinpbuf);
X    bufinit(&reprbuf);
X}
X
X#ifdef MEMTRACE
X
XHidden Procedure fini_buffers() {
X    buffree(&definpbuf);
X    buffree(&repinpbuf);
X    buffree(&reprbuf);
X}
X
X#endif
X
XHidden string getbuf(bp) bufadm *bp; {
X    bufpush(bp, '\0');
X    return (string) bp->buf;
X}
X
X/****************************************************************************/
X
X#ifndef NULL_EXTENDED
X
X#define MAXAVAILABLE 100
X
XHidden int available[MAXAVAILABLE];    /* save chars from trmavail() */
XHidden int navailable= 0;        /* nr of available chars */
XHidden int iavailable= 0;        /* next available character */
X
X/*
X * attempt to recognize key sequences using trmavail();
X * it works if the user presses the keys one after another not too fast;
X * be careful: if trmavail() isn't implemented it still has to work!
X * returns -1 for EOF, 0 for extended chars, >0 for 'normal' chars.
X */
X
XHidden int inchar() {
X    int c;
X
X    if (iavailable != navailable) {        /* char in buffer */
X        c= available[iavailable++];
X        if (iavailable == navailable)
X            iavailable= navailable= 0;
X        return c;
X    }
X
X    c= Inchar();    /* returns -1 or >0 */
X
X    while (c != EOF && trmavail() == 1) {
X        available[navailable++]= c;
X        c= Inchar();
X    }
X    if (navailable == 0)            /* no char available */
X        return c;
X    else {
X        available[navailable++]= c;
X        return 0;
X    }
X}
X
XHidden string findrepr(def) string def; {
X    tabent *d;
X    string findoldrepr();
X    string rep;
X
X    for (d= deftab+ndefs-1; d >= deftab; d--) {
X        if (Val(d->def) && Equal(d->def, def) && Val(d->rep))
X            return d->rep;
X    }
X    return findoldrepr(def);
X}
X
X/*
X * try to find a representation for thw whole sequence in the buffer
X */
X
XHidden bool knownkeysequence(key, rep) string *key, *rep; {
X    string pkey;
X    int n;
X
X    if (navailable < 2)            /* no sequence */
X        return No;
X
X    /* make sequence */
X    *key= pkey= (string) getmem((unsigned) (navailable+1));
X    for (n= 0; n < navailable; n++)
X        *pkey++= available[n];
X    *pkey= '\0';
X
X    if ((*rep= findrepr(*key)) != SNULL) {
X        iavailable= navailable= 0;     /* empty buffer */
X        return Yes;
X    }
X    freemem((ptr) *key);
X    return No;
X}
X
X#endif /* ! NULL_EXTENDED */
X
X/****************************************************************************/
X
X/*
X * get a key sequence from input, delimited by \r (or \n)
X * if you want that delimiter in your binding,
X * enclose the entire binding with single or double quotes
X */
X
X#define NEW_KEY    "Press new key(s) for %s (%s)"
X
X#define Quote(c) ((c) == '\"' || (c) == '\'')
X
XHidden string ask_definition(op, prepr) operation *op; string *prepr; {
X    int c;
X    string def;
X    string repr;
X    bufadm *dp= &definpbuf;
X    bufadm *rp= &reprbuf;
X    char quot_repr[20];
X    bool quoting= No;
X    bool first= Yes;
X
X    sprintf(fmtbuf, NEW_KEY, op->name, op->descr);
X    putdata(fmtbuf, 0);
X    nextline();
X
X    bufreinit(dp);
X    bufreinit(rp);
X
X    for (;; first= No) {
X
X#ifdef NULL_EXTENDED
X
X        c= Inchar();
X
X#else /* ! NULL_EXTENDED */
X
X        c= inchar();
X        if (c == 0) { /* there are chars in the buffer */
X            if (knownkeysequence(&def, &repr)) {
X                savputrepr(rp, repr);    /* save and put repr */
X                bufcpy(dp, def);    /* save key */
X                freemem((ptr) def);
X                continue;
X            }
X            else c= inchar(); /* get char out of buffer */
X                      /* note: c != 0 */
X        }
X
X#endif /* ! NULL_EXTENDED */
X
X        if (c == EOF)
X            break;
X        if (Eok(c)) {        /* end of key sequence */
X            if (!quoting)
X                break;
X            if (Equal(repr, quot_repr)) {
X                    /* pop quote from key buffer: */
X                --(dp->ptr);
X                    /* pop quote from rep buffer: */
X                rp->ptr-= strlen(repr) + 1;
X                break;
X            }
X        }
X        if (first && Quote(c)) {
X            quoting= Yes;
X            repr= reprchar(c);
X            strcpy(quot_repr, repr);
X            putdata(repr, win.x);    /* no save */
X            putdata(" ", win.x);
X            repr= "";        /* to prevent equality above */
X        }
X        else {
X            repr= reprchar(c);
X            savputrepr(rp, repr);    /* save and put repr */
X            bufpush(dp, c);        /* save key */
X        }
X    }
X    *prepr= getbuf(rp);
X
X    return getbuf(dp);
X}
X
X/* save and put the representation */
X
XHidden Procedure savputrepr(rp, repr) bufadm *rp; string repr; {
X    if (strlen(repr) > 0) {
X        /* save */
X        if (rp->ptr != rp->buf) /* not the first time */
X            bufpush(rp, ' ');
X        bufcpy(rp, repr);
X
X        /* put */
X        putdata(repr, win.x);
X        putdata(" ", win.x);
X    }
X}
X
XHidden string new_definition(op, prepr) operation *op; string *prepr; {
X    string def;
X
X    if (op == ONULL)
X        return SNULL;
X    for (;;) {
X        def= ask_definition(op, prepr);
X        if (op->code < 0) /* string-valued */
X            return def;
X        if (!illegal(def))
X            return def;
X    }
X}
X
XHidden bool illegal(def) string def; {
X    if (Empty(def))
X        return No;
X    if  (Printable(*def)) {
X        sprintf(fmtbuf, E_ILLEGAL, *def);
X        putdata(fmtbuf, 0);
X        return Yes;
X    }
X    for (; *def; def++) {
X        if (is_spchar(*def)) {
X            putdata(E_SPCHAR, 0);
X            return Yes;
X        }
X    }
X    return No;
X}
X
X/****************************************************************************/
X
X/*
X * getinput() reads characters from input delimited by \r or \n
X */
X
XHidden string getinput(bp)  bufadm *bp; {
X    int c;
X    char echo[2];
X
X    echo[1]= '\0';
X    bufreinit(bp);
X    for (;;) {
X        c= Inchar();
X        if (c == EOF || CRLF(c))
X            break;
X
X        if (Cbackspace(c)) {
X            if (bp->ptr == bp->buf)        /* no chars */
X                trmbell();
X            else {
X                if (win.x == 0) {    /* begin of line */
X                    --win.y;
X                    win.x= win.width;
X                }
X                putdata("", --win.x);
X                --(bp->ptr);    /* pop character from buffer */
X            }
X        }
X        else if (Printable(c)) {
X            echo[0]= c;
X            putdata(echo, win.x);
X            bufpush(bp, c);
X        }
X        else trmbell();
X    }
X    return getbuf(bp);
X}
X
X/****************************************************************************/
X
X#define ALPHA_REP "Enter an alpha-numeric representation for this definition"
X
X#define DFLT_REP " [default %s] "
X
XHidden string ask_representation(dfltrep) string dfltrep; {
X    int len= strlen(DFLT_REP) + strlen(dfltrep);
X    char *dflt= (char *) getmem((unsigned) (len+1));
X    /* we don't use fmtbuf, because the 'dfltrep' can be very long */
X
X    putdata(ALPHA_REP, 0);
X    sprintf(dflt, DFLT_REP, dfltrep);
X    putdata(dflt, 0);
X    freemem((ptr) dflt);
X    return getinput(&repinpbuf);
X}
X
XHidden string new_representation(dfltrep, def) string dfltrep, def; {
X    string repr;
X
X    for (;;) {
X        repr= ask_representation(dfltrep);
X
X        if (Empty(repr)) /* accept default */
X            return dfltrep;
X        if (unlawful(repr) || rep_in_use(repr, def))
X            continue;
X        return repr;
X    }
X}
X
XHidden string representation(def) string def; {
X    bufadm *rp= &reprbuf;
X    string repr;
X
X    bufreinit(rp);
X
X    for (; *def; def++) {
X        repr= reprchar(*def);
X        if (strlen(repr) > 0) {
X            bufcpy(rp, repr);
X            if (*(def+1) != '\0') {
X                bufpush(rp, ' ');
X            }
X        }
X    }
X    return getbuf(rp);
X}
X
XHidden bool unlawful(rep) string rep; {
X    for (; *rep; rep++) {
X        if (!Printable(*rep)) {
X            putdata(E_UNLAWFUL, 0);
X            return Yes;
X        }
X    }
X
X    return No;
X}
X
XHidden bool rep_in_use(rep, def) string rep, def; {
X    tabent *d;
X
X    for (d= deftab; d < deftab+ndefs; d++) {
X        if (Val(d->rep) && Equal(rep, d->rep)
X            &&
X            Val(d->def) && !Equal(def, d->def)
X            &&
X            d->code != DELBIND
X           ) {
X            sprintf(fmtbuf, E_IN_USE, d->name);
X            putdata(fmtbuf, 0);
X            return Yes;
X        }
X    }
X    return No;
X}
X
X/****************************************************************************/
X
XHidden Procedure keep(code, name, def, rep) int code; string name, def, rep; {
X    if (ndefs == MAXDEFS) {
X        putdata(E_TOO_MANY, 0);
X        return;
X    }
X    undefine(code, def);
X    deftab[ndefs].code= code;
X    deftab[ndefs].name= name;
X    deftab[ndefs].def= (string) savestr(def);
X    deftab[ndefs].rep= (string) savestr(rep);
X    ndefs++;
X}
X
XHidden Procedure store(code, name, def, rep) int code; string name, def, rep; {
X    tabent *d;
X
X    if (code > 0) {
X        keep(code, name, def, rep);
X    }
X    else {    /* code < 0; string-valued entry */
X        /* find the place matching name to replace definition */
X            for (d= deftab; d < deftab+ndefs; ++d) {
X            if (code == d->code) {
X                               d->def= (string) savestr(def);
X                               d->rep= (string) savestr(rep);
X                               break;
X            }
X        }
X    }
X    bind_changed(code);
X}
X
X/****************************************************************************/
X
X#define I_OP_PROMPT "Enter operation [? for help]: "
X#define OP_PROMPT   "Enter operation: "
X
XHidden string ask_name(prompt) string prompt; {
X    putdata(prompt, 0);
X    return getinput(&definpbuf);
X}
X
XHidden Procedure print_heading() {
X    sprintf(fmtbuf, ABC_RELEASE, RELEASE);
X    putdata(fmtbuf, 0);
X    nextline();
X    putdata(COPYRIGHT, 0);
X    nextline();
X    putdata(HEADING, 0);
X    nextline();
X    nextline();
X}
X
XHidden Procedure process() {
X    operation *op;
X    string name;
X    bool show;
X    bool del;
X    bool first= Yes;
X    int ysave;
X
X    print_heading();
X
X    ysave= win.y;
X
X    set_windows(win.y);
X    Upd_bindings();
X
X    for (;;) {
X        if (first) {
X            name= ask_name(I_OP_PROMPT);
X            scrolloff_heading(ysave);
X            first= No;
X        }
X        else {
X            setpromptline();
X            name= ask_name(OP_PROMPT);
X        }
X        if (Empty(name))
X            continue;
X        if (Equal(name, "?")) {
X            help();
X            continue;
X        }
X        show= *name == '=';
X        del= *name == '-';
X        if (show || del) name++;
X
X        if (is_quit(name)) {
X            if (!del)
X                putkeydefs();
X            break;
X        }
X        else if (is_init(name)) {
X            nextline();
X            sendinistring();
X            continue;
X        }
X
X        sprintf(fmtbuf, "[%s]", name);
X        op= findoperation(fmtbuf);
X
X        if (op == ONULL || !op->allowed) {
X            putdata(E_UNKNOWN, 0);
X            continue;
X        }
X        if (!show && spec_operation(op)) {
X            sprintf(fmtbuf, E_NOTALLOWED, name);
X            putdata(fmtbuf, 0);
X            continue;
X        }
X
X        if (show)
X            showbindings(op);
X        else if (del)
X            delbindings(op);
X        else
X            definebinding(op);
X    }
X}
X
XHidden bool is_quit(name) string name; {
X    if (Equal(name, "q") || Equal(name, "quit"))
X        return Yes;
X    return No;
X}
X
XHidden bool is_init(name) string name; {
X    if (Equal(name, "init"))
X        return Yes;
X    return No;
X}
X
XHidden bool spec_operation(op) operation *op; {
X    if (op->code == CANCEL || op->code == SUSPEND)
X        return Yes;
X    return No;
X}
X
XHidden Procedure scrolloff_heading(n) int n; {
X    int y= win.y, x= win.x;        /* save old values */
X
X    trmscrollup(0, win.ylast, n);
X    set_windows(0);
X    win.y= y - n;
X    win.x= x;
X}
X
XHidden Procedure setpromptline() {
X    if (win.y != win.yfirst || win.x > 0) {
X        if (win.x > 0)
X            nextline();
X        if (!CONTINUE_GIVEN)
X            nextline();
X        if (CONTINUE_GIVEN)
X            clearwindow();
X    }
X}
X
X/****************************************************************************/
X
XHidden Procedure definebinding(op) operation *op; {
X    string def, rep;
X
X    clearwindow();
X    def= new_definition(op, &rep);
X    if (!Val(def))
X        return;
X
X#ifndef KNOWN_KEYBOARD
X    rep= new_representation(rep, def);
X#else
X    if (op->code == TERMINIT || op->code == TERMDONE)
X        rep= new_representation(rep, def);
X#endif
X
X    store(op->code, op->name, def, rep);
X    Upd_bindings();
X}
X
X#define SHOW_PROMPT "Showing the bindings for %s (%s):"
X
XHidden Procedure showbindings(op) operation *op; {
X    tabent *d;
X
X    clearwindow();
X    sprintf(fmtbuf, SHOW_PROMPT, op->name, op->descr);
X    putdata(fmtbuf, 0);
X
X    for (d= deftab+ndefs-1; d >= deftab; d--) {
X        if (d->code != op->code || !Val(d->def) || !Val(d->rep))
X            continue;
X        putdata(d->rep, 0);
X    }
X}
X
XHidden Procedure delbindings(op) operation *op; {
X    tabent *d;
X
X    for (d= deftab; d < deftab+ndefs; d++) {
X        if (d->code == op->code && Val(d->def)) {
X            store(DELBIND, S_IGNORE, d->def, d->rep);
X            d->def= d->rep= SNULL;
X            bind_changed(d->code);
X        }
X    }
X    Upd_bindings();
X    clearwindow();
X}
X
X/****************************************************************************/
X
XHidden tabent savedeftab[MAXDEFS];
XHidden int nsaveharddefs= 0;
XHidden int nsavefiledefs= 0;
X
X
XVisible Procedure saveharddefs() {
X    tabent *d, *h;
X
X    for (d= deftab, h= savedeftab; d < deftab+nharddefs; d++) {
X        if (Val(d->name) && Val(d->def)) {
X            h->code= d->code;
X            h->name= d->name;
X            h->def= d->def;
X            h->rep= d->rep;
X            h++;
X        }
X    }
X    nsaveharddefs= h-savedeftab;
X}
X
XVisible Procedure savefiledefs() {
X    tabent *d, *h;
X
X    d= deftab + nharddefs;
X    h= savedeftab + nsaveharddefs;
X    for (; d < deftab + ndefs; d++) {
X        if (Val(d->name) && Val(d->def)) {
X            h->code= d->code;
X            h->name= d->name;
X            h->def= d->def;
X            h->rep= d->rep;
X            h++;
X        }
X    }
X    nsavefiledefs= h-savedeftab;
X}
X
XHidden bool a_harddef(d) tabent *d; {
X    tabent *h;
X
X    if (!Val(d->def))
X        return No;
X    for (h= savedeftab; h < savedeftab+nsaveharddefs; h++) {
X        if (Equal(d->def, h->def) &&
X            Equal(d->rep, h->rep) &&    /* TODO: needed ? */
X            (d->code == h->code ||
X             d->code == IGNORE ||
X             d->code == DELBIND
X            )
X           )
X            return Yes;
X    }
X    return No;
X}
X
XHidden Procedure init_ignore() {
X    tabent *d;
X
X    for (d= deftab+nharddefs; d < deftab+ndefs; d++) {
X        if (d->code == IGNORE && a_harddef(d))
X            /* don't show it in the bindings window */
X            d->code= DELBIND;
X    }
X}
X
X#ifndef NULL_EXTENDED
X
XHidden string findoldrepr(def) string def; {
X    tabent *h;
X
X    h= savedeftab + nsavefiledefs - 1;
X    for (; h >= savedeftab; h--) {
X        if (Val(h->def) && Equal(h->def, def) && Val(h->rep))
X            return h->rep;
X    }
X    return SNULL;
X}
X
X#endif /* ! NULL_EXTENDED */
X
X/****************************************************************************/
X
XFILE *keyfp;            /* fileptr for key definitions file */
X
XHidden Procedure putkeydefs() {
X    openkeyfile();
X    put_table();
X    put_strings();
X    closekeyfile();
X}
X
XHidden Procedure init_newfile() {
X    char *termname;
X    string termfile;
X
X#ifdef KEYSPREFIX
X    if ((termname= getenv("TERM")) != NULL) {
X        termfile= (string) getmem((unsigned) strlen(KEYSPREFIX)+strlen(termname));
X        strcpy(termfile, KEYSPREFIX);
X        strcat(termfile, termname);
X    }
X    else
X#endif /*KEYSPREFIX*/
X        termfile= savestr(NEWFILE);
X
X    if (bwsdefault
X        && (D_exists(bwsdefault) || Mkdir(bwsdefault) == 0)
X        && F_writable(bwsdefault))
X    {
X        newfile= makepath(bwsdefault, termfile);
X    }
X    else {
X        putSstr(errfile,
X        "Cannot use directory \"%s\" for private keydefinitions file\n",
X            bwsdefault);
X        putSstr(errfile,
X        "Cannot use directory \"%s\" for private keydefinitions file",
X            bwsdefault);
X
X        newfile= termfile;
X    }
X}
X
X#define MAKE_KEYFILE "Producing key definitions file %s."
X
XHidden Procedure openkeyfile() {
X    keyfp= fopen(newfile, "w");
X    nextline();
X    if (keyfp == NULL) {
X        sprintf(fmtbuf, E_KEYFILE, newfile);
X        putdata(fmtbuf, 0);
X        keyfp= stdout;
X    }
X    else {
X        sprintf(fmtbuf, MAKE_KEYFILE, newfile);
X        putdata(fmtbuf, 0);
X    }
X    freemem(newfile);
X}
X
XHidden Procedure closekeyfile() {
X    fclose(keyfp);
X}
X
XHidden Procedure put_table() {
X    tabent *d;
X
X    for (d= deftab+nharddefs; d < deftab+ndefs; d++) {
X        if (Val(d->def)) {
X            if (d->code != IGNORE) {
X                if (d->code == DELBIND) {
X                    if (!a_harddef(d))
X                        continue;
X                }
X                else if (a_harddef(d))
X                    continue;
X            }
X            put_def(d->name, d->def, d->rep);
X        }
X    }
X}
X
XHidden Procedure put_strings() {
X    if (terminit != DNULL && Val(terminit->def)) {
X        string rep= terminit->rep;
X        put_def(S_TERMINIT, terminit->def, Val(rep) ? rep : "");
X    }
X    else put_def(S_TERMINIT, "", "");
X
X    if (termdone != DNULL && Val(termdone->def)) {
X        string rep= termdone->rep;
X        put_def(S_TERMDONE, termdone->def, Val(rep) ? rep : "");
X    }
X    else put_def(S_TERMDONE, "", "");
X}
X
X#define NAMESPACE 15 /* TODO: e1getc.c accepts until 20 */
X
XHidden Procedure put_def(name, def, rep) string name, def, rep; {
X    int i;
X    string s;
X
X    i= 0;
X    for (s= name; *s; s++) {
X        putchr(keyfp, *s);
X        i++;
X    }
X    while (i < NAMESPACE) {
X        putchr(keyfp, ' ');
X        i++;
X    }
X    putstr(keyfp, " = ");
X    putchr(keyfp, '"');
X    for (s= def; *s != '\0'; ++s) {
X        if (*s == '"')
X            putchr(keyfp, '\\');
X        if (Printable(*s))
X            putchr(keyfp, *s);
X        else
X            putDstr(keyfp, "\\%03o", (int) (*s&0377));
X    }
X    putchr(keyfp, '"');
X    putSstr(keyfp, " = \"%s\"\n", rep);
X}
X
X/****************************************************************************/
X
X#define HELP_PROMPT    "Press [SPACE] to continue, [RETURN] to exit help"
X
XHidden Procedure help() {
X    clearwindow();
X    shorthelp();
X    if (morehelp()) {
X        clearwindow();
X        longhelp();
X    }
X    else
X        clearwindow();
X}
X
XHidden Procedure shorthelp() {
X    putdata(" name: (re)define binding for \"name\",", 0);
X    putdata("-name: remove all the bindings for \"name\"", 0);
X    putdata("=name: show all the bindings for \"name\"", 0);
X    putdata(" quit: exit this program, saving the changes", 0);
X    putdata("-quit: exit this program", 0);
X    putdata(" init: send term-init string to screen", 0);
X}
X
XHidden bool morehelp() {
X    int c;
X    int y= win.y+1;
X    string prompt= mkstandout(HELP_PROMPT);
X    bool ans;
X
X    if (y < win.ylast)
X        y++;
X    trmputdata(y, y, 0, prompt);
X    trmsync(y, strlen(prompt));
X
X    for (;;) {
X        c= Inchar();
X        if (c == EOF || CRLF(c))
X            { ans= No; break; }
X        else if (Cspace(c))
X            { ans= Yes; break; }
X        else
X            trmbell();
X    }
X    trmputdata(y, y, 0, "");
X    return ans;
X}
X
XHidden Procedure longhelp() {
X
Xputdata("    While (re)defining a binding, the program will ask you to enter \
Xa key sequence; end it with [RETURN].", 0);
X
Xputdata("If you want [RETURN] in your binding, enclose the whole binding \
Xwith single or double quotes.", 0);
X
X#ifndef KNOWN_KEYBOARD
X
Xputdata("It will then ask you how to represent this key in the bindings \
Xwindow; the default can be accepted with [RETURN].", 0);
X
X#endif /* KNOWN_KEYBOARD */
X
Xputdata("    [term-init] and [term-done] are the names for the strings that \
Xshould be sent to the screen upon startup and exit, respectively (for \
Xprogramming function keys or setting background colours etc).", 0);
X
Xsprintf(fmtbuf,
X"    This program will not allow you to use your interrupt character (%s) in \
Xany keybinding, since the ABC system always binds this to %s.",
X    representation(intr_char), S_INTERRUPT);
Xputdata(fmtbuf, 0);
X
X#ifdef CANSUSPEND
X
Xif (susp_char != SNULL) {
Xsprintf(fmtbuf, "The same holds for your suspend character (%s), bound to %s.",
X    representation(susp_char), S_SUSPEND);
Xputdata(fmtbuf, 0);
X            }
X#endif /* CANSUSPEND */
X
Xputdata("You can use this idiosyncrasy to cancel a binding while typing \
Xby including your interrupt character.", 0);
X
Xputdata("   The space in the window above sometimes isn't sufficient to \
Xshow all the bindings. You will recognize this situation by a marker \
X('*') after the name. Hence the option '=name'.", 0);
X
X}
END_OF_FILE
  if test 29155 -ne `wc -c <'abc/keys/keydef.c'`; then
    echo shar: \"'abc/keys/keydef.c'\" unpacked with wrong size!
  fi
  # end of 'abc/keys/keydef.c'
fi
if test -f 'abc/stc/i2tca.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'abc/stc/i2tca.c'\"
else
  echo shar: Extracting \"'abc/stc/i2tca.c'\" \(21735 characters\)
  sed "s/^X//" >'abc/stc/i2tca.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, amsterdam, 1988. */
X
X/* ABC type check */
X
X#include "b.h"
X#include "bmem.h"
X#include "bfil.h"
X#include "bint.h"
X#include "bobj.h"
X#include "b0lan.h"
X#include "i2nod.h"
X#include "i2par.h"
X#include "i2stc.h"
X#include "i3env.h"    /* for curline and curlino */
X#include "i3sou.h"    /* for is_udfpr and args */
X
X#define WRONG_ARGUMENT    MESS(2300, "wrong argument of type_check()")
X#define WARNING_DUMMY    MESS(2301, "next line must be impossible as a refinement name, e.g. with a space:")
X#define RETURNED_VALUE    GMESS(2302, "returned value")
X#define WRONG_RETURN    MESS(2303, "RETURN not in function or expression refinement")
X#define EMPTY_STACK    MESS(2304, "Empty polytype stack")
X
X/* ******************************************************************** */
X
Xchar *tc_code[NTYPES] = {    /* Type checker table; */
X                /* see comment below for meaning of codes */
X/* How-to's */
X
X    /* HOW_TO */ "-s-csH",
X    /* YIELD */ "--p-YcysF",
X    /* TEST */ "--p-csP",
X    /* REFINEMENT */ "--Rcys",
X
X/* Commands */
X
X    /* SUITE */ "Lc-c",
X    /* PUT */ "eeU",
X    /* INSERT */ "e}eU",
X    /* REMOVE */ "e}eU",
X    /* SET_RANDOM */ "e*",
X    /* DELETE */ "e*",
X    /* CHECK */ "t*",
X    /* SHARE */ "",
X    /* PASS */ "",
X
X    /* WRITE */ "-?e*",
X    /* WRITE1 */ "-?e*",
X    /* READ */ "eeU",
X    /* READ_RAW */ "e'U",
X
X    /* IF */ "t*-c",
X    /* WHILE */ "Lt*-c",
X    /* FOR */ "e#eU-c",
X
X    /* SELECT */ "-c",
X    /* TEST_SUITE */ "L?t*-cc",
X    /* ELSE */ "L-c",
X
X    /* QUIT */ "",
X    /* RETURN */ "erU",
X    /* REPORT */ "t*",
X    /* SUCCEED */ "",
X    /* FAIL */ "",
X
X    /* USER_COMMAND */ "A-sC",
X    /* EXTENDED_COMMAND */ "",
X
X/* Expressions, targets, tests */
X
X    /* TAG */ "T",
X    /* COMPOUND */ "e",
X
X/* Expressions, targets */
X
X    /* COLLATERAL */ ":(<e,>)",
X    /* SELECTION */ "we~e~]U",
X    /* BEHEAD */ "e'UenU'",
X    /* CURTAIL */ "e'UenU'",
X
X/* Expressions, tests */
X
X    /* UNPARSED */ "v",
X
X/* Expressions */
X
X    /* MONF */ "-eM",
X    /* DYAF */ "e-eD",
X    /* NUMBER */ "n",
X    /* TEXT_DIS */ "-s'",
X    /* TEXT_LIT */ "-s",
X    /* TEXT_CONV */ "e*s",
X    /* ELT_DIS */ "v{",
X    /* LIST_DIS */ ":e<eu>}",
X    /* RANGE_BNDS */ "e.ueu",
X    /* TAB_DIS */ ":ee<~eu~eu>]",
X
X/* Tests */
X
X    /* AND */ "t*t",
X    /* OR */ "t*t",
X    /* NOT */ "t",
X    /* SOME_IN */ "e#eUt",
X    /* EACH_IN */ "e#eUt",
X    /* NO_IN */ "e#eUt",
X    /* MONPRD */ "-em",
X    /* DYAPRD */ "e-ed",
X    /* LESS_THAN */ "eeu",
X    /* AT_MOST */ "eeu",
X    /* GREATER_THAN */ "eeu",
X    /* AT_LEAST */ "eeu",
X    /* EQUAL */ "eeu",
X    /* UNEQUAL */ "eeu",
X    /* Nonode */ "",
X
X    /* TAGformal */ "T",
X    /* TAGlocal */ "T",
X    /* TAGglobal */ "T",
X    /* TAGrefinement */ "T",
X    /* TAGzerfun */ "Z",
X    /* TAGzerprd */ "z",
X
X    /* ACTUAL */ "-?aes",
X    /* FORMAL */ "-?fes",
X
X#ifdef GFX
X    /* SPACE */ "eeU",
X    /* LINE */ "eeU",
X    /* CLEAR */ "",
X#endif
X
X    /* COLON_NODE */ "c"
X
X};
X
X/************************************************************************/
X
XHidden char *zerf[]= {
X    F_pi, "n",
X    F_e, "n",
X    F_random, "n",
X    F_now, "(6n,0n,1n,2n,3n,4n,5)",
X    NULL
X};
X
XHidden char *monf[]= {
X    S_ABOUT, "nUn",
X    S_PLUS, "nUn",
X    S_MINUS, "nUn",
X    S_NUMERATOR, "nUn",
X    S_DENOMINATOR, "nUn",
X    F_root, "nUn",
X    F_abs, "nUn",
X    F_sign, "nUn",
X    F_floor, "nUn",
X    F_ceiling, "nUn",
X    F_round, "nUn",
X    F_exactly, "nUn",
X    F_sin, "nUn",
X    F_cos, "nUn",
X    F_tan, "nUn",
X    F_arctan, "nUn",
X    F_exp, "nUn",
X    F_log, "nUn",
X    F_lower, "'U'",
X    F_upper, "'U'",
X    F_stripped, "'U'",
X    F_split, "'Un']",
X    F_keys, "wv]%U}",
X    S_NUMBER, "v#Un",
X    F_min, "w#%U",
X    F_max, "w#%U",
X    F_choice, "w#%U",
X    F_radius, "(2n,0n,1)Un",
X    F_angle, "(2n,0n,1)Un",
X    NULL
X};
X
XHidden char *dyaf[]= {
X    S_PLUS, "nUnUn",
X    S_MINUS, "nUnUn",
X    S_TIMES, "nUnUn",
X    S_OVER, "nUnUn",
X    S_POWER, "nUnUn",
X    F_root, "nUnUn",
X    F_round, "nUnUn",
X    F_mod, "nUnUn",
X    F_sin, "nUnUn",
X    F_cos, "nUnUn",
X    F_tan, "nUnUn",
X    F_arctan, "nUnUn",
X    F_log, "nUnUn",
X    S_JOIN, "'U'U'",
X    S_BEHEAD, "nU'U'",
X    S_CURTAIL, "nU'U'",
X    S_REPEAT, "nU'U'",
X    S_LEFT_ADJUST, "nU*'",
X    S_CENTER, "nU*'",
X    S_RIGHT_ADJUST, "nU*'",
X    S_NUMBER, "~#Un",
X    F_min, "~#ux",
X    F_max, "~#ux",
X    F_item, "nUw%#U",
X    F_angle, "(2n,0n,1)UnUn",
X#ifdef B_COMPAT
X    F_thof, "~nUw%#U",
X#endif
X    NULL
X};
X
XHidden char *zerp[]= {
X    NULL
X};
X
XHidden char *monp[]= {
X    P_exact, "nu",
X    NULL
X};
X
XHidden char *dyap[]= {
X    P_in, "~#u",
X    P_notin, "~#u",
X    NULL
X};
X
X/*********************************************************************
X
XMeaning of codes:
X
XH,F,P    calculate and store typecode for
X    (H)command, F(unction), or P(redicate) definition
Xf    count a formal parameter for a command definition
Xp    set number of formal parameters for a function or predicate definition
X    (also register that a next M,D,m or d concern the parameters
X     and not a use of the function or predicate
X     [the parstree's for FPR_FORMALS and e.g. MONF's are identical:-])
X
XC    typecheck user defined command, actuals are on the stack
XA,a    initialize/augment number of actual parameters for a used
X    user defined command
Xq,Q    check for one/excessive actual parameter(s)
X    (these are only used in typecodes for command definitions)
XZ,M,D,z,m,d
X    if (this if the FPR_FORMALS subtree
X        of a function or predicate definition)
X    then
X        interchange formals on the stack for d,D
X        return
X    else
X        replace codestring t by the proper one for this
X        (user defined or predefined) function or predicate;
X        (the actual parameters are already on the stack)
X
XV[0-9]+    push a new external type, with ident="NN.nn"
X    where NN is the current ext_level and nn is the value of [0-9]+
X    (this code only occurs in typecode's of how-to definitions)
X
Xc,s,e,t typecheck c(ommand), s(ubnode), e(xpression) or t(est)
X        in subnode Fld(v, f++)
X        As side effects, c sets curline for error messages,
X        and e and t push a polytype on the stack.
X-       skip subnode f++
XL       curlino= subnode f++
X
Xu       pop(x); pop(y); push(unify(x, y)); p_release(x); p_release(y);
XU       pop(x); pop(y); p_release(unify(x, y))); p_release(x); p_release(y);
X
XY       set returned value name for Yield
XR       set returned value name for Refinement
Xy       release returned value name for yield/refinement
Xr       push(type of returned value);
X
X*       pop(x); p_release(x)
X?       skip code "e*" or "t*" if subnode f is NilTree
X~       interchange: pop(x); pop(y); push(x); push(y);
X%    pop(u); interchange like ~; push(u)
X'       push(mk_text());
Xn       push(mk_number());
X.       push(mk_text_or_number());
X{       push(mk_elt());
X}       pop(x); push(mk_list(x));
X#       pop(x); push(mk_tlt(x));
X]       pop(a); pop(k); push(mk_table(k, a));
XT       push(tag(subnode f++));
Xw       x= mk_newvar(); push(x); push(copy(x));
Xv       push(mk_newvar());
X
X
XSimple loop facility:
X:       init loop over subnode f; f=FF and nf=Nfields(subnode)
X<       indicator for start of loop body; if f>=nf goto ">"
X>       indicator for end of loop body; if f<nf, go back to "<"
X
XCoumpound types: (N is a number of digits, with decimal value N)
X(N      push(mkt_compound(N))
X,>      pop subtype, pop compound, putsubtype f in compound, push compound
X,N      pop subtype, pop compound, putsubtype N in compound, push compound
X)    no action, used for legibility,
X        e.g. (2(2n,0n,1),1n,2) for compound in compound.
XCOLLATERALS don't use N, but combine with the loop facility, as indicated.
X
X*************************************************************************/
X
XHidden value ret_name= Vnil;
X/*
X * if in commandsuite of expression- or test-refinement:
X *    holds refinement name;
X * if in commandsuite of yield unit:
X *     holds ABC-text RETURNED_VALUE
X *        (used in error messages,
X *         no confusion with refinement names should be possible)
X * else
X *    Vnil
X * Used in tc_node(RETURN expr)
X */
X
X/************************************************************************/
X
X/* For the inter-unit typecheck we need codes
X * for "externally used variable types".
X * These codes look like "V1", "V2", etc., for the first, second etc used
X * external variable type.
X * When used in user defined commands, functions or precidate calls,
X * we turn these into types (kind="Variable", id="N.1" or "N.2" etc)
X * where N stands for the number of the currently used user defined;
X * N is augmented for every use of some user defined command, function
X * or predicate, and is kept in ext_level.
X */
XHidden int ext_level= 0;
X
X/* nformals counts the number of formal parameters of a how-to.
X * For functions and predicate definitions it also acts
X * as a boolean to know when a MONF (etc) is an FPR_FORMAL,
X * or part of an expression.
X */
X#define FPR_PARAMETERS (-1)
XHidden int nformals= 0;
XHidden int nactuals= 0;
X
X/************************************************************************/
X
X/************************************************************************/
X
XForward polytype pt_pop();
XForward polytype external_type();
X
XForward string get_code();
XForward string fpr_code();
X
XVisible Procedure type_check(v) parsetree v; {
X    typenode n;
X
X    if (!still_ok || v == NilTree)
X        return;
X    n= nodetype(v);
X    curline= v; curlino= one;
X    pts_init();
X    usetypetable(mk_elt());
X    start_vars();
X    ret_name= Vnil;
X    ext_level= 0;
X    nformals= 0;
X    if (Unit(n) || Command(n) || Expression(n)) {
X        tc_node(v);
X        if (!interrupted && Expression(n))
X            p_release(pt_pop());
X    }
X    else syserr(WRONG_ARGUMENT);
X    end_vars();
X    deltypetable();
X    pts_free();
X}
X
X#define FF First_fieldnr
X#define Fld(v, f) (*(Branch(v, f)))
X
XHidden Procedure tc_node(v) parsetree v; {
X    string t;
X    string t_saved= NULL;
X    int f;
X    int nf;
X    int len;    /* length of compound */
X    polytype x, y, u;
X
X    if (v == NilTree)
X        return;
X
X    t= tc_code[nodetype(v)];
X    f= FF;
X
X#ifdef TYPETRACE
X    t_typecheck((int)nodetype(v), t);
X#endif
X
X    while (*t) {
X
X    switch (*t) {
X
X    case 'p':    /* formal parameter(s) of func or pred */
X        switch (nodetype(Fld(v, f))) {
X        case TAG:
X            nformals= 0;
X            break;
X        case MONF: case MONPRD:
X            nformals= FPR_PARAMETERS;
X            tc_node(Fld(v, f));
X            nformals= 1;
X            break;
X        case DYAF: case DYAPRD:
X            nformals= FPR_PARAMETERS;
X            tc_node(Fld(v, f));
X            nformals= 2;
X            break;
X        }
X        f++;
X        break;
X    case 'f':    /* formal parameter of command definition */
X        nformals++;
X        break;
X    case 'H':
X    case 'F':
X    case 'P':
X        put_code(v, *t);
X        break;
X
X    case 'A':
X        nactuals= 0;
X        break;
X    case 'a':
X        nactuals++;
X        break;
X    case 'C':
X        /* user defined Command, actuals are on the stack */
X        ext_level++;
X        t= get_code(Fld(v, UNIT_NAME), Cmd);
X        if (t != NULL)
X            t_saved= t;
X        else
X            t= "Q";
X        continue;    /* skips t++ */
X    case 'q':
X        if (nactuals <= 0)
X            return;    /* breaks loop over formals in excess */
X        /* else: */
X        nactuals--;
X        break;
X    case 'Q':
X        while (nactuals > 0) {
X            p_release(pt_pop());
X            nactuals--;
X        }
X        break;
X
X    case 'Z':
X        ext_level++;
X        t_saved= t= fpr_code(Fld(v, TAG_NAME), Zfd, zerf, "T");
X        continue;    /* skips t++ */
X    case 'M':
X        if (nformals == FPR_PARAMETERS)
X            return;
X        ext_level++;
X        t_saved= t= fpr_code(Fld(v, MON_NAME), Mfd, monf, "*v");
X        continue;    /* skips t++ */
X    case 'D':
X        if (nformals == FPR_PARAMETERS) {
X            return;
X        }
X        ext_level++;
X        t_saved= t= fpr_code(Fld(v, DYA_NAME), Dfd, dyaf, "**v");
X        continue;    /* skips t++ */
X    case 'z':
X        ext_level++;
X        t_saved= t= fpr_code(Fld(v, TAG_NAME), Zpd, zerp, "T");
X        continue;    /* skips t++ */
X    case 'm':
X        if (nformals == FPR_PARAMETERS)
X            return;
X        ext_level++;
X        t_saved= t= fpr_code(Fld(v, MON_NAME), Mpd, monp, "");
X        continue;    /* skips t++ */
X    case 'd':
X        if (nformals == FPR_PARAMETERS) {
X            return;
X        }
X        ext_level++;
X        t_saved= t= fpr_code(Fld(v, DYA_NAME), Dpd, dyap, "*");
X        continue;    /* skips t++ */
X
X    case 'V':
X        x= external_type(&t);
X        pt_push(x);
X        continue;    /* skipping t++ ! */
X
X    case 'c':
X        curline= Fld(v, f);
X        end_vars();
X        start_vars();
X        /* FALLTHROUGH */
X    case 's': /* just subnode, without curline setting */
X    case 'e': /* 'e' and 't' leave polytype on stack */
X    case 't':
X        tc_node(Fld(v, f));
X        f++;
X        break;
X    case '-':
X        f++;
X        break;
X    case 'Y':
X        ret_name= mk_text(RETURNED_VALUE);
X        break;
X    case 'y':
X        if (ret_name != Vnil)
X            release(ret_name);
X        ret_name= Vnil;
X        break;
X    case 'R':
X        set_ret_name((value) Fld(v, REF_NAME));
X        break;
X    case 'r':
X        if (ret_name != Vnil) {
X            pt_push(mkt_var(copy(ret_name)));
X        }
X        else {
X            interr(WRONG_RETURN);
X            /* skip final U in tc_code for RETURN: */
X            p_release(pt_pop());
X            return;
X        }
X        break;
X    case 'L':
X        curlino= Fld(v, f);
X        f++;
X        break;
X    case '?':
X        if (Fld(v, f) == NilTree) {
X            /* skip tc_code "t*" or "e*" */
X            t+=2;
X            f++;
X            /* to prevent p_release(not pushed e or t) */
X        }
X        break;
X    case 'U':
X    case 'u':
X        y= pt_pop();
X        x= pt_pop();
X        unify(x, y, &u);
X        p_release(x);
X        p_release(y);
X        if (*t == 'U')
X            p_release(u);
X        else
X            pt_push(u);
X        break;
X    case '*':
X        p_release(pt_pop());
X        break;
X    case '\'':
X        pt_push(mkt_text());
X        break;
X    case 'n':
X        pt_push(mkt_number());
X        break;
X    case '.':
X        pt_push(mkt_tn());
X        break;
X    case '{':
X        pt_push(mkt_lt(pt_pop()));
X        break;
X    case '}':
X        pt_push(mkt_list(pt_pop()));
X        break;
X    case '#':
X        pt_push(mkt_tlt(pt_pop()));
X        break;
X    case ']':
X        y= pt_pop();
X        x= pt_pop();
X        pt_push(mkt_table(x, y));
X        break;
X    case 'x':
X        x= pt_pop();
X        if (t_is_error(kind(x)))
X            pt_push(mkt_error());
X        else
X            pt_push(p_copy(asctype(bottomtype(x))));
X        p_release(x);
X        break;
X    case 'v':
X        pt_push(mkt_newvar());
X        break;
X    case 'w':
X        x= mkt_newvar();
X        pt_push(x);
X        pt_push(p_copy(x));
X        break;
X    case '~':
X        x= pt_pop();
X        y= pt_pop();
X        pt_push(x);
X        pt_push(y);
X        break;
X    case '%':
X        u= pt_pop();
X        x= pt_pop();
X        y= pt_pop();
X        pt_push(x);
X        pt_push(y);
X        pt_push(u);
X        break;
X    case 'T':
X        x= mkt_var(copy(Fld(v, f)));
X        add_var(x);
X        pt_push(x);
X        /* f++ unnecessary */
X        break;
X    case ':':    /* initialize loop over subnode */
X        /* f == FF */
X        v= Fld(v, f);
X        nf= Nfields(v);
X        break;
X    case '<':    /* start of loop body (after init part) */
X        if (f >= nf) /* init part ate the one-and-only subfield */
X            while (*t != '>') ++t;
X        break;
X    case '>':    /* end of loop body */
X        if (f < nf)
X            while (*t != '<') --t;
X        break;
X    case '(':
X        ++t;
X        if (*t == '<') {
X            /* COLLATERAL above */
X            len= nf;
X        }
X        else {
X            /* code for compound in fpr_code */
X            len= 0;
X            while ('0' <= *t && *t <= '9') {
X                len= 10*len + *t - '0';
X                ++t;
X            }
X        }
X        pt_push(mkt_compound(len));
X        continue;
X    case ',':
X        ++t;
X        if (*t == '>') {
X            len= f-1;
X        }
X        else {
X            len= 0;
X            while ('0' <= *t && *t <= '9') {
X                len= 10*len + *t - '0';
X                ++t;
X            }
X        }
X        x= pt_pop();
X        u= pt_pop();
X        putsubtype(x, u, len);
X        pt_push(u);
X        continue;
X    case ')':
X        /* just there to end number in compound in compound */
X        break;
X
X    } /* end switch (*t) */
X
X    t++;
X
X    } /* end while (*t) */
X
X    if (t_saved != NULL)
X            freestr(t_saved);
X}
X
X/************************************************************************/
X
X/* table mapping pname's to type_code's for how-to definitions */
X
XHidden value abctypes= Vnil;
XHidden bool typeschanges;
X
X#define tc_exists(pname, cc)    (in_env(abctypes, pname, cc))
X#define def_typecode(pname, tc)    (e_replace(tc, &abctypes, pname), \
X                    typeschanges= Yes)
X#define del_typecode(pname)    (e_delete(&abctypes, pname), \
X                    typeschanges= Yes)
X
X/* get and put table mapping pname's to typecode's of how-to's
X * to file when entering or leaving workspace.
X */
XVisible Procedure initstc() {
X    value fn;
X
X    if (Valid(abctypes)) {
X        release(abctypes);
X        abctypes= Vnil;
X    }
X    if (F_exists(typesfile)) {
X        fn= mk_text(typesfile);
X        abctypes= getval(fn, In_prmnv);
X        if (!still_ok) {
X            if (Valid(abctypes))
X                release(abctypes);
X            abctypes= mk_elt();
X            still_ok= Yes;
X        }
X        release(fn);
X    }
X    else abctypes= mk_elt();
X    typeschanges= No;
X}
X
XVisible Procedure endstc() {
X    value fn;
X    int len;
X
X    if (!typeschanges || !Valid(abctypes))
X        return;
X    fn= mk_text(typesfile);
X    /* Remove the file if the permanent environment is empty */
X    len= length(abctypes);
X    if (len == 0)
X        f_delete(fn);
X    else
X        putval(fn, abctypes, Yes, In_prmnv);
X    release(fn);
X    typeschanges= No;
X
X    if (terminated) return;
X    release(abctypes); abctypes= Vnil;
X}
X
XVisible Procedure rectypes() {
X    value fn;
X
X    if (Valid(abctypes))
X        release(abctypes);
X    abctypes= mk_elt();
X    if (F_exists(typesfile)) {
X        fn= mk_text(typesfile);
X        f_delete(fn);
X        release(fn);
X    }
X}
X
X/************************************************************************/
X
XVisible value stc_code(pname) value pname; {
X    value *tc;
X
X    if (tc_exists(pname, &tc))
X        return copy(*tc);
X    /* else: */
X    return Vnil;
X}
X
XHidden value old_abctypes;
XHidden bool old_typeschanges;
X
XVisible Procedure del_types() {
X    old_abctypes= copy(abctypes);
X    old_typeschanges= typeschanges;
X    release(abctypes);
X    abctypes= mk_elt();
X    typeschanges= Yes;
X}
X
XVisible Procedure adjust_types(no_change) bool no_change; {
X    if (no_change) {
X        /* recover old inter-unit typetable */
X        release(abctypes);
X        abctypes= old_abctypes;
X        typeschanges= old_typeschanges;
X    }
X    else {
X        release(old_abctypes);
X    }
X}
X
X/************************************************************************/
X
X/* Calculate code for how-to definition and put into typetable */
X/* formals are on the stack */
X
XForward value type_code();
X
XHidden Procedure put_code(v, type) parsetree v; char type; {
X    value howcode, fmlcode;
X    value pname, *tc;
X    polytype x;
X    int f;
X
X    pname= get_pname(v);
X    if (tc_exists(pname, &tc))
X        del_typecode(pname);
X        /* do not use old code for possibly edited how-to */
X
X    new_externals();
X
X    howcode= mk_text("");
X    for (f= nformals; f > 0; f--) {
X        if (type == 'H') {
X            howcode= conc(howcode, mk_text("q"));
X        }
X        fmlcode= type_code(x=pt_pop()); p_release(x);
X        howcode= conc(howcode, fmlcode);
X        howcode= conc(howcode, mk_text("U"));
X    }
X    if (type == 'H') {
X        howcode= conc(howcode, mk_text("Q"));
X    }
X    else if (type == 'P')
X        howcode= conc(howcode, mk_text("v"));
X    else {
X        x= mkt_var(mk_text(RETURNED_VALUE));
X        howcode= conc(howcode, type_code(x));
X        p_release(x);
X    }
X
X    def_typecode(pname, howcode);
X    release(pname); release(howcode);
X}
X
XHidden value type_code(p) polytype p; {
X    typekind p_kind;
X    polytype tp;
X    polytype ext;
X    value tc;
X    intlet k, len;
X    char buf[20];
X
X    p_kind = kind(p);
X    if (t_is_number(p_kind)) {
X        return mk_text("n");
X    }
X    else if (t_is_text(p_kind)) {
X        return mk_text("'");
X    }
X    else if (t_is_tn(p_kind)) {
X        return mk_text(".");
X    }
X    else if (t_is_compound(p_kind)) {
X        len= nsubtypes(p);
X        tc= mk_text("(");
X        sprintf(buf, "%d", len);
X        tc= conc(tc, mk_text(buf));
X        for (k = 0; k < len; k++) {
X            tc= conc(tc, type_code(subtype(p, k)));
X            sprintf(buf, ",%d", k);
X            tc= conc(tc, mk_text(buf));
X        }
X        return conc(tc, mk_text(")"));
X    }
X    else if (t_is_error(p_kind)) {
X        return mk_text("v");
X    }
X    else if (t_is_table(p_kind)) {
X        tc = type_code(keytype(p));
X        tc = conc(tc, type_code(asctype(p)));
X        return conc(tc, mk_text("]"));
X    }
X    else if (t_is_list(p_kind)) {
X        tc = type_code(asctype(p));
X        return conc(tc, mk_text("}"));
X    }
X    else if (t_is_lt(p_kind)) {
X        tc = type_code(asctype(p));
X        return conc(tc, mk_text("{"));
X    }
X    else if (t_is_tlt(p_kind)) {
X        tc = type_code(asctype(p));
X        return conc(tc, mk_text("#"));
X    }
X    else if (t_is_var(p_kind)) {
X        tp = bottomtype(p);
X        if (!t_is_var(kind(tp)))
X            return type_code(tp);
X        else {
X            ext= mkt_ext();
X            repl_type_of(tp, ext);
X            return type_code(ext);
X        }
X    }
X    else if (t_is_ext(p_kind)) {
X        return conc(mk_text("V"), convert(ident(p), No, Yes));
X    }
X    else {
X        return mk_text("v"); /* cannot happen */
X    }
X    /* NOTREACHED */
X}
X
X/************************************************************************/
X
X/* retrieve the codes for user defined commands and for
X * user defined and predefined functions and predicates
X * from the respective tables
X */
X
XHidden string get_code(name, type) value name; int type; {
X    value pname;
X    value *aa;
X
X    pname= permkey(name, type);
X    if (tc_exists(pname, &aa))
X        return savestr(strval(*aa));
X    /* else: */
X    return NULL;
X}
X
XHidden string pre_fpr_code(fn, func) value fn; char *func[]; {
X    int i;
X    string f= strval(fn);
X
X    for (i= 0;  ; i+=2) {
X        if (func[i] == NULL)
X            return NULL;
X        if (strcmp(f, func[i]) == 0)
X            return (string) savestr(func[i+1]);
X    }
X    /*NOTREACHED*/
X}
X
XHidden string fpr_code(name, type, functab, defcode)
Xvalue name; literal type; char *functab[]; string defcode;
X{
X    string t;
X
X    if (is_udfpr(name, type))
X        t= get_code(name, type);
X    else
X        t= pre_fpr_code(name, functab);
X
X    if (t == NULL)
X        t= savestr(defcode);
X
X    return t;
X}
X
X/************************************************************************/
X
XHidden polytype external_type(pt) string *pt; {
X    int n;
X    string t;
X    polytype x;
X    char buf[20];
X
X    n= 0;
X    t= *pt;
X    for (++t; '0' <= *t && *t <= '9'; t++) {
X        n= n*10 + *t-'0';
X    }
X    sprintf(buf, "%d.%d", ext_level, n);
X    x= mkt_var(mk_text(buf));
X    *pt= t;
X    return x;
X}
X
X/************************************************************************/
X
XHidden Procedure set_ret_name(name) value name; {
X    value n1;
X
X    n1= curtail(name, one);
X        /* should check for expression refinement */
X    if (!Cap(charval(n1)))
X        ret_name= copy(name);
X    release(n1);
X}
X
X/************************************************************************/
X
X/* PolyTypes Stack */
X
X#define STACKINCR 100
X
XHidden polytype *pts_start;
XHidden polytype *pts_top;
XHidden polytype *pts_end;
X
XHidden Procedure pts_init() {
X    pts_start= (polytype *) getmem((unsigned) (STACKINCR * sizeof(polytype)));
X    pts_top= pts_start;
X    pts_end= pts_start + STACKINCR;
X    *(pts_top)= (polytype) Vnil;
X}
X
XHidden Procedure pts_free() {
X    if (interrupted) {
X        for (--pts_top; pts_top >= pts_start; --pts_top) {
X            p_release(*pts_top);
X        }
X    }
X    freemem((ptr) pts_start);
X}
X
XHidden Procedure pts_grow() {
X    int oldtop= pts_top - pts_start;
X    int syze= (pts_end - pts_start) + STACKINCR;
X
X    regetmem((ptr *) &(pts_start), (unsigned) (syze * sizeof(polytype)));
X    pts_top= pts_start + oldtop;
X    pts_end= pts_start + syze;
X}
X
XHidden Procedure pt_push(pt) polytype pt; {
X    if (pts_top >= pts_end)
X        pts_grow();
X    *pts_top++= pt;
X}
X
XHidden polytype pt_pop() {
X#ifndef NDEBUG
X    if (pts_top <= pts_start)
X        syserr(EMPTY_STACK);
X#endif
X    return *--pts_top;
X}
END_OF_FILE
  if test 21735 -ne `wc -c <'abc/stc/i2tca.c'`; then
    echo shar: \"'abc/stc/i2tca.c'\" unpacked with wrong size!
  fi
  # end of 'abc/stc/i2tca.c'
fi
echo shar: End of archive 3 \(of 25\).
cp /dev/null ark3isdone
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...