rsalz@bbn.com (Rich Salz) (12/18/90)
Submitted-by: Steven Pemberton <steven@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@uunet.uu.net if you want that tool. # Contents: abc/keys/keydef.c abc/stc/i2tca.c # Wrapped by rsalz@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@uunet.uu.net. Use a domain-based address or give alternate paths, or you may lose out.