diff options
Diffstat (limited to 'src/icont')
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; + } |