summaryrefslogtreecommitdiff
path: root/src/common
diff options
context:
space:
mode:
Diffstat (limited to 'src/common')
-rw-r--r--src/common/Makefile91
-rw-r--r--src/common/alloc.c65
-rw-r--r--src/common/dlrgint.c252
-rw-r--r--src/common/doincl.c77
-rw-r--r--src/common/error.h179
-rw-r--r--src/common/filepart.c218
-rw-r--r--src/common/fixgram.icn48
-rw-r--r--src/common/getopt.c57
-rw-r--r--src/common/icontype.h55
-rw-r--r--src/common/identify.c30
-rw-r--r--src/common/infer.c33
-rw-r--r--src/common/ipp.c971
-rw-r--r--src/common/lextab.h576
-rw-r--r--src/common/literals.c180
-rw-r--r--src/common/long.c34
-rw-r--r--src/common/mktoktab.icn507
-rw-r--r--src/common/munix.c258
-rw-r--r--src/common/op.txt61
-rw-r--r--src/common/patchstr.c189
-rw-r--r--src/common/pscript.icn44
-rw-r--r--src/common/rtdb.c1692
-rw-r--r--src/common/strtbl.c207
-rw-r--r--src/common/time.c34
-rw-r--r--src/common/tokens.txt76
-rw-r--r--src/common/typespec.icn482
-rw-r--r--src/common/typespec.txt87
-rw-r--r--src/common/xwindow.c159
-rw-r--r--src/common/yacctok.h125
-rw-r--r--src/common/yylex.h624
29 files changed, 7411 insertions, 0 deletions
diff --git a/src/common/Makefile b/src/common/Makefile
new file mode 100644
index 0000000..bb5546a
--- /dev/null
+++ b/src/common/Makefile
@@ -0,0 +1,91 @@
+include ../../Makedefs
+
+
+OBJS = long.o getopt.o time.o filepart.o identify.o strtbl.o rtdb.o\
+ munix.o literals.o rswitch.o alloc.o long.o getopt.o time.o\
+ xwindow.o dlrgint.o ipp.o
+
+common: doincl $(OBJS) gpxmaybe
+
+doincl: doincl.c ../h/arch.h
+ $(CC) $(CFLAGS) -o doincl doincl.c
+ -./doincl -o ../../bin/rt.h ../h/rt.h
+
+patchstr: patchstr.c
+ $(CC) $(CFLAGS) -o patchstr patchstr.c
+
+gpxmaybe:
+ -if [ "x$(XL)" != "x" ]; then $(MAKE) $(GDIR); fi
+
+xpm:
+ cd ../xpm; $(MAKE) libXpm.a
+ cp -p ../xpm/libXpm.a ../../bin/libIgpx.a
+
+wincap:
+ cd ../wincap; $(MAKE) libWincap.a
+ cp -u ../wincap/libWincap.a ../../bin/libIgpx.a
+
+$(OBJS): ../h/define.h ../h/arch.h ../h/config.h ../h/cstructs.h \
+ ../h/typedefs.h ../h/mproto.h ../h/cpuconf.h
+
+../h/arch.h: infer.c
+ $(CC) $(CFLAGS) -o infer infer.c
+ ./infer >../h/arch.h
+
+identify.o: ../h/version.h
+
+ipp.o: ../h/features.h
+
+literals.o: ../h/esctab.h
+
+rtdb.o: ../h/version.h icontype.h
+
+dlrgint.o: ../h/rproto.h ../h/rexterns.h ../h/rmacros.h ../h/rstructs.h
+
+xwindow.o: ../h/graphics.h ../h/xwin.h
+
+# for rswitch, $(CFLAGS) is deliberately omitted (-O may cause problems)
+rswitch.o: ../h/define.h ../h/arch.h $(RSW)
+ $(CC) -c $(RSW)
+
+
+# The following section is needed if changes are made to the Icon grammar,
+# but it is not run as part of the normal installation process. If it is
+# needed, it is run by changing ../icont/Makefile and/or ../iconc/Makefile;
+# see the comments there for details. icont must be in the search path
+# for this section to work.
+
+gfiles: lextab.h yacctok.h fixgram pscript
+
+lextab.h yacctok.h: tokens.txt op.txt mktoktab
+ ./mktoktab
+
+mktoktab: mktoktab.icn
+ icont -s mktoktab.icn
+
+fixgram: fixgram.icn
+ icont -s fixgram.icn
+
+pscript: pscript.icn
+ icont -s pscript.icn
+
+
+
+# The following section is commented out because it does not need to be
+# performed unless changes are made to typespec.txt. Such changes
+# 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 section would be attempted.
+#
+# Note that if any changes are made to the file mentioned above, the
+# comment characters at the beginning of the following lines should be
+# removed.
+#
+# Note that icont must be on your search path for this.
+#
+#
+#icontype.h: typespec.txt typespec
+# typespec <typespec.txt >icontype.h
+#
+#typespec: typespec.icn
+# icont typespec
diff --git a/src/common/alloc.c b/src/common/alloc.c
new file mode 100644
index 0000000..7a048b1
--- /dev/null
+++ b/src/common/alloc.c
@@ -0,0 +1,65 @@
+/*
+ * alloc.c -- allocation routines for the Icon compiler
+ */
+
+#include "../h/gsupport.h"
+
+#ifdef TypTrc
+ int typealloc = 0; /* type allocation switch */
+ long typespace = 0; /* type allocation amount */
+#endif /* TypTrc */
+
+/*
+ * salloc - allocate and initialize string
+ */
+
+char *salloc(s)
+char *s;
+ {
+ register char *s1;
+
+ s1 = (char *)malloc(strlen(s) + 1);
+ if (s1 == NULL) {
+ fprintf(stderr, "salloc(%d): out of memory\n", (int)strlen(s) + 1);
+ exit(EXIT_FAILURE);
+ }
+ return strcpy(s1, s);
+ }
+
+/*
+ * alloc - allocate n bytes
+ */
+
+pointer alloc(n)
+unsigned int n;
+ {
+ register pointer a;
+
+#ifdef AllocTrace
+ static int sum = 0;
+#endif /* AllocTrace */
+
+#ifdef TypTrc
+ if (typealloc)
+ typespace += (long)n;
+#endif /* TypTrc */
+
+#ifdef AllocTrace
+ sum = sum + n;
+ if (sum > 5000) {
+ fprintf(stderr, ".");
+ fflush(stderr);
+ sum = 0;
+ };
+#endif /* AllocTrace */
+
+ if (n == 0) /* Work-around for 0 allocation */
+ n = 1;
+
+ a = calloc(n, sizeof(char));
+ if (a == NULL) {
+ fprintf(stderr, "alloc(%d): out of memory\n", (int)n);
+ exit(EXIT_FAILURE);
+ }
+ return a;
+ }
diff --git a/src/common/dlrgint.c b/src/common/dlrgint.c
new file mode 100644
index 0000000..3ca79d1
--- /dev/null
+++ b/src/common/dlrgint.c
@@ -0,0 +1,252 @@
+/*
+ * dlrgint.c - versions of "large integer" routines for compiled programs
+ * that do not support large integers.
+ */
+#define COMPILER 1
+#include "../h/rt.h"
+
+/*
+ *****************************************************************
+ *
+ * Routines in the first set are only called when large integers
+ * exist and thus these versions will never be called. They need
+ * only have the correct signature and compile without error.
+ */
+
+/*
+ * bignum -> file
+ */
+void bigprint(f, da)
+FILE *f;
+dptr da;
+ {
+ }
+
+/*
+ * bignum -> real
+ */
+double bigtoreal(da)
+dptr da;
+ {
+ return 0.0;
+ }
+
+/*
+ * bignum -> string
+ */
+int bigtos(da, dx)
+dptr da, dx;
+ {
+ return 0;
+ }
+
+/*
+ * da -> dx
+ */
+int cpbignum(da, dx)
+dptr da, dx;
+ {
+ return 0;
+ }
+
+/*
+ * da / db -> dx
+ */
+int bigdiv(da, db, dx)
+dptr da, db, dx;
+ {
+ return 0;
+ }
+
+/*
+ * da % db -> dx
+ */
+int bigmod(da, db, dx)
+dptr da, db, dx;
+ {
+ return 0;
+ }
+
+/*
+ * iand(da, db) -> dx
+ */
+int bigand(da, db, dx)
+dptr da, db, dx;
+ {
+ return 0;
+ }
+
+/*
+ * ior(da, db) -> dx
+ */
+int bigor(da, db, dx)
+dptr da, db, dx;
+ {
+ return 0;
+ }
+
+/*
+ * xor(da, db) -> dx
+ */
+int bigxor(da, db, dx)
+dptr da, db, dx;
+ {
+ return 0;
+ }
+
+/*
+ * negative if da < db
+ * zero if da == db
+ * positive if da > db
+ */
+word bigcmp(da, db)
+dptr da, db;
+ {
+ return (word)0;
+ }
+
+/*
+ * ?da -> dx
+ */
+int bigrand(da, dx)
+dptr da, dx;
+ {
+ return 0;
+ }
+
+/*
+ *************************************************************
+ *
+ * The following routines are called when overflow has occurred
+ * during ordinary arithmetic.
+ */
+
+/*
+ * da + db -> dx
+ */
+int bigadd(da, db, dx)
+dptr da, db;
+dptr dx;
+ {
+ t_errornumber = 203;
+ t_errorvalue = nulldesc;
+ t_have_val = 0;
+ return Error;
+ }
+
+/*
+ * da * db -> dx
+ */
+int bigmul(da, db, dx)
+dptr da, db, dx;
+ {
+ t_errornumber = 203;
+ t_errorvalue = nulldesc;
+ t_have_val = 0;
+ return Error;
+ }
+
+/*
+ * -i -> dx
+ */
+int bigneg(da, dx)
+dptr da, dx;
+ {
+ t_errornumber = 203;
+ t_errorvalue = nulldesc;
+ t_have_val = 0;
+ return Error;
+ }
+
+/*
+ * da - db -> dx
+ */
+int bigsub(da, db, dx)
+dptr da, db, dx;
+ {
+ t_errornumber = 203;
+ t_errorvalue = nulldesc;
+ t_have_val = 0;
+ return Error;
+ }
+
+/*
+ * ********************************************************
+ *
+ * The remaining routines each requires different handling.
+ */
+
+/*
+ * real -> bignum
+ */
+int realtobig(da, dx)
+dptr da, dx;
+ {
+ return Failed; /* conversion cannot be done */
+ }
+
+/*
+ * da ^ db -> dx
+ */
+int bigpow(da, db, dx)
+dptr da, db, dx;
+ {
+ C_integer r;
+ extern int over_flow;
+
+ /*
+ * Just do ordinary interger exponentiation and check for overflow.
+ */
+ r = iipow(IntVal(*da), IntVal(*db));
+ if (over_flow) {
+ k_errornumber = 203;
+ k_errortext = "";
+ k_errorvalue = nulldesc;
+ have_errval = 0;
+ return Error;
+ }
+ MakeInt(r, dx);
+ return Succeeded;
+ }
+
+/*
+ * string -> bignum
+ */
+word bigradix(sign, r, s, end_s, result)
+int sign; /* '-' or not */
+int r; /* radix 2 .. 36 */
+char *s, *end_s; /* input string */
+union numeric *result; /* output T_Integer or T_Lrgint */
+ {
+ /*
+ * Just do string to ordinary integer.
+ */
+ return radix(sign, r, s, end_s, result);
+ }
+
+/*
+ * bigshift(da, db) -> dx
+ */
+int bigshift(da, db, dx)
+dptr da, db, dx;
+ {
+ uword ci; /* shift in 0s, even if negative */
+ C_integer cj;
+
+ /*
+ * Do an ordinary shift - note that db is always positive when this
+ * routine is called.
+ */
+ ci = (uword)IntVal(*da);
+ cj = IntVal(*db);
+ /*
+ * Check for a shift of WordSize or greater; return an explicit 0 because
+ * this is beyond C's defined behavior. Otherwise shift as requested.
+ */
+ if (cj >= WordBits)
+ ci = 0;
+ else
+ ci <<= cj;
+ MakeInt(ci, dx);
+ return Succeeded;
+ }
diff --git a/src/common/doincl.c b/src/common/doincl.c
new file mode 100644
index 0000000..8f80c87
--- /dev/null
+++ b/src/common/doincl.c
@@ -0,0 +1,77 @@
+/*
+ * doincl.c -- expand include directives (recursively)
+ *
+ * Usage: doinclude [-o outfile] filename...
+ *
+ * Doinclude copies a C source file, expanding non-system include directives.
+ * For each line of the form
+ * #include "filename"
+ * the named file is interpolated; all other lines are copied verbatim.
+ *
+ * No error is generated if a file cannot be opened.
+ */
+
+#include "../h/rt.h"
+
+void doinclude (char *fname);
+
+#define MAXLINE 500 /* maximum line length */
+
+FILE *outfile; /* output file */
+
+int main(argc, argv)
+int argc;
+char *argv[];
+ {
+ char *progname = argv[0];
+
+ outfile = stdout;
+ if (argc > 3 && strcmp(argv[1], "-o") == 0) {
+ if ((outfile = fopen(argv[2], "w")) != NULL) {
+ argv += 2;
+ argc -= 2;
+ }
+ else {
+ perror(argv[2]);
+ exit(1);
+ }
+ }
+ if (argc < 2) {
+ fprintf(stderr, "usage: %s [-o outfile] filename...\n", progname);
+ exit(1);
+ }
+
+ fprintf(outfile,
+ "/***** do not edit -- this file was generated mechanically *****/\n\n");
+ while (--argc > 0)
+ doinclude(*++argv);
+ exit(0);
+ /*NOTREACHED*/
+ }
+
+void doinclude(fname)
+char *fname;
+ {
+ FILE *f;
+ char line[MAXLINE], newname[MAXLINE], *p;
+
+ fprintf(outfile, "\n\n/****************************************");
+ fprintf(outfile, " from %s: */\n\n", fname);
+ if ((f = fopen(fname, "r")) != NULL) {
+ while (fgets(line, MAXLINE, f))
+ if (sscanf(line, " # include \"%s\"", newname) == 1) {
+ for (p = newname; *p != '\0' && *p != '"'; p++)
+ ;
+ *p = '\0'; /* strip off trailing '"' */
+ doinclude(newname); /* include file */
+ }
+ else
+ fputs(line, outfile); /* not an include directive */
+ fclose(f);
+ }
+ else {
+ fprintf(outfile, "/* [file not found] */\n");
+ }
+ fprintf(outfile, "\n/****************************************");
+ fprintf(outfile, " end %s */\n", fname);
+ }
diff --git a/src/common/error.h b/src/common/error.h
new file mode 100644
index 0000000..0c5cb83
--- /dev/null
+++ b/src/common/error.h
@@ -0,0 +1,179 @@
+/*
+ * error.h -- routines for producing error messages.
+ *
+ * This source file contains the routines for issuing error messages.
+ * It is built by inclusion in ../icont/tlex.c and ../iconc/clex.c,
+ * with slight variations depending on whether "Iconc" is defined.
+ */
+
+/*
+ * Prototype.
+ */
+
+static char *mapterm (int typ,struct node *val);
+
+/*
+ * yyerror produces syntax error messages. tok is the offending token
+ * (yychar), lval is yylval, and state is the parser's state.
+ *
+ * errtab is searched for the state, if it is found, the associated
+ * message is produced; if the state isn't found, "syntax error"
+ * is produced.
+ */
+void yyerror(tok, lval, state)
+int tok, state;
+nodeptr lval;
+ {
+ register struct errmsg *p;
+ int line;
+
+ if (lval == NULL)
+ line = 0;
+ else
+ line = Line(lval);
+
+ if (tok_loc.n_file)
+ fprintf(stderr, "File %s; ", tok_loc.n_file);
+ if (tok == EOFX) /* special case end of file */
+ fprintf(stderr, "unexpected end of file\n");
+ else {
+ fprintf(stderr, "Line %d # ", line);
+ if (Col(lval))
+ fprintf(stderr, "\"%s\": ", mapterm(tok,lval));
+ for (p = errtab; p->e_state != state && p->e_state >= 0; p++) ;
+ fprintf(stderr, "%s\n", p->e_mesg);
+ }
+ tfatals++;
+ nocode++;
+ }
+
+/*
+ * mapterm finds a printable string for the given token type
+ * and value.
+ */
+static char *mapterm(typ,val)
+int typ;
+nodeptr val;
+ {
+ register struct toktab *t;
+ register struct optab *ot;
+ register int i;
+
+ i = typ;
+ if (i == IDENT || i == INTLIT || i == REALLIT || i == STRINGLIT ||
+ i == CSETLIT)
+ return Str0(val);
+ for (t = toktab; t->t_type != 0; t++)
+ if (t->t_type == i)
+ return t->t_word;
+ for (ot = optab; ot->tok.t_type != 0; ot++)
+ if (ot->tok.t_type == i)
+ return ot->tok.t_word;
+ return "???";
+ }
+
+/*
+ * tfatal produces the translator error messages s1 and s2 (if nonnull). The
+ * location of the error is found in tok_loc.
+ */
+void tfatal(s1, s2)
+char *s1, *s2;
+ {
+
+ if (tok_loc.n_file)
+ fprintf(stderr, "File %s; ", tok_loc.n_file);
+ fprintf(stderr, "Line %d # ", tok_loc.n_line);
+ if (s2)
+ fprintf(stderr, "\"%s\": ", s2);
+ fprintf(stderr, "%s\n", s1);
+ tfatals++;
+ nocode++;
+ }
+
+/*
+ * nfatal produces the error messages s1 and s2 (if nonnull), and associates
+ * it with source location of node.
+ */
+void nfatal(n, s1, s2)
+nodeptr n;
+char *s1, *s2;
+ {
+
+ if (n != NULL) {
+ fprintf(stderr, "File %s; ", File(n));
+ fprintf(stderr, "Line %d # ", Line(n));
+ }
+ if (s2)
+ fprintf(stderr, "\"%s\": ", s2);
+ fprintf(stderr, "%s\n", s1);
+ tfatals++;
+ nocode++;
+ }
+
+#ifdef Iconc
+/*
+ * twarn produces s1 and s2 (if nonnull) as translator warning messages.
+ * The location of the error is found in tok_loc.
+ */
+void twarn(s1, s2)
+char *s1, *s2;
+ {
+
+ if (tok_loc.n_file)
+ fprintf(stderr, "File %s; ", tok_loc.n_file);
+ fprintf(stderr, "Line %d # ", tok_loc.n_line);
+ if (s2)
+ fprintf(stderr, "\"%s\": ", s2);
+ fprintf(stderr, "%s\n", s1);
+ twarns++;
+ }
+#endif /* Iconc */
+
+/*
+ * tsyserr is called for fatal errors. The message s is produced and the
+ * translator exits.
+ */
+void tsyserr(s)
+char *s;
+ {
+
+
+ if (tok_loc.n_file)
+ fprintf(stderr, "File %s; ", tok_loc.n_file);
+ fprintf(stderr, "Line %d # %s\n", in_line, s);
+
+ exit(EXIT_FAILURE);
+ }
+
+/*
+ * quit - immediate exit with error message
+ */
+
+void quit(msg)
+char *msg;
+ {
+ quitf(msg,"");
+ }
+
+/*
+ * quitf - immediate exit with message format and argument
+ */
+void quitf(msg,arg)
+char *msg, *arg;
+ {
+ extern char *progname;
+
+ fprintf(stderr,"%s: ",progname);
+ fprintf(stderr,msg,arg);
+ fprintf(stderr,"\n");
+
+ #if !defined(Iconc)
+ {
+ extern char *ofile;
+ if (ofile)
+ remove(ofile); /* remove bad icode file */
+ }
+ #endif /* !Iconc */
+
+ exit(EXIT_FAILURE);
+ }
diff --git a/src/common/filepart.c b/src/common/filepart.c
new file mode 100644
index 0000000..ab8049a
--- /dev/null
+++ b/src/common/filepart.c
@@ -0,0 +1,218 @@
+/*
+ * This file contains pathfind(), fparse(), makename(), and smatch().
+ */
+#include "../h/gsupport.h"
+
+static char *pathelem (char *s, char *buf);
+static char *tryfile (char *buf, char *dir, char *name, char *extn);
+
+/*
+ * Define symbols for building file names.
+ * 1. Prefix: the characters that terminate a file name prefix
+ * 2. FileSep: the char to insert after a dir name, if any
+ * 3. DefPath: the default IPATH/LPATH
+ * 4. PathSep: allowable IPATH/LPATH separators
+ *
+ * All platforms use POSIX forms of file paths.
+ * MS Windows implementations canonize local forms before parsing.
+ */
+
+#define Prefix "/"
+#define FileSep '/'
+#define PathSep " :"
+#define DefPath ""
+
+/*
+ * pathfind(buf,path,name,extn) -- find file in path and return name.
+ *
+ * pathfind looks for a file on a path, begining with the current
+ * directory. Details vary by platform, but the general idea is
+ * that the file must be a readable simple text file. pathfind
+ * returns buf if it finds a file or NULL if not.
+ *
+ * buf[MaxPath] is a buffer in which to put the constructed file name.
+ * path is the IPATH or LPATH value, or NULL if unset.
+ * name is the file name.
+ * extn is the file extension (.icn or .u1) to be appended, or NULL if none.
+ */
+char *pathfind(buf, path, name, extn)
+char *buf, *path, *name, *extn;
+ {
+ char *s;
+ char pbuf[MaxPath];
+
+ if (tryfile(buf, (char *)NULL, name, extn)) /* try curr directory first */
+ return buf;
+ if (!path) /* if no path, use default */
+ path = DefPath;
+
+ #if CYGWIN
+ s = alloca(cygwin_win32_to_posix_path_list_buf_size(path));
+ cygwin_win32_to_posix_path_list(path, s);
+ #else /* CYGWIN */
+ s = path;
+ #endif /* CYGWIN */
+
+ while ((s = pathelem(s, pbuf)) != 0) /* for each path element */
+ if (tryfile(buf, pbuf, name, extn)) /* look for file */
+ return buf;
+ return NULL; /* return NULL if no file found */
+ }
+
+/*
+ * pathelem(s,buf) -- copy next path element from s to buf.
+ *
+ * Returns the updated pointer s.
+ */
+static char *pathelem(s, buf)
+char *s, *buf;
+ {
+ char c;
+
+ while ((c = *s) != '\0' && strchr(PathSep, c))
+ s++;
+ if (!*s)
+ return NULL;
+ while ((c = *s) != '\0' && !strchr(PathSep, c)) {
+ *buf++ = c;
+ s++;
+ }
+
+ #ifdef FileSep
+ /*
+ * We have to append a path separator here.
+ * Seems like makename should really be the one to do that.
+ */
+ if (!strchr(Prefix, buf[-1])) { /* if separator not already there */
+ *buf++ = FileSep;
+ }
+ #endif /* FileSep */
+
+ *buf = '\0';
+ return s;
+ }
+
+/*
+ * tryfile(buf, dir, name, extn) -- check to see if file is readable.
+ *
+ * The file name is constructed in buf from dir + name + extn.
+ * findfile returns buf if successful or NULL if not.
+ */
+static char *tryfile(buf, dir, name, extn)
+char *buf, *dir, *name, *extn;
+ {
+ FILE *f;
+ makename(buf, dir, name, extn);
+ if ((f = fopen(buf, "r")) != NULL) {
+ fclose(f);
+ return buf;
+ }
+ else
+ return NULL;
+ }
+
+/*
+ * fparse - break a file name down into component parts.
+ * Result is a pointer to a struct of static pointers good until the next call.
+ */
+struct fileparts *fparse(s)
+char *s;
+ {
+ static char buf[MaxPath+2];
+ static struct fileparts fp;
+ int n;
+ char *p, *q;
+
+ #if CYGWIN
+ char posix_s[_POSIX_PATH_MAX + 1];
+ cygwin_conv_to_posix_path(s, posix_s);
+ s = posix_s;
+ #endif /* CYGWIN */
+
+ q = s;
+ fp.ext = p = s + strlen(s);
+ while (--p >= s) {
+ if (*p == '.' && *fp.ext == '\0')
+ fp.ext = p;
+ else if (strchr(Prefix,*p)) {
+ q = p+1;
+ break;
+ }
+ }
+
+ fp.dir = buf;
+ n = q - s;
+ strncpy(fp.dir,s,n);
+ fp.dir[n] = '\0';
+ fp.name = buf + n + 1;
+ n = fp.ext - q;
+ strncpy(fp.name,q,n);
+ fp.name[n] = '\0';
+ p = fp.ext;
+ fp.ext = fp.name + n + 1;
+ strcpy(fp.ext, p);
+
+ return &fp;
+ }
+
+/*
+ * makename - make a file name, optionally substituting a new dir and/or ext
+ */
+char *makename(dest,d,name,e)
+char *dest, *d, *name, *e;
+ {
+ struct fileparts fp;
+ fp = *fparse(name);
+ if (d != NULL)
+ fp.dir = d;
+ if (e != NULL)
+ fp.ext = e;
+ sprintf(dest,"%s%s%s",fp.dir,fp.name,fp.ext);
+ return dest;
+ }
+
+/*
+ * smatch - case-insensitive string match - returns nonzero if they match
+ */
+int smatch(s,t)
+char *s, *t;
+ {
+ char a, b;
+ for (;;) {
+ while (*s == *t)
+ if (*s++ == '\0')
+ return 1;
+ else
+ t++;
+ a = *s++;
+ b = *t++;
+ if (isupper(a)) a = tolower(a);
+ if (isupper(b)) b = tolower(b);
+ if (a != b)
+ return 0;
+ }
+ }
+
+#if MSWIN
+
+FILE *pathOpen(fname, mode)
+ char *fname;
+ char *mode;
+ {
+ char buf[MaxPath];
+ int i;
+
+ for (i = 0; fname[i] != '\0'; i++) {
+ if (fname[i] == '/' || fname[i] == ':' || fname[i] == '\\') {
+ /* fname contains an explicit path */
+ return fopen(fname, mode);
+ }
+ }
+
+ if (!pathfind(buf, getenv("PATH"), fname, NULL))
+ return 0;
+
+ return fopen(buf, mode);
+ }
+
+#endif /* MSWIN */
diff --git a/src/common/fixgram.icn b/src/common/fixgram.icn
new file mode 100644
index 0000000..8d55b4d
--- /dev/null
+++ b/src/common/fixgram.icn
@@ -0,0 +1,48 @@
+# fix grammar after it has been put through the C preprosesor
+#
+# allow at most 3 blank lines in a row
+# change /*#...*/ to #...
+# remove lines begining with #
+# remove some of the extra tabs introduced by macro definitions and insert
+# some newlines
+
+procedure main()
+ local s,n
+
+ write("/*")
+ write(" * W A R N I N G:")
+ write(" *")
+ write(" * this file has been preprocessed")
+ write(" * any changes must be made to the original file")
+ write(" */")
+ write()
+
+ n := 0
+ while s := read() do {
+ while s == "" do {
+ if (n +:= 1) <= 3 then write()
+ s := read() | break
+ }
+ s ? (="/*#" & write("#",tab(find("*/"))) & (n := 0)) |
+ ="#" |
+ (fix_tabs() & (n := 0))
+ }
+end
+
+procedure fix_tabs()
+ if ="\t\t\t" then {
+ tab(many('\t'))
+ writes("\t\t")
+ }
+ while writes(tab(upto('{\t'))) do
+ if writes(="{") then
+ tab(many(' \t'))
+ else if ="\t\t\t" then {
+ writes("\n\t\t")
+ tab(many('\t'))
+ }
+ else
+ writes(tab(many('\t')))
+ write(tab(0))
+ return
+end
diff --git a/src/common/getopt.c b/src/common/getopt.c
new file mode 100644
index 0000000..9b02f12
--- /dev/null
+++ b/src/common/getopt.c
@@ -0,0 +1,57 @@
+/*
+ * getopt.c -- get command-line options.
+ */
+
+#include "../h/gsupport.h"
+
+#ifndef SysOpt
+extern char* progname;
+
+/*
+ * Based on a public domain implementation of System V
+ * getopt(3) by Keith Bostic (keith@seismo), Aug 24, 1984.
+ */
+
+#define BadCh (int)'?'
+#define EMSG ""
+#define tell(m) fprintf(stderr,"%s: %s -- %c\n",progname,m,optopt);return BadCh;
+
+int optind = 1; /* index into parent argv vector */
+int optopt; /* character checked for validity */
+char *optarg; /* argument associated with option */
+
+int getopt(int nargc, char *const nargv[], const char *ostr)
+ {
+ static char *place = EMSG; /* option letter processing */
+ register char *oli; /* option letter list index */
+
+ if(!*place) { /* update scanning pointer */
+ if(optind >= nargc || *(place = nargv[optind]) != '-' || !*++place)
+ return EOF;
+ if (*place == '-') { /* found "--" */
+ ++optind;
+ return EOF;
+ }
+ } /* option letter okay? */
+
+ if (((optopt=(int)*place++) == (int)':') || (oli=strchr(ostr,optopt)) == 0) {
+ if(!*place) ++optind;
+ tell("illegal option");
+ }
+ if (*++oli != ':') { /* don't need argument */
+ optarg = NULL;
+ if (!*place) ++optind;
+ }
+ else { /* need an argument */
+ if (*place) optarg = place; /* no white space */
+ else if (nargc <= ++optind) { /* no arg */
+ place = EMSG;
+ tell("option requires an argument");
+ }
+ else optarg = nargv[optind]; /* white space */
+ place = EMSG;
+ ++optind;
+ }
+ return optopt; /* dump back option letter */
+ }
+#endif /* SysOpt */
diff --git a/src/common/icontype.h b/src/common/icontype.h
new file mode 100644
index 0000000..38a1d70
--- /dev/null
+++ b/src/common/icontype.h
@@ -0,0 +1,55 @@
+/*
+ * This file was generated by the program typespec.
+ */
+
+int str_typ = 0;
+int int_typ = 1;
+int rec_typ = 2;
+int proc_typ = 3;
+int coexp_typ = 4;
+int stv_typ = 5;
+int ttv_typ = 6;
+int null_typ = 7;
+int cset_typ = 8;
+int real_typ = 9;
+int list_typ = 10;
+int tbl_typ = 11;
+
+int num_typs = 20;
+struct icon_type icontypes[20] = {
+ {"string", 0, DrfNone, TRetSpcl, NULL, 0, 0, "s", "String"},
+ {"integer", 0, DrfNone, TRetNone, NULL, 0, 0, "i", "Integer"},
+ {"record", 0, DrfNone, TRetBlkP, NULL, 0, 0, "R", "Record"},
+ {"proc", 0, DrfNone, TRetBlkP, NULL, 0, 0, "proc", "Proc"},
+ {"coexpr", 0, DrfNone, TRetBlkP, NULL, 0, 0, "C", "Coexpr"},
+ {"tvsubs", 1, DrfSpcl, TRetSpcl, NULL, 1, 0, "sstv", "Tvsubs"},
+ {"tvtbl", 1, DrfSpcl, TRetBlkP, NULL, 1, 1, "tetv", "Tvtbl"},
+ {"null", 0, DrfNone, TRetNone, NULL, 0, 0, "n", "Null"},
+ {"cset", 0, DrfNone, TRetBlkP, NULL, 0, 0, "c", "Cset"},
+ {"real", 0, DrfNone, TRetBlkP, NULL, 0, 0, "r", "Real"},
+ {"list", 1, DrfNone, TRetBlkP, NULL, 1, 2, "L", "List"},
+ {"table", 1, DrfNone, TRetBlkP, NULL, 3, 3, "T", "Table"},
+ {"file", 0, DrfNone, TRetBlkP, NULL, 0, 0, "f", "File"},
+ {"set", 1, DrfNone, TRetBlkP, NULL, 1, 6, "S", "Set"},
+ {"kywdint", 0, DrfCnst, TRetDescP, ".i..................", 0, 0, "kywdint", "Kywdint"},
+ {"kywdsubj", 0, DrfCnst, TRetDescP, "s...................", 0, 0, "kywdsubj", "Kywdsubj"},
+ {"kywdpos", 0, DrfCnst, TRetDescP, ".i..................", 0, 0, "kywdpos", "Kywdpos"},
+ {"kywdevent", 0, DrfCnst, TRetDescP, "siRpC..ncrLTfS......", 0, 0, "kywdevent", "Kywdevent"},
+ {"kywdwin", 0, DrfCnst, TRetDescP, ".......n....f.......", 0, 0, "kywdwin", "Kywdwin"},
+ {"kywdstr", 0, DrfCnst, TRetDescP, "s...................", 0, 0, "kywdstr", "Kywdstr"}};
+
+int str_var = 0;
+int trpd_tbl = 1;
+int lst_elem = 2;
+int tbl_dflt = 5;
+int tbl_val = 4;
+
+int num_cmpnts = 7;
+struct typ_compnt typecompnt[7] = {
+ {"str_var", 0, 0, 5, NULL},
+ {"trpd_tbl", 0, 0, 6, NULL},
+ {"lst_elem", 0, 1, 10, "LE"},
+ {"tbl_key", 0, 0, 11, NULL},
+ {"tbl_val", 1, 1, 11, "TV"},
+ {"tbl_dflt", 2, 0, 11, NULL},
+ {"set_elem", 0, 0, 13, NULL}};
diff --git a/src/common/identify.c b/src/common/identify.c
new file mode 100644
index 0000000..a1b7038
--- /dev/null
+++ b/src/common/identify.c
@@ -0,0 +1,30 @@
+#include "../h/gsupport.h"
+
+#undef COMPILER
+#define COMPILER 1 /* insure compiler Version number */
+#include "../h/version.h"
+
+extern char *progname;
+
+/*
+ * id_comment - output a comment C identifying the date and time and what
+ * program is producing the output.
+ */
+void id_comment(f)
+FILE *f;
+ {
+ static char sbuf[26];
+ static int first_time = 1;
+ time_t ct;
+
+ if (first_time) {
+ time(&ct);
+ strcpy(sbuf, ctime(&ct));
+ first_time = 0;
+ }
+ fprintf(f, "/*\n");
+ fprintf(f, " * %s", sbuf);
+ fprintf(f, " * This file was produced by\n");
+ fprintf(f, " * %s: %s\n", progname, Version);
+ fprintf(f, " */\n");
+ }
diff --git a/src/common/infer.c b/src/common/infer.c
new file mode 100644
index 0000000..819bf8b
--- /dev/null
+++ b/src/common/infer.c
@@ -0,0 +1,33 @@
+/*
+ * infer.c -- generate definitions reflecting present hardware architecture
+ *
+ * Inspired by mail from Christian Hudon.
+ */
+
+#include <assert.h>
+#include <stddef.h>
+#include <stdio.h>
+
+typedef struct {
+ char c;
+ double d;
+ } tstruct;
+
+static long atdepth(int n) {
+ return n <= 1 ? (long)&n : atdepth(n - 1);
+ }
+
+int main(int argc, char *argv[]) {
+ assert (-1 == (signed char)0xFF); /* chars must be 8 bits */
+ assert (sizeof(void*) == sizeof(long)); /* these must be the same */
+ assert (sizeof(int) >= 4); /* need 32-bit ints or better */
+ assert (sizeof(long) <= 8); /* but can't handle over 64 */
+ printf("/* generated by infer.c */\n");
+ printf("#define IntBits %d\n", 8 * sizeof(int));
+ printf("#define WordBits %d\n", 8 * sizeof(void *));
+ if (offsetof(tstruct, d) > sizeof(void *))
+ printf("#define Double\n");
+ if (atdepth(2) > atdepth(1))
+ printf("#define UpStack\n");
+ return 0;
+ }
diff --git a/src/common/ipp.c b/src/common/ipp.c
new file mode 100644
index 0000000..8913ee5
--- /dev/null
+++ b/src/common/ipp.c
@@ -0,0 +1,971 @@
+/*
+ * ipp.c -- the Icon preprocessor.
+ *
+ * All Icon source passes through here before translation or compilation.
+ * Directives recognized are:
+ * #line n [filename]
+ * $line n [filename]
+ * $include filename
+ * $define identifier text
+ * $undef identifier
+ * $ifdef identifier
+ * $ifndef identifier
+ * $else
+ * $endif
+ * $error [text]
+ *
+ * Entry points are
+ * ppinit(fname,inclpath,m4flag) -- open input file
+ * ppdef(s,v) -- "$define s v", or "$undef s" if v is a null pointer
+ * ppch() -- return next preprocessed character
+ * ppecho() -- preprocess to stdout (for icont/iconc -E)
+ *
+ * See ../h/features.h for the set of predefined symbols.
+ */
+
+#include "../h/gsupport.h"
+
+#define HTBINS 256 /* number of hash bins */
+
+typedef struct fstruct { /* input file structure */
+ struct fstruct *prev; /* previous file */
+ char *fname; /* file name */
+ long lno; /* line number */
+ FILE *fp; /* stdio file pointer */
+ int m4flag; /* nz if preprocessed by m4 */
+ int ifdepth; /* $if nesting depth when opened */
+ } infile;
+
+typedef struct bstruct { /* buffer pointer structure */
+ struct bstruct *prev; /* previous pointer structure */
+ struct cd *defn; /* definition being processed */
+ char *ptr; /* saved pointer value */
+ char *stop; /* saved stop value */
+ char *lim; /* saved limit value */
+ } buffer;
+
+typedef struct { /* preprocessor token structure */
+ char *addr; /* beginning of token */
+ short len; /* length */
+ } ptok;
+
+typedef struct cd { /* structure holding a definition */
+ struct cd *next; /* link to next defn */
+ struct cd *prev; /* link to previous defn */
+ short nlen, vlen; /* length of name & val */
+ char inuse; /* nonzero if curr being expanded */
+ char s[1]; /* name then value, as needed, no \0 */
+ } cdefn;
+
+static int ppopen (char *fname, int m4);
+static FILE * m4pipe (char *fname);
+static char * rline (FILE *fp);
+static void pushdef (cdefn *d);
+static void pushline (char *fname, long lno);
+static void ppdir (char *line);
+static void pfatal (char *s1, char *s2);
+static void skipcode (int doelse, int report);
+static char * define (char *s);
+static char * undef (char *s);
+static char * ifdef (char *s);
+static char * ifndef (char *s);
+static char * ifxdef (char *s, int f);
+static char * elsedir (char *s);
+static char * endif (char *s);
+static char * errdir (char *s);
+static char * include (char *s);
+static char * setline (char *s);
+static char * wskip (char *s);
+static char * nskip (char *s);
+static char * matchq (char *s);
+static char * getidt (char *dst, char *src);
+static char * getfnm (char *dst, char *src);
+static cdefn * dlookup (char *name, int len, char *val);
+
+struct ppcmd {
+ char *name;
+ char *(*func)();
+ }
+pplist[] = {
+ { "define", define },
+ { "undef", undef },
+ { "ifdef", ifdef },
+ { "ifndef", ifndef },
+ { "else", elsedir },
+ { "endif", endif },
+ { "include", include },
+ { "line", setline },
+ { "error", errdir },
+ { 0, 0 }};
+
+static infile nofile; /* ancestor of all files; all zero */
+static infile *curfile; /* pointer to current entry */
+
+static buffer *bstack; /* stack of pending buffers */
+static buffer *bfree; /* pool of free bstructs */
+
+static char *buf; /* input line buffer */
+static char *bnxt; /* next character */
+static char *bstop; /* limit of preprocessed chars */
+static char *blim; /* limit of all chars */
+
+static cdefn *cbin[HTBINS]; /* hash bins for defn table */
+
+static char *lpath; /* LPATH for finding source files */
+
+static int ifdepth; /* depth of $if nesting */
+
+extern int tfatals, nocode; /* provided by icont, iconc */
+
+/*
+ * ppinit(fname, inclpath, m4) -- initialize preprocessor to read from fname.
+ *
+ * Returns 1 if successful, 0 if open failed.
+ */
+int ppinit(fname, inclpath, m4)
+char *fname;
+char *inclpath;
+int m4;
+ {
+ int i;
+ cdefn *d, *n;
+
+ /*
+ * clear out any existing definitions from previous files
+ */
+ for (i = 0; i < HTBINS; i++) {
+ for (d = cbin[i]; d != NULL; d = n) {
+ n = d->next;
+ free((char *)d);
+ }
+ cbin[i] = NULL;
+ }
+
+ /*
+ * install predefined symbols
+ */
+#define Feature(guard,symname,kwval) dlookup(symname, -1, "1");
+#include "../h/features.h"
+
+ /*
+ * initialize variables and open source file
+ */
+ lpath = inclpath;
+ curfile = &nofile; /* init file struct pointer */
+ return ppopen(fname, m4); /* open main source file */
+ }
+
+/*
+ * ppopen(fname, m4) -- open a new file for reading by the preprocessor.
+ *
+ * Returns 1 if successful, 0 if open failed.
+ *
+ * Open calls may be nested. Files are closed when EOF is read.
+ */
+static int ppopen(fname, m4)
+char *fname;
+int m4;
+ {
+ FILE *f;
+ infile *fs;
+
+ for (fs = curfile; fs->fname != NULL; fs = fs->prev)
+ if (strcmp(fname, fs->fname) == 0) {
+ pfatal("circular include", fname); /* issue error message */
+ return 1; /* treat as success */
+ }
+ if (m4)
+ f = m4pipe(fname);
+ else if (curfile == &nofile && strcmp(fname, "-") == 0) { /* 1st file only */
+ f = stdin;
+ fname = "stdin";
+ }
+ else
+ f = fopen(fname, "r");
+ if (f == NULL) {
+ return 0;
+ }
+ fs = alloc(sizeof(infile));
+ fs->prev = curfile;
+ fs->fp = f;
+ fs->fname = salloc(fname);
+ fs->lno = 0;
+ fs->m4flag = m4;
+ fs->ifdepth = ifdepth;
+ pushline(fs->fname, 0L);
+ curfile = fs;
+ return 1;
+ }
+
+/*
+ * m4pipe -- open a pipe from m4.
+ */
+static FILE *m4pipe(filename)
+char *filename;
+ {
+ FILE *f;
+ char *s = alloc(4 + strlen(filename));
+ sprintf(s, "m4 %s", filename);
+ f = popen(s, "r");
+ free(s);
+ return f;
+ }
+
+/*
+ * ppdef(s,v) -- define/undefine a symbol
+ *
+ * If v is a null pointer, undefines symbol s.
+ * Otherwise, defines s to have the value v.
+ * No error is given for a redefinition.
+ */
+void ppdef(s, v)
+char *s, *v;
+ {
+ dlookup(s, -1, (char *)NULL);
+ if (v != NULL)
+ dlookup(s, -1, v);
+ }
+
+/*
+ * ppecho() -- run input through preprocessor and echo directly to stdout.
+ */
+void ppecho()
+ {
+ int c;
+
+ while ((c = ppch()) != EOF)
+ putchar(c);
+ }
+
+/*
+ * ppch() -- get preprocessed character.
+ */
+int ppch()
+ {
+ int c, f;
+ char *p;
+ buffer *b;
+ cdefn *d;
+ infile *fs;
+
+ for (;;) {
+ if (bnxt < bstop) /* if characters ready to go */
+ return ((int)*bnxt++) & 0xFF; /* return first one */
+
+ if (bnxt < blim) {
+ /*
+ * There are characters in the buffer, but they haven't been
+ * checked for substitutions yet. Process either one id, if
+ * that's what's next, or as much else as we can.
+ */
+ f = *bnxt;
+ if (isalpha(f) || f == '_') {
+ /*
+ * This is the first character of an identifier. It could
+ * be the name of a definition. If so, the name will be
+ * contiguous in this buffer. Check it.
+ */
+ p = bnxt + 1;
+ while (p < blim && (isalnum(c = *p) || c == '_')) /* find end */
+ p++;
+ bstop = p; /* safe to consume through end */
+ if (((d = dlookup(bnxt, p-bnxt, bnxt)) == 0) || (d->inuse == 1)) {
+ bnxt++;
+ return f; /* not defined; just use it */
+ }
+ /*
+ * We got a match. Remove the token from the input stream and
+ * push the replacement value.
+ */
+ bnxt = p;
+ pushdef(d); /* make defn the curr buffer */
+ continue; /* loop to preprocess */
+ }
+ else {
+ /*
+ * Not an id. Find the end of non-id stuff and mark it as
+ * having been preprocessed. This is where we skip over
+ * string and cset literals to avoid processing them.
+ */
+ p = bnxt++;
+ while (p < blim) {
+ c = *p;
+ if (isalpha(c) || c == '_') { /* there's an id ahead */
+ bstop = p;
+ return f;
+ }
+ else if (isdigit(c)) { /* numeric constant */
+ p = nskip(p);
+ }
+ else if (c == '#') { /* comment: skip to EOL */
+ bstop = blim;
+ return f;
+ }
+ else if (c == '"' || c == '\''){ /* quoted literal */
+ p = matchq(p); /* skip to end */
+ if (*p != '\0')
+ p++;
+ }
+ else
+ p++; /* else advance one char */
+ }
+ bstop = blim; /* mark end of processed chrs */
+ return f; /* return first char */
+ }
+ }
+
+ /*
+ * The buffer is empty. Revert to a previous buffer.
+ */
+ if (bstack != NULL) {
+ b = bstack;
+ b->defn->inuse = 0;
+ bnxt = b->ptr;
+ bstop = b->stop;
+ blim = b->lim;
+ bstack = b->prev;
+ b->prev = bfree;
+ bfree = b;
+ continue; /* loop to preprocess */
+ }
+
+ /*
+ * There's nothing at all in memory. Read a new line.
+ */
+ if ((buf = rline(curfile->fp)) != NULL) {
+ /*
+ * The read was successful.
+ */
+ p = bnxt = bstop = blim = buf; /* reset buffer pointers */
+ curfile->lno++; /* bump line number */
+ while (isspace(c = *p))
+ p++; /* find first nonwhite */
+ if (c == '$' && (!ispunct(p[1]) || p[1]==' '))
+ ppdir(p + 1); /* handle preprocessor cmd */
+ else if (buf[1]=='l' && buf[2]=='i' && buf[3]=='n' && buf[4]=='e' &&
+ buf[0]=='#' && buf[5]==' ')
+ ppdir(p + 1); /* handle #line form */
+ else {
+ /*
+ * Not a preprocessor line; will need to scan for symbols.
+ */
+ bnxt = buf;
+ blim = buf + strlen(buf);
+ bstop = bnxt; /* no chars scanned yet */
+ }
+ }
+
+ else {
+ /*
+ * The read hit EOF.
+ */
+ if (curfile->ifdepth != ifdepth) {
+ pfatal("unterminated $if", (char *)0);
+ ifdepth = curfile->ifdepth;
+ }
+
+ /*
+ * switch to previous file and close current file.
+ */
+ fs = curfile;
+ curfile = fs->prev;
+
+ if (fs->m4flag) { /* if m4 preprocessing */
+ void quit();
+ if (pclose(fs->fp) != 0) /* close pipe */
+ quit("m4 terminated abnormally");
+ }
+ else
+ fclose(fs->fp); /* close current file */
+
+ free((char *)fs->fname);
+ free((char *)fs);
+ if (curfile == &nofile) /* if at outer level, return EOF */
+ return EOF;
+ else /* else generate #line comment */
+ pushline(curfile->fname, curfile->lno);
+ }
+ }
+ }
+
+/*
+ * rline(fp) -- read arbitrarily long line and return pointer.
+ *
+ * Allocates memory as needed. Returns NULL for EOF. Lines end with "\n\0".
+ */
+static char *rline(fp)
+FILE *fp;
+ {
+#define LINE_SIZE_INIT 100
+#define LINE_SIZE_INCR 100
+ static char *lbuf = NULL; /* line buffer */
+ static int llen = 0; /* current buffer length */
+ register char *p;
+ register int c, n;
+
+ /* if first time, allocate buffer */
+ if (!lbuf) {
+ lbuf = alloc(LINE_SIZE_INIT);
+ llen = LINE_SIZE_INIT;
+ }
+
+ /* first character is special; return NULL if hit EOF here */
+ c = getc(fp);
+ if (c == EOF)
+ return NULL;
+ if (c == '\n')
+ return "\n";
+
+ p = lbuf;
+ n = llen - 3;
+ *p++ = c;
+
+ for (;;) {
+ /* read until buffer full; return after newline or EOF */
+ while (--n >= 0 && (c = getc(fp)) != '\n' && c != EOF)
+ *p++ = c;
+ if (n >= 0) {
+ *p++ = '\n'; /* always terminate with \n\0 */
+ *p++ = '\0';
+ return lbuf;
+ }
+
+ /* need to read more, so we need a bigger buffer */
+ llen += LINE_SIZE_INCR;
+ lbuf = realloc(lbuf, (unsigned int)llen);
+ if (!lbuf) {
+ fprintf(stderr, "rline(%d): out of memory\n", llen);
+ exit(EXIT_FAILURE);
+ }
+ p = lbuf + llen - LINE_SIZE_INCR - 2;
+ n = LINE_SIZE_INCR;
+ }
+ }
+
+/*
+ * pushdef(d) -- insert definition into the input stream.
+ */
+static void pushdef(d)
+cdefn *d;
+ {
+ buffer *b;
+
+ d->inuse = 1;
+ b = bfree;
+ if (b == NULL)
+ b = (buffer *)alloc(sizeof(buffer));
+ else
+ bfree = b->prev;
+ b->prev = bstack;
+ b->defn = d;
+ b->ptr = bnxt;
+ b->stop = bstop;
+ b->lim = blim;
+ bstack = b;
+ bnxt = bstop = d->s + d->nlen;
+ blim = bnxt + d->vlen;
+ }
+
+/*
+ * pushline(fname,lno) -- push #line directive into input stream.
+ */
+static void pushline(fname, lno)
+char *fname;
+long lno;
+ {
+ static char tbuf[200];
+
+ sprintf(tbuf, "#line %ld \"%s\"\n", lno, fname);
+ bnxt = tbuf;
+ bstop = blim = tbuf + strlen(tbuf);
+ }
+
+/*
+ * ppdir(s) -- handle preprocessing directive.
+ *
+ * s is the portion of the line following the $.
+ */
+static void ppdir(s)
+char *s;
+ {
+ char b0, *cmd, *errmsg;
+ struct ppcmd *p;
+
+ b0 = buf[0]; /* remember first char of line */
+ bnxt = "\n"; /* set buffer pointers to empty line */
+ bstop = blim = bnxt + 1;
+
+ s = wskip(s); /* skip whitespace */
+ s = getidt(cmd = s - 1, s); /* get command name */
+ s = wskip(s); /* skip whitespace */
+
+ for (p = pplist; p->name != NULL; p++) /* find name in table */
+ if (strcmp(cmd, p->name) == 0) {
+ errmsg = (*p->func)(s); /* process directive */
+ if (errmsg != NULL && (p->func != setline || b0 != '#'))
+ pfatal(errmsg, (char *)0); /* issue err if not from #line form */
+ return;
+ }
+
+ pfatal("invalid preprocessing directive", cmd);
+ }
+
+/*
+ * pfatal(s1,s2) -- output a preprocessing error message.
+ *
+ * s1 is the error message; s2 is the offending value, if any.
+ * If s2 ends in a newline, the newline is truncated in place.
+ *
+ * We can't use tfatal() because we have our own line counter which may be
+ * out of sync with the lexical analyzer's.
+ */
+static void pfatal(s1, s2)
+char *s1, *s2;
+ {
+ int n;
+
+ fprintf(stderr, "File %s; Line %ld # ", curfile->fname, curfile->lno);
+ if (s2 != NULL && *s2 != '\0') {
+ n = strlen(s2);
+ if (n > 0 && s2[n-1] == '\n')
+ s2[n-1] = '\0'; /* remove newline */
+ fprintf(stderr, "\"%s\": ", s2); /* print offending value */
+ }
+ fprintf(stderr, "%s\n", s1); /* print diagnostic */
+ tfatals++;
+ nocode++;
+ }
+
+/*
+ * errdir(s) -- handle deliberate $error.
+ */
+static char *errdir(s)
+char *s;
+ {
+ pfatal("explicit $error", s); /* issue msg with text */
+ return NULL;
+ }
+
+/*
+ * define(s) -- handle $define directive.
+ */
+static char *define(s)
+char *s;
+ {
+ char c, *name, *val;
+
+ if (isalpha(c = *s) || c == '_')
+ s = getidt(name = s - 1, s); /* get name */
+ else
+ return "$define: missing name";
+ if (*s == '(')
+ return "$define: \"(\" after name requires preceding space";
+ val = s = wskip(s);
+ if (*s != '\0') {
+ while ((c = *s) != '\0' && c != '#') { /* scan value */
+ if (c == '"' || c == '\'') {
+ s = matchq(s);
+ if (*s == '\0')
+ return "$define: unterminated literal";
+ }
+ s++;
+ }
+ while (isspace(s[-1])) /* trim trailing whitespace */
+ s--;
+ }
+ *s = '\0';
+ dlookup(name, -1, val); /* install in table */
+ return NULL;
+ }
+
+/*
+ * undef(s) -- handle $undef directive.
+ */
+static char *undef(s)
+char *s;
+ {
+ char c, *name;
+
+ if (isalpha(c = *s) || c == '_')
+ s = getidt(name = s - 1, s); /* get name */
+ else
+ return "$undef: missing name";
+ if (*wskip(s) != '\0')
+ return "$undef: too many arguments";
+ dlookup(name, -1, (char *)NULL);
+ return NULL;
+ }
+
+/*
+ * include(s) -- handle $include directive.
+ */
+static char *include(s)
+char *s;
+ {
+ char *fname;
+ char fullpath[MaxPath];
+
+ s = getfnm(fname = s - 1, s);
+ if (*fname == '\0')
+ return "$include: invalid file name";
+ if (*wskip(s) != '\0')
+ return "$include: too many arguments";
+ if (!pathfind(fullpath, lpath, fname, (char *)NULL) || !ppopen(fullpath, 0))
+ pfatal("cannot open", fname);
+ return NULL;
+ }
+
+/*
+ * setline(s) -- handle $line (or #line) directive.
+ */
+static char *setline(s)
+char *s;
+ {
+ long n;
+ char c;
+ char *fname;
+
+ if (!isdigit(c = *s))
+ return "$line: no line number";
+ n = c - '0';
+
+ while (isdigit(c = *++s)) /* extract line number */
+ n = 10 * n + c - '0';
+ s = wskip(s); /* skip whitespace */
+
+ if (isalpha (c = *s) || c == '_' || c == '"') { /* if filename */
+ s = getfnm(fname = s - 1, s); /* extract it */
+ if (*fname == '\0')
+ return "$line: invalid file name";
+ }
+ else
+ fname = NULL;
+
+ if (*wskip(s) != '\0')
+ return "$line: too many arguments";
+
+ curfile->lno = n; /* set line number */
+ if (fname != NULL) { /* also set filename if given */
+ free(curfile->fname);
+ curfile->fname = salloc(fname);
+ }
+
+ pushline(curfile->fname, curfile->lno);
+ return NULL;
+ }
+
+/*
+ * ifdef(s), ifndef(s) -- conditional processing if s is/isn't defined.
+ */
+static char *ifdef(s)
+char *s;
+ {
+ return ifxdef(s, 1);
+ }
+
+static char *ifndef(s)
+char *s;
+ {
+ return ifxdef(s, 0);
+ }
+
+/*
+ * ifxdef(s) -- handle $ifdef (if n is 1) or $ifndef (if n is 0).
+ */
+static char *ifxdef(s, f)
+char *s;
+int f;
+ {
+ char c, *name;
+
+ ifdepth++;
+ if (isalpha(c = *s) || c == '_')
+ s = getidt(name = s - 1, s); /* get name */
+ else
+ return "$ifdef/$ifndef: missing name";
+ if (*wskip(s) != '\0')
+ return "$ifdef/$ifndef: too many arguments";
+ if ((dlookup(name, -1, name) != NULL) ^ f)
+ skipcode(1, 1); /* skip to $else or $endif */
+ return NULL;
+ }
+
+/*
+ * elsedir(s) -- handle $else by skipping to $endif.
+ */
+static char *elsedir(s)
+char *s;
+ {
+ if (ifdepth <= curfile->ifdepth)
+ return "unexpected $else";
+ if (*s != '\0')
+ pfatal ("extraneous arguments on $else/$endif", s);
+ skipcode(0, 1); /* skip the $else section */
+ return NULL;
+ }
+
+/*
+ * endif(s) -- handle $endif.
+ */
+static char *endif(s)
+char *s;
+ {
+ if (ifdepth <= curfile->ifdepth)
+ return "unexpected $endif";
+ if (*s != '\0')
+ pfatal ("extraneous arguments on $else/$endif", s);
+ ifdepth--;
+ return NULL;
+ }
+
+/*
+ * skipcode(doelse,report) -- skip code to $else (doelse=1) or $endif (=0).
+ *
+ * If report is nonzero, generate #line directive at end of skip.
+ */
+static void skipcode(doelse, report)
+int doelse, report;
+ {
+ char c, *p, *cmd;
+
+ while ((p = buf = rline(curfile->fp)) != NULL) {
+ curfile->lno++; /* bump line number */
+
+ /*
+ * Handle #line form encountered while skipping.
+ */
+ if (buf[1]=='l' && buf[2]=='i' && buf[3]=='n' && buf[4]=='e' &&
+ buf[0]=='#' && buf[5]==' ') {
+ ppdir(buf + 1); /* interpret #line */
+ continue;
+ }
+
+ /*
+ * Check for any other kind of preprocessing directive.
+ */
+ while (isspace(c = *p))
+ p++; /* find first nonwhite */
+ if (c != '$' || (ispunct(p[1]) && p[1]!=' '))
+ continue; /* not a preprocessing directive */
+ p = wskip(p+1); /* skip whitespace */
+ p = getidt(cmd = p-1, p); /* get command name */
+ p = wskip(p); /* skip whitespace */
+
+ /*
+ * Check for a directive that needs special attention.
+ * Deliberately accept any form of $if... as valid
+ * in anticipation of possible future extensions;
+ * this allows them to appear here if commented out.
+ */
+ if (cmd[0] == 'i' && cmd[1] == 'f') {
+ ifdepth++;
+ skipcode(0, 0); /* skip to $endif */
+ }
+ else if (strcmp(cmd, "line") == 0)
+ setline(p); /* process $line, ignore errors */
+ else if (strcmp(cmd, "endif") == 0 ||
+ (doelse == 1 && strcmp(cmd, "else") == 0)) {
+ /*
+ * Time to stop skipping.
+ */
+ if (*p != '\0')
+ pfatal ("extraneous arguments on $else/$endif", p);
+ if (cmd[1] == 'n') /* if $endif */
+ ifdepth--;
+ if (report)
+ pushline(curfile->fname, curfile->lno);
+ return;
+ }
+ }
+
+ /*
+ * At EOF, just return; main loop will report unterminated $if.
+ */
+ }
+
+/*
+ * Token scanning functions.
+ */
+
+/*
+ * wskip(s) -- skip whitespace and return updated pointer
+ *
+ * If '#' is encountered, skips to end of string.
+ */
+static char *wskip(s)
+char *s;
+ {
+ char c;
+
+ while (isspace(c = *s))
+ s++;
+ if (c == '#')
+ while ((c = *++s) != 0)
+ ;
+ return s;
+ }
+
+/*
+ * nskip(s) -- skip over numeric constant and return updated pointer.
+ */
+static char *nskip(s)
+char *s;
+ {
+ char c;
+
+ while (isdigit(c = *++s))
+ ;
+ if (c == 'r' || c == 'R') {
+ while (isalnum(c = *++s))
+ ;
+ return s;
+ }
+ if (c == '.')
+ while (isdigit (c = *++s))
+ ;
+ if (c == 'e' || c == 'E') {
+ c = s[1];
+ if (c == '+' || c == '-')
+ s++;
+ while (isdigit (c = *++s))
+ ;
+ }
+ return s;
+ }
+
+/*
+ * matchq(s) -- scan for matching quote character and return pointer.
+ *
+ * Taking *s as the quote character, s is incremented until it points
+ * to either another occurrence of the character or the '\0' terminating
+ * the string. Escaped quote characters do not stop the scan. The
+ * updated pointer is returned.
+ */
+static char *matchq(s)
+char *s;
+ {
+ char c, q;
+
+ q = *s;
+ if (q == '\0')
+ return s;
+ while ((c = *++s) != q && c != '\0') {
+ if (c == '\\')
+ if (*++s == '\0')
+ return s;
+ }
+ return s;
+ }
+
+/*
+ * getidt(dst,src) -- extract identifier, return updated pointer
+ *
+ * The identifier (in Icon terms, "many(&letters++&digits++'_')")
+ * at src is copied to dst and '\0' is appended. A pointer to the
+ * character following the identifier is returned.
+ *
+ * dst may partially overlap src if dst has a lower address. This
+ * is typically done to avoid the need for another arbitrarily-long
+ * buffer. An offset of -1 allows room for insertion of the '\0'.
+ */
+static char *getidt(dst, src)
+char *dst, *src;
+ {
+ char c;
+
+ while (isalnum(c = *src) || (c == '_')) {
+ *dst++ = c;
+ src++;
+ }
+ *dst = '\0';
+ return src;
+ }
+
+/*
+ * getfnm(dst,src) -- extract filename, return updated pointer
+ *
+ * Similarly to getidt, getfnm extracts a quoted or unquoted file name.
+ * An empty string at dst indicates a missing or unterminated file name.
+ */
+static char *getfnm(dst, src)
+char *dst, *src;
+ {
+ char *lim;
+
+ if (*src != '"')
+ return getidt(dst, src);
+ lim = matchq(src);
+ if (*lim != '"') {
+ *dst = '\0';
+ return lim;
+ }
+ while (++src < lim)
+ if ((*dst++ = *src) == '\\')
+ dst[-1] = *++src;
+ *dst = '\0';
+ return lim + 1;
+ }
+
+/*
+ * dlookup(name, len, val) look up entry in definition table.
+ *
+ * If val == name, return the existing value, or NULL if undefined.
+ * If val == NULL, delete any existing value and undefine the name.
+ * If val != NULL, install a new value, and print error if different.
+ *
+ * If name is null, the call is ignored.
+ * If len < 0, strlen(name) is taken.
+ */
+static cdefn *dlookup(name, len, val)
+char *name;
+int len;
+char *val;
+ {
+ int h, i, nlen, vlen;
+ unsigned int t;
+ cdefn *d, **p;
+
+ if (len < 0)
+ len = strlen(name);
+ if (len == 0)
+ return NULL;
+ for (t = i = 0; i < len; i++)
+ t = 37 * t + (name[i] & 0xFF); /* calc hash value */
+ h = t % HTBINS; /* calc bin number */
+ p = &cbin[h]; /* get head of list */
+ while ((d = *p) != NULL) {
+ if (d->nlen == len && strncmp(name, d->s, len) == 0) {
+ /*
+ * We found a match in the table.
+ */
+ if (val == NULL) { /* if $undef */
+ *p = d->next; /* delete from table */
+ free((char *)d);
+ return NULL;
+ }
+ if (val != name && strcmp(val, d->s + d->nlen) != 0)
+ pfatal("value redefined", name);
+ return d; /* return pointer to entry */
+ }
+ p = &d->next;
+ }
+ /*
+ * No match. Install a definition if that is what is wanted.
+ */
+ if (val == name || val == NULL) /* if was reference or $undef */
+ return NULL;
+ nlen = strlen(name);
+ vlen = strlen(val);
+ d = (cdefn *)alloc(sizeof(*d) - sizeof(d->s) + nlen + vlen + 1);
+ d->nlen = nlen;
+ d->vlen = vlen;
+ d->inuse = 0;
+ strcpy(d->s, name);
+ strcpy(d->s + nlen, val);
+ d->prev = NULL;
+ d->next = cbin[h];
+ if (d->next != NULL)
+ d->next->prev = d;
+ cbin[h] = d;
+ return d;
+ }
diff --git a/src/common/lextab.h b/src/common/lextab.h
new file mode 100644
index 0000000..7a6154b
--- /dev/null
+++ b/src/common/lextab.h
@@ -0,0 +1,576 @@
+/*
+ * NOTE: this file is generated automatically by mktoktab
+ * from tokens.txt and op.txt.
+ */
+
+/*
+ * Token table - contains an entry for each token type
+ * with printable name of token, token type, and flags
+ * for semicolon insertion.
+ */
+
+struct toktab toktab[] = {
+/* token token type flags */
+
+ /* primitives */
+ "identifier", IDENT, Beginner+Ender, /* 0 */
+ "integer-literal", INTLIT, Beginner+Ender, /* 1 */
+ "real-literal", REALLIT, Beginner+Ender, /* 2 */
+ "string-literal", STRINGLIT, Beginner+Ender, /* 3 */
+ "cset-literal", CSETLIT, Beginner+Ender, /* 4 */
+ "end-of-file", EOFX, 0, /* 5 */
+
+ /* reserved words */
+ "break", BREAK, Beginner+Ender, /* 6 */
+ "by", BY, 0, /* 7 */
+ "case", CASE, Beginner, /* 8 */
+ "create", CREATE, Beginner, /* 9 */
+ "default", DEFAULT, Beginner, /* 10 */
+ "do", DO, 0, /* 11 */
+ "else", ELSE, 0, /* 12 */
+ "end", END, Beginner, /* 13 */
+ "every", EVERY, Beginner, /* 14 */
+ "fail", FAIL, Beginner+Ender, /* 15 */
+ "global", GLOBAL, 0, /* 16 */
+ "if", IF, Beginner, /* 17 */
+ "initial", INITIAL, Beginner, /* 18 */
+ "invocable", INVOCABLE, 0, /* 19 */
+ "link", LINK, 0, /* 20 */
+ "local", LOCAL, Beginner, /* 21 */
+ "next", NEXT, Beginner+Ender, /* 22 */
+ "not", NOT, Beginner, /* 23 */
+ "of", OF, 0, /* 24 */
+ "procedure", PROCEDURE, 0, /* 25 */
+ "record", RECORD, 0, /* 26 */
+ "repeat", REPEAT, Beginner, /* 27 */
+ "return", RETURN, Beginner+Ender, /* 28 */
+ "static", STATIC, Beginner, /* 29 */
+ "suspend", SUSPEND, Beginner+Ender, /* 30 */
+ "then", THEN, 0, /* 31 */
+ "to", TO, 0, /* 32 */
+ "until", UNTIL, Beginner, /* 33 */
+ "while", WHILE, Beginner, /* 34 */
+ "end-of-file", 0, 0,
+ };
+
+/*
+ * restab[c] points to the first reserved word in toktab which
+ * begins with the letter c.
+ */
+
+struct toktab *restab[] = {
+ NULL, &toktab[ 6], &toktab[ 8], &toktab[10], /* 61-64 abcd */
+ &toktab[12], &toktab[15], &toktab[16], NULL, /* 65-68 efgh */
+ &toktab[17], NULL, NULL, &toktab[20], /* 69-6C ijkl */
+ NULL, &toktab[22], &toktab[24], &toktab[25], /* 6D-70 mnop */
+ NULL, &toktab[26], &toktab[29], &toktab[31], /* 71-74 qrst */
+ &toktab[33], NULL, &toktab[34], NULL, /* 75-78 uvwx */
+ NULL, NULL, /* 79-7A yz */
+ };
+
+/*
+ * The operator table acts to extend the token table, it
+ * indicates what implementations are expected from rtt,
+ * and it has pointers for the implementation information.
+ */
+
+struct optab optab[] = {
+ {{"!", BANG, Beginner}, Unary, NULL, NULL}, /* 0 */
+ {{"%", MOD, 0}, Binary, NULL, NULL}, /* 1 */
+ {{"%:=", AUGMOD, 0}, 0, NULL, NULL}, /* 2 */
+ {{"&", AND, Beginner}, Binary, NULL, NULL}, /* 3 */
+ {{"&:=", AUGAND, 0}, 0, NULL, NULL}, /* 4 */
+ {{"*", STAR, Beginner}, Unary | Binary, NULL, NULL}, /* 5 */
+ {{"*:=", AUGSTAR, 0}, 0, NULL, NULL}, /* 6 */
+ {{"**", INTER, Beginner}, Binary, NULL, NULL}, /* 7 */
+ {{"**:=", AUGINTER, 0}, 0, NULL, NULL}, /* 8 */
+ {{"+", PLUS, Beginner}, Unary | Binary, NULL, NULL}, /* 9 */
+ {{"+:=", AUGPLUS, 0}, 0, NULL, NULL}, /* 10 */
+ {{"++", UNION, Beginner}, Binary, NULL, NULL}, /* 11 */
+ {{"++:=", AUGUNION, 0}, 0, NULL, NULL}, /* 12 */
+ {{"-", MINUS, Beginner}, Unary | Binary, NULL, NULL}, /* 13 */
+ {{"-:=", AUGMINUS, 0}, 0, NULL, NULL}, /* 14 */
+ {{"--", DIFF, Beginner}, Binary, NULL, NULL}, /* 15 */
+ {{"--:=", AUGDIFF, 0}, 0, NULL, NULL}, /* 16 */
+ {{".", DOT, Beginner}, Unary, NULL, NULL}, /* 17 */
+ {{"/", SLASH, Beginner}, Unary | Binary, NULL, NULL}, /* 18 */
+ {{"/:=", AUGSLASH, 0}, 0, NULL, NULL}, /* 19 */
+ {{":=", ASSIGN, 0}, Binary, NULL, NULL}, /* 20 */
+ {{":=:", SWAP, 0}, Binary, NULL, NULL}, /* 21 */
+ {{"<", NMLT, 0}, Binary, NULL, NULL}, /* 22 */
+ {{"<:=", AUGNMLT, 0}, 0, NULL, NULL}, /* 23 */
+ {{"<-", REVASSIGN, 0}, Binary, NULL, NULL}, /* 24 */
+ {{"<->", REVSWAP, 0}, Binary, NULL, NULL}, /* 25 */
+ {{"<<", SLT, 0}, Binary, NULL, NULL}, /* 26 */
+ {{"<<:=", AUGSLT, 0}, 0, NULL, NULL}, /* 27 */
+ {{"<<=", SLE, 0}, Binary, NULL, NULL}, /* 28 */
+ {{"<<=:=", AUGSLE, 0}, 0, NULL, NULL}, /* 29 */
+ {{"<=", NMLE, 0}, Binary, NULL, NULL}, /* 30 */
+ {{"<=:=", AUGNMLE, 0}, 0, NULL, NULL}, /* 31 */
+ {{"=", NMEQ, Beginner}, Unary | Binary, NULL, NULL}, /* 32 */
+ {{"=:=", AUGNMEQ, 0}, 0, NULL, NULL}, /* 33 */
+ {{"==", SEQ, Beginner}, Binary, NULL, NULL}, /* 34 */
+ {{"==:=", AUGSEQ, 0}, 0, NULL, NULL}, /* 35 */
+ {{"===", EQUIV, Beginner}, Binary, NULL, NULL}, /* 36 */
+ {{"===:=", AUGEQUIV, 0}, 0, NULL, NULL}, /* 37 */
+ {{">", NMGT, 0}, Binary, NULL, NULL}, /* 38 */
+ {{">:=", AUGNMGT, 0}, 0, NULL, NULL}, /* 39 */
+ {{">=", NMGE, 0}, Binary, NULL, NULL}, /* 40 */
+ {{">=:=", AUGNMGE, 0}, 0, NULL, NULL}, /* 41 */
+ {{">>", SGT, 0}, Binary, NULL, NULL}, /* 42 */
+ {{">>:=", AUGSGT, 0}, 0, NULL, NULL}, /* 43 */
+ {{">>=", SGE, 0}, Binary, NULL, NULL}, /* 44 */
+ {{">>=:=", AUGSGE, 0}, 0, NULL, NULL}, /* 45 */
+ {{"?", QMARK, Beginner}, Unary, NULL, NULL}, /* 46 */
+ {{"?:=", AUGQMARK, 0}, 0, NULL, NULL}, /* 47 */
+ {{"@", AT, Beginner}, 0, NULL, NULL}, /* 48 */
+ {{"@:=", AUGAT, 0}, 0, NULL, NULL}, /* 49 */
+ {{"\\", BACKSLASH, Beginner}, Unary, NULL, NULL}, /* 50 */
+ {{"^", CARET, Beginner}, Unary | Binary, NULL, NULL}, /* 51 */
+ {{"^:=", AUGCARET, 0}, 0, NULL, NULL}, /* 52 */
+ {{"|", BAR, Beginner}, 0, NULL, NULL}, /* 53 */
+ {{"||", CONCAT, Beginner}, Binary, NULL, NULL}, /* 54 */
+ {{"||:=", AUGCONCAT, 0}, 0, NULL, NULL}, /* 55 */
+ {{"|||", LCONCAT, Beginner}, Binary, NULL, NULL}, /* 56 */
+ {{"|||:=", AUGLCONCAT, 0}, 0, NULL, NULL}, /* 57 */
+ {{"~", TILDE, Beginner}, Unary, NULL, NULL}, /* 58 */
+ {{"~=", NMNE, Beginner}, Binary, NULL, NULL}, /* 59 */
+ {{"~=:=", AUGNMNE, 0}, 0, NULL, NULL}, /* 60 */
+ {{"~==", SNE, Beginner}, Binary, NULL, NULL}, /* 61 */
+ {{"~==:=", AUGSNE, 0}, 0, NULL, NULL}, /* 62 */
+ {{"~===", NEQUIV, Beginner}, Binary, NULL, NULL}, /* 63 */
+ {{"~===:=", AUGNEQUIV, 0}, 0, NULL, NULL}, /* 64 */
+ {{"(", LPAREN, Beginner}, 0, NULL, NULL}, /* 65 */
+ {{")", RPAREN, Ender}, 0, NULL, NULL}, /* 66 */
+ {{"+:", PCOLON, 0}, 0, NULL, NULL}, /* 67 */
+ {{",", COMMA, 0}, 0, NULL, NULL}, /* 68 */
+ {{"-:", MCOLON, 0}, 0, NULL, NULL}, /* 69 */
+ {{":", COLON, 0}, 0, NULL, NULL}, /* 70 */
+ {{";", SEMICOL, 0}, 0, NULL, NULL}, /* 71 */
+ {{"[", LBRACK, Beginner}, 0, NULL, NULL}, /* 72 */
+ {{"]", RBRACK, Ender}, 0, NULL, NULL}, /* 73 */
+ {{"{", LBRACE, Beginner}, 0, NULL, NULL}, /* 74 */
+ {{"}", RBRACE, Ender}, 0, NULL, NULL}, /* 75 */
+ {{"$(", LBRACE, Beginner}, 0, NULL, NULL}, /* 76 */
+ {{"$)", RBRACE, Ender}, 0, NULL, NULL}, /* 77 */
+ {{"$<", LBRACK, Beginner}, 0, NULL, NULL}, /* 78 */
+ {{"$>", RBRACK, Ender}, 0, NULL, NULL}, /* 79 */
+ {{NULL, 0, 0}, 0, NULL, NULL}
+ };
+
+int asgn_loc = 20;
+int semicol_loc = 71;
+int plus_loc = 9;
+int minus_loc = 13;
+
+/*
+ * getopr - find the longest legal operator and return the
+ * index to its entry in the operator table.
+ */
+
+int getopr(ac, cc)
+int ac;
+int *cc;
+ {
+ register char c;
+
+ *cc = ' ';
+ switch (c = ac) {
+ case '!':
+ return 0; /* ! */
+ case '$':
+ switch (c = NextChar) {
+ case '(':
+ return 76; /* $( */
+ case ')':
+ return 77; /* $) */
+ case '<':
+ return 78; /* $< */
+ case '>':
+ return 79; /* $> */
+ }
+ break;
+ case '%':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 2; /* %:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 1; /* % */
+ }
+ break;
+ case '&':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 4; /* &:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 3; /* & */
+ }
+ break;
+ case '(':
+ return 65; /* ( */
+ case ')':
+ return 66; /* ) */
+ case '*':
+ switch (c = NextChar) {
+ case '*':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 8; /* **:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 7; /* ** */
+ }
+ break;
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 6; /* *:= */
+ }
+ break;
+ default:
+ *cc = c;
+ return 5; /* * */
+ }
+ break;
+ case '+':
+ switch (c = NextChar) {
+ case '+':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 12; /* ++:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 11; /* ++ */
+ }
+ break;
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 10; /* +:= */
+ }
+ else {
+ *cc = c;
+ return 67; /* +: */
+ }
+ default:
+ *cc = c;
+ return 9; /* + */
+ }
+ break;
+ case ',':
+ return 68; /* , */
+ case '-':
+ switch (c = NextChar) {
+ case '-':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 16; /* --:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 15; /* -- */
+ }
+ break;
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 14; /* -:= */
+ }
+ else {
+ *cc = c;
+ return 69; /* -: */
+ }
+ default:
+ *cc = c;
+ return 13; /* - */
+ }
+ break;
+ case '.':
+ return 17; /* . */
+ case '/':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 19; /* /:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 18; /* / */
+ }
+ break;
+ case ':':
+ if ((c = NextChar) == '=') {
+ if ((c = NextChar) == ':') {
+ return 21; /* :=: */
+ }
+ else {
+ *cc = c;
+ return 20; /* := */
+ }
+ }
+ else {
+ *cc = c;
+ return 70; /* : */
+ }
+ case ';':
+ return 71; /* ; */
+ case '<':
+ switch (c = NextChar) {
+ case '-':
+ if ((c = NextChar) == '>') {
+ return 25; /* <-> */
+ }
+ else {
+ *cc = c;
+ return 24; /* <- */
+ }
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 23; /* <:= */
+ }
+ break;
+ case '<':
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 27; /* <<:= */
+ }
+ break;
+ case '=':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 29; /* <<=:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 28; /* <<= */
+ }
+ break;
+ default:
+ *cc = c;
+ return 26; /* << */
+ }
+ break;
+ case '=':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 31; /* <=:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 30; /* <= */
+ }
+ break;
+ default:
+ *cc = c;
+ return 22; /* < */
+ }
+ break;
+ case '=':
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 33; /* =:= */
+ }
+ break;
+ case '=':
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 35; /* ==:= */
+ }
+ break;
+ case '=':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 37; /* ===:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 36; /* === */
+ }
+ break;
+ default:
+ *cc = c;
+ return 34; /* == */
+ }
+ break;
+ default:
+ *cc = c;
+ return 32; /* = */
+ }
+ break;
+ case '>':
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 39; /* >:= */
+ }
+ break;
+ case '=':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 41; /* >=:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 40; /* >= */
+ }
+ break;
+ case '>':
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 43; /* >>:= */
+ }
+ break;
+ case '=':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 45; /* >>=:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 44; /* >>= */
+ }
+ break;
+ default:
+ *cc = c;
+ return 42; /* >> */
+ }
+ break;
+ default:
+ *cc = c;
+ return 38; /* > */
+ }
+ break;
+ case '?':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 47; /* ?:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 46; /* ? */
+ }
+ break;
+ case '@':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 49; /* @:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 48; /* @ */
+ }
+ break;
+ case '[':
+ return 72; /* [ */
+ case '\\':
+ return 50; /* \ */
+ case ']':
+ return 73; /* ] */
+ case '^':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 52; /* ^:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 51; /* ^ */
+ }
+ break;
+ case '{':
+ return 74; /* { */
+ case '|':
+ if ((c = NextChar) == '|') {
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 55; /* ||:= */
+ }
+ break;
+ case '|':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 57; /* |||:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 56; /* ||| */
+ }
+ break;
+ default:
+ *cc = c;
+ return 54; /* || */
+ }
+ }
+ else {
+ *cc = c;
+ return 53; /* | */
+ }
+ break;
+ case '}':
+ return 75; /* } */
+ case '~':
+ if ((c = NextChar) == '=') {
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 60; /* ~=:= */
+ }
+ break;
+ case '=':
+ switch (c = NextChar) {
+ case ':':
+ if ((c = NextChar) == '=') {
+ return 62; /* ~==:= */
+ }
+ break;
+ case '=':
+ if ((c = NextChar) == ':') {
+ if ((c = NextChar) == '=') {
+ return 64; /* ~===:= */
+ }
+ }
+ else {
+ *cc = c;
+ return 63; /* ~=== */
+ }
+ break;
+ default:
+ *cc = c;
+ return 61; /* ~== */
+ }
+ break;
+ default:
+ *cc = c;
+ return 59; /* ~= */
+ }
+ }
+ else {
+ *cc = c;
+ return 58; /* ~ */
+ }
+ break;
+ }
+ tfatal("invalid character", (char *)NULL);
+ return -1;
+ }
diff --git a/src/common/literals.c b/src/common/literals.c
new file mode 100644
index 0000000..4978d5f
--- /dev/null
+++ b/src/common/literals.c
@@ -0,0 +1,180 @@
+#include "../h/gsupport.h"
+#include "../h/esctab.h"
+
+/*
+ * Prototypes.
+ */
+unsigned short *bitvect (char *image, int len);
+static int escape (char **str_ptr, int *nchars_ptr);
+
+/*
+ * Within translators, csets are internally implemented as a bit vector made
+ * from an array of unsigned shorts. For portability, only the lower 16
+ * bits of these shorts are used.
+ */
+#define BVectIndx(c) (((unsigned char)c >> 4) & 0xf)
+#define BitInShrt(c) (1 << ((unsigned char)c & 0xf))
+
+/*
+ * Macros used by escape() to advance to the next character and to
+ * test the kind of character.
+ */
+#define NextChar(c) ((*nchars_ptr)--, c = *(*str_ptr)++)
+#define isoctal(c) ((c)>='0'&&(c)<='7') /* macro to test for octal digit */
+
+/*
+ * escape - translate the character sequence following a '\' into the
+ * single character it represents.
+ */
+static int escape(str_ptr, nchars_ptr)
+char **str_ptr;
+int *nchars_ptr;
+ {
+ register int c, nc, i;
+
+ /*
+ * Note, it is impossible to have a character string ending with a '\',
+ * something must be here.
+ */
+ NextChar(c);
+ if (isoctal(c)) {
+ /*
+ * translate an octal escape -- backslash followed by one, two, or three
+ * octal digits.
+ */
+ c -= '0';
+ for (i = 2; *nchars_ptr > 0 && isoctal(**str_ptr) && i <= 3; ++i) {
+ NextChar(nc);
+ c = (c << 3) | (nc - '0');
+ }
+ return (c & 0377);
+ }
+ else if (c == 'x') {
+ /*
+ * translate a hexadecimal escape -- backslash-x followed by one or
+ * two hexadecimal digits.
+ */
+ c = 0;
+ for (i = 1; *nchars_ptr > 0 && isxdigit(**str_ptr) && i <= 2; ++i) {
+ NextChar(nc);
+ if (nc >= 'a' && nc <= 'f')
+ nc -= 'a' - 10;
+ else if (nc >= 'A' && nc <= 'F')
+ nc -= 'A' - 10;
+ else if (isdigit(nc))
+ nc -= '0';
+ c = (c << 4) | nc;
+ }
+ return c;
+ }
+ else if (c == '^') {
+ /*
+ * translate a control escape -- backslash followed by caret and one
+ * character.
+ */
+ if (*nchars_ptr <= 0)
+ return 0; /* could only happen in a keyword */
+ NextChar(c);
+ return (c & 037);
+ }
+ else
+ return esctab[c];
+ }
+
+/*
+ * bitvect - convert cset literal into a bitvector
+ */
+unsigned short *bitvect(image, len)
+char *image;
+int len;
+ {
+ register int c;
+ register unsigned short *bv;
+ register int i;
+
+ bv = alloc(BVectSize * sizeof(unsigned short));
+ for (i = 0; i < BVectSize; ++i)
+ bv[i] = 0;
+ while (len-- > 0) {
+ c = *image++;
+ if (c == '\\')
+ c = escape(&image, &len);
+ bv[BVectIndx(c)] |= BitInShrt(c);
+ }
+ return bv;
+ }
+
+/*
+ * cset_init - use bitvector for a cset to write an initialization for
+ * a cset block.
+ */
+void cset_init(f, bv)
+FILE *f;
+unsigned short *bv;
+ {
+ int size;
+ unsigned short n;
+ register int j;
+
+ size = 0;
+ for (j = 0; j < BVectSize; ++j)
+ for (n = bv[j]; n != 0; n >>= 1)
+ size += n & 1;
+ fprintf(f, "{T_Cset, %d,\n", size);
+ fprintf(f, " cset_display(0x%x", bv[0]);
+ for (j = 1; j < BVectSize; ++j)
+ fprintf(f, ",0x%x", bv[j]);
+ fprintf(f, ")\n };\n");
+ }
+
+/*
+ * prtstr - print an Icon string literal as a C string literal.
+ */
+int prt_i_str(f, s, len)
+FILE *f;
+char *s;
+int len;
+ {
+ int c;
+ int n_chars;
+
+ n_chars = 0;
+ while (len-- > 0) {
+ ++n_chars;
+ c = *s++;
+ if (c == '\\')
+ c = escape(&s, &len);
+ switch (c) {
+ case '\n':
+ fprintf(f, "\\n");
+ break;
+ case '\t':
+ fprintf(f, "\\t");
+ break;
+ case '\v':
+ fprintf(f, "\\v");
+ break;
+ case '\b':
+ fprintf(f, "\\b");
+ break;
+ case '\r':
+ fprintf(f, "\\r");
+ break;
+ case '\f':
+ fprintf(f, "\\f");
+ break;
+ case '\\':
+ fprintf(f, "\\\\");
+ break;
+ case '\"':
+ fprintf(f, "\\\"");
+ break;
+ default:
+ if (isprint(c))
+ fprintf(f, "%c", c);
+ else
+ fprintf(f, "\\%03o", (int)c);
+ }
+ }
+ return n_chars;
+ }
diff --git a/src/common/long.c b/src/common/long.c
new file mode 100644
index 0000000..071a944
--- /dev/null
+++ b/src/common/long.c
@@ -0,0 +1,34 @@
+/*
+ * long.c -- functions for handling long values on 16-bit computers.
+ */
+
+#include "../h/gsupport.h"
+
+/*
+ * Write a long string in int-sized chunks.
+ */
+
+long longwrite(s,len,file)
+FILE *file;
+char *s;
+long len;
+{
+ long tally = 0;
+ int n = 0;
+ int leftover, loopnum;
+ char *p;
+
+ leftover = (int)(len % (long)MaxInt);
+ for (p = s, loopnum = (int)(len / (long)MaxInt); loopnum; loopnum--) {
+ n = fwrite(p,sizeof(char),MaxInt,file);
+ tally += (long)n;
+ p += MaxInt;
+ }
+ if (leftover) {
+ n = fwrite(p,sizeof(char),leftover,file);
+ tally += (long)n;
+ }
+ if (tally != len)
+ return -1;
+ else return tally;
+ }
diff --git a/src/common/mktoktab.icn b/src/common/mktoktab.icn
new file mode 100644
index 0000000..c066958
--- /dev/null
+++ b/src/common/mktoktab.icn
@@ -0,0 +1,507 @@
+# Build the files:
+# lextab.h - token tables and operator recognizer
+# yacctok.h - %token declarations for YACC
+# from token description file "tokens.txt" and operator description
+# file "op.txt".
+
+global token, tokval, bflag, eflag, head, oper, tail, count
+global restable, flagtable, op_lst, asgn_loc, semicol_loc, plus_loc, minus_loc
+global white_sp, unary_set
+global tokfile, opfile, toktab, tok_dot_h
+
+record op_sym(op, aug, tokval, unary, binary)
+record association(op, n)
+record trie(by_1st_c, dflt)
+
+procedure tokpat()
+ if tab(many(white_sp)) & (token := tab(upto(white_sp))) &
+ tab(many(white_sp)) & (tokval := (tab(upto(white_sp) | 0)))
+ then return (tab(upto('b')) & (bflag := move(1))) | (bflag := "") &
+ ((tab(upto('e')) & (eflag := move(1))) | (eflag := "")) & pos(0)
+end
+
+procedure main()
+ local line, letter, lastletter
+ local s, op, aug, tok, unary, binary, tok_chars, sym, op_trie
+ local prognm, tokfnm, opfnm, toktbnm, dothnm, op_linenum
+
+ white_sp := ' \t'
+
+ prognm := "mktoktab"
+ tokfnm := "tokens.txt"
+ opfnm := "op.txt"
+ toktbnm := "lextab.h"
+ dothnm := "yacctok.h"
+
+ restable := table()
+ flagtable := table("")
+ flagtable[""] := "0"
+ flagtable["b"] := "Beginner"
+ flagtable["e"] := "Ender"
+ flagtable["be"] := "Beginner+Ender"
+ count := 0
+ lastletter := ""
+
+ tokfile := open(tokfnm) | stop("unable to open \"", tokfnm, "\"")
+ opfile := open(opfnm) | stop("unable to open \"", opfnm, "\"")
+ toktab := open(toktbnm,"w") | stop("unable to create \"", toktbnm, "\"")
+ tok_dot_h := open(dothnm,"w") | stop("unable to create \"", dothnm, "\"")
+ write(" writing ", tokfnm, " and ", dothnm)
+
+# Output header for token table
+ write(toktab,"/*")
+ write(toktab," * NOTE: this file is generated automatically by ", prognm)
+ write(toktab," * from ", tokfnm, " and ", opfnm, ".")
+ write(toktab," */")
+ write(toktab)
+ write(toktab,"/*")
+ write(toktab," * Token table - contains an entry for each token type")
+ write(toktab," * with printable name of token, token type, and flags")
+ write(toktab," * for semicolon insertion.")
+ write(toktab," */")
+ write(toktab)
+ write(toktab,"struct toktab toktab[] = {")
+ write(toktab,"/* token\t\ttoken type\tflags */")
+ write(toktab)
+ write(toktab," /* primitives */")
+
+# output header for token include file
+ write(tok_dot_h,"/*")
+ write(tok_dot_h," * NOTE: these %token declarations are generated")
+ write(tok_dot_h," * automatically by ", prognm, " from ", tokfnm, " and ")
+ write(tok_dot_h," * ", opfnm, ".")
+ write(tok_dot_h," */")
+ write(tok_dot_h)
+ write(tok_dot_h, "/* primitive tokens */")
+ write(tok_dot_h)
+
+
+# Skip the first few (non-informative) lines of "tokens.txt"
+
+ garbage()
+
+# Read primitive tokens
+
+ repeat {
+ write(toktab,makeline(token,tokval,bflag || eflag,count))
+ wrt_tok_def(tokval)
+ count +:= 1
+ line := read(tokfile) | stop("premature end-of-file")
+ line ? tokpat() | break
+ }
+
+# Skip some more garbage lines
+
+ garbage()
+
+# Output some more comments
+
+ write(toktab)
+ write(toktab," /* reserved words */")
+ write(tok_dot_h)
+ write(tok_dot_h, "/* reserved words */")
+ write(tok_dot_h)
+
+# Read in reserved words, output them,
+# and build table of first letters.
+
+ repeat {
+ write(toktab,makeline(token,tokval,bflag || eflag,count))
+ wrt_tok_def(tokval, token)
+ letter := token[1]
+ if letter ~== lastletter then {
+ lastletter := letter
+ restable[letter] := count
+ }
+ count +:= 1
+ line := read(tokfile) | stop("premature end-of-file")
+ if line ? tokpat() then next else break
+ }
+
+# output end of token table and reserveed word first-letter index.
+
+ write(toktab,makeline("end-of-file","0","",""))
+ write(toktab," };")
+ write(toktab)
+ write(toktab,"/*")
+ write(toktab," * restab[c] points to the first reserved word in toktab which")
+ write(toktab," * begins with the letter c.")
+ write(toktab," */")
+ write(toktab)
+ write(toktab,"struct toktab *restab[] = {")
+ write(toktab,makeres("abcd", 16r61))
+ write(toktab,makeres("efgh"))
+ write(toktab,makeres("ijkl"))
+ write(toktab,makeres("mnop"))
+ write(toktab,makeres("qrst"))
+ write(toktab,makeres("uvwx"))
+ write(toktab,makeres("yz"))
+ write(toktab," };")
+
+# Another comment
+
+ write(toktab)
+ write(toktab,"/*")
+ write(toktab," * The operator table acts to extend the token table, it")
+ write(toktab," * indicates what implementations are expected from rtt,")
+ write(toktab," * and it has pointers for the implementation information.")
+ write(toktab," */")
+ write(toktab)
+ write(toktab, "struct optab optab[] = {")
+ write(tok_dot_h)
+ write(tok_dot_h, "/* operators */")
+ write(tok_dot_h)
+
+# read operator file
+
+ tok_chars := &lcase ++ &ucase ++ '_'
+
+ op_linenum := 0
+ unary_set := set()
+ ops := table()
+ op_lst := []
+
+ while s := read(opfile) do {
+ op_linenum +:= 1
+ s ? {
+ tab(many(white_sp))
+ if pos(0) | = "#" then
+ next
+ op := tab(upto(white_sp)) | err(opfnm, op_linenum,
+ "unexpected end of line")
+ tab(many(white_sp))
+ if ="(:=" then {
+ tab(many(white_sp))
+ if not ="AUG)" then
+ err(opfnm, op_linenum, "invalid augmented indication")
+ tab(many(white_sp))
+ aug := 1
+ }
+ else
+ aug := &null
+ tok := tab(many(tok_chars)) | err(opfnm, op_linenum, "invalid token")
+ tab(many(white_sp))
+ unary := tab(any('_us')) | err(opfnm,op_linenum,"invalid unary flag")
+ tab(many(white_sp))
+ binary := tab(any('_bs')) | err(opfnm,op_linenum,"invalid binary flag")
+ if unary == "_" & binary == "_" then
+ err(opfnm, op_linenum, "either unary or binary flag must be set")
+ if unary ~== "_" then {
+ if *op ~= 1 then
+ err(opfnm, op_linenum,
+ "unary operators must be single characters: " || op);
+ insert(unary_set, op)
+ }
+ if \aug & binary == "_" then
+ err(opfnm, op_linenum,
+ "binary flag must be set for augmented assignment")
+
+ ops[op] := op_sym(op, aug, tok, unary, binary)
+ }
+ }
+
+ ops := sort(ops, 3)
+ while get(ops) & sym := get(ops) do
+ op_out(sym.op, sym.aug, sym.tokval, sym.unary, sym.binary)
+
+# Skip more garbage
+
+ garbage()
+
+repeat {
+ wrt_op(token, tokval, bflag || eflag, 0, 1)
+ line := read(tokfile) | stop("premature end-of-file")
+ line ? tokpat() | break
+ }
+
+# Skip more garbage
+
+ garbage()
+
+repeat {
+ wrt_op(token, tokval, bflag || eflag, 0, &null)
+ line := read(tokfile) | stop("premature end-of-file")
+ line ? tokpat() | break
+ }
+ write(toktab,
+ " {{NULL, 0, 0}, 0, NULL, NULL}")
+ write(toktab, " };")
+
+ write(toktab)
+ if /asgn_loc then
+ stop(opfnm, " does not contain a definition for ':='")
+ if /semicol_loc then
+ stop(tokfnm, " does not contain a definition for ';'")
+ if /plus_loc then
+ stop(tokfnm, " does not contain a definition for '+'")
+ if /minus_loc then
+ stop(tokfnm, " does not contain a definition for '-'")
+ write(toktab, "int asgn_loc = ", asgn_loc, ";")
+ write(toktab, "int semicol_loc = ", semicol_loc, ";")
+ write(toktab, "int plus_loc = ", plus_loc, ";")
+ write(toktab, "int minus_loc = ", minus_loc, ";")
+
+ op_trie := build_trie(op_lst)
+
+ write(toktab);
+ wrt(toktab, 0, "/*")
+ wrt(toktab, 0, " * getopr - find the longest legal operator and return the")
+ wrt(toktab, 0, " * index to its entry in the operator table.")
+ wrt(toktab, 0, " */\n")
+ wrt(toktab, 0, "int getopr(ac, cc)")
+ wrt(toktab, 0, "int ac;")
+ wrt(toktab, 0, "int *cc;")
+ wrt(toktab, 1, "{")
+ wrt(toktab, 1, "register char c;\n")
+ wrt(toktab, 1, "*cc = ' ';")
+ bld_slct(op_trie, "", "ac", toktab, 1)
+ wrt(toktab, 1, "tfatal(\"invalid character\", (char *)NULL);")
+ wrt(toktab, 1, "return -1;")
+ wrt(toktab, 1, "}")
+end
+
+procedure makeline(token,tokval,flag,count) # build an output line for token table.
+ local line
+ line := left(" \"" || token || "\",",22) || left(tokval || ",",15)
+ flag := flagtable[flag] || ","
+ if count ~=== "" then flag := left(flag,19)
+ line ||:= flag
+ if count ~=== "" then line ||:= "/* " || right(count,3) || " */"
+ return line
+end
+
+# makeres - build an output line for reserved word index.
+#
+procedure makeres(lets, strt_repr)
+ local let, letters, line
+ static repr
+
+ repr := \strt_repr
+
+ line := " "
+ letters := lets
+ every let := !lets do
+ if let ~== "." & \restable[let] then {
+ line ||:= "&toktab[" || right(restable[let],2) || "], "
+ }
+ else line ||:= "NULL, "
+ line := left(line,55) || "/* "
+ if integer(repr) then
+ line ||:= hex(repr) || "-" || hex((repr +:= *lets) - 1) || " "
+ return line || letters || " */"
+end
+
+procedure garbage()
+ local line
+ while line := read(tokfile) | stop("premature end-of-file") do
+ if line ? tokpat() then return
+end
+
+procedure hex(n)
+ local s
+ static hexdig
+
+ initial hexdig := "0123456789ABCDEF"
+
+ s := ""
+ while n > 0 do {
+ s := hexdig[n % 16 + 1] || s
+ n := n / 16
+ }
+ return s
+end
+
+procedure op_out(op, aug, tokval, unary, binary)
+ local flag, arity
+
+ if unary_str(op) then
+ flag := "b"
+ else
+ flag := ""
+ if unary == "u" then
+ arity := "Unary"
+ if binary == "b" then
+ if /arity then
+ arity := "Binary"
+ else
+ arity ||:= " | Binary"
+ /arity := "0"
+ wrt_op(op, tokval, flag, arity, 1)
+ if \aug then
+ wrt_op(op || ":=", "AUG" || tokval, "", "0", 1)
+end
+
+procedure wrt_op(op, tokval, flag, arity, define)
+ static cnt
+
+ initial cnt := 0;
+
+ flag := flagtable[flag]
+ writes(toktab, " {{\"", left(esc(op) || "\",", 9))
+ writes(toktab, left(tokval || ",", 12))
+ writes(toktab, left(flag || "},", 11))
+ writes(toktab, left(arity|| ",", 16))
+ write(toktab, "NULL, NULL}, /* ", cnt, " */")
+ if \define then
+ wrt_tok_def(tokval, op)
+ if op == ":=" then
+ asgn_loc := cnt
+ else if op == ";" then
+ semicol_loc := cnt
+ else if op == "+" then
+ plus_loc := cnt
+ else if op == "-" then
+ minus_loc := cnt
+ put(op_lst, association(op, cnt))
+ cnt +:= 1
+end
+
+procedure wrt_tok_def(tokval, tok)
+ if \tok then
+ write(tok_dot_h, "%token\t", left(tokval, 12), "/* ", left(tok, 9),
+ " */")
+ else
+ write(tok_dot_h, "%token\t", tokval);
+end
+
+procedure unary_str(op)
+ if op == "" then
+ return
+ if member(unary_set, op[1]) then
+ return unary_str(op[2:0])
+end
+
+procedure err(file, line, msg)
+ stop(&errout, "file: ", file, ", line: ", line, " - ", msg)
+end
+
+procedure build_trie(ops)
+ local by_1st_c, dflt, asc, c, c_ops
+
+ by_1st_c := table()
+ every asc := !ops do {
+ #
+ # See if there are more characters in this operator.
+ #
+ if c := asc.op[1] then {
+ /by_1st_c[c] := []
+ put(by_1st_c[c], association(asc.op[2:0], asc.n))
+ }
+ else
+ dflt := asc.n
+ }
+ by_1st_c := sort(by_1st_c)
+ every c_ops := !by_1st_c do
+ c_ops[2] := build_trie(c_ops[2])
+ return trie(by_1st_c, dflt)
+end
+
+
+# bld_slct - output selection code which will recongize operators
+# represented by the given trie. Code has already been generated
+# to recognize the string in prefix.
+procedure bld_slct(op_trie, prefix, char_src, f, indent)
+ local fall_through, by_1st_c, dflt, char, trie_1, a, ft
+
+ by_1st_c := op_trie.by_1st_c
+ dflt := op_trie.dflt
+
+ case *by_1st_c of {
+ 0:
+ #
+ # There are no more characters to check. When execution gets
+ # here in the generated code we have found a longest possible
+ # operator: the one contained in prefix.
+ #
+ wrt(f, indent, "return " , dflt, "; /* ", prefix, " */")
+ 1: {
+ #
+ # If there is only one valid character to check for, generate an
+ # if statement rather than a switch statement. If the character
+ # is not next in the input, either we are already at the end of
+ # a valid operator (in which case, the generated code must
+ # must save the one-character look ahead) or the generated
+ # code will fall through to an error message at the end of the
+ # function.
+ #
+ char := by_1st_c[1][1]
+ trie_1 := by_1st_c[1][2]
+ wrt(f, indent, "if ((c = ", char_src, ") == '", esc(char), "') {")
+ fall_through := bld_slct(trie_1, prefix || char, "NextChar", f,
+ indent + 1)
+ wrt(f, indent + 1, "}")
+ if \dflt then {
+ wrt(f, indent, "else {")
+ wrt(f, indent + 1, "*cc = c;")
+ wrt(f, indent + 1, "return " , dflt, "; /* ", prefix, " */")
+ wrt(f, indent + 1, "}")
+ }
+ else
+ fall_through := 1
+ }
+ default: {
+ #
+ # There are several possible next characters. Produce a switch
+ # statement to check for them.
+ #
+ wrt(f, indent, "switch (c = ", char_src, ") {")
+ every a := !by_1st_c do {
+ char := a[1]
+ trie_1 := a[2]
+ wrt(f, indent + 1, "case '", esc(char), "':")
+ ft := bld_slct(trie_1, prefix || char, "NextChar", f, indent + 2)
+ if \ft then {
+ wrt(f, indent + 2, "break;")
+ fall_through := 1
+ }
+ }
+ if \dflt then {
+ wrt(f, indent + 1, "default:")
+ wrt(f, indent + 2, "*cc = c;")
+ wrt(f, indent + 2, "return " , dflt, "; /* ", prefix, " */")
+ }
+ else
+ fall_through := 1
+ wrt(f, indent + 1, "}")
+ }
+ }
+
+ return fall_through
+end
+
+procedure wrt(f, indent, slst[])
+ local s1, i, exp_indent
+
+ exp_indent := indent * 3;
+ s1 := repl(" ", exp_indent)
+ while s1 ||:= get(slst)
+ if (*s1 > 80) then {
+ #
+ # line too long, find first space before 80th column, and
+ # break there. note, this will not work in general. it may
+ # break a line within a string.
+ #
+ every i := 80 to 1 by -1 do
+ if s1[i] == " " then
+ if i <= exp_indent then {
+ #
+ # we have indented too far
+ #
+ wrt(f, indent - 1, s1[exp_indent+1:0])
+ return
+ }
+ else {
+ write(f, s1[1:i])
+ wrt(f, indent, s1[i+1:0])
+ return
+ }
+ }
+ write(f, s1)
+end
+
+procedure esc(c)
+ if c == "\\" then
+ return "\\\\"
+ else
+ return c
+end
diff --git a/src/common/munix.c b/src/common/munix.c
new file mode 100644
index 0000000..132f397
--- /dev/null
+++ b/src/common/munix.c
@@ -0,0 +1,258 @@
+/*
+ * munix.c -- special common code from Unix
+ *
+ * (Originally used only under Unix, but now on all platforms.)
+ */
+
+#include "../h/gsupport.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <unistd.h>
+
+/*
+ * relfile(prog, mod) -- find related file.
+ *
+ * Given that prog is the argv[0] by which this program was executed,
+ * and assuming that it was set by the shell or other equally correct
+ * invoker, relfile finds the location of a related file and returns
+ * it in an allocated string. It takes the location of prog, appends
+ * mod, and canonizes the result; thus if argv[0] is icont or its path,
+ * relfile(argv[0],"/../iconx") finds the location of iconx.
+ */
+char *relfile(char *prog, char *mod) {
+ static char baseloc[MaxPath];
+ char buf[MaxPath];
+
+ if (baseloc[0] == 0) { /* if argv[0] not already found */
+
+ #if CYGWIN
+ char posix_prog[_POSIX_PATH_MAX + 1];
+ cygwin_conv_to_posix_path(prog, posix_prog);
+ prog = posix_prog;
+ #endif /* CYGWIN */
+
+ if (findexe(prog, baseloc, sizeof(baseloc)) == NULL) {
+ fprintf(stderr, "cannot find location of %s\n", prog);
+ exit(EXIT_FAILURE);
+ }
+ if (followsym(baseloc, buf, sizeof(buf)) != NULL)
+ strcpy(baseloc, buf);
+ }
+
+ strcpy(buf, baseloc); /* start with base location */
+ strcat(buf, mod); /* append adjustment */
+ canonize(buf); /* canonize result */
+ if (mod[strlen(mod)-1] == '/') /* if trailing slash wanted */
+ strcat(buf, "/"); /* append to result */
+ return salloc(buf); /* return allocated string */
+ }
+
+/*
+ * findexe(prog, buf, len) -- find absolute executable path, given argv[0]
+ *
+ * Finds the absolute path to prog, assuming that prog is the value passed
+ * by the shell in argv[0]. The result is placed in buf, which is returned.
+ * NULL is returned in case of error.
+ */
+
+char *findexe(char *name, char *buf, size_t len) {
+ int n;
+ char *s;
+
+ if (name == NULL)
+ return NULL;
+
+ /* if name does not contain a slash, search $PATH for file */
+ if (strchr(name, '/') != NULL)
+ strcpy(buf, name);
+ else if (findonpath(name, buf, len) == NULL)
+ return NULL;
+
+ /* if path is not absolute, prepend working directory */
+ if (buf[0] != '/') {
+ n = strlen(buf) + 1;
+ memmove(buf + len - n, buf, n);
+ if (getcwd(buf, len - n) == NULL)
+ return NULL;
+ s = buf + strlen(buf);
+ *s = '/';
+ memcpy(s + 1, buf + len - n, n);
+ }
+ canonize(buf);
+ return buf;
+ }
+
+/*
+ * findonpath(name, buf, len) -- find name on $PATH
+ *
+ * Searches $PATH (using POSIX 1003.2 rules) for executable name,
+ * writing the resulting path in buf if found.
+ */
+char *findonpath(char *name, char *buf, size_t len) {
+ int nlen, plen;
+ char *path, *next, *sep, *end;
+ struct stat status;
+
+ nlen = strlen(name);
+ path = getenv("PATH");
+
+ if (path == NULL || *path == '\0')
+ path = ".";
+ #if CYGWIN
+ else {
+ char *posix_path;
+ posix_path = alloca(cygwin_win32_to_posix_path_list_buf_size(path));
+ cygwin_win32_to_posix_path_list(path, posix_path);
+ path = posix_path;
+ }
+ #endif /* CYGWIN */
+
+ end = path + strlen(path);
+ for (next = path; next <= end; next = sep + 1) {
+ sep = strchr(next, ':');
+ if (sep == NULL)
+ sep = end;
+ plen = sep - next;
+ if (plen == 0) {
+ next = ".";
+ plen = 1;
+ }
+ if (plen + 1 + nlen + 1 > len)
+ return NULL;
+ memcpy(buf, next, plen);
+ buf[plen] = '/';
+ strcpy(buf + plen + 1, name);
+ if (access(buf, X_OK) == 0) {
+ if (stat(buf, &status) == 0 && S_ISREG(status.st_mode))
+ return buf;
+ }
+ }
+ return NULL;
+ }
+
+/*
+ * followsym(name, buf, len) -- follow symlink to final destination.
+ *
+ * If name specifies a file that is a symlink, resolves the symlink to
+ * its ultimate destination, and returns buf. Otherwise, returns NULL.
+ *
+ * Note that symlinks in the path to name do not make it a symlink.
+ *
+ * buf should be long enough to hold name.
+ */
+
+#define MAX_FOLLOWED_LINKS 24
+
+char *followsym(char *name, char *buf, size_t len) {
+ int i, n;
+ char *s, tbuf[MaxPath];
+
+ strcpy(buf, name);
+
+ for (i = 0; i < MAX_FOLLOWED_LINKS; i++) {
+ if ((n = readlink(buf, tbuf, sizeof(tbuf) - 1)) <= 0)
+ break;
+ tbuf[n] = 0;
+
+ if (tbuf[0] == '/') {
+ if (n < len)
+ strcpy(buf, tbuf);
+ else
+ return NULL;
+ }
+ else {
+ s = strrchr(buf, '/');
+ if (s != NULL)
+ s++;
+ else
+ s = buf;
+ if ((s - buf) + n < len)
+ strcpy(s, tbuf);
+ else
+ return NULL;
+ }
+ canonize(buf);
+ }
+
+ if (i > 0 && i < MAX_FOLLOWED_LINKS)
+ return buf;
+ else
+ return NULL;
+ }
+
+/*
+ * canonize(path) -- put file path in canonical form.
+ *
+ * Rewrites path in place, and returns it, after excising fragments of
+ * "." or "dir/..". All leading slashes are preserved but other extra
+ * slashes are deleted. The path never grows longer except for the
+ * special case of an empty path, which is rewritten to be ".".
+ *
+ * No check is made that any component of the path actually exists or
+ * that inner components are truly directories. From this it follows
+ * that if "foo" is any file path, canonizing "foo/.." produces the path
+ * of the directory containing "foo".
+ */
+
+char *canonize(char *path) {
+ int len;
+ char *root, *end, *in, *out, *prev;
+
+ /* initialize */
+ root = path; /* set barrier for trimming by ".." */
+ end = path + strlen(path); /* set end of input marker */
+ while (*root == '/') /* preserve all leading slashes */
+ root++;
+ in = root; /* input pointer */
+ out = root; /* output pointer */
+
+ /* scan string one component at a time */
+ while (in < end) {
+
+ /* count component length */
+ for (len = 0; in + len < end && in[len] != '/'; len++)
+ ;
+
+ /* check for ".", "..", or other */
+ if (len == 1 && *in == '.') /* just ignore "." */
+ in++;
+ else if (len == 2 && in[0] == '.' && in[1] == '.') {
+ in += 2; /* skip over ".." */
+ /* find start of previous component */
+ prev = out;
+ if (prev > root)
+ prev--; /* skip trailing slash */
+ while (prev > root && prev[-1] != '/')
+ prev--; /* find next slash or start of path */
+ if (prev < out - 1
+ && (out - prev != 3 || strncmp(prev, "../", 3) != 0)) {
+ out = prev; /* trim trailing component */
+ }
+ else {
+ memcpy(out, "../", 3); /* cannot trim, so must keep ".." */
+ out += 3;
+ }
+ }
+ else {
+ memmove(out, in, len); /* copy component verbatim */
+ out += len;
+ in += len;
+ *out++ = '/'; /* add output separator */
+ }
+
+ while (in < end && *in == '/') /* consume input separators */
+ in++;
+ }
+
+ /* final fixup */
+ if (out > root)
+ out--; /* trim trailing slash */
+ if (out == path)
+ *out++ = '.'; /* change null path to "." */
+ *out++ = '\0';
+ return path; /* return result */
+ }
diff --git a/src/common/op.txt b/src/common/op.txt
new file mode 100644
index 0000000..fa80fc5
--- /dev/null
+++ b/src/common/op.txt
@@ -0,0 +1,61 @@
+# This file contains tokens for symbols used in standard unary/binary syntax
+#
+# operator token unary/binary/special (see notes at bottom)
+
+ := ASSIGN _ b
+ :=: SWAP _ b
+ <- REVASSIGN _ b
+ <-> REVSWAP _ b
+ & (:= AUG) AND s b # unary form is for keywords
+ @ (:= AUG) AT s s # control structures for activation
+ ^ (:= AUG) CARET u b
+ || (:= AUG) CONCAT _ b
+ -- (:= AUG) DIFF _ b
+ === (:= AUG) EQUIV _ b
+ ** (:= AUG) INTER _ b
+ ||| (:= AUG) LCONCAT _ b
+ - (:= AUG) MINUS u b
+ % (:= AUG) MOD _ b
+ ~=== (:= AUG) NEQUIV _ b
+ = (:= AUG) NMEQ u b
+ >= (:= AUG) NMGE _ b
+ > (:= AUG) NMGT _ b
+ <= (:= AUG) NMLE _ b
+ < (:= AUG) NMLT _ b
+ ~= (:= AUG) NMNE _ b
+ + (:= AUG) PLUS u b
+ ? (:= AUG) QMARK u s # binary form is a control structure
+ == (:= AUG) SEQ _ b
+ >>= (:= AUG) SGE _ b
+ >> (:= AUG) SGT _ b
+ <<= (:= AUG) SLE _ b
+ << (:= AUG) SLT _ b
+ ~== (:= AUG) SNE _ b
+ / (:= AUG) SLASH u b
+ * (:= AUG) STAR u b
+ ++ (:= AUG) UNION _ b
+ \ BACKSLASH u s # binary form is a control structure
+ | BAR s s # unary & binary forms are control strutures
+ ! BANG u s # binary form is a control structure
+ . DOT u s # binary form is for field references
+ ~ TILDE u _
+
+
+# notes,
+#
+# (:= AUG) indicates that the binary operator has an augmented
+# assignment form. For example, the entry
+# + (:= AUG) PLUS ub
+# acts like two entries:
+# + PLUS ub
+# +:= AUGPLUS b
+# except that the compiler automatically combines the
+# implementations for + and := to implement +:=.
+#
+# 1st flag: _ - no unary form
+# u - unary operator implemented by .rtt file
+# s - unary form but special implementation within the compiler
+#
+# 2st flag: _ - no binary form
+# b - binary operator implemented by .rtt file
+# s - binary form but special implementation within the compiler
diff --git a/src/common/patchstr.c b/src/common/patchstr.c
new file mode 100644
index 0000000..7edc24c
--- /dev/null
+++ b/src/common/patchstr.c
@@ -0,0 +1,189 @@
+/*
+ * patchstr.c -- install a string at preconfigured points in an executable
+ *
+ * Usage: patchstr filename newstring -- to patch a file
+ * patchstr filename -- to report existing values
+ *
+ * Patchstr installs or changes strings in an executable file. It replaces
+ * null-terminated strings of up to 500 characters that are immediately
+ * preceded by the eighteen (unterminated) characters "%PatchStringHere->".
+ *
+ * If the new string is shorter than the old string, it is null-padded.
+ * If the old string is shorter, it must have suffient null padding to
+ * accept the new string.
+ *
+ * If no "newstring" is specified, existing values are printed.
+ *
+ * 4-Aug-91, 14-Feb-92 gmt
+ */
+
+#include "../h/rt.h"
+
+#undef strlen
+
+void report (char *filename);
+void patchstr (char *filename, char *newstring);
+int findpattern (FILE *f);
+int oldval (FILE *f, char *buf);
+
+/* guard pattern; first character must not reappear later */
+#define PATTERN "%PatchStringHere->"
+
+/* maximum string length */
+#define MAXLEN 500
+
+int exitcode = 0; /* exit code; nonzero if any problems */
+int nfound = 0; /* number of strings found */
+int nchanged = 0; /* number of strings changed */
+
+/*
+ * main program
+ */
+int main (argc, argv)
+int argc;
+char *argv[];
+ {
+ char *fname, *newstr;
+
+ if (argc < 2 || argc > 3) {
+ fprintf(stderr, "usage: %s filename [newstring]\n", argv[0]);
+ exit(1);
+ }
+ fname = argv[1];
+ newstr = argv[2];
+ if (newstr)
+ patchstr(fname, newstr);
+ else
+ report(fname);
+ exit(exitcode);
+ /*NOTREACHED*/
+ }
+
+/*
+ * report (filename) -- report existing string values in a file
+ */
+void report (fname)
+char *fname;
+ {
+ FILE *f;
+ long posn;
+ int n;
+ char buf[MAXLEN+2];
+
+ if (!(f = fopen(fname, "rb"))) { /* open read-only */
+ perror(fname);
+ exit(1);
+ }
+ while (findpattern(f)) { /* find occurrence of magic string */
+ nfound++;
+ posn = ftell(f); /* remember current location */
+ n = oldval(f, buf); /* check available space */
+ fseek(f, posn, 0); /* reposition to beginning of string */
+ if (n > MAXLEN) {
+ strcpy (buf+40, "... [unterminated]");
+ exitcode = 1;
+ }
+ printf("at byte %ld:\t%s\n", posn, buf); /* print value */
+ }
+ if (nfound == 0) {
+ fprintf(stderr, "flag pattern not found\n");
+ exitcode = 1;
+ }
+ }
+
+/*
+ * patchstr (filename, newstring) -- patch a file
+ */
+void patchstr (fname, newstr)
+char *fname, *newstr;
+ {
+ FILE *f;
+ long posn;
+ int n;
+ char buf[MAXLEN+2];
+
+ if (!(f = fopen(fname, "r+b"))) { /* open for read-and-update */
+ perror(fname);
+ exit(1);
+ }
+ while (findpattern(f)) { /* find occurrence of magic string */
+ nfound++;
+ posn = ftell(f); /* remember current location */
+ n = oldval(f, buf); /* check available space */
+ fseek(f, posn, 0); /* reposition to beginning of string */
+ if (n > MAXLEN) {
+ fprintf(stderr, "at byte %ld: unterminated string\n", posn);
+ exitcode = 1;
+ }
+ else if (n < (int)strlen(newstr)) {
+ fprintf (stderr, "at byte %ld: buffer only holds %d characters\n",
+ posn, n);
+ exitcode = 1;
+ }
+ else {
+ fputs(newstr, f); /* rewrite string with new value */
+ n -= strlen(newstr);
+ while (n-- > 0)
+ putc('\0', f); /* pad out with NUL characters */
+ nchanged++;
+ fseek(f, 0L, 1); /* re-enable reading */
+ }
+ }
+ if (nfound == 0) {
+ fprintf(stderr, "flag pattern not found\n");
+ exitcode = 1;
+ }
+ else
+ fprintf(stderr, "replaced %d occurrence%s\n", nchanged,
+ nchanged == 1 ? "" : "s");
+ }
+
+/*
+ * findpattern(f) - read until the magic pattern has been matched
+ *
+ * Return 1 if successful, 0 if not.
+ */
+int findpattern(f)
+FILE *f;
+ {
+ int c;
+ char *p;
+
+ p = PATTERN; /* p points to next char we're looking for */
+ for (;;) {
+ c = getc(f); /* get next char from file */
+ if (c == EOF)
+ return 0; /* if EOF, give up */
+ if (c != *p) {
+ p = PATTERN; /* if mismatch, start over */
+ if (c == *p) /* (but see if matched pattern start) */
+ p++;
+ continue;
+ }
+ if (*++p == '\0') /* if entire pattern matched */
+ return 1;
+ }
+ }
+
+/*
+ * oldval(f, buf) - read old string into buf and return usable length
+ *
+ * The "usable" (replaceable) length for rewriting takes null padding into
+ * account up to MAXLEN. A returned value greater than that indicates an
+ * unterminated string. The file will need to be repositioned after calling
+ * this function.
+ */
+int oldval(f, buf)
+FILE *f;
+char buf[MAXLEN+2];
+ {
+ int n;
+ char *e, *p;
+
+ n = fread(buf, 1, MAXLEN+1, f); /* read up to MAXLEN + null char */
+ e = buf + n; /* note end of read area */
+ n = strlen(buf); /* count string length proper */
+ for (p = buf + n + 1; p < e && *p == '\0'; p++)
+ n++; /* count nulls beyond end */
+ return n; /* return usable length */
+ }
diff --git a/src/common/pscript.icn b/src/common/pscript.icn
new file mode 100644
index 0000000..d9b2ee7
--- /dev/null
+++ b/src/common/pscript.icn
@@ -0,0 +1,44 @@
+# Program to sanitize Yacc output and minor changes to it to suit the Icon
+# translator.
+
+# procedure to skip optional white space.
+procedure sws()
+ return tab( many( ' \t' ) ) | ""
+end
+
+$ifdef _CYGWIN
+ $define YY_STATE "yystate"
+$else # _CYGWIN
+ $define YY_STATE "yy_state"
+$endif # _CYGWIN
+
+procedure main()
+ local line, prefix
+
+ while line := read() do {
+ if line == "#" then next # omit lone #s -- illegal now
+ else line ? {
+ if write(="#endif") then next # omit illegal stuff
+ else if (prefix := tab(find("yyerror"))) & ="yyerror" & sws() & ="(" &
+ sws() & ="\"" then {
+ #
+ # We are beyond the 'yyerror( "'. Write the part of the
+ # line before the call, then decide what to do about
+ # the error message that follows.
+ #
+ writes(prefix)
+ if ="syntax error\"" then
+ writes("yyerror(yychar, yylval, ", YY_STATE)
+ else if ="yacc stack overflow\"" then
+ writes("tsyserr(\"parse stack overflow\"")
+ else
+ writes("tsyserr(\"parser: ")
+ write(tab(0))
+ }
+ else if ="extern char *malloc(), *realloc();" then {
+ # let proto.h handle this declaration.
+ }
+ else write(tab(0))
+ }
+ }
+end
diff --git a/src/common/rtdb.c b/src/common/rtdb.c
new file mode 100644
index 0000000..5467244
--- /dev/null
+++ b/src/common/rtdb.c
@@ -0,0 +1,1692 @@
+/*
+ * Routines to read a data base of run-time information.
+ */
+#include "../h/gsupport.h"
+#include "../h/version.h"
+#include "icontype.h"
+
+/*
+ * GetInt - the next thing in the data base is an integer. Get it.
+ */
+#define GetInt(n, c)\
+ n = 0;\
+ while (isdigit(c)) {\
+ n = n * 10 + (c - '0');\
+ c = getc(db);\
+ }
+
+/*
+ * SkipWhSp - skip white space characters in the data base.
+ */
+#define SkipWhSp(c)\
+ while (isspace(c)) {\
+ if (c == '\n')\
+ ++dbline;\
+ c = getc(db);\
+ }
+
+/*
+ * prototypes for static functions.
+ */
+static int cmp_1_pre (int p1, int p2);
+static struct il_code *db_abstr (void);
+static void db_case (struct il_code *il, int num_cases);
+static void db_err3 (int fatal,char *s1,char *s2,char *s3);
+static int db_icntyp (void);
+static struct il_c *db_ilc (void);
+static struct il_c *db_ilcret (int il_c_type);
+static struct il_code *db_inlin (void);
+static struct il_code *db_ilvar (void);
+static int db_rtflg (void);
+static int db_tndtyp (void);
+static struct il_c *new_ilc (int il_c_type);
+static void quoted (int delim);
+
+extern char *progname; /* name of program using this module */
+
+static char *dbname; /* data base name */
+static FILE *db; /* data base file */
+static int dbline; /* line number current position in data base */
+static struct str_buf db_sbuf; /* string buffer */
+static int *type_map; /* map data base type codes to internal ones */
+static int *compnt_map; /* map data base component codes to internal */
+
+/*
+ * opendb - open data base and do other house keeping.
+ */
+int db_open(s, lrgintflg)
+char *s;
+char **lrgintflg;
+ {
+ char *msg_buf;
+ char *id;
+ int i, n;
+ register int c;
+ static int first_time = 1;
+
+ if (first_time) {
+ first_time = 0;
+ init_sbuf(&db_sbuf);
+ }
+ dbname = s;
+ dbline = 0;
+ *lrgintflg = NULL;
+ db = fopen(dbname, "rb");
+ if (db == NULL)
+ return 0;
+ ++dbline;
+
+ /*
+ * Make sure the version number in the data base is what is expected.
+ */
+ s = db_string();
+ if (strcmp(s, DVersion) != 0) {
+ msg_buf = alloc(35 + strlen(s) + strlen(progname) + strlen(DVersion));
+ sprintf(msg_buf, "found version %s, %s requires version %s",
+ s, progname, DVersion);
+ db_err1(1, msg_buf);
+ }
+
+ *lrgintflg = db_string(); /* large integer flag */
+
+ /*
+ * Create tables for mapping type codes and type component codes in
+ * the data base to those compiled into this program. The codes may
+ * be different if types have been added to the program since the
+ * data base was created.
+ */
+ type_map = alloc(num_typs * sizeof(int));
+ db_chstr("", "types"); /* verify section header */
+ c = getc(db);
+ SkipWhSp(c)
+ while (c == 'T') {
+ c = getc(db);
+ if (!isdigit(c))
+ db_err1(1, "expected type code");
+ GetInt(n, c)
+ if (n >= num_typs)
+ db_err1(1, "data base inconsistant with program, rebuild data base");
+ SkipWhSp(c)
+ if (c != ':')
+ db_err1(1, "expected ':'");
+ id = db_string();
+ for (i = 0; strcmp(id, icontypes[i].id) != 0; ++i)
+ if (i >= num_typs)
+ db_err2(1, "unknown type:", id);
+ type_map[n] = i;
+ c = getc(db);
+ SkipWhSp(c)
+ }
+ db_chstr("", "endsect");
+
+ compnt_map = alloc(num_cmpnts * sizeof(int));
+ db_chstr("", "components"); /* verify section header */
+ c = getc(db);
+ SkipWhSp(c)
+ while (c == 'C') {
+ c = getc(db);
+ if (!isdigit(c))
+ db_err1(1, "expected type component code");
+ GetInt(n, c)
+ if (n >= num_cmpnts)
+ db_err1(1, "data base inconsistant with program, rebuild data base");
+ SkipWhSp(c)
+ if (c != ':')
+ db_err1(1, "expected ':'");
+ id = db_string();
+ for (i = 0; strcmp(id, typecompnt[i].id) != 0; ++i)
+ if (i >= num_cmpnts)
+ db_err2(1, "unknown type component:", id);
+ compnt_map[n] = i;
+ c = getc(db);
+ SkipWhSp(c)
+ }
+ db_chstr("", "endsect");
+
+ return 1;
+ }
+
+/*
+ * db_close - close data base.
+ */
+void db_close()
+ {
+ if (fclose(db) != 0)
+ db_err2(0, "cannot close", dbname);
+ }
+
+/*
+ * db_string - get a white-space delimited string from the data base.
+ */
+char *db_string()
+ {
+ register int c;
+
+ /*
+ * Look for the start of the string; '$' starts a special indicator.
+ * Copy characters into string buffer until white space is found.
+ */
+ c = getc(db);
+ SkipWhSp(c);
+ if (c == EOF)
+ db_err1(1, "unexpected EOF");
+ if (c == '$')
+ return NULL;
+ while (!isspace(c) && c != EOF) {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ if (c == '\n')
+ ++dbline;
+ return str_install(&db_sbuf); /* put string in string table */
+ }
+
+/*
+ * db_impl - read basic header information for an operation into a structure
+ * and return it.
+ */
+struct implement *db_impl(oper_typ)
+int oper_typ;
+ {
+ register struct implement *ip;
+ register int c;
+ int i;
+ char *name;
+ long n;
+
+ /*
+ * Get operation name.
+ */
+ if ((name = db_string()) == NULL)
+ return NULL;
+
+ /*
+ * Create an internal structure to hold the data base entry.
+ */
+ ip = NewStruct(implement);
+ ip->blink = NULL;
+ ip->iconc_flgs = 0; /* reserved for internal use by compiler */
+ ip->oper_typ = oper_typ;
+ ip->name = name;
+ ip->op = NULL;
+
+ /*
+ * Get the function name prefix assigned to this operation.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (isalpha(c) || isdigit(c))
+ ip->prefix[0] = c;
+ else
+ db_err2(1, "invalid prefix for", ip->name);
+ c = getc(db);
+ if (isalpha(c) || isdigit(c))
+ ip->prefix[1] = c;
+ else
+ db_err2(1, "invalid prefix for", ip->name);
+
+ /*
+ * Get the number of parameters.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (!isdigit(c))
+ db_err2(1, "number of parameters missing for", ip->name);
+ GetInt(n, c)
+ ip->nargs = n;
+
+ /*
+ * Get the flags that indicate whether each parameter requires a dereferenced
+ * and/or undereferenced value, and whether the last parameter represents
+ * the end of a varargs list. Store the flags in an array.
+ */
+ if (n == 0)
+ ip->arg_flgs = NULL;
+ else
+ ip->arg_flgs = alloc(n * sizeof(int));
+ if (c != '(')
+ db_err2(1, "parameter flags missing for", ip->name);
+ c = getc(db);
+ for (i = 0; i < n; ++i) {
+ if (c == ',' || c == ')')
+ db_err2(1, "parameter flag missing for", ip->name);
+ ip->arg_flgs[i] = 0;
+ while (c != ',' && c != ')') {
+ switch (c) {
+ case 'u':
+ ip->arg_flgs[i] |= RtParm;
+ break;
+ case 'd':
+ ip->arg_flgs[i] |= DrfPrm;
+ break;
+ case 'v':
+ ip->arg_flgs[i] |= VarPrm;
+ break;
+ default:
+ db_err2(1, "invalid parameter flag for", ip->name);
+ }
+ c = getc(db);
+ }
+ if (c == ',')
+ c = getc(db);
+ }
+ if (c != ')')
+ db_err2(1, "invalid parameter flag list for", ip->name);
+
+ /*
+ * Get the result sequence indicator for the operation.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c != '{')
+ db_err2(1, "result sequence missing for", ip->name);
+ c = getc(db);
+ ip->resume = 0;
+ if (c == '}') {
+ ip->min_result = NoRsltSeq;
+ ip->max_result = NoRsltSeq;
+ }
+ else {
+ if (!isdigit(c))
+ db_err2(1, "invalid result sequence for", ip->name);
+ GetInt(n, c)
+ ip->min_result = n;
+ if (c != ',')
+ db_err2(1, "invalid result sequence for", ip->name);
+ c = getc(db);
+ if (c == '*') {
+ ip->max_result = UnbndSeq;
+ c = getc(db);
+ }
+ else if (isdigit(c)) {
+ GetInt(n, c)
+ ip->max_result = n;
+ }
+ else
+ db_err2(1, "invalid result sequence for", ip->name);
+ if (c == '+') {
+ ip->resume = 1;
+ c = getc(db);
+ }
+ if (c != '}')
+ db_err2(1, "invalid result sequence for", ip->name);
+ }
+
+ /*
+ * Get the flag indicating whether the operation contains returns, fails,
+ * or suspends.
+ */
+ ip->ret_flag = db_rtflg();
+
+ /*
+ * Get the t/f flag that indicates whether the operation explicitly
+ * uses the 'result' location.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 't':
+ ip->use_rslt = 1;
+ break;
+ case 'f':
+ ip->use_rslt = 0;
+ break;
+ default:
+ db_err2(1, "invalid 'result' use indicator for", ip->name);
+ }
+ return ip;
+ }
+
+/*
+ * db_code - read the RTL code for the body of an operation.
+ */
+void db_code(ip)
+struct implement *ip;
+ {
+ register int c;
+ char *s;
+ word n;
+ int var_type;
+ int i;
+
+ /*
+ * read the descriptive string.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c != '"')
+ db_err1(1, "operation description expected");
+ for (c = getc(db); c != '"' && c != '\n' && c != EOF; c = getc(db)) {
+ if (c == '\\') {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ AppChar(db_sbuf, c);
+ }
+ if (c != '"')
+ db_err1(1, "expected '\"'");
+ ip->comment = str_install(&db_sbuf);
+
+ /*
+ * Get the number of tended variables in the declare clause.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ ip->ntnds = n;
+
+ /*
+ * Read information about the tended variables into an array.
+ */
+ if (n == 0)
+ ip->tnds = NULL;
+ else
+ ip->tnds = alloc(n * sizeof(struct tend_var));
+ for (i = 0; i < n; ++i) {
+ var_type = db_tndtyp(); /* type of tended declaration */
+ ip->tnds[i].var_type = var_type;
+ ip->tnds[i].blk_name = NULL;
+ if (var_type == TndBlk) {
+ /*
+ * Tended block pointer declarations include a block type or '*' to
+ * indicate 'union block *'.
+ */
+ s = db_string();
+ if (s == NULL)
+ db_err1(1, "block name expected");
+ if (*s != '*')
+ ip->tnds[i].blk_name = s;
+ }
+ ip->tnds[i].init = db_ilc(); /* C code for declaration initializer */
+ }
+
+ /*
+ * Get the number of non-tended variables in the declare clause.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ ip->nvars = n;
+
+ /*
+ * Get each non-tended declaration and store it in an array.
+ */
+ if (n == 0)
+ ip->vars = NULL;
+ else
+ ip->vars = alloc(n * sizeof(struct ord_var));
+ for (i = 0; i < n; ++i) {
+ s = db_string(); /* variable name */
+ if (s == NULL)
+ db_err1(1, "variable name expected");
+ ip->vars[i].name = s;
+ ip->vars[i].dcl = db_ilc(); /* full declaration including name */
+ }
+
+ /*
+ * Get the executable RTL code.
+ */
+ ip->in_line = db_inlin();
+
+ /*
+ * We should be at the end of the operation.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c != '$')
+ db_err1(1, "expected $end");
+ }
+
+/*
+ * db_inlin - read in the in-line code (executable RTL code) for an operation.
+ */
+static struct il_code *db_inlin()
+ {
+ struct il_code *il = NULL;
+ register int c;
+ int i;
+ int indx;
+ int fall_thru;
+ int n, n1;
+
+ /*
+ * The following nested switch statements act as a trie for recognizing
+ * the prefix form of RTL code in the data base.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'a':
+ switch (getc(db)) {
+ case 'b': {
+ db_chstr("ab", "str");
+ il = new_il(IL_Abstr, 2); /* abstract type computation */
+ il->u[0].fld = db_abstr(); /* side effects */
+ il->u[1].fld = db_abstr(); /* return type */
+ break;
+ }
+ case 'c': {
+ db_chstr("ac", "ase");
+ il = new_il(IL_Acase, 5); /* arith_case */
+ il->u[0].fld = db_ilvar(); /* first variable */
+ il->u[1].fld = db_ilvar(); /* second variable */
+ il->u[2].fld = db_inlin(); /* C_integer action */
+ il->u[3].fld = db_inlin(); /* integer action */
+ il->u[4].fld = db_inlin(); /* C_double action */
+ break;
+ }
+ default:
+ db_err1(1, "expected abstr or acase");
+ }
+ break;
+
+ case 'b':
+ db_chstr("b", "lock");
+ c = getc(db);
+ SkipWhSp(c)
+ if (c == 't')
+ fall_thru = 1;
+ else
+ fall_thru = 0;
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Block, 3 + n); /* block of in-line C code */
+ il->u[0].n = fall_thru;
+ il->u[1].n = n; /* number of local tended */
+ for (i = 2; i - 2 < n; ++i)
+ il->u[i].n = db_tndtyp(); /* tended declaration */
+ il->u[i].c_cd = db_ilc(); /* C code */
+ break;
+
+ case 'c':
+ switch (getc(db)) {
+ case 'a': {
+ char prfx3;
+ int ret_val = 0;
+ int ret_flag;
+ int rslt = 0;
+ int num_sbuf;
+ int num_cbuf;
+
+ db_chstr("ca", "ll");
+ /*
+ * Call to body function. Get the letter used as the 3rd
+ * character of the function prefix.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ prfx3 = c;
+
+ /*
+ * Determine what the body function returns directly.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'i':
+ ret_val = RetInt; /* returns C integer */
+ break;
+ case 'd':
+ ret_val = RetDbl; /* returns C double */
+ break;
+ case 'n':
+ ret_val = RetNoVal; /* returns nothing directly */
+ break;
+ case 's':
+ ret_val = RetSig; /* returns a signal */
+ break;
+ default:
+ db_err1(1, "invalid indicator for type of return value");
+ }
+
+ /*
+ * Get the return/suspend/fail/fall-through flag.
+ */
+ c = getc(db);
+ ret_flag = db_rtflg();
+
+ /*
+ * Get the flag indicating whether the body function expects
+ * to have an explicit result location passed to it.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 't':
+ rslt = 1;
+ break;
+ case 'f':
+ rslt = 0;
+ break;
+ default:
+ db_err1(1, "t or f expected");
+ }
+
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(num_sbuf, c) /* number of cset buffers */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(num_cbuf, c) /* number of string buffers */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c) /* num args */
+
+ il = new_il(IL_Call, 8 + n * 2);
+ il->u[0].n = 0; /* reserved for internal use by compiler */
+ il->u[1].n = prfx3;
+ il->u[2].n = ret_val;
+ il->u[3].n = ret_flag;
+ il->u[4].n = rslt;
+ il->u[5].n = num_sbuf;
+ il->u[6].n = num_cbuf;
+ il->u[7].n = n;
+ indx = 8;
+
+ /*
+ * get the prototype parameter declarations and actual arguments.
+ */
+ n *= 2;
+ while (n--)
+ il->u[indx++].c_cd = db_ilc();
+ }
+ break;
+
+ case 'n':
+ if (getc(db) != 'v')
+ db_err1(1, "expected cnv1 or cnv2");
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_Cnv1, 2);
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ break;
+ case '2':
+ il = new_il(IL_Cnv2, 3);
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ il->u[2].c_cd = db_ilc(); /* destination */
+ break;
+ default:
+ db_err1(1, "expected cnv1 or cnv2");
+ }
+ break;
+
+ case 'o':
+ db_chstr("co", "nst");
+ il = new_il(IL_Const, 2); /* constant keyword */
+ il->u[0].n = db_icntyp(); /* type code */
+ c = getc(db);
+ SkipWhSp(c)
+ if (c == '"' || c == '\'') {
+ quoted(c);
+ c = getc(db); /* quoted literal without quotes */
+ }
+ else
+ while (c != EOF && !isspace(c)) {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ il->u[1].s = str_install(&db_sbuf); /* non-quoted values */
+ break;
+
+ default:
+ db_err1(1, "expected call, const, cnv1, or cnv2");
+ }
+ break;
+
+ case 'd':
+ if (getc(db) != 'e' || getc(db) != 'f')
+ db_err1(1, "expected def1 or def2");
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_Def1, 3); /* defaulting, no dest. field */
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ il->u[2].c_cd = db_ilc(); /* default value */
+ break;
+ case '2':
+ il = new_il(IL_Def2, 4); /* defaulting, with dest. field */
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* source */
+ il->u[2].c_cd = db_ilc(); /* default value */
+ il->u[3].c_cd = db_ilc(); /* destination */
+ break;
+ default:
+ db_err1(1, "expected dflt1 or dflt2");
+ }
+ break;
+
+ case 'r':
+ if (getc(db) != 'u' || getc(db) != 'n' || getc(db) != 'e' ||
+ getc(db) != 'r' || getc(db) != 'r')
+ db_err1(1, "expected runerr1 or runerr2");
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_Err1, 1); /* runerr, no offending value */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il->u[0].n = n; /* error number */
+ break;
+ case '2':
+ il = new_il(IL_Err2, 2); /* runerr, with offending value */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il->u[0].n = n; /* error number */
+ il->u[1].fld = db_ilvar(); /* variable */
+ break;
+ default:
+ db_err1(1, "expected runerr1 or runerr2");
+ }
+ break;
+
+ case 'i':
+ switch (getc(db)) {
+ case 'f':
+ switch (getc(db)) {
+ case '1':
+ il = new_il(IL_If1, 2); /* if-then */
+ il->u[0].fld = db_inlin(); /* condition */
+ il->u[1].fld = db_inlin(); /* then clause */
+ break;
+ case '2':
+ il = new_il(IL_If2, 3); /* if-then-else */
+ il->u[0].fld = db_inlin(); /* condition */
+ il->u[1].fld = db_inlin(); /* then clause */
+ il->u[2].fld = db_inlin(); /* else clause */
+ break;
+ default:
+ db_err1(1, "expected if1 or if2");
+ }
+ break;
+ case 's':
+ il = new_il(IL_Is, 2); /* type check */
+ il->u[0].n = db_icntyp(); /* type code */
+ il->u[1].fld = db_ilvar(); /* variable */
+ break;
+ default:
+ db_err1(1, "expected if1, if2, or is");
+ }
+ break;
+
+ case 'l':
+ switch (getc(db)) {
+ case 'c':
+ db_chstr("lc", "ase");
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Lcase, 2 + 2 * n); /* length case */
+ il->u[0].n = n; /* number of cases */
+ indx = 1;
+ while (n--) {
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n1, c)
+ il->u[indx++].n = n1; /* selection number */
+ il->u[indx++].fld = db_inlin(); /* action */
+ }
+ il->u[indx].fld = db_inlin(); /* default */
+ break;
+
+ case 's':
+ if (getc(db) != 't')
+ db_err1(1, "expected lst");
+ il = new_il(IL_Lst, 2); /* sequence of code parts */
+ il->u[0].fld = db_inlin(); /* 1st part */
+ il->u[1].fld = db_inlin(); /* 2nd part */
+ break;
+
+ default:
+ db_err1(1, "expected lcase or lst");
+ }
+ break;
+
+ case 'n':
+ db_chstr("n", "il");
+ il = NULL;
+ break;
+
+ case 't': {
+ struct il_code *var;
+
+ if (getc(db) != 'c' || getc(db) != 'a' || getc(db) != 's' ||
+ getc(db) != 'e')
+ db_err1(1, "expected tcase1 or tcase2");
+ switch (getc(db)) {
+ case '1':
+ var = db_ilvar();
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Tcase1, 3 * n + 2); /* type case, no default */
+ il->u[0].fld = var; /* variable */
+ db_case(il, n); /* get cases */
+ break;
+
+ case '2':
+ var = db_ilvar();
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il = new_il(IL_Tcase2, 3 * n + 3); /* type case, with default */
+ il->u[0].fld = var; /* variable */
+ db_case(il, n); /* get cases */
+ il->u[3 * n + 2].fld = db_inlin(); /* default */
+ break;
+
+ default:
+ db_err1(1, "expected tcase1 or tcase2");
+ }
+ }
+ break;
+
+ case '!':
+ il = new_il(IL_Bang, 1); /* negated condition */
+ il->u[0].fld = db_inlin(); /* condition */
+ break;
+
+ case '&':
+ if (getc(db) != '&')
+ db_err1(1, "expected &&");
+ il = new_il(IL_And, 2); /* && (conjunction) */
+ il->u[0].fld = db_inlin(); /* 1st operand */
+ il->u[1].fld = db_inlin(); /* 2nd operand */
+ break;
+
+ default:
+ db_err1(1, "syntax error");
+ }
+ return il;
+ }
+
+/*
+ * db_rtflg - get the sequence of 4 [or 5] flags that indicate whether code
+ * for a operation [or body function] returns, fails, suspends, has error
+ * failure, [or execution falls through the code].
+ */
+static int db_rtflg()
+ {
+ register int c;
+ int ret_flag;
+
+ /*
+ * The presence of each flag is indicated by a unique character. Its absence
+ * indicated by '_'.
+ */
+ ret_flag = 0;
+ c = getc(db);
+ SkipWhSp(c)
+ if (c == 'f')
+ ret_flag |= DoesFail;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 'r')
+ ret_flag |= DoesRet;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 's')
+ ret_flag |= DoesSusp;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 'e')
+ ret_flag |= DoesEFail;
+ else if (c != '_')
+ db_err1(1, "invalid return indicator");
+ c = getc(db);
+ if (c == 't')
+ ret_flag |= DoesFThru;
+ else if (c != '_' && c != ' ')
+ db_err1(1, "invalid return indicator");
+ return ret_flag;
+ }
+
+/*
+ * db_case - get the cases for a type_case statement from the data base.
+ */
+static void db_case(il, num_cases)
+struct il_code *il;
+int num_cases;
+ {
+ register int c;
+ int *typ_vect;
+ int i, j;
+ int num_types;
+ int indx;
+
+ il->u[1].n = num_cases; /* number of cases */
+ indx = 2;
+ for (i = 0; i < num_cases; ++i) {
+ /*
+ * Determine the number of types in this case then store the
+ * type codes in an array.
+ */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(num_types, c)
+ il->u[indx++].n = num_types;
+ typ_vect = alloc(num_types * sizeof(int));
+ il->u[indx++].vect = typ_vect;
+ for (j = 0; j < num_types; ++j)
+ typ_vect[j] = db_icntyp(); /* type code */
+
+ il->u[indx++].fld = db_inlin(); /* action */
+ }
+ }
+
+/*
+ * db_ilvar - get a symbol table index for a simple variable or a
+ * subscripted variable from the data base.
+ */
+static struct il_code *db_ilvar()
+ {
+ struct il_code *il;
+ register int c;
+ int n;
+
+ c = getc(db);
+ SkipWhSp(c)
+
+ if (isdigit(c)) {
+ /*
+ * Simple variable: just a symbol table index.
+ */
+ il = new_il(IL_Var, 1);
+ GetInt(n, c)
+ il->u[0].n = n; /* symbol table index */
+ }
+ else {
+ if (c != '[')
+ db_err1(1, "expected symbol table index or '['");
+ /*
+ * Subscripted variable: symbol table index and subscript.
+ */
+ il = new_il(IL_Subscr, 2);
+ c = getc(db);
+ SkipWhSp(c);
+ GetInt(n, c)
+ il->u[0].n = n; /* symbol table index */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c)
+ il->u[1].n = n; /* subscripting index */
+ }
+ return il;
+ }
+
+/*
+ * db_abstr - get abstract type computations from the data base.
+ */
+static struct il_code *db_abstr()
+ {
+ struct il_code *il = NULL;
+ register int c;
+ word typcd;
+ word indx;
+ int n;
+ int nargs;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'l':
+ db_chstr("l", "st");
+ il = new_il(IL_Lst, 2); /* sequence of code parts */
+ il->u[0].fld = db_abstr(); /* 1st part */
+ il->u[1].fld = db_abstr(); /* 2nd part */
+ break;
+
+ case 'n':
+ switch (getc(db)) {
+ case 'e':
+ if (getc(db) != 'w')
+ db_err1(1, "expected new");
+ typcd = db_icntyp();
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(nargs, c)
+ il = new_il(IL_New, 2 + nargs); /* new structure create here */
+ il->u[0].n = typcd; /* type code */
+ il->u[1].n = nargs; /* number of args */
+ indx = 2;
+ while (nargs--)
+ il->u[indx++].fld = db_abstr(); /* argument for component */
+ break;
+ case 'i':
+ if (getc(db) != 'l')
+ db_err1(1, "expected nil");
+ il = NULL;
+ break;
+ default:
+ db_err1(1, "expected new or nil");
+ }
+ break;
+
+ case 's':
+ db_chstr("s", "tore");
+ il = new_il(IL_Store, 1); /* abstract store */
+ il->u[0].fld = db_abstr(); /* type to "dereference" */
+ break;
+
+ case 't':
+ db_chstr("t", "yp");
+ il = new_il(IL_IcnTyp, 1); /* explicit type */
+ il->u[0].n = db_icntyp(); /* type code */
+ break;
+
+ case 'v':
+ db_chstr("v", "artyp");
+ il = new_il(IL_VarTyp, 1); /* variable */
+ il->u[0].fld = db_ilvar(); /* symbol table index, etc */
+ break;
+
+ case '.':
+ il = new_il(IL_Compnt, 2); /* component access */
+ il->u[0].fld = db_abstr(); /* type being accessed */
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'f':
+ il->u[1].n = CM_Fields;
+ break;
+ case 'C':
+ c = getc(db);
+ GetInt(n, c)
+ il->u[1].n = compnt_map[n];
+ break;
+ default:
+ db_err1(1, "expected component code");
+ }
+ break;
+
+ case '=':
+ il = new_il(IL_TpAsgn, 2); /* assignment (side effect) */
+ il->u[0].fld = db_abstr(); /* left-hand-side */
+ il->u[1].fld = db_abstr(); /* right-hand-side */
+ break;
+
+ case '+':
+ if (getc(db) != '+')
+ db_err1(1, "expected ++");
+ il = new_il(IL_Union, 2); /* ++ (union) */
+ il->u[0].fld = db_abstr(); /* 1st operand */
+ il->u[1].fld = db_abstr(); /* 2nd operand */
+ break;
+
+ case '*':
+ if (getc(db) != '*')
+ db_err1(1, "expected **");
+ il = new_il(IL_Inter, 2); /* ** (intersection) */
+ il->u[0].fld = db_abstr(); /* 1st operand */
+ il->u[1].fld = db_abstr(); /* 2nd operand */
+ break;
+ }
+ return il;
+ }
+
+/*
+ * db_ilc - read a piece of in-line C code.
+ */
+static struct il_c *db_ilc()
+ {
+ register int c;
+ int old_c;
+ word n;
+ struct il_c *base = NULL;
+ struct il_c **nxtp = &base;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case '$':
+ /*
+ * This had better be the starting $c.
+ */
+ c = getc(db);
+ if (c == 'c') {
+ c = getc(db);
+ for (;;) {
+ SkipWhSp(c)
+ if (c == '$') {
+ c = getc(db);
+ switch (c) {
+ case 'c': /* $cb or $cgoto <cond> <lbl num> */
+ c = getc(db);
+ switch (c) {
+ case 'b':
+ *nxtp = new_ilc(ILC_CBuf);
+ c = getc(db);
+ break;
+ case 'g':
+ db_chstr("$cg", "oto");
+ *nxtp = new_ilc(ILC_CGto);
+#ifdef MultiThread
+ #undef code
+#endif /* MultiThead */
+ (*nxtp)->code[0] = db_ilc();
+ c = getc(db);
+ SkipWhSp(c);
+ if (!isdigit(c))
+ db_err1(1, "$cgoto: expected label number");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ default:
+ db_err1(1, "expected $cb or $cgoto");
+ }
+ break;
+ case 'e':
+ c = getc(db);
+ if (c == 'f') { /* $efail */
+ db_chstr("$ef", "ail");
+ *nxtp = new_ilc(ILC_EFail);
+ c = getc(db);
+ break;
+ }
+ else
+ return base; /* $e */
+ case 'f': /* $fail */
+ db_chstr("$f", "ail");
+ *nxtp = new_ilc(ILC_Fail);
+ c = getc(db);
+ break;
+ case 'g': /* $goto <lbl num> */
+ db_chstr("$g", "oto");
+ *nxtp = new_ilc(ILC_Goto);
+ c = getc(db);
+ SkipWhSp(c);
+ if (!isdigit(c))
+ db_err1(1, "$goto: expected label number");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ case 'l': /* $lbl <lbl num> */
+ db_chstr("$l", "bl");
+ *nxtp = new_ilc(ILC_Lbl);
+ c = getc(db);
+ SkipWhSp(c);
+ if (!isdigit(c))
+ db_err1(1, "$lbl: expected label number");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ case 'm': /* $m[d]<indx> */
+ *nxtp = new_ilc(ILC_Mod);
+ c = getc(db);
+ if (c == 'd') {
+ (*nxtp)->s = "d";
+ c = getc(db);
+ }
+ if (isdigit(c)) {
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ }
+ else if (c == 'r') {
+ (*nxtp)->n = RsltIndx;
+ c = getc(db);
+ }
+ else
+ db_err1(1, "$m: expected symbol table index");
+ break;
+ case 'r': /* $r[d]<indx> or $ret ... */
+ c = getc(db);
+ if (isdigit(c) || c == 'd') {
+ *nxtp = new_ilc(ILC_Ref);
+ if (c == 'd') {
+ (*nxtp)->s = "d";
+ c = getc(db);
+ }
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ }
+ else if (c == 'r') {
+ *nxtp = new_ilc(ILC_Ref);
+ (*nxtp)->n = RsltIndx;
+ c = getc(db);
+ }
+ else {
+ if (c != 'e' || getc(db) != 't')
+ db_err1(1, "expected $ret");
+ *nxtp = db_ilcret(ILC_Ret);
+ c = getc(db);
+ }
+ break;
+ case 's': /* $sb or $susp ... */
+ c = getc(db);
+ switch (c) {
+ case 'b':
+ *nxtp = new_ilc(ILC_SBuf);
+ c = getc(db);
+ break;
+ case 'u':
+ db_chstr("$su", "sp");
+ *nxtp = db_ilcret(ILC_Susp);
+ c = getc(db);
+ break;
+ default:
+ db_err1(1, "expected $sb or $susp");
+ }
+ break;
+ case 't': /* $t[d]<indx> */
+ *nxtp = new_ilc(ILC_Tend);
+ c = getc(db);
+ if (!isdigit(c))
+ db_err1(1, "$t: expected index");
+ GetInt(n, c);
+ (*nxtp)->n = n;
+ break;
+ case '{':
+ *nxtp = new_ilc(ILC_LBrc);
+ c = getc(db);
+ break;
+ case '}':
+ *nxtp = new_ilc(ILC_RBrc);
+ c = getc(db);
+ break;
+ default:
+ db_err1(1, "invalid $ escape in C code");
+ }
+ }
+ else {
+ /*
+ * Arbitrary code - gather into a string.
+ */
+ while (c != '$') {
+ if (c == '"' || c == '\'') {
+ quoted(c);
+ c = getc(db);
+ }
+ if (c == '\n')
+ ++dbline;
+ if (c == EOF)
+ db_err1(1, "unexpected EOF in C code");
+ old_c = c;
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ if (old_c == ' ')
+ while (c == ' ')
+ c = getc(db);
+ }
+ *nxtp = new_ilc(ILC_Str);
+ (*nxtp)->s = str_install(&db_sbuf);
+ }
+ nxtp = &(*nxtp)->next;
+ }
+ }
+ break;
+ case 'n':
+ db_chstr("n", "il");
+ return NULL;
+ }
+ db_err1(1, "expected C code of the form $c ... $e or nil");
+ /*NOTREACHED*/
+ return 0; /* avoid gcc warning */
+ }
+
+/*
+ * quoted - get the string for a quoted literal. The first quote mark
+ * has been read.
+ */
+static void quoted(delim)
+int delim;
+ {
+ register int c;
+
+ AppChar(db_sbuf, delim);
+ c = getc(db);
+ while (c != delim && c != EOF) {
+ if (c == '\\') {
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ if (c == EOF)
+ db_err1(1, "unexpected EOF in quoted literal");
+ }
+ AppChar(db_sbuf, c);
+ c = getc(db);
+ }
+ if (c == EOF)
+ db_err1(1, "unexpected EOF in quoted literal");
+ AppChar(db_sbuf, c);
+ }
+
+/*
+ * db_ilcret - get the in-line C code on a return or suspend statement.
+ */
+static struct il_c *db_ilcret(il_c_type)
+int il_c_type;
+ {
+ struct il_c *ilc;
+ int c;
+ int n;
+ int i;
+
+ ilc = new_ilc(il_c_type);
+ ilc->n = db_icntyp(); /* kind of return expression */
+ c = getc(db);
+ SkipWhSp(c)
+ GetInt(n, c) /* number of arguments in this expression */
+ for (i = 0; i < n; ++i)
+ ilc->code[i] = db_ilc(); /* an argument to the return expression */
+ return ilc;
+ }
+
+/*
+ * db_tndtyp - get the indication for the type of a tended declaration.
+ */
+static int db_tndtyp()
+ {
+ int c;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'b':
+ db_chstr("b", "lkptr");
+ return TndBlk; /* tended block pointer */
+ case 'd':
+ db_chstr("d", "esc");
+ return TndDesc; /* tended descriptor */
+ case 's':
+ db_chstr("s", "tr");
+ return TndStr; /* tended string */
+ default:
+ db_err1(1, "expected blkptr, desc, or str");
+ /* NOTREACHED */
+ }
+ /* NOTREACHED */
+ return 0; /* avoid gcc warning */
+ }
+
+/*
+ * db_icntyp - get a type code from the data base.
+ */
+static int db_icntyp()
+ {
+ int c;
+ int n;
+
+ c = getc(db);
+ SkipWhSp(c)
+ switch (c) {
+ case 'T':
+ c = getc(db);
+ GetInt(n, c)
+ if (n < num_typs)
+ return type_map[n]; /* type code from specification system */
+ break;
+ case 'a':
+ return TypAny; /* a - any type */
+ case 'c':
+ switch (getc(db)) {
+ case 'i':
+ return TypCInt; /* ci - C integer */
+ case 'd':
+ return TypCDbl; /* cd - C double */
+ case 's':
+ return TypCStr; /* cs - C string */
+ }
+ break;
+ case 'd':
+ return RetDesc; /* d - descriptor on return statement */
+ case 'e':
+ switch (getc(db)) {
+ case 'c':
+ if (getc(db) == 'i')
+ return TypECInt; /* eci - exact C integer */
+ break;
+ case 'i':
+ return TypEInt; /* ei - exact integer */
+ case ' ':
+ case '\n':
+ case '\t':
+ return TypEmpty; /* e - empty type */
+ }
+ break;
+ case 'n':
+ if (getc(db) == 'v')
+ return RetNVar; /* nv - named variable on return */
+ break;
+ case 'r':
+ if (getc(db) == 'n')
+ return RetNone; /* rn - nothing explicitly returned */
+ break;
+ case 's':
+ if (getc(db) == 'v')
+ return RetSVar; /* sv - structure variable on return */
+ break;
+ case 't':
+ switch (getc(db)) {
+ case 'c':
+ return TypTCset; /* tc - temporary cset */
+ case 's':
+ return TypTStr; /* ts - temporary string */
+ }
+ break;
+ case 'v':
+ return TypVar; /* v - variable */
+ }
+ db_err1(1, "invalid type code");
+ /* NOTREACHED */
+ return 0; /* avoid gcc warning */
+ }
+
+/*
+ * new_ilc - allocate a new structure to hold a piece of in-line C code.
+ */
+static struct il_c *new_ilc(il_c_type)
+int il_c_type;
+ {
+ struct il_c *ilc;
+ int i;
+
+ ilc = NewStruct(il_c);
+ ilc->next = NULL;
+ ilc->il_c_type = il_c_type;
+ for (i = 0; i < 3; ++i)
+ ilc->code[i] = NULL;
+ ilc->n = 0;
+ ilc->s = NULL;
+ return ilc;
+ }
+
+/*
+ * new_il - allocate a new structure with "size" fields to hold a piece of
+ * RTL code.
+ */
+struct il_code *new_il(il_type, size)
+int il_type;
+int size;
+ {
+ struct il_code *il;
+
+ il = alloc(sizeof(struct il_code) + (size-1) * sizeof(union il_fld));
+ il->il_type = il_type;
+ return il;
+ }
+
+/*
+ * db_dscrd - discard an implementation up to $end, skipping the in-line
+ * RTL code.
+ */
+void db_dscrd(ip)
+struct implement *ip;
+ {
+ char state; /* how far along we are at recognizing $end */
+
+ free(ip);
+ state = '\0';
+ for (;;) {
+ switch (getc(db)) {
+ case '$':
+ state = '$';
+ continue;
+ case 'e':
+ if (state == '$') {
+ state = 'e';
+ continue;
+ }
+ break;
+ case 'n':
+ if (state == 'e') {
+ state = 'n';
+ continue;
+ }
+ break;
+ case 'd':
+ if (state == 'n')
+ return;
+ break;
+ case '\n':
+ ++dbline;
+ break;
+ case EOF:
+ db_err1(1, "unexpected EOF");
+ }
+ state = '\0';
+ }
+ }
+
+/*
+ * db_chstr - we are expecting a specific string. We may already have
+ * read a prefix of it.
+ */
+void db_chstr(prefix, suffix)
+char *prefix;
+char *suffix;
+ {
+ int c;
+
+ c = getc(db);
+ SkipWhSp(c)
+
+ for (;;) {
+ if (*suffix == '\0' && (isspace(c) || c == EOF)) {
+ if (c == '\n')
+ ++dbline;
+ return;
+ }
+ else if (*suffix != c)
+ break;
+ c = getc(db);
+ ++suffix;
+ }
+ db_err3(1, "expected:", prefix, suffix);
+ }
+
+/*
+ * db_tbl - fill in a hash table of implementation information for the
+ * given section.
+ */
+int db_tbl(section, tbl)
+char *section;
+struct implement **tbl;
+ {
+ struct implement *ip;
+ int num_added = 0;
+ unsigned hashval;
+
+ /*
+ * Get past the section header.
+ */
+ db_chstr("", section);
+
+ /*
+ * Create an entry in the hash table for each entry in the data base.
+ * If multiple data bases are loaded into one hash table, use the
+ * first entry encountered for each operation.
+ */
+ while ((ip = db_impl(toupper(section[0]))) != NULL) {
+ if (db_ilkup(ip->name, tbl) == NULL) {
+ db_code(ip);
+ hashval = IHasher(ip->name);
+ ip->blink = tbl[hashval];
+ tbl[hashval] = ip;
+ ++num_added;
+ db_chstr("", "end");
+ }
+ else
+ db_dscrd(ip);
+ }
+ db_chstr("", "endsect");
+ return num_added;
+ }
+
+/*
+ * db_ilkup - look up id in a table of implementation information and return
+ * pointer it or NULL if it is not there.
+ */
+struct implement *db_ilkup(id, tbl)
+char *id;
+struct implement **tbl;
+ {
+ register struct implement *ptr;
+
+ ptr = tbl[IHasher(id)];
+ while (ptr != NULL && ptr->name != id)
+ ptr = ptr->blink;
+ return ptr;
+ }
+
+/*
+ * nxt_pre - assign next prefix. A prefix consists of n characters each from
+ * the range 0-9 and a-z, at least one of which is a digit.
+ *
+ */
+void nxt_pre(pre, nxt, n)
+char *pre;
+char *nxt;
+int n;
+ {
+ int i, num_dig;
+
+ if (nxt[0] == '\0') {
+ fprintf(stderr, "out of unique prefixes\n");
+ exit(EXIT_FAILURE);
+ }
+
+ /*
+ * copy the next prefix into the output string.
+ */
+ for (i = 0; i < n; ++i)
+ pre[i] = nxt[i];
+
+ /*
+ * Increment next prefix. First, determine how many digits there are in
+ * the current prefix.
+ */
+ num_dig = 0;
+ for (i = 0; i < n; ++i)
+ if (isdigit(nxt[i]))
+ ++num_dig;
+
+ for (i = n - 1; i >= 0; --i) {
+ switch (nxt[i]) {
+ case '9':
+ /*
+ * If there is at least one other digit, increment to a letter.
+ * Otherwise, start over at zero and continue to the previous
+ * character in the prefix.
+ */
+ if (num_dig > 1) {
+ nxt[i] = 'a';
+ return;
+ }
+ else
+ nxt[i] = '0';
+ break;
+
+ case 'z':
+ /*
+ * Start over at zero and continue to previous character in the
+ * prefix.
+ */
+ nxt[i] = '0';
+ ++num_dig;
+ break;
+ default:
+ ++nxt[i];
+ return;
+ }
+ }
+
+ /*
+ * Indicate that there are no more prefixes.
+ */
+ nxt[0] = '\0';
+ }
+
+/*
+ * cmp_pre - lexically compare 2-character prefixes.
+ */
+int cmp_pre(pre1, pre2)
+char *pre1;
+char *pre2;
+ {
+ int cmp;
+
+ cmp = cmp_1_pre(pre1[0], pre2[0]);
+ if (cmp == 0)
+ return cmp_1_pre(pre1[1], pre2[1]);
+ else
+ return cmp;
+ }
+
+/*
+ * cmp_1_pre - lexically compare 1 character of a prefix.
+ */
+static int cmp_1_pre(p1, p2)
+int p1;
+int p2;
+ {
+ if (isdigit(p1)) {
+ if (isdigit(p2))
+ return p1 - p2;
+ else
+ return -1;
+ }
+ else {
+ if (isdigit(p2))
+ return 1;
+ else
+ return p1 - p2;
+ }
+ }
+
+/*
+ * db_err1 - print a data base error message in the form of 1 string.
+ */
+void db_err1(fatal, s)
+int fatal;
+char *s;
+ {
+ if (fatal)
+ fprintf(stderr, "error, ");
+ else
+ fprintf(stderr, "warning, ");
+ fprintf(stderr, "data base \"%s\", line %d - %s\n", dbname, dbline, s);
+ if (fatal)
+ exit(EXIT_FAILURE);
+ }
+
+/*
+ * db_err2 - print a data base error message in the form of 2 strings.
+ */
+void db_err2(fatal, s1, s2)
+int fatal;
+char *s1;
+char *s2;
+ {
+ if (fatal)
+ fprintf(stderr, "error, ");
+ else
+ fprintf(stderr, "warning, ");
+ fprintf(stderr, "data base \"%s\", line %d - %s %s\n", dbname, dbline, s1,
+ s2);
+ if (fatal)
+ exit(EXIT_FAILURE);
+ }
+
+/*
+ * db_err3 - print a data base error message in the form of 3 strings.
+ */
+static void db_err3(fatal, s1, s2, s3)
+int fatal;
+char *s1;
+char *s2;
+char *s3;
+ {
+ if (fatal)
+ fprintf(stderr, "error, ");
+ else
+ fprintf(stderr, "warning, ");
+ fprintf(stderr, "data base \"%s\", line %d - %s %s%s\n", dbname, dbline, s1,
+ s2, s3);
+ if (fatal)
+ exit(EXIT_FAILURE);
+ }
diff --git a/src/common/strtbl.c b/src/common/strtbl.c
new file mode 100644
index 0000000..129dc94
--- /dev/null
+++ b/src/common/strtbl.c
@@ -0,0 +1,207 @@
+/*
+ * The functions in this file maintain a hash table of strings and manage
+ * string buffers.
+ */
+#include "../h/gsupport.h"
+
+/*
+ * Prototype for static function.
+ */
+static int streq (int len, char *s1, char *s2);
+
+/*
+ * Entry in string table.
+ */
+struct str_entry {
+ char *s; /* string */
+ int length; /* length of string */
+ struct str_entry *next;
+ };
+
+#define SBufSize 1024 /* initial size of a string buffer */
+#define StrTblSz 149 /* size of string hash table */
+static struct str_entry **str_tbl = NULL; /* string hash table */
+
+/*
+ * init_str - initialize string hash table.
+ */
+void init_str()
+ {
+ int h;
+
+ if (str_tbl == NULL) {
+ str_tbl = alloc(StrTblSz * sizeof(struct str_entry *));
+ for (h = 0; h < StrTblSz; ++h)
+ str_tbl[h] = NULL;
+ }
+ }
+
+/*
+ * free_stbl - free string table.
+ */
+void free_stbl()
+ {
+ struct str_entry *se, *se1;
+ int h;
+
+ for (h = 0; h < StrTblSz; ++h)
+ for (se = str_tbl[h]; se != NULL; se = se1) {
+ se1 = se->next;
+ free((char *)se);
+ }
+
+ free((char *)str_tbl);
+ str_tbl = NULL;
+ }
+
+/*
+ * init_sbuf - initialize a new sbuf struct, allocating an initial buffer.
+ */
+void init_sbuf(sbuf)
+struct str_buf *sbuf;
+ {
+ sbuf->size = SBufSize;
+ sbuf->frag_lst = alloc(sizeof(struct str_buf_frag) + (SBufSize - 1));
+ sbuf->frag_lst->next = NULL;
+ sbuf->strtimage = sbuf->frag_lst->s;
+ sbuf->endimage = sbuf->strtimage;
+ sbuf->end = sbuf->strtimage + SBufSize;
+ }
+
+/*
+ * clear_sbuf - free string buffer storage.
+ */
+void clear_sbuf(sbuf)
+struct str_buf *sbuf;
+ {
+ struct str_buf_frag *sbf, *sbf1;
+
+ for (sbf = sbuf->frag_lst; sbf != NULL; sbf = sbf1) {
+ sbf1 = sbf->next;
+ free((char *)sbf);
+ }
+ sbuf->frag_lst = NULL;
+ sbuf->strtimage = NULL;
+ sbuf->endimage = NULL;
+ sbuf->end = NULL;
+ }
+
+/*
+ * new_sbuf - allocate a new buffer for a sbuf struct, copying the partially
+ * created string from the end of full buffer to the new one.
+ */
+void new_sbuf(sbuf)
+struct str_buf *sbuf;
+ {
+ struct str_buf_frag *sbf;
+ char *s1, *s2;
+
+ /*
+ * The new buffer is larger than the old one to insure that any
+ * size string can be buffered.
+ */
+ sbuf->size *= 2;
+ s1 = sbuf->strtimage;
+ sbf = alloc(sizeof(struct str_buf_frag) + (sbuf->size - 1));
+ sbf->next = sbuf->frag_lst;
+ sbuf->frag_lst = sbf;
+ sbuf->strtimage = sbf->s;
+ s2 = sbuf->strtimage;
+ while (s1 < sbuf->endimage)
+ *s2++ = *s1++;
+ sbuf->endimage = s2;
+ sbuf->end = sbuf->strtimage + sbuf->size;
+ }
+
+/*
+ * spec_str - install a special string (null terminated) in the string table.
+ */
+char *spec_str(s)
+char *s;
+ {
+ struct str_entry *se;
+ register char *s1;
+ register int l;
+ register int h;
+
+ h = 0;
+ l = 1;
+ for (s1 = s; *s1 != '\0'; ++s1) {
+ h += *s1 & 0377;
+ ++l;
+ }
+ h %= StrTblSz;
+ for (se = str_tbl[h]; se != NULL; se = se->next)
+ if (l == se->length && streq(l, s, se->s))
+ return se->s;
+ se = NewStruct(str_entry);
+ se->s = s;
+ se->length = l;
+ se->next = str_tbl[h];
+ str_tbl[h] = se;
+ return s;
+ }
+
+/*
+ * str_install - find out if the string at the end of the buffer is in
+ * the string table. If not, put it there. Return a pointer to the
+ * string in the table.
+ */
+char *str_install(sbuf)
+struct str_buf *sbuf;
+ {
+ int h;
+ struct str_entry *se;
+ register char *s;
+ register char *e;
+ int l;
+
+ AppChar(*sbuf, '\0'); /* null terminate the buffered copy of the string */
+ s = sbuf->strtimage;
+ e = sbuf->endimage;
+
+ /*
+ * Compute hash value.
+ */
+ h = 0;
+ while (s < e)
+ h += *s++ & 0377;
+ h %= StrTblSz;
+ s = sbuf->strtimage;
+ l = e - s;
+ for (se = str_tbl[h]; se != NULL; se = se->next)
+ if (l == se->length && streq(l, s, se->s)) {
+ /*
+ * A copy of the string is already in the table. Delete the copy
+ * in the buffer.
+ */
+ sbuf->endimage = s;
+ return se->s;
+ }
+
+ /*
+ * The string is not in the table. Add the copy from the buffer to the
+ * table.
+ */
+ se = NewStruct(str_entry);
+ se->s = s;
+ se->length = l;
+ sbuf->strtimage = e;
+ se->next = str_tbl[h];
+ str_tbl[h] = se;
+ return se->s;
+ }
+
+/*
+ * streq - compare s1 with s2 for len bytes, and return 1 for equal,
+ * 0 for not equal.
+ */
+static int streq(len, s1, s2)
+register int len;
+register char *s1, *s2;
+ {
+ while (len--)
+ if (*s1++ != *s2++)
+ return 0;
+ return 1;
+ }
diff --git a/src/common/time.c b/src/common/time.c
new file mode 100644
index 0000000..84d8fe1
--- /dev/null
+++ b/src/common/time.c
@@ -0,0 +1,34 @@
+#include "../h/gsupport.h"
+
+/*
+ * millisec - returns execution time in milliseconds. Time is measured
+ * from the function's first call. The granularity of the time is
+ * generally larger than one millisecond and on some systems it may
+ * only be accurate to the second.
+ *
+ * For some unfathomable reason, the Open Group's "Single Unix Specification"
+ * requires that the ANSI C clock() function be defined in units of 1/1000000
+ * second. This means that the result overflows a 32-bit signed clock_t
+ * value only about 35 minutes. Consequently, we use the POSIX standard
+ * times() function instead.
+ */
+
+long millisec()
+ {
+ static long clockres = 0;
+ static long starttime = 0;
+ long curtime;
+ struct tms tp;
+
+ times(&tp);
+ curtime = tp.tms_utime + tp.tms_stime;
+ if (clockres == 0) {
+ #ifdef CLK_TCK
+ clockres = CLK_TCK;
+ #else
+ clockres = sysconf(_SC_CLK_TCK);
+ #endif
+ starttime = curtime;
+ }
+ return (long) ((1000.0 / clockres) * (curtime - starttime));
+ }
diff --git a/src/common/tokens.txt b/src/common/tokens.txt
new file mode 100644
index 0000000..c717d36
--- /dev/null
+++ b/src/common/tokens.txt
@@ -0,0 +1,76 @@
+Primitive Tokens
+
+ Token Token Type Flags
+
+ identifier IDENT b e
+ integer-literal INTLIT b e
+ real-literal REALLIT b e
+ string-literal STRINGLIT b e
+ cset-literal CSETLIT b e
+ end-of-file EOFX
+
+Reserved Words
+
+ Token Token Type Flags
+
+ break BREAK b e
+ by BY
+ case CASE b
+ create CREATE b
+ default DEFAULT b
+ do DO
+ else ELSE
+ end END b
+ every EVERY b
+ fail FAIL b e
+ global GLOBAL
+ if IF b
+ initial INITIAL b
+ invocable INVOCABLE
+ link LINK
+ local LOCAL b
+ next NEXT b e
+ not NOT b
+ of OF
+ procedure PROCEDURE
+ record RECORD
+ repeat REPEAT b
+ return RETURN b e
+ static STATIC b
+ suspend SUSPEND b e
+ then THEN
+ to TO
+ until UNTIL b
+ while WHILE b
+
+``Operator'' tokens not used in standard unary/binary syntax, see op.txt.
+
+ Token Token Type Flags
+
+ ( LPAREN b
+ ) RPAREN e
+ +: PCOLON
+ , COMMA
+ -: MCOLON
+ : COLON
+ ; SEMICOL
+ [ LBRACK b
+ ] RBRACK e
+ { LBRACE b
+ } RBRACE e
+
+tokens starting with $ are alternate spellings for some tokens
+
+ $( LBRACE b
+ $) RBRACE e
+ $< LBRACK b
+ $> RBRACK e
+
+Explanation of Flags
+
+ b indicates that the token may begin an expression.
+ e indicates that the token may end an expression.
+
+ These two flags are used for semicolon insertion. If a line
+ ends with an "e" token, and the next token is a "b" token,
+ a semicolon is inserted between the two tokens.
diff --git a/src/common/typespec.icn b/src/common/typespec.icn
new file mode 100644
index 0000000..f86ba9a
--- /dev/null
+++ b/src/common/typespec.icn
@@ -0,0 +1,482 @@
+#
+# typespec - transform Icon type specifications into C tables.
+# Specifications are read from standard input; tables are written
+# to standard output.
+#
+# The grammar for the a type specifcation is:
+#
+# <type-def> ::= <identifier> <opt-abrv> : <kind> <opt-return>
+#
+# <kind> ::= simple |
+# aggregate(<component>, ... ) |
+# variable <var-type-spec>
+#
+# <component> ::= var <identifier> <opt-abrv> |
+# <identifier>
+#
+# <var-type-spec> ::= initially <type> |
+# always <type>
+#
+# <type> ::= <type-name> | <type> ++ <type-name>
+#
+# <opt-abrv> ::= <nil> |
+# { <identifier> }
+#
+# <opt-return> ::= <nil> |
+# return block_pointer |
+# return descriptor_pointer |
+# return char_pointer |
+# return C_integer
+
+# Information about an Icon type.
+#
+record icon_type(
+ id, # name of type
+ support_new, # supports RTL "new" construct
+ deref, # dereferencing needs
+ rtl_ret, # kind of RTL return supported if any
+ typ, # for variable: initial type
+ num_comps, # for aggregate: number of type components
+ compnts, # for aggregate: index of first component
+ abrv) # abreviation used for type tracing
+
+# Information about a component of an aggregate type.
+#
+record typ_compnt (
+ id, # name of component
+ n, # position of component within type aggragate
+ var, # flag: this component is an Icon-level variable
+ aggregate, # index of type that owns the component
+ abrv) # abreviation used for type tracing
+
+record token(kind, image)
+
+global icontypes, typecompnt, type_indx, compnt_indx
+global lex, line_num, saved_token, error_msg, prog_name
+
+procedure main()
+ local typ, tok, compnt, indx, x
+
+ prog_name := "typespec"
+ lex := create tokenize_input()
+
+ icontypes := []
+ typecompnt := []
+
+ #
+ # Read each of the type specifications
+ #
+ while typ := icon_type(ident("may be EOF")) do {
+ #
+ # Check for abreviation
+ #
+ typ.abrv := opt_abrv(typ.id)
+
+ if next_token().kind ~== ":" then
+ input_err("expected ':'")
+
+ #
+ # See what kind of type this is
+ #
+ case ident() of {
+ "simple": {
+ typ.support_new := "0"
+ typ.deref := "DrfNone"
+ typ.num_comps := "0"
+ typ.compnts := "0"
+ }
+
+ "aggregate": {
+ typ.support_new := "1"
+ typ.deref := "DrfNone"
+
+ #
+ # get the component names for the type
+ #
+ typ.compnts := *typecompnt
+ if next_token().kind ~== "(" then
+ input_err("expected '('")
+ typ.num_comps := 0
+ tok := next_token()
+ if tok.kind ~== "id" then
+ input_err("expected type component")
+ while tok.kind ~== ")" do {
+ #
+ # See if this component is an Icon variable.
+ #
+ if tok.image == "var" then {
+ compnt := typ_compnt(ident(), typ.num_comps, "1", *icontypes)
+ compnt.abrv := opt_abrv(compnt.id)
+ }
+ else
+ compnt := typ_compnt(tok.image, typ.num_comps, "0",
+ *icontypes)
+
+ put(typecompnt, compnt)
+ typ.num_comps +:= 1
+
+ tok := next_token()
+ if tok.kind == "," then {
+ tok := next_token()
+ if tok.kind ~== "id" then
+ input_err("expected type component")
+ }
+ else if tok.kind ~== ")" then
+ input_err("expected type component")
+ }
+ }
+
+ "variable": {
+ typ.support_new := "0"
+ typ.num_comps := "0"
+ typ.compnts := "0"
+ case ident() of {
+ "initially":
+ typ.deref := "DrfGlbl"
+ "always":
+ typ.deref := "DrfCnst"
+ default:
+ input_err("expected 'initially' or 'always'")
+ }
+
+ #
+ # Get the initial type associated with the variable
+ #
+ typ.typ := [ident()]
+ tok := &null
+ while (tok := next_token("may be EOF")).kind == "++" do {
+ put(typ.typ, ident())
+ tok := &null
+ }
+ saved_token := tok # put token back
+ }
+ default:
+ input_err("expected 'simple', 'aggregate', or 'variable'")
+ }
+
+ #
+ # Check for an optional return clause
+ #
+ tok := &null
+ if (tok := next_token("may be EOF")).image == "return" then {
+ case next_token().image of {
+ "block_pointer":
+ typ.rtl_ret := "TRetBlkP"
+ "descriptor_pointer":
+ typ.rtl_ret := "TRetDescP"
+ "char_pointer":
+ typ.rtl_ret := "TRetCharP"
+ "C_integer":
+ typ.rtl_ret := "TRetCInt"
+ default:
+ input_err("expected vword type")
+ }
+ }
+ else {
+ typ.rtl_ret := "TRetNone"
+ saved_token := tok # put token back
+ }
+
+ put(icontypes, typ)
+ }
+
+ #
+ # Create tables of type and compontent indexes.
+ #
+ type_indx := table()
+ indx := -1
+ every type_indx[(!icontypes).id] := (indx +:= 1)
+ compnt_indx := table()
+ indx := -1
+ every compnt_indx[(!typecompnt).id] := (indx +:= 1)
+
+ write("/*")
+ write(" * This file was generated by the program ", prog_name, ".")
+ write(" */")
+ write()
+
+ #
+ # Locate the indexes of types with special semantics or which are
+ # explicitly needed by iconc. Output the indexes as assignments to
+ # variables.
+ #
+ indx := req_type("string")
+ icontypes[indx + 1].rtl_ret := "TRetSpcl"
+ write("int str_typ = ", indx, ";")
+
+ indx := req_type("integer")
+ write("int int_typ = ", indx, ";")
+
+ indx := req_type("record")
+ write("int rec_typ = ", indx, ";")
+
+ indx := req_type("proc")
+ write("int proc_typ = ", indx, ";")
+
+ indx := req_type("coexpr")
+ write("int coexp_typ = ", indx, ";")
+
+ indx := req_type("tvsubs")
+ icontypes[indx + 1].deref := "DrfSpcl"
+ icontypes[indx + 1].rtl_ret := "TRetSpcl"
+ write("int stv_typ = ", indx, ";")
+
+ indx := req_type("tvtbl")
+ icontypes[indx + 1].deref := "DrfSpcl"
+ write("int ttv_typ = ", indx, ";")
+
+ indx := req_type("null")
+ write("int null_typ = ", indx, ";")
+
+ indx := req_type("cset")
+ write("int cset_typ = ", indx, ";")
+
+ indx := req_type("real")
+ write("int real_typ = ", indx, ";")
+
+ indx := req_type("list")
+ write("int list_typ = ", indx, ";")
+
+ indx := req_type("table")
+ write("int tbl_typ = ", indx, ";")
+
+ #
+ # Output the type table.
+ #
+ write()
+ write("int num_typs = ", *icontypes, ";")
+ write("struct icon_type icontypes[", *icontypes, "] = {")
+ x := copy(icontypes)
+ output_typ(get(x))
+ while typ := get(x) do {
+ write(",")
+ output_typ(typ)
+ }
+ write("};")
+
+ #
+ # Locate the indexes of components which are explicitly needed by iconc.
+ # Output the indexes as assignments to variables.
+ #
+ write()
+ indx := req_compnt("str_var")
+ write("int str_var = ", indx, ";")
+
+ indx := req_compnt("trpd_tbl")
+ write("int trpd_tbl = ", indx, ";")
+
+ indx := req_compnt("lst_elem")
+ write("int lst_elem = ", indx, ";")
+
+ indx := req_compnt("tbl_dflt")
+ write("int tbl_dflt = ", indx, ";")
+
+ indx := req_compnt("tbl_val")
+ write("int tbl_val = ", indx, ";")
+
+ #
+ # Output the component table.
+ #
+ write()
+ write("int num_cmpnts = ", *typecompnt, ";")
+ write("struct typ_compnt typecompnt[", *typecompnt, "] = {")
+ output_compnt(get(typecompnt))
+ while compnt := get(typecompnt) do {
+ write(",")
+ output_compnt(compnt)
+ }
+ write("};")
+end
+
+#
+# ident - insure that next token is an identifier and return its image
+#
+procedure ident(may_be_eof)
+ local tok
+
+ tok := next_token(may_be_eof) | fail
+
+ if tok.kind == "id" then
+ return tok.image
+ else
+ input_err("expected identifier")
+end
+
+#
+# opt_abrv - look for an optional abreviation. If there is none, return the
+# default value supplied by the caller.
+#
+procedure opt_abrv(abrv)
+ local tok
+
+ tok := next_token("may be EOF")
+ if tok.kind == "{" then {
+ abrv := ident()
+ if next_token().kind ~== "}" then
+ input_err("expected '}'")
+ }
+ else
+ saved_token := tok # put token back
+
+ return abrv
+end
+
+#
+# next_token - get the next token, looking to see if one was put back.
+#
+procedure next_token(may_be_eof)
+ local tok
+
+ if \saved_token then {
+ tok := saved_token
+ saved_token := &null
+ return tok
+ }
+ else if tok := @lex then
+ return tok
+ else if \may_be_eof then
+ fail
+ else {
+ write(&errout, prog_name, ", unexpected EOF")
+ exit(1)
+ }
+end
+
+#
+# req_type - get the index of a required type.
+#
+procedure req_type(id)
+ local indx
+
+ if indx := \type_indx[id] then
+ return indx
+ else {
+ write(&errout, prog_name, ", the type ", id, " is required")
+ exit(1)
+ }
+end
+
+#
+# req_compnt - get the index of a required component.
+#
+procedure req_compnt(id)
+ local indx
+
+ if indx := \compnt_indx[id] then
+ return indx
+ else {
+ write(&errout, prog_name, ", the component ", id, " is required")
+ exit(1)
+ }
+end
+
+#
+# output_typ - output the table entry for a type.
+#
+procedure output_typ(typ)
+ local typ_str, s, indx
+
+ writes(" {", image(typ.id), ", ", typ.support_new, ", ", typ.deref, ", ",
+ typ.rtl_ret, ", ")
+ if \typ.typ then {
+ typ_str := repl(".", *type_indx)
+ every s := !typ.typ do {
+ if s == "any_value" then {
+ every indx := 1 to *icontypes do {
+ if icontypes[indx].deref == "DrfNone" then
+ typ_str[indx] := icontypes[indx].abrv[1]
+ }
+ }
+ else if indx := \type_indx[s] + 1 then
+ typ_str[indx] := icontypes[indx].abrv[1]
+ else {
+ write(&errout, prog_name, ", the specification for ", typ.id,
+ " contains an illegal type: ", s)
+ exit(1)
+ }
+ }
+ writes(image(typ_str))
+ }
+ else
+ writes("NULL")
+ writes(", ", typ.num_comps, ", ", typ.compnts, ", ", image(typ.abrv), ", ")
+ writes(image(map(typ.id[1], &lcase, &ucase) || typ.id[2:0]), "}")
+end
+
+#
+# output_compnt - output the table entry for a component.
+#
+procedure output_compnt(compnt)
+ writes(" {", image(compnt.id), ", ", compnt.n, ", ", compnt.var, ", ",
+ compnt.aggregate, ", ", image(\compnt.abrv) | "NULL", "}")
+end
+
+#
+# input_err - signal the lexical anaylser to print an error message about
+# the last token
+#
+procedure input_err(msg)
+ error_msg := msg
+ @lex
+end
+
+#
+# tokenize_input - transform standard input into tokens and suspend them
+#
+procedure tokenize_input()
+ local line
+
+ line_num := 0
+ while line := read() do {
+ line_num +:= 1
+ suspend line ? tokenize_line()
+ }
+ fail
+end
+
+#
+# tokenize_line - transform the subject of string scanning into tokens and
+# suspend them
+#
+procedure tokenize_line()
+ local s, tok, save_pos
+ static id_chars
+
+ initial id_chars := &letters ++ &digits ++ '_'
+
+ repeat {
+ tab(many(' \t')) # skip white space
+ if ="#" | pos(0) then
+ fail # end of input on this line
+
+ save_pos := &pos
+
+ if any(&letters) then
+ tok := token("id", tab(many(id_chars)))
+ else if s := =(":" | "(" | "," | ")" | "++" | "{" | "}") then
+ tok := token(s, s)
+ else
+ err("unknown symbol")
+
+ suspend tok
+ err(\error_msg, save_pos) # was the last token erroneous?
+ }
+end
+
+#
+# err - print an error message about the current string being scanned
+#
+procedure err(msg, save_pos)
+ local s, strt_msg
+
+ tab(\save_pos) # error occured here
+
+ strt_msg := prog_name || ", " || msg || "; line " || line_num || ": "
+ (s := image(tab(1))) & &fail # get front of line then undo tab
+ strt_msg ||:= s[1:-1] # strip ending quote from image
+ s := image(tab(0)) # get end of line
+ s := s[2:0] # strip first quote from image
+ write(&errout, strt_msg, s)
+ write(&errout, repl(" ", *strt_msg), "^") # show location of error
+ exit(1)
+end
diff --git a/src/common/typespec.txt b/src/common/typespec.txt
new file mode 100644
index 0000000..6fdd726
--- /dev/null
+++ b/src/common/typespec.txt
@@ -0,0 +1,87 @@
+# This file contains Icon type specifications.
+
+# The first group of types have special semantics that are not completely
+# captured by the specification system.
+
+
+ string{s}: simple
+ # special form of descriptor
+ # has RLT return construct with two arguments
+
+ integer{i}: simple
+ # two kinds of dwords
+
+ record{R}: simple # really special aggregate
+ return block_pointer
+ # special semantics for allocating sub-types
+ # different sub-types have different components
+
+ proc: simple
+ return block_pointer
+ # special semantics for allocating sub-types
+
+ coexpr{C}: simple
+ return block_pointer
+ # special semantics for allocating sub-types
+
+ # sub-string trapped variables
+ tvsubs{sstv}: aggregate(str_var)
+ # has RTL return construct with three arguments
+ # variable type with special dereferencing semantics
+
+ # table-element trapped variables
+ tvtbl{tetv}: aggregate(trpd_tbl)
+ return block_pointer
+ # variable type with special dereferencing semantics
+
+
+# The second group of types are required by iconc but have no special
+# semantics.
+
+ null{n}: simple
+
+ cset{c}: simple
+ return block_pointer
+
+ real{r}: simple
+ return block_pointer
+
+ list{L}: aggregate(var lst_elem{LE})
+ return block_pointer
+
+ table{T}: aggregate(tbl_key, var tbl_val{TV}, tbl_dflt)
+ return block_pointer
+
+
+# The third group of types appear only in RTL code. They have no special
+# semantics nor any special uses by iconc.
+
+ file{f}: simple
+ return block_pointer
+
+ set{S}: aggregate(set_elem)
+ return block_pointer
+
+ # integer keyword variables: &random, &trace, &error
+ kywdint: variable always integer
+ return descriptor_pointer
+
+ # &subject
+ kywdsubj: variable always string
+ return descriptor_pointer
+
+ # &pos
+ kywdpos: variable always integer
+ return descriptor_pointer
+
+ # &eventsource, &eventvalue, &eventcode
+ kywdevent: variable always any_value
+ return descriptor_pointer
+
+ # &window
+ kywdwin: variable always file ++ null
+ return descriptor_pointer
+
+ # &fg and friends
+ kywdstr: variable always string
+ return descriptor_pointer
diff --git a/src/common/xwindow.c b/src/common/xwindow.c
new file mode 100644
index 0000000..b5d2c5b
--- /dev/null
+++ b/src/common/xwindow.c
@@ -0,0 +1,159 @@
+/*
+ * xwindow.c - X Window System-specific routines
+ */
+#include "../h/define.h"
+#include "../h/config.h"
+#ifdef XWindows
+
+typedef struct {
+ char *s;
+ int i;
+} stringint, *siptr;
+
+#ifdef XpmFormat
+ #include "../xpm/xpm.h"
+#else /* XpmFormat */
+ #include <X11/Xlib.h>
+ #include <X11/Xutil.h>
+#endif /* XpmFormat */
+
+#include <X11/Xos.h>
+#include <X11/Xatom.h>
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+
+int GraphicsHome = XK_Home;
+int GraphicsLeft = XK_Left;
+int GraphicsUp = XK_Up;
+int GraphicsRight = XK_Right;
+int GraphicsDown = XK_Down;
+int GraphicsPrior = XK_Prior;
+int GraphicsNext = XK_Next;
+int GraphicsEnd = XK_End;
+
+/*
+ * Translate a key event. Put ascii result if any in s.
+ * Return number of ascii (>0) if the key was "normal" and s is filled in.
+ * Return 0 if the key was strange and keysym should be returned.
+ * Return -1 if the key was a modifier key and should be dropped.
+ */
+int translate_key_event(event, s, k)
+XKeyEvent *event;
+char *s;
+KeySym *k;
+{
+ int i = XLookupString(event, s, 10, k, NULL);
+
+ if (i > 0)
+ return i; /* "normal" key */
+ else if (IsModifierKey(*k))
+ return -1; /* modifier key */
+ else
+ return 0; /* other (e.g. function key) */
+}
+
+stringint drawops[] = {
+ { 0, 16},
+ {"and", GXand},
+ {"andInverted", GXandInverted},
+ {"andReverse", GXandReverse},
+ {"clear", GXclear},
+ {"copy", GXcopy},
+ {"copyInverted", GXcopyInverted},
+ {"equiv", GXequiv},
+ {"invert", GXinvert},
+ {"nand", GXnand},
+ {"noop", GXnoop},
+ {"nor", GXnor},
+ {"or", GXor},
+ {"orInverted", GXorInverted},
+ {"orReverse", GXorReverse},
+ {"set", GXset},
+ {"xor", GXxor},
+};
+
+#define NUMCURSORSYMS 78
+
+stringint cursorsyms[] = {
+ { 0, NUMCURSORSYMS},
+ {"X cursor", XC_X_cursor},
+ {"arrow", XC_arrow},
+ {"based arrow down", XC_based_arrow_down},
+ {"based arrow up", XC_based_arrow_up},
+ {"boat", XC_boat},
+ {"bogosity", XC_bogosity},
+ {"bottom left corner",XC_bottom_left_corner},
+ {"bottom right corner",XC_bottom_right_corner},
+ {"bottom side", XC_bottom_side},
+ {"bottom tee", XC_bottom_tee},
+ {"box spiral", XC_box_spiral},
+ {"center ptr", XC_center_ptr},
+ {"circle", XC_circle},
+ {"clock", XC_clock},
+ {"coffee mug", XC_coffee_mug},
+ {"cross", XC_cross},
+ {"cross reverse", XC_cross_reverse},
+ {"crosshair", XC_crosshair},
+ {"diamond cross", XC_diamond_cross},
+ {"dot", XC_dot},
+ {"dotbox", XC_dotbox},
+ {"double arrow", XC_double_arrow},
+ {"draft large", XC_draft_large},
+ {"draft small", XC_draft_small},
+ {"draped box", XC_draped_box},
+ {"exchange", XC_exchange},
+ {"fleur", XC_fleur},
+ {"gobbler", XC_gobbler},
+ {"gumby", XC_gumby},
+ {"hand1", XC_hand1},
+ {"hand2", XC_hand2},
+ {"heart", XC_heart},
+ {"icon", XC_icon},
+ {"iron cross", XC_iron_cross},
+ {"left ptr", XC_left_ptr},
+ {"left side", XC_left_side},
+ {"left tee", XC_left_tee},
+ {"leftbutton", XC_leftbutton},
+ {"ll angle", XC_ll_angle},
+ {"lr angle", XC_lr_angle},
+ {"man", XC_man},
+ {"middlebutton", XC_middlebutton},
+ {"mouse", XC_mouse},
+ {"pencil", XC_pencil},
+ {"pirate", XC_pirate},
+ {"plus", XC_plus},
+ {"question arrow", XC_question_arrow},
+ {"right ptr", XC_right_ptr},
+ {"right side", XC_right_side},
+ {"right tee", XC_right_tee},
+ {"rightbutton", XC_rightbutton},
+ {"rtl logo", XC_rtl_logo},
+ {"sailboat", XC_sailboat},
+ {"sb down arrow", XC_sb_down_arrow},
+ {"sb h double arrow", XC_sb_h_double_arrow},
+ {"sb left arrow", XC_sb_left_arrow},
+ {"sb right arrow", XC_sb_right_arrow},
+ {"sb up arrow", XC_sb_up_arrow},
+ {"sb v double arrow", XC_sb_v_double_arrow},
+ {"shuttle", XC_shuttle},
+ {"sizing", XC_sizing},
+ {"spider", XC_spider},
+ {"spraycan", XC_spraycan},
+ {"star", XC_star},
+ {"target", XC_target},
+ {"tcross", XC_tcross},
+ {"top left arrow", XC_top_left_arrow},
+ {"top left corner", XC_top_left_corner},
+ {"top right corner", XC_top_right_corner},
+ {"top side", XC_top_side},
+ {"top tee", XC_top_tee},
+ {"trek", XC_trek},
+ {"ul angle", XC_ul_angle},
+ {"umbrella", XC_umbrella},
+ {"ur angle", XC_ur_angle},
+ {"watch", XC_watch},
+ {"xterm", XC_xterm},
+ {"num glyphs", XC_num_glyphs},
+};
+
+#endif /* XWindows */
diff --git a/src/common/yacctok.h b/src/common/yacctok.h
new file mode 100644
index 0000000..a6a532d
--- /dev/null
+++ b/src/common/yacctok.h
@@ -0,0 +1,125 @@
+/*
+ * NOTE: these %token declarations are generated
+ * automatically by mktoktab from tokens.txt and
+ * op.txt.
+ */
+
+/* primitive tokens */
+
+%token IDENT
+%token INTLIT
+%token REALLIT
+%token STRINGLIT
+%token CSETLIT
+%token EOFX
+
+/* reserved words */
+
+%token BREAK /* break */
+%token BY /* by */
+%token CASE /* case */
+%token CREATE /* create */
+%token DEFAULT /* default */
+%token DO /* do */
+%token ELSE /* else */
+%token END /* end */
+%token EVERY /* every */
+%token FAIL /* fail */
+%token GLOBAL /* global */
+%token IF /* if */
+%token INITIAL /* initial */
+%token INVOCABLE /* invocable */
+%token LINK /* link */
+%token LOCAL /* local */
+%token NEXT /* next */
+%token NOT /* not */
+%token OF /* of */
+%token PROCEDURE /* procedure */
+%token RECORD /* record */
+%token REPEAT /* repeat */
+%token RETURN /* return */
+%token STATIC /* static */
+%token SUSPEND /* suspend */
+%token THEN /* then */
+%token TO /* to */
+%token UNTIL /* until */
+%token WHILE /* while */
+
+/* operators */
+
+%token BANG /* ! */
+%token MOD /* % */
+%token AUGMOD /* %:= */
+%token AND /* & */
+%token AUGAND /* &:= */
+%token STAR /* * */
+%token AUGSTAR /* *:= */
+%token INTER /* ** */
+%token AUGINTER /* **:= */
+%token PLUS /* + */
+%token AUGPLUS /* +:= */
+%token UNION /* ++ */
+%token AUGUNION /* ++:= */
+%token MINUS /* - */
+%token AUGMINUS /* -:= */
+%token DIFF /* -- */
+%token AUGDIFF /* --:= */
+%token DOT /* . */
+%token SLASH /* / */
+%token AUGSLASH /* /:= */
+%token ASSIGN /* := */
+%token SWAP /* :=: */
+%token NMLT /* < */
+%token AUGNMLT /* <:= */
+%token REVASSIGN /* <- */
+%token REVSWAP /* <-> */
+%token SLT /* << */
+%token AUGSLT /* <<:= */
+%token SLE /* <<= */
+%token AUGSLE /* <<=:= */
+%token NMLE /* <= */
+%token AUGNMLE /* <=:= */
+%token NMEQ /* = */
+%token AUGNMEQ /* =:= */
+%token SEQ /* == */
+%token AUGSEQ /* ==:= */
+%token EQUIV /* === */
+%token AUGEQUIV /* ===:= */
+%token NMGT /* > */
+%token AUGNMGT /* >:= */
+%token NMGE /* >= */
+%token AUGNMGE /* >=:= */
+%token SGT /* >> */
+%token AUGSGT /* >>:= */
+%token SGE /* >>= */
+%token AUGSGE /* >>=:= */
+%token QMARK /* ? */
+%token AUGQMARK /* ?:= */
+%token AT /* @ */
+%token AUGAT /* @:= */
+%token BACKSLASH /* \ */
+%token CARET /* ^ */
+%token AUGCARET /* ^:= */
+%token BAR /* | */
+%token CONCAT /* || */
+%token AUGCONCAT /* ||:= */
+%token LCONCAT /* ||| */
+%token AUGLCONCAT /* |||:= */
+%token TILDE /* ~ */
+%token NMNE /* ~= */
+%token AUGNMNE /* ~=:= */
+%token SNE /* ~== */
+%token AUGSNE /* ~==:= */
+%token NEQUIV /* ~=== */
+%token AUGNEQUIV /* ~===:= */
+%token LPAREN /* ( */
+%token RPAREN /* ) */
+%token PCOLON /* +: */
+%token COMMA /* , */
+%token MCOLON /* -: */
+%token COLON /* : */
+%token SEMICOL /* ; */
+%token LBRACK /* [ */
+%token RBRACK /* ] */
+%token LBRACE /* { */
+%token RBRACE /* } */
diff --git a/src/common/yylex.h b/src/common/yylex.h
new file mode 100644
index 0000000..9850417
--- /dev/null
+++ b/src/common/yylex.h
@@ -0,0 +1,624 @@
+/*
+ * yylex.h -- the lexical analyzer.
+ *
+ * This source file contains the lexical analyzer, yylex(), and its
+ * support routines. It is built by inclusion in ../icont/tlex.c and
+ * ../iconc/clex.c, with slight variations depending on whether "Iconc"
+ * is defined.
+ */
+
+#if !defined(Iconc)
+ #include "../h/esctab.h"
+#endif /* !Iconc */
+
+/*
+ * Prototypes.
+ */
+
+static int bufcmp (char *s);
+static struct toktab *findres (void);
+static struct toktab *getident (int ac,int *cc);
+static struct toktab *getnum (int ac,int *cc);
+static struct toktab *getstring (int ac,int *cc);
+static int setfilenm (int c);
+static int setlineno (void);
+
+#if !defined(Iconc)
+ static int ctlesc (void);
+ static int hexesc (void);
+ static int octesc (int ac);
+#endif /* !Iconc */
+
+#define isletter(s) (isupper(c) | islower(c))
+#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9))
+
+struct node tok_loc =
+ {0, NULL, 0, 0}; /* "model" node containing location of current token */
+
+struct str_buf lex_sbuf; /* string buffer for lexical analyzer */
+
+/*
+ * yylex - find the next token in the input stream, and return its token
+ * type and value to the parser.
+ *
+ * Variables of interest:
+ *
+ * cc - character following last token.
+ * nlflag - set if a newline was between the last token and the current token
+ * lastend - set if the last token was an Ender.
+ * lastval - when a semicolon is inserted and returned, lastval gets the
+ * token value that would have been returned if the semicolon hadn't
+ * been inserted.
+ */
+
+static struct toktab *lasttok = NULL;
+static int lastend = 0;
+static int eofflag = 0;
+static int cc = '\n';
+
+int yylex()
+ {
+ register struct toktab *t;
+ register int c;
+ int n;
+ int nlflag;
+ static nodeptr lastval;
+ static struct node semi_loc;
+
+ if (lasttok != NULL) {
+ /*
+ * A semicolon was inserted and returned on the last call to yylex,
+ * instead of going to the input, return lasttok and set the
+ * appropriate variables.
+ */
+
+ yylval = lastval;
+ tok_loc = *lastval;
+ t = lasttok;
+ goto ret;
+ }
+ nlflag = 0;
+loop:
+ c = cc;
+ /*
+ * Remember where a semicolon will go if we insert one.
+ */
+ semi_loc.n_file = tok_loc.n_file;
+ semi_loc.n_line = in_line;
+ if (cc == '\n')
+ --semi_loc.n_line;
+ semi_loc.n_col = incol;
+ /*
+ * Skip whitespace and comments and process #line directives.
+ */
+ while (c == Comment || isspace(c)) {
+ if (c == '\n') {
+ nlflag++;
+ c = NextChar;
+ if (c == Comment) {
+ /*
+ * Check for #line directive at start of line.
+ */
+ if (('l' == (c = NextChar)) &&
+ ('i' == (c = NextChar)) &&
+ ('n' == (c = NextChar)) &&
+ ('e' == (c = NextChar))) {
+ c = setlineno();
+ while ((c == ' ') || (c == '\t'))
+ c = NextChar;
+ if (c != EOF && c != '\n')
+ c = setfilenm(c);
+ }
+ while (c != EOF && c != '\n')
+ c = NextChar;
+ }
+ }
+ else {
+ if (c == Comment) {
+ while (c != EOF && c != '\n')
+ c = NextChar;
+ }
+ else {
+ c = NextChar;
+ }
+ }
+ }
+ /*
+ * A token is the next thing in the input. Set token location to
+ * the current line and column.
+ */
+ tok_loc.n_line = in_line;
+ tok_loc.n_col = incol;
+
+ if (c == EOF) {
+ /*
+ * End of file has been reached. Set eofflag, return T_Eof, and
+ * set cc to EOF so that any subsequent scans also return T_Eof.
+ */
+ if (eofflag++) {
+ eofflag = 0;
+ cc = '\n';
+ yylval = NULL;
+ return 0;
+ }
+ cc = EOF;
+ t = T_Eof;
+ yylval = NULL;
+ goto ret;
+ }
+
+ /*
+ * Look at current input character to determine what class of token
+ * is next and take the appropriate action. Note that the various
+ * token gathering routines write a value into cc.
+ */
+ if (isalpha(c) || (c == '_')) { /* gather ident or reserved word */
+ if ((t = getident(c, &cc)) == NULL)
+ goto loop;
+ }
+ else if (isdigit(c) || (c == '.')) { /* gather numeric literal or "." */
+ if ((t = getnum(c, &cc)) == NULL)
+ goto loop;
+ }
+ else if (c == '"' || c == '\'') { /* gather string or cset literal */
+ if ((t = getstring(c, &cc)) == NULL)
+ goto loop;
+ }
+ else { /* gather longest legal operator */
+ if ((n = getopr(c, &cc)) == -1)
+ goto loop;
+ t = &(optab[n].tok);
+ yylval = OpNode(n);
+ }
+ if (nlflag && lastend && (t->t_flags & Beginner)) {
+ /*
+ * A newline was encountered between the current token and the last,
+ * the last token was an Ender, and the current token is a Beginner.
+ * Return a semicolon and save the current token in lastval.
+ */
+ lastval = yylval;
+ lasttok = t;
+ tok_loc = semi_loc;
+ yylval = OpNode(semicol_loc);
+ return SEMICOL;
+ }
+ret:
+ /*
+ * Clear lasttok, set lastend if the token being returned is an
+ * Ender, and return the token.
+ */
+ lasttok = 0;
+ lastend = t->t_flags & Ender;
+ return (t->t_type);
+ }
+
+/*
+ * getident - gather an identifier beginning with ac. The character
+ * following identifier goes in cc.
+ */
+
+static struct toktab *getident(ac, cc)
+int ac;
+int *cc;
+ {
+ register int c;
+ register struct toktab *t;
+
+ c = ac;
+ /*
+ * Copy characters into string space until a non-alphanumeric character
+ * is found.
+ */
+ do {
+ AppChar(lex_sbuf, c);
+ c = NextChar;
+ } while (isalnum(c) || (c == '_'));
+ *cc = c;
+ /*
+ * If the identifier is a reserved word, make a ResNode for it and return
+ * the token value. Otherwise, install it with putid, make an
+ * IdNode for it, and return.
+ */
+ if ((t = findres()) != NULL) {
+ lex_sbuf.endimage = lex_sbuf.strtimage;
+ yylval = ResNode(t->t_type);
+ return t;
+ }
+ else {
+ yylval = IdNode(str_install(&lex_sbuf));
+ return (struct toktab *)T_Ident;
+ }
+ }
+
+/*
+ * findres - if the string just copied into the string space by getident
+ * is a reserved word, return a pointer to its entry in the token table.
+ * Return NULL if the string isn't a reserved word.
+ */
+
+static struct toktab *findres()
+ {
+ register struct toktab *t;
+ register char c;
+
+ c = *lex_sbuf.strtimage;
+ if (!islower(c))
+ return NULL;
+ /*
+ * Point t at first reserved word that starts with c (if any).
+ */
+ if ((t = restab[c - 'a']) == NULL)
+ return NULL;
+ /*
+ * Search through reserved words, stopping when a match is found
+ * or when the current reserved word doesn't start with c.
+ */
+ while (t->t_word[0] == c) {
+ if (bufcmp(t->t_word))
+ return t;
+ t++;
+ }
+ return NULL;
+ }
+
+/*
+ * bufcmp - compare a null terminated string to what is in the string buffer.
+ */
+static int bufcmp(s)
+char *s;
+ {
+ register char *s1;
+ s1 = lex_sbuf.strtimage;
+ while (s != '\0' && s1 < lex_sbuf.endimage && *s == *s1) {
+ ++s;
+ ++s1;
+ }
+ if (*s == '\0' && s1 == lex_sbuf.endimage)
+ return 1;
+ else
+ return 0;
+ }
+
+/*
+ * getnum - gather a numeric literal starting with ac and put the
+ * character following the literal into *cc.
+ *
+ * getnum also handles the "." operator, which is distinguished from
+ * a numeric literal by what follows it.
+ */
+
+static struct toktab *getnum(ac, cc)
+int ac;
+int *cc;
+ {
+ register int c, r, state;
+ int realflag, n, dummy;
+
+ c = ac;
+ if (c == '.') {
+ r = 0;
+ state = 7;
+ realflag = 1;
+ }
+ else {
+ r = tonum(c);
+ state = 0;
+ realflag = 0;
+ }
+ for (;;) {
+ AppChar(lex_sbuf, c);
+ c = NextChar;
+ switch (state) {
+ case 0: /* integer part */
+ if (isdigit(c)) { r = r * 10 + tonum(c); continue; }
+ if (c == '.') { state = 1; realflag++; continue; }
+ if (c == 'e' || c == 'E') { state = 2; realflag++; continue; }
+ if (c == 'r' || c == 'R') {
+ state = 5;
+ if (r < 2 || r > 36)
+ tfatal("invalid radix for integer literal", (char *)NULL);
+ continue;
+ }
+ break;
+ case 1: /* fractional part */
+ if (isdigit(c)) continue;
+ if (c == 'e' || c == 'E') { state = 2; continue; }
+ break;
+ case 2: /* optional exponent sign */
+ if (c == '+' || c == '-') { state = 3; continue; }
+ case 3: /* first digit after e, e+, or e- */
+ if (isdigit(c)) { state = 4; continue; }
+ tfatal("invalid real literal", (char *)NULL);
+ break;
+ case 4: /* remaining digits after e */
+ if (isdigit(c)) continue;
+ break;
+ case 5: /* first digit after r */
+ if ((isdigit(c) || isletter(c)) && tonum(c) < r)
+ { state = 6; continue; }
+ tfatal("invalid integer literal", (char *)NULL);
+ break;
+ case 6: /* remaining digits after r */
+ if (isdigit(c) || isletter(c)) {
+ if (tonum(c) >= r) { /* illegal digit for radix r */
+ tfatal("invalid digit in integer literal", (char *)NULL);
+ r = tonum('z'); /* prevent more messages */
+ }
+ continue;
+ }
+ break;
+ case 7: /* token began with "." */
+ if (isdigit(c)) {
+ state = 1; /* followed by digit is a real const */
+ realflag = 1;
+ continue;
+ }
+ *cc = c; /* anything else is just a dot */
+ lex_sbuf.endimage--; /* remove dot (undo AppChar) */
+ n = getopr((int)'.', &dummy);
+ yylval = OpNode(n);
+ return &(optab[n].tok);
+ }
+ break;
+ }
+ *cc = c;
+ if (realflag) {
+ yylval = RealNode(str_install(&lex_sbuf));
+ return T_Real;
+ }
+ yylval = IntNode(str_install(&lex_sbuf));
+ return T_Int;
+ }
+
+/*
+ * getstring - gather a string literal starting with ac and place the
+ * character following the literal in *cc.
+ */
+static struct toktab *getstring(ac, cc)
+int ac;
+int *cc;
+ {
+ register int c, sc;
+ int sav_indx;
+ int len;
+
+ sc = ac;
+ sav_indx = -1;
+ c = NextChar;
+ while (c != sc && c != '\n' && c != EOF) {
+ /*
+ * If a '_' is the last non-white space before a new-line,
+ * we must remember where it is.
+ */
+ if (c == '_')
+ sav_indx = lex_sbuf.endimage - lex_sbuf.strtimage;
+ else if (!isspace(c))
+ sav_indx = -1;
+
+ if (c == Escape) {
+ c = NextChar;
+ if (c == EOF)
+ break;
+
+#if defined(Iconc)
+ AppChar(lex_sbuf, Escape);
+ if (c == '^') {
+ c = NextChar;
+ if (c == EOF)
+ break;
+ AppChar(lex_sbuf, '^');
+ }
+#else /* Iconc */
+ if (isoctal(c))
+ c = octesc(c);
+ else if (c == 'x')
+ c = hexesc();
+ else if (c == '^')
+ c = ctlesc();
+ else
+ c = esctab[c];
+#endif /* Iconc */
+
+ }
+ AppChar(lex_sbuf, c);
+ c = NextChar;
+
+ /*
+ * If a '_' is the last non-white space before a new-line, the
+ * string continues at the first non-white space on the next line
+ * and everything from the '_' to the end of this line is ignored.
+ */
+ if (c == '\n' && sav_indx >= 0) {
+ lex_sbuf.endimage = lex_sbuf.strtimage + sav_indx;
+ while ((c = NextChar) != EOF && isspace(c))
+ ;
+ }
+ }
+ if (c == sc)
+ *cc = ' ';
+ else {
+ tfatal("unclosed quote", (char *)NULL);
+ *cc = c;
+ }
+ len = lex_sbuf.endimage - lex_sbuf.strtimage;
+ if (ac == '"') { /* a string literal */
+ yylval = StrNode(str_install(&lex_sbuf), len);
+ return T_String;
+ }
+ else { /* a cset literal */
+ yylval = CsetNode(str_install(&lex_sbuf), len);
+ return T_Cset;
+ }
+ }
+
+#if !defined(Iconc)
+
+/*
+ * ctlesc - translate a control escape -- backslash followed by
+ * caret and one character.
+ */
+
+static int ctlesc()
+ {
+ register int c;
+
+ c = NextChar;
+ if (c == EOF)
+ return EOF;
+
+ return (c & 037);
+ }
+
+/*
+ * octesc - translate an octal escape -- backslash followed by
+ * one, two, or three octal digits.
+ */
+
+static int octesc(ac)
+int ac;
+ {
+ register int c, nc, i;
+
+ c = 0;
+ nc = ac;
+ i = 1;
+ do {
+ c = (c << 3) | (nc - '0');
+ nc = NextChar;
+ if (nc == EOF)
+ return EOF;
+ } while (isoctal(nc) && i++ < 3);
+ PushChar(nc);
+
+ return (c & 0377);
+ }
+
+/*
+ * hexesc - translate a hexadecimal escape -- backslash-x
+ * followed by one or two hexadecimal digits.
+ */
+
+static int hexesc()
+ {
+ register int c, nc, i;
+
+ c = 0;
+ i = 0;
+ while (i++ < 2) {
+ nc = NextChar;
+ if (nc == EOF)
+ return EOF;
+ if (nc >= 'a' && nc <= 'f')
+ nc -= 'a' - 10;
+ else if (nc >= 'A' && nc <= 'F')
+ nc -= 'A' - 10;
+ else if (isdigit(nc))
+ nc -= '0';
+ else {
+ PushChar(nc);
+ break;
+ }
+ c = (c << 4) | nc;
+ }
+
+ return c;
+ }
+
+#endif /* !Iconc */
+
+/*
+ * setlineno - set line number from #line comment, return following char.
+ */
+
+static int setlineno()
+ {
+ register int c;
+
+ while ((c = NextChar) == ' ' || c == '\t')
+ ;
+ if (c < '0' || c > '9') {
+ tfatal("no line number in #line directive", "");
+ while (c != EOF && c != '\n')
+ c = NextChar;
+ return c;
+ }
+ in_line = 0;
+ while (c >= '0' && c <= '9') {
+ in_line = in_line * 10 + (c - '0');
+ c = NextChar;
+ }
+ return c;
+ }
+
+/*
+ * setfilenm - set file name from #line comment, return following char.
+ */
+
+static int setfilenm(c)
+register int c;
+ {
+ while (c == ' ' || c == '\t')
+ c = NextChar;
+ if (c != '"') {
+ tfatal("'\"' missing from file name in #line directive", "");
+ while (c != EOF && c != '\n')
+ c = NextChar;
+ return c;
+ }
+ while ((c = NextChar) != '"' && c != EOF && c != '\n')
+ AppChar(lex_sbuf, c);
+ if (c == '"') {
+ tok_loc.n_file = str_install(&lex_sbuf);
+ return NextChar;
+ }
+ else {
+ tfatal("'\"' missing from file name in #line directive", "");
+ return c;
+ }
+ }
+
+/*
+ * nextchar - return the next character in the input.
+ *
+ * Called from the lexical analyzer; interfaces it to the preprocessor.
+ */
+
+int nextchar()
+ {
+ register int c;
+
+ if ((c = peekc) != 0) {
+ peekc = 0;
+ return c;
+ }
+ c = ppch();
+ switch (c) {
+ case EOF:
+ if (incol) {
+ c = '\n';
+ in_line++;
+ incol = 0;
+ peekc = EOF;
+ break;
+ }
+ else {
+ in_line = 0;
+ incol = 0;
+ break;
+ }
+ case '\n':
+ in_line++;
+ incol = 0;
+ break;
+ case '\t':
+ incol = (incol | 7) + 1;
+ break;
+ case '\b':
+ if (incol)
+ incol--;
+ break;
+ default:
+ incol++;
+ }
+ return c;
+ }
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-07 00:23:56 +0000