--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 January 1979
+ */
+
+#include "0.h"
+#include "opcode.h"
+
+#ifdef PI
+/*
+ * Array of information about pre-defined, block 0 symbols.
+ */
+int *biltins[] {
+
+ /*
+ * Types
+ */
+ "boolean",
+ "char",
+ "integer",
+ "real",
+ "_nil", /* dummy name */
+ 0,
+
+ /*
+ * Ranges
+ */
+ TINT, 0177777, 0177600, 0, 0177,
+ TINT, 0177777, 0100000, 0, 077777,
+ TINT, 0100000, 0, 077777, 0177777,
+ TCHAR, 0, 0, 0, 127,
+ TBOOL, 0, 0, 0, 1,
+ TDOUBLE, 0, 0, 0, 0, /* fake for reals */
+ 0,
+
+ /*
+ * Built-in composite types
+ */
+ "Boolean",
+ "intset",
+ "alfa",
+ "text",
+ "input",
+ "output",
+
+ /*
+ * Built-in constants
+ */
+ "true", TBOOL, 1, 0,
+ "false", TBOOL, 0, 0,
+ "minchar", T1CHAR, 0, 0,
+ "maxchar", T1CHAR, 0177, 0,
+ "bell", T1CHAR, 07, 0,
+ "tab", T1CHAR, 011, 0,
+ "minint", T4INT, 0100000, 0, /* Must be last 2! */
+ "maxint", T4INT, 077777, 0177777,
+ 0,
+
+ /*
+ * Built-in functions
+ */
+#ifndef PI0
+ "abs", O_ABS2,
+ "arctan", O_ATAN,
+ "card", O_CARD|NSTAND,
+ "chr", O_CHR2,
+ "clock", O_CLCK|NSTAND,
+ "cos", O_COS,
+ "eof", O_EOF,
+ "eoln", O_EOLN,
+ "eos", 0,
+ "exp", O_EXP,
+ "expo", O_EXPO|NSTAND,
+ "ln", O_LN,
+ "odd", O_ODD2,
+ "ord", O_ORD2,
+ "pred", O_PRED2,
+ "round", O_ROUND,
+ "sin", O_SIN,
+ "sqr", O_SQR2,
+ "sqrt", O_SQRT,
+ "succ", O_SUCC2,
+ "trunc", O_TRUNC,
+ "undefined", O_UNDEF|NSTAND,
+ /*
+ * Extensions
+ */
+ "argc", O_ARGC|NSTAND,
+ "random", O_RANDOM|NSTAND,
+ "seed", O_SEED|NSTAND,
+ "wallclock", O_WCLCK|NSTAND,
+ "sysclock", O_SCLCK|NSTAND,
+ 0,
+
+ /*
+ * Built-in procedures
+ */
+ "date", O_DATE|NSTAND,
+ "flush", O_FLUSH|NSTAND,
+ "get", O_GET,
+ "getseg", 0,
+ "halt", O_HALT|NSTAND,
+ "linelimit", O_LLIMIT|NSTAND,
+ "message", O_MESSAGE|NSTAND,
+ "new", O_NEW,
+ "pack", O_PACK,
+ "page", O_PAGE,
+ "put", O_PUT,
+ "putseg", 0,
+ "read", O_READ4,
+ "readln", O_READLN,
+ "remove", O_REMOVE|NSTAND,
+ "reset", O_RESET,
+ "rewrite", O_REWRITE,
+ "time", O_TIME|NSTAND,
+ "unpack", O_UNPACK,
+ "write", O_WRIT2,
+ "writeln", O_WRITLN,
+ /*
+ * Extensions
+ */
+ "argv", O_ARGV|NSTAND,
+ "null", O_NULL|NSTAND,
+ "stlimit", O_STLIM|NSTAND,
+ 0,
+#else
+ "abs",
+ "arctan",
+ "card",
+ "chr",
+ "clock",
+ "cos",
+ "eof",
+ "eoln",
+ "eos",
+ "exp",
+ "expo",
+ "ln",
+ "odd",
+ "ord",
+ "pred",
+ "round",
+ "sin",
+ "sqr",
+ "sqrt",
+ "succ",
+ "trunc",
+ "undefined",
+ /*
+ * Extensions
+ */
+ "argc",
+ "random",
+ "seed",
+ "wallclock",
+ "sysclock",
+ 0,
+
+ /*
+ * Built-in procedures
+ */
+ "date",
+ "flush",
+ "get",
+ "getseg",
+ "halt",
+ "linelimit",
+ "message",
+ "new",
+ "pack",
+ "page",
+ "put",
+ "putseg",
+ "read",
+ "readln",
+ "remove",
+ "reset",
+ "rewrite",
+ "time",
+ "unpack",
+ "write",
+ "writeln",
+ /*
+ * Extensions
+ */
+ "argv",
+ "null",
+ "stlimit",
+ 0,
+#endif
+};
+\f
+/*
+ * NAMELIST SEGMENT DEFINITIONS
+ */
+struct nls {
+ struct nl *nls_low;
+ struct nl *nls_high;
+} ntab[MAXNL], *nlact;
+
+struct nl nl[INL];
+struct nl *nlp nl;
+struct nls *nlact ntab;
+/*
+ * Initnl initializes the first namelist segment and then
+ * uses the array biltins to initialize the name list for
+ * block 0.
+ */
+initnl()
+{
+ register int *q;
+ register struct nl *p;
+ register int i;
+
+#ifdef DEBUG
+ if (hp21mx) {
+ MININT = -32768.;
+ MAXINT = 32767.;
+#ifndef PI0
+ genmx();
+#endif
+ }
+#endif
+ ntab[0].nls_low = nl;
+ ntab[0].nls_high = &nl[INL];
+ defnl(0, 0, 0, 0);
+ /*
+ * Fundamental types
+ */
+ for (q = biltins; *q != 0; q++)
+ hdefnl(*q, TYPE, nlp, 0);
+ q++;
+
+ /*
+ * Ranges
+ */
+ while (*q) {
+ p = defnl(0, RANGE, nl+*q, 0);
+ nl[*q++].type = p;
+ for (i = 0; i < 4; i++)
+ p->value[i] = *q++;
+ }
+ q++;
+
+#ifdef DEBUG
+ if (hp21mx) {
+ nl[T4INT].range[0] = MININT;
+ nl[T4INT].range[1] = MAXINT;
+ }
+#endif
+
+ /*
+ * Pre-defined composite types
+ */
+ hdefnl(*q++, TYPE, nl+T1BOOL, 0);
+ enter(defnl((intset = *q++), TYPE, nlp+1, 0));
+ defnl(0, SET, nlp+1, 0);
+ defnl(0, RANGE, nl+TINT, 0)->value[3] = 127;
+ p= defnl(0, RANGE, nl+TINT, 0);
+ p->value[1] = 1;
+ p->value[3] = 10;
+ defnl(0, ARRAY, nl+T1CHAR, 1)->chain = p;
+ hdefnl(*q++, TYPE, nlp-1, 0); /* "alfa" */
+ hdefnl(*q++, TYPE, nlp+1, 0); /* "text" */
+ p= defnl(0, FILE, nl+T1CHAR, 0);
+ p->nl_flags =| NFILES;
+#ifndef PI0
+ input = hdefnl(*q++, VAR, p, -2); /* "input" */
+ output = hdefnl(*q++, VAR, p, -4); /* "output" */
+#else
+ input = hdefnl(*q++, VAR, p, 0); /* "input" */
+ output = hdefnl(*q++, VAR, p, 0); /* "output" */
+#endif
+
+ /*
+ * Pre-defined constants
+ */
+ for (; *q; q =+ 4)
+ hdefnl(q[0], CONST, nl+q[1], q[2])->value[1] = q[3];
+
+#ifdef DEBUG
+ if (hp21mx) {
+ nlp[-2].range[0] = MININT;
+ nlp[-1].range[0] = MAXINT;
+ }
+#endif
+
+ /*
+ * Built-in procedures and functions
+ */
+#ifndef PI0
+ for (q++; *q; q =+ 2)
+ hdefnl(q[0], FUNC, 0, q[1]);
+ for (q++; *q; q =+ 2)
+ hdefnl(q[0], PROC, 0, q[1]);
+#else
+ for (q++; *q;)
+ hdefnl(*q++, FUNC, 0, 0);
+ for (q++; *q;)
+ hdefnl(*q++, PROC, 0, 0);
+#endif
+}
+
+hdefnl(sym, cls, typ, val)
+{
+ register struct nl *p;
+
+#ifndef PI1
+ if (sym)
+ hash(sym, 0);
+#endif
+ p = defnl(sym, cls, typ, val);
+ if (sym)
+ enter(p);
+ return (p);
+}
+
+/*
+ * Free up the name list segments
+ * at the end of a statement/proc/func
+ * All segments are freed down to the one in which
+ * p points.
+ */
+nlfree(p)
+ struct nl *p;
+{
+
+ nlp = p;
+ while (nlact->nls_low > nlp || nlact->nls_high < nlp) {
+ free(nlact->nls_low);
+ nlact->nls_low = NIL;
+ nlact->nls_high = NIL;
+ --nlact;
+ if (nlact < &ntab[0])
+ panic("nlfree");
+ }
+}
+#endif
+\f
+char VARIABLE[] "variable";
+
+char *classes[] {
+ "undefined",
+ "constant",
+ "type",
+ VARIABLE,
+ "array",
+ "pointer or file",
+ "record",
+ "field",
+ "procedure",
+ "function",
+ VARIABLE,
+ VARIABLE,
+ "pointer",
+ "file",
+ "set",
+ "subrange",
+ "label",
+ "withptr",
+ "scalar",
+ "string",
+ "program",
+ "improper",
+#ifdef DEBUG
+ "variant",
+#endif
+};
+
+char snark[] "SNARK";
+
+#ifdef PI
+#ifdef DEBUG
+char *ctext[]
+{
+ "BADUSE",
+ "CONST",
+ "TYPE",
+ "VAR",
+ "ARRAY",
+ "PTRFILE",
+ "RECORD",
+ "FIELD",
+ "PROC",
+ "FUNC",
+ "FVAR",
+ "REF",
+ "PTR",
+ "FILE",
+ "SET",
+ "RANGE",
+ "LABEL",
+ "WITHPTR",
+ "SCAL",
+ "STR",
+ "PROG",
+ "IMPROPER",
+ "VARNT"
+};
+
+char *stars "\t***";
+
+/*
+ * Dump the namelist from the
+ * current nlp down to 'to'.
+ * All the namelist is dumped if
+ * to is NIL.
+ */
+dumpnl(to, rout)
+ struct nl *to;
+{
+ register struct nl *p;
+ register int j;
+ struct nls *nlsp;
+ int i, v, head;
+
+ if (opt('y') == 0)
+ return;
+ if (to != NIL)
+ printf("\n\"%s\" Block=%d\n", rout, cbn);
+ nlsp = nlact;
+ head = NIL;
+ for (p = nlp; p != to;) {
+ if (p == nlsp->nls_low) {
+ if (nlsp == &ntab[0])
+ break;
+ nlsp--;
+ p = nlsp->nls_high;
+ }
+ p--;
+ if (head == NIL) {
+ printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n");
+ head++;
+ }
+ printf("%3d:", nloff(p));
+ if (p->symbol)
+ printf("\t%.7s", p->symbol);
+ else
+ printf(stars);
+ if (p->class)
+ printf("\t%s", ctext[p->class]);
+ else
+ printf(stars);
+ if (p->nl_flags) {
+ putchar('\t');
+ if (p->nl_flags & 037)
+ printf("%d ", p->nl_flags & 037);
+#ifndef PI0
+ if (p->nl_flags & NMOD)
+ putchar('M');
+ if (p->nl_flags & NUSED)
+ putchar('U');
+#endif
+ if (p->nl_flags & NFILES)
+ putchar('F');
+ } else
+ printf(stars);
+ if (p->type)
+ printf("\t[%d]", nloff(p->type));
+ else
+ printf(stars);
+ v = p->value[0];
+ switch (p->class) {
+ case TYPE:
+ break;
+ case VARNT:
+ goto con;
+ case CONST:
+ switch (nloff(p->type)) {
+ default:
+ printf("\t%d", v);
+ break;
+ case TDOUBLE:
+ printf("\t%f", p->real);
+ break;
+ case TINT:
+con:
+ printf("\t%ld", p->range[0]);
+ break;
+ case TSTR:
+ printf("\t'%s'", v);
+ break;
+ }
+ break;
+ case VAR:
+ case REF:
+ case WITHPTR:
+ printf("\t%d,%d", cbn, v);
+ break;
+ case SCAL:
+ case RANGE:
+ printf("\t%ld..%ld", p->range[0], p->range[1]);
+ break;
+ case RECORD:
+ printf("\t%d(%d)", v, p->value[NL_FLDSZ]);
+ break;
+ case FIELD:
+ printf("\t%d", v);
+ break;
+ case STR:
+ printf("\t\"%s\"", p->value[1]);
+ goto casedef;
+ case FVAR:
+ case FUNC:
+ case PROC:
+ case PROG:
+ if (cbn == 0) {
+ printf("\t<%o>", p->value[0] & 0377);
+#ifndef PI0
+ if (p->value[0] & NSTAND)
+ printf("\tNSTAND");
+#endif
+ break;
+ }
+ v = p->value[1];
+ default:
+casedef:
+ if (v)
+ printf("\t<%d>", v);
+ else
+ printf(stars);
+ }
+ if (p->chain)
+ printf("\t[%d]", nloff(p->chain));
+ switch (p->class) {
+ case RECORD:
+ if (p->value[NL_VARNT])
+ printf("\tVARNT=[%d]", nloff(p->value[NL_VARNT]));
+ if (p->value[NL_TAG])
+ printf(" TAG=[%d]", nloff(p->value[NL_TAG]));
+ break;
+ case VARNT:
+ printf("\tVTOREC=[%d]", nloff(p->value[NL_VTOREC]));
+ break;
+ }
+ putchar('\n');
+ }
+ if (head == 0)
+ printf("\tNo entries\n");
+}
+#endif
+
+\f
+/*
+ * Define a new name list entry
+ * with initial symbol, class, type
+ * and value[0] as given. A new name
+ * list segment is allocated to hold
+ * the next name list slot if necessary.
+ */
+defnl(sym, cls, typ, val)
+ char *sym;
+ int cls;
+ struct nl *typ;
+ int val;
+{
+ register struct nl *p;
+ register int *q, i;
+ char *cp;
+
+ p = nlp;
+
+ /*
+ * Zero out this entry
+ */
+ q = p;
+ i = (sizeof *p)/2;
+ do
+ *q++ = 0;
+ while (--i);
+
+ /*
+ * Insert the values
+ */
+ p->symbol = sym;
+ p->class = cls;
+ p->type = typ;
+ p->nl_block = cbn;
+ p->value[0] = val;
+
+ /*
+ * Insure that the next namelist
+ * entry actually exists. This is
+ * really not needed here, it would
+ * suffice to do it at entry if we
+ * need the slot. It is done this
+ * way because, historically, nlp
+ * always pointed at the next namelist
+ * slot.
+ */
+ nlp++;
+ if (nlp >= nlact->nls_high) {
+ i = NLINC;
+ cp = alloc(NLINC * sizeof *nlp);
+ if (cp == -1) {
+ i = NLINC / 2;
+ cp = alloc((NLINC / 2) * sizeof *nlp);
+ }
+ if (cp == -1) {
+ error("Ran out of memory (defnl)");
+ pexit(DIED);
+ }
+ nlact++;
+ if (nlact >= &ntab[MAXNL]) {
+ error("Ran out of name list tables");
+ pexit(DIED);
+ }
+ nlp = cp;
+ nlact->nls_low = nlp;
+ nlact->nls_high = nlact->nls_low + i;
+ }
+ return (p);
+}
+
+/*
+ * Make a duplicate of the argument
+ * namelist entry for, e.g., type
+ * declarations of the form 'type a = b'
+ * and array indicies.
+ */
+nlcopy(p)
+ struct nl *p;
+{
+ register int *p1, *p2, i;
+
+ p1 = p;
+ p = p2 = defnl(0, 0, 0, 0);
+ i = (sizeof *p)/2;
+ do
+ *p2++ = *p1++;
+ while (--i);
+ return (p);
+}
+
+/*
+ * Compute a namelist offset
+ */
+nloff(p)
+ struct nl *p;
+{
+
+ return (p - nl);
+}
+\f
+/*
+ * Enter a symbol into the block
+ * symbol table. Symbols are hashed
+ * 64 ways based on low 6 bits of the
+ * character pointer into the string
+ * table.
+ */
+enter(np)
+ struct nl *np;
+{
+ register struct nl *rp, *hp;
+ register struct nl *p;
+ int i;
+
+ rp = np;
+ if (rp == NIL)
+ return (NIL);
+#ifndef PI1
+ if (cbn > 0)
+ if (rp->symbol == input->symbol || rp->symbol == output->symbol)
+ error("Pre-defined files input and output must not be redefined");
+#endif
+ i = rp->symbol;
+ i =& 077;
+ hp = disptab[i];
+ if (rp->class != BADUSE && rp->class != FIELD)
+ for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)
+ if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) {
+#ifndef PI1
+ error("%s is already defined in this block", rp->symbol);
+#endif
+ break;
+
+ }
+ rp->nl_next = hp;
+ disptab[i] = rp;
+ return (rp);
+}
+#endif
+
+double MININT -2147483648.;
+double MAXINT 2147483647.;
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 January 1979
+ */
+
+#include "0.h"
+#include "tree.h"
+#include "opcode.h"
+
+/*
+ * Build a record namelist entry.
+ * Some of the processing here is somewhat involved.
+ * The basic structure we are building is as follows.
+ *
+ * Each record has a main RECORD entry, with an attached
+ * chain of fields as ->chain; these include all the fields in all
+ * the variants of this record.
+ *
+ * Attached to NL_VARNT is a chain of VARNT structures
+ * describing each of the variants. These are further linked
+ * through ->chain. Each VARNT has, in ->range[0] the value of
+ * the associated constant, and each points at a RECORD describing
+ * the subrecord through NL_VTOREC. These pointers are not unique,
+ * more than one VARNT may reference the same RECORD.
+ *
+ * The involved processing here is in computing the NL_OFFS entry
+ * by maxing over the variants. This works as follows.
+ *
+ * Each RECORD has two size counters. NL_OFFS is the maximum size
+ * so far of any variant of this record; NL_FLDSZ gives the size
+ * of just the FIELDs to this point as a base for further variants.
+ *
+ * As we process each variant record, we start its size with the
+ * NL_FLDSZ we have so far. After processing it, if its NL_OFFS
+ * is the largest so far, we update the NL_OFFS of this subrecord.
+ * This will eventually propagate back and update the NL_OFFS of the
+ * entire record.
+ */
+
+/*
+ * P0 points to the outermost RECORD for name searches.
+ */
+struct nl *P0;
+
+tyrec(r, off)
+ int *r, off;
+{
+
+ tyrec1(r, off, 1);
+}
+
+/*
+ * Define a record namelist entry.
+ * R is the tree for the record to be built.
+ * Off is the offset for the first item in this (sub)record.
+ */
+tyrec1(r, off, first)
+ register int *r;
+ int off;
+ char first;
+{
+ register struct nl *p, *P0was;
+
+ p = defnl(0, RECORD, 0, 0);
+ P0was = P0;
+ if (first)
+ P0 = p;
+#ifndef PI0
+ p->value[NL_FLDSZ] = p->value[NL_OFFS] = off;
+#endif
+ if (r != NIL) {
+ fields(p, r[2]);
+ variants(p, r[3]);
+ }
+ P0 = P0was;
+ return (p);
+}
+
+/*
+ * Define the fixed part fields for p.
+ */
+fields(p, r)
+ struct nl *p;
+ int *r;
+{
+ register int *fp, *tp, *ip;
+ struct nl *jp;
+
+ for (fp = r; fp != NIL; fp = fp[2]) {
+ tp = fp[1];
+ if (tp == NIL)
+ continue;
+ jp = gtype(tp[3]);
+ line = tp[1];
+ for (ip = tp[2]; ip != NIL; ip = ip[2])
+ deffld(p, ip[1], jp);
+ }
+}
+
+/*
+ * Define the variants for RECORD p.
+ */
+variants(p, r)
+ struct nl *p;
+ register int *r;
+{
+ register int *vc, *v;
+ int *vr;
+ struct nl *ct;
+
+ if (r == NIL)
+ return;
+ ct = gtype(r[3]);
+ line = r[1];
+ /*
+ * Want it even if r[2] is NIL so
+ * we check its type in "new" and "dispose"
+ * calls -- link it to NL_TAG.
+ */
+ p->value[NL_TAG] = deffld(p, r[2], ct);
+ for (vc = r[4]; vc != NIL; vc = vc[2]) {
+ v = vc[1];
+ if (v == NIL)
+ continue;
+ vr = tyrec1(v[3], p->value[NL_FLDSZ], 0);
+#ifndef PI0
+ if (vr->value[NL_OFFS] > p->value[NL_OFFS])
+ p->value[NL_OFFS] = vr->value[NL_OFFS];
+#endif
+ line = v[1];
+ for (v = v[2]; v != NIL; v = v[2])
+ defvnt(p, v[1], vr, ct);
+ }
+}
+
+/*
+ * Define a field in subrecord p of record P0
+ * with name s and type t.
+ */
+deffld(p, s, t)
+ struct nl *p;
+ register char *s;
+ register struct nl *t;
+{
+ register struct nl *fp;
+
+ if (reclook(P0, s) != NIL) {
+#ifndef PI1
+ error("%s is a duplicate field name in this record", s);
+#endif
+ s = NIL;
+ }
+#ifndef PI0
+ fp = enter(defnl(s, FIELD, t, p->value[NL_OFFS]));
+#else
+ fp = enter(defnl(s, FIELD, t, 0));
+#endif
+ if (s != NIL) {
+ fp->chain = P0->chain;
+ P0->chain = fp;
+#ifndef PI0
+ p->value[NL_FLDSZ] = p->value[NL_OFFS] =+ even(width(t));
+#endif
+ if (t != NIL) {
+ P0->nl_flags =| t->nl_flags & NFILES;
+ p->nl_flags =| t->nl_flags & NFILES;
+ }
+ }
+ return (fp);
+}
+
+/*
+ * Define a variant from the constant tree of t
+ * in subrecord p of record P0 where the casetype
+ * is ct and the variant record to be associated is vr.
+ */
+defvnt(p, t, vr, ct)
+ struct nl *p, *vr;
+ int *t;
+ register struct nl *ct;
+{
+ register struct nl *av;
+
+ gconst(t);
+ if (ct != NIL && incompat(con.ctype, ct)) {
+#ifndef PI1
+ cerror("Variant label type incompatible with selector type");
+#endif
+ ct = NIL;
+ }
+ av = defnl(0, VARNT, ct, 0);
+#ifndef PI1
+ if (ct != NIL)
+ uniqv(p);
+#endif
+ av->chain = p->value[NL_VARNT];
+ p->value[NL_VARNT] = av;
+ av->value[NL_VTOREC] = vr;
+ av->range[0] = con.crval;
+ return (av);
+}
+
+#ifndef PI1
+/*
+ * Check that the constant label value
+ * is unique among the labels in this variant.
+ */
+uniqv(p)
+ struct nl *p;
+{
+ register struct nl *vt;
+
+ for (vt = p->value[NL_VARNT]; vt != NIL; vt = vt->chain)
+ if (vt->range[0] == con.crval) {
+ error("Duplicate variant case label in record");
+ return;
+ }
+}
+#endif
+
+/*
+ * See if the field name s is defined
+ * in the record p, returning a pointer
+ * to it namelist entry if it is.
+ */
+reclook(p, s)
+ register struct nl *p;
+ char *s;
+{
+
+ if (p == NIL || s == NIL)
+ return (NIL);
+ for (p = p->chain; p != NIL; p = p->chain)
+ if (p->symbol == s)
+ return (p);
+ return (NIL);
+}