--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 Novmeber 1978
+ */
+
+#include "whoami"
+#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;
+{
+
+ return 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.
+ */
+struct nl *
+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.
+ */
+struct nl *
+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.
+ */
+struct nl *
+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->ptr[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.
+ */
+struct nl *
+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.
+ */
+struct nl *
+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->ptr[NL_VARNT];
+ p->ptr[NL_VARNT] = av;
+ av->ptr[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->ptr[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.
+ */
+struct nl *
+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);
+}
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 Novmeber 1978
+ */
+
+#include "whoami"
+#include "0.h"
+#include "tree.h"
+#include "opcode.h"
+
+extern char *opnames[];
+/*
+ * Rvalue - an expression.
+ *
+ * Contype is the type that the caller would prefer, nand is important
+ * if constant sets or constant strings are involved, the latter
+ * because of string padding.
+ */
+struct nl *
+rvalue(r, contype)
+ int *r;
+ struct nl *contype;
+{
+ register struct nl *p, *p1;
+ register struct nl *q;
+ int c, c1, *rt, w, g;
+ char *cp, *cp1, *opname;
+ long l;
+ double f;
+
+ if (r == NIL)
+ return (NIL);
+ if (nowexp(r))
+ return (NIL);
+ /*
+ * Pick up the name of the operation
+ * for future error messages.
+ */
+ if (r[0] <= T_IN)
+ opname = opnames[r[0]];
+
+ /*
+ * The root of the tree tells us what sort of expression we have.
+ */
+ switch (r[0]) {
+
+ /*
+ * The constant nil
+ */
+ case T_NIL:
+ put2(O_CON2, 0);
+ return (nl+TNIL);
+
+ /*
+ * Function call with arguments.
+ */
+ case T_FCALL:
+ return (funccod(r));
+
+ case T_VAR:
+ p = lookup(r[2]);
+ if (p == NIL || p->class == BADUSE)
+ return (NIL);
+ switch (p->class) {
+ case VAR:
+ /*
+ * If a variable is
+ * qualified then get
+ * the rvalue by a
+ * lvalue and an ind.
+ */
+ if (r[3] != NIL)
+ goto ind;
+ q = p->type;
+ if (q == NIL)
+ return (NIL);
+ w = width(q);
+ switch (w) {
+ case 8:
+ w = 6;
+ case 4:
+ case 2:
+ case 1:
+ put2(O_RV1 + (w >> 1) | bn << 9
+ , p->value[0]);
+ break;
+ default:
+ put3(O_RV | bn << 9, p->value[0], w);
+ }
+ return (q);
+
+ case WITHPTR:
+ case REF:
+ /*
+ * A lvalue for these
+ * is actually what one
+ * might consider a rvalue.
+ */
+ind:
+ q = lvalue(r, NOMOD);
+ if (q == NIL)
+ return (NIL);
+ w = width(q);
+ switch (w) {
+ case 8:
+ w = 6;
+ case 4:
+ case 2:
+ case 1:
+ put1(O_IND1 + (w >> 1));
+ break;
+ default:
+ put2(O_IND, w);
+ }
+ return (q);
+
+ case CONST:
+ if (r[3] != NIL) {
+ error("%s is a constant and cannot be qualified", r[2]);
+ return (NIL);
+ }
+ q = p->type;
+ if (q == NIL)
+ return (NIL);
+ if (q == nl+TSTR) {
+ /*
+ * Find the size of the string
+ * constant if needed.
+ */
+ cp = p->ptr[0];
+cstrng:
+ cp1 = cp;
+ for (c = 0; *cp++; c++)
+ continue;
+ if (contype != NIL && !opt('s')) {
+ if (width(contype) < c && classify(contype) == TSTR) {
+ error("Constant string too long");
+ return (NIL);
+ }
+ c = width(contype);
+ }
+ put( 2 + (sizeof ( char * )/sizeof ( short )) , O_CONG, c, cp1);
+ /*
+ * Define the string temporarily
+ * so later people can know its
+ * width.
+ * cleaned out by stat.
+ */
+ q = defnl(0, STR, 0, c);
+ q->type = q;
+ return (q);
+ }
+ if (q == nl+T1CHAR) {
+ put2(O_CONC, p->value[0]);
+ return (q);
+ }
+ /*
+ * Every other kind of constant here
+ */
+ switch (width(q)) {
+ case 8:
+#ifndef DEBUG
+ put(5, O_CON8, p->real);
+#else
+ if (hp21mx) {
+ f = p->real;
+ conv(&f);
+ l = f.plong;
+ put( 3 , O_CON4, l);
+ } else
+ put(5, O_CON8, p->real);
+#endif
+ break;
+ case 4:
+ put( 3 , O_CON4, p->range[0]);
+ break;
+ case 2:
+ put2(O_CON2, ( short ) p->range[0]);
+ break;
+ case 1:
+ put2(O_CON1, p->value[0]);
+ break;
+ default:
+ panic("rval");
+ }
+ return (q);
+
+ case FUNC:
+ /*
+ * Function call with no arguments.
+ */
+ if (r[3]) {
+ error("Can't qualify a function result value");
+ return (NIL);
+ }
+ return (funccod((int *) r));
+
+ case TYPE:
+ error("Type names (e.g. %s) allowed only in declarations", p->symbol);
+ return (NIL);
+
+ case PROC:
+ error("Procedure %s found where expression required", p->symbol);
+ return (NIL);
+ default:
+ panic("rvid");
+ }
+ /*
+ * Constant sets
+ */
+ case T_CSET:
+ return (cset(r, contype, NIL));
+
+ /*
+ * Unary plus and minus
+ */
+ case T_PLUS:
+ case T_MINUS:
+ q = rvalue(r[2], NIL);
+ if (q == NIL)
+ return (NIL);
+ if (isnta(q, "id")) {
+ error("Operand of %s must be integer or real, not %s", opname, nameof(q));
+ return (NIL);
+ }
+ if (r[0] == T_MINUS) {
+ put1(O_NEG2 + (width(q) >> 2));
+ return (isa(q, "d") ? q : nl+T4INT);
+ }
+ return (q);
+
+ case T_NOT:
+ q = rvalue(r[2], NIL);
+ if (q == NIL)
+ return (NIL);
+ if (isnta(q, "b")) {
+ error("not must operate on a Boolean, not %s", nameof(q));
+ return (NIL);
+ }
+ put1(O_NOT);
+ return (nl+T1BOOL);
+
+ case T_AND:
+ case T_OR:
+ p = rvalue(r[2], NIL);
+ p1 = rvalue(r[3], NIL);
+ if (p == NIL || p1 == NIL)
+ return (NIL);
+ if (isnta(p, "b")) {
+ error("Left operand of %s must be Boolean, not %s", opname, nameof(p));
+ return (NIL);
+ }
+ if (isnta(p1, "b")) {
+ error("Right operand of %s must be Boolean, not %s", opname, nameof(p1));
+ return (NIL);
+ }
+ put1(r[0] == T_AND ? O_AND : O_OR);
+ return (nl+T1BOOL);
+
+ case T_DIVD:
+ p = rvalue(r[2], NIL);
+ p1 = rvalue(r[3], NIL);
+ if (p == NIL || p1 == NIL)
+ return (NIL);
+ if (isnta(p, "id")) {
+ error("Left operand of / must be integer or real, not %s", nameof(p));
+ return (NIL);
+ }
+ if (isnta(p1, "id")) {
+ error("Right operand of / must be integer or real, not %s", nameof(p1));
+ return (NIL);
+ }
+ return (gen(NIL, r[0], width(p), width(p1)));
+
+ case T_MULT:
+ case T_SUB:
+ case T_ADD:
+ /*
+ * If the context hasn't told us
+ * the type and a constant set is
+ * present on the left we need to infer
+ * the type from the right if possible
+ * before generating left side code.
+ */
+ if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) {
+ codeoff();
+ contype = rvalue(r[3], NIL);
+ codeon();
+ if (contype == NIL)
+ return (NIL);
+ }
+ p = rvalue(r[2], contype);
+ p1 = rvalue(r[3], p);
+ if (p == NIL || p1 == NIL)
+ return (NIL);
+ if (isa(p, "id") && isa(p1, "id"))
+ return (gen(NIL, r[0], width(p), width(p1)));
+ if (isa(p, "t") && isa(p1, "t")) {
+ if (p != p1) {
+ error("Set types of operands of %s must be identical", opname);
+ return (NIL);
+ }
+ gen(TSET, r[0], width(p), 0);
+ /*
+ * Note that set was filled in by the call
+ * to width above.
+ */
+ if (r[0] == T_SUB)
+ put2(NIL, 0177777 << ((set.uprbp & 017) + 1));
+ return (p);
+ }
+ if (isnta(p, "idt")) {
+ error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p));
+ return (NIL);
+ }
+ if (isnta(p1, "idt")) {
+ error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1));
+ return (NIL);
+ }
+ error("Cannot mix sets with integers and reals as operands of %s", opname);
+ return (NIL);
+
+ case T_MOD:
+ case T_DIV:
+ p = rvalue(r[2], NIL);
+ p1 = rvalue(r[3], NIL);
+ if (p == NIL || p1 == NIL)
+ return (NIL);
+ if (isnta(p, "i")) {
+ error("Left operand of %s must be integer, not %s", opname, nameof(p));
+ return (NIL);
+ }
+ if (isnta(p1, "i")) {
+ error("Right operand of %s must be integer, not %s", opname, nameof(p1));
+ return (NIL);
+ }
+ return (gen(NIL, r[0], width(p), width(p1)));
+
+ case T_EQ:
+ case T_NE:
+ case T_GE:
+ case T_LE:
+ case T_GT:
+ case T_LT:
+ /*
+ * Since there can be no, a priori, knowledge
+ * of the context type should a constant string
+ * or set arise, we must poke around to find such
+ * a type if possible. Since constant strings can
+ * always masquerade as identifiers, this is always
+ * necessary.
+ */
+ codeoff();
+ p1 = rvalue(r[3], NIL);
+ codeon();
+ if (p1 == NIL)
+ return (NIL);
+ contype = p1;
+ if (p1 == nl+TSET || p1->class == STR) {
+ /*
+ * For constant strings we want
+ * the longest type so as to be
+ * able to do padding (more importantly
+ * avoiding truncation). For clarity,
+ * we get this length here.
+ */
+ codeoff();
+ p = rvalue(r[2], NIL);
+ codeon();
+ if (p == NIL)
+ return (NIL);
+ if (p1 == nl+TSET || width(p) > width(p1))
+ contype = p;
+ }
+ /*
+ * Now we generate code for
+ * the operands of the relational
+ * operation.
+ */
+ p = rvalue(r[2], contype);
+ if (p == NIL)
+ return (NIL);
+ p1 = rvalue(r[3], p);
+ if (p1 == NIL)
+ return (NIL);
+ c = classify(p);
+ c1 = classify(p1);
+ if (nocomp(c) || nocomp(c1))
+ return (NIL);
+ g = NIL;
+ switch (c) {
+ case TBOOL:
+ case TCHAR:
+ if (c != c1)
+ goto clash;
+ break;
+ case TINT:
+ case TDOUBLE:
+ if (c1 != TINT && c1 != TDOUBLE)
+ goto clash;
+ break;
+ case TSCAL:
+ if (c1 != TSCAL)
+ goto clash;
+ if (scalar(p) != scalar(p1))
+ goto nonident;
+ break;
+ case TSET:
+ if (c1 != TSET)
+ goto clash;
+ if (p != p1)
+ goto nonident;
+ g = TSET;
+ break;
+ case TPTR:
+ case TNIL:
+ if (c1 != TPTR && c1 != TNIL)
+ goto clash;
+ if (r[0] != T_EQ && r[0] != T_NE) {
+ error("%s not allowed on pointers - only allow = and <>");
+ return (NIL);
+ }
+ break;
+ case TSTR:
+ if (c1 != TSTR)
+ goto clash;
+ if (width(p) != width(p1)) {
+ error("Strings not same length in %s comparison", opname);
+ return (NIL);
+ }
+ g = TSTR;
+ break;
+ default:
+ panic("rval2");
+ }
+ return (gen(g, r[0], width(p), width(p1)));
+clash:
+ error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname);
+ return (NIL);
+nonident:
+ error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname);
+ return (NIL);
+
+ case T_IN:
+ rt = r[3];
+ if (rt != NIL && rt[0] == T_CSET)
+ p1 = cset(rt, NLNIL, 1);
+ else {
+ p1 = rvalue(r[3], NIL);
+ rt = NIL;
+ }
+ if (p1 == nl+TSET) {
+ warning();
+ error("... in [] makes little sense, since it is always false!");
+ put1(O_CON1, 0);
+ return (nl+T1BOOL);
+ }
+ p = rvalue(r[2], NIL);
+ if (p == NIL || p1 == NIL)
+ return (NIL);
+ if (p1->class != SET) {
+ error("Right operand of 'in' must be a set, not %s", nameof(p1));
+ return (NIL);
+ }
+ if (incompat(p, p1->type, r[2])) {
+ cerror("Index type clashed with set component type for 'in'");
+ return (NIL);
+ }
+ convert(p, nl+T2INT);
+ setran(p1->type);
+ if (rt == NIL)
+ put4(O_IN, width(p1), set.lwrb, set.uprbp);
+ else
+ put1(O_INCT);
+ return (nl+T1BOOL);
+
+ default:
+ if (r[2] == NIL)
+ return (NIL);
+ switch (r[0]) {
+ default:
+ panic("rval3");
+
+
+ /*
+ * An octal number
+ */
+ case T_BINT:
+ f = a8tol(r[2]);
+ goto conint;
+
+ /*
+ * A decimal number
+ */
+ case T_INT:
+ f = atof(r[2]);
+conint:
+ if (f > MAXINT || f < MININT) {
+ error("Constant too large for this implementation");
+ return (NIL);
+ }
+ l = f;
+ if (bytes(l, l) <= 2) {
+ put2(O_CON2, ( short ) l);
+ return (nl+T2INT);
+ }
+ put( 3 , O_CON4, l);
+ return (nl+T4INT);
+
+ /*
+ * A floating point number
+ */
+ case T_FINT:
+ put(5, O_CON8, atof(r[2]));
+ return (nl+TDOUBLE);
+
+ /*
+ * Constant strings. Note that constant characters
+ * are constant strings of length one; there is
+ * no constant string of length one.
+ */
+ case T_STRNG:
+ cp = r[2];
+ if (cp[1] == 0) {
+ put2(O_CONC, cp[0]);
+ return (nl+T1CHAR);
+ }
+ goto cstrng;
+ }
+
+ }
+}
+
+/*
+ * Can a class appear
+ * in a comparison ?
+ */
+nocomp(c)
+ int c;
+{
+
+ switch (c) {
+ case TFILE:
+ case TARY:
+ case TREC:
+ error("%ss may not participate in comparisons", clnames[c]);
+ return (1);
+ }
+ return (NIL);
+}
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 November 1978
+ */
+
+#include "whoami"
+#include "0.h"
+#include "tree.h"
+
+int cntstat;
+short cnts = 2;
+#include "opcode.h"
+
+/*
+ * Statement list
+ */
+statlist(r)
+ int *r;
+{
+ register *sl;
+
+ for (sl=r; sl != NIL; sl=sl[2])
+ statement(sl[1]);
+}
+
+/*
+ * Statement
+ */
+statement(r)
+ int *r;
+{
+ register *s;
+ register struct nl *snlp;
+
+ s = r;
+ snlp = nlp;
+top:
+ if (cntstat) {
+ cntstat = 0;
+ putcnt();
+ }
+ if (s == NIL)
+ return;
+ line = s[1];
+ if (s[0] == T_LABEL) {
+ labeled(s[2]);
+ s = s[3];
+ noreach = 0;
+ cntstat = 1;
+ goto top;
+ }
+ if (noreach) {
+ noreach = 0;
+ warning();
+ error("Unreachable statement");
+ }
+ switch (s[0]) {
+ case T_PCALL:
+ putline();
+ proc(s);
+ break;
+ case T_ASGN:
+ putline();
+ asgnop(s);
+ break;
+ case T_GOTO:
+ putline();
+ gotoop(s[2]);
+ noreach = 1;
+ cntstat = 1;
+ break;
+ default:
+ level++;
+ switch (s[0]) {
+ default:
+ panic("stat");
+ case T_IF:
+ case T_IFEL:
+ ifop(s);
+ break;
+ case T_WHILE:
+ whilop(s);
+ noreach = 0;
+ break;
+ case T_REPEAT:
+ repop(s);
+ break;
+ case T_FORU:
+ case T_FORD:
+ forop(s);
+ noreach = 0;
+ break;
+ case T_BLOCK:
+ statlist(s[2]);
+ break;
+ case T_CASE:
+ putline();
+ caseop(s);
+ break;
+ case T_WITH:
+ withop(s);
+ break;
+ case T_ASRT:
+ putline();
+ asrtop(s);
+ break;
+ }
+ --level;
+ if (gotos[cbn])
+ ungoto();
+ break;
+ }
+ /*
+ * Free the temporary name list entries defined in
+ * expressions, e.g. STRs, and WITHPTRs from withs.
+ */
+ nlfree(snlp);
+}
+
+ungoto()
+{
+ register struct nl *p;
+
+ for (p = gotos[cbn]; p != NIL; p = p->chain)
+ if ((p->nl_flags & NFORWD) != 0) {
+ if (p->value[NL_GOLEV] != NOTYET)
+ if (p->value[NL_GOLEV] > level)
+ p->value[NL_GOLEV] = level;
+ } else
+ if (p->value[NL_GOLEV] != DEAD)
+ if (p->value[NL_GOLEV] > level)
+ p->value[NL_GOLEV] = DEAD;
+}
+
+putcnt()
+{
+
+ if (monflg == 0)
+ return;
+ cnts++;
+ put2(O_COUNT, cnts);
+}
+
+putline()
+{
+
+# ifdef OBJ
+ if (opt('p') != 0)
+ put2(O_LINO, line);
+# endif
+}
+
+/*
+ * With varlist do stat
+ *
+ * With statement requires an extra word
+ * in automatic storage for each level of withing.
+ * These indirect pointers are initialized here, and
+ * the scoping effect of the with statement occurs
+ * because lookup examines the field names of the records
+ * associated with the WITHPTRs on the withlist.
+ */
+withop(s)
+ int *s;
+{
+ register *p;
+ register struct nl *r;
+ int i;
+ int *swl;
+ long soffset;
+
+ putline();
+ swl = withlist;
+ soffset = sizes[cbn].om_off;
+ for (p = s[2]; p != NIL; p = p[2]) {
+ sizes[cbn].om_off -= sizeof ( int * );
+# ifdef PPC
+ putlbracket();
+# endif
+ put2(O_LV | cbn <<9, i = sizes[cbn].om_off);
+ r = lvalue(p[1], MOD);
+ if (r == NIL)
+ continue;
+ if (r->class != RECORD) {
+ error("Variable in with statement refers to %s, not to a record", nameof(r));
+ continue;
+ }
+ r = defnl(0, WITHPTR, r, i);
+ r->nl_next = withlist;
+ withlist = r;
+# ifdef VAX
+ put1 ( O_AS4 );
+# endif
+# ifdef PDP11
+ put1(O_AS2);
+# endif
+ }
+ if (sizes[cbn].om_off < sizes[cbn].om_max)
+ sizes[cbn].om_max = sizes[cbn].om_off;
+ statement(s[3]);
+ sizes[cbn].om_off = soffset;
+# ifdef PPC
+ putlbracket();
+# endif
+ withlist = swl;
+}
+
+extern flagwas;
+/*
+ * var := expr
+ */
+asgnop(r)
+ int *r;
+{
+ register struct nl *p;
+ register *av;
+
+ if (r == NIL)
+ return (NIL);
+ /*
+ * Asgnop's only function is
+ * to handle function variable
+ * assignments. All other assignment
+ * stuff is handled by asgnop1.
+ */
+ av = r[2];
+ if (av != NIL && av[0] == T_VAR && av[3] == NIL) {
+ p = lookup1(av[2]);
+ if (p != NIL)
+ p->nl_flags = flagwas;
+ if (p != NIL && p->class == FVAR) {
+ /*
+ * Give asgnop1 the func
+ * which is the chain of
+ * the FVAR.
+ */
+ p->nl_flags |= NUSED|NMOD;
+ p = p->chain;
+ if (p == NIL) {
+ rvalue(r[3], NIL);
+ return;
+ }
+ put2(O_LV | bn << 9, p->value[NL_OFFS]);
+ if (isa(p->type, "i") && width(p->type) == 1)
+ asgnop1(r, nl+T2INT);
+ else
+ asgnop1(r, p->type);
+ return;
+ }
+ }
+ asgnop1(r, NIL);
+}
+
+/*
+ * Asgnop1 handles all assignments.
+ * If p is not nil then we are assigning
+ * to a function variable, otherwise
+ * we look the variable up ourselves.
+ */
+struct nl *
+asgnop1(r, p)
+ int *r;
+ register struct nl *p;
+{
+ register struct nl *p1;
+
+ if (r == NIL)
+ return (NIL);
+ if (p == NIL) {
+ p = lvalue(r[2], MOD|ASGN|NOUSE);
+ if (p == NIL) {
+ rvalue(r[3], NIL);
+ return (NIL);
+ }
+ }
+ p1 = rvalue(r[3], p);
+ if (p1 == NIL)
+ return (NIL);
+ if (incompat(p1, p, r[3])) {
+ cerror("Type of expression clashed with type of variable in assignment");
+ return (NIL);
+ }
+ switch (classify(p)) {
+ case TBOOL:
+ case TCHAR:
+ case TINT:
+ case TSCAL:
+ rangechk(p, p1);
+ case TDOUBLE:
+ case TPTR:
+ gen(O_AS2, O_AS2, width(p), width(p1));
+ break;
+ default:
+ put2(O_AS, width(p));
+ }
+# ifdef PPC
+ putexpr();
+# endif
+ return (p); /* Used by for statement */
+}
+
+/*
+ * for var := expr [down]to expr do stat
+ */
+forop(r)
+ int *r;
+{
+ register struct nl *t1, *t2;
+ int l1, l2, l3;
+ long soffset;
+ register op;
+ struct nl *p;
+ int *rr, goc, i;
+
+ p = NIL;
+ goc = gocnt;
+ if (r == NIL)
+ goto aloha;
+ putline();
+ /*
+ * Start with assignment
+ * of initial value to for variable
+ */
+ t1 = asgnop1(r[2], NIL);
+ if (t1 == NIL) {
+ rvalue(r[3], NIL);
+ statement(r[4]);
+ goto aloha;
+ }
+ rr = r[2]; /* Assignment */
+ rr = rr[2]; /* Lhs variable */
+ if (rr[3] != NIL) {
+ error("For variable must be unqualified");
+ rvalue(r[3], NIL);
+ statement(r[4]);
+ goto aloha;
+ }
+ p = lookup(rr[2]);
+ p->value[NL_FORV] = 1;
+ if (isnta(t1, "bcis")) {
+ error("For variables cannot be %ss", nameof(t1));
+ statement(r[4]);
+ goto aloha;
+ }
+ /*
+ * Allocate automatic
+ * space for limit variable
+ */
+ sizes[cbn].om_off -= 4;
+# ifdef PPC
+ putlbracket();
+# endif
+ if (sizes[cbn].om_off < sizes[cbn].om_max)
+ sizes[cbn].om_max = sizes[cbn].om_off;
+ i = sizes[cbn].om_off;
+ /*
+ * Initialize the limit variable
+ */
+ put2(O_LV | cbn<<9, i);
+ t2 = rvalue(r[3], NIL);
+ if (incompat(t2, t1, r[3])) {
+ cerror("Limit type clashed with index type in 'for' statement");
+ statement(r[4]);
+ goto aloha;
+ }
+ put1(width(t2) <= 2 ? O_AS24 : O_AS4);
+# ifdef PPC
+ putexpr();
+# endif
+ /*
+ * See if we can skip the loop altogether
+ */
+ rr = r[2];
+ if (rr != NIL)
+ rvalue(rr[2], NIL);
+ put2(O_RV4 | cbn<<9, i);
+ gen(NIL, r[0] == T_FORU ? T_LE : T_GE, width(t1), 4);
+ /*
+ * L1 will be patched to skip the body of the loop.
+ * L2 marks the top of the loop when we go around.
+ */
+ put2(O_IF, (l1 = getlab()));
+ putlab(l2 = getlab());
+ putcnt();
+ statement(r[4]);
+ /*
+ * now we see if we get to go again
+ */
+ if (opt('t') == 0) {
+ /*
+ * Easy if we dont have to test
+ */
+ put2(O_RV4 | cbn<<9, i);
+ if (rr != NIL)
+ lvalue(rr[2], MOD);
+ put2((r[0] == T_FORU ? O_FOR1U : O_FOR1D) + (width(t1) >> 1), l2);
+ } else {
+ line = r[1];
+ putline();
+ if (rr != NIL)
+ rvalue(rr[2], NIL);
+ put2(O_RV4 | cbn << 9, i);
+ gen(NIL, (r[0] == T_FORU ? T_LT : T_GT), width(t1), 4);
+ l3 = put2(O_IF, getlab());
+ lvalue((int *) rr[2], MOD);
+ rvalue(rr[2], NIL);
+ put2(O_CON2, 1);
+ t2 = gen(NIL, r[0] == T_FORU ? T_ADD: T_SUB, width(t1), 2);
+ rangechk(t1, t2); /* The point of all this */
+ gen(O_AS2, O_AS2, width(t1), width(t2));
+ put2(O_TRA, l2);
+ patch(l3);
+ }
+ sizes[cbn].om_off += 4;
+# ifdef PPC
+ putlbracket();
+# endif
+ patch(l1);
+aloha:
+ noreach = 0;
+ if (p != NIL)
+ p->value[NL_FORV] = 0;
+ if (goc != gocnt)
+ putcnt();
+}
+
+/*
+ * if expr then stat [ else stat ]
+ */
+ifop(r)
+ int *r;
+{
+ register struct nl *p;
+ register l1, l2;
+ int nr, goc;
+
+ goc = gocnt;
+ if (r == NIL)
+ return;
+ putline();
+ p = rvalue(r[2], NIL);
+ if (p == NIL) {
+ statement(r[3]);
+ noreach = 0;
+ statement(r[4]);
+ noreach = 0;
+ return;
+ }
+ if (isnta(p, "b")) {
+ error("Type of expression in if statement must be Boolean, not %s", nameof(p));
+ statement(r[3]);
+ noreach = 0;
+ statement(r[4]);
+ noreach = 0;
+ return;
+ }
+ l1 = put2(O_IF, getlab());
+ putcnt();
+ statement(r[3]);
+ nr = noreach;
+ if (r[4] != NIL) {
+ /*
+ * else stat
+ */
+ --level;
+ ungoto();
+ ++level;
+ l2 = put2(O_TRA, getlab());
+ patch(l1);
+ noreach = 0;
+ statement(r[4]);
+ noreach &= nr;
+ l1 = l2;
+ } else
+ noreach = 0;
+ patch(l1);
+ if (goc != gocnt)
+ putcnt();
+}
+
+/*
+ * while expr do stat
+ */
+whilop(r)
+ int *r;
+{
+ register struct nl *p;
+ register l1, l2;
+ int goc;
+
+ goc = gocnt;
+ if (r == NIL)
+ return;
+ putlab(l1 = getlab());
+ putline();
+ p = rvalue(r[2], NIL);
+ if (p == NIL) {
+ statement(r[3]);
+ noreach = 0;
+ return;
+ }
+ if (isnta(p, "b")) {
+ error("Type of expression in while statement must be Boolean, not %s", nameof(p));
+ statement(r[3]);
+ noreach = 0;
+ return;
+ }
+ put2(O_IF, (l2 = getlab()));
+ putcnt();
+ statement(r[3]);
+ put2(O_TRA, l1);
+ patch(l2);
+ if (goc != gocnt)
+ putcnt();
+}
+
+/*
+ * repeat stat* until expr
+ */
+repop(r)
+ int *r;
+{
+ register struct nl *p;
+ register l;
+ int goc;
+
+ goc = gocnt;
+ if (r == NIL)
+ return;
+ l = putlab(getlab());
+ putcnt();
+ statlist(r[2]);
+ line = r[1];
+ p = rvalue(r[3], NIL);
+ if (p == NIL)
+ return;
+ if (isnta(p,"b")) {
+ error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
+ return;
+ }
+ put2(O_IF, l);
+ if (goc != gocnt)
+ putcnt();
+}
+
+/*
+ * assert expr
+ */
+asrtop(r)
+ register int *r;
+{
+ register struct nl *q;
+
+ if (opt('s')) {
+ standard();
+ error("Assert statement is non-standard");
+ }
+ if (!opt('t'))
+ return;
+ r = r[2];
+ q = rvalue((int *) r, NLNIL);
+ if (q == NIL)
+ return;
+ if (isnta(q, "b"))
+ error("Assert expression must be Boolean, not %ss", nameof(q));
+ put1(O_ASRT);
+}
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 November 1978
+ *
+ * pxp - Pascal execution profiler
+ *
+ * Bill Joy UCB
+ * Version 1.2 November 1978
+ */
+
+#include "whoami"
+#include "0.h"
+#ifndef PI01
+#ifndef PXP
+#include "send.h"
+#endif
+#endif
+
+/*
+ * STRING SPACE DECLARATIONS
+ *
+ * Strng is the base of the current
+ * string space and strngp the
+ * base of the free area therein.
+ * Strp is the array of descriptors.
+ */
+#ifndef PI0
+STATIC char strings[STRINC];
+STATIC char *strng = strings;
+STATIC char *strngp = strings;
+#else
+char *strng, *strngp;
+#endif
+#ifndef PI01
+#ifndef PXP
+STATIC char *strp[20];
+STATIC char **stract strp;
+int strmax;
+#endif
+#endif
+
+#ifndef PI01
+#ifndef PXP
+#ifndef PI0
+initstring()
+#else
+initstring(strings)
+ char *strings;
+#endif
+{
+
+ *stract++ = strings;
+#ifdef PI0
+ strng = strngp = strings;
+#endif
+ strmax = STRINC * 2;
+}
+#endif
+#endif
+
+/*
+ * Copy a string into the string area.
+ */
+char *
+savestr(cp)
+ register char *cp;
+{
+ register int i;
+
+ i = strlen(cp) + 1;
+ if (strngp + i >= strng + STRINC) {
+ strngp = malloc(STRINC);
+ if (strngp == -1) {
+ yerror("Ran out of memory (string)");
+ pexit(DIED);
+ }
+#ifndef PI01
+#ifndef PXP
+ *stract++ = strngp;
+ strmax =+ STRINC;
+#endif
+#endif
+ strng = strngp;
+ }
+ strcpy(strngp, cp);
+ cp = strngp;
+ strngp = cp + i;
+#ifdef PI0
+ send(RSTRING, cp);
+#endif
+ return (cp);
+}
+
+#ifndef PI1
+#ifndef PXP
+esavestr(cp)
+ char *cp;
+{
+
+#ifdef PI0
+ send(REVENIT);
+#endif
+ strngp = ( (char *) ( ( (int) (strngp + 1) ) &~ 1 ) );
+ return (savestr(cp));
+}
+#endif
+#endif
+
+#ifndef PI01
+#ifndef PXP
+soffset(cp)
+ register char *cp;
+{
+ register char **sp;
+ register int i;
+
+ if (cp == NIL || cp == OCT || cp == HEX)
+ return (-cp);
+ for (i = STRINC, sp = strp; sp < stract; sp++) {
+ if (cp >= *sp && cp < (*sp + STRINC))
+ return (i + (cp - *sp));
+ i =+ STRINC;
+ }
+ i = nlfund(cp);
+ if (i != 0)
+ return (i);
+ panic("soffset");
+}
+#ifdef PI1
+sreloc(i)
+ register int i;
+{
+
+ if (i == 0 || i == -OCT || i == -HEX)
+ return (-i);
+ if (i < STRINC) {
+ if (i >= INL)
+ panic("sreloc INL");
+ i = nl[i].symbol;
+ if (i == 0)
+ panic("sreloc nl[i]");
+ return (i);
+ }
+ if (i > strmax || i < 0)
+ panic("sreloc");
+ return (strp[(i / STRINC) - 1] + (i % STRINC));
+}
+
+evenit()
+{
+
+ strngp = (strngp + 1) &~ 1;
+}
+#endif
+#endif
+#endif
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#include "whoami"
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.2 November 1978
+ *
+ *
+ * pxp - Pascal execution profiler
+ *
+ * Bill Joy UCB
+ * Version 1.2 November 1978
+ */
+
+#include "0.h"
+
+#ifndef PI1
+/*
+ * Does the string fp end in '.' and the character c ?
+ */
+dotted(fp, c)
+ register char *fp;
+ char c;
+{
+ register int i;
+
+ i = strlen(fp);
+ return (i > 1 && fp[i - 2] == '.' && fp[i - 1] == c);
+}
+
+/*
+ * Toggle the option c.
+ */
+togopt(c)
+ char c;
+{
+ register char *tp;
+
+ tp = &opts[c-'a'];
+ *tp = 1 - *tp;
+}
+
+/*
+ * Set the time vector "tvec" to the
+ * modification time stamp of a file.
+ */
+gettime( filename )
+ char *filename;
+{
+#include <stat.h>
+ struct stat stb;
+
+ stat(filename, &stb);
+ tvec = stb.st_mtime;
+}
+
+/*
+ * Convert a "ctime" into a Pascal styple time line
+ */
+char *
+myctime(tv)
+ int *tv;
+{
+ register char *cp, *dp;
+ char *cpp;
+ register i;
+ static char mycbuf[26];
+
+ cpp = ctime(tv);
+ dp = mycbuf;
+ cp = cpp;
+ cpp[16] = 0;
+ while (*dp++ = *cp++);
+ dp--;
+ cp = cpp+19;
+ cpp[24] = 0;
+ while (*dp++ = *cp++);
+ return (mycbuf);
+}
+
+/*
+ * Is "fp" in the command line list of names ?
+ */
+inpflist(fp)
+ char *fp;
+{
+ register i, *pfp;
+
+ pfp = pflist;
+ for (i = pflstc; i > 0; i--)
+ if (strcmp(fp, *pfp++) == 0)
+ return (1);
+ return (0);
+}
+#endif
+
+extern int errno;
+extern char *sys_errlist[];
+
+/*
+ * Boom!
+ */
+Perror(file, error)
+ char *file, *error;
+{
+
+ errno = 0;
+ sys_errlist[0] = error;
+ perror(file);
+}
+
+int *
+calloc(num, size)
+ int num, size;
+{
+ register int p1, *p2, nbyte;
+
+ nbyte = (num*size+( ( sizeof ( int ) ) - 1 ) ) & ~( ( sizeof ( int ) ) - 1 );
+ if ((p1 = malloc(nbyte)) == -1 || p1==0)
+ return (-1);
+ p2 = p1;
+ nbyte /= sizeof ( int );
+ do {
+ *p2++ = 0;
+ } while (--nbyte);
+ return (p1);
+}
+
+/*
+ * Compare strings: s1>s2: >0 s1==s2: 0 s1<s2: <0
+ */
+strcmp(s1, s2)
+ register char *s1, *s2;
+{
+
+ while (*s1 == *s2++)
+ if (*s1++=='\0')
+ return (0);
+ return (*s1 - *--s2);
+}
+
+/*
+ * Copy string s2 to s1.
+ * S1 must be large enough.
+ * Return s1.
+ */
+strcpy(s1, s2)
+ register char *s1, *s2;
+{
+ register os1;
+
+ os1 = s1;
+ while (*s1++ = *s2++)
+ continue;
+ return (os1);
+}
+
+/*
+ * Strlen is currently a freebie of perror
+ * Take the length of a string.
+ * Note that this does not include the trailing null!
+strlen(cp)
+ register char *cp;
+{
+ register int i;
+
+ for (i = 0; *cp != 0; cp++)
+ i++;
+ return (i);
+}
+ */
+copy(to, from, bytes)
+ register char *to, *from;
+ register int bytes;
+{
+
+ if (bytes != 0)
+ do
+ *to++ = *from++;
+ while (--bytes);
+}
+
+/*
+ * Is ch one of the characters in the string cp ?
+ */
+any(cp, ch)
+ register char *cp;
+ char ch;
+{
+
+ while (*cp)
+ if (*cp++ == ch)
+ return (1);
+ return (0);
+}
+
+opush(c)
+ register CHAR c;
+{
+
+ c -= 'a';
+ optstk[c] <<= 1;
+ optstk[c] |= opts[c];
+ opts[c] = 1;
+#ifdef PI0
+ send(ROPUSH, c);
+#endif
+}
+
+opop(c)
+ register CHAR c;
+{
+
+ c -= 'a';
+ opts[c] = optstk[c] & 1;
+ optstk[c] >>= 1;
+#ifdef PI0
+ send(ROPOP, c);
+#endif
+}
--- /dev/null
+ /*
+ * tCopy.c
+ *
+ * functions to copy pi trees to pTrees
+ */
+
+#include "whoami"
+
+#ifdef PTREE
+
+#include "0.h"
+
+#include "tree.h"
+
+ /*
+ * tCopy
+ * a mongo switch statement to farm out the actual copying
+ * to the appropriate routines.
+ * given a pointer to a pi tree branch, it returns a pPointer to
+ * a pTree copy of that branch.
+ */
+pPointer
+tCopy( node )
+ int *node;
+ {
+
+ if ( node == NIL )
+ return pNIL;
+ switch ( node[ 0 ] ) {
+ case T_PROG:
+ case T_PDEC:
+ case T_FDEC:
+ return PorFCopy( node );
+ case T_TYPTR:
+ return PtrTCopy( node );
+ case T_TYPACK:
+ return PackTCopy( node );
+ case T_TYSCAL:
+ return EnumTCopy( node );
+ case T_TYRANG:
+ return RangeTCopy( node );
+ case T_TYARY:
+ return ArrayTCopy( node );
+ case T_TYFILE:
+ return FileTCopy( node );
+ case T_TYSET:
+ return SetTCopy( node );
+ case T_TYREC:
+ return RecTCopy( node );
+ case T_FLDLST:
+ return FldlstCopy( node );
+ case T_RFIELD:
+ return FieldCopy( node );
+ case T_TYVARPT:
+ return VarntCopy( node );
+ case T_TYVARNT:
+ return VCaseCopy( node );
+ case T_CSTAT:
+ return CasedCopy( node );
+ case T_PVAL:
+ case T_PVAR:
+ return ParamCopy( node );
+ case T_CSTRNG:
+ return sCopy( node[1] );
+ case T_STRNG:
+ return sCopy( node[2] );
+ case T_PLUSC:
+ case T_PLUS:
+ case T_MINUSC:
+ case T_MINUS:
+ case T_NOT:
+ return UnOpCopy( node );
+ case T_ID:
+ return ThreadSymbol( node[1] );
+ case T_TYID:
+ return ThreadSymbol( node[2] );
+ case T_CINT:
+ case T_CBINT:
+ return iCopy( node[1] );
+ case T_INT:
+ case T_BINT:
+ return iCopy( node[2] );
+ case T_CFINT:
+ return fCopy( node[1] );
+ case T_FINT:
+ return fCopy( node[2] );
+ case T_LISTPP:
+ return ListCopy( node );
+ case T_PCALL:
+ return PCallCopy( node );
+ case T_BLOCK:
+ case T_BSTL:
+ return ListCopy( node[2] );
+ case T_CASE:
+ return CaseSCopy( node );
+ case T_WITH:
+ return WithCopy( node );
+ case T_WHILE:
+ return WhileCopy( node );
+ case T_REPEAT:
+ return RepeatCopy( node );
+ case T_FORU:
+ case T_FORD:
+ return ForCopy( node );
+ case T_IF:
+ case T_IFEL:
+ return IfCopy( node );
+ case T_GOTO:
+ return GotoCopy( node );
+ case T_LABEL:
+ return LabelCopy( node );
+ case T_ASRT:
+ return AssertCopy( node );
+ case T_ASGN:
+ return AssignCopy( node );
+ case T_NIL:
+ return NilCopy( node );
+ case T_FCALL:
+ return FCallCopy( node );
+ case T_CSET:
+ return SetCopy( node );
+ case T_RANG:
+ return RangeCopy( node );
+ case T_VAR:
+ return VarCopy( node );
+ case T_ARY:
+ return SubscCopy( node );
+ case T_FIELD:
+ return SelCopy( node );
+ case T_PTR:
+ return PtrCopy( node );
+ case T_EQ:
+ case T_LT:
+ case T_GT:
+ case T_LE:
+ case T_GE:
+ case T_NE:
+ case T_IN:
+ case T_ADD:
+ case T_SUB:
+ case T_MULT:
+ case T_DIVD:
+ case T_DIV:
+ case T_MOD:
+ case T_OR:
+ case T_AND:
+ return BinOpCopy( node );
+ case T_WEXP:
+ return WidthCopy( node );
+ default:
+ panic("tCopy");
+ }
+ }
+
+\f
+ /*
+ * copy a list of nodes into ListNodes
+ * (with a hack for appending one list to another
+ * for example: labelled statements)
+ * listnode[0] T_LISTPP
+ * [1] "list_element"
+ * [2] "list_next"
+ */
+pPointer
+ListCopy( listnode )
+ int *listnode;
+ {
+ pPointer First;
+ pPointer After;
+ int *listp;
+ pPointer Item;
+ pPointer List;
+ pPointer Furthur;
+
+ First = pNIL;
+ After = pNIL;
+ for ( listp = listnode ; listp != NIL ; listp = (int *) listp[2] ) {
+ List = pNewNode( ListTAG , sizeof( struct ListNode ) );
+ if ( First == pNIL )
+ First = List;
+ Item = tCopy( listp[1] );
+ pDEF( List ).ListItem = Item;
+ pDEF( List ).ListDown = pNIL;
+ pDEF( List ).ListUp = After;
+ if ( After != pNIL )
+ pDEF( After ).ListDown = List;
+ After = List;
+ /*
+ * if ListItem is a ListNode whose ListUp is non-pNIL
+ * append that list to this list, using that ListUp
+ * as an additional ListItem.
+ */
+ Furthur = Item;
+ if ( Furthur != pNIL
+ && pTAG( Furthur ) == ListTAG
+ && pUSE( Furthur ).ListUp != pNIL ) {
+ Item = pUSE( Furthur ).ListUp;
+ pDEF( List ).ListItem = Item;
+ pDEF( Furthur ).ListUp = List;
+ pDEF( List ).ListDown = Furthur;
+ do {
+ After = Furthur;
+ Furthur = pUSE( After ).ListDown;
+ } while ( Furthur != pNIL );
+ }
+ }
+ return First;
+ }
+
+ /*
+ * ListAppend
+ * append a random item to the end of a list
+ * (with a hack for appending one list to another
+ * e.g. labelled statments)
+ */
+pPointer
+ListAppend( list , item )
+ pPointer list;
+ pPointer item;
+ {
+ pPointer List = pNewNode( ListTAG , sizeof( struct ListNode ) );
+ pPointer First;
+ pPointer After;
+ pPointer Furthur;
+
+ pDEF( List ).ListItem = item;
+ pDEF( List ).ListDown = pNIL;
+ First = After = list;
+ if ( First == pNIL ) {
+ First = List;
+ } else {
+ while ( ( Furthur = pUSE( After ).ListDown ) != pNIL )
+ After = Furthur;
+ pDEF( After ).ListDown = List;
+ }
+ pDEF( List ).ListUp = After;
+ /*
+ * if item is a ListNode whose ListUp is non-pNIL
+ * append that list to this list, using that ListUp
+ * as an additional ListItem.
+ */
+ Furthur = item;
+ if ( Furthur != pNIL
+ && pTAG( Furthur ) == ListTAG
+ && pUSE( Furthur ).ListUp != pNIL ) {
+ pDEF( List ).ListDown = Furthur;
+ pDEF( List ).ListItem = pUSE( Furthur ).ListUp;
+ pDEF( Furthur ).ListUp = List;
+ }
+ return First;
+ }
+
+ /*
+ * iCopy
+ * copy an integer (string) to an IntNode
+ */
+pPointer
+iCopy( intstring )
+ char *intstring;
+ {
+ pPointer Int = pNewNode( IntTAG , sizeof( struct IntNode ) );
+
+ pDEF( Int ).IntValue = atol( intstring );
+ return Int;
+ }
+
+ /*
+ * fCopy
+ * copy a float (string) to a RealNode
+ */
+pPointer
+fCopy( realstring )
+ char *realstring;
+ {
+ pPointer Real = pNewNode( RealTAG , sizeof( struct RealNode ) );
+
+ pDEF( Real ).RealValue = atof( realstring );
+ return Real;
+ }
+
+ /*
+ * sCopy
+ * copy a string to a StringNode
+ */
+pPointer
+sCopy( string )
+ char *string;
+ {
+ pPointer String;
+
+ if ( string == NIL )
+ return pNIL;
+ String = pNewNode( StringTAG , strlen( string ) + 1 );
+ strcpy( pDEF( String ).StringValue , string );
+ return String;
+ }
+
+#endif PTREE
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.1 February 1978
+ *
+ *
+ * pxp - Pascal execution profiler
+ *
+ * Bill Joy UCB
+ * Version 1.1 February 1978
+ */
+
+#include "whoami"
+#include "0.h"
+
+/*
+ * TREE SPACE DECLARATIONS
+ */
+struct tr {
+ int *tr_low;
+ int *tr_high;
+} ttab[MAXTREE], *tract;
+
+/*
+ * The variable space is the
+ * absolute base of the tree segments.
+ * (exactly the same as ttab[0].tr_low)
+ * Spacep is maintained to point at the
+ * beginning of the next tree slot to
+ * be allocated for use by the grammar.
+ * Spacep is used "extern" by the semantic
+ * actions in pas.y.
+ * The variable tract is maintained to point
+ * at the tree segment out of which we are
+ * allocating (the active segment).
+ */
+int *space, *spacep;
+
+/*
+ * TREENMAX is the maximum width
+ * in words that any tree node
+ * due to the way in which the parser uses
+ * the pointer spacep.
+ */
+#define TREENMAX 6
+
+int trspace[ITREE];
+int *space = trspace;
+int *spacep = trspace;
+struct tr *tract = ttab;
+
+/*
+ * Inittree allocates the first tree slot
+ * and sets up the first segment descriptor.
+ * A lot of this work is actually done statically
+ * above.
+ */
+inittree()
+{
+
+ ttab[0].tr_low = space;
+ ttab[0].tr_high = &space[ITREE];
+}
+
+/*
+ * Tree builds the nodes in the
+ * parse tree. It is rarely called
+ * directly, rather calls are made
+ * to tree[12345] which supplies the
+ * first argument to save space in
+ * the code. Tree also guarantees
+ * that spacep points to the beginning
+ * of the next slot it will return,
+ * a property required by the parser
+ * which was always true before we
+ * segmented the tree space.
+ */
+int *tree(cnt, a)
+ int cnt;
+{
+ register int *p, *q;
+ register int i;
+
+ i = cnt;
+ p = spacep;
+ q = &a;
+ do
+ *p++ = *q++;
+ while (--i);
+ q = spacep;
+ spacep = p;
+ if (p+TREENMAX >= tract->tr_high)
+ /*
+ * this peek-ahead should
+ * save a great number of calls
+ * to tralloc.
+ */
+ tralloc(TREENMAX);
+ return (q);
+}
+
+/*
+ * Tralloc preallocates enough
+ * space in the tree to allow
+ * the grammar to use the variable
+ * spacep, as it did before the
+ * tree was segmented.
+ */
+tralloc(howmuch)
+{
+ register char *cp;
+ register i;
+
+ if (spacep + howmuch >= tract->tr_high) {
+ i = TRINC;
+ cp = malloc(i * sizeof ( int ));
+ if (cp == -1) {
+ yerror("Ran out of memory (tralloc)");
+ pexit(DIED);
+ }
+ spacep = cp;
+ tract++;
+ if (tract >= &ttab[MAXTREE]) {
+ yerror("Ran out of tree tables");
+ pexit(DIED);
+ }
+ tract->tr_low = cp;
+ tract->tr_high = tract->tr_low+i;
+ }
+}
+
+extern int yylacnt;
+extern bottled;
+#ifdef PXP
+#endif
+/*
+ * Free up the tree segments
+ * at the end of a block.
+ * If there is scanner lookahead,
+ * i.e. if yylacnt != 0 or there is bottled output, then we
+ * cannot free the tree space.
+ * This happens only when errors
+ * occur and the forward move extends
+ * across "units".
+ */
+trfree()
+{
+
+ if (yylacnt != 0 || bottled != NIL)
+ return;
+#ifdef PXP
+ if (needtree())
+ return;
+#endif
+ spacep = space;
+ while (tract->tr_low > spacep || tract->tr_high <= spacep) {
+ free(tract->tr_low);
+ tract->tr_low = NIL;
+ tract->tr_high = NIL;
+ tract--;
+ if (tract < ttab)
+ panic("ttab");
+ }
+#ifdef PXP
+ packtree();
+#endif
+}
+
+/*
+ * Copystr copies a token from
+ * the "token" buffer into the
+ * tree space.
+ */
+copystr(token)
+ register char *token;
+{
+ register char *cp;
+ register int i;
+
+ i = (strlen(token) + sizeof ( int )) & ~( ( sizeof ( int ) ) - 1 );
+ tralloc(i / sizeof ( int ));
+ strcpy(spacep, token);
+ cp = spacep;
+ spacep = cp + i;
+ tralloc(TREENMAX);
+ return (cp);
+}
--- /dev/null
+#define T_MINUS 1
+#define T_MOD 2
+#define T_DIV 3
+#define T_DIVD 4
+#define T_MULT 5
+#define T_ADD 6
+#define T_SUB 7
+#define T_EQ 8
+#define T_NE 9
+#define T_LT 10
+#define T_GT 11
+#define T_LE 12
+#define T_GE 13
+#define T_NOT 14
+#define T_AND 15
+#define T_OR 16
+#define T_ASGN 17
+#define T_PLUS 18
+#define T_IN 19
+#define T_LISTPP 20
+#define T_PDEC 21
+#define T_FDEC 22
+#define T_PVAL 23
+#define T_PVAR 24
+#define T_PFUNC 25
+#define T_PPROC 26
+#define T_NIL 27
+#define T_STRNG 28
+#define T_CSTRNG 29
+#define T_PLUSC 30
+#define T_MINUSC 31
+#define T_ID 32
+#define T_INT 33
+#define T_FINT 34
+#define T_CINT 35
+#define T_CFINT 36
+#define T_TYPTR 37
+#define T_TYPACK 38
+#define T_TYSCAL 39
+#define T_TYRANG 40
+#define T_TYARY 41
+#define T_TYFILE 42
+#define T_TYSET 43
+#define T_TYREC 44
+#define T_TYFIELD 45
+#define T_TYVARPT 46
+#define T_TYVARNT 47
+#define T_CSTAT 48
+#define T_BLOCK 49
+#define T_BSTL 50
+#define T_LABEL 51
+#define T_PCALL 52
+#define T_FCALL 53
+#define T_CASE 54
+#define T_WITH 55
+#define T_WHILE 56
+#define T_REPEAT 57
+#define T_FORU 58
+#define T_FORD 59
+#define T_GOTO 60
+#define T_IF 61
+#define T_ASRT 62
+#define T_CSET 63
+#define T_RANG 64
+#define T_VAR 65
+#define T_ARGL 66
+#define T_ARY 67
+#define T_FIELD 68
+#define T_PTR 69
+#define T_WEXP 70
+#define T_PROG 71
+#define T_BINT 72
+#define T_CBINT 73
+#define T_IFEL 74
+#define T_IFX 75
+#define T_TYID 76
+#define T_COPSTR 77
+#define T_BOTTLE 78
+#define T_RFIELD 79
+#define T_FLDLST 80
+#define T_LAST 81
--- /dev/null
+/* Copyright (c) 1979 Regents of the University of California */
+ /*
+ * is there some reason why these aren't #defined?
+ */
+
+tree1 ( arg1 )
+ int arg1;
+ {
+ tree ( 1 , arg1 );
+ }
+
+tree2 ( arg1 , arg2 )
+ int arg1 , arg2;
+ {
+ tree ( 2 , arg1 , arg2 );
+ }
+
+tree3 ( arg1 , arg2 , arg3 )
+ int arg1 , arg2 , arg3;
+ {
+ tree ( 3 , arg1 , arg2 , arg3 );
+ }
+
+tree4 ( arg1 , arg2 , arg3 , arg4 )
+ int arg1 , arg2 , arg3 , arg4;
+ {
+ tree ( 4 , arg1 , arg2 , arg3 , arg4 );
+ }
+
+tree5 ( arg1 , arg2 , arg3 , arg4 , arg5 )
+ int arg1 , arg2 , arg3 , arg4 , arg5;
+ {
+ tree ( 5 , arg1 , arg2 , arg3 , arg4 , arg5 );
+ }
+
projects / unix-history / commitdiff