v23i082: ABC interactive programming environment, Part03/25
Rich Salz
rsalz at bbn.com
Tue Dec 18 05:35:16 AEST 1990
Submitted-by: Steven Pemberton <steven at cwi.nl>
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 comp-sources-unix at uunet.uu.net if you want that tool.
# Contents: abc/keys/keydef.c abc/stc/i2tca.c
# Wrapped by rsalz at litchi.bbn.com 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...
--
Please send comp.sources.unix-related mail to rsalz at uunet.uu.net.
Use a domain-based address or give alternate paths, or you may lose out.
More information about the Comp.sources.unix
mailing list