summaryrefslogtreecommitdiff
path: root/src/icont
diff options
context:
space:
mode:
authorIgor Pashev <pashev.igor@gmail.com>2013-01-27 23:51:56 +0000
committerIgor Pashev <pashev.igor@gmail.com>2013-01-27 23:51:56 +0000
commit6ab0c0f5bf14ed9c15370407b9ee7e0b4b089ae1 (patch)
tree926065cf45450116098db664e3c61dced9e1f21a /src/icont
downloadicon-6ab0c0f5bf14ed9c15370407b9ee7e0b4b089ae1.tar.gz
Initial upstream version 9.4.3upstream/9.4.3
Diffstat (limited to 'src/icont')
-rw-r--r--src/icont/Makefile108
-rw-r--r--src/icont/ixhdr.c73
-rw-r--r--src/icont/keyword.h70
-rw-r--r--src/icont/lcode.c1564
-rw-r--r--src/icont/lfile.h21
-rw-r--r--src/icont/lglob.c356
-rw-r--r--src/icont/link.c228
-rw-r--r--src/icont/link.h143
-rw-r--r--src/icont/llex.c318
-rw-r--r--src/icont/lmem.c224
-rw-r--r--src/icont/lnklist.c83
-rw-r--r--src/icont/lsym.c446
-rw-r--r--src/icont/mkkwd.icn52
-rw-r--r--src/icont/newhdr.c90
-rw-r--r--src/icont/opcode.c117
-rw-r--r--src/icont/opcode.h17
-rw-r--r--src/icont/tcode.c1097
-rw-r--r--src/icont/tglobals.c24
-rw-r--r--src/icont/tglobals.h67
-rw-r--r--src/icont/tgrammar.c239
-rw-r--r--src/icont/tlex.c16
-rw-r--r--src/icont/tmem.c76
-rw-r--r--src/icont/tparse.c1917
-rw-r--r--src/icont/tproto.h106
-rw-r--r--src/icont/trans.c125
-rw-r--r--src/icont/trash.icn35
-rw-r--r--src/icont/tree.c175
-rw-r--r--src/icont/tree.h109
-rw-r--r--src/icont/tsym.c519
-rw-r--r--src/icont/tsym.h69
-rw-r--r--src/icont/ttoken.h111
-rw-r--r--src/icont/tunix.c420
-rw-r--r--src/icont/util.c93
33 files changed, 9108 insertions, 0 deletions
diff --git a/src/icont/Makefile b/src/icont/Makefile
new file mode 100644
index 0000000..8f15f9d
--- /dev/null
+++ b/src/icont/Makefile
@@ -0,0 +1,108 @@
+# Makefile for the Icon translator, icont.
+
+include ../../Makedefs
+
+
+HFILES = ../h/define.h ../h/config.h ../h/cpuconf.h ../h/gsupport.h \
+ ../h/mproto.h ../h/typedefs.h ../h/cstructs.h
+
+TRANS = trans.o tcode.o tlex.o lnklist.o tparse.o tsym.o tmem.o tree.o
+
+LINKR = link.o lglob.o lcode.o llex.o lmem.o lsym.o opcode.o
+
+OBJS = tunix.o tglobals.o util.o $(TRANS) $(LINKR)
+
+COBJS = ../common/long.o ../common/getopt.o ../common/alloc.o \
+ ../common/filepart.o ../common/strtbl.o ../common/ipp.o \
+ ../common/munix.o
+
+
+
+icont: $(OBJS) $(COBJS)
+ $(CC) $(CFLAGS) $(LDFLAGS) -o icont $(OBJS) $(COBJS)
+ cp icont ../../bin
+ strip ../../bin/icont$(EXE)
+ (cd ../../bin; rm -f icon; ln -s icont icon)
+
+$(OBJS): $(HFILES) tproto.h
+
+$(COBJS): $(HFILES)
+ cd ../common; $(MAKE)
+
+tunix.o: tglobals.h ../h/version.h
+tglobals.o: tglobals.h
+util.o: tglobals.h tree.h ../h/fdefs.h
+
+# translator files
+trans.o: tglobals.h tsym.h ttoken.h tree.h ../h/version.h ../h/kdefs.h
+lnklist.o: lfile.h
+tparse.o: ../h/lexdef.h tglobals.h tsym.h tree.h keyword.h
+tcode.o: tglobals.h tsym.h ttoken.h tree.h
+tlex.o: ../h/lexdef.h ../h/parserr.h ttoken.h tree.h ../h/esctab.h \
+ ../common/lextab.h ../common/yylex.h ../common/error.h
+tmem.o: tglobals.h tsym.h tree.h
+tree.o: tree.h
+tsym.o: tglobals.h tsym.h ttoken.h lfile.h keyword.h ../h/kdefs.h
+
+# linker files
+$(LINKR): link.h lfile.h ../h/rt.h ../h/sys.h ../h/monitor.h \
+ ../h/rstructs.h ../h/rmacros.h ../h/rexterns.h
+
+link.o: tglobals.h hdr.h ../h/header.h
+lcode.o: tglobals.h opcode.h keyword.h ../h/header.h \
+ ../h/opdefs.h ../h/version.h
+lglob.o: tglobals.h opcode.h ../h/opdefs.h ../h/version.h
+llex.o: tglobals.h opcode.h ../h/opdefs.h
+lmem.o: tglobals.h
+lsym.o: tglobals.h
+opcode.o: opcode.h ../h/opdefs.h
+
+# hdr.h is always built, to simplify the Makefile,
+# but it is only actually used if BinHeader is define.
+hdr.h: newhdr ixhdr.hdr
+ ./newhdr -o hdr.h ixhdr.hdr
+newhdr: newhdr.c ../h/define.h ../h/config.h ../h/gsupport.h
+ $(CC) $(CFLAGS) $(LDFLAGS) -o newhdr newhdr.c
+ixhdr.hdr: ixhdr.c ../h/define.h ../h/config.h ../h/header.h $(COBJS)
+ $(CC) $(CFLAGS) $(LDFLAGS) -o ixhdr.hdr \
+ ixhdr.c ../common/alloc.o ../common/munix.o
+ strip ixhdr.hdr
+
+
+
+
+# The following sections are commented out because they do not need to be
+# performed unless changes are made to cgrammar.c, ../h/grammar.h,
+# ../common/tokens.txt, or ../common/op.txt. Such changes involve
+# modifications to the syntax of Icon and are not part of the installation
+# process. However, if the distribution files are unloaded in a fashion
+# such that their dates are not set properly, the following sections would
+# be attempted.
+#
+# Note that if any changes are made to the files mentioned above, the comment
+# characters at the beginning of the following lines should be removed.
+# icont must be on your search path for these actions to work.
+#
+#../common/lextab.h ../common/yacctok.h ../common/fixgram ../common/pscript: \
+# ../common/tokens.txt ../common/op.txt
+# cd ../common; $(MAKE) gfiles
+#
+#tparse.c ttoken.h: tgram.g trash ../common/pscript
+## expect 218 shift/reduce conflicts
+# yacc -d tgram.g
+# ./trash <y.tab.c | ../common/pscript >tparse.c
+# mv y.tab.h ttoken.h
+# rm -f y.tab.c
+#
+#tgram.g: tgrammar.c ../h/define.h ../h/grammar.h \
+# ../common/yacctok.h ../common/fixgram
+# $(CC) -E -C tgrammar.c | ../common/fixgram >tgram.g
+#
+#../h/kdefs.h keyword.h: ../runtime/keyword.r mkkwd
+# ./mkkwd <../runtime/keyword.r
+#
+#trash: trash.icn
+# icont -s trash.icn
+#
+#mkkwd: mkkwd.icn
+# icont -s mkkwd.icn
diff --git a/src/icont/ixhdr.c b/src/icont/ixhdr.c
new file mode 100644
index 0000000..9766292
--- /dev/null
+++ b/src/icont/ixhdr.c
@@ -0,0 +1,73 @@
+/*
+ * ixhdr.c -- bootstrap header for icode files
+ *
+ * (used when BinaryHeader is defined)
+ */
+
+#include "../h/gsupport.h"
+
+static void doiconx (char *argv[]);
+static void hsyserr (char *av, char *file);
+
+int main(int argc, char *argv[]) {
+ char *argvx[1000];
+
+ /*
+ * Abort if we've been invoked with setuid or setgid privileges.
+ * Allowing such usage would open a huge security hole, because
+ * there is no way to ensure that the right iconx will interpret
+ * the right user program.
+ */
+ if (getuid() != geteuid() || getgid() != getegid())
+ hsyserr(argv[0], ": cannot run an Icon program setuid/setgid");
+
+ /*
+ * Shift the argument list to make room for iconx in argv[0].
+ */
+ do
+ argvx[argc + 1] = argv[argc];
+ while (argc--);
+
+ /*
+ * Pass the arglist and execute iconx.
+ */
+ doiconx(argvx);
+ return EXIT_FAILURE;
+ }
+
+/*
+ * doiconx(argv) - execute iconx, passing argument list.
+ *
+ * To find the interpreter, first check the environment variable ICONX.
+ * If it defines a path, it had better work, else we abort.
+ *
+ * Failing that, check the directory containing the icode file,
+ * and if that doesn't work, search $PATH.
+ */
+static void doiconx(char *argv[]) {
+ char xcmd[256];
+
+ if ((argv[0] = getenv("ICONX")) != NULL && argv[0][0] != '\0') {
+ execv(argv[0], argv); /* exec file specified by $ICONX */
+ hsyserr("cannot execute $ICONX: ", argv[0]);
+ }
+
+ argv[0] = relfile(argv[1], "/../iconx" ExecSuffix);
+ execv(argv[0], argv); /* try iconx in same dir; just continue if absent */
+
+ if (findonpath("iconx" ExecSuffix, xcmd, sizeof(xcmd))) {
+ argv[0] = xcmd;
+ execv(xcmd, argv);
+ hsyserr("cannot execute ", xcmd);
+ }
+
+ hsyserr(argv[1], ": cannot find iconx" ExecSuffix);
+ }
+
+/*
+ * hsyserr(s1, s2) - print s1 and s2 on stderr, then abort.
+ */
+static void hsyserr(char *s1, char *s2) {
+ fprintf(stderr, "%s%s\n", s1, s2);
+ exit(EXIT_FAILURE);
+ }
diff --git a/src/icont/keyword.h b/src/icont/keyword.h
new file mode 100644
index 0000000..f6659c1
--- /dev/null
+++ b/src/icont/keyword.h
@@ -0,0 +1,70 @@
+/*
+ * keyword.h -- Keyword manifest constants.
+ *
+ * Created mechanically by mkkwd.icn -- DO NOT EDIT.
+ */
+
+#define K_ALLOCATED 1
+#define K_ASCII 2
+#define K_CLOCK 3
+#define K_COL 4
+#define K_COLLECTIONS 5
+#define K_COLUMN 6
+#define K_CONTROL 7
+#define K_CSET 8
+#define K_CURRENT 9
+#define K_DATE 10
+#define K_DATELINE 11
+#define K_DIGITS 12
+#define K_DUMP 13
+#define K_E 14
+#define K_ERROR 15
+#define K_ERRORNUMBER 16
+#define K_ERRORTEXT 17
+#define K_ERRORVALUE 18
+#define K_ERROUT 19
+#define K_EVENTCODE 20
+#define K_EVENTSOURCE 21
+#define K_EVENTVALUE 22
+#define K_FAIL 23
+#define K_FEATURES 24
+#define K_FILE 25
+#define K_HOST 26
+#define K_INPUT 27
+#define K_INTERVAL 28
+#define K_LCASE 29
+#define K_LDRAG 30
+#define K_LETTERS 31
+#define K_LEVEL 32
+#define K_LINE 33
+#define K_LPRESS 34
+#define K_LRELEASE 35
+#define K_MAIN 36
+#define K_MDRAG 37
+#define K_META 38
+#define K_MPRESS 39
+#define K_MRELEASE 40
+#define K_NULL 41
+#define K_OUTPUT 42
+#define K_PHI 43
+#define K_PI 44
+#define K_POS 45
+#define K_PROGNAME 46
+#define K_RANDOM 47
+#define K_RDRAG 48
+#define K_REGIONS 49
+#define K_RESIZE 50
+#define K_ROW 51
+#define K_RPRESS 52
+#define K_RRELEASE 53
+#define K_SHIFT 54
+#define K_SOURCE 55
+#define K_STORAGE 56
+#define K_SUBJECT 57
+#define K_TIME 58
+#define K_TRACE 59
+#define K_UCASE 60
+#define K_VERSION 61
+#define K_WINDOW 62
+#define K_X 63
+#define K_Y 64
diff --git a/src/icont/lcode.c b/src/icont/lcode.c
new file mode 100644
index 0000000..a1481f1
--- /dev/null
+++ b/src/icont/lcode.c
@@ -0,0 +1,1564 @@
+/*
+ * lcode.c -- linker routines to parse .u1 files and produce icode.
+ */
+
+#include "link.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "opcode.h"
+#include "keyword.h"
+#include "../h/version.h"
+#include "../h/header.h"
+
+/*
+ * This needs fixing ...
+ */
+#undef CsetPtr
+#define CsetPtr(b,c) ((c) + (((b)&0377) >> LogIntBits))
+
+/*
+ * Prototypes.
+ */
+
+static void align (void);
+static void backpatch (int lab);
+static void clearlab (void);
+static void flushcode (void);
+static void intout (int oint);
+static void lemit (int op,char *name);
+static void lemitcon (int k);
+static void lemitin (int op,word offset,int n,char *name);
+static void lemitint (int op,long i,char *name);
+static void lemitl (int op,int lab,char *name);
+static void lemitn (int op,word n,char *name);
+static void lemitproc (word name,int nargs,int ndyn,int nstat,int fstat);
+static void lemitr (int op,word loc,char *name);
+static void misalign (void);
+static void outblock (char *addr,int count);
+static void setfile (void);
+static void wordout (word oword);
+
+#ifdef FieldTableCompression
+ static void charout (unsigned char oint);
+ static void shortout (short oint);
+#endif /* FieldTableCompression */
+
+#ifdef DeBugLinker
+ static void dumpblock (char *addr,int count);
+#endif /* DeBugLinker */
+
+word pc = 0; /* simulated program counter */
+
+#define outword(n) wordout((word)(n))
+#define outop(n) intout((int)(n))
+#define outchar(n) charout((unsigned char)(n))
+#define outshort(n) shortout((short)(n))
+#define CodeCheck(n) if ((long)codep + (n) > (long)((long)codeb + maxcode))\
+ codeb = (char *) trealloc(codeb, &codep, &maxcode, 1,\
+ (n), "code buffer");
+
+#define ByteBits 8
+
+/*
+ * gencode - read .u1 file, resolve variable references, and generate icode.
+ * Basic process is to read each line in the file and take some action
+ * as dictated by the opcode. This action sometimes involves parsing
+ * of arguments and usually culminates in the call of the appropriate
+ * lemit* routine.
+ */
+void gencode()
+ {
+ register int op, k, lab;
+ int j, nargs, flags, implicit;
+ char *name;
+ word id, procname;
+ struct centry *cp;
+ struct gentry *gp;
+ struct fentry *fp;
+ union xval gg;
+
+ while ((op = getopc(&name)) != EOF) {
+ switch (op) {
+
+ /* Ternary operators. */
+
+ case Op_Toby:
+ case Op_Sect:
+
+ /* Binary operators. */
+
+ case Op_Asgn:
+ case Op_Cat:
+ case Op_Diff:
+ case Op_Div:
+ case Op_Eqv:
+ case Op_Inter:
+ case Op_Lconcat:
+ case Op_Lexeq:
+ case Op_Lexge:
+ case Op_Lexgt:
+ case Op_Lexle:
+ case Op_Lexlt:
+ case Op_Lexne:
+ case Op_Minus:
+ case Op_Mod:
+ case Op_Mult:
+ case Op_Neqv:
+ case Op_Numeq:
+ case Op_Numge:
+ case Op_Numgt:
+ case Op_Numle:
+ case Op_Numlt:
+ case Op_Numne:
+ case Op_Plus:
+ case Op_Power:
+ case Op_Rasgn:
+ case Op_Rswap:
+ case Op_Subsc:
+ case Op_Swap:
+ case Op_Unions:
+
+ /* Unary operators. */
+
+ case Op_Bang:
+ case Op_Compl:
+ case Op_Neg:
+ case Op_Nonnull:
+ case Op_Null:
+ case Op_Number:
+ case Op_Random:
+ case Op_Refresh:
+ case Op_Size:
+ case Op_Tabmat:
+ case Op_Value:
+
+ /* Instructions. */
+
+ case Op_Bscan:
+ case Op_Ccase:
+ case Op_Coact:
+ case Op_Cofail:
+ case Op_Coret:
+ case Op_Dup:
+ case Op_Efail:
+ case Op_Eret:
+ case Op_Escan:
+ case Op_Esusp:
+ case Op_Limit:
+ case Op_Lsusp:
+ case Op_Pfail:
+ case Op_Pnull:
+ case Op_Pop:
+ case Op_Pret:
+ case Op_Psusp:
+ case Op_Push1:
+ case Op_Pushn1:
+ case Op_Sdup:
+ newline();
+ lemit(op, name);
+ break;
+
+ case Op_Chfail:
+ case Op_Create:
+ case Op_Goto:
+ case Op_Init:
+ lab = getlab();
+ newline();
+ lemitl(op, lab, name);
+ break;
+
+ case Op_Cset:
+ case Op_Real:
+ k = getdec();
+ newline();
+ lemitr(op, lctable[k].c_pc, name);
+ break;
+
+ case Op_Field:
+ id = getid();
+ newline();
+ fp = flocate(id);
+ if (fp != NULL)
+ lemitn(op, (word)(fp->f_fid-1), name);
+ else
+ lemitn(op, (word)-1, name); /* no warning any more */
+ break;
+
+
+ case Op_Int: {
+ long i;
+ k = getdec();
+ newline();
+ cp = &lctable[k];
+ /*
+ * Check to see if a large integers has been converted to a string.
+ * If so, generate the code for +s.
+ */
+ if (cp->c_flag & F_StrLit) {
+ lemit(Op_Pnull,"pnull");
+ lemitin(Op_Str, cp->c_val.sval, cp->c_length, "str");
+ lemit(Op_Number,"number");
+ break;
+ }
+ i = (long)cp->c_val.ival;
+ lemitint(op, i, name);
+ break;
+ }
+
+
+ case Op_Invoke:
+ k = getdec();
+ newline();
+ if (k == -1)
+ lemit(Op_Apply,"apply");
+ else
+ lemitn(op, (word)k, name);
+ break;
+
+ case Op_Keywd:
+ id = getstr();
+ newline();
+ k = klookup(&lsspace[id]);
+ switch (k) {
+ case 0:
+ lfatal(&lsspace[id],"invalid keyword");
+ break;
+ case K_FAIL:
+ lemit(Op_Efail,"efail");
+ break;
+ case K_NULL:
+ lemit(Op_Pnull,"pnull");
+ break;
+ default:
+ lemitn(op, (word)k, name);
+ }
+ break;
+
+ case Op_Llist:
+ k = getdec();
+ newline();
+ lemitn(op, (word)k, name);
+ break;
+
+ case Op_Lab:
+ lab = getlab();
+ newline();
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "L%d:\n", lab);
+ #endif /* DeBugLinker */
+ backpatch(lab);
+ break;
+
+ case Op_Line:
+ /*
+ * Line number change.
+ * All the interesting stuff happens in Op_Colm now.
+ */
+ lineno = getdec();
+
+ #ifndef SrcColumnInfo
+ /*
+ * Enter the value in the line number table
+ * that is stored in the icode file and used during error
+ * handling and execution monitoring. One can generate a VM
+ * instruction for these changes, but since the numbers are not
+ * saved and restored during backtracking, it is more accurate
+ * to check for line number changes in-line in the interpreter.
+ * Fortunately, the in-line check is about as fast as executing
+ * Op_Line instructions. All of this is complicated by the use
+ * of Op_Line to generate Noop instructions when enabled by the
+ * LineCodes #define.
+ *
+ * If SrcColumnInfo is required, this code is duplicated,
+ * with changes, in the Op_Colm case below.
+ */
+ if (lnfree >= &lntable[nsize])
+ lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize,
+ sizeof(struct ipc_line), 1, "line number table");
+ lnfree->ipc = pc;
+ lnfree->line = lineno;
+ lnfree++;
+ #endif /* SrcColumnInfo */
+
+ /*
+ * Could generate an Op_Line for monitoring, but don't anymore:
+ *
+ * lemitn(op, (word)lineno, name);
+ */
+
+ newline();
+
+ #ifdef LineCodes
+ #ifndef EventMon
+ lemit(Op_Noop,"noop");
+ #endif /* EventMon */
+ #endif /* LineCodes */
+
+ break;
+
+ case Op_Colm: /* always recognize, maybe ignore */
+
+ colmno = getdec();
+ #ifdef SrcColumnInfo
+ if (lnfree >= &lntable[nsize])
+ lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize,
+ sizeof(struct ipc_line), 1, "line number table");
+ lnfree->ipc = pc;
+ lnfree->line = lineno + (colmno << 16);
+ lnfree++;
+ #endif /* SrcColumnInfo */
+ break;
+
+ case Op_Mark:
+ lab = getlab();
+ newline();
+ lemitl(op, lab, name);
+ break;
+
+ case Op_Mark0:
+ lemit(op, name);
+ break;
+
+ case Op_Str:
+ k = getdec();
+ newline();
+ cp = &lctable[k];
+ lemitin(op, cp->c_val.sval, cp->c_length, name);
+ break;
+
+ case Op_Tally:
+ k = getdec();
+ newline();
+ lemitn(op, (word)k, name);
+ break;
+
+ case Op_Unmark:
+ lemit(Op_Unmark, name);
+ break;
+
+ case Op_Var:
+ k = getdec();
+ newline();
+ flags = lltable[k].l_flag;
+ if (flags & F_Global)
+ lemitn(Op_Global, (word)(lltable[k].l_val.global->g_index),
+ "global");
+ else if (flags & F_Static)
+ lemitn(Op_Static, (word)(lltable[k].l_val.staticid-1), "static");
+ else if (flags & F_Argument)
+ lemitn(Op_Arg, (word)(lltable[k].l_val.offset-1), "arg");
+ else
+ lemitn(Op_Local, (word)(lltable[k].l_val.offset-1), "local");
+ break;
+
+ /* Declarations. */
+
+ case Op_Proc:
+ getstr();
+ newline();
+ procname = putident(strlen(&lsspace[lsfree]) + 1, 0);
+ if (procname >= 0 && (gp = glocate(procname)) != NULL) {
+ /*
+ * Initialize for wanted procedure.
+ */
+ locinit();
+ clearlab();
+ lineno = 0;
+ implicit = gp->g_flag & F_ImpError;
+ nargs = gp->g_nargs;
+ align();
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\n# procedure %s\n", &lsspace[lsfree]);
+ #endif /* DeBugLinker */
+ }
+ else {
+ /*
+ * Skip unreferenced procedure.
+ */
+ while ((op = getopc(&name)) != EOF && op != Op_End)
+ if (op == Op_Filen)
+ setfile(); /* handle filename op while skipping */
+ else
+ newline(); /* ignore everything else */
+ }
+ break;
+
+ case Op_Local:
+ k = getdec();
+ flags = getoct();
+ id = getid();
+ putlocal(k, id, flags, implicit, procname);
+ break;
+
+ case Op_Con:
+ k = getdec();
+ flags = getoct();
+ if (flags & F_IntLit) {
+ {
+ long m;
+ word s_indx;
+
+ j = getdec(); /* number of characters in integer */
+ m = getint(j,&s_indx); /* convert if possible */
+ if (m < 0) { /* negative indicates integer too big */
+ gg.sval = s_indx; /* convert to a string */
+ putconst(k, F_StrLit, j, pc, &gg);
+ }
+ else { /* integers is small enough */
+ gg.ival = m;
+ putconst(k, flags, 0, pc, &gg);
+ }
+ }
+ }
+ else if (flags & F_RealLit) {
+ gg.rval = getreal();
+ putconst(k, flags, 0, pc, &gg);
+ }
+ else if (flags & F_StrLit) {
+ j = getdec();
+ gg.sval = getstrlit(j);
+ putconst(k, flags, j, pc, &gg);
+ }
+ else if (flags & F_CsetLit) {
+ j = getdec();
+ gg.sval = getstrlit(j);
+ putconst(k, flags, j, pc, &gg);
+ }
+ else
+ fprintf(stderr, "gencode: illegal constant\n");
+ newline();
+ lemitcon(k);
+ break;
+
+ case Op_Filen:
+ setfile();
+ break;
+
+ case Op_Declend:
+ newline();
+ gp->g_pc = pc;
+ lemitproc(procname, nargs, dynoff, lstatics-static1, static1);
+ break;
+
+ case Op_End:
+ newline();
+ flushcode();
+ break;
+
+ default:
+ fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name);
+ newline();
+ }
+ }
+ }
+
+/*
+ * setfile - handle Op_Filen.
+ */
+static void setfile()
+ {
+ if (fnmfree >= &fnmtbl[fnmsize])
+ fnmtbl = (struct ipc_fname *) trealloc(fnmtbl, &fnmfree,
+ &fnmsize, sizeof(struct ipc_fname), 1, "file name table");
+ fnmfree->ipc = pc;
+ fnmfree->fname = getrest();
+ strcpy(icnname, &lsspace[fnmfree->fname]);
+ fnmfree++;
+ newline();
+ }
+
+/*
+ * lemit - emit opcode.
+ * lemitl - emit opcode with reference to program label.
+ * for a description of the chaining and backpatching for labels.
+ * lemitn - emit opcode with integer argument.
+ * lemitr - emit opcode with pc-relative reference.
+ * lemitin - emit opcode with reference to identifier table & integer argument.
+ * lemitint - emit word opcode with integer argument.
+ * lemitcon - emit constant table entry.
+ * lemitproc - emit procedure block.
+ *
+ * The lemit* routines call out* routines to effect the "outputting" of icode.
+ * Note that the majority of the code for the lemit* routines is for debugging
+ * purposes.
+ */
+static void lemit(op, name)
+int op;
+char *name;
+ {
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name);
+ #endif /* DeBugLinker */
+
+ outop(op);
+ }
+
+static void lemitl(op, lab, name)
+int op, lab;
+char *name;
+ {
+ misalign();
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name);
+ #endif /* DeBugLinker */
+
+ if (lab >= maxlabels)
+ labels = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word),
+ lab - maxlabels + 1, "labels");
+ outop(op);
+ if (labels[lab] <= 0) { /* forward reference */
+ outword(labels[lab]);
+ labels[lab] = WordSize - pc; /* add to front of reference chain */
+ }
+ else /* output relative offset */
+ outword(labels[lab] - (pc + WordSize));
+ }
+
+static void lemitn(op, n, name)
+int op;
+word n;
+char *name;
+ {
+ misalign();
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n,
+ name);
+ #endif /* DeBugLinker */
+
+ outop(op);
+ outword(n);
+ }
+
+
+static void lemitr(op, loc, name)
+int op;
+word loc;
+char *name;
+ {
+ misalign();
+
+ loc -= pc + ((IntBits/ByteBits) + WordSize);
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ if (loc >= 0)
+ fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op,
+ (long)loc, name);
+ else
+ fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op,
+ (long)-loc, name);
+ }
+ #endif /* DeBugLinker */
+
+ outop(op);
+ outword(loc);
+ }
+
+static void lemitin(op, offset, n, name)
+int op, n;
+word offset;
+char *name;
+ {
+ misalign();
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%d\t%d,S+%ld\t\t\t# %s\n", (long)pc, op, n,
+ (long)offset, name);
+ #endif /* DeBugLinker */
+
+ outop(op);
+ outword(n);
+ outword(offset);
+ }
+
+/*
+ * lemitint can have some pitfalls. outword is used to output the
+ * integer and this is picked up in the interpreter as the second
+ * word of a short integer. The integer value output must be
+ * the same size as what the interpreter expects. See op_int and op_intx
+ * in interp.s
+ */
+static void lemitint(op, i, name)
+int op;
+long i;
+char *name;
+ {
+ misalign();
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name);
+ #endif /* DeBugLinker */
+
+ outop(op);
+ outword(i);
+ }
+
+static void lemitcon(k)
+register int k;
+ {
+ register int i, j;
+ register char *s;
+ int csbuf[CsetSize];
+ union {
+ char ovly[1]; /* Array used to overlay l and f on a bytewise basis. */
+ long l;
+ double f;
+ } x;
+
+ if (lctable[k].c_flag & F_RealLit) {
+
+ #ifdef Double
+ /* access real values one word at a time */
+ int *rp, *rq;
+ rp = (int *) &(x.f);
+ rq = (int *) &(lctable[k].c_val.rval);
+ *rp++ = *rq++;
+ *rp = *rq;
+ #else /* Double */
+ x.f = lctable[k].c_val.rval;
+ #endif /* Double */
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ fprintf(dbgfile,"%ld:\t%d\t\t\t\t# real(%g)",(long)pc,T_Real, x.f);
+ dumpblock(x.ovly,sizeof(double));
+ }
+ #endif /* DeBugLinker */
+
+ outword(T_Real);
+
+ #ifdef Double
+ #if WordBits != 64
+ /* fill out real block with an empty word */
+ outword(0);
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile,"\t0\t\t\t\t\t# padding\n");
+ #endif /* DeBugLinker */
+ #endif /* WordBits != 64 */
+ #endif /* Double */
+
+ outblock(x.ovly,sizeof(double));
+ }
+ else if (lctable[k].c_flag & F_CsetLit) {
+ for (i = 0; i < CsetSize; i++)
+ csbuf[i] = 0;
+ s = &lsspace[lctable[k].c_val.sval];
+ i = lctable[k].c_length;
+ while (i--) {
+ Setb(*s, csbuf);
+ s++;
+ }
+ j = 0;
+ for (i = 0; i < 256; i++) {
+ if (Testb(i, csbuf))
+ j++;
+ }
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset);
+ fprintf(dbgfile, "\t%d\n",j);
+ }
+ #endif /* DeBugLinker */
+
+ outword(T_Cset);
+ outword(j); /* cset size */
+ outblock((char *)csbuf,sizeof(csbuf));
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ dumpblock((char *)csbuf,CsetSize);
+ #endif /* DeBugLinker */
+
+ }
+ }
+
+static void lemitproc(name, nargs, ndyn, nstat, fstat)
+word name;
+int nargs, ndyn, nstat, fstat;
+ {
+ register int i;
+ register char *p;
+ word s_indx;
+ int size;
+ /*
+ * FncBlockSize = sizeof(BasicFncBlock) +
+ * sizeof(descrip)*(# of args + # of dynamics + # of statics).
+ */
+ size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat);
+
+ p = &lsspace[name];
+ #ifdef DeBugLinker
+ if (Dflag) {
+ fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */
+ fprintf(dbgfile, "\t%d\n", size); /* size of block */
+ fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size)); /* entry point */
+ fprintf(dbgfile, "\t%d\n", nargs); /* # arguments */
+ fprintf(dbgfile, "\t%d\n", ndyn); /* # dynamic locals */
+ fprintf(dbgfile, "\t%d\n", nstat); /* # static locals */
+ fprintf(dbgfile, "\t%d\n", fstat); /* first static */
+ fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", /* name of procedure */
+ (int)strlen(p), (long)(name), p);
+ }
+ #endif /* DeBugLinker */
+
+ outword(T_Proc);
+ outword(size);
+ outword(pc + size - 2*WordSize); /* Have to allow for the two words
+ that we've already output. */
+ outword(nargs);
+ outword(ndyn);
+ outword(nstat);
+ outword(fstat);
+ outword(strlen(p)); /* procedure name: length & offset */
+ outword(name);
+
+ /*
+ * Output string descriptors for argument names by looping through
+ * all locals, and picking out those with F_Argument set.
+ */
+ for (i = 0; i <= nlocal; i++) {
+ if (lltable[i].l_flag & F_Argument) {
+ s_indx = lltable[i].l_name;
+ p = &lsspace[s_indx];
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p),
+ (long)s_indx, p);
+ #endif /* DeBugLinker */
+
+ outword(strlen(p));
+ outword(s_indx);
+ }
+ }
+
+ /*
+ * Output string descriptors for local variable names.
+ */
+ for (i = 0; i <= nlocal; i++) {
+ if (lltable[i].l_flag & F_Dynamic) {
+ s_indx = lltable[i].l_name;
+ p = &lsspace[s_indx];
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p),
+ (long)s_indx, p);
+ #endif /* DeBugLinker */
+
+ outword(strlen(p));
+ outword(s_indx);
+ }
+ }
+
+ /*
+ * Output string descriptors for static variable names.
+ */
+ for (i = 0; i <= nlocal; i++) {
+ if (lltable[i].l_flag & F_Static) {
+ s_indx = lltable[i].l_name;
+ p = &lsspace[s_indx];
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p),
+ (long)s_indx, p);
+ #endif /* DeBugLinker */
+
+ outword(strlen(p));
+ outword(s_indx);
+ }
+ }
+ }
+
+/*
+ * gentables - generate interpreter code for global, static,
+ * identifier, and record tables, and built-in procedure blocks.
+ */
+
+void gentables()
+ {
+ register int i;
+ register char *s;
+ register struct gentry *gp;
+ struct fentry *fp;
+ struct rentry *rp;
+ struct header hdr;
+
+ /*
+ * Output record constructor procedure blocks.
+ */
+ align();
+ hdr.Records = pc;
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ fprintf(dbgfile, "\n\n# global tables\n");
+ fprintf(dbgfile, "\n%ld:\t%d\t\t\t\t# record blocks\n",
+ (long)pc, nrecords);
+ }
+ #endif /* DeBugLinker */
+
+ outword(nrecords);
+ for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
+ if ((gp->g_flag & F_Record) && gp->g_procid > 0) {
+ s = &lsspace[gp->g_name];
+ gp->g_pc = pc;
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ fprintf(dbgfile, "%ld:\n", pc);
+ fprintf(dbgfile, "\t%d\n", T_Proc);
+ fprintf(dbgfile, "\t%d\n", RkBlkSize(gp));
+ fprintf(dbgfile, "\t_mkrec\n");
+ fprintf(dbgfile, "\t%d\n", gp->g_nargs);
+ fprintf(dbgfile, "\t-2\n");
+ fprintf(dbgfile, "\t%d\n", gp->g_procid);
+ fprintf(dbgfile, "\t1\n");
+ fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(s),
+ (long)gp->g_name, s);
+ }
+ #endif /* DeBugLinker */
+
+ outword(T_Proc); /* type code */
+ outword(RkBlkSize(gp));
+ outword(0); /* entry point (filled in by interp)*/
+ outword(gp->g_nargs); /* number of fields */
+ outword(-2); /* record constructor indicator */
+ outword(gp->g_procid); /* record id */
+ outword(1); /* serial number */
+ outword(strlen(s)); /* name of record: size and offset */
+ outword(gp->g_name);
+
+ for (i=0;i<gp->g_nargs;i++) { /* field names (filled in by interp) */
+ int foundit = 0;
+ /*
+ * Find the field list entry corresponding to field i in
+ * record gp, then write out a descriptor for it.
+ */
+ for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
+ for (rp = fp->f_rlist; rp!= NULL; rp=rp->r_link) {
+ if (rp->r_gp == gp && rp->r_fnum == i) {
+ if (foundit) {
+ /*
+ * This internal error should never occur
+ */
+ fprintf(stderr,"found rec %d field %d already!!\n",
+ gp->g_procid, i);
+ fflush(stderr);
+ exit(1);
+ }
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n",
+ (int)strlen(&lsspace[fp->f_name]),
+ fp->f_name, &lsspace[fp->f_name]);
+ #endif /* DeBugLinker */
+ outword(strlen(&lsspace[fp->f_name]));
+ outword(fp->f_name);
+ foundit++;
+ }
+ }
+ }
+ if (!foundit) {
+ /*
+ * This internal error should never occur
+ */
+ fprintf(stderr,"never found rec %d field %d!!\n",
+ gp->g_procid,i);
+ fflush(stderr);
+ exit(1);
+ }
+ }
+ }
+ }
+
+ #ifndef FieldTableCompression
+
+ /*
+ * Output record/field table (not compressed).
+ */
+ hdr.Ftab = pc;
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile,"\n%ld:\t\t\t\t\t# record/field table\n",(long)pc);
+ #endif /* DeBugLinker */
+
+ for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t\t\t\t\t# %s\n", (long)pc,
+ &lsspace[fp->f_name]);
+ #endif /* DeBugLinker */
+ rp = fp->f_rlist;
+ for (i = 1; i <= nrecords; i++) {
+ while (rp != NULL && rp->r_gp->g_procid < 0)
+ rp = rp->r_link; /* skip unreferenced constructor */
+ if (rp != NULL && rp->r_gp->g_procid == i) {
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\t%d\n", rp->r_fnum);
+ #endif /* DeBugLinker */
+ outop(rp->r_fnum);
+ rp = rp->r_link;
+ }
+ else {
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "\t-1\n");
+ #endif /* DeBugLinker */
+ outop(-1);
+ }
+ #ifdef DeBugLinker
+ if (Dflag && (i == nrecords || (i & 03) == 0))
+ putc('\n', dbgfile);
+ #endif /* DeBugLinker */
+ }
+ }
+
+ #else /* FieldTableCompression */
+
+ /*
+ * Output record/field table (compressed).
+ * This code has not been tested recently.
+ */
+ {
+ int counter = 0, f_num, first, begin, end, entries;
+ int *f_fo, *f_row, *f_tabp;
+ char *f_bm;
+ int pointer, first_avail = 0, inserted, bytes;
+ hdr.Fo = pc;
+
+ /*
+ * Compute the field width required for this binary;
+ * it is determined by the maximum # of fields in any one record.
+ */
+ long ct = 0;
+ for (gp = lgfirst; gp != NULL; gp = gp->g_next)
+ if ((gp->g_flag & F_Record) && gp->g_procid > 0)
+ if (gp->g_nargs > ct) ct=gp->g_nargs;
+ if (ct > 65535L) hdr.FtabWidth = 4;
+ else if (ct > 254) hdr.FtabWidth = 2; /* 255 is (not present) */
+ else hdr.FtabWidth = 1;
+
+ /* Find out how many field names there are. */
+ hdr.Nfields = 0;
+ for (fp = lffirst; fp != NULL; fp = fp->f_nextentry)
+ hdr.Nfields++;
+
+ entries = hdr.Nfields * nrecords / 4 + 1;
+ f_tabp = malloc (entries * sizeof (int));
+ for (i = 0; i < entries; i++)
+ f_tabp[i] = -1;
+ f_fo = malloc (hdr.Nfields * sizeof (int));
+
+ bytes = nrecords / 8;
+ if (nrecords % 8 != 0)
+ bytes++;
+ f_bm = calloc (hdr.Nfields, bytes);
+ f_row = malloc (nrecords * sizeof (int));
+ f_num = 0;
+
+ for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
+ rp = fp->f_rlist;
+ first = 1;
+ for (i = 0; i < nrecords; i++) {
+ while (rp != NULL && rp->r_gp->g_procid < 0)
+ rp = rp->r_link; /* skip unreferenced constructor */
+ if (rp != NULL && rp->r_gp->g_procid == i + 1) {
+ if (first) {
+ first = 0;
+ begin = end = i;
+ }
+ else
+ end = i;
+ f_row[i] = rp->r_fnum;
+ rp = rp->r_link;
+ }
+ else {
+ f_row[i] = -1;
+ }
+ }
+
+ inserted = 0;
+ pointer = first_avail;
+ while (!inserted) {
+ inserted = 1;
+ for (i = begin; i <= end; i++) {
+ if (pointer + (end - begin) >= entries) {
+ int j;
+ int old_entries = entries;
+ entries *= 2;
+ f_tabp = realloc (f_tabp, entries * sizeof (int));
+ for (j = old_entries; j < entries; j++)
+ f_tabp[j] = -1;
+ }
+ if (f_row[i] != -1)
+ if (f_tabp[pointer + (i - begin)] != -1) {
+ inserted = 0;
+ break;
+ }
+ }
+ pointer++;
+ }
+ pointer--;
+
+ /* Create bitmap */
+ for (i = 0; i < nrecords; i++) {
+ int index = f_num * bytes + i / 8;
+ /* Picks out byte within bitmap row */
+ if (f_row[i] != -1) {
+ f_bm[index] |= 01;
+ }
+ if (i % 8 != 7)
+ f_bm [index] <<= 1;
+ }
+
+ if (nrecords%8)
+ f_bm[(f_num + 1) * bytes - 1] <<= 7 - (nrecords % 8);
+
+ f_fo[f_num++] = pointer - begin;
+ /* So that f_fo[] points to the first bit */
+
+ for (i = begin; i <= end; i++)
+ if (f_row[i] != -1)
+ f_tabp[pointer + (i - begin)] = f_row[i];
+ if (pointer + (end - begin) >= counter)
+ counter = pointer + (end - begin + 1);
+ while ((f_tabp[first_avail] != -1) && (first_avail <= counter))
+ first_avail++;
+ }
+
+ /* Write out the arrays. */
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf (dbgfile, "\n%ld:\t\t\t\t\t# field offset array\n",
+ (long)pc);
+ #endif /* DeBugLinker */
+
+ /*
+ * Compute largest value stored in fo array
+ */
+ {
+ word maxfo = 0;
+ for (i = 0; i < hdr.Nfields; i++) {
+ if (f_fo[i] > maxfo) maxfo = f_fo[i];
+ }
+ if (maxfo < 254)
+ hdr.FoffWidth = 1;
+ else if (maxfo < 65535L)
+ hdr.FoffWidth = 2;
+ else
+ hdr.FoffWidth = 4;
+ }
+
+ for (i = 0; i < hdr.Nfields; i++) {
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf (dbgfile, "\t%d\n", f_fo[i]);
+ #endif /* DeBugLinker */
+ if (hdr.FoffWidth == 1) {
+ outchar(f_fo[i]);
+ }
+ else if (hdr.FoffWidth == 2)
+ outshort(f_fo[i]);
+ else
+ outop (f_fo[i]);
+ }
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf (dbgfile, "\n%ld:\t\t\t\t\t# Bit maps array\n",
+ (long)pc);
+ #endif /* DeBugLinker */
+
+ for (i = 0; i < hdr.Nfields; i++) {
+ #ifdef DeBugLinker
+ if (Dflag) {
+ int ct, index = i * bytes;
+ unsigned char this_bit = 0200;
+
+ fprintf (dbgfile, "\t");
+ for (ct = 0; ct < nrecords; ct++) {
+ if ((f_bm[index] | this_bit) == f_bm[index])
+ fprintf (dbgfile, "1");
+ else
+ fprintf (dbgfile, "0");
+
+ if (ct % 8 == 7) {
+ fprintf (dbgfile, " ");
+ index++;
+ this_bit = 0200;
+ }
+ else
+ this_bit >>= 1;
+ }
+ fprintf (dbgfile, "\n");
+ }
+ #endif /* DeBugLinker */
+ for (pointer = i * bytes; pointer < (i + 1) * bytes; pointer++) {
+ outchar (f_bm[pointer]);
+ }
+ }
+
+ align();
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf (dbgfile, "\n%ld:\t\t\t\t\t# record/field array\n",
+ (long)pc);
+ #endif /* DeBugLinker */
+
+ hdr.Ftab = pc;
+ for (i = 0; i < counter; i++) {
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf (dbgfile, "\t%d\t%d\n", i, f_tabp[i]);
+ #endif /* DeBugLinker */
+ if (hdr.FtabWidth == 1)
+ outchar(f_tabp[i]);
+ else if (hdr.FtabWidth == 2)
+ outshort(f_tabp[i]);
+ else
+ outop (f_tabp[i]);
+ }
+
+ /* Free memory allocated by Jigsaw. */
+ free (f_fo);
+ free (f_bm);
+ free (f_tabp);
+ free (f_row);
+ }
+
+ #endif /* FieldTableCompression */
+
+ /*
+ * Output descriptors for field names.
+ */
+ align();
+ hdr.Fnames = pc;
+ for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
+ s = &lsspace[fp->f_name];
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n",
+ (long)pc, (int)strlen(s), (long)fp->f_name, s);
+ #endif /* DeBugLinker */
+
+ outword(strlen(s)); /* name of field: length & offset */
+ outword(fp->f_name);
+ }
+
+ /*
+ * Output global variable descriptors.
+ */
+ hdr.Globals = pc;
+ for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
+ if (gp->g_flag & F_Builtin) { /* function */
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n",
+ (long)pc, (long)D_Proc, -gp->g_procid, &lsspace[gp->g_name]);
+ #endif /* DeBugLinker */
+ outword(D_Proc);
+ outword(-gp->g_procid);
+ }
+ else if (gp->g_flag & F_Proc) { /* Icon procedure */
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n",
+ (long)pc,(long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]);
+ #endif /* DeBugLinker */
+ outword(D_Proc);
+ outword(gp->g_pc);
+ }
+ else if (gp->g_flag & F_Record) { /* record constructor */
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", (long) pc,
+ (long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]);
+ #endif /* DeBugLinker */
+ outword(D_Proc);
+ outword(gp->g_pc);
+ }
+ else { /* simple global variable */
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc,
+ (long)D_Null, &lsspace[gp->g_name]);
+ #endif /* DeBugLinker */
+ outword(D_Null);
+ outword(0);
+ }
+ }
+
+ /*
+ * Output descriptors for global variable names.
+ */
+ hdr.Gnames = pc;
+ for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n",
+ (long)pc, (int)strlen(&lsspace[gp->g_name]), (long)(gp->g_name),
+ &lsspace[gp->g_name]);
+ #endif /* DeBugLinker */
+
+ outword(strlen(&lsspace[gp->g_name]));
+ outword(gp->g_name);
+ }
+
+ /*
+ * Output a null descriptor for each static variable.
+ */
+ hdr.Statics = pc;
+ for (i = lstatics; i > 0; i--) {
+
+ #ifdef DeBugLinker
+ if (Dflag)
+ fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc);
+ #endif /* DeBugLinker */
+
+ outword(D_Null);
+ outword(0);
+ }
+ flushcode();
+
+ /*
+ * Output the string constant table and the two tables associating icode
+ * locations with source program locations. Note that the calls to write
+ * really do all the work.
+ */
+
+ hdr.Filenms = pc;
+ if (longwrite((char *)fnmtbl, (long)((char *)fnmfree - (char *)fnmtbl),
+ outfile) < 0)
+ quit("cannot write icode file");
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ int k = 0;
+ struct ipc_fname *ptr;
+ for (ptr = fnmtbl; ptr < fnmfree; ptr++) {
+ fprintf(dbgfile, "%ld:\t%03d\tS+%03d\t\t\t# %s\n",
+ (long)(pc + k), ptr->ipc, ptr->fname, &lsspace[ptr->fname]);
+ k = k + 8;
+ }
+ putc('\n', dbgfile);
+ }
+
+ #endif /* DeBugLinker */
+
+ pc += (char *)fnmfree - (char *)fnmtbl;
+
+ hdr.linenums = pc;
+ if (longwrite((char *)lntable, (long)((char *)lnfree - (char *)lntable),
+ outfile) < 0)
+ quit("cannot write icode file");
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ int k = 0;
+ struct ipc_line *ptr;
+ for (ptr = lntable; ptr < lnfree; ptr++) {
+ fprintf(dbgfile, "%ld:\t%03d\t%03d\n", (long)(pc + k),
+ ptr->ipc, ptr->line);
+ k = k + 8;
+ }
+ putc('\n', dbgfile);
+ }
+
+ #endif /* DeBugLinker */
+
+ pc += (char *)lnfree - (char *)lntable;
+
+ hdr.Strcons = pc;
+ #ifdef DeBugLinker
+ if (Dflag) {
+ int c, j, k;
+ j = k = 0;
+ for (s = lsspace; s < &lsspace[lsfree]; ) {
+ fprintf(dbgfile, "%ld:\t%03o", (long)(pc + k), *s++ & 0377);
+ k = k + 8;
+ for (i = 7; i > 0; i--) {
+ if (s >= &lsspace[lsfree])
+ fprintf(dbgfile," ");
+ else
+ fprintf(dbgfile, " %03o", *s++ & 0377);
+ }
+ fprintf(dbgfile, " ");
+ for (i = 0; i < 8; i++)
+ if (j < lsfree) {
+ c = lsspace[j++];
+ putc(isprint(c & 0377) ? c : ' ', dbgfile);
+ }
+ putc('\n', dbgfile);
+ }
+ }
+
+ #endif /* DeBugLinker */
+
+ if (longwrite(lsspace, (long)lsfree, outfile) < 0)
+ quit("cannot write icode file");
+
+ pc += lsfree;
+
+ /*
+ * Output icode file header.
+ */
+ hdr.hsize = pc;
+ strcpy((char *)hdr.config,IVersion);
+ hdr.trace = trace;
+
+
+ #ifdef DeBugLinker
+ if (Dflag) {
+ fprintf(dbgfile, "\n");
+ fprintf(dbgfile, "size: %ld\n", (long)hdr.hsize);
+ fprintf(dbgfile, "trace: %ld\n", (long)hdr.trace);
+ fprintf(dbgfile, "records: %ld\n", (long)hdr.Records);
+ fprintf(dbgfile, "ftab: %ld\n", (long)hdr.Ftab);
+ fprintf(dbgfile, "fnames: %ld\n", (long)hdr.Fnames);
+ fprintf(dbgfile, "globals: %ld\n", (long)hdr.Globals);
+ fprintf(dbgfile, "gnames: %ld\n", (long)hdr.Gnames);
+ fprintf(dbgfile, "statics: %ld\n", (long)hdr.Statics);
+ fprintf(dbgfile, "strcons: %ld\n", (long)hdr.Strcons);
+ fprintf(dbgfile, "filenms: %ld\n", (long)hdr.Filenms);
+ fprintf(dbgfile, "linenums: %ld\n", (long)hdr.linenums);
+ fprintf(dbgfile, "config: %s\n", hdr.config);
+ }
+ #endif /* DeBugLinker */
+
+ fseek(outfile, hdrsize, 0);
+ if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0)
+ quit("cannot write icode file");
+
+ if (verbose >= 2) {
+ word tsize = sizeof(hdr) + hdr.hsize;
+ fprintf(stderr, " bootstrap %7ld\n", hdrsize);
+ tsize += hdrsize;
+ fprintf(stderr, " header %7ld\n", (long)sizeof(hdr));
+ fprintf(stderr, " procedures %7ld\n", (long)hdr.Records);
+ fprintf(stderr, " records %7ld\n", (long)(hdr.Ftab - hdr.Records));
+ fprintf(stderr, " fields %7ld\n", (long)(hdr.Globals - hdr.Ftab));
+ fprintf(stderr, " globals %7ld\n", (long)(hdr.Statics - hdr.Globals));
+ fprintf(stderr, " statics %7ld\n", (long)(hdr.Filenms - hdr.Statics));
+ fprintf(stderr, " linenums %7ld\n", (long)(hdr.Strcons - hdr.Filenms));
+ fprintf(stderr, " strings %7ld\n", (long)(hdr.hsize - hdr.Strcons));
+ fprintf(stderr, " total %7ld\n", (long)tsize);
+ }
+ }
+
+/*
+ * align() outputs zeroes as padding until pc is a multiple of WordSize.
+ */
+static void align()
+ {
+ static word x = 0;
+
+ if (pc % WordSize != 0)
+ outblock((char *)&x, (int)(WordSize - (pc % WordSize)));
+ }
+
+/*
+ * misalign() outputs a Noop instruction for padding if pc + sizeof(int)
+ * is not a multiple of WordSize. This is for operations that output
+ * an int opcode followed by an operand that needs to be word-aligned.
+ */
+static void misalign()
+ {
+ if ((pc + IntBits/ByteBits) % WordSize != 0)
+ lemit(Op_Noop, "noop [pad]");
+ }
+
+/*
+ * intout(i) outputs i as an int that is used by the runtime system
+ * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0].
+ */
+static void intout(oint)
+int oint;
+ {
+ int i;
+ union {
+ int i;
+ char c[IntBits/ByteBits];
+ } u;
+
+ CodeCheck(IntBits/ByteBits);
+ u.i = oint;
+
+ for (i = 0; i < IntBits/ByteBits; i++)
+ codep[i] = u.c[i];
+
+ codep += IntBits/ByteBits;
+ pc += IntBits/ByteBits;
+ }
+
+#ifdef FieldTableCompression
+/*
+ * charout(i) outputs i as an unsigned char that is used by the runtime system
+ */
+static void charout(unsigned char ochar)
+ {
+ CodeCheck(1);
+ *codep++ = (unsigned char)ochar;
+ pc++;
+ }
+/*
+ * shortout(i) outputs i as a short that is used by the runtime system
+ * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0].
+ */
+static void shortout(short oint)
+ {
+ int i;
+ union {
+ short i;
+ char c[2];
+ } u;
+
+ CodeCheck(2);
+ u.i = oint;
+
+ for (i = 0; i < 2; i++)
+ codep[i] = u.c[i];
+
+ codep += 2;
+ pc += 2;
+ }
+#endif /* FieldTableCompression */
+
+
+/*
+ * wordout(i) outputs i as a word that is used by the runtime system
+ * WordSize bytes must be moved from &oword[0] to &codep[0].
+ */
+static void wordout(oword)
+word oword;
+ {
+ int i;
+ union {
+ word i;
+ char c[WordSize];
+ } u;
+
+ CodeCheck(WordSize);
+ u.i = oword;
+
+ for (i = 0; i < WordSize; i++)
+ codep[i] = u.c[i];
+
+ codep += WordSize;
+ pc += WordSize;
+ }
+
+/*
+ * outblock(a,i) output i bytes starting at address a.
+ */
+static void outblock(addr,count)
+char *addr;
+int count;
+ {
+ CodeCheck(count);
+ pc += count;
+ while (count--)
+ *codep++ = *addr++;
+ }
+
+#ifdef DeBugLinker
+ /*
+ * dumpblock(a,i) dump contents of i bytes at address a, used only
+ * in conjunction with -L.
+ */
+ static void dumpblock(addr, count)
+ char *addr;
+ int count;
+ {
+ int i;
+ for (i = 0; i < count; i++) {
+ if ((i & 7) == 0)
+ fprintf(dbgfile,"\n\t");
+ fprintf(dbgfile," %03o",(0377 & (unsigned)addr[i]));
+ }
+ putc('\n',dbgfile);
+ }
+ #endif /* DeBugLinker */
+
+/*
+ * flushcode - write buffered code to the output file.
+ */
+static void flushcode()
+ {
+ if (codep > codeb)
+ if (longwrite(codeb, DiffPtrs(codep,codeb), outfile) < 0)
+ quit("cannot write icode file");
+ codep = codeb;
+ }
+
+/*
+ * clearlab - clear label table to all zeroes.
+ */
+static void clearlab()
+ {
+ register int i;
+
+ for (i = 0; i < maxlabels; i++)
+ labels[i] = 0;
+ }
+
+/*
+ * backpatch - fill in all forward references to lab.
+ */
+static void backpatch(lab)
+int lab;
+ {
+ word p, r;
+ char *q;
+ char *cp, *cr;
+ register int j;
+
+ if (lab >= maxlabels)
+ labels = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word),
+ lab - maxlabels + 1, "labels");
+
+ p = labels[lab];
+ if (p > 0)
+ quit("multiply defined label in ucode");
+ while (p < 0) { /* follow reference chain */
+ r = pc - (WordSize - p); /* compute relative offset */
+ q = codep - (pc + p); /* point to word with address */
+ cp = (char *) &p; /* address of integer p */
+ cr = (char *) &r; /* address of integer r */
+ for (j = 0; j < WordSize; j++) { /* move bytes from word pointed to */
+ *cp++ = *q; /* by q to p, and move bytes from */
+ *q++ = *cr++; /* r to word pointed to by q */
+ } /* moves integers at arbitrary addresses */
+ }
+ labels[lab] = pc;
+ }
+
+#ifdef DeBugLinker
+ void idump(s) /* dump code region */
+ char *s;
+ {
+ int *c;
+
+ fprintf(stderr,"\ndump of code region %s:\n",s);
+ for (c = (int *)codeb; c < (int *)codep; c++)
+ fprintf(stderr,"%ld: %d\n",(long)c, (int)*c);
+ fflush(stderr);
+ }
+ #endif /* DeBugLinker */
diff --git a/src/icont/lfile.h b/src/icont/lfile.h
new file mode 100644
index 0000000..1da9746
--- /dev/null
+++ b/src/icont/lfile.h
@@ -0,0 +1,21 @@
+/*
+ * A linked list of files named by link declarations is maintained using
+ * lfile structures.
+ */
+struct lfile {
+ char *lf_name; /* name of the file */
+ struct lfile *lf_link; /* pointer to next file */
+ };
+
+extern struct lfile *lfiles;
+
+
+/*
+ * "Invocable" declarations are recorded in a list of invkl structs.
+ */
+struct invkl {
+ char *iv_name; /* name of global */
+ struct invkl *iv_link; /* link to next entry */
+ };
+
+extern struct invkl *invkls;
diff --git a/src/icont/lglob.c b/src/icont/lglob.c
new file mode 100644
index 0000000..6583b8a
--- /dev/null
+++ b/src/icont/lglob.c
@@ -0,0 +1,356 @@
+/*
+ * lglob.c -- routines for processing globals.
+ */
+
+#include "link.h"
+#include "tglobals.h"
+#include "tproto.h"
+#include "opcode.h"
+#include "../h/version.h"
+
+/*
+ * Prototypes.
+ */
+
+static void scanfile (char *filename);
+static void reference (struct gentry *gp);
+
+int nrecords = 0; /* number of records in program */
+
+/*
+ * readglob reads the global information from infile (.u2) and merges it with
+ * the global table and record table.
+ */
+void readglob()
+ {
+ register word id;
+ register int n, op;
+ int k;
+ int implicit;
+ char *name;
+ struct gentry *gp;
+ extern char *progname;
+
+ if (getopc(&name) != Op_Version)
+ quitf("ucode file %s has no version identification",inname);
+ id = getid(); /* get version number of ucode */
+ newline();
+ if (strcmp(&lsspace[id],UVersion)) {
+ fprintf(stderr,"version mismatch in ucode file %s\n",inname);
+ fprintf(stderr,"\tucode version: %s\n",&lsspace[id]);
+ fprintf(stderr,"\texpected version: %s\n",UVersion);
+ exit(EXIT_FAILURE);
+ }
+ while ((op = getopc(&name)) != EOF) {
+ switch (op) {
+ case Op_Record: /* a record declaration */
+ id = getid(); /* record name */
+ n = getdec(); /* number of fields */
+ newline();
+ gp = glocate(id);
+ /*
+ * It's ok if the name isn't already in use or if the
+ * name is just used in a "global" declaration. Otherwise,
+ * it is an inconsistent redeclaration.
+ */
+ if (gp == NULL || (gp->g_flag & ~F_Global) == 0) {
+ gp = putglobal(id, F_Record, n, ++nrecords);
+ while (n--) { /* loop reading field numbers and names */
+ k = getdec();
+ putfield(getid(), gp, k);
+ newline();
+ }
+ }
+ else {
+ lfatal(&lsspace[id], "inconsistent redeclaration");
+ while (n--)
+ newline();
+ }
+ break;
+
+ case Op_Impl: /* undeclared identifiers should be noted */
+ if (getopc(&name) == Op_Local)
+ implicit = 0;
+ else
+ implicit = F_ImpError;
+ break;
+
+ case Op_Trace: /* turn on tracing */
+ trace = -1;
+ break;
+
+ case Op_Global: /* global variable declarations */
+ n = getdec(); /* number of global declarations */
+ newline();
+ while (n--) { /* process each declaration */
+ getdec(); /* throw away sequence number */
+ k = getoct(); /* get flags */
+ if (k & F_Proc)
+ k |= implicit;
+ id = getid(); /* get variable name */
+ gp = glocate(id);
+ /*
+ * Check for conflicting declarations and install the
+ * variable.
+ */
+ if (gp != NULL && (k & F_Proc) && gp->g_flag != F_Global)
+ lfatal(&lsspace[id], "inconsistent redeclaration");
+ else if (gp == NULL || (k & F_Proc))
+ putglobal(id, k, getdec(), 0);
+ newline();
+ }
+ break;
+
+ case Op_Invocable: /* "invocable" declaration */
+ id = getid(); /* get name */
+ if (lsspace[id] == '0')
+ strinv = 1; /* name of "0" means "invocable all" */
+ else
+ addinvk(&lsspace[id], 2);
+ newline();
+ break;
+
+ case Op_Link: /* link the named file */
+ name = &lsspace[getrest()]; /* get the name and */
+ alsolink(name); /* put it on the list of files to link */
+ newline();
+ break;
+
+ default:
+ quitf("ill-formed global file %s",inname);
+ }
+ }
+ }
+
+/*
+ * scanrefs - scan .u1 files for references and mark unreferenced globals.
+ *
+ * Called only if -fs is *not* specified (or implied by "invocable all").
+ */
+void scanrefs()
+ {
+ int i, n;
+ char *t, *old;
+ struct fentry *fp, **fpp;
+ struct gentry *gp, **gpp;
+ struct rentry *rp;
+ struct lfile *lf, *lfls;
+ struct ientry *ip, *ipnext;
+ struct invkl *inv;
+
+ /*
+ * Loop through .u1 files and accumulate reference lists.
+ */
+ lfls = llfiles;
+ while ((lf = getlfile(&lfls)) != 0)
+ scanfile(lf->lf_name);
+ lstatics = 0; /* discard accumulated statics */
+
+ /*
+ * Mark every global as unreferenced.
+ */
+ for (gp = lgfirst; gp != NULL; gp = gp->g_next)
+ gp->g_flag |= F_Unref;
+
+ /*
+ * Clear the F_Unref flag for referenced globals, starting with main()
+ * and marking references within procedures recursively.
+ */
+ reference(lgfirst);
+
+ /*
+ * Reference (recursively) every global declared to be "invocable".
+ */
+ for (inv = invkls; inv != NULL; inv = inv->iv_link)
+ if ((gp = glocate(instid(inv->iv_name))) != NULL)
+ reference(gp);
+
+ /*
+ * Rebuild the global list to include only referenced globals,
+ * and renumber them. Also renumber all record constructors.
+ * Free all reference lists.
+ */
+ n = 0;
+ nrecords = 0;
+ gpp = &lgfirst;
+ while ((gp = *gpp) != NULL) {
+ if (gp->g_refs != NULL) {
+ free((char *)gp->g_refs); /* free the reference list */
+ gp->g_refs = NULL;
+ }
+ if (gp->g_flag & F_Unref) {
+ /*
+ * Global is not referenced anywhere.
+ */
+ gp->g_index = gp->g_procid = -1; /* flag as unused */
+ if (verbose >= 3) {
+ if (gp->g_flag & F_Proc)
+ t = "procedure";
+ else if (gp->g_flag & F_Record)
+ t = "record ";
+ else
+ t = "global ";
+ if (!(gp->g_flag & F_Builtin))
+ fprintf(stderr, " discarding %s %s\n", t, &lsspace[gp->g_name]);
+ }
+ *gpp = gp->g_next;
+ }
+ else {
+ /*
+ * The global is used. Assign it new serial number(s).
+ */
+ gp->g_index = n++;
+ if (gp->g_flag & F_Record)
+ gp->g_procid = ++nrecords;
+ gpp = &gp->g_next;
+ }
+ }
+
+ /*
+ * Rebuild the field list to include only referenced fields,
+ * and renumber them.
+ */
+ n = 0;
+ fpp = &lffirst;
+ while ((fp = *fpp) != NULL) {
+ for (rp = fp->f_rlist; rp != NULL; rp = rp->r_link)
+ if (rp->r_gp->g_procid > 0) /* if record was referenced */
+ break;
+ if (rp == NULL) {
+ /*
+ * The field was used only in unreferenced record constructors.
+ */
+ fp->f_fid = 0;
+ *fpp = fp->f_nextentry;
+ }
+ else {
+ /*
+ * The field was referenced. Give it the next number.
+ */
+ fp->f_fid = ++n;
+ fpp = &fp->f_nextentry;
+ }
+ }
+
+ /*
+ * Create a new, empty string space, saving a pointer to the old one.
+ * Clear the old identifier hash table.
+ */
+ old = lsspace;
+ lsspace = (char *)tcalloc(stsize, 1);
+ lsfree = 0;
+ for (i = 0; i < ihsize; i++) {
+ for (ip = lihash[i]; ip != NULL; ip = ipnext) {
+ ipnext = ip->i_blink;
+ free((char *)ip);
+ }
+ lihash[i] = NULL;
+ }
+
+ /*
+ * Reinstall the global identifiers that are actually referenced.
+ * This changes the hashing, so clear and rebuild the hash table.
+ */
+ for (i = 0; i < ghsize; i++)
+ lghash[i] = NULL;
+ for (gp = lgfirst; gp != NULL; gp = gp->g_next) {
+ gp->g_name = instid(&old[gp->g_name]);
+ i = ghasher(gp->g_name);
+ gp->g_blink = lghash[i];
+ lghash[i] = gp;
+ }
+
+ /*
+ * Reinstall the referenced record fields in similar fashion.
+ */
+ for (i = 0; i < fhsize; i++)
+ lfhash[i] = NULL;
+ for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) {
+ fp->f_name = instid(&old[fp->f_name]);
+ i = fhasher(fp->f_name);
+ fp->f_blink = lfhash[i];
+ lfhash[i] = fp;
+ }
+
+ /*
+ * Free the old string space.
+ */
+ free((char *)old);
+ }
+
+/*
+ * scanfile -- scan one file for references.
+ */
+static void scanfile(filename)
+char *filename;
+ {
+ int i, k, f, op, nrefs, flags;
+ word id, procid;
+ char *name;
+ struct gentry *gp, **rp;
+
+ makename(inname, SourceDir, filename, U1Suffix);
+ infile = fopen(inname, "r");
+ if (infile == NULL)
+ quitf("cannot open %s", inname);
+
+ while ((op = getopc(&name)) != EOF) {
+ switch (op) {
+ case Op_Proc:
+ procid = getid();
+ newline();
+ gp = glocate(procid);
+ locinit();
+ nrefs = 0;
+ break;
+ case Op_Local:
+ k = getdec();
+ flags = getoct();
+ id = getid();
+ putlocal(k, id, flags, 0, procid);
+ lltable[k].l_flag |= F_Unref;
+ break;
+ case Op_Var:
+ k = getdec();
+ newline();
+ f = lltable[k].l_flag;
+ if ((f & F_Global) && (f & F_Unref)) {
+ lltable[k].l_flag = f & ~F_Unref;
+ nrefs++;
+ }
+ break;
+ case Op_End:
+ newline();
+ if (nrefs > 0) {
+ rp = (struct gentry **)tcalloc(nrefs + 1, sizeof(*rp));
+ gp->g_refs = rp;
+ for (i = 0; i <= nlocal; i++)
+ if ((lltable[i].l_flag & (F_Unref + F_Global)) == F_Global)
+ *rp++ = lltable[i].l_val.global;
+ *rp = NULL;
+ }
+ break;
+ default:
+ newline();
+ break;
+ }
+ }
+
+ fclose(infile);
+ }
+
+/*
+ *
+ */
+static void reference(gp)
+struct gentry *gp;
+ {
+ struct gentry **rp;
+
+ if (gp->g_flag & F_Unref) {
+ gp->g_flag &= ~F_Unref;
+ if ((rp = gp->g_refs) != NULL)
+ while ((gp = *rp++) != 0)
+ reference(gp);
+ }
+ }
diff --git a/src/icont/link.c b/src/icont/link.c
new file mode 100644
index 0000000..362b257
--- /dev/null
+++ b/src/icont/link.c
@@ -0,0 +1,228 @@
+/*
+ * link.c -- linker main program that controls the linking process.
+ */
+
+#include "link.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "../h/header.h"
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+#ifdef BinaryHeader
+ #include "hdr.h"
+#endif /* BinaryHeader */
+
+static void setexe (char *fname);
+
+FILE *infile; /* input file (.u1 or .u2) */
+FILE *outfile; /* interpreter code output file */
+
+#ifdef DeBugLinker
+ FILE *dbgfile; /* debug file */
+ static char dbgname[MaxPath]; /* debug file name */
+#endif /* DeBugLinker */
+
+struct lfile *llfiles = NULL; /* List of files to link */
+
+char inname[MaxPath]; /* input file name */
+
+char icnname[MaxPath]; /* current icon source file name */
+int colmno = 0; /* current source column number */
+int lineno = 0; /* current source line number */
+int fatals = 0; /* number of errors encountered */
+
+/*
+ * ilink - link a number of files, returning error count
+ */
+int ilink(ifiles,outname)
+char **ifiles;
+char *outname;
+ {
+ int i;
+ struct lfile *lf,*lfls;
+ char *filename; /* name of current input file */
+
+ linit(); /* initialize memory structures */
+ while (*ifiles)
+ alsolink(*ifiles++); /* make initial list of files */
+
+ /*
+ * Phase I: load global information contained in .u2 files into
+ * data structures.
+ *
+ * The list of files to link is maintained as a queue with llfiles
+ * as the base. lf moves along the list. Each file is processed
+ * in turn by forming .u2 and .icn names from each file name, each
+ * of which ends in .u1. The .u2 file is opened and globals is called
+ * to process it. When the end of the list is reached, lf becomes
+ * NULL and the loop is terminated, completing phase I. Note that
+ * link instructions in the .u2 file cause files to be added to list
+ * of files to link.
+ */
+ for (lf = llfiles; lf != NULL; lf = lf->lf_link) {
+ filename = lf->lf_name;
+ makename(inname, SourceDir, filename, U2Suffix);
+ makename(icnname, TargetDir, filename, SourceSuffix);
+ infile = fopen(inname, "r");
+ if (infile == NULL)
+ quitf("cannot open %s",inname);
+ readglob();
+ fclose(infile);
+ }
+
+ /* Phase II (optional): scan code and suppress unreferenced procs. */
+ if (!strinv)
+ scanrefs();
+
+ /* Phase III: resolve undeclared variables and generate code. */
+
+ /*
+ * Open the output file.
+ */
+ outfile = fopen(outname, "wb");
+
+ if (outfile == NULL) { /* may exist, but can't open for "w" */
+ ofile = NULL; /* so don't delete if it's there */
+ quitf("cannot create %s",outname);
+ }
+
+ /*
+ * Write the bootstrap header to the output file.
+ */
+ #ifdef BinaryHeader
+ /*
+ * With BinaryHeader defined, always write MaxHdr bytes.
+ */
+ fwrite(iconxhdr, sizeof(char), MaxHdr, outfile);
+ hdrsize = MaxHdr;
+
+ #else /* BinaryHeader */
+ /*
+ * Write a short shell header terminated by \n\f\n\0.
+ * Use magic "#!/bin/sh" to ensure that $0 is set when run via $PATH.
+ * Pad header to a multiple of 8 characters.
+ *
+ * The shell header searches for iconx in this order:
+ * a. location specified by ICONX environment variable
+ * (if specified, this MUST work, else the script exits)
+ * b. iconx in same directory as executing binary
+ * c. location specified in script
+ * (as generated by icont or as patched later)
+ * d. iconx in $PATH
+ *
+ * The ugly ${1+"$@"} is a workaround for non-POSIX handling
+ * of "$@" by some shells in the absence of any arguments.
+ * Thanks to the Unix-haters handbook for this trick.
+ */
+ {
+ char script[2 * MaxPath + 300];
+ sprintf(script, "%s\n%s%-72s\n%s\n\n%s\n%s\n%s\n%s\n\n%s\n",
+ "#!/bin/sh",
+ "IXBIN=", iconxloc,
+ "IXLCL=`echo $0 | sed 's=[^/]*$=iconx='`",
+ "[ -n \"$ICONX\" ] && exec \"$ICONX\" $0 ${1+\"$@\"}",
+ "[ -x \"$IXLCL\" ] && exec \"$IXLCL\" $0 ${1+\"$@\"}",
+ "[ -x \"$IXBIN\" ] && exec \"$IXBIN\" $0 ${1+\"$@\"}",
+ "exec iconx $0 ${1+\"$@\"}",
+ "[executable Icon binary follows]");
+ strcat(script, " \n\f\n" + ((int)(strlen(script) + 4) % 8));
+ hdrsize = strlen(script) + 1; /* length includes \0 at end */
+ fwrite(script, hdrsize, 1, outfile); /* write header */
+ }
+
+ #endif /* BinaryHeader */
+
+ for (i = sizeof(struct header); i--;)
+ putc(0, outfile);
+ fflush(outfile);
+ if (ferror(outfile) != 0)
+ quit("unable to write to icode file");
+
+ #ifdef DeBugLinker
+ /*
+ * Open the .ux file if debugging is on.
+ */
+ if (Dflag) {
+ makename(dbgname, TargetDir, llfiles->lf_name, ".ux");
+ dbgfile = fopen(dbgname, "w");
+ if (dbgfile == NULL)
+ quitf("cannot create %s", dbgname);
+ }
+ #endif /* DeBugLinker */
+
+ /*
+ * Loop through input files and generate code for each.
+ */
+ lfls = llfiles;
+ while ((lf = getlfile(&lfls)) != 0) {
+ filename = lf->lf_name;
+ makename(inname, SourceDir, filename, U1Suffix);
+ makename(icnname, TargetDir, filename, SourceSuffix);
+ infile = fopen(inname, "r");
+ if (infile == NULL)
+ quitf("cannot open %s", inname);
+ gencode();
+ fclose(infile);
+ }
+
+ gentables(); /* Generate record, field, global, global names,
+ static, and identifier tables. */
+
+ fclose(outfile);
+ lmfree();
+ if (fatals > 0)
+ return fatals;
+ setexe(outname);
+ return 0;
+ }
+
+/*
+ * lwarn - issue a linker warning message.
+ */
+void lwarn(s1, s2, s3)
+char *s1, *s2, *s3;
+ {
+ fprintf(stderr, "%s: ", icnname);
+ if (lineno)
+ fprintf(stderr, "Line %d # :", lineno);
+ fprintf(stderr, "\"%s\": %s%s\n", s1, s2, s3);
+ fflush(stderr);
+ }
+
+/*
+ * lfatal - issue a fatal linker error message.
+ */
+
+void lfatal(s1, s2)
+char *s1, *s2;
+ {
+ fatals++;
+ fprintf(stderr, "%s: ", icnname);
+ if (lineno)
+ fprintf(stderr, "Line %d # : ", lineno);
+ fprintf(stderr, "\"%s\": %s\n", s1, s2);
+ }
+
+/*
+ * setexe - mark the output file as executable
+ */
+
+static void setexe(fname)
+char *fname;
+ {
+ struct stat stbuf;
+ int u, r, m;
+ /*
+ * Set each of the three execute bits (owner,group,other) if allowed by
+ * the current umask and if the corresponding read bit is set; do not
+ * clear any bits already set.
+ */
+ umask(u = umask(0)); /* get and restore umask */
+ if (stat(fname,&stbuf) == 0) { /* must first read existing mode */
+ r = (stbuf.st_mode & 0444) >> 2; /* get & position read bits */
+ m = stbuf.st_mode | (r & ~u); /* set execute bits */
+ chmod(fname,m); /* change file mode */
+ }
+ }
diff --git a/src/icont/link.h b/src/icont/link.h
new file mode 100644
index 0000000..f49d436
--- /dev/null
+++ b/src/icont/link.h
@@ -0,0 +1,143 @@
+/*
+ * External declarations for the linker.
+ */
+
+#include "../h/rt.h"
+
+/*
+ * Miscellaneous external declarations.
+ */
+
+extern FILE *infile; /* current input file */
+extern FILE *outfile; /* linker output file */
+extern FILE *dbgfile; /* debug file */
+extern char inname[]; /* input file name */
+extern char icnname[]; /* source program file name */
+extern int lineno; /* source program line number (from ucode) */
+extern int colmno; /* source program column number */
+
+extern int lstatics; /* total number of statics */
+extern int argoff; /* stack offset counter for arguments */
+extern int dynoff; /* stack offset counter for locals */
+extern int static1; /* first static in procedure */
+extern int nlocal; /* number of locals in local table */
+extern int nconst; /* number of constants in constant table */
+extern int nrecords; /* number of records in program */
+extern int trace; /* initial setting of &trace */
+extern char ixhdr[]; /* header line for direct execution */
+extern char *iconx; /* location of iconx */
+extern int hdrloc; /* location to place hdr block at */
+extern struct lfile *llfiles; /* list of files to link */
+
+/*
+ * Structures for symbol table entries.
+ */
+
+struct lentry { /* local table entry */
+ word l_name; /* index into string space of variable name */
+ int l_flag; /* variable flags */
+ union { /* value field */
+ int staticid; /* unique id for static variables */
+ word offset; /* stack offset for args and locals */
+ struct gentry *global; /* global table entry */
+ } l_val;
+ };
+
+struct gentry { /* global table entry */
+ struct gentry *g_blink; /* link for bucket chain */
+ word g_name; /* index into string space of variable name */
+ int g_flag; /* variable flags */
+ int g_nargs; /* number of args or fields */
+ int g_procid; /* procedure or record id */
+ word g_pc; /* position in icode of object */
+ int g_index; /* "index" in global table */
+ struct gentry **g_refs; /* other globals referenced, if a proc */
+ struct gentry *g_next; /* next global in table */
+ };
+
+struct centry { /* constant table entry */
+ int c_flag; /* type of literal flag */
+ union xval c_val; /* value field */
+ int c_length; /* length of literal string */
+ word c_pc; /* position in icode of object */
+ };
+
+struct ientry { /* identifier table entry */
+ struct ientry *i_blink; /* link for bucket chain */
+ word i_name; /* index into string space of string */
+ int i_length; /* length of string */
+ };
+
+struct fentry { /* field table header entry */
+ struct fentry *f_blink; /* link for bucket chain */
+ word f_name; /* index into string space of field name */
+ int f_fid; /* field id */
+ struct rentry *f_rlist; /* head of list of records */
+ struct fentry *f_nextentry; /* next field name in allocation order */
+ };
+
+struct rentry { /* field table record list entry */
+ struct rentry *r_link; /* link for list of records */
+ struct gentry *r_gp; /* global entry for record */
+ int r_fnum; /* offset of field within record */
+ };
+
+#include "lfile.h"
+
+/*
+ * Flag values in symbol tables.
+ */
+
+#define F_Global 01 /* variable declared global externally */
+#define F_Unref 02 /* procedure is unreferenced */
+#define F_Proc 04 /* procedure */
+#define F_Record 010 /* record */
+#define F_Dynamic 020 /* variable declared local dynamic */
+#define F_Static 040 /* variable declared local static */
+#define F_Builtin 0100 /* identifier refers to built-in procedure */
+#define F_ImpError 0400 /* procedure has default error */
+#define F_Argument 01000 /* variable is a formal parameter */
+#define F_IntLit 02000 /* literal is an integer */
+#define F_RealLit 04000 /* literal is a real */
+#define F_StrLit 010000 /* literal is a string */
+#define F_CsetLit 020000 /* literal is a cset */
+
+/*
+ * Symbol table region pointers.
+ */
+
+extern struct gentry **lghash; /* hash area for global table */
+extern struct ientry **lihash; /* hash area for identifier table */
+extern struct fentry **lfhash; /* hash area for field table */
+
+extern struct lentry *lltable; /* local table */
+extern struct centry *lctable; /* constant table */
+extern struct ipc_fname *fnmtbl; /* table associating ipc with file name */
+extern struct ipc_line *lntable; /* table associating ipc with line number */
+extern char *lsspace; /* string space */
+extern word *labels; /* label table */
+extern char *codeb; /* generated code space */
+
+extern struct ipc_fname *fnmfree; /* free pointer for ipc/file name tbl */
+extern struct ipc_line *lnfree; /* free pointer for ipc/line number tbl */
+extern word lsfree; /* free index for string space */
+extern char *codep; /* free pointer for code space */
+
+extern struct fentry *lffirst; /* first field table entry */
+extern struct fentry *lflast; /* last field table entry */
+extern struct gentry *lgfirst; /* first global table entry */
+extern struct gentry *lglast; /* last global table entry */
+
+
+/*
+ * Hash computation macros.
+ */
+
+#define ghasher(x) (((word)x)&gmask) /* for global table */
+#define fhasher(x) (((word)x)&fmask) /* for field table */
+
+/*
+ * Machine-dependent constants.
+ */
+
+#define RkBlkSize(gp) ((9*WordSize)+(gp)->g_nargs * sizeof(struct descrip))
diff --git a/src/icont/llex.c b/src/icont/llex.c
new file mode 100644
index 0000000..8b62d59
--- /dev/null
+++ b/src/icont/llex.c
@@ -0,0 +1,318 @@
+/*
+ * llex.c -- lexical analysis routines.
+ */
+
+#include "link.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "opcode.h"
+
+int nlflag = 0; /* newline last seen */
+
+#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9))
+
+/*
+ * getopc - get an opcode from infile, return the opcode number (via
+ * binary search of opcode table), and point id at the name of the opcode.
+ */
+int getopc(id)
+char **id;
+ {
+ register char *s;
+ register struct opentry *p;
+ register int test;
+ word indx;
+ int low, high, cmp;
+
+ indx = getstr();
+ if (indx == -1)
+ return EOF;
+ s = &lsspace[indx];
+ low = 0;
+ high = NOPCODES;
+ do {
+ test = (low + high) / 2;
+ p = &optable[test];
+ if ((cmp = strcmp(p->op_name, s)) < 0)
+ low = test + 1;
+ else if (cmp > 0)
+ high = test;
+ else {
+ *id = p->op_name;
+ return (p->op_code);
+ }
+ } while (low < high);
+ *id = s;
+ return 0;
+ }
+
+/*
+ * getid - get an identifier from infile, put it in the identifier
+ * table, and return a index to it.
+ */
+word getid()
+ {
+ word indx;
+
+ indx = getstr();
+ if (indx == -1)
+ return EOF;
+ return putident((int)strlen(&lsspace[indx])+1, 1);
+ }
+
+/*
+ * getstr - get an identifier from infile and return an index to it.
+ */
+word getstr()
+ {
+ register int c;
+ register word indx;
+
+ indx = lsfree;
+ while ((c = getc(infile)) == ' ' || c == '\t') ;
+ if (c == EOF)
+ return -1;
+ while (c != ' ' && c != '\t' && c != '\n' && c != ',' && c != EOF) {
+ if (indx >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1,
+ "string space");
+ lsspace[indx++] = c;
+ c = getc(infile);
+ }
+ if (indx >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1,
+ "string space");
+ lsspace[indx] = '\0';
+ nlflag = (c == '\n');
+ return lsfree;
+ }
+
+/*
+ * getrest - get the rest of the line from infile, put it in the identifier
+ * table, and return its index in the string space.
+ */
+word getrest()
+ {
+ register int c;
+ register word indx;
+
+ indx = lsfree;
+ while ((c = getc(infile)) != '\n' && c != EOF) {
+ if (indx >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1,
+ "string space");
+ lsspace[indx++] = c;
+ }
+ if (indx >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1,
+ "string space");
+ lsspace[indx++] = '\0';
+ nlflag = (c == '\n');
+ return putident((int)(indx - lsfree), 1);
+ }
+
+/*
+ * getdec - get a decimal integer from infile, and return it.
+ */
+int getdec()
+ {
+ register int c, n;
+ int sign = 1, rv;
+
+ n = 0;
+ while ((c = getc(infile)) == ' ' || c == '\t') ;
+ if (c == EOF)
+ return 0;
+ if (c == '-') {
+ sign = -1;
+ c = getc(infile);
+ }
+ while (c >= '0' && c <= '9') {
+ n = n * 10 + (c - '0');
+ c = getc(infile);
+ }
+ nlflag = (c == '\n');
+ rv = n * sign;
+ return rv; /* some compilers ... */
+ }
+
+/*
+ * getoct - get an octal number from infile, and return it.
+ */
+int getoct()
+ {
+ register int c, n;
+
+ n = 0;
+ while ((c = getc(infile)) == ' ' || c == '\t') ;
+ if (c == EOF)
+ return 0;
+ while (c >= '0' && c <= '7') {
+ n = (n << 3) | (c - '0');
+ c = getc(infile);
+ }
+ nlflag = (c == '\n');
+ return n;
+ }
+
+/*
+ * Get integer, but if it's too large for a long, put the string via wp
+ * and return -1.
+ */
+long getint(j,wp)
+ int j;
+ word *wp;
+ {
+ register int c;
+ int over = 0;
+ register word indx;
+ double result = 0;
+ long lresult = 0;
+ double radix;
+
+ ++j; /* incase we need to add a '\0' and make it into a string */
+ if (lsfree + j >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, j, "string space");
+ indx = lsfree;
+
+ while ((c = getc(infile)) >= '0' && c <= '9') {
+ lsspace[indx++] = c;
+ result = result * 10 + (c - '0');
+ lresult = lresult * 10 + (c - '0');
+ if (result <= MinLong || result >= MaxLong) {
+ over = 1; /* flag overflow */
+ result = 0; /* reset to avoid fp exception */
+ }
+ }
+ if (c == 'r' || c == 'R') {
+ lsspace[indx++] = c;
+ radix = result;
+ lresult = 0;
+ result = 0;
+ while ((c = getc(infile)) != 0) {
+ lsspace[indx++] = c;
+ if (isdigit(c) || isalpha(c))
+ c = tonum(c);
+ else
+ break;
+ result = result * radix + c;
+ lresult = lresult * radix + c;
+ if (result <= MinLong || result >= MaxLong) {
+ over = 1; /* flag overflow */
+ result = 0; /* reset to avoid fp exception */
+ }
+ }
+ }
+ nlflag = (c == '\n');
+ if (!over)
+ return lresult; /* integer is small enough */
+ else { /* integer is too large */
+ lsspace[indx++] = '\0';
+ *wp = putident((int)(indx - lsfree), 1); /* convert integer to string */
+ return -1; /* indicate integer is too big */
+ }
+ }
+
+/*
+ * getreal - get an Icon real number from infile, and return it.
+ */
+double getreal()
+ {
+ double n;
+ register int c, d, e;
+ int esign;
+ register char *s, *ep;
+ char cbuf[128];
+
+ s = cbuf;
+ d = 0;
+ while ((c = getc(infile)) == '0')
+ ;
+ while (c >= '0' && c <= '9') {
+ *s++ = c;
+ d++;
+ c = getc(infile);
+ }
+ if (c == '.') {
+ if (s == cbuf)
+ *s++ = '0';
+ *s++ = c;
+ while ((c = getc(infile)) >= '0' && c <= '9')
+ *s++ = c;
+ }
+ ep = s;
+ if (c == 'e' || c == 'E') {
+ *s++ = c;
+ if ((c = getc(infile)) == '+' || c == '-') {
+ esign = (c == '-');
+ *s++ = c;
+ c = getc(infile);
+ }
+ else
+ esign = 0;
+ e = 0;
+ while (c >= '0' && c <= '9') {
+ e = e * 10 + c - '0';
+ *s++ = c;
+ c = getc(infile);
+ }
+ if (esign) e = -e;
+ e += d - 1;
+ if (abs(e) >= LogHuge)
+ *ep = '\0';
+ }
+ *s = '\0';
+ n = atof(cbuf);
+ nlflag = (c == '\n');
+ return n;
+ }
+
+/*
+ * getlab - get a label ("L" followed by a number) from infile,
+ * and return the number.
+ */
+
+int getlab()
+ {
+ register int c;
+
+ while ((c = getc(infile)) != 'L' && c != EOF && c != '\n') ;
+ if (c == 'L')
+ return getdec();
+ nlflag = (c == '\n');
+ return 0;
+ }
+
+/*
+ * getstrlit - get a string literal from infile, as a string
+ * of octal bytes, and return its index into the string table.
+ */
+word getstrlit(l)
+register int l;
+ {
+ register word indx;
+
+ if (lsfree + l >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, l, "string space");
+ indx = lsfree;
+ while (!nlflag && l--)
+ lsspace[indx++] = getoct();
+ if (indx >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1,
+ "string space");
+ lsspace[indx++] = '\0';
+ return putident((int)(indx-lsfree), 1);
+ }
+
+/*
+ * newline - skip to next line.
+ */
+void newline()
+ {
+ register int c;
+
+ if (!nlflag) {
+ while ((c = getc(infile)) != '\n' && c != EOF) ;
+ }
+ nlflag = 0;
+ }
diff --git a/src/icont/lmem.c b/src/icont/lmem.c
new file mode 100644
index 0000000..8e091a5
--- /dev/null
+++ b/src/icont/lmem.c
@@ -0,0 +1,224 @@
+/*
+ * lmem.c -- memory initialization and allocation; also parses arguments.
+ */
+
+#include "link.h"
+#include "tproto.h"
+#include "tglobals.h"
+
+/*
+ * Prototypes.
+ */
+
+static struct lfile *alclfile (char *name);
+
+void dumplfiles(void);
+
+/*
+ * Memory initialization
+ */
+
+struct gentry **lghash; /* hash area for global table */
+struct ientry **lihash; /* hash area for identifier table */
+struct fentry **lfhash; /* hash area for field table */
+
+struct lentry *lltable; /* local table */
+struct centry *lctable; /* constant table */
+struct ipc_fname *fnmtbl; /* table associating ipc with file name */
+struct ipc_line *lntable; /* table associating ipc with line number */
+
+char *lsspace; /* string space */
+word *labels; /* label table */
+char *codeb; /* generated code space */
+
+struct ipc_fname *fnmfree; /* free pointer for ipc/file name table */
+struct ipc_line *lnfree; /* free pointer for ipc/line number table */
+word lsfree; /* free index for string space */
+char *codep; /* free pointer for code space */
+
+struct fentry *lffirst; /* first field table entry */
+struct fentry *lflast; /* last field table entry */
+struct gentry *lgfirst; /* first global table entry */
+struct gentry *lglast; /* last global table entry */
+
+/*
+ * linit - scan the command line arguments and initialize data structures.
+ */
+void linit()
+ {
+ struct gentry **gp;
+ struct ientry **ip;
+ struct fentry **fp;
+
+ llfiles = NULL; /* Zero queue of files to link. */
+
+ /*
+ * Allocate the various data structures that are used by the linker.
+ */
+ lghash = (struct gentry **) tcalloc(ghsize, sizeof(struct gentry *));
+ lihash = (struct ientry **) tcalloc(ihsize, sizeof(struct ientry *));
+ lfhash = (struct fentry **) tcalloc(fhsize, sizeof(struct fentry *));
+
+ lltable = (struct lentry *) tcalloc(lsize, sizeof(struct lentry));
+ lctable = (struct centry *) tcalloc(csize, sizeof(struct centry));
+
+ lnfree = lntable = (struct ipc_line*)tcalloc(nsize,sizeof(struct ipc_line));
+
+ lsspace = (char *) tcalloc(stsize, sizeof(char));
+ lsfree = 0;
+
+ fnmtbl = (struct ipc_fname *) tcalloc(fnmsize, sizeof(struct ipc_fname));
+ fnmfree = fnmtbl;
+
+ labels = (word *) tcalloc(maxlabels, sizeof(word));
+ codep = codeb = (char *) tcalloc(maxcode, 1);
+
+ lffirst = NULL;
+ lflast = NULL;
+ lgfirst = NULL;
+ lglast = NULL;
+
+ /*
+ * Zero out the hash tables.
+ */
+ for (gp = lghash; gp < &lghash[ghsize]; gp++)
+ *gp = NULL;
+ for (ip = lihash; ip < &lihash[ihsize]; ip++)
+ *ip = NULL;
+ for (fp = lfhash; fp < &lfhash[fhsize]; fp++)
+ *fp = NULL;
+
+ /*
+ * Install "main" as a global variable in order to insure that it
+ * is the first global variable. iconx/start.s depends on main
+ * being global number 0.
+ */
+ putglobal(instid("main"), F_Global, 0, 0);
+ }
+
+#ifdef DeBugLinker
+ /*
+ * dumplfiles - print the list of files to link. Used for debugging only.
+ */
+ void dumplfiles()
+ {
+ struct lfile *p,*lfls;
+
+ fprintf(stderr,"lfiles:\n");
+ lfls = llfiles;
+ while (p = getlfile(&lfls))
+ fprintf(stderr,"'%s'\n",p->lf_name);
+ fflush(stderr);
+ }
+#endif /* DeBugLinker */
+
+/*
+ * alsolink - create an lfile structure for the named file and add it to the
+ * end of the list of files (llfiles) to generate link instructions for.
+ */
+void alsolink(name)
+char *name;
+ {
+ struct lfile *nlf, *p;
+ char file[MaxPath];
+
+ if (!pathfind(file, ipath, name, U1Suffix))
+ quitf("cannot resolve reference to file '%s'",name);
+
+ nlf = alclfile(file);
+ if (llfiles == NULL) {
+ llfiles = nlf;
+ }
+ else {
+ p = llfiles;
+ while (p->lf_link != NULL) {
+ if (strcmp(p->lf_name,file) == 0)
+ return;
+ p = p->lf_link;
+ }
+ if (strcmp(p->lf_name,file) == 0)
+ return;
+ p->lf_link = nlf;
+ }
+ }
+
+/*
+ * getlfile - return a pointer (p) to the lfile structure pointed at by lptr
+ * and move lptr to the lfile structure that p points at. That is, getlfile
+ * returns a pointer to the current (wrt. lptr) lfile and advances lptr.
+ */
+struct lfile *getlfile(lptr)
+struct lfile **lptr;
+ {
+ struct lfile *p;
+
+ if (*lptr == NULL)
+ return (struct lfile *)NULL;
+ else {
+ p = *lptr;
+ *lptr = p->lf_link;
+ return p;
+ }
+ }
+
+/*
+ * alclfile - allocate an lfile structure for the named file, fill
+ * in the name and return a pointer to it.
+ */
+static struct lfile *alclfile(name)
+char *name;
+ {
+ struct lfile *p;
+
+ p = (struct lfile *) alloc(sizeof(struct lfile));
+ p->lf_link = NULL;
+ p->lf_name = salloc(name);
+ return p;
+ }
+
+/*
+ * lmfree - free memory used by the linker
+ */
+void lmfree()
+ {
+ struct fentry *fp, *fp1;
+ struct gentry *gp, *gp1;
+ struct rentry *rp, *rp1;
+ struct ientry *ip, *ip1;
+ int i;
+
+ for (i = 0; i < ihsize; ++i)
+ for (ip = lihash[i]; ip != NULL; ip = ip1) {
+ ip1 = ip->i_blink;
+ free((char *)ip);
+ }
+
+ free((char *) lghash); lghash = NULL;
+ free((char *) lihash); lihash = NULL;
+ free((char *) lfhash); lfhash = NULL;
+ free((char *) lltable); lltable = NULL;
+ free((char *) lctable); lctable = NULL;
+ free((char *) lntable); lntable = NULL;
+ free((char *) lsspace); lsspace = NULL;
+ free((char *) fnmtbl); fnmtbl = NULL;
+ free((char *) labels); labels = NULL;
+ free((char *) codep); codep = NULL;
+
+ for (fp = lffirst; fp != NULL; fp = fp1) {
+ for(rp = fp->f_rlist; rp != NULL; rp = rp1) {
+ rp1 = rp->r_link;
+ free((char *)rp);
+ }
+ fp1 = fp->f_nextentry;
+ free((char *)fp);
+ }
+ lffirst = NULL;
+ lflast = NULL;
+
+ for (gp = lgfirst; gp != NULL; gp = gp1) {
+ gp1 = gp->g_next;
+ free((char *)gp);
+ }
+ lgfirst = NULL;
+ lglast = NULL;
+ }
diff --git a/src/icont/lnklist.c b/src/icont/lnklist.c
new file mode 100644
index 0000000..f322355
--- /dev/null
+++ b/src/icont/lnklist.c
@@ -0,0 +1,83 @@
+/*
+ * lnklist.c -- functions for handling file linking.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "lfile.h"
+
+/*
+ * Prototype.
+ */
+static struct lfile *alclfile (char *name);
+
+struct lfile *lfiles;
+struct invkl *invkls;
+
+/*
+ * addinvk adds an "invokable" name to the list.
+ * n==1 if name is an identifier; otherwise it is a string literal.
+ */
+void addinvk(name, n)
+char *name;
+int n;
+ {
+ struct invkl *p;
+
+ if (n == 1) { /* if identifier, must be "all" */
+ if (strcmp(name, "all") != 0) {
+ tfatal("invalid operand to invocable", name);
+ return;
+ }
+ else
+ name = "0"; /* "0" represents "all" */
+ }
+ else if (!isalpha(name[0]) && (name[0] != '_'))
+ return; /* if operator, ignore */
+
+ p = alloc(sizeof(struct invkl));
+ if (!p)
+ tsyserr("not enough memory for invocable list");
+ p->iv_name = salloc(name);
+ p->iv_link = invkls;
+ invkls = p;
+ }
+
+/*
+ * alclfile allocates an lfile structure for the named file, fills
+ * in the name and returns a pointer to it.
+ */
+static struct lfile *alclfile(name)
+char *name;
+ {
+ struct lfile *p;
+
+ p = alloc(sizeof(struct lfile));
+ if (!p)
+ tsyserr("not enough memory for file list");
+ p->lf_link = NULL;
+ p->lf_name = salloc(name);
+ return p;
+ }
+
+/*
+ * addlfile creates an lfile structure for the named file and add it to the
+ * end of the list of files (lfiles) to generate link instructions for.
+ */
+void addlfile(name)
+char *name;
+ {
+ struct lfile *nlf, *p;
+
+ nlf = alclfile(name);
+ if (lfiles == NULL) {
+ lfiles = nlf;
+ }
+ else {
+ p = lfiles;
+ while (p->lf_link != NULL) {
+ p = p->lf_link;
+ }
+ p->lf_link = nlf;
+ }
+ }
diff --git a/src/icont/lsym.c b/src/icont/lsym.c
new file mode 100644
index 0000000..83b6768
--- /dev/null
+++ b/src/icont/lsym.c
@@ -0,0 +1,446 @@
+/*
+ * lsym.c -- functions for symbol table manipulation.
+ */
+
+#include "link.h"
+#include "tproto.h"
+#include "tglobals.h"
+
+/*
+ * Prototypes.
+ */
+
+static struct fentry *alcfhead
+ (struct fentry *blink, word name, int fid, struct rentry *rlist);
+static struct rentry *alcfrec
+ (struct rentry *link, struct gentry *gp, int fnum);
+static struct gentry *alcglobal
+ (struct gentry *blink, word name, int flag, int nargs, int procid);
+static struct ientry *alcident (char *nam, int len);
+
+int dynoff; /* stack offset counter for locals */
+int argoff; /* stack offset counter for arguments */
+int static1; /* first static in procedure */
+int lstatics = 0; /* static variable counter */
+
+int nlocal; /* number of locals in local table */
+int nconst; /* number of constants in constant table */
+int nfields = 0; /* number of fields in field table */
+
+/*
+ * instid - copy the string s to the start of the string free space
+ * and call putident with the length of the string.
+ */
+word instid(s)
+char *s;
+ {
+ register int l;
+ register word indx;
+ register char *p;
+
+ indx = lsfree;
+ p = s;
+ l = 0;
+ do {
+ if (indx >= stsize)
+ lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1,
+ "string space");
+ l++;
+ } while ((lsspace[indx++] = *p++) != 0);
+
+ return putident(l, 1);
+ }
+
+/*
+ * putident - install the identifier named by the string starting at lsfree
+ * and extending for len bytes. The installation entails making an
+ * entry in the identifier hash table and then making an identifier
+ * table entry for it with alcident. A side effect of installation
+ * is the incrementing of lsfree by the length of the string, thus
+ * "saving" it.
+ *
+ * Nothing is changed if the identifier has already been installed.
+ *
+ * If "install" is 0, putident returns -1 for a nonexistent identifier,
+ * and does not install it.
+ */
+word putident(len, install)
+int len, install;
+ {
+ register int hash;
+ register char *s;
+ register struct ientry *ip;
+ int l;
+
+ /*
+ * Compute hash value by adding bytes and masking result with imask.
+ * (Recall that imask is ihsize-1.)
+ */
+ s = &lsspace[lsfree];
+ hash = 0;
+ l = len;
+ while (l--)
+ hash += *s++;
+ l = len;
+ s = &lsspace[lsfree];
+ hash &= imask;
+ /*
+ * If the identifier hasn't been installed, install it.
+ */
+ if ((ip = lihash[hash]) != NULL) { /* collision */
+ for (;;) {
+ /*
+ * follow i_blink chain until id is found or end of chain reached
+ */
+ if (l == ip->i_length && lexeql(l, s, &lsspace[ip->i_name]))
+ return ip->i_name; /* id is already installed, return it */
+ if (ip->i_blink == NULL) { /* end of chain */
+ if (install == 0)
+ return -1;
+ ip->i_blink = alcident(s, l);
+ lsfree += l;
+ return ip->i_blink->i_name;
+ }
+ ip = ip->i_blink;
+ }
+ }
+ /*
+ * Hashed to an empty slot.
+ */
+ if (install == 0)
+ return -1;
+ lihash[hash] = alcident(s, l);
+ lsfree += l;
+ return lihash[hash]->i_name;
+ }
+
+/*
+ * lexeql - compare two strings of given length. Returns non-zero if
+ * equal, zero if not equal.
+ */
+int lexeql(l, s1, s2)
+register int l;
+register char *s1, *s2;
+ {
+ while (l--)
+ if (*s1++ != *s2++)
+ return 0;
+ return 1;
+ }
+
+/*
+ * alcident - get the next free identifier table entry, and fill it in with
+ * the specified values.
+ */
+static struct ientry *alcident(nam, len)
+char *nam;
+int len;
+ {
+ register struct ientry *ip;
+
+ ip = NewStruct(ientry);
+ ip->i_blink = NULL;
+ ip->i_name = (word)(nam - lsspace);
+ ip->i_length = len;
+ return ip;
+ }
+
+/*
+ * locinit - clear local symbol table.
+ */
+void locinit()
+ {
+ dynoff = 0;
+ argoff = 0;
+ nlocal = -1;
+ nconst = -1;
+ static1 = lstatics;
+ }
+
+/*
+ * putlocal - make a local symbol table entry.
+ */
+void putlocal(n, id, flags, imperror, procname)
+int n;
+word id;
+register int flags;
+int imperror;
+word procname;
+ {
+ register struct lentry *lp;
+ union {
+ struct gentry *gp;
+ int bn;
+ } p;
+
+ if (n >= lsize)
+ lltable = (struct lentry *)trealloc(lltable, NULL, &lsize,
+ sizeof(struct lentry), 1, "local symbol table");
+ if (n > nlocal)
+ nlocal = n;
+ lp = &lltable[n];
+ lp->l_name = id;
+ lp->l_flag = flags;
+ if (flags == 0) { /* undeclared */
+ if ((p.gp = glocate(id)) != NULL) { /* check global */
+ lp->l_flag = F_Global;
+ lp->l_val.global = p.gp;
+ }
+
+ else if ((p.bn = blocate(id)) != 0) { /* check for function */
+ lp->l_flag = F_Builtin | F_Global;
+ lp->l_val.global = putglobal(id, F_Builtin | F_Proc, -1, p.bn);
+ }
+
+ else { /* implicit local */
+ if (imperror)
+ lwarn(&lsspace[id], "undeclared identifier, procedure ",
+ &lsspace[procname]);
+ lp->l_flag = F_Dynamic;
+ lp->l_val.offset = ++dynoff;
+ }
+ }
+ else if (flags & F_Global) { /* global variable */
+ if ((p.gp = glocate(id)) == NULL)
+ quit("putlocal: global not in global table");
+ lp->l_val.global = p.gp;
+ }
+ else if (flags & F_Argument) /* procedure argument */
+ lp->l_val.offset = ++argoff;
+ else if (flags & F_Dynamic) /* local dynamic */
+ lp->l_val.offset = ++dynoff;
+ else if (flags & F_Static) /* local static */
+ lp->l_val.staticid = ++lstatics;
+ else
+ quit("putlocal: unknown flags");
+ }
+
+/*
+ * putglobal - make a global symbol table entry.
+ */
+struct gentry *putglobal(id, flags, nargs, procid)
+word id;
+int flags;
+int nargs;
+int procid;
+ {
+ register struct gentry *p;
+
+ flags |= F_Global;
+ if ((p = glocate(id)) == NULL) { /* add to head of hash chain */
+ p = lghash[ghasher(id)];
+ lghash[ghasher(id)] = alcglobal(p, id, flags, nargs, procid);
+ return lghash[ghasher(id)];
+ }
+ p->g_flag |= flags;
+ p->g_nargs = nargs;
+ p->g_procid = procid;
+ return p;
+ }
+
+/*
+ * putconst - make a constant symbol table entry.
+ */
+void putconst(n, flags, len, pc, valp)
+int n;
+int flags, len;
+word pc;
+union xval *valp;
+
+ {
+ register struct centry *p;
+ if (n >= csize)
+ lctable = (struct centry *)trealloc(lctable, NULL, &csize,
+ sizeof(struct centry), 1, "constant table");
+ if (nconst < n)
+ nconst = n;
+ p = &lctable[n];
+ p->c_flag = flags;
+ p->c_pc = pc;
+ if (flags & F_IntLit) {
+ p->c_val.ival = valp->ival;
+ }
+ else if (flags & F_StrLit) {
+ p->c_val.sval = valp->sval;
+ p->c_length = len;
+ }
+ else if (flags & F_CsetLit) {
+ p->c_val.sval = valp->sval;
+ p->c_length = len;
+ }
+ else if (flags & F_RealLit) {
+ #ifdef Double
+ /*
+ * Access real values one word at a time.
+ */
+ int *rp, *rq;
+ rp = (int *) &(p->c_val.rval);
+ rq = (int *) &(valp->rval);
+ *rp++ = *rq++;
+ *rp = *rq;
+ #else /* Double */
+ p->c_val.rval = valp->rval;
+ #endif /* Double */
+ }
+ else
+ fprintf(stderr, "putconst: bad flags: %06o %011lo\n", flags, valp->ival);
+ }
+
+/*
+ * putfield - make a record/field table entry.
+ */
+void putfield(fname, gp, fnum)
+word fname;
+struct gentry *gp;
+int fnum;
+ {
+ register struct fentry *fp;
+ register struct rentry *rp, *rp2;
+ word hash;
+
+ fp = flocate(fname);
+ if (fp == NULL) { /* create a field entry */
+ nfields++;
+ hash = fhasher(fname);
+ fp = lfhash[hash];
+ lfhash[hash] = alcfhead(fp, fname, nfields, alcfrec((struct rentry *)NULL,
+ gp, fnum));
+ return;
+ }
+ rp = fp->f_rlist; /* found field entry; */
+ if (rp->r_gp->g_procid > gp->g_procid) { /* find spot in record list */
+ fp->f_rlist = alcfrec(rp, gp, fnum);
+ return;
+ }
+ while (rp->r_gp->g_procid < gp->g_procid) { /* keep record list ascending */
+ if (rp->r_link == NULL) {
+ rp->r_link = alcfrec((struct rentry *)NULL, gp, fnum);
+ return;
+ }
+ rp2 = rp;
+ rp = rp->r_link;
+ }
+ rp2->r_link = alcfrec(rp, gp, fnum);
+ }
+
+/*
+ * glocate - lookup identifier in global symbol table, return NULL
+ * if not present.
+ */
+struct gentry *glocate(id)
+word id;
+ {
+ register struct gentry *p;
+
+ p = lghash[ghasher(id)];
+ while (p != NULL && p->g_name != id)
+ p = p->g_blink;
+ return p;
+ }
+
+/*
+ * flocate - lookup identifier in field table.
+ */
+struct fentry *flocate(id)
+word id;
+ {
+ register struct fentry *p;
+
+ p = lfhash[fhasher(id)];
+ while (p != NULL && p->f_name != id)
+ p = p->f_blink;
+ return p;
+ }
+
+/*
+ * alcglobal - create a new global symbol table entry.
+ */
+static struct gentry *alcglobal(blink, name, flag, nargs, procid)
+struct gentry *blink;
+word name;
+int flag;
+int nargs;
+int procid;
+ {
+ register struct gentry *gp;
+
+ gp = NewStruct(gentry);
+ gp->g_blink = blink;
+ gp->g_name = name;
+ gp->g_flag = flag;
+ gp->g_nargs = nargs;
+ gp->g_procid = procid;
+ gp->g_next = NULL;
+ if (lgfirst == NULL) {
+ lgfirst = gp;
+ gp->g_index = 0;
+ }
+ else {
+ lglast->g_next = gp;
+ gp->g_index = lglast->g_index + 1;
+ }
+ lglast = gp;
+ return gp;
+ }
+
+/*
+ * alcfhead - allocate a field table header.
+ */
+static struct fentry *alcfhead(blink, name, fid, rlist)
+struct fentry *blink;
+word name;
+int fid;
+struct rentry *rlist;
+ {
+ register struct fentry *fp;
+
+ fp = NewStruct(fentry);
+ fp->f_blink = blink;
+ fp->f_name = name;
+ fp->f_fid = fid;
+ fp->f_rlist = rlist;
+ fp->f_nextentry = NULL;
+ if (lffirst == NULL)
+ lffirst = fp;
+ else
+ lflast->f_nextentry = fp;
+ lflast = fp;
+ return fp;
+ }
+
+/*
+ * alcfrec - allocate a field table record list element.
+ */
+static struct rentry *alcfrec(link, gp, fnum)
+struct rentry *link;
+struct gentry *gp;
+int fnum;
+ {
+ register struct rentry *rp;
+
+ rp = NewStruct(rentry);
+ rp->r_link = link;
+ rp->r_gp = gp;
+ rp->r_fnum = fnum;
+ return rp;
+ }
+
+/*
+ * blocate - search for a function. The search is linear to make
+ * it easier to add/delete functions. If found, returns index+1 for entry.
+ */
+
+int blocate(s_indx)
+word s_indx;
+ {
+register char *s;
+ register int i;
+ extern char *ftable[];
+ extern int ftbsize;
+
+ s = &lsspace[s_indx];
+ for (i = 0; i < ftbsize; i++)
+ if (strcmp(ftable[i], s) == 0)
+ return i + 1;
+ return 0;
+ }
diff --git a/src/icont/mkkwd.icn b/src/icont/mkkwd.icn
new file mode 100644
index 0000000..14af432
--- /dev/null
+++ b/src/icont/mkkwd.icn
@@ -0,0 +1,52 @@
+# mkkwd.icn
+#
+# reads: standard input (typically ../runtime/keywords.r)
+#
+# writes: keyword.c
+# keyword.h
+# kdefs.h
+
+procedure main()
+ local kywds, klist, line, f, k, i
+
+ # load keywords
+ kywds := set()
+ while line := read() do {
+ line ? {
+ if ="keyword" then {
+ tab(find("}")+1)
+ tab(many(' \t'))
+ insert(kywds,tab(0))
+ }
+ }
+ }
+ klist := sort(kywds)
+
+ # write defined constants to keyword.h
+ hfile := wopen("keyword.h", "Keyword manifest constants")
+ lfile := wopen("../h/kdefs.h", "Keyword list")
+ i := 0
+ every k := !klist do {
+ kname := "K_" || map(k,&lcase,&ucase)
+ write(hfile, "#define ", left(kname,13), right(i+:=1,3))
+ write(lfile, "KDef(", k, ",", kname, ")")
+ }
+end
+
+
+# wopen(fname,comment) -- open file for writing
+#
+# opens and returns file; writes header comment; writes message to stdout
+
+procedure wopen(fname,comment)
+ local f
+ f := open(fname, "w") | stop ("can't open ", fname, " for writing")
+ write(f, "/*")
+ write(f, " * ", fname, " -- ", comment, ".")
+ write(f, " *")
+ write(f, " * Created mechanically by mkkwd.icn -- DO NOT EDIT.")
+ write(f, " */")
+ write(f)
+ write(" writing ", fname)
+ return f
+end
diff --git a/src/icont/newhdr.c b/src/icont/newhdr.c
new file mode 100644
index 0000000..7e23edb
--- /dev/null
+++ b/src/icont/newhdr.c
@@ -0,0 +1,90 @@
+/*
+ * Intermediate program to convert iconx.hdr into a header file for inclusion
+ * in icont. This eliminates a compile-time file search on Unix systems.
+ * Definition of BinaryHeader activates the inclusion.
+ */
+
+#include "../h/gsupport.h"
+
+void putbyte(FILE *fout, int b);
+
+int main(int argc, char *argv[])
+ {
+ static const char Usage[] = "Usage %s [Filename]\n";
+ int b, n;
+ char *ifile = NULL;
+ char *ofile = NULL;
+ FILE *fin, *fout;
+
+ n = 1;
+ if (((n + 1) < argc) && !strcmp(argv[n], "-o")) {
+ ofile = argv[++n];
+ ++n;
+ }
+ if (n < argc)
+ ifile = argv[n++];
+
+ if (ifile == NULL)
+ fin = stdin;
+ else if ((fin = fopen(ifile, "rb")) == NULL) {
+ fprintf(stderr, "Cannot open \"%s\" for input\n\n", ifile);
+ fprintf(stderr, Usage, argv[0]);
+ return EXIT_FAILURE;
+ }
+
+ if (ofile == NULL)
+ fout = stdout;
+ else if ((fout = fopen(ofile, "w")) == NULL) {
+ fprintf(stderr, "Cannot open \"%s\" for output\n\n", ofile);
+ fprintf(stderr, Usage, argv[0]);
+ return EXIT_FAILURE;
+ }
+
+ /*
+ * Create an array large enough to hold iconx.hdr (+1 for luck)
+ * This array shall be included by link.c (and is nominally called
+ * hdr.h)
+ */
+ fprintf(fout, "static unsigned char iconxhdr[MaxHdr+1] = {\n");
+
+ /*
+ * Recreate iconx.hdr as a series of hex constants, padded with zero bytes.
+ */
+ for (n = 0; (b = getc(fin)) != EOF; n++)
+ putbyte(fout, b);
+
+ /*
+ * If header is to be used, make sure it fits.
+ */
+ #ifdef BinaryHeader
+ if (n > MaxHdr) {
+ fprintf(stderr, "%s: file size is %d bytes but MaxHdr is only %d\n",
+ argv[0], n, MaxHdr);
+ if (ofile != NULL) {
+ fclose(fout);
+ unlink(ofile);
+ }
+ return EXIT_FAILURE;
+ }
+ #endif /* BinaryHeader */
+
+ while (n++ < MaxHdr)
+ putbyte(fout, 0);
+ fprintf(fout,"0x00};\n"); /* one more, sans comma, and finish */
+
+ return EXIT_SUCCESS;
+ }
+
+/*
+ * putbyte(b) - output byte b as two hex digits
+ */
+void putbyte(FILE *fout, int b)
+ {
+ static int n = 0;
+
+ fprintf(fout, "0x%02x,", b & 0xFF);
+ if (++n == 16) {
+ fprintf(fout, "\n");
+ n = 0;
+ }
+ }
diff --git a/src/icont/opcode.c b/src/icont/opcode.c
new file mode 100644
index 0000000..a7d557e
--- /dev/null
+++ b/src/icont/opcode.c
@@ -0,0 +1,117 @@
+#include "link.h"
+#include "tproto.h"
+#include "opcode.h"
+
+/*
+ * Opcode table.
+ */
+
+struct opentry optable[] = {
+ "asgn", Op_Asgn,
+ "bang", Op_Bang,
+
+ "bscan", Op_Bscan,
+
+ "cat", Op_Cat,
+ "ccase", Op_Ccase,
+ "chfail", Op_Chfail,
+ "coact", Op_Coact,
+ "cofail", Op_Cofail,
+ "colm", Op_Colm, /* always recognized, possibly ignored*/
+ "compl", Op_Compl,
+ "con", Op_Con,
+ "coret", Op_Coret,
+ "create", Op_Create,
+ "cset", Op_Cset,
+ "declend", Op_Declend,
+ "diff", Op_Diff,
+ "div", Op_Div,
+ "dup", Op_Dup,
+ "efail", Op_Efail,
+ "end", Op_End,
+ "eqv", Op_Eqv,
+ "eret", Op_Eret,
+ "error", Op_Error,
+ "escan", Op_Escan,
+ "esusp", Op_Esusp,
+ "field", Op_Field,
+ "filen", Op_Filen,
+
+ "global", Op_Global,
+ "goto", Op_Goto,
+ "impl", Op_Impl,
+ "init", Op_Init,
+ "int", Op_Int,
+ "inter", Op_Inter,
+ "invocable", Op_Invocable,
+ "invoke", Op_Invoke,
+ "keywd", Op_Keywd,
+ "lab", Op_Lab,
+ "lconcat", Op_Lconcat,
+ "lexeq", Op_Lexeq,
+ "lexge", Op_Lexge,
+ "lexgt", Op_Lexgt,
+ "lexle", Op_Lexle,
+ "lexlt", Op_Lexlt,
+ "lexne", Op_Lexne,
+ "limit", Op_Limit,
+ "line", Op_Line,
+ "link", Op_Link,
+ "llist", Op_Llist,
+ "local", Op_Local,
+ "lsusp", Op_Lsusp,
+ "mark", Op_Mark,
+ "mark0", Op_Mark0,
+ "minus", Op_Minus,
+ "mod", Op_Mod,
+ "mult", Op_Mult,
+ "neg", Op_Neg,
+ "neqv", Op_Neqv,
+ "nonnull", Op_Nonnull,
+
+#ifdef LineCodes
+ "noop", Op_Noop,
+#endif /* LineCodes */
+
+ "null", Op_Null,
+ "number", Op_Number,
+ "numeq", Op_Numeq,
+ "numge", Op_Numge,
+ "numgt", Op_Numgt,
+ "numle", Op_Numle,
+ "numlt", Op_Numlt,
+ "numne", Op_Numne,
+ "pfail", Op_Pfail,
+ "plus", Op_Plus,
+ "pnull", Op_Pnull,
+ "pop", Op_Pop,
+ "power", Op_Power,
+ "pret", Op_Pret,
+ "proc", Op_Proc,
+ "psusp", Op_Psusp,
+ "push1", Op_Push1,
+ "pushn1", Op_Pushn1,
+ "random", Op_Random,
+ "rasgn", Op_Rasgn,
+ "real", Op_Real,
+ "record", Op_Record,
+ "refresh", Op_Refresh,
+ "rswap", Op_Rswap,
+ "sdup", Op_Sdup,
+ "sect", Op_Sect,
+ "size", Op_Size,
+ "str", Op_Str,
+ "subsc", Op_Subsc,
+ "swap", Op_Swap,
+ "tabmat", Op_Tabmat,
+ "tally", Op_Tally,
+ "toby", Op_Toby,
+ "trace", Op_Trace,
+ "unions", Op_Unions,
+ "unmark", Op_Unmark,
+ "value", Op_Value,
+ "var", Op_Var,
+ "version", Op_Version,
+ };
+
+int NOPCODES = sizeof(optable) / sizeof(struct opentry);
diff --git a/src/icont/opcode.h b/src/icont/opcode.h
new file mode 100644
index 0000000..ca98cf1
--- /dev/null
+++ b/src/icont/opcode.h
@@ -0,0 +1,17 @@
+/*
+ * Opcode table structure.
+ */
+
+struct opentry {
+ char *op_name; /* name of opcode */
+ int op_code; /* opcode number */
+ };
+
+/*
+ * External definitions.
+ */
+
+extern struct opentry optable[];
+extern int NOPCODES;
+
+#include "../h/opdefs.h"
diff --git a/src/icont/tcode.c b/src/icont/tcode.c
new file mode 100644
index 0000000..9a9787c
--- /dev/null
+++ b/src/icont/tcode.c
@@ -0,0 +1,1097 @@
+/*
+ * tcode.c -- translator functions for traversing parse trees and generating
+ * code.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "tree.h"
+#include "ttoken.h"
+#include "tsym.h"
+
+/*
+ * Prototypes.
+ */
+
+static int alclab (int n);
+static void binop (int op);
+static void emit (char *s);
+static void emitl (char *s,int a);
+static void emitlab (int l);
+static void emitn (char *s,int a);
+static void emits (char *s,char *a);
+static void emitfile (nodeptr n);
+static void emitline (nodeptr n);
+static void setloc (nodeptr n);
+static int traverse (nodeptr t);
+static void unopa (int op, nodeptr t);
+static void unopb (int op);
+
+extern int tfatals;
+extern int nocode;
+
+/*
+ * Code generator parameters.
+ */
+
+#define LoopDepth 20 /* max. depth of nested loops */
+#define CaseDepth 10 /* max. depth of nested case statements */
+#define CreatDepth 10 /* max. depth of nested create statements */
+
+/*
+ * loopstk structures hold information about nested loops.
+ */
+struct loopstk {
+ int nextlab; /* label for next exit */
+ int breaklab; /* label for break exit */
+ int markcount; /* number of marks */
+ int ltype; /* loop type */
+ };
+
+/*
+ * casestk structure hold information about case statements.
+ */
+struct casestk {
+ int endlab; /* label for exit from case statement */
+ nodeptr deftree; /* pointer to tree for default clause */
+ };
+
+/*
+ * creatstk structures hold information about create statements.
+ */
+struct creatstk {
+ int nextlab; /* previous value of nextlab */
+ int breaklab; /* previous value of breaklab */
+ };
+static int nextlab; /* next label allocated by alclab() */
+
+/*
+ * codegen - traverse tree t, generating code.
+ */
+
+void codegen(t)
+nodeptr t;
+ {
+ nextlab = 1;
+ traverse(t);
+ }
+
+/*
+ * traverse - traverse tree rooted at t and generate code. This is just
+ * plug and chug code for each of the node types.
+ */
+
+static int traverse(t)
+register nodeptr t;
+ {
+ register int lab, n, i;
+ struct loopstk loopsave;
+ static struct loopstk loopstk[LoopDepth]; /* loop stack */
+ static struct loopstk *loopsp;
+ static struct casestk casestk[CaseDepth]; /* case stack */
+ static struct casestk *casesp;
+ static struct creatstk creatstk[CreatDepth]; /* create stack */
+ static struct creatstk *creatsp;
+
+ n = 1;
+ switch (TType(t)) {
+
+ case N_Activat: /* co-expression activation */
+ if (Val0(Tree0(t)) == AUGAT) {
+ emit("pnull");
+ }
+ traverse(Tree2(t)); /* evaluate result expression */
+ if (Val0(Tree0(t)) == AUGAT)
+ emit("sdup");
+ traverse(Tree1(t)); /* evaluate activate expression */
+ setloc(t);
+ emit("coact");
+ if (Val0(Tree0(t)) == AUGAT)
+ emit("asgn");
+ free(Tree0(t));
+ break;
+
+ case N_Alt: /* alternation */
+ lab = alclab(2);
+ emitl("mark", lab);
+ loopsp->markcount++;
+ traverse(Tree0(t)); /* evaluate first alternative */
+ loopsp->markcount--;
+ #ifdef EventMon
+ setloc(t);
+ #endif /* EventMon */
+ emit("esusp"); /* and suspend with its result */
+ emitl("goto", lab+1);
+ emitlab(lab);
+ traverse(Tree1(t)); /* evaluate second alternative */
+ emitlab(lab+1);
+ break;
+
+ case N_Augop: /* augmented assignment */
+ case N_Binop: /* or a binary operator */
+ emit("pnull");
+ traverse(Tree1(t));
+ if (TType(t) == N_Augop)
+ emit("dup");
+ traverse(Tree2(t));
+ setloc(t);
+ binop((int)Val0(Tree0(t)));
+ free(Tree0(t));
+ break;
+
+ case N_Bar: /* repeated alternation */
+ lab = alclab(1);
+ emitlab(lab);
+ emit("mark0"); /* fail if expr fails first time */
+ loopsp->markcount++;
+ traverse(Tree0(t)); /* evaluate first alternative */
+ loopsp->markcount--;
+ emitl("chfail", lab); /* change to loop on failure */
+ emit("esusp"); /* suspend result */
+ break;
+
+ case N_Break: /* break expression */
+ if (loopsp->breaklab <= 0)
+ nfatal(t, "invalid context for break", NULL);
+ else {
+ for (i = 0; i < loopsp->markcount; i++)
+ emit("unmark");
+ loopsave = *loopsp--;
+ traverse(Tree0(t));
+ *++loopsp = loopsave;
+ emitl("goto", loopsp->breaklab);
+ }
+ break;
+
+ case N_Case: /* case expression */
+ lab = alclab(1);
+ casesp++;
+ casesp->endlab = lab;
+ casesp->deftree = NULL;
+ emit("mark0");
+ loopsp->markcount++;
+ traverse(Tree0(t)); /* evaluate control expression */
+ loopsp->markcount--;
+ emit("eret");
+ traverse(Tree1(t)); /* do rest of case (CLIST) */
+ if (casesp->deftree != NULL) { /* evaluate default clause */
+ emit("pop");
+ traverse(casesp->deftree);
+ }
+ else
+ emit("efail");
+ emitlab(lab); /* end label */
+ casesp--;
+ break;
+
+ case N_Ccls: /* case expression clause */
+ if (TType(Tree0(t)) == N_Res && /* default clause */
+ Val0(Tree0(t)) == DEFAULT) {
+ if (casesp->deftree != NULL)
+ nfatal(t, "more than one default clause", NULL);
+ else
+ casesp->deftree = Tree1(t);
+ free(Tree0(t));
+ }
+ else { /* case clause */
+ lab = alclab(1);
+ emitl("mark", lab);
+ loopsp->markcount++;
+ emit("ccase");
+ traverse(Tree0(t)); /* evaluate selector */
+ setloc(t);
+ emit("eqv");
+ loopsp->markcount--;
+ emit("unmark");
+ emit("pop");
+ traverse(Tree1(t)); /* evaluate expression */
+ emitl("goto", casesp->endlab); /* goto end label */
+ emitlab(lab); /* label for next clause */
+ }
+ break;
+
+ case N_Clist: /* list of case clauses */
+ traverse(Tree0(t));
+ traverse(Tree1(t));
+ break;
+
+ case N_Conj: /* conjunction */
+ if (Val0(Tree0(t)) == AUGAND) {
+ emit("pnull");
+ }
+ traverse(Tree1(t));
+ if (Val0(Tree0(t)) != AUGAND)
+ emit("pop");
+ traverse(Tree2(t));
+ if (Val0(Tree0(t)) == AUGAND) {
+ setloc(t);
+ emit("asgn");
+ }
+ free(Tree0(t));
+ break;
+
+ case N_Create: /* create expression */
+ creatsp++;
+ creatsp->nextlab = loopsp->nextlab;
+ creatsp->breaklab = loopsp->breaklab;
+ loopsp->nextlab = 0; /* make break and next illegal */
+ loopsp->breaklab = 0;
+ lab = alclab(3);
+ emitl("goto", lab+2); /* skip over code for co-expression */
+ emitlab(lab); /* entry point */
+ emit("pop"); /* pop the result from activation */
+ emitl("mark", lab+1);
+ loopsp->markcount++;
+ traverse(Tree0(t)); /* traverse code for co-expression */
+ loopsp->markcount--;
+ setloc(t);
+ emit("coret"); /* return to activator */
+ emit("efail"); /* drive co-expression */
+ emitlab(lab+1); /* loop on exhaustion */
+ emit("cofail"); /* and fail each time */
+ emitl("goto", lab+1);
+ emitlab(lab+2);
+ emitl("create", lab); /* create entry block */
+ loopsp->nextlab = creatsp->nextlab; /* legalize break and next */
+ loopsp->breaklab = creatsp->breaklab;
+ creatsp--;
+ break;
+
+ case N_Cset: /* cset literal */
+ emitn("cset", (int)Val0(t));
+ break;
+
+ case N_Elist: /* expression list */
+ n = traverse(Tree0(t));
+ n += traverse(Tree1(t));
+ break;
+
+ case N_Empty: /* a missing expression */
+ emit("pnull");
+ break;
+
+ case N_Field: /* field reference */
+ emit("pnull");
+ traverse(Tree0(t));
+ setloc(t);
+ emits("field", Str0(Tree1(t)));
+ free(Tree1(t));
+ break;
+
+ case N_Id: /* identifier */
+ emitn("var", (int)Val0(t));
+ break;
+
+ case N_If: /* if expression */
+ if (TType(Tree2(t)) == N_Empty) {
+ lab = 0;
+ emit("mark0");
+ }
+ else {
+ lab = alclab(2);
+ emitl("mark", lab);
+ }
+ loopsp->markcount++;
+ traverse(Tree0(t));
+ loopsp->markcount--;
+ emit("unmark");
+ traverse(Tree1(t));
+ if (lab > 0) {
+ emitl("goto", lab+1);
+ emitlab(lab);
+ traverse(Tree2(t));
+ emitlab(lab+1);
+ }
+ else
+ free(Tree2(t));
+ break;
+
+ case N_Int: /* integer literal */
+ emitn("int", (int)Val0(t));
+ break;
+
+ case N_Apply: /* application */
+ traverse(Tree0(t));
+ traverse(Tree1(t));
+ emitn("invoke", -1);
+ break;
+
+ case N_Invok: /* invocation */
+ if (TType(Tree0(t)) != N_Empty) {
+ traverse(Tree0(t));
+ }
+ else {
+ emit("pushn1"); /* default to -1(e1,...,en) */
+ free(Tree0(t));
+ }
+ if (TType(Tree1(t)) == N_Empty) {
+ n = 0;
+ free(Tree1(t));
+ }
+ else
+ n = traverse(Tree1(t));
+ setloc(t);
+ emitn("invoke", n);
+ n = 1;
+ break;
+
+ case N_Key: /* keyword reference */
+ setloc(t);
+ emits("keywd", Str0(t));
+ break;
+
+ case N_Limit: /* limitation */
+ traverse(Tree1(t));
+ setloc(t);
+ emit("limit");
+ loopsp->markcount++;
+ traverse(Tree0(t));
+ loopsp->markcount--;
+ emit("lsusp");
+ break;
+
+ case N_List: /* list construction */
+ emit("pnull");
+ if (TType(Tree0(t)) == N_Empty) {
+ n = 0;
+ free(Tree0(t));
+ }
+ else
+ n = traverse(Tree0(t));
+ setloc(t);
+ emitn("llist", n);
+ n = 1;
+ break;
+
+ case N_Loop: /* loop */
+ switch ((int)Val0(Tree0(t))) {
+ case EVERY:
+ lab = alclab(2);
+ loopsp++;
+ loopsp->ltype = EVERY;
+ loopsp->nextlab = lab;
+ loopsp->breaklab = lab + 1;
+ loopsp->markcount = 1;
+ emit("mark0");
+ traverse(Tree1(t));
+ emit("pop");
+ if (TType(Tree2(t)) != N_Empty) { /* every e1 do e2 */
+ emit("mark0");
+ loopsp->ltype = N_Loop;
+ loopsp->markcount++;
+ traverse(Tree2(t));
+ loopsp->markcount--;
+ emit("unmark");
+ }
+ else
+ free(Tree2(t));
+ emitlab(loopsp->nextlab);
+ emit("efail");
+ emitlab(loopsp->breaklab);
+ loopsp--;
+ break;
+
+ case REPEAT:
+ lab = alclab(3);
+ loopsp++;
+ loopsp->ltype = N_Loop;
+ loopsp->nextlab = lab + 1;
+ loopsp->breaklab = lab + 2;
+ loopsp->markcount = 1;
+ emitlab(lab);
+ emitl("mark", lab);
+ traverse(Tree1(t));
+ emitlab(loopsp->nextlab);
+ emit("unmark");
+ emitl("goto", lab);
+ emitlab(loopsp->breaklab);
+ loopsp--;
+ free(Tree2(t));
+ break;
+
+ case SUSPEND: /* suspension expression */
+ if (creatsp > creatstk)
+ nfatal(t, "invalid context for suspend", NULL);
+ lab = alclab(2);
+ loopsp++;
+ loopsp->ltype = EVERY; /* like every ... do for next */
+ loopsp->nextlab = lab;
+ loopsp->breaklab = lab + 1;
+ loopsp->markcount = 1;
+ emit("mark0");
+ traverse(Tree1(t));
+ setloc(t);
+ emit("psusp");
+ emit("pop");
+ if (TType(Tree2(t)) != N_Empty) { /* suspend e1 do e2 */
+ emit("mark0");
+ loopsp->ltype = N_Loop;
+ loopsp->markcount++;
+ traverse(Tree2(t));
+ loopsp->markcount--;
+ emit("unmark");
+ }
+ else
+ free(Tree2(t));
+ emitlab(loopsp->nextlab);
+ emit("efail");
+ emitlab(loopsp->breaklab);
+ loopsp--;
+ break;
+
+ case WHILE:
+ lab = alclab(3);
+ loopsp++;
+ loopsp->ltype = N_Loop;
+ loopsp->nextlab = lab + 1;
+ loopsp->breaklab = lab + 2;
+ loopsp->markcount = 1;
+ emitlab(lab);
+ emit("mark0");
+ traverse(Tree1(t));
+ if (TType(Tree2(t)) != N_Empty) {
+ emit("unmark");
+ emitl("mark", lab);
+ traverse(Tree2(t));
+ }
+ else
+ free(Tree2(t));
+ emitlab(loopsp->nextlab);
+ emit("unmark");
+ emitl("goto", lab);
+ emitlab(loopsp->breaklab);
+ loopsp--;
+ break;
+
+ case UNTIL:
+ lab = alclab(4);
+ loopsp++;
+ loopsp->ltype = N_Loop;
+ loopsp->nextlab = lab + 2;
+ loopsp->breaklab = lab + 3;
+ loopsp->markcount = 1;
+ emitlab(lab);
+ emitl("mark", lab+1);
+ traverse(Tree1(t));
+ emit("unmark");
+ emit("efail");
+ emitlab(lab+1);
+ emitl("mark", lab);
+ traverse(Tree2(t));
+ emitlab(loopsp->nextlab);
+ emit("unmark");
+ emitl("goto", lab);
+ emitlab(loopsp->breaklab);
+ loopsp--;
+ break;
+ }
+ free(Tree0(t));
+ break;
+
+ case N_Next: /* next expression */
+ if (loopsp < loopstk || loopsp->nextlab <= 0)
+ nfatal(t, "invalid context for next", NULL);
+ else {
+ if (loopsp->ltype != EVERY && loopsp->markcount > 1)
+ for (i = 0; i < loopsp->markcount - 1; i++)
+ emit("unmark");
+ emitl("goto", loopsp->nextlab);
+ }
+ break;
+
+ case N_Not: /* not expression */
+ lab = alclab(1);
+ emitl("mark", lab);
+ loopsp->markcount++;
+ traverse(Tree0(t));
+ loopsp->markcount--;
+ emit("unmark");
+ emit("efail");
+ emitlab(lab);
+ emit("pnull");
+ break;
+
+ case N_Proc: /* procedure */
+ loopsp = loopstk;
+ loopsp->nextlab = 0;
+ loopsp->breaklab = 0;
+ loopsp->markcount = 0;
+ casesp = casestk;
+ creatsp = creatstk;
+
+ writecheck(fprintf(codefile, "proc %s\n", Str0(Tree0(t))));
+ emitfile(t);
+ lout(codefile);
+ constout(codefile);
+ emit("declend");
+ emitline(t);
+
+ if (TType(Tree1(t)) != N_Empty) {
+ lab = alclab(1);
+ emitl("init", lab);
+ emitl("mark", lab);
+ traverse(Tree1(t));
+ emit("unmark");
+ emitlab(lab);
+ }
+ else
+ free(Tree1(t));
+ if (TType(Tree2(t)) != N_Empty)
+ traverse(Tree2(t));
+ else
+ free(Tree2(t));
+ setloc(Tree3(t));
+ emit("pfail");
+ emit("end");
+ if (!silent)
+ fprintf(stderr, " %s\n", Str0(Tree0(t)));
+ free(Tree0(t));
+ free(Tree3(t));
+ break;
+
+ case N_Real: /* real literal */
+ emitn("real", (int)Val0(t));
+ break;
+
+ case N_Ret: /* return expression */
+ if (creatsp > creatstk)
+ nfatal(t, "invalid context for return or fail", NULL);
+ if (Val0(Tree0(t)) == FAIL)
+ free(Tree1(t));
+ else {
+ lab = alclab(1);
+ emitl("mark", lab);
+ loopsp->markcount++;
+ traverse(Tree1(t));
+ loopsp->markcount--;
+ setloc(t);
+ emit("pret");
+ emitlab(lab);
+ }
+ setloc(t);
+ emit("pfail");
+ free(Tree0(t));
+ break;
+
+ case N_Scan: /* scanning expression */
+ if (Val0(Tree0(t)) == AUGQMARK)
+ emit("pnull");
+ traverse(Tree1(t));
+ if (Val0(Tree0(t)) == AUGQMARK)
+ emit("sdup");
+ setloc(t);
+ emit("bscan");
+ traverse(Tree2(t));
+ setloc(t);
+ emit("escan");
+ if (Val0(Tree0(t)) == AUGQMARK)
+ emit("asgn");
+ free(Tree0(t));
+ break;
+
+ case N_Sect: /* section operation */
+ emit("pnull");
+ traverse(Tree1(t));
+ traverse(Tree2(t));
+ if (Val0(Tree0(t)) == PCOLON || Val0(Tree0(t)) == MCOLON)
+ emit("dup");
+ traverse(Tree3(t));
+ setloc(Tree0(t));
+ if (Val0(Tree0(t)) == PCOLON)
+ emit("plus");
+ else if (Val0(Tree0(t)) == MCOLON)
+ emit("minus");
+ setloc(t);
+ emit("sect");
+ free(Tree0(t));
+ break;
+
+ case N_Slist: /* semicolon-separated expr list */
+ lab = alclab(1);
+ emitl("mark", lab);
+ loopsp->markcount++;
+ traverse(Tree0(t));
+ loopsp->markcount--;
+ emit("unmark");
+ emitlab(lab);
+ traverse(Tree1(t));
+ break;
+
+ case N_Str: /* string literal */
+ emitn("str", (int)Val0(t));
+ break;
+
+ case N_To: /* to expression */
+ emit("pnull");
+ traverse(Tree0(t));
+ traverse(Tree1(t));
+ emit("push1");
+ setloc(t);
+ emit("toby");
+ break;
+
+ case N_ToBy: /* to-by expression */
+ emit("pnull");
+ traverse(Tree0(t));
+ traverse(Tree1(t));
+ traverse(Tree2(t));
+ setloc(t);
+ emit("toby");
+ break;
+
+ case N_Unop: /* unary operator */
+ unopa((int)Val0(Tree0(t)),t);
+ traverse(Tree1(t));
+ setloc(t);
+ unopb((int)Val0(Tree0(t)));
+ free(Tree0(t));
+ break;
+
+ default:
+ emitn("?????", TType(t));
+ tsyserr("traverse: undefined node type");
+ }
+ free(t);
+ return n;
+ }
+
+/*
+ * binop emits code for binary operators. For non-augmented operators,
+ * the name of operator is emitted. For augmented operators, an "asgn"
+ * is emitted after the name of the operator.
+ */
+static void binop(op)
+int op;
+ {
+ register int asgn;
+ register char *name;
+
+ asgn = 0;
+ switch (op) {
+
+ case ASSIGN:
+ name = "asgn";
+ break;
+
+ case AUGCARET:
+ asgn++;
+ case CARET:
+ name = "power";
+ break;
+
+ case AUGCONCAT:
+ asgn++;
+ case CONCAT:
+ name = "cat";
+ break;
+
+ case AUGDIFF:
+ asgn++;
+ case DIFF:
+ name = "diff";
+ break;
+
+ case AUGEQUIV:
+ asgn++;
+ case EQUIV:
+ name = "eqv";
+ break;
+
+ case AUGINTER:
+ asgn++;
+ case INTER:
+ name = "inter";
+ break;
+
+ case LBRACK:
+ name = "subsc";
+ break;
+
+ case AUGLCONCAT:
+ asgn++;
+ case LCONCAT:
+ name = "lconcat";
+ break;
+
+ case AUGSEQ:
+ asgn++;
+ case SEQ:
+ name = "lexeq";
+ break;
+
+ case AUGSGE:
+ asgn++;
+ case SGE:
+ name = "lexge";
+ break;
+
+ case AUGSGT:
+ asgn++;
+ case SGT:
+ name = "lexgt";
+ break;
+
+ case AUGSLE:
+ asgn++;
+ case SLE:
+ name = "lexle";
+ break;
+
+ case AUGSLT:
+ asgn++;
+ case SLT:
+ name = "lexlt";
+ break;
+
+ case AUGSNE:
+ asgn++;
+ case SNE:
+ name = "lexne";
+ break;
+
+ case AUGMINUS:
+ asgn++;
+ case MINUS:
+ name = "minus";
+ break;
+
+ case AUGMOD:
+ asgn++;
+ case MOD:
+ name = "mod";
+ break;
+
+ case AUGNEQUIV:
+ asgn++;
+ case NEQUIV:
+ name = "neqv";
+ break;
+
+ case AUGNMEQ:
+ asgn++;
+ case NMEQ:
+ name = "numeq";
+ break;
+
+ case AUGNMGE:
+ asgn++;
+ case NMGE:
+ name = "numge";
+ break;
+
+ case AUGNMGT:
+ asgn++;
+ case NMGT:
+ name = "numgt";
+ break;
+
+ case AUGNMLE:
+ asgn++;
+ case NMLE:
+ name = "numle";
+ break;
+
+ case AUGNMLT:
+ asgn++;
+ case NMLT:
+ name = "numlt";
+ break;
+
+ case AUGNMNE:
+ asgn++;
+ case NMNE:
+ name = "numne";
+ break;
+
+ case AUGPLUS:
+ asgn++;
+ case PLUS:
+ name = "plus";
+ break;
+
+ case REVASSIGN:
+ name = "rasgn";
+ break;
+
+ case REVSWAP:
+ name = "rswap";
+ break;
+
+ case AUGSLASH:
+ asgn++;
+ case SLASH:
+ name = "div";
+ break;
+
+ case AUGSTAR:
+ asgn++;
+ case STAR:
+ name = "mult";
+ break;
+
+ case SWAP:
+ name = "swap";
+ break;
+
+ case AUGUNION:
+ asgn++;
+ case UNION:
+ name = "unions";
+ break;
+
+ default:
+ emitn("?binop", op);
+ tsyserr("binop: undefined binary operator");
+ }
+ emit(name);
+ if (asgn)
+ emit("asgn");
+
+ }
+/*
+ * unopa and unopb handle code emission for unary operators. unary operator
+ * sequences that are the same as binary operator sequences are recognized
+ * by the lexical analyzer as binary operators. For example, ~===x means to
+ * do three tab(match(...)) operations and then a cset complement, but the
+ * lexical analyzer sees the operator sequence as the "neqv" binary
+ * operation. unopa and unopb unravel tokens of this form.
+ *
+ * When a N_Unop node is encountered, unopa is called to emit the necessary
+ * number of "pnull" operations to receive the intermediate results. This
+ * amounts to a pnull for each operation.
+ */
+static void unopa(op,t)
+int op;
+nodeptr t;
+ {
+ switch (op) {
+ case NEQUIV: /* unary ~ and three = operators */
+ emit("pnull");
+ case SNE: /* unary ~ and two = operators */
+ case EQUIV: /* three unary = operators */
+ emit("pnull");
+ case NMNE: /* unary ~ and = operators */
+ case UNION: /* two unary + operators */
+ case DIFF: /* two unary - operators */
+ case SEQ: /* two unary = operators */
+ case INTER: /* two unary * operators */
+ emit("pnull");
+ case BACKSLASH: /* unary \ operator */
+ case BANG: /* unary ! operator */
+ case CARET: /* unary ^ operator */
+ case PLUS: /* unary + operator */
+ case TILDE: /* unary ~ operator */
+ case MINUS: /* unary - operator */
+ case NMEQ: /* unary = operator */
+ case STAR: /* unary * operator */
+ case QMARK: /* unary ? operator */
+ case SLASH: /* unary / operator */
+ case DOT: /* unary . operator */
+ emit("pnull");
+ break;
+ default:
+ tsyserr("unopa: undefined unary operator");
+ }
+ }
+
+/*
+ * unopb is the back-end code emitter for unary operators. It emits
+ * the operations represented by the token op. For tokens representing
+ * a single operator, the name of the operator is emitted. For tokens
+ * representing a sequence of operators, recursive calls are used. In
+ * such a case, the operator sequence is "scanned" from right to left
+ * and unopb is called with the token for the appropriate operation.
+ *
+ * For example, consider the sequence of calls and code emission for "~===":
+ * unopb(NEQUIV) ~===
+ * unopb(NMEQ) =
+ * emits "tabmat"
+ * unopb(NMEQ) =
+ * emits "tabmat"
+ * unopb(NMEQ) =
+ * emits "tabmat"
+ * emits "compl"
+ */
+static void unopb(op)
+int op;
+ {
+ register char *name;
+
+ switch (op) {
+
+ case DOT: /* unary . operator */
+ name = "value";
+ break;
+
+ case BACKSLASH: /* unary \ operator */
+ name = "nonnull";
+ break;
+
+ case BANG: /* unary ! operator */
+ name = "bang";
+ break;
+
+ case CARET: /* unary ^ operator */
+ name = "refresh";
+ break;
+
+ case UNION: /* two unary + operators */
+ unopb(PLUS);
+ case PLUS: /* unary + operator */
+ name = "number";
+ break;
+
+ case NEQUIV: /* unary ~ and three = operators */
+ unopb(NMEQ);
+ case SNE: /* unary ~ and two = operators */
+ unopb(NMEQ);
+ case NMNE: /* unary ~ and = operators */
+ unopb(NMEQ);
+ case TILDE: /* unary ~ operator (cset compl) */
+ name = "compl";
+ break;
+
+ case DIFF: /* two unary - operators */
+ unopb(MINUS);
+ case MINUS: /* unary - operator */
+ name = "neg";
+ break;
+
+ case EQUIV: /* three unary = operators */
+ unopb(NMEQ);
+ case SEQ: /* two unary = operators */
+ unopb(NMEQ);
+ case NMEQ: /* unary = operator */
+ name = "tabmat";
+ break;
+
+ case INTER: /* two unary * operators */
+ unopb(STAR);
+ case STAR: /* unary * operator */
+ name = "size";
+ break;
+
+ case QMARK: /* unary ? operator */
+ name = "random";
+ break;
+
+ case SLASH: /* unary / operator */
+ name = "null";
+ break;
+
+ default:
+ emitn("?unop", op);
+ tsyserr("unopb: undefined unary operator");
+ }
+ emit(name);
+ }
+
+/*
+ * emitfile(n) emits "filen" directives for node n's source location.
+ * emitline(n) emits "line" and possibly "colm" directives.
+ * setloc(n) does both.
+ * A directive is only emitted if the corresponding value
+ * has changed since the previous call.
+ *
+ */
+static char *lastfiln = NULL;
+static int lastlin = 0;
+
+static void setloc(n)
+nodeptr n;
+ {
+ emitfile(n);
+ emitline(n);
+ }
+
+static void emitfile(n)
+nodeptr n;
+ {
+ if ((n != NULL) &&
+ (TType(n) != N_Empty) &&
+ (File(n) != NULL) &&
+ (lastfiln == NULL || strcmp(File(n), lastfiln) != 0)) {
+ lastfiln = File(n);
+ emits("filen", lastfiln);
+ }
+ }
+
+static void emitline(n)
+nodeptr n;
+ {
+ #ifdef SrcColumnInfo
+ /*
+ * if either line or column has changed, emit location information
+ */
+ if (((Col(n) << 16) + Line(n)) != lastlin) {
+ lastlin = (Col(n) << 16) + Line(n);
+ emitn("line",Line(n));
+ emitn("colm",Col(n));
+ }
+ #else /* SrcColumnInfo */
+ /*
+ * if line has changed, emit line information
+ */
+ if (Line(n) != lastlin) {
+ lastlin = Line(n);
+ emitn("line", lastlin);
+ }
+ #endif /* SrcColumnInfo */
+ }
+
+/*
+ * The emit* routines output ucode to codefile. The various routines are:
+ *
+ * emitlab(l) - emit "lab" instruction for label l.
+ * emit(s) - emit instruction s.
+ * emitl(s,a) - emit instruction s with reference to label a.
+ * emitn(s,n) - emit instruction s with numeric argument a.
+ * emits(s,a) - emit instruction s with string argument a.
+ */
+static void emitlab(l)
+int l;
+ {
+ writecheck(fprintf(codefile, "lab L%d\n", l));
+ }
+
+static void emit(s)
+char *s;
+ {
+ writecheck(fprintf(codefile, "\t%s\n", s));
+ }
+
+static void emitl(s, a)
+char *s;
+int a;
+ {
+ writecheck(fprintf(codefile, "\t%s\tL%d\n", s, a));
+ }
+
+static void emitn(s, a)
+char *s;
+int a;
+ {
+ writecheck(fprintf(codefile, "\t%s\t%d\n", s, a));
+ }
+
+static void emits(s, a)
+char *s, *a;
+ {
+ writecheck(fprintf(codefile, "\t%s\t%s\n", s, a));
+ }
+
+/*
+ * alclab allocates n labels and returns the first. For the interpreter,
+ * labels are restarted at 1 for each procedure, while in the compiler,
+ * they start at 1 and increase throughout the entire compilation.
+ */
+static int alclab(n)
+int n;
+ {
+ register int lab;
+
+ lab = nextlab;
+ nextlab += n;
+ return lab;
+ }
diff --git a/src/icont/tglobals.c b/src/icont/tglobals.c
new file mode 100644
index 0000000..0e963ea
--- /dev/null
+++ b/src/icont/tglobals.c
@@ -0,0 +1,24 @@
+/*
+ * tglobals.c - declaration and initialization of icont globals.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+
+#define Global
+#define Init(v) = v
+#include "tglobals.h" /* define globals */
+
+/*
+ * Initialize globals that cannot be handled statically.
+ */
+void initglob(void) {
+ /*
+ * Round hash table sizes to next power of two, and set masks for hashing.
+ */
+ lchsize = round2(lchsize); cmask = lchsize - 1;
+ fhsize = round2(fhsize); fmask = fhsize - 1;
+ ghsize = round2(ghsize); gmask = ghsize - 1;
+ ihsize = round2(ihsize); imask = ihsize - 1;
+ lhsize = round2(lhsize); lmask = lhsize - 1;
+ }
diff --git a/src/icont/tglobals.h b/src/icont/tglobals.h
new file mode 100644
index 0000000..5568293
--- /dev/null
+++ b/src/icont/tglobals.h
@@ -0,0 +1,67 @@
+/*
+ * Global variables.
+ */
+
+#ifndef Global
+ #define Global extern
+ #define Init(v)
+#endif /* Global */
+
+/*
+ * Masks for accessing hash tables.
+ */
+Global int cmask; /* mask for constant table hash */
+Global int fmask; /* mask for field table hash */
+Global int gmask; /* mask for global table hash */
+Global int imask; /* mask for identifier table hash */
+Global int lmask; /* mask for local table hash */
+
+/*
+ * Array sizes for various linker tables that can be expanded with realloc().
+ */
+Global unsigned int csize Init(100); /* constant table */
+Global unsigned int lsize Init(100); /* local table */
+Global unsigned int nsize Init(1000); /* ipc/line num. assoc. table */
+Global unsigned int stsize Init(20000); /* string space */
+Global unsigned int maxcode Init(15000); /* code space */
+Global unsigned int fnmsize Init(10); /* ipc/file name assoc. table */
+Global unsigned int maxlabels Init(500); /* maximum num of labels/proc */
+
+/*
+ * Sizes of various hash tables.
+ */
+Global unsigned int lchsize Init(128); /* constant hash table */
+Global unsigned int fhsize Init(32); /* field hash table */
+Global unsigned int ghsize Init(128); /* global hash table */
+Global unsigned int ihsize Init(128); /* identifier hash table */
+Global unsigned int lhsize Init(128); /* local hash table */
+
+/*
+ * Variables related to command processing.
+ */
+Global char *progname Init("icont"); /* program name for diagnostics */
+Global int silent Init(0); /* -s: suppress info messages? */
+Global int m4pre Init(0); /* -m: use m4 preprocessor? */
+Global int uwarn Init(0); /* -u: warn about undefined ids? */
+Global int trace Init(0); /* -t: initial &trace value */
+Global int pponly Init(0); /* -E: preprocess only */
+Global int strinv Init(0); /* -f s: allow full string invocation */
+Global int verbose Init(1); /* -v n: verbosity of commentary */
+
+#ifdef DeBugLinker
+ Global int Dflag Init(0); /* -L: linker debug (write .ux file) */
+#endif /* DeBugLinker */
+
+/*
+ * Files and related globals.
+ */
+Global char *lpath; /* search path for $include */
+Global char *ipath; /* search path for linking */
+
+Global FILE *codefile Init(0); /* current ucode output file */
+Global FILE *globfile Init(0); /* current global table output file */
+
+Global char *ofile Init(NULL); /* name of linker output file */
+
+Global char *iconxloc; /* path to iconx */
+Global long hdrsize; /* size of iconx header */
diff --git a/src/icont/tgrammar.c b/src/icont/tgrammar.c
new file mode 100644
index 0000000..7301c07
--- /dev/null
+++ b/src/icont/tgrammar.c
@@ -0,0 +1,239 @@
+/*
+ * tgrammar.c - includes and macros for building the parse tree
+ */
+
+#include "../h/define.h"
+#include "../common/yacctok.h"
+
+%{
+/*
+ * These commented directives are passed through the first application
+ * of cpp, then turned into real includes in tgram.g by fixgram.icn.
+ */
+/*#include "../h/gsupport.h"*/
+/*#include "../h/lexdef.h"*/
+/*#include "tproto.h"*/
+/*#include "tglobals.h"*/
+/*#include "tsym.h"*/
+/*#include "tree.h"*/
+/*#include "keyword.h"*/
+/*#undef YYSTYPE*/
+/*#define YYSTYPE nodeptr*/
+/*#define YYMAXDEPTH 500*/
+
+extern int fncargs[];
+int idflag;
+int id_cnt;
+
+#define EmptyNode tree1(N_Empty)
+
+#define Alt(x1,x2,x3) $$ = tree4(N_Alt,x2,x1,x3)
+#define Apply(x1,x2,x3) $$ = tree4(N_Apply,x2,x1,x3)
+#define Arglist1() id_cnt = 0
+#define Arglist2(x) /* empty */
+#define Arglist3(x,y,z) id_cnt = -id_cnt
+#define Bact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x3,x1)
+#define Bamper(x1,x2,x3) $$ = tree5(N_Conj,x2,x2,x1,x3)
+#define Bassgn(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Baugact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x3,x1)
+#define Baugamper(x1,x2,x3) $$ = tree5(N_Conj,x2,x2,x1,x3)
+#define Baugcat(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugeq(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugeqv(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugge(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bauggt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bauglcat(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugle(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bauglt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugne(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugneqv(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3)
+#define Baugseq(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugsge(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugsgt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugsle(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugslt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Baugsne(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bcaret(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bcareta(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bcat(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bdiff(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bdiffa(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Beq(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Beqv(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bge(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bgt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Binter(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bintera(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Blcat(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Ble(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Blim(x1,x2,x3) $$ = tree4(N_Limit,x1,x1,x3)
+#define Blt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bminus(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bminusa(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bmod(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bmoda(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bne(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bneqv(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bplus(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bplusa(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3)
+#define Brace(x1,x2,x3) $$ = x2
+#define Brack(x1,x2,x3) $$ = tree3(N_List,x1,x2)
+#define Brassgn(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Break(x1,x2) $$ = tree3(N_Break,x1,x2)
+#define Brswap(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bseq(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bsge(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bsgt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bslash(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bslasha(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bsle(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bslt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bsne(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bstar(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bstara(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Bswap(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Bunion(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3)
+#define Buniona(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3)
+#define Call(x1,x2,x3,x4) if (Val2(x1) = blocate(Str0(x1))) {\
+ Val4(x1) = fncargs[Val2(x1)-1]; \
+ $$ = tree4(N_Call,x2,x1,x3);} \
+ else { \
+ Val0(x1) = putloc(Str0(x1),0); \
+ $$ = tree4(N_Invok,x2,x1,x3); \
+ }
+#define Case(x1,x2,x3,x4,x5,x6) $$ = tree4(N_Case,x1,x2,x5)
+#define Caselist(x1,x2,x3) $$ = tree4(N_Clist,x2,x1,x3)
+#define Cclause0(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3)
+#define Cclause1(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3)
+#define Cliter(x) Val0(x) = putlit(Str0(x),F_CsetLit,(int)Val1(x))
+#define Colon(x) $$ = x
+#define Compound(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3)
+#define Create(x1,x2) $$ = tree3(N_Create,x1,x2)
+#define Elst0(x1) /* empty */
+#define Elst1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,x3)
+#define Every0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode)
+#define Every1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4)
+#define Fail(x) $$ = tree4(N_Ret,x,x,EmptyNode)
+#define Field(x1,x2,x3) $$ = tree4(N_Field,x2,x1,x3)
+#define Global0(x) idflag = F_Global
+#define Global1(x1,x2,x3) /* empty */
+#define Globdcl(x) /* empty */
+#define Ident(x) install(Str0(x),idflag,0);\
+ id_cnt = 1
+#define Idlist(x1,x2,x3) install(Str0(x3),idflag,0);\
+ ++id_cnt
+#define If0(x1,x2,x3,x4) $$ = tree5(N_If,x1,x2,x4,EmptyNode)
+#define If1(x1,x2,x3,x4,x5,x6) $$ = tree5(N_If,x1,x2,x4,x6)
+#define Iliter(x) Val0(x) = putlit(Str0(x),F_IntLit,0)
+#define Initial1() $$ = EmptyNode
+#define Initial2(x1,x2,x3) $$ = x2
+#define Invocable(x1,x2) /* empty */
+#define Invocdcl(x1) /* empty */
+#define Invoclist(x1,x2,x3) /* empty */
+#define Invocop1(x1) addinvk(Str0(x1),1)
+#define Invocop2(x1) addinvk(Str0(x1),2)
+#define Invocop3(x1,x2,x3) addinvk(Str0(x1),3)
+#define Invoke(x1,x2,x3,x4) $$ = tree4(N_Invok,x2,x1,x3)
+#define Keyword(x1,x2) if (klookup(Str0(x2)) == 0)\
+ tfatal("invalid keyword",Str0(x2));\
+ $$ = c_str_leaf(N_Key,x1,Str0(x2))
+#define Kfail(x1,x2) $$ = c_str_leaf(N_Key,x1,"fail")
+#define Link(x1,x2) /* empty */
+#define Linkdcl(x) /* empty */
+#define Lnkfile1(x) addlfile(Str0(x))
+#define Lnkfile2(x) addlfile(Str0(x))
+#define Lnklist(x1,x2,x3) /* empty */
+#define Local(x) idflag = F_Dynamic
+#define Locals1() /* empty */
+#define Locals2(x1,x2,x3,x4) /* empty */
+#define Mcolon(x) $$ = x
+#define Nexpr() $$ = EmptyNode
+#define Next(x) $$ = tree2(N_Next,x)
+#define Paren(x1,x2,x3) if ((x2)->n_type == N_Elist)\
+ $$ = tree4(N_Invok,x1,EmptyNode,x2);\
+ else\
+ $$ = x2
+#define Pcolon(x) $$ = x
+#define Pdco0(x1,x2,x3) $$ = tree4(N_Invok,x2,x1,\
+ tree3(N_List,x2,EmptyNode))
+#define Pdco1(x1,x2,x3,x4) $$ = tree4(N_Invok,x2,x1,tree3(N_List,x2,x3))
+#define Pdcolist0(x) $$ = tree3(N_Create,x,x)
+#define Pdcolist1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,tree3(N_Create,x2,x3))
+#define Proc1(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Proc,x1,x1,x4,x5,x6)
+#define Procbody1() $$ = EmptyNode
+#define Procbody2(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3)
+#define Procdcl(x) if (!nocode)\
+ codegen(x);\
+ nocode = 0;\
+ loc_init()
+#define Prochead1(x1,x2) idflag = F_Argument
+#define Prochead2(x1,x2,x3,x4,x5,x6)\
+ $$ = x2;\
+ install(Str0(x2),F_Proc|F_Global,id_cnt)
+#define Progend(x1,x2) gout(globfile)
+#define Recdcl(x) if (!nocode)\
+ rout(globfile, Str0(x));\
+ nocode = 0;\
+ loc_init()
+#define Record1(x1,x2) idflag = F_Argument
+#define Record2(x1,x2,x3,x4,x5,x6) install(Str0(x2),F_Record|F_Global,id_cnt); \
+ $$ = x2
+#define Repeat(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode)
+#define Return(x1,x2) $$ = tree4(N_Ret,x1,x1,x2)
+#define Rliter(x) Val0(x) = putlit(Str0(x),F_RealLit,0)
+#define Section(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Sect,x4,x4,x1,x3,x5)
+#define Sliter(x) Val0(x) = putlit(Str0(x),F_StrLit,(int)Val1(x))
+#define Static(x) idflag = F_Static
+#define Subscript(x1,x2,x3,x4) $$ = buildarray(x1,x2,x3,x4)
+#define Suspend0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode)
+#define Suspend1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4)
+#define To0(x1,x2,x3) $$ = tree4(N_To,x2,x1,x3)
+#define To1(x1,x2,x3,x4,x5) $$ = tree5(N_ToBy,x2,x1,x3,x5)
+#define Uat(x1,x2) $$ = tree5(N_Activat,x1,x1,x2,EmptyNode)
+#define Ubackslash(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Ubang(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Ubar(x1,x2) $$ = tree3(N_Bar,x2,x2)
+#define Ucaret(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uconcat(x1,x2) $$ = tree3(N_Bar,x2,x2)
+#define Udiff(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Udot(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uequiv(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uinter(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Ulconcat(x1,x2) $$ = tree3(N_Bar,x2,x2)
+#define Ulexeq(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Ulexne(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uminus(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Unot(x1,x2) $$ = tree3(N_Not,x2,x2)
+#define Unotequiv(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Until0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode)
+#define Until1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4)
+#define Unumeq(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Unumne(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uplus(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uqmark(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uslash(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Ustar(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Utilde(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Uunion(x1,x2) $$ = tree4(N_Unop,x1,x1,x2)
+#define Var(x) Val0(x) = putloc(Str0(x),0)
+#define While0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode)
+#define While1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4)
+%}
+
+%%
+#include "../h/grammar.h"
+%%
+
+/*
+ * xfree(p) -- used with free(p) macro to avoid compiler errors from
+ * miscast free calls generated by Yacc.
+ */
+static void xfree(p)
+char *p;
+{
+ free(p);
+}
+
+/*#define free(p) xfree((char*)p)*/
diff --git a/src/icont/tlex.c b/src/icont/tlex.c
new file mode 100644
index 0000000..d79bcc9
--- /dev/null
+++ b/src/icont/tlex.c
@@ -0,0 +1,16 @@
+/*
+ * tlex.c -- the lexical analyzer for icont.
+ */
+
+#include "../h/gsupport.h"
+#undef T_Real
+#undef T_String
+#undef T_Cset
+#include "../h/lexdef.h"
+#include "ttoken.h"
+#include "tree.h"
+#include "tproto.h"
+#include "../h/parserr.h"
+#include "../common/lextab.h"
+#include "../common/yylex.h"
+#include "../common/error.h"
diff --git a/src/icont/tmem.c b/src/icont/tmem.c
new file mode 100644
index 0000000..54e1b60
--- /dev/null
+++ b/src/icont/tmem.c
@@ -0,0 +1,76 @@
+/*
+ * tmem.c -- memory initialization and allocation for the translator.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "tsym.h"
+#include "tree.h"
+
+struct tlentry **lhash; /* hash area for local table */
+struct tgentry **ghash; /* hash area for global table */
+struct tcentry **chash; /* hash area for constant table */
+
+struct tlentry *lfirst; /* first local table entry */
+struct tlentry *llast; /* last local table entry */
+struct tcentry *cfirst; /* first constant table entry */
+struct tcentry *clast; /* last constant table entry */
+struct tgentry *gfirst; /* first global table entry */
+struct tgentry *glast; /* last global table entry */
+
+extern struct str_buf lex_sbuf;
+
+
+/*
+ * tmalloc - allocate memory for the translator
+ */
+
+void tmalloc()
+{
+ chash = (struct tcentry **) tcalloc(lchsize, sizeof (struct tcentry *));
+ ghash = (struct tgentry **) tcalloc(ghsize, sizeof (struct tgentry *));
+ lhash = (struct tlentry **) tcalloc(lhsize, sizeof (struct tlentry *));
+ init_str();
+ init_sbuf(&lex_sbuf);
+ }
+
+/*
+ * meminit - clear tables for use in translating the next file
+ */
+void tminit()
+ {
+ register struct tlentry **lp;
+ register struct tgentry **gp;
+ register struct tcentry **cp;
+
+ lfirst = NULL;
+ llast = NULL;
+ cfirst = NULL;
+ clast = NULL;
+ gfirst = NULL;
+ glast = NULL;
+
+ /*
+ * Zero out the hash tables.
+ */
+ for (lp = lhash; lp < &lhash[lhsize]; lp++)
+ *lp = NULL;
+ for (gp = ghash; gp < &ghash[ghsize]; gp++)
+ *gp = NULL;
+ for (cp = chash; cp < &chash[lchsize]; cp++)
+ *cp = NULL;
+ }
+
+/*
+ * tmfree - free memory used by the translator
+ */
+void tmfree()
+ {
+ free((char *) chash); chash = NULL;
+ free((char *) ghash); ghash = NULL;
+ free((char *) lhash); lhash = NULL;
+
+ free_stbl(); /* free string table */
+ clear_sbuf(&lex_sbuf); /* free buffer store for strings */
+ }
diff --git a/src/icont/tparse.c b/src/icont/tparse.c
new file mode 100644
index 0000000..35420fb
--- /dev/null
+++ b/src/icont/tparse.c
@@ -0,0 +1,1917 @@
+# define IDENT 257
+# define INTLIT 258
+# define REALLIT 259
+# define STRINGLIT 260
+# define CSETLIT 261
+# define EOFX 262
+# define BREAK 263
+# define BY 264
+# define CASE 265
+# define CREATE 266
+# define DEFAULT 267
+# define DO 268
+# define ELSE 269
+# define END 270
+# define EVERY 271
+# define FAIL 272
+# define GLOBAL 273
+# define IF 274
+# define INITIAL 275
+# define INVOCABLE 276
+# define LINK 277
+# define LOCAL 278
+# define NEXT 279
+# define NOT 280
+# define OF 281
+# define PROCEDURE 282
+# define RECORD 283
+# define REPEAT 284
+# define RETURN 285
+# define STATIC 286
+# define SUSPEND 287
+# define THEN 288
+# define TO 289
+# define UNTIL 290
+# define WHILE 291
+# define BANG 292
+# define MOD 293
+# define AUGMOD 294
+# define AND 295
+# define AUGAND 296
+# define STAR 297
+# define AUGSTAR 298
+# define INTER 299
+# define AUGINTER 300
+# define PLUS 301
+# define AUGPLUS 302
+# define UNION 303
+# define AUGUNION 304
+# define MINUS 305
+# define AUGMINUS 306
+# define DIFF 307
+# define AUGDIFF 308
+# define DOT 309
+# define SLASH 310
+# define AUGSLASH 311
+# define ASSIGN 312
+# define SWAP 313
+# define NMLT 314
+# define AUGNMLT 315
+# define REVASSIGN 316
+# define REVSWAP 317
+# define SLT 318
+# define AUGSLT 319
+# define SLE 320
+# define AUGSLE 321
+# define NMLE 322
+# define AUGNMLE 323
+# define NMEQ 324
+# define AUGNMEQ 325
+# define SEQ 326
+# define AUGSEQ 327
+# define EQUIV 328
+# define AUGEQUIV 329
+# define NMGT 330
+# define AUGNMGT 331
+# define NMGE 332
+# define AUGNMGE 333
+# define SGT 334
+# define AUGSGT 335
+# define SGE 336
+# define AUGSGE 337
+# define QMARK 338
+# define AUGQMARK 339
+# define AT 340
+# define AUGAT 341
+# define BACKSLASH 342
+# define CARET 343
+# define AUGCARET 344
+# define BAR 345
+# define CONCAT 346
+# define AUGCONCAT 347
+# define LCONCAT 348
+# define AUGLCONCAT 349
+# define TILDE 350
+# define NMNE 351
+# define AUGNMNE 352
+# define SNE 353
+# define AUGSNE 354
+# define NEQUIV 355
+# define AUGNEQUIV 356
+# define LPAREN 357
+# define RPAREN 358
+# define PCOLON 359
+# define COMMA 360
+# define MCOLON 361
+# define COLON 362
+# define SEMICOL 363
+# define LBRACK 364
+# define RBRACK 365
+# define LBRACE 366
+# define RBRACE 367
+
+# line 145 "tgram.g"
+/*
+ * These commented directives are passed through the first application
+ * of cpp, then turned into real includes in tgram.g by fixgram.icn.
+ */
+#include "../h/gsupport.h"
+#undef T_Real
+#undef T_String
+#undef T_Cset
+#include "../h/lexdef.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "tsym.h"
+#include "tree.h"
+#include "keyword.h"
+#undef YYSTYPE
+#define YYSTYPE nodeptr
+#define YYMAXDEPTH 500
+
+extern int fncargs[];
+int idflag;
+int id_cnt;
+
+
+
+#define yyclearin yychar = -1
+#define yyerrok yyerrflag = 0
+extern int yychar;
+extern int yyerrflag;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+#ifndef YYSTYPE
+#define YYSTYPE int
+#endif
+YYSTYPE yylval, yyval;
+# define YYERRCODE 256
+
+# line 442 "tgram.g"
+
+
+/*
+ * xfree(p) -- used with free(p) macro to avoid compiler errors from
+ * miscast free calls generated by Yacc.
+ */
+static void xfree(p)
+char *p;
+{
+ free(p);
+}
+
+#define free(p) xfree((char*)p)
+int yyexca[] ={
+-1, 0,
+ 262, 2,
+ 273, 2,
+ 276, 2,
+ 277, 2,
+ 282, 2,
+ 283, 2,
+ -2, 0,
+-1, 1,
+ 0, -1,
+ -2, 0,
+-1, 20,
+ 270, 40,
+ 363, 42,
+ -2, 0,
+-1, 86,
+ 264, 42,
+ 268, 42,
+ 269, 42,
+ 281, 42,
+ 288, 42,
+ 289, 42,
+ 293, 42,
+ 294, 42,
+ 296, 42,
+ 298, 42,
+ 300, 42,
+ 302, 42,
+ 304, 42,
+ 306, 42,
+ 308, 42,
+ 311, 42,
+ 312, 42,
+ 313, 42,
+ 314, 42,
+ 315, 42,
+ 316, 42,
+ 317, 42,
+ 318, 42,
+ 319, 42,
+ 320, 42,
+ 321, 42,
+ 322, 42,
+ 323, 42,
+ 325, 42,
+ 327, 42,
+ 329, 42,
+ 330, 42,
+ 331, 42,
+ 332, 42,
+ 333, 42,
+ 334, 42,
+ 335, 42,
+ 336, 42,
+ 337, 42,
+ 339, 42,
+ 341, 42,
+ 344, 42,
+ 347, 42,
+ 349, 42,
+ 352, 42,
+ 354, 42,
+ 356, 42,
+ 358, 42,
+ 359, 42,
+ 360, 42,
+ 361, 42,
+ 362, 42,
+ 363, 42,
+ 365, 42,
+ 367, 42,
+ -2, 0,
+-1, 87,
+ 358, 42,
+ 360, 42,
+ -2, 0,
+-1, 88,
+ 363, 42,
+ 367, 42,
+ -2, 0,
+-1, 89,
+ 360, 42,
+ 365, 42,
+ -2, 0,
+-1, 96,
+ 264, 42,
+ 268, 42,
+ 269, 42,
+ 281, 42,
+ 288, 42,
+ 289, 42,
+ 293, 42,
+ 294, 42,
+ 296, 42,
+ 298, 42,
+ 300, 42,
+ 302, 42,
+ 304, 42,
+ 306, 42,
+ 308, 42,
+ 311, 42,
+ 312, 42,
+ 313, 42,
+ 314, 42,
+ 315, 42,
+ 316, 42,
+ 317, 42,
+ 318, 42,
+ 319, 42,
+ 320, 42,
+ 321, 42,
+ 322, 42,
+ 323, 42,
+ 325, 42,
+ 327, 42,
+ 329, 42,
+ 330, 42,
+ 331, 42,
+ 332, 42,
+ 333, 42,
+ 334, 42,
+ 335, 42,
+ 336, 42,
+ 337, 42,
+ 339, 42,
+ 341, 42,
+ 344, 42,
+ 347, 42,
+ 349, 42,
+ 352, 42,
+ 354, 42,
+ 356, 42,
+ 358, 42,
+ 359, 42,
+ 360, 42,
+ 361, 42,
+ 362, 42,
+ 363, 42,
+ 365, 42,
+ 367, 42,
+ -2, 0,
+-1, 97,
+ 264, 42,
+ 268, 42,
+ 269, 42,
+ 281, 42,
+ 288, 42,
+ 289, 42,
+ 293, 42,
+ 294, 42,
+ 296, 42,
+ 298, 42,
+ 300, 42,
+ 302, 42,
+ 304, 42,
+ 306, 42,
+ 308, 42,
+ 311, 42,
+ 312, 42,
+ 313, 42,
+ 314, 42,
+ 315, 42,
+ 316, 42,
+ 317, 42,
+ 318, 42,
+ 319, 42,
+ 320, 42,
+ 321, 42,
+ 322, 42,
+ 323, 42,
+ 325, 42,
+ 327, 42,
+ 329, 42,
+ 330, 42,
+ 331, 42,
+ 332, 42,
+ 333, 42,
+ 334, 42,
+ 335, 42,
+ 336, 42,
+ 337, 42,
+ 339, 42,
+ 341, 42,
+ 344, 42,
+ 347, 42,
+ 349, 42,
+ 352, 42,
+ 354, 42,
+ 356, 42,
+ 358, 42,
+ 359, 42,
+ 360, 42,
+ 361, 42,
+ 362, 42,
+ 363, 42,
+ 365, 42,
+ 367, 42,
+ -2, 0,
+-1, 111,
+ 270, 40,
+ 363, 42,
+ -2, 0,
+-1, 117,
+ 270, 40,
+ 363, 42,
+ -2, 0,
+-1, 182,
+ 360, 42,
+ 365, 42,
+ -2, 0,
+-1, 183,
+ 360, 42,
+ -2, 0,
+-1, 184,
+ 358, 42,
+ 360, 42,
+ -2, 0,
+-1, 311,
+ 358, 42,
+ 360, 42,
+ 365, 42,
+ -2, 0,
+-1, 313,
+ 363, 42,
+ 367, 42,
+ -2, 0,
+-1, 335,
+ 360, 42,
+ 367, 42,
+ -2, 0,
+ };
+# define YYNPROD 203
+# define YYLAST 728
+int yyact[]={
+
+ 38, 84, 91, 92, 93, 94, 312, 86, 185, 99,
+ 83, 118, 335, 359, 341, 102, 95, 358, 98, 334,
+ 311, 311, 355, 85, 51, 329, 314, 20, 103, 96,
+ 118, 97, 313, 228, 101, 100, 56, 346, 118, 90,
+ 118, 59, 117, 62, 360, 58, 108, 70, 336, 64,
+ 311, 57, 228, 55, 60, 326, 184, 228, 310, 119,
+ 311, 107, 106, 182, 345, 183, 324, 232, 65, 110,
+ 67, 168, 69, 169, 352, 214, 118, 350, 328, 177,
+ 41, 356, 71, 174, 50, 175, 73, 61, 325, 52,
+ 53, 320, 54, 316, 63, 66, 176, 68, 327, 72,
+ 118, 87, 332, 118, 333, 331, 319, 361, 89, 116,
+ 88, 305, 38, 84, 91, 92, 93, 94, 118, 86,
+ 181, 99, 83, 353, 317, 231, 3, 102, 95, 218,
+ 98, 318, 105, 118, 19, 85, 51, 315, 118, 28,
+ 103, 96, 29, 97, 217, 321, 101, 100, 56, 309,
+ 170, 90, 172, 59, 173, 62, 171, 58, 118, 70,
+ 30, 64, 18, 57, 118, 55, 60, 44, 180, 37,
+ 179, 178, 113, 24, 104, 114, 25, 330, 351, 306,
+ 65, 212, 67, 115, 69, 82, 2, 81, 80, 27,
+ 17, 36, 23, 79, 71, 78, 50, 77, 73, 61,
+ 76, 52, 53, 75, 54, 74, 63, 66, 49, 68,
+ 47, 72, 42, 87, 38, 84, 91, 92, 93, 94,
+ 89, 86, 88, 99, 83, 40, 112, 322, 109, 102,
+ 95, 34, 98, 273, 274, 111, 33, 85, 51, 12,
+ 233, 32, 103, 96, 21, 97, 22, 26, 101, 100,
+ 56, 10, 9, 90, 8, 59, 7, 62, 31, 58,
+ 6, 70, 5, 64, 1, 57, 0, 55, 60, 13,
+ 0, 216, 15, 14, 0, 210, 0, 0, 16, 11,
+ 0, 0, 65, 0, 67, 234, 69, 236, 239, 221,
+ 222, 223, 224, 225, 226, 227, 71, 230, 50, 229,
+ 73, 61, 0, 52, 53, 237, 54, 0, 63, 66,
+ 0, 68, 0, 72, 0, 87, 46, 84, 91, 92,
+ 93, 94, 89, 86, 88, 99, 83, 45, 0, 0,
+ 0, 102, 95, 0, 98, 0, 289, 290, 0, 85,
+ 51, 0, 0, 235, 103, 96, 0, 97, 0, 238,
+ 101, 100, 56, 0, 0, 90, 0, 59, 0, 62,
+ 0, 58, 4, 70, 303, 64, 308, 57, 0, 55,
+ 60, 0, 0, 13, 304, 0, 15, 14, 0, 0,
+ 0, 0, 16, 11, 65, 0, 67, 0, 69, 338,
+ 0, 213, 0, 0, 0, 0, 0, 0, 71, 43,
+ 50, 0, 73, 61, 0, 52, 53, 323, 54, 347,
+ 63, 66, 35, 68, 152, 72, 0, 87, 0, 133,
+ 0, 150, 0, 130, 89, 131, 88, 128, 0, 127,
+ 0, 129, 0, 126, 362, 0, 132, 121, 120, 0,
+ 140, 123, 122, 0, 147, 164, 146, 0, 139, 158,
+ 135, 157, 143, 163, 136, 160, 138, 154, 137, 166,
+ 145, 162, 144, 161, 149, 156, 151, 155, 0, 134,
+ 0, 0, 124, 0, 125, 0, 153, 141, 211, 148,
+ 215, 142, 165, 39, 159, 0, 167, 0, 219, 220,
+ 0, 295, 296, 297, 298, 299, 0, 0, 291, 292,
+ 293, 294, 0, 35, 0, 0, 0, 339, 340, 35,
+ 342, 343, 344, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 348, 0, 0, 0, 48, 0, 0, 0,
+ 0, 0, 0, 354, 0, 0, 0, 0, 0, 0,
+ 0, 0, 357, 0, 0, 0, 0, 0, 0, 0,
+ 0, 354, 363, 364, 275, 276, 277, 278, 279, 280,
+ 281, 282, 283, 284, 285, 286, 287, 288, 0, 0,
+ 0, 0, 0, 0, 0, 307, 0, 186, 187, 188,
+ 189, 190, 191, 192, 193, 194, 195, 196, 197, 198,
+ 199, 200, 201, 202, 203, 204, 205, 206, 207, 208,
+ 209, 0, 0, 240, 241, 242, 243, 244, 245, 246,
+ 247, 248, 249, 250, 251, 252, 253, 254, 255, 256,
+ 257, 258, 259, 260, 261, 262, 263, 264, 265, 266,
+ 267, 268, 269, 270, 271, 272, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 337, 0, 215, 300, 301, 302, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 349 };
+int yypact[]={
+
+ -130, -1000, 100, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -95, -229, -1000, -84, -118, -97, -4, -1000, -1000,
+ -42, -125, -298, -1000, -1000, -1000, -299, -1000, -1000, -316,
+ -1000, -1000, -288, -103, -161, -321, -219, -279, -1000, -1000,
+ 125, -1000, 131, -275, -151, -214, -1000, -172, -1000, -301,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -42, -1000, -1000, -42, -42, -42, -42,
+ -128, -1000, -1000, -1000, -1000, -1000, -42, -42, -42, -42,
+ -42, -42, -42, -42, -303, -1000, -84, -118, -133, -290,
+ -125, -42, -125, -42, -1000, -1000, -1000, -42, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, 60, 60, 60, 60, 60, 60, 60, 60,
+ 60, 60, -42, -256, -42, -108, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -219, -1000, -300, -1000, -361, -331, -339, -1000, -1000, -1000,
+ -1000, -131, -195, -157, -137, -162, -177, -219, -112, -1000,
+ -1000, -1000, -125, -292, -303, -182, -308, -265, -1000, -279,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -186, -1000, -275, -275, -275, -275, -275,
+ -275, -275, -275, -275, -275, -275, -275, -275, -275, -151,
+ -151, -214, -214, -214, -214, -1000, -1000, -1000, -1000, -1000,
+ -1000, -1000, -1000, -340, -257, -1000, -348, -1000, -310, -1000,
+ -1000, -42, -1000, -42, -1000, -42, -42, -352, -42, -42,
+ -42, -1000, -294, -327, -1000, -1000, -1000, -1000, 60, -1000,
+ -42, -1000, -1000, -1000, -1000, -42, -1000, -1000, -1000, -219,
+ -192, -144, -219, -219, -219, -1000, -343, -1000, -284, -1000,
+ -42, -350, -1000, -318, -255, -1000, -1000, -219, -1000, -144,
+ -42, -42, -1000, -219, -219 };
+int yypgo[]={
+
+ 0, 264, 186, 262, 260, 256, 254, 252, 251, 247,
+ 189, 246, 192, 244, 174, 241, 240, 239, 236, 235,
+ 231, 228, 227, 226, 191, 391, 169, 483, 225, 80,
+ 212, 399, 167, 327, 316, 210, 526, 208, 205, 203,
+ 200, 197, 195, 193, 188, 187, 185, 181, 75, 179,
+ 178, 74, 177 };
+int yyr1[]={
+
+ 0, 1, 2, 2, 3, 3, 3, 3, 3, 8,
+ 9, 9, 10, 10, 10, 7, 11, 11, 12, 12,
+ 13, 6, 15, 4, 16, 16, 5, 21, 17, 22,
+ 22, 22, 14, 14, 18, 18, 23, 23, 19, 19,
+ 20, 20, 25, 25, 24, 24, 26, 26, 27, 27,
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+ 27, 28, 28, 28, 29, 29, 30, 30, 30, 30,
+ 30, 30, 30, 30, 30, 30, 30, 30, 30, 30,
+ 30, 31, 31, 31, 32, 32, 32, 32, 32, 33,
+ 33, 33, 33, 33, 34, 34, 35, 35, 35, 35,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 36, 36, 36, 36, 36,
+ 36, 36, 36, 36, 36, 37, 37, 37, 37, 37,
+ 37, 37, 37, 37, 37, 37, 37, 37, 37, 37,
+ 37, 37, 37, 37, 37, 37, 37, 37, 43, 43,
+ 44, 44, 45, 45, 46, 40, 40, 40, 40, 41,
+ 41, 42, 50, 50, 51, 51, 47, 47, 49, 49,
+ 38, 38, 38, 38, 39, 52, 52, 52, 48, 48,
+ 1, 5, 24 };
+int yyr2[]={
+
+ 0, 5, 0, 4, 3, 3, 3, 3, 3, 5,
+ 2, 7, 3, 3, 7, 5, 2, 7, 3, 3,
+ 1, 7, 1, 13, 1, 3, 13, 1, 13, 1,
+ 3, 7, 3, 7, 1, 9, 3, 3, 1, 7,
+ 1, 7, 1, 2, 2, 7, 2, 7, 2, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 2, 7, 11, 2, 7, 2, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 2, 7, 7, 2, 7, 7, 7, 7, 2,
+ 7, 7, 7, 7, 2, 7, 2, 7, 7, 7,
+ 2, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 5, 5, 5, 5, 5, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 5, 3, 3, 5, 7, 7,
+ 7, 9, 7, 9, 9, 7, 5, 5, 5, 9,
+ 5, 9, 5, 9, 5, 3, 5, 5, 9, 9,
+ 13, 13, 2, 7, 7, 7, 3, 7, 3, 7,
+ 3, 3, 3, 3, 13, 3, 3, 3, 2, 7,
+ 6, 8, 2 };
+int yychk[]={
+
+ -1000, -1, -2, 256, 262, -3, -4, -5, -6, -7,
+ -8, 283, -17, 273, 277, 276, 282, -2, 257, 363,
+ 256, -13, -11, -12, 257, 260, -9, -10, 257, 260,
+ 257, 262, -15, -18, -20, -25, -24, -26, 256, -27,
+ -28, -29, -30, -31, -32, -33, -34, -35, -36, -37,
+ 340, 280, 345, 346, 348, 309, 292, 307, 301, 297,
+ 310, 343, 299, 350, 305, 324, 351, 326, 353, 328,
+ 303, 338, 355, 342, -38, -39, -40, -41, -42, -43,
+ -44, -45, -46, 266, 257, 279, 263, 357, 366, 364,
+ 295, 258, 259, 260, 261, 272, 285, 287, 274, 265,
+ 291, 290, 271, 284, -14, 257, 360, 360, 362, -21,
+ 357, -19, -23, 275, 278, 286, 270, 363, 295, 338,
+ 313, 312, 317, 316, 347, 349, 308, 304, 302, 306,
+ 298, 300, 311, 294, 344, 325, 329, 333, 331, 323,
+ 315, 352, 356, 327, 337, 335, 321, 319, 354, 339,
+ 296, 341, 289, 345, 326, 336, 334, 320, 318, 353,
+ 324, 332, 330, 322, 314, 351, 328, 355, 346, 348,
+ 301, 307, 303, 305, 297, 299, 310, 293, 343, 342,
+ 340, 292, 364, 366, 357, 309, -36, -36, -36, -36,
+ -36, -36, -36, -36, -36, -36, -36, -36, -36, -36,
+ -36, -36, -36, -36, -36, -36, -36, -36, -36, -36,
+ -24, -25, -47, -25, -48, -25, -47, 272, 257, -25,
+ -25, -24, -24, -24, -24, -24, -24, -24, 360, -12,
+ -10, 258, 357, -16, -14, -20, -14, -24, -20, -26,
+ -27, -27, -27, -27, -27, -27, -27, -27, -27, -27,
+ -27, -27, -27, -27, -27, -27, -27, -27, -27, -27,
+ -27, -27, -27, -27, -27, -27, -27, -27, -27, -27,
+ -27, -27, -27, -29, -29, -31, -31, -31, -31, -31,
+ -31, -31, -31, -31, -31, -31, -31, -31, -31, -32,
+ -32, -33, -33, -33, -33, -34, -34, -34, -34, -34,
+ -36, -36, -36, -47, -24, 367, -49, -25, -47, 257,
+ 358, 360, 367, 363, 365, 268, 288, 281, 268, 268,
+ 268, 257, -22, -14, 358, 270, 363, 363, 264, 365,
+ -52, 362, 359, 361, 367, 360, 358, -25, -48, -24,
+ -24, 366, -24, -24, -24, 358, 364, -29, -24, -25,
+ 269, -50, -51, 267, -24, 365, 365, -24, 367, 363,
+ 362, 362, -51, -24, -24 };
+int yydef[]={
+
+ -2, -2, 0, 2, 1, 3, 4, 5, 6, 7,
+ 8, 0, 0, 20, 0, 0, 0, 0, 22, 34,
+ -2, 0, 15, 16, 18, 19, 9, 10, 12, 13,
+ 27, 200, 0, 38, 0, 0, 43, 44, 202, 46,
+ 48, 81, 84, 86, 101, 104, 109, 114, 116, 120,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 145, 146, 147, 148, 149, 150,
+ 151, 152, 153, 0, 155, 156, -2, -2, -2, -2,
+ 0, 190, 191, 192, 193, 175, -2, -2, 0, 0,
+ 0, 0, 0, 0, 21, 32, 0, 0, 0, 0,
+ 24, -2, 0, 0, 36, 37, 201, -2, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, -2, -2, -2, 0, 121, 122, 123, 124,
+ 125, 126, 127, 128, 129, 130, 131, 132, 133, 134,
+ 135, 136, 137, 138, 139, 140, 141, 142, 143, 144,
+ 154, 157, 0, 186, 0, 198, 0, 166, 167, 176,
+ 177, 43, 0, 0, 168, 170, 172, 174, 0, 17,
+ 11, 14, 29, 0, 25, 0, 0, 0, 41, 45,
+ 47, 49, 50, 51, 52, 53, 54, 55, 56, 57,
+ 58, 59, 60, 61, 62, 63, 64, 65, 66, 67,
+ 68, 69, 70, 71, 72, 73, 74, 75, 76, 77,
+ 78, 79, 80, 82, 85, 87, 88, 89, 90, 91,
+ 92, 93, 94, 95, 96, 97, 98, 99, 100, 102,
+ 103, 105, 106, 107, 108, 110, 111, 112, 113, 115,
+ 117, 118, 119, 0, 43, 162, 0, 188, 0, 165,
+ 158, -2, 159, -2, 160, 0, 0, 0, 0, 0,
+ 0, 33, 0, 30, 23, 26, 35, 39, 0, 161,
+ 0, 195, 196, 197, 163, -2, 164, 187, 199, 178,
+ 179, 0, 169, 171, 173, 28, 0, 83, 0, 189,
+ 0, 0, 182, 0, 0, 31, 194, 180, 181, 0,
+ 0, 0, 183, 184, 185 };
+typedef struct { char *t_name; int t_val; } yytoktype;
+#ifndef YYDEBUG
+# define YYDEBUG 0 /* don't allow debugging */
+#endif
+
+#if YYDEBUG
+
+yytoktype yytoks[] =
+{
+ "IDENT", 257,
+ "INTLIT", 258,
+ "REALLIT", 259,
+ "STRINGLIT", 260,
+ "CSETLIT", 261,
+ "EOFX", 262,
+ "BREAK", 263,
+ "BY", 264,
+ "CASE", 265,
+ "CREATE", 266,
+ "DEFAULT", 267,
+ "DO", 268,
+ "ELSE", 269,
+ "END", 270,
+ "EVERY", 271,
+ "FAIL", 272,
+ "GLOBAL", 273,
+ "IF", 274,
+ "INITIAL", 275,
+ "INVOCABLE", 276,
+ "LINK", 277,
+ "LOCAL", 278,
+ "NEXT", 279,
+ "NOT", 280,
+ "OF", 281,
+ "PROCEDURE", 282,
+ "RECORD", 283,
+ "REPEAT", 284,
+ "RETURN", 285,
+ "STATIC", 286,
+ "SUSPEND", 287,
+ "THEN", 288,
+ "TO", 289,
+ "UNTIL", 290,
+ "WHILE", 291,
+ "BANG", 292,
+ "MOD", 293,
+ "AUGMOD", 294,
+ "AND", 295,
+ "AUGAND", 296,
+ "STAR", 297,
+ "AUGSTAR", 298,
+ "INTER", 299,
+ "AUGINTER", 300,
+ "PLUS", 301,
+ "AUGPLUS", 302,
+ "UNION", 303,
+ "AUGUNION", 304,
+ "MINUS", 305,
+ "AUGMINUS", 306,
+ "DIFF", 307,
+ "AUGDIFF", 308,
+ "DOT", 309,
+ "SLASH", 310,
+ "AUGSLASH", 311,
+ "ASSIGN", 312,
+ "SWAP", 313,
+ "NMLT", 314,
+ "AUGNMLT", 315,
+ "REVASSIGN", 316,
+ "REVSWAP", 317,
+ "SLT", 318,
+ "AUGSLT", 319,
+ "SLE", 320,
+ "AUGSLE", 321,
+ "NMLE", 322,
+ "AUGNMLE", 323,
+ "NMEQ", 324,
+ "AUGNMEQ", 325,
+ "SEQ", 326,
+ "AUGSEQ", 327,
+ "EQUIV", 328,
+ "AUGEQUIV", 329,
+ "NMGT", 330,
+ "AUGNMGT", 331,
+ "NMGE", 332,
+ "AUGNMGE", 333,
+ "SGT", 334,
+ "AUGSGT", 335,
+ "SGE", 336,
+ "AUGSGE", 337,
+ "QMARK", 338,
+ "AUGQMARK", 339,
+ "AT", 340,
+ "AUGAT", 341,
+ "BACKSLASH", 342,
+ "CARET", 343,
+ "AUGCARET", 344,
+ "BAR", 345,
+ "CONCAT", 346,
+ "AUGCONCAT", 347,
+ "LCONCAT", 348,
+ "AUGLCONCAT", 349,
+ "TILDE", 350,
+ "NMNE", 351,
+ "AUGNMNE", 352,
+ "SNE", 353,
+ "AUGSNE", 354,
+ "NEQUIV", 355,
+ "AUGNEQUIV", 356,
+ "LPAREN", 357,
+ "RPAREN", 358,
+ "PCOLON", 359,
+ "COMMA", 360,
+ "MCOLON", 361,
+ "COLON", 362,
+ "SEMICOL", 363,
+ "LBRACK", 364,
+ "RBRACK", 365,
+ "LBRACE", 366,
+ "RBRACE", 367,
+ "-unknown-", -1 /* ends search */
+};
+
+char * yyreds[] =
+{
+ "-no such reduction-",
+ "program : decls EOFX",
+ "decls : /* empty */",
+ "decls : decls decl",
+ "decl : record",
+ "decl : proc",
+ "decl : global",
+ "decl : link",
+ "decl : invocable",
+ "invocable : INVOCABLE invoclist",
+ "invoclist : invocop",
+ "invoclist : invoclist COMMA invocop",
+ "invocop : IDENT",
+ "invocop : STRINGLIT",
+ "invocop : STRINGLIT COLON INTLIT",
+ "link : LINK lnklist",
+ "lnklist : lnkfile",
+ "lnklist : lnklist COMMA lnkfile",
+ "lnkfile : IDENT",
+ "lnkfile : STRINGLIT",
+ "global : GLOBAL",
+ "global : GLOBAL idlist",
+ "record : RECORD IDENT",
+ "record : RECORD IDENT LPAREN fldlist RPAREN",
+ "fldlist : /* empty */",
+ "fldlist : idlist",
+ "proc : prochead SEMICOL locals initial procbody END",
+ "prochead : PROCEDURE IDENT",
+ "prochead : PROCEDURE IDENT LPAREN arglist RPAREN",
+ "arglist : /* empty */",
+ "arglist : idlist",
+ "arglist : idlist LBRACK RBRACK",
+ "idlist : IDENT",
+ "idlist : idlist COMMA IDENT",
+ "locals : /* empty */",
+ "locals : locals retention idlist SEMICOL",
+ "retention : LOCAL",
+ "retention : STATIC",
+ "initial : /* empty */",
+ "initial : INITIAL expr SEMICOL",
+ "procbody : /* empty */",
+ "procbody : nexpr SEMICOL procbody",
+ "nexpr : /* empty */",
+ "nexpr : expr",
+ "expr : expr1a",
+ "expr : expr AND expr1a",
+ "expr1a : expr1",
+ "expr1a : expr1a QMARK expr1",
+ "expr1 : expr2",
+ "expr1 : expr2 SWAP expr1",
+ "expr1 : expr2 ASSIGN expr1",
+ "expr1 : expr2 REVSWAP expr1",
+ "expr1 : expr2 REVASSIGN expr1",
+ "expr1 : expr2 AUGCONCAT expr1",
+ "expr1 : expr2 AUGLCONCAT expr1",
+ "expr1 : expr2 AUGDIFF expr1",
+ "expr1 : expr2 AUGUNION expr1",
+ "expr1 : expr2 AUGPLUS expr1",
+ "expr1 : expr2 AUGMINUS expr1",
+ "expr1 : expr2 AUGSTAR expr1",
+ "expr1 : expr2 AUGINTER expr1",
+ "expr1 : expr2 AUGSLASH expr1",
+ "expr1 : expr2 AUGMOD expr1",
+ "expr1 : expr2 AUGCARET expr1",
+ "expr1 : expr2 AUGNMEQ expr1",
+ "expr1 : expr2 AUGEQUIV expr1",
+ "expr1 : expr2 AUGNMGE expr1",
+ "expr1 : expr2 AUGNMGT expr1",
+ "expr1 : expr2 AUGNMLE expr1",
+ "expr1 : expr2 AUGNMLT expr1",
+ "expr1 : expr2 AUGNMNE expr1",
+ "expr1 : expr2 AUGNEQUIV expr1",
+ "expr1 : expr2 AUGSEQ expr1",
+ "expr1 : expr2 AUGSGE expr1",
+ "expr1 : expr2 AUGSGT expr1",
+ "expr1 : expr2 AUGSLE expr1",
+ "expr1 : expr2 AUGSLT expr1",
+ "expr1 : expr2 AUGSNE expr1",
+ "expr1 : expr2 AUGQMARK expr1",
+ "expr1 : expr2 AUGAND expr1",
+ "expr1 : expr2 AUGAT expr1",
+ "expr2 : expr3",
+ "expr2 : expr2 TO expr3",
+ "expr2 : expr2 TO expr3 BY expr3",
+ "expr3 : expr4",
+ "expr3 : expr4 BAR expr3",
+ "expr4 : expr5",
+ "expr4 : expr4 SEQ expr5",
+ "expr4 : expr4 SGE expr5",
+ "expr4 : expr4 SGT expr5",
+ "expr4 : expr4 SLE expr5",
+ "expr4 : expr4 SLT expr5",
+ "expr4 : expr4 SNE expr5",
+ "expr4 : expr4 NMEQ expr5",
+ "expr4 : expr4 NMGE expr5",
+ "expr4 : expr4 NMGT expr5",
+ "expr4 : expr4 NMLE expr5",
+ "expr4 : expr4 NMLT expr5",
+ "expr4 : expr4 NMNE expr5",
+ "expr4 : expr4 EQUIV expr5",
+ "expr4 : expr4 NEQUIV expr5",
+ "expr5 : expr6",
+ "expr5 : expr5 CONCAT expr6",
+ "expr5 : expr5 LCONCAT expr6",
+ "expr6 : expr7",
+ "expr6 : expr6 PLUS expr7",
+ "expr6 : expr6 DIFF expr7",
+ "expr6 : expr6 UNION expr7",
+ "expr6 : expr6 MINUS expr7",
+ "expr7 : expr8",
+ "expr7 : expr7 STAR expr8",
+ "expr7 : expr7 INTER expr8",
+ "expr7 : expr7 SLASH expr8",
+ "expr7 : expr7 MOD expr8",
+ "expr8 : expr9",
+ "expr8 : expr9 CARET expr8",
+ "expr9 : expr10",
+ "expr9 : expr9 BACKSLASH expr10",
+ "expr9 : expr9 AT expr10",
+ "expr9 : expr9 BANG expr10",
+ "expr10 : expr11",
+ "expr10 : AT expr10",
+ "expr10 : NOT expr10",
+ "expr10 : BAR expr10",
+ "expr10 : CONCAT expr10",
+ "expr10 : LCONCAT expr10",
+ "expr10 : DOT expr10",
+ "expr10 : BANG expr10",
+ "expr10 : DIFF expr10",
+ "expr10 : PLUS expr10",
+ "expr10 : STAR expr10",
+ "expr10 : SLASH expr10",
+ "expr10 : CARET expr10",
+ "expr10 : INTER expr10",
+ "expr10 : TILDE expr10",
+ "expr10 : MINUS expr10",
+ "expr10 : NMEQ expr10",
+ "expr10 : NMNE expr10",
+ "expr10 : SEQ expr10",
+ "expr10 : SNE expr10",
+ "expr10 : EQUIV expr10",
+ "expr10 : UNION expr10",
+ "expr10 : QMARK expr10",
+ "expr10 : NEQUIV expr10",
+ "expr10 : BACKSLASH expr10",
+ "expr11 : literal",
+ "expr11 : section",
+ "expr11 : return",
+ "expr11 : if",
+ "expr11 : case",
+ "expr11 : while",
+ "expr11 : until",
+ "expr11 : every",
+ "expr11 : repeat",
+ "expr11 : CREATE expr",
+ "expr11 : IDENT",
+ "expr11 : NEXT",
+ "expr11 : BREAK nexpr",
+ "expr11 : LPAREN exprlist RPAREN",
+ "expr11 : LBRACE compound RBRACE",
+ "expr11 : LBRACK exprlist RBRACK",
+ "expr11 : expr11 LBRACK exprlist RBRACK",
+ "expr11 : expr11 LBRACE RBRACE",
+ "expr11 : expr11 LBRACE pdcolist RBRACE",
+ "expr11 : expr11 LPAREN exprlist RPAREN",
+ "expr11 : expr11 DOT IDENT",
+ "expr11 : AND FAIL",
+ "expr11 : AND IDENT",
+ "while : WHILE expr",
+ "while : WHILE expr DO expr",
+ "until : UNTIL expr",
+ "until : UNTIL expr DO expr",
+ "every : EVERY expr",
+ "every : EVERY expr DO expr",
+ "repeat : REPEAT expr",
+ "return : FAIL",
+ "return : RETURN nexpr",
+ "return : SUSPEND nexpr",
+ "return : SUSPEND expr DO expr",
+ "if : IF expr THEN expr",
+ "if : IF expr THEN expr ELSE expr",
+ "case : CASE expr OF LBRACE caselist RBRACE",
+ "caselist : cclause",
+ "caselist : caselist SEMICOL cclause",
+ "cclause : DEFAULT COLON expr",
+ "cclause : expr COLON expr",
+ "exprlist : nexpr",
+ "exprlist : exprlist COMMA nexpr",
+ "pdcolist : nexpr",
+ "pdcolist : pdcolist COMMA nexpr",
+ "literal : INTLIT",
+ "literal : REALLIT",
+ "literal : STRINGLIT",
+ "literal : CSETLIT",
+ "section : expr11 LBRACK expr sectop expr RBRACK",
+ "sectop : COLON",
+ "sectop : PCOLON",
+ "sectop : MCOLON",
+ "compound : nexpr",
+ "compound : nexpr SEMICOL compound",
+ "program : error decls EOFX",
+ "proc : prochead error procbody END",
+ "expr : error",
+};
+#endif
+#line 1 "/usr/lib/yaccpar"
+/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */
+
+/*
+** Skeleton parser driver for yacc output
+*/
+
+/*
+** yacc user known macros and defines
+*/
+#define YYERROR goto yyerrlab
+#define YYACCEPT { free(yys); free(yyv); return(0); }
+#define YYABORT { free(yys); free(yyv); return(1); }
+#define YYBACKUP( newtoken, newvalue )\
+{\
+ if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\
+ {\
+ tsyserr("parser: syntax error - cannot backup" );\
+ goto yyerrlab;\
+ }\
+ yychar = newtoken;\
+ yystate = *yyps;\
+ yylval = newvalue;\
+ goto yynewstate;\
+}
+#define YYRECOVERING() (!!yyerrflag)
+#ifndef YYDEBUG
+# define YYDEBUG 1 /* make debugging available */
+#endif
+
+/*
+** user known globals
+*/
+int yydebug; /* set to 1 to get debugging */
+
+/*
+** driver internal defines
+*/
+#define YYFLAG (-1000)
+
+/*
+** static variables used by the parser
+*/
+static YYSTYPE *yyv; /* value stack */
+static int *yys; /* state stack */
+
+static YYSTYPE *yypv; /* top of value stack */
+static int *yyps; /* top of state stack */
+
+static int yystate; /* current state */
+static int yytmp; /* extra var (lasts between blocks) */
+
+int yynerrs; /* number of errors */
+
+int yyerrflag; /* error recovery flag */
+int yychar; /* current input token number */
+
+
+/*
+** yyparse - return 0 if worked, 1 if syntax error not recovered from
+*/
+int
+yyparse()
+{
+ register YYSTYPE *yypvt; /* top of value stack for $vars */
+ unsigned yymaxdepth = YYMAXDEPTH;
+
+ /*
+ ** Initialize externals - yyparse may be called more than once
+ */
+ yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE));
+ yys = (int*)malloc(yymaxdepth*sizeof(int));
+ if (!yyv || !yys)
+ {
+ tsyserr("parser: out of memory" );
+ return(1);
+ }
+ yypv = &yyv[-1];
+ yyps = &yys[-1];
+ yystate = 0;
+ yytmp = 0;
+ yynerrs = 0;
+ yyerrflag = 0;
+ yychar = -1;
+
+ goto yystack;
+ {
+ register YYSTYPE *yy_pv; /* top of value stack */
+ register int *yy_ps; /* top of state stack */
+ register int yy_state; /* current state */
+ register int yy_n; /* internal state number info */
+
+ /*
+ ** get globals into registers.
+ ** branch to here only if YYBACKUP was called.
+ */
+ yynewstate:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ goto yy_newstate;
+
+ /*
+ ** get globals into registers.
+ ** either we just started, or we just finished a reduction
+ */
+ yystack:
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+
+ /*
+ ** top of for (;;) loop while no reductions done
+ */
+ yy_stack:
+ /*
+ ** put a state and value onto the stacks
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token value in list of value vs.
+ ** name pairs. 0 and negative (-1) are special values.
+ ** Note: linear search is used since time is not a real
+ ** consideration while debugging.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ (void)printf( "State %d, token ", yy_state );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif
+ if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int yyps_index = (yy_ps - yys);
+ int yypv_index = (yy_pv - yyv);
+ int yypvt_index = (yypvt - yyv);
+ yymaxdepth += YYMAXDEPTH;
+ yyv = (YYSTYPE*)realloc((char*)yyv,
+ yymaxdepth * sizeof(YYSTYPE));
+ yys = (int*)realloc((char*)yys,
+ yymaxdepth * sizeof(int));
+ if (!yyv || !yys)
+ {
+ tsyserr("parse stack overflow" );
+ return(1);
+ }
+ yy_ps = yys + yyps_index;
+ yy_pv = yyv + yypv_index;
+ yypvt = yyv + yypvt_index;
+ }
+ *yy_ps = yy_state;
+ *++yy_pv = yyval;
+
+ /*
+ ** we have a new state - find out what to do
+ */
+ yy_newstate:
+ if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG )
+ goto yydefault; /* simple state */
+#if YYDEBUG
+ /*
+ ** if debugging, need to mark whether new token grabbed
+ */
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ (void)printf( "Received token " );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0; yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val == yychar )
+ break;
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif
+ if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) )
+ goto yydefault;
+ if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/
+ {
+ yychar = -1;
+ yyval = yylval;
+ yy_state = yy_n;
+ if ( yyerrflag > 0 )
+ yyerrflag--;
+ goto yy_stack;
+ }
+
+ yydefault:
+ if ( ( yy_n = yydef[ yy_state ] ) == -2 )
+ {
+#if YYDEBUG
+ yytmp = yychar < 0;
+#endif
+ if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) )
+ yychar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( yydebug && yytmp )
+ {
+ register int yy_i;
+
+ (void)printf( "Received token " );
+ if ( yychar == 0 )
+ (void)printf( "end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "-none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ (void)printf( "%s\n", yytoks[yy_i].t_name );
+ }
+ }
+#endif
+ /*
+ ** look through exception table
+ */
+ {
+ register int *yyxi = yyexca;
+
+ while ( ( *yyxi != -1 ) ||
+ ( yyxi[1] != yy_state ) )
+ {
+ yyxi += 2;
+ }
+ while ( ( *(yyxi += 2) >= 0 ) &&
+ ( *yyxi != yychar ) )
+ ;
+ if ( ( yy_n = yyxi[1] ) < 0 )
+ YYACCEPT;
+ }
+ }
+
+ /*
+ ** check for syntax error
+ */
+ if ( yy_n == 0 ) /* have an error */
+ {
+ /* no worry about speed here! */
+ switch ( yyerrflag )
+ {
+ case 0: /* new error */
+ yyerror(yychar, yylval, yy_state );
+ goto skip_init;
+ yyerrlab:
+ /*
+ ** get globals into registers.
+ ** we have a user generated syntax type error
+ */
+ yy_pv = yypv;
+ yy_ps = yyps;
+ yy_state = yystate;
+ yynerrs++;
+ skip_init:
+ case 1:
+ case 2: /* incompletely recovered error */
+ /* try again... */
+ yyerrflag = 3;
+ /*
+ ** find state where "error" is a legal
+ ** shift action
+ */
+ while ( yy_ps >= yys )
+ {
+ yy_n = yypact[ *yy_ps ] + YYERRCODE;
+ if ( yy_n >= 0 && yy_n < YYLAST &&
+ yychk[yyact[yy_n]] == YYERRCODE) {
+ /*
+ ** simulate shift of "error"
+ */
+ yy_state = yyact[ yy_n ];
+ goto yy_stack;
+ }
+ /*
+ ** current state has no shift on
+ ** "error", pop stack
+ */
+#if YYDEBUG
+# define _POP_ "Error recovery pops state %d, uncovers state %d\n"
+ if ( yydebug )
+ (void)printf( _POP_, *yy_ps,
+ yy_ps[-1] );
+# undef _POP_
+#endif
+ yy_ps--;
+ yy_pv--;
+ }
+ /*
+ ** there is no state on stack with "error" as
+ ** a valid shift. give up.
+ */
+ YYABORT;
+ case 3: /* no shift yet; eat a token */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token in list of
+ ** pairs. 0 and negative shouldn't occur,
+ ** but since timing doesn't matter when
+ ** debugging, it doesn't hurt to leave the
+ ** tests here.
+ */
+ if ( yydebug )
+ {
+ register int yy_i;
+
+ (void)printf( "Error recovery discards " );
+ if ( yychar == 0 )
+ (void)printf( "token end-of-file\n" );
+ else if ( yychar < 0 )
+ (void)printf( "token -none-\n" );
+ else
+ {
+ for ( yy_i = 0;
+ yytoks[yy_i].t_val >= 0;
+ yy_i++ )
+ {
+ if ( yytoks[yy_i].t_val
+ == yychar )
+ {
+ break;
+ }
+ }
+ (void)printf( "token %s\n",
+ yytoks[yy_i].t_name );
+ }
+ }
+#endif
+ if ( yychar == 0 ) /* reached EOF. quit */
+ YYABORT;
+ yychar = -1;
+ goto yy_newstate;
+ }
+ }/* end if ( yy_n == 0 ) */
+ /*
+ ** reduction by production yy_n
+ ** put stack tops, etc. so things right after switch
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, print the string that is the user's
+ ** specification of the reduction which is just about
+ ** to be done.
+ */
+ if ( yydebug )
+ (void)printf( "Reduce by (%d) \"%s\"\n",
+ yy_n, yyreds[ yy_n ] );
+#endif
+ yytmp = yy_n; /* value to switch over */
+ yypvt = yy_pv; /* $vars top of value stack */
+ /*
+ ** Look in goto table for next state
+ ** Sorry about using yy_state here as temporary
+ ** register variable, but why not, if it works...
+ ** If yyr2[ yy_n ] doesn't have the low order bit
+ ** set, then there is no action to be done for
+ ** this reduction. So, no saving & unsaving of
+ ** registers done. The only difference between the
+ ** code just after the if and the body of the if is
+ ** the goto yy_stack in the body. This way the test
+ ** can be made before the choice of what to do is needed.
+ */
+ {
+ /* length of production doubled with extra bit */
+ register int yy_len = yyr2[ yy_n ];
+
+ if ( !( yy_len & 01 ) )
+ {
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state =
+ yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ goto yy_stack;
+ }
+ yy_len >>= 1;
+ yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */
+ yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] +
+ *( yy_ps -= yy_len ) + 1;
+ if ( yy_state >= YYLAST ||
+ yychk[ yy_state = yyact[ yy_state ] ] != -yy_n )
+ {
+ yy_state = yyact[ yypgo[ yy_n ] ];
+ }
+ }
+ /* save until reenter driver code */
+ yystate = yy_state;
+ yyps = yy_ps;
+ yypv = yy_pv;
+ }
+ /*
+ ** code supplied by user is placed in this switch
+ */
+ switch( yytmp )
+ {
+
+case 1:
+# line 179 "tgram.g"
+{gout(globfile);} break;
+case 4:
+# line 184 "tgram.g"
+{if (!nocode) rout(globfile, Str0(yypvt[-0])); nocode = 0; loc_init();} break;
+case 5:
+# line 185 "tgram.g"
+{if (!nocode) codegen(yypvt[-0]); nocode = 0; loc_init();} break;
+case 6:
+# line 186 "tgram.g"
+{;} break;
+case 7:
+# line 187 "tgram.g"
+{;} break;
+case 8:
+# line 188 "tgram.g"
+{;} break;
+case 9:
+# line 190 "tgram.g"
+{;} break;
+case 11:
+# line 193 "tgram.g"
+{;} break;
+case 12:
+# line 195 "tgram.g"
+{addinvk(Str0(yypvt[-0]),1);} break;
+case 13:
+# line 196 "tgram.g"
+{addinvk(Str0(yypvt[-0]),2);} break;
+case 14:
+# line 197 "tgram.g"
+{addinvk(Str0(yypvt[-2]),3);} break;
+case 15:
+# line 199 "tgram.g"
+{;} break;
+case 17:
+# line 202 "tgram.g"
+{;} break;
+case 18:
+# line 204 "tgram.g"
+{addlfile(Str0(yypvt[-0]));} break;
+case 19:
+# line 205 "tgram.g"
+{addlfile(Str0(yypvt[-0]));} break;
+case 20:
+# line 207 "tgram.g"
+{idflag = F_Global;} break;
+case 21:
+# line 207 "tgram.g"
+{;} break;
+case 22:
+# line 209 "tgram.g"
+{idflag = F_Argument;} break;
+case 23:
+# line 209 "tgram.g"
+{
+ install(Str0(yypvt[-4]),F_Record|F_Global,id_cnt); yyval = yypvt[-4];
+ } break;
+case 24:
+# line 213 "tgram.g"
+{id_cnt = 0;} break;
+case 25:
+# line 214 "tgram.g"
+{;} break;
+case 26:
+# line 216 "tgram.g"
+{
+ yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]);
+ } break;
+case 27:
+# line 220 "tgram.g"
+{idflag = F_Argument;} break;
+case 28:
+# line 220 "tgram.g"
+{
+ yyval = yypvt[-4]; install(Str0(yypvt[-4]),F_Proc|F_Global,id_cnt);
+ } break;
+case 29:
+# line 224 "tgram.g"
+{id_cnt = 0;} break;
+case 30:
+# line 225 "tgram.g"
+{;} break;
+case 31:
+# line 226 "tgram.g"
+{id_cnt = -id_cnt;} break;
+case 32:
+# line 229 "tgram.g"
+{
+ install(Str0(yypvt[-0]),idflag,0); id_cnt = 1;
+ } break;
+case 33:
+# line 232 "tgram.g"
+{
+ install(Str0(yypvt[-0]),idflag,0); ++id_cnt;
+ } break;
+case 34:
+# line 236 "tgram.g"
+{;} break;
+case 35:
+# line 237 "tgram.g"
+{;} break;
+case 36:
+# line 239 "tgram.g"
+{idflag = F_Dynamic;} break;
+case 37:
+# line 240 "tgram.g"
+{idflag = F_Static;} break;
+case 38:
+# line 242 "tgram.g"
+{yyval = tree1(N_Empty);} break;
+case 39:
+# line 243 "tgram.g"
+{yyval = yypvt[-1];} break;
+case 40:
+# line 245 "tgram.g"
+{yyval = tree1(N_Empty);} break;
+case 41:
+# line 246 "tgram.g"
+{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 42:
+# line 248 "tgram.g"
+{yyval = tree1(N_Empty);} break;
+case 45:
+# line 252 "tgram.g"
+{yyval = tree5(N_Conj,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 47:
+# line 255 "tgram.g"
+{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 49:
+# line 258 "tgram.g"
+case 50:
+# line 259 "tgram.g"
+case 51:
+# line 260 "tgram.g"
+case 52:
+# line 261 "tgram.g"
+{yyval = tree5(N_Binop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 53:
+# line 262 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 54:
+# line 263 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 55:
+# line 264 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 56:
+# line 265 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 57:
+# line 266 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 58:
+# line 267 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 59:
+# line 268 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 60:
+# line 269 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 61:
+# line 270 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 62:
+# line 271 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 63:
+# line 272 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 64:
+# line 273 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 65:
+# line 274 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 66:
+# line 275 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 67:
+# line 276 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 68:
+# line 277 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 69:
+# line 278 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 70:
+# line 279 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 71:
+# line 280 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 72:
+# line 281 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 73:
+# line 282 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 74:
+# line 283 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 75:
+# line 284 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 76:
+# line 285 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 77:
+# line 286 "tgram.g"
+{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 78:
+# line 287 "tgram.g"
+{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 79:
+# line 288 "tgram.g"
+{yyval = tree5(N_Conj,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 80:
+# line 289 "tgram.g"
+{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],yypvt[-2]);} break;
+case 82:
+# line 292 "tgram.g"
+{yyval = tree4(N_To,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 83:
+# line 293 "tgram.g"
+{yyval = tree5(N_ToBy,yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]);} break;
+case 85:
+# line 296 "tgram.g"
+{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 87:
+# line 299 "tgram.g"
+case 88:
+# line 300 "tgram.g"
+case 89:
+# line 301 "tgram.g"
+case 90:
+# line 302 "tgram.g"
+case 91:
+# line 303 "tgram.g"
+case 92:
+# line 304 "tgram.g"
+case 93:
+# line 305 "tgram.g"
+case 94:
+# line 306 "tgram.g"
+case 95:
+# line 307 "tgram.g"
+case 96:
+# line 308 "tgram.g"
+case 97:
+# line 309 "tgram.g"
+case 98:
+# line 310 "tgram.g"
+case 99:
+# line 311 "tgram.g"
+case 100:
+# line 312 "tgram.g"
+case 102:
+# line 315 "tgram.g"
+case 103:
+# line 316 "tgram.g"
+case 105:
+# line 319 "tgram.g"
+case 106:
+# line 320 "tgram.g"
+case 107:
+# line 321 "tgram.g"
+case 108:
+# line 322 "tgram.g"
+case 110:
+# line 325 "tgram.g"
+case 111:
+# line 326 "tgram.g"
+case 112:
+# line 327 "tgram.g"
+case 113:
+# line 328 "tgram.g"
+case 115:
+# line 331 "tgram.g"
+{yyval = tree5(N_Binop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 117:
+# line 334 "tgram.g"
+{yyval = tree4(N_Limit,yypvt[-2],yypvt[-2],yypvt[-0]);} break;
+case 118:
+# line 335 "tgram.g"
+{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],yypvt[-2]);} break;
+case 119:
+# line 336 "tgram.g"
+{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 121:
+# line 339 "tgram.g"
+{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break;
+case 122:
+# line 340 "tgram.g"
+{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]);} break;
+case 123:
+# line 341 "tgram.g"
+{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]);} break;
+case 124:
+# line 342 "tgram.g"
+{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]);} break;
+case 125:
+# line 343 "tgram.g"
+{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]);} break;
+case 126:
+# line 344 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 127:
+# line 345 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 128:
+# line 346 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 129:
+# line 347 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 130:
+# line 348 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 131:
+# line 349 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 132:
+# line 350 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 133:
+# line 351 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 134:
+# line 352 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 135:
+# line 353 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 136:
+# line 354 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 137:
+# line 355 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 138:
+# line 356 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 139:
+# line 357 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 140:
+# line 358 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 141:
+# line 359 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 142:
+# line 360 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 143:
+# line 361 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 144:
+# line 362 "tgram.g"
+{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 154:
+# line 373 "tgram.g"
+{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]);} break;
+case 155:
+# line 374 "tgram.g"
+{Val0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0);} break;
+case 156:
+# line 375 "tgram.g"
+{yyval = tree2(N_Next,yypvt[-0]);} break;
+case 157:
+# line 376 "tgram.g"
+{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]);} break;
+case 158:
+# line 377 "tgram.g"
+{if ((yypvt[-1])->n_type == N_Elist) yyval = tree4(N_Invok,yypvt[-2],tree1(N_Empty),yypvt[-1]); else yyval = yypvt[-1];} break;
+case 159:
+# line 378 "tgram.g"
+{yyval = yypvt[-1];} break;
+case 160:
+# line 379 "tgram.g"
+{yyval = tree3(N_List,yypvt[-2],yypvt[-1]);} break;
+case 161:
+# line 380 "tgram.g"
+{yyval = buildarray(yypvt[-3],yypvt[-2],yypvt[-1],yypvt[-0]);} break;
+case 162:
+# line 381 "tgram.g"
+{yyval = tree4(N_Invok,yypvt[-1],yypvt[-2], tree3(N_List,yypvt[-1],tree1(N_Empty)));} break;
+case 163:
+# line 382 "tgram.g"
+{yyval = tree4(N_Invok,yypvt[-2],yypvt[-3],tree3(N_List,yypvt[-2],yypvt[-1]));} break;
+case 164:
+# line 383 "tgram.g"
+{yyval = tree4(N_Invok,yypvt[-2],yypvt[-3],yypvt[-1]);} break;
+case 165:
+# line 384 "tgram.g"
+{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 166:
+# line 385 "tgram.g"
+{yyval = c_str_leaf(N_Key,yypvt[-1],"fail");} break;
+case 167:
+# line 386 "tgram.g"
+{if (klookup(Str0(yypvt[-0])) == 0) tfatal("invalid keyword",Str0(yypvt[-0])); yyval = c_str_leaf(N_Key,yypvt[-1],Str0(yypvt[-0]));} break;
+case 168:
+# line 388 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break;
+case 169:
+# line 389 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break;
+case 170:
+# line 391 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break;
+case 171:
+# line 392 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break;
+case 172:
+# line 394 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break;
+case 173:
+# line 395 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break;
+case 174:
+# line 397 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break;
+case 175:
+# line 399 "tgram.g"
+{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty));} break;
+case 176:
+# line 400 "tgram.g"
+{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]);} break;
+case 177:
+# line 401 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break;
+case 178:
+# line 402 "tgram.g"
+{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break;
+case 179:
+# line 404 "tgram.g"
+{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty));} break;
+case 180:
+# line 405 "tgram.g"
+{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]);} break;
+case 181:
+# line 407 "tgram.g"
+{yyval = tree4(N_Case,yypvt[-5],yypvt[-4],yypvt[-1]);} break;
+case 183:
+# line 410 "tgram.g"
+{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 184:
+# line 412 "tgram.g"
+{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 185:
+# line 413 "tgram.g"
+{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 186:
+# line 415 "tgram.g"
+{;} break;
+case 187:
+# line 416 "tgram.g"
+{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+case 188:
+# line 418 "tgram.g"
+{
+ yyval = tree3(N_Create,yypvt[-0],yypvt[-0]);
+ } break;
+case 189:
+# line 421 "tgram.g"
+{
+ yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0]));
+ } break;
+case 190:
+# line 425 "tgram.g"
+{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0);} break;
+case 191:
+# line 426 "tgram.g"
+{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0);} break;
+case 192:
+# line 427 "tgram.g"
+{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0]));} break;
+case 193:
+# line 428 "tgram.g"
+{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0]));} break;
+case 194:
+# line 430 "tgram.g"
+{yyval = tree6(N_Sect,yypvt[-2],yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]);} break;
+case 195:
+# line 432 "tgram.g"
+{yyval = yypvt[-0];} break;
+case 196:
+# line 433 "tgram.g"
+{yyval = yypvt[-0];} break;
+case 197:
+# line 434 "tgram.g"
+{yyval = yypvt[-0];} break;
+case 199:
+# line 437 "tgram.g"
+{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]);} break;
+ }
+ goto yystack; /* reset registers in driver code */
+}
diff --git a/src/icont/tproto.h b/src/icont/tproto.h
new file mode 100644
index 0000000..aaea6c4
--- /dev/null
+++ b/src/icont/tproto.h
@@ -0,0 +1,106 @@
+/*
+ * Prototypes for functions in icont.
+ */
+
+void addinvk (char *name, int n);
+void addlfile (char *name);
+pointer alloc (unsigned int n);
+void alsolink (char *name);
+int blocate (word s);
+struct node *c_str_leaf (int type,struct node *loc_model, char *c);
+void codegen (struct node *t);
+void constout (FILE *fd);
+void dummyda (void);
+struct fentry *flocate (word id);
+struct fileparts *fparse (char *s);
+void gencode (void);
+void gentables (void);
+int getdec (void);
+int getopr (int ac, int *cc);
+word getid (void);
+long getint (int i, word *wp);
+int getlab (void);
+struct lfile *getlfile (struct lfile * *lptr);
+int getoct (void);
+int getopc (char * *id);
+double getreal (void);
+word getrest (void);
+word getstr (void);
+word getstrlit (int l);
+struct gentry *glocate (word id);
+void gout (FILE *fd);
+struct node *i_str_leaf (int type,struct node *loc_model,char *c,int d);
+int ilink (char * *ifiles,char *outname);
+void initglob (void);
+void install (char *name,int flag,int argcnt);
+word instid (char *s);
+struct node *int_leaf (int type,struct node *loc_model,int c);
+int klookup (char *id);
+int lexeql (int l,char *s1,char *s2);
+void lfatal (char *s1,char *s2);
+void linit (void);
+void lmfree (void);
+void loc_init (void);
+void locinit (void);
+void lout (FILE *fd);
+void lwarn (char *s1,char *s2,char *s3);
+char *makename (char *dest,char *d,char *name,char *e);
+void newline (void);
+int nextchar (void);
+void nfatal (struct node *n,char *s1,char *s2);
+void putconst (int n,int flags,int len,word pc, union xval *valp);
+void putfield (word fname,struct gentry *gp,int fnum);
+struct gentry *putglobal (word id,int flags,int nargs, int procid);
+char *putid (int len);
+word putident (int len, int install);
+int putlit (char *id,int idtype,int len);
+int putloc (char *id,int id_type);
+void putlocal (int n,word id,int flags,int imperror,
+ word procname);
+void quit (char *msg);
+void quitf (char *msg,char *arg);
+void readglob (void);
+void report (char *s);
+unsigned int round2 (unsigned int n);
+void rout (FILE *fd,char *name);
+char *salloc (char *s);
+void scanrefs (void);
+void sizearg (char *arg,char * *argv);
+int smatch (char *s,char *t);
+pointer tcalloc (unsigned int m,unsigned int n);
+void tfatal (char *s1,char *s2);
+void tmalloc (void);
+void tmfree (void);
+void tminit (void);
+int trans (char * *ifiles, char *tgtdir);
+pointer trealloc (pointer table, pointer tblfree,
+ unsigned int *size, int unit_size,
+ int min_units, char *tbl_name);
+struct node *tree1 (int type);
+struct node *tree2 (int type,struct node *loc_model);
+struct node *tree3 (int type,struct node *loc_model,struct node *c);
+struct node *tree4 (int type,struct node *loc_model,struct node *c,struct node *d);
+struct node *tree5 (int type,struct node *loc_model,
+ struct node *c,struct node *d,
+ struct node *e);
+struct node *tree6 (int type,struct node *loc_model,
+ struct node *c, struct node *d,
+ struct node *e,struct node *f);
+struct node *buildarray (struct node *a,struct node *lb,
+ struct node *e, struct node *rb);
+void treeinit (void);
+void tsyserr (char *s);
+void writecheck (int rc);
+void yyerror (int tok,struct node *lval,int state);
+int yylex (void);
+int yyparse (void);
+
+#ifdef DeBugTrans
+ void cdump (void);
+ void gdump (void);
+ void ldump (void);
+#endif /* DeBugTrans */
+
+#ifdef DeBugLinker
+ void idump (char *c);
+#endif /* DeBugLinker */
diff --git a/src/icont/trans.c b/src/icont/trans.c
new file mode 100644
index 0000000..c27b1f6
--- /dev/null
+++ b/src/icont/trans.c
@@ -0,0 +1,125 @@
+/*
+ * trans.c - main control of the translation process.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "../h/version.h"
+#include "tglobals.h"
+#include "tsym.h"
+#include "tree.h"
+#include "ttoken.h"
+
+/*
+ * Prototypes.
+ */
+
+static void trans1 (char *filename, char *tgtdir);
+
+int tfatals; /* number of fatal errors in file */
+int afatals; /* total number of fatal errors */
+int nocode; /* non-zero to suppress code generation */
+int in_line; /* current input line number */
+int incol; /* current input column number */
+int peekc; /* one-character look ahead */
+
+/*
+ * translate a number of files, returning an error count
+ */
+int trans(ifiles, tgtdir)
+char **ifiles;
+char *tgtdir;
+ {
+ afatals = 0;
+
+ tmalloc(); /* allocate memory for translation */
+ while (*ifiles) {
+ trans1(*ifiles++, tgtdir); /* translate each file in turn */
+ afatals += tfatals;
+ }
+ tmfree(); /* free memory used for translation */
+
+ /*
+ * Report information about errors and warnings and be correct about it.
+ */
+ if (afatals == 1)
+ report("1 error\n");
+ else if (afatals > 1) {
+ char tmp[12];
+ sprintf(tmp, "%d errors\n", afatals);
+ report(tmp);
+ }
+ else
+ report("No errors\n");
+
+ return afatals;
+ }
+
+/*
+ * translate one file.
+ */
+static void trans1(filename, tgtdir)
+char *filename, *tgtdir;
+{
+ char oname1[MaxPath]; /* buffer for constructing file name */
+ char oname2[MaxPath]; /* buffer for constructing file name */
+
+ tfatals = 0; /* reset error counts */
+ nocode = 0; /* allow code generation */
+ in_line = 1; /* start with line 1, column 0 */
+ incol = 0;
+ peekc = 0; /* clear character lookahead */
+
+ if (!ppinit(filename,lpath,m4pre))
+ quitf("cannot open %s",filename);
+
+ if (strcmp(filename,"-") == 0)
+ filename = "stdin";
+
+ report(filename);
+
+ if (pponly) {
+ ppecho();
+ return;
+ }
+
+ /*
+ * Form names for the .u1 and .u2 files and open them.
+ * Write the ucode version number to the .u2 file.
+ */
+ makename(oname1, tgtdir, filename, U1Suffix);
+ codefile = fopen(oname1, "w");
+ if (codefile == NULL)
+ quitf("cannot create %s", oname1);
+ makename(oname2, tgtdir, filename, U2Suffix);
+ globfile = fopen(oname2, "w");
+ if (globfile == NULL)
+ quitf("cannot create %s", oname2);
+ writecheck(fprintf(globfile,"version\t%s\n",UVersion));
+
+ tok_loc.n_file = filename;
+ in_line = 1;
+
+ tminit(); /* Initialize data structures */
+ yyparse(); /* Parse the input */
+
+ /*
+ * Close the output files.
+ */
+ if (fclose(codefile) != 0 || fclose(globfile) != 0)
+ quit("cannot close ucode file");
+ if (tfatals) {
+ remove(oname1);
+ remove(oname2);
+ }
+ }
+
+/*
+ * writecheck - check the return code from a stdio output operation
+ */
+void writecheck(rc)
+int rc;
+ {
+ if (rc < 0)
+ quit("cannot write to ucode file");
+}
diff --git a/src/icont/trash.icn b/src/icont/trash.icn
new file mode 100644
index 0000000..a94594b
--- /dev/null
+++ b/src/icont/trash.icn
@@ -0,0 +1,35 @@
+#
+# This is an ad-hoc program for removing duplicate code in the main switch
+# statement for binary operators (the optimizer should fold these, if
+# the compiler can get that far).
+#
+# This program relies on the form of parse.c as presently produced; it is
+# fragile and may need modification for other versions of parse.c. Look
+# at your parse.c first to see if the template is correct.
+#
+# The same thing could be done for N_Unop, but if this works, that will not
+# be necesssary.
+
+procedure main()
+ template := "{yyval = tree5(N_Binop"
+ while line := read () do {
+ if not(match(template,line)) then
+ write(line) # copy until "offending member" is found
+ else {
+ lastline := line # save it for last case in group
+ buffer := [] # push-back buffer
+ repeat {
+ put(buffer,read()) # "case ..."
+ put(buffer,read()) # "# line ...
+ line := read()
+ if not match(template,line) then {
+ write(lastline) # if not a duplicate, insert the one instance
+ while write(get(buffer)) # write out lines pushed back
+ write(line) # write the new line
+ break # break back to the main loop (may be more)
+ }
+ else while write(get(buffer)) # else write out lines pushed back
+ }
+ }
+ }
+end
diff --git a/src/icont/tree.c b/src/icont/tree.c
new file mode 100644
index 0000000..535c62a
--- /dev/null
+++ b/src/icont/tree.c
@@ -0,0 +1,175 @@
+/*
+ * tree.c -- functions for constructing parse trees
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "tree.h"
+
+/*
+ * tree[1-6] construct parse tree nodes with specified values.
+ * Parameters a and b are line and column information,
+ * while parameters c through f are values to be assigned to n_field[0-3].
+ * Note that this could be done with a single routine; a separate routine
+ * for each node size is used for speed and simplicity.
+ */
+
+nodeptr tree1(type)
+int type;
+ {
+ register nodeptr t;
+
+ t = NewNode(0);
+ t->n_type = type;
+ return t;
+ }
+
+nodeptr tree2(type, loc_model)
+int type;
+nodeptr loc_model;
+ {
+ register nodeptr t;
+
+ t = NewNode(0);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ return t;
+ }
+
+nodeptr tree3(type, loc_model, c)
+int type;
+nodeptr loc_model;
+nodeptr c;
+ {
+ register nodeptr t;
+
+ t = NewNode(1);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_ptr = c;
+ return t;
+ }
+
+nodeptr tree4(type, loc_model, c, d)
+int type;
+nodeptr loc_model;
+nodeptr c, d;
+ {
+ register nodeptr t;
+
+ t = NewNode(2);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_ptr = c;
+ t->n_field[1].n_ptr = d;
+ return t;
+ }
+
+nodeptr tree5(type, loc_model, c, d, e)
+int type;
+nodeptr loc_model;
+nodeptr c, d, e;
+ {
+ register nodeptr t;
+
+ t = NewNode(3);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_ptr = c;
+ t->n_field[1].n_ptr = d;
+ t->n_field[2].n_ptr = e;
+ return t;
+ }
+
+nodeptr tree6(type, loc_model, c, d, e, f)
+int type;
+nodeptr loc_model;
+nodeptr c, d, e, f;
+ {
+ register nodeptr t;
+
+ t = NewNode(4);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_ptr = c;
+ t->n_field[1].n_ptr = d;
+ t->n_field[2].n_ptr = e;
+ t->n_field[3].n_ptr = f;
+ return t;
+ }
+
+nodeptr buildarray(a,lb,e,rb)
+nodeptr a, lb, e, rb;
+ {
+ register nodeptr t, t2;
+ if (e->n_type == N_Elist) {
+ t2 = int_leaf(lb->n_type, lb, (int)lb->n_field[0].n_val);
+ t = tree5(N_Binop, t2, t2, buildarray(a,lb,e->n_field[0].n_ptr,rb),
+ e->n_field[1].n_ptr);
+ free(e);
+ }
+ else
+ t = tree5(N_Binop, lb, lb, a, e);
+ return t;
+ }
+
+nodeptr int_leaf(type, loc_model, c)
+int type;
+nodeptr loc_model;
+int c;
+ {
+ register nodeptr t;
+
+ t = NewNode(1);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_val = c;
+ return t;
+ }
+
+nodeptr c_str_leaf(type, loc_model, c)
+int type;
+nodeptr loc_model;
+char *c;
+ {
+ register nodeptr t;
+
+ t = NewNode(1);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_str = c;
+ return t;
+ }
+
+nodeptr i_str_leaf(type, loc_model, c, d)
+int type;
+nodeptr loc_model;
+char *c;
+int d;
+ {
+ register nodeptr t;
+
+ t = NewNode(2);
+ t->n_type = type;
+ t->n_file = loc_model->n_file;
+ t->n_line = loc_model->n_line;
+ t->n_col = loc_model->n_col;
+ t->n_field[0].n_str = c;
+ t->n_field[1].n_val = d;
+ return t;
+ }
+
diff --git a/src/icont/tree.h b/src/icont/tree.h
new file mode 100644
index 0000000..7950c81
--- /dev/null
+++ b/src/icont/tree.h
@@ -0,0 +1,109 @@
+/*
+ * Structure of a tree node.
+ */
+
+typedef struct node *nodeptr;
+#define YYSTYPE nodeptr
+
+union field {
+ long n_val; /* integer-valued fields */
+ char *n_str; /* string-valued fields */
+ nodeptr n_ptr; /* subtree pointers */
+ };
+
+struct node {
+ int n_type; /* node type */
+ char *n_file; /* name of file containing source program */
+ int n_line; /* line number in source program */
+ int n_col; /* column number in source program */
+ union field n_field[1]; /* variable-content fields */
+ };
+
+#define NewNode(size) (struct node *)alloc(\
+ (sizeof(struct node) + (size-1) * sizeof(union field)))
+
+/*
+ * Macros to access fields of parse tree nodes.
+ */
+
+#define TType(t) t->n_type
+#define File(t) t->n_file
+#define Line(t) t->n_line
+#define Col(t) t->n_col
+#define Tree0(t) t->n_field[0].n_ptr
+#define Tree1(t) t->n_field[1].n_ptr
+#define Tree2(t) t->n_field[2].n_ptr
+#define Tree3(t) t->n_field[3].n_ptr
+#define Val0(t) t->n_field[0].n_val
+#define Val1(t) t->n_field[1].n_val
+#define Val2(t) t->n_field[2].n_val
+#define Val3(t) t->n_field[3].n_val
+#define Val4(t) t->n_field[4].n_val
+#define Str0(t) t->n_field[0].n_str
+#define Str1(t) t->n_field[1].n_str
+#define Str2(t) t->n_field[2].n_str
+#define Str3(t) t->n_field[3].n_str
+
+/*
+ * External declarations.
+ */
+
+extern nodeptr yylval; /* parser's current token value */
+extern struct node tok_loc; /* "model" token holding current location */
+
+/*
+ * Node types.
+ */
+
+#define N_Activat 1 /* activation control structure */
+#define N_Alt 2 /* alternation operator */
+#define N_Augop 3 /* augmented operator */
+#define N_Bar 4 /* generator control structure */
+#define N_Binop 5 /* other binary operator */
+#define N_Break 6 /* break statement */
+#define N_Case 7 /* case statement */
+#define N_Ccls 8 /* case clause */
+#define N_Clist 9 /* list of case clauses */
+#define N_Conj 10 /* conjunction operator */
+#define N_Create 11 /* create control structure */
+#define N_Cset 12 /* cset literal */
+#define N_Elist 14 /* list of expressions */
+#define N_Empty 15 /* empty expression or statement */
+#define N_Field 16 /* record field reference */
+#define N_Id 17 /* identifier token */
+#define N_If 18 /* if-then-else statement */
+#define N_Int 19 /* integer literal */
+#define N_Invok 20 /* invocation */
+#define N_Key 21 /* keyword */
+#define N_Limit 22 /* LIMIT control structure */
+#define N_List 23 /* [ ... ] style list */
+#define N_Loop 24 /* while, until, every, or repeat */
+#define N_Not 25 /* not prefix control structure */
+#define N_Next 26 /* next statement */
+#define N_Op 27 /* operator token */
+#define N_Proc 28 /* procedure */
+#define N_Real 29 /* real literal */
+#define N_Res 30 /* reserved word token */
+#define N_Ret 31 /* fail, return, or succeed */
+#define N_Scan 32 /* scan-using statement */
+#define N_Sect 33 /* s[i:j] (section) */
+#define N_Slist 34 /* list of statements */
+#define N_Str 35 /* string literal */
+#define N_Susp 36 /* suspend statement */
+#define N_To 37 /* TO operator */
+#define N_ToBy 38 /* TO-BY operator */
+#define N_Unop 39 /* unary operator */
+#define N_Apply 40 /* procedure application */
+
+
+/*
+ * Macros for constructing basic nodes.
+ */
+
+#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b)
+#define IdNode(a) c_str_leaf(N_Id,&tok_loc,a)
+#define IntNode(a) c_str_leaf(N_Int,&tok_loc,a)
+#define OpNode(a) int_leaf(N_Op,&tok_loc,optab[a].tok.t_type)
+#define RealNode(a) c_str_leaf(N_Real,&tok_loc,a)
+#define ResNode(a) int_leaf(N_Res,&tok_loc,a)
+#define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b)
diff --git a/src/icont/tsym.c b/src/icont/tsym.c
new file mode 100644
index 0000000..1d0f16c
--- /dev/null
+++ b/src/icont/tsym.c
@@ -0,0 +1,519 @@
+/*
+ * tsym.c -- functions for symbol table management.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "ttoken.h"
+#include "tsym.h"
+#include "keyword.h"
+#include "lfile.h"
+
+/*
+ * Prototypes.
+ */
+
+static struct tgentry *alcglob
+ (struct tgentry *blink, char *name,int flag,int nargs);
+static struct tcentry *alclit
+ (struct tcentry *blink, char *name, int len,int flag);
+static struct tlentry *alcloc
+ (struct tlentry *blink, char *name,int flag);
+static struct tcentry *clookup (char *id,int flag);
+static struct tgentry *glookup (char *id);
+static struct tlentry *llookup (char *id);
+static void putglob
+ (char *id,int id_type, int n_args);
+
+#ifdef DeBugTrans
+ void cdump (void);
+ void gdump (void);
+ void ldump (void);
+#endif /* DeBugTrans */
+
+
+/*
+ * Keyword table.
+ */
+
+struct keyent {
+ char *keyname;
+ int keyid;
+ };
+
+#define KDef(p,n) Lit(p), n,
+static struct keyent keytab[] = {
+#include "../h/kdefs.h"
+ NULL, -1
+};
+
+/*
+ * loc_init - clear the local and constant symbol tables.
+ */
+
+void loc_init()
+ {
+ struct tlentry *lptr, *lptr1;
+ struct tcentry *cptr, *cptr1;
+ int i;
+
+ /*
+ * Clear local table, freeing entries.
+ */
+ for (i = 0; i < lhsize; i++) {
+ for (lptr = lhash[i]; lptr != NULL; lptr = lptr1) {
+ lptr1 = lptr->l_blink;
+ free((char *)lptr);
+ }
+ lhash[i] = NULL;
+ }
+ lfirst = NULL;
+ llast = NULL;
+
+ /*
+ * Clear constant table, freeing entries.
+ */
+ for (i = 0; i < lchsize; i++) {
+ for (cptr = chash[i]; cptr != NULL; cptr = cptr1) {
+ cptr1 = cptr->c_blink;
+ free((char *)cptr);
+ }
+ chash[i] = NULL;
+ }
+ cfirst = NULL;
+ clast = NULL;
+ }
+
+/*
+ * install - put an identifier into the global or local symbol table.
+ * The basic idea here is to look in the right table and install
+ * the identifier if it isn't already there. Some semantic checks
+ * are performed.
+ */
+void install(name, flag, argcnt)
+char *name;
+int flag, argcnt;
+ {
+ union {
+ struct tgentry *gp;
+ struct tlentry *lp;
+ } p;
+
+ switch (flag) {
+ case F_Global: /* a variable in a global declaration */
+ if ((p.gp = glookup(name)) == NULL)
+ putglob(name, flag, argcnt);
+ else
+ p.gp->g_flag |= flag;
+ break;
+
+ case F_Proc|F_Global: /* procedure declaration */
+ case F_Record|F_Global: /* record declaration */
+ case F_Builtin|F_Global: /* external declaration */
+ if ((p.gp = glookup(name)) == NULL)
+ putglob(name, flag, argcnt);
+ else if ((p.gp->g_flag & (~F_Global)) == 0) { /* superfluous global
+ declaration for
+ record or proc */
+ p.gp->g_flag |= flag;
+ p.gp->g_nargs = argcnt;
+ }
+ else /* the user can't make up his mind */
+ tfatal("inconsistent redeclaration", name);
+ break;
+
+ case F_Static: /* static declaration */
+ case F_Dynamic: /* local declaration (possibly implicit?) */
+ case F_Argument: /* formal parameter */
+ if ((p.lp = llookup(name)) == NULL)
+ putloc(name,flag);
+ else if (p.lp->l_flag == flag) /* previously declared as same type */
+ tfatal("redeclared identifier", name);
+ else /* previously declared as different type */
+ tfatal("inconsistent redeclaration", name);
+ break;
+
+ default:
+ tsyserr("install: unrecognized symbol table flag.");
+ }
+ }
+
+/*
+ * putloc - make a local symbol table entry and return the index
+ * of the entry in lhash. alcloc does the work if there is a collision.
+ */
+int putloc(id,id_type)
+char *id;
+int id_type;
+ {
+ register struct tlentry *ptr;
+
+ if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */
+ ptr = lhash[lhasher(id)];
+ lhash[lhasher(id)] = alcloc(ptr, id, id_type);
+ return lhash[lhasher(id)]->l_index;
+ }
+ return ptr->l_index;
+ }
+
+/*
+ * putglob makes a global symbol table entry. alcglob does the work if there
+ * is a collision.
+ */
+
+static void putglob(id, id_type, n_args)
+char *id;
+int id_type, n_args;
+ {
+ register struct tgentry *ptr;
+
+ if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */
+ ptr = ghash[ghasher(id)];
+ ghash[ghasher(id)] = alcglob(ptr, id, id_type, n_args);
+ }
+ }
+
+/*
+ * putlit makes a constant symbol table entry and returns the table "index"
+ * of the constant. alclit does the work if there is a collision.
+ */
+int putlit(id, idtype, len)
+char *id;
+int len, idtype;
+ {
+ register struct tcentry *ptr;
+
+ if ((ptr = clookup(id,idtype)) == NULL) { /* add to head of hash chain */
+ ptr = chash[chasher(id)];
+ chash[chasher(id)] = alclit(ptr, id, len, idtype);
+ return chash[chasher(id)]->c_index;
+ }
+ return ptr->c_index;
+ }
+
+/*
+ * llookup looks up id in local symbol table and returns pointer to
+ * to it if found or NULL if not present.
+ */
+
+static struct tlentry *llookup(id)
+char *id;
+ {
+ register struct tlentry *ptr;
+
+ ptr = lhash[lhasher(id)];
+ while (ptr != NULL && ptr->l_name != id)
+ ptr = ptr->l_blink;
+ return ptr;
+ }
+
+/*
+ * glookup looks up id in global symbol table and returns pointer to
+ * to it if found or NULL if not present.
+ */
+static struct tgentry *glookup(id)
+char *id;
+ {
+ register struct tgentry *ptr;
+
+ ptr = ghash[ghasher(id)];
+ while (ptr != NULL && ptr->g_name != id) {
+ ptr = ptr->g_blink;
+ }
+ return ptr;
+ }
+
+/*
+ * clookup looks up id in constant symbol table and returns pointer to
+ * to it if found or NULL if not present.
+ */
+static struct tcentry *clookup(id,flag)
+char *id;
+int flag;
+ {
+ register struct tcentry *ptr;
+
+ ptr = chash[chasher(id)];
+ while (ptr != NULL && (ptr->c_name != id || ptr->c_flag != flag))
+ ptr = ptr->c_blink;
+
+ return ptr;
+ }
+
+/*
+ * klookup looks up keyword named by id in keyword table and returns
+ * its number (keyid).
+ */
+int klookup(id)
+register char *id;
+ {
+ register struct keyent *kp;
+
+ for (kp = keytab; kp->keyid >= 0; kp++)
+ if (strcmp(kp->keyname,id) == 0)
+ return (kp->keyid);
+
+ return 0;
+ }
+
+#ifdef DeBugTrans
+/*
+ * ldump displays local symbol table to stdout.
+ */
+
+void ldump()
+ {
+ register int i;
+ register struct tlentry *lptr;
+ int n;
+
+ if (llast == NULL)
+ n = 0;
+ else
+ n = llast->l_index + 1;
+ fprintf(stderr,"Dump of local symbol table (%d entries)\n", n);
+ fprintf(stderr," loc blink id (name) flags\n");
+ for (i = 0; i < lhsize; i++)
+ for (lptr = lhash[i]; lptr != NULL; lptr = lptr->l_blink)
+ fprintf(stderr,"%5d %5d %5d %20s %7o\n", lptr->l_index,
+ lptr->l_blink, lptr->l_name, lptr->l_name, lptr->l_flag);
+ fflush(stderr);
+
+ }
+
+/*
+ * gdump displays global symbol table to stdout.
+ */
+
+void gdump()
+ {
+ register int i;
+ register struct tgentry *gptr;
+ int n;
+
+ if (glast == NULL)
+ n = 0;
+ else
+ n = glast->g_index + 1;
+ fprintf(stderr,"Dump of global symbol table (%d entries)\n", n);
+ fprintf(stderr," loc blink id (name) flags nargs\n");
+ for (i = 0; i < ghsize; i++)
+ for (gptr = ghash[i]; gptr != NULL; gptr = gptr->g_blink)
+ fprintf(stderr,"%5d %5d %5d %20s %7o %8d\n", gptr->g_index,
+ gptr->g_blink, gptr->g_name, gptr->g_name,
+ gptr->g_flag, gptr->g_nargs);
+ fflush(stderr);
+ }
+
+/*
+ * cdump displays constant symbol table to stdout.
+ */
+
+void cdump()
+ {
+ register int i;
+ register struct tcentry *cptr;
+ int n;
+
+ if (clast == NULL)
+ n = 0;
+ else
+ n = clast->c_index + 1;
+ fprintf(stderr,"Dump of constant symbol table (%d entries)\n", n);
+ fprintf(stderr," loc blink id (name) flags\n");
+ for (i = 0; i < lchsize; i++)
+ for (cptr = chash[i]; cptr != NULL; cptr = cptr->c_blink)
+ fprintf(stderr,"%5d %5d %5d %20s %7o\n", cptr->c_index,
+ cptr->c_blink, cptr->c_name, cptr->c_name, cptr->c_flag);
+ fflush(stderr);
+ }
+#endif /* DeBugTrans */
+
+/*
+ * alcloc allocates a local symbol table entry, fills in fields with
+ * specified values and returns the new entry.
+ */
+static struct tlentry *alcloc(blink, name, flag)
+struct tlentry *blink;
+char *name;
+int flag;
+ {
+ register struct tlentry *lp;
+
+ lp = NewStruct(tlentry);
+ lp->l_blink = blink;
+ lp->l_name = name;
+ lp->l_flag = flag;
+ lp->l_next = NULL;
+ if (lfirst == NULL) {
+ lfirst = lp;
+ lp->l_index = 0;
+ }
+ else {
+ llast->l_next = lp;
+ lp->l_index = llast->l_index + 1;
+ }
+ llast = lp;
+ return lp;
+ }
+
+/*
+ * alcglob allocates a global symbol table entry, fills in fields with
+ * specified values and returns offset of new entry.
+ */
+static struct tgentry *alcglob(blink, name, flag, nargs)
+struct tgentry *blink;
+char *name;
+int flag, nargs;
+ {
+ register struct tgentry *gp;
+
+ gp = NewStruct(tgentry);
+ gp->g_blink = blink;
+ gp->g_name = name;
+ gp->g_flag = flag;
+ gp->g_nargs = nargs;
+ gp->g_next = NULL;
+ if (gfirst == NULL) {
+ gfirst = gp;
+ gp->g_index = 0;
+ }
+ else {
+ glast->g_next = gp;
+ gp->g_index = glast->g_index + 1;
+ }
+ glast = gp;
+ return gp;
+ }
+
+/*
+ * alclit allocates a constant symbol table entry, fills in fields with
+ * specified values and returns the new entry.
+ */
+static struct tcentry *alclit(blink, name, len, flag)
+struct tcentry *blink;
+char *name;
+int len, flag;
+ {
+ register struct tcentry *cp;
+
+ cp = NewStruct(tcentry);
+ cp->c_blink = blink;
+ cp->c_name = name;
+ cp->c_length = len;
+ cp->c_flag = flag;
+ cp->c_next = NULL;
+ if (cfirst == NULL) {
+ cfirst = cp;
+ cp->c_index = 0;
+ }
+ else {
+ clast->c_next = cp;
+ cp->c_index = clast->c_index + 1;
+ }
+ clast = cp;
+ return cp;
+ }
+
+/*
+ * lout dumps local symbol table to fd, which is a .u1 file.
+ */
+void lout(fd)
+FILE *fd;
+ {
+ register struct tlentry *lp;
+
+ for (lp = lfirst; lp != NULL; lp = lp->l_next)
+ writecheck(fprintf(fd, "\tlocal\t%d,%06o,%s\n",
+ lp->l_index, lp->l_flag, lp->l_name));
+ }
+
+/*
+ * constout dumps constant symbol table to fd, which is a .u1 file.
+ */
+void constout(fd)
+FILE *fd;
+ {
+ register int l;
+ register char *c;
+ register struct tcentry *cp;
+
+ for (cp = cfirst; cp != NULL; cp = cp->c_next) {
+ writecheck(fprintf(fd, "\tcon\t%d,%06o", cp->c_index, cp->c_flag));
+ if (cp->c_flag & F_IntLit)
+ writecheck(fprintf(fd,",%d,%s\n",(int)strlen(cp->c_name),cp->c_name));
+ else if (cp->c_flag & F_RealLit)
+ writecheck(fprintf(fd, ",%s\n", cp->c_name));
+ else {
+ c = cp->c_name;
+ l = cp->c_length;
+ writecheck(fprintf(fd, ",%d", l));
+ while (l--)
+ writecheck(fprintf(fd, ",%03o", *c++ & 0377));
+ writecheck(putc('\n', fd));
+ }
+ }
+ }
+
+/*
+ * rout dumps a record declaration for name to file fd, which is a .u2 file.
+ */
+void rout(fd,name)
+FILE *fd;
+char *name;
+ {
+ register struct tlentry *lp;
+ int n;
+
+ if (llast == NULL)
+ n = 0;
+ else
+ n = llast->l_index + 1;
+ writecheck(fprintf(fd, "record\t%s,%d\n", name, n));
+ for (lp = lfirst; lp != NULL; lp = lp->l_next)
+ writecheck(fprintf(fd, "\t%d,%s\n", lp->l_index, lp->l_name));
+ }
+
+/*
+ * gout writes various items to fd, which is a .u2 file. These items
+ * include: implicit status, tracing activation, link directives,
+ * invocable directives, and the global table.
+ */
+void gout(fd)
+FILE *fd;
+ {
+ register char *name;
+ register struct tgentry *gp;
+ int n;
+ struct lfile *lfl;
+ struct invkl *ivl;
+
+ if (uwarn)
+ name = "error";
+ else
+ name = "local";
+ writecheck(fprintf(fd, "impl\t%s\n", name));
+ if (trace)
+ writecheck(fprintf(fd, "trace\n"));
+
+ lfl = lfiles;
+ while (lfl) {
+ writecheck(fprintf(fd,"link\t%s.u1\n",lfl->lf_name));
+ lfl = lfl->lf_link;
+ }
+ lfiles = 0;
+
+ for (ivl = invkls; ivl != NULL; ivl = ivl->iv_link)
+ writecheck(fprintf(fd, "invocable\t%s\n", ivl->iv_name));
+ invkls = NULL;
+
+ if (glast == NULL)
+ n = 0;
+ else
+ n = glast->g_index + 1;
+ writecheck(fprintf(fd, "global\t%d\n", n));
+ for (gp = gfirst; gp != NULL; gp = gp->g_next)
+ writecheck(fprintf(fd, "\t%d,%06o,%s,%d\n", gp->g_index, gp->g_flag,
+ gp->g_name, gp->g_nargs));
+ }
diff --git a/src/icont/tsym.h b/src/icont/tsym.h
new file mode 100644
index 0000000..a932345
--- /dev/null
+++ b/src/icont/tsym.h
@@ -0,0 +1,69 @@
+/*
+ * Structures for symbol table entries.
+ */
+
+struct tlentry { /* local table entry */
+ struct tlentry *l_blink; /* link for bucket chain */
+ char *l_name; /* name of variable */
+ int l_flag; /* variable flags */
+ int l_index; /* "index" of local in table */
+ struct tlentry *l_next; /* next local in table */
+ };
+
+struct tgentry { /* global table entry */
+ struct tgentry *g_blink; /* link for bucket chain */
+ char *g_name; /* name of variable */
+ int g_flag; /* variable flags */
+ int g_nargs; /* number of args (procedure) or */
+ int g_index; /* "index" of global in table */
+ struct tgentry *g_next; /* next global in table */
+ }; /* number of fields (record) */
+
+struct tcentry { /* constant table entry */
+ struct tcentry *c_blink; /* link for bucket chain */
+ char *c_name; /* pointer to string */
+ int c_length; /* length of string */
+ int c_flag; /* type of literal flag */
+ int c_index; /* "index" of constant in table */
+ struct tcentry *c_next; /* next constant in table */
+ };
+
+/*
+ * Flag values.
+ */
+
+#define F_Global 01 /* variable declared global externally */
+#define F_Proc 04 /* procedure */
+#define F_Record 010 /* record */
+#define F_Dynamic 020 /* variable declared local dynamic */
+#define F_Static 040 /* variable declared local static */
+#define F_Builtin 0100 /* identifier refers to built-in procedure */
+#define F_ImpError 0400 /* procedure has default error */
+#define F_Argument 01000 /* variable is a formal parameter */
+#define F_IntLit 02000 /* literal is an integer */
+#define F_RealLit 04000 /* literal is a real */
+#define F_StrLit 010000 /* literal is a string */
+#define F_CsetLit 020000 /* literal is a cset */
+
+/*
+ * Symbol table region pointers.
+ */
+
+extern struct tlentry **lhash; /* hash area for local table */
+extern struct tgentry **ghash; /* hash area for global table */
+extern struct tcentry **chash; /* hash area for constant table */
+
+extern struct tlentry *lfirst; /* first local table entry */
+extern struct tlentry *llast; /* last local table entry */
+extern struct tcentry *cfirst; /* first constant table entry */
+extern struct tcentry *clast; /* last constant table entry */
+extern struct tgentry *gfirst; /* first global table entry */
+extern struct tgentry *glast; /* last global table entry */
+
+/*
+ * Hash functions for symbol tables.
+ */
+
+#define ghasher(x) (((word)x)&gmask) /* global symbol table */
+#define lhasher(x) (((word)x)&lmask) /* local symbol table */
+#define chasher(x) (((word)x)&cmask) /* constant symbol table */
diff --git a/src/icont/ttoken.h b/src/icont/ttoken.h
new file mode 100644
index 0000000..1e95e98
--- /dev/null
+++ b/src/icont/ttoken.h
@@ -0,0 +1,111 @@
+# define IDENT 257
+# define INTLIT 258
+# define REALLIT 259
+# define STRINGLIT 260
+# define CSETLIT 261
+# define EOFX 262
+# define BREAK 263
+# define BY 264
+# define CASE 265
+# define CREATE 266
+# define DEFAULT 267
+# define DO 268
+# define ELSE 269
+# define END 270
+# define EVERY 271
+# define FAIL 272
+# define GLOBAL 273
+# define IF 274
+# define INITIAL 275
+# define INVOCABLE 276
+# define LINK 277
+# define LOCAL 278
+# define NEXT 279
+# define NOT 280
+# define OF 281
+# define PROCEDURE 282
+# define RECORD 283
+# define REPEAT 284
+# define RETURN 285
+# define STATIC 286
+# define SUSPEND 287
+# define THEN 288
+# define TO 289
+# define UNTIL 290
+# define WHILE 291
+# define BANG 292
+# define MOD 293
+# define AUGMOD 294
+# define AND 295
+# define AUGAND 296
+# define STAR 297
+# define AUGSTAR 298
+# define INTER 299
+# define AUGINTER 300
+# define PLUS 301
+# define AUGPLUS 302
+# define UNION 303
+# define AUGUNION 304
+# define MINUS 305
+# define AUGMINUS 306
+# define DIFF 307
+# define AUGDIFF 308
+# define DOT 309
+# define SLASH 310
+# define AUGSLASH 311
+# define ASSIGN 312
+# define SWAP 313
+# define NMLT 314
+# define AUGNMLT 315
+# define REVASSIGN 316
+# define REVSWAP 317
+# define SLT 318
+# define AUGSLT 319
+# define SLE 320
+# define AUGSLE 321
+# define NMLE 322
+# define AUGNMLE 323
+# define NMEQ 324
+# define AUGNMEQ 325
+# define SEQ 326
+# define AUGSEQ 327
+# define EQUIV 328
+# define AUGEQUIV 329
+# define NMGT 330
+# define AUGNMGT 331
+# define NMGE 332
+# define AUGNMGE 333
+# define SGT 334
+# define AUGSGT 335
+# define SGE 336
+# define AUGSGE 337
+# define QMARK 338
+# define AUGQMARK 339
+# define AT 340
+# define AUGAT 341
+# define BACKSLASH 342
+# define CARET 343
+# define AUGCARET 344
+# define BAR 345
+# define CONCAT 346
+# define AUGCONCAT 347
+# define LCONCAT 348
+# define AUGLCONCAT 349
+# define TILDE 350
+# define NMNE 351
+# define AUGNMNE 352
+# define SNE 353
+# define AUGSNE 354
+# define NEQUIV 355
+# define AUGNEQUIV 356
+# define LPAREN 357
+# define RPAREN 358
+# define PCOLON 359
+# define COMMA 360
+# define MCOLON 361
+# define COLON 362
+# define SEMICOL 363
+# define LBRACK 364
+# define RBRACK 365
+# define LBRACE 366
+# define RBRACE 367
diff --git a/src/icont/tunix.c b/src/icont/tunix.c
new file mode 100644
index 0000000..9478403
--- /dev/null
+++ b/src/icont/tunix.c
@@ -0,0 +1,420 @@
+/*
+ * tunix.c - user interface for Unix.
+ */
+
+#include "../h/gsupport.h"
+#include "../h/version.h"
+#include "tproto.h"
+#include "tglobals.h"
+
+static void execute (char *ofile, char *efile, char *args[]);
+static void usage (void);
+static char *libpath (char *prog, char *envname);
+
+static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]);
+static char *copyfile(FILE *f, char *srcfile);
+static char *savefile(FILE *f, char *srcprog);
+static void cleanup(void);
+
+static char **rfiles; /* list of files removed by cleanup() */
+
+/*
+ * for old method of hardwiring iconx path; not normally used.
+ */
+static char patchpath[MaxPath+18] = "%PatchStringHere->";
+
+/*
+ * getopt() variables
+ */
+extern int optind; /* index into parent argv vector */
+extern int optopt; /* character checked for validity */
+extern char *optarg; /* argument associated with option */
+
+/*
+ * main program
+ */
+int main(int argc, char *argv[]) {
+ int nolink = 0; /* suppress linking? */
+ int errors = 0; /* translator and linker errors */
+ char **tfiles, **tptr; /* list of files to translate */
+ char **lfiles, **lptr; /* list of files to link */
+ char **rptr; /* list of files to remove */
+ char *efile = NULL; /* stderr file */
+ char buf[MaxPath]; /* file name construction buffer */
+ int c, n;
+ char ch;
+ struct fileparts *fp;
+
+ /*
+ * Initialize globals.
+ */
+ initglob(); /* general global initialization */
+ ipath = libpath(argv[0], "IPATH"); /* set library search paths */
+ lpath = libpath(argv[0], "LPATH");
+ if (strlen(patchpath) > 18)
+ iconxloc = patchpath + 18; /* use stated iconx path if patched */
+ else
+ iconxloc = relfile(argv[0], "/../iconx"); /* otherwise infer it */
+
+ /*
+ * Process options.
+ * IMPORTANT: When making changes here,
+ * also update usage() function and man page.
+ */
+ while ((c = getopt(argc, argv, "+ce:f:o:stuv:ELNP:VX:")) != EOF)
+ switch (c) {
+ case 'c': /* -c: compile only (no linking) */
+ nolink = 1;
+ break;
+ case 'e': /* -e file: [undoc] redirect stderr */
+ efile = optarg;
+ break;
+ case 'f': /* -f features: enable features */
+ if (strchr(optarg, 's') || strchr(optarg, 'a'))
+ strinv = 1; /* this is the only icont feature */
+ break;
+ case 'o': /* -o file: name output file */
+ ofile = optarg;
+ break;
+ case 's': /* -s: suppress informative messages */
+ silent = 1;
+ verbose = 0;
+ break;
+ case 't': /* -t: turn on procedure tracing */
+ trace = -1;
+ break;
+ case 'u': /* -u: warn about undeclared ids */
+ uwarn = 1;
+ break;
+ case 'v': /* -v n: set verbosity level */
+ if (sscanf(optarg, "%d%c", &verbose, &ch) != 1)
+ quitf("bad operand to -v option: %s", optarg);
+ if (verbose == 0)
+ silent = 1;
+ break;
+ case 'E': /* -E: preprocess only */
+ pponly = 1;
+ nolink = 1;
+ break;
+ case 'P': /* -P program: execute from argument */
+ txrun(savefile, optarg, &argv[optind]);
+ break; /*NOTREACHED*/
+ case 'N': /* -N: don't embed iconx path */
+ iconxloc = "";
+ break;
+ case 'V': /* -V: print version information */
+ fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__);
+ if (optind == argc)
+ exit(0);
+ break;
+ case 'X': /* -X srcfile: execute single srcfile */
+ txrun(copyfile, optarg, &argv[optind]);
+ break; /*NOTREACHED*/
+
+ #ifdef DeBugLinker
+ case 'L': /* -L: enable linker debugging */
+ Dflag = 1;
+ break;
+ #endif /* DeBugLinker */
+
+ default:
+ case 'x': /* -x illegal until after file list */
+ usage();
+ }
+
+ /*
+ * If argv[0] ends in "icon" (instead of "icont" or anything else),
+ * process as "icon [options] sourcefile [arguments]" scripting shortcut.
+ */
+ n = strlen(argv[0]);
+ if (n >= 4 && strcmp(argv[0]+n-4, "icon") == 0) {
+ if (optind < argc)
+ txrun(copyfile, argv[optind], &argv[optind+1]);
+ else
+ usage();
+ }
+
+ /*
+ * Allocate space for lists of file names.
+ */
+ n = argc - optind + 1;
+ tptr = tfiles = alloc(n * sizeof(char *));
+ lptr = lfiles = alloc(n * sizeof(char *));
+ rptr = rfiles = alloc(2 * n * sizeof(char *));
+
+ /*
+ * Scan file name arguments.
+ */
+ while (optind < argc) {
+ if (strcmp(argv[optind], "-x") == 0) /* stop at -x */
+ break;
+ else if (strcmp(argv[optind], "-") == 0) {
+ *tptr++ = "-"; /* "-" means standard input */
+ *lptr++ = *rptr++ = "stdin.u1";
+ *rptr++ = "stdin.u2";
+ }
+ else {
+ fp = fparse(argv[optind]); /* parse file name */
+ if (*fp->ext == '\0' || smatch(fp->ext, SourceSuffix)) {
+ makename(buf, SourceDir, argv[optind], SourceSuffix);
+ *tptr++ = salloc(buf); /* translate the .icn file */
+ makename(buf, TargetDir, argv[optind], U1Suffix);
+ *lptr++ = *rptr++ = salloc(buf); /* link & remove .u1 */
+ makename(buf, TargetDir, argv[optind], U2Suffix);
+ *rptr++ = salloc(buf); /* also remove .u2 */
+ }
+ else if (smatch(fp->ext, U1Suffix) || smatch(fp->ext, U2Suffix)
+ || smatch(fp->ext, USuffix)) {
+ makename(buf, TargetDir, argv[optind], U1Suffix);
+ *lptr++ = salloc(buf);
+ }
+ else
+ quitf("bad argument %s", argv[optind]);
+ }
+ optind++;
+ }
+
+ *tptr = *lptr = *rptr = NULL; /* terminate filename lists */
+ if (lptr == lfiles)
+ usage(); /* error -- no files named */
+
+ /*
+ * Translate .icn files to make .u1 and .u2 files.
+ */
+ if (tptr > tfiles) {
+ if (!pponly)
+ report("Translating");
+ errors = trans(tfiles, TargetDir);
+ if (errors > 0) /* exit if errors seen */
+ exit(EXIT_FAILURE);
+ }
+
+ /*
+ * Link .u1 and .u2 files to make an executable.
+ */
+ if (nolink) /* exit if no linking wanted */
+ exit(EXIT_SUCCESS);
+
+ if (ofile == NULL) { /* if no -o file, synthesize a name */
+ ofile = salloc(makename(buf, TargetDir, lfiles[0], IcodeSuffix));
+ }
+ else { /* add extension in necessary */
+ fp = fparse(ofile);
+ if (*fp->ext == '\0' && *IcodeSuffix != '\0') /* if no ext given */
+ ofile = salloc(makename(buf, NULL, ofile, IcodeSuffix));
+ }
+
+ report("Linking");
+ errors = ilink(lfiles, ofile); /* link .u files to make icode file */
+
+ /*
+ * Finish by removing intermediate files.
+ * Execute the linked program if so requested and if there were no errors.
+ */
+ cleanup(); /* delete intermediate files */
+ if (errors > 0) { /* exit if linker errors seen */
+ remove(ofile);
+ exit(EXIT_FAILURE);
+ }
+ if (optind < argc) {
+ report("Executing");
+ execute (ofile, efile, argv + optind + 1);
+ }
+ exit(EXIT_SUCCESS);
+ return 0;
+ }
+
+/*
+ * execute - execute iconx to run the icon program
+ */
+static void execute(char *ofile, char *efile, char *args[]) {
+ int n;
+ char **argv, **p;
+ char buf[MaxPath+10];
+
+ /*
+ * Build argument vector.
+ */
+ for (n = 0; args[n] != NULL; n++) /* count arguments */
+ ;
+ p = argv = alloc((n + 5) * sizeof(char *));
+
+ *p++ = ofile; /* pass icode file name */
+ while ((*p++ = *args++) != 0) /* copy args into argument vector */
+ ;
+ *p = NULL;
+
+ /*
+ * Redirect stderr if requested.
+ */
+ if (efile != NULL) {
+ close(fileno(stderr));
+ if (strcmp(efile, "-") == 0)
+ dup(fileno(stdout));
+ else if (freopen(efile, "w", stderr) == NULL)
+ quitf("could not redirect stderr to %s\n", efile);
+ }
+
+ /*
+ * Export $ICONX to specify the path to iconx.
+ */
+ sprintf(buf, "ICONX=%s", iconxloc);
+ putenv(buf);
+
+ /*
+ * Execute the generated program.
+ */
+ execv(ofile, argv);
+ quitf("could not execute %s", ofile);
+ }
+
+void report(char *s) {
+ char *c = (strchr(s, '\n') ? "" : ":\n") ;
+ if (!silent)
+ fprintf(stderr, "%s%s", s, c);
+ }
+
+/*
+ * Print a usage message and abort the run.
+ */
+static void usage(void) {
+ fprintf(stderr, "usage: icon sourcefile [args]\n");
+ fprintf(stderr, " icon -P 'program' [args]\n");
+ fprintf(stderr, " icont %s\n",
+ "[-cstuENV] [-f s] [-o ofile] [-v i] file ... [-x args]");
+ exit(EXIT_FAILURE);
+ }
+
+/*
+ * Return path after appending lib directory.
+ */
+static char *libpath(char *prog, char *envname) {
+ char buf[1000], *s;
+
+ s = getenv(envname);
+ if (s != NULL)
+ #if CYGWIN
+ cygwin_win32_to_posix_path_list(s, buf);
+ #else /* CYGWIN */
+ strcpy(buf, s);
+ #endif /* CYGWIN */
+ else
+ strcpy(buf, ".");
+ strcat(buf, ":");
+ strcat(buf, relfile(prog, "/../../lib"));
+ return salloc(buf);
+ }
+
+/*
+ * Translate, link, and execute a source file.
+ * Does not return under any circumstances.
+ */
+static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]) {
+ int omask;
+ char c1, c2;
+ char *flist[2], *progname;
+ char srcfile[MaxPath], u1[MaxPath], u2[MaxPath];
+ char icode[MaxPath], buf[MaxPath + 20];
+ static char abet[] = "abcdefghijklmnopqrstuvwxyz";
+ FILE *f;
+
+ silent = 1; /* don't issue commentary while translating */
+ uwarn = 1; /* do diagnose undeclared identifiers */
+ omask = umask(0077); /* remember umask; keep /tmp files private */
+
+ /*
+ * Invent a file named /tmp/innnnnxx.icn.
+ */
+ srand(time(NULL));
+ c1 = abet[rand() % (sizeof(abet) - 1)];
+ c2 = abet[rand() % (sizeof(abet) - 1)];
+ sprintf(srcfile, "/tmp/i%d%c%c.icn", getpid(), c1, c2);
+
+ /*
+ * Copy the source code to the temporary file.
+ */
+ f = fopen(srcfile, "w");
+ if (f == NULL)
+ quitf("cannot open for writing: %s", srcfile);
+ progname = func(f, source);
+ fclose(f);
+
+ /*
+ * Derive other names and arrange for cleanup on exit.
+ */
+ rfiles = alloc(5 * sizeof(char *));
+ rfiles[0] = srcfile;
+ makename(rfiles[1] = u1, NULL, srcfile, U1Suffix);
+ makename(rfiles[2] = u2, NULL, srcfile, U2Suffix);
+ makename(rfiles[3] = icode, NULL, srcfile, IcodeSuffix);
+ rfiles[4] = NULL;
+ atexit(cleanup);
+
+ /*
+ * Translate to produce .u1 and .u2 files.
+ */
+ flist[0] = srcfile;
+ flist[1] = NULL;
+ if (trans(flist, SourceDir) > 0)
+ exit(EXIT_FAILURE);
+
+ /*
+ * Link to make an icode file.
+ */
+ flist[0] = u1;
+ if (ilink(flist, icode) > 0)
+ exit(EXIT_FAILURE);
+
+ /*
+ * Execute the icode file.
+ */
+ rfiles[3] = NULL; /* don't delete icode yet */
+ cleanup(); /* but delete the others */
+ sprintf(buf, "ICODE_TEMP=%s:%s", icode, progname);
+ putenv(buf); /* tell iconx to delete icode */
+ umask(omask); /* reset original umask */
+ execute(icode, NULL, args); /* execute the program */
+ quitf("could not execute %s", icode);
+ }
+
+/*
+ * Dump a string to a file, prefixed by $line 0 "[inline]".
+ */
+static char *savefile(FILE *f, char *srcprog) {
+ static char *progname = "[inline]";
+ fprintf(f, "$line 0 \"%s\"\n", progname);
+ fwrite(srcprog, 1, strlen(srcprog), f);
+ return progname;
+ }
+
+/*
+ * Copy a source file for later translation, adding $line 0 "filename".
+ */
+static char *copyfile(FILE *f, char *srcfile) {
+ int c;
+ FILE *e;
+
+ if (strcmp(srcfile, "-") == 0) {
+ e = stdin;
+ srcfile = "stdin";
+ }
+ else {
+ if ((e = fopen(srcfile, "r")) == NULL)
+ quitf("cannot open: %s", srcfile);
+ }
+ fprintf(f, "$line 0 \"%s\"\n", srcfile);
+ while ((c = getc(e)) != EOF)
+ putc(c, f);
+ fclose(e);
+ return srcfile;
+ }
+
+/*
+ * Deletes the files listed in rfiles[].
+ */
+static void cleanup(void) {
+ char **p;
+
+ for (p = rfiles; *p; p++)
+ remove(*p);
+ }
diff --git a/src/icont/util.c b/src/icont/util.c
new file mode 100644
index 0000000..3a54901
--- /dev/null
+++ b/src/icont/util.c
@@ -0,0 +1,93 @@
+/*
+ * util.c -- general utility functions.
+ */
+
+#include "../h/gsupport.h"
+#include "tproto.h"
+#include "tglobals.h"
+#include "tree.h"
+
+extern int optind;
+extern char *ofile;
+
+/*
+ * Information about Icon functions.
+ */
+
+/*
+ * Names of Icon functions.
+ */
+char *ftable[] = {
+#define FncDef(p,n) Lit(p),
+#define FncDefV(p) Lit(p),
+#include "../h/fdefs.h"
+#undef FncDef
+#undef FncDefV
+ };
+
+int ftbsize = sizeof(ftable) / sizeof(char *);
+
+/*
+ * tcalloc - allocate and zero m*n bytes
+ */
+pointer tcalloc(m, n)
+unsigned int m, n;
+ {
+ pointer a;
+
+ if ((a = calloc(m, n)) == 0)
+ quit("out of memory");
+ return a;
+ }
+
+/*
+ * trealloc - realloc a table making it half again larger and zero the
+ * new part of the table.
+ */
+pointer trealloc(table, tblfree, size, unit_size, min_units, tbl_name)
+pointer table; /* table to be realloc()ed */
+pointer tblfree; /* reference to table free pointer if there is one */
+unsigned int *size; /* size of table */
+int unit_size; /* number of bytes in a unit of the table */
+int min_units; /* the minimum number of units that must be allocated. */
+char *tbl_name; /* name of the table */
+ {
+ word new_size;
+ word num_bytes;
+ word free_offset;
+ word i;
+ char *new_tbl;
+
+ new_size = (*size * 3) / 2;
+ if (new_size - *size < min_units)
+ new_size = *size + min_units;
+ num_bytes = new_size * unit_size;
+
+ if (tblfree != NULL)
+ free_offset = DiffPtrs(*(char **)tblfree, (char *)table);
+
+ if ((new_tbl = realloc(table, (unsigned)num_bytes)) == 0)
+ quitf("out of memory for %s", tbl_name);
+
+ for (i = *size * unit_size; i < num_bytes; ++i)
+ new_tbl[i] = 0;
+
+ *size = new_size;
+ if (tblfree != NULL)
+ *(char **)tblfree = (char *)(new_tbl + free_offset);
+
+ return (pointer)new_tbl;
+ }
+
+
+/*
+ * round2 - round an integer up to the next power of 2.
+ */
+unsigned int round2(n)
+unsigned int n;
+ {
+ unsigned int b = 1;
+ while (b < n)
+ b <<= 1;
+ return b;
+ }
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-03 18:30:57 +0000