BSD 1 development

Work on file pi/tree.c
Work on file pi/stat.c
Work on file pi/subr.c
Work on file pi/lval.c

Co-Authored-By: Bill Joy <wnj@ucbvax.Berkeley.EDU>
Synthesized-from: 1bsd

diff --git a/pi/lval.c b/pi/lval.c
new file mode 100644 (file)
index 0000000..6830120
--- /dev/null
+++ b/pi/lval.c
@@ -0,0 +1,249 @@
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.0 August 1977
+ */
+
+#include "whoami"
+#include "0.h"
+#include "tree.h"
+#include "opcode.h"
+
+extern int flagwas;
+/*
+ * Lvalue computes the address
+ * of a qualified name and
+ * leaves it on the stack.
+ */
+lvalue(r, modflag)
+       int *r, modflag;
+{
+       register struct nl *p;
+       struct nl *firstp, *lastp;
+       register *c, *co;
+       int f, o;
+       /*
+        * Note that the local optimizations
+        * done here for offsets would more
+        * appropriately be done in put.
+        */
+       int tr[2], trp[3];
+
+       if (r == NIL)
+               return (NIL);
+       if (nowexp(r))
+               return (NIL);
+       if (r[0] != T_VAR) {
+               error("Variable required");     /* Pass mesgs down from pt of call ? */
+               return (NIL);
+       }
+       firstp = p = lookup(r[2]);
+       if (p == NIL)
+               return (NIL);
+       if (modflag & NOUSE)
+               p->nl_flags = flagwas;
+       if (modflag & MOD)
+               p->nl_flags =| NMOD;
+       /*
+        * Only possibilities for p->class here
+        * are the named classes, i.e. CONST, TYPE
+        * VAR, PROC, FUNC, REF, or a WITHPTR.
+        */
+       c = r[3];
+       switch (p->class) {
+               case WITHPTR:
+                       /*
+                        * Construct the tree implied by
+                        * the with statement
+                        */
+                       trp[0] = T_LISTPP;
+                       trp[1] = tr;
+                       trp[2] = r[3];
+                       tr[0] = T_FIELD;
+                       tr[1] = r[2];
+                       c = trp;
+               case REF:
+                       /*
+                        * Obtain the indirect word
+                        * of the WITHPTR or REF
+                        * as the base of our lvalue
+                        */
+                       put2(O_RV2 | bn << 9, p->value[0]);
+                       f = 0;          /* have an lv on stack */
+                       o = 0;
+                       break;
+               case VAR:
+                       f = 1;          /* no lv on stack yet */
+                       o = p->value[0];
+                       break;
+               default:
+                       error("%s %s found where variable required", classes[p->class], p->symbol);
+                       return (NIL);
+       }
+       /*
+        * Loop and handle each
+        * qualification on the name
+        */
+       if (c == NIL && modflag & ASGN && p->value[NL_FORV]) {
+               error("Can't modify the for variable %s in the range of the loop", p->symbol);
+               return (NIL);
+       }
+       for (; c != NIL; c = c[2]) {
+               co = c[1];
+               if (co == NIL)
+                       return (NIL);
+               lastp = p;
+               p = p->type;
+               if (p == NIL)
+                       return (NIL);
+               switch (co[0]) {
+                       case T_PTR:
+                               /*
+                                * Pointer qualification.
+                                */
+                               lastp->nl_flags =| NUSED;
+                               if (p->class != PTR && p->class != FILE) {
+                                       error("^ allowed only on files and pointers, not on %ss", nameof(p));
+                                       goto bad;
+                               }
+                               if (f)
+                                       put2(O_RV2 | bn<<9, o);
+                               else {
+                                       if (o)
+                                               put2(O_OFF, o);
+                                       put1(O_IND2);
+                               }
+                               /*
+                                * Pointer cannot be
+                                * nil and file cannot
+                                * be at end-of-file.
+                                */
+                               put1(p->class == FILE ? O_FNIL : O_NIL);
+                               f = o = 0;
+                               continue;
+                       case T_ARGL:
+                               if (p->class != ARRAY) {
+                                       if (lastp == firstp)
+                                               error("%s is a %s, not a function", r[2], classes[firstp->class]);
+                                       else
+                                               error("Illegal function qualificiation");
+                                       return (NIL);
+                               }
+                               recovered();
+                               error("Pascal uses [] for subscripting, not ()");
+                       case T_ARY:
+                               if (p->class != ARRAY) {
+                                       error("Subscripting allowed only on arrays, not on %ss", nameof(p));
+                                       goto bad;
+                               }
+                               if (f)
+                                       put2(O_LV | bn<<9, o);
+                               else if (o)
+                                       put2(O_OFF, o);
+                               switch (arycod(p, co[1])) {
+                                       case 0:
+                                               return (NIL);
+                                       case -1:
+                                               goto bad;
+                               }
+                               f = o = 0;
+                               continue;
+                       case T_FIELD:
+                               /*
+                                * Field names are just
+                                * an offset with some 
+                                * semantic checking.
+                                */
+                               if (p->class != RECORD) {
+                                       error(". allowed only on records, not on %ss", nameof(p));
+                                       goto bad;
+                               }
+                               if (co[1] == NIL)
+                                       return (NIL);
+                               p = reclook(p, co[1]);
+                               if (p == NIL) {
+                                       error("%s is not a field in this record", co[1]);
+                                       goto bad;
+                               }
+                               if (modflag & MOD)
+                                       p->nl_flags =| NMOD;
+                               else
+                                       p->nl_flags =| NUSED;
+                               o =+ p->value[0];
+                               continue;
+                       default:
+                               panic("lval2");
+               }
+       }
+       if (f)
+               put2(O_LV | bn<<9, o);
+       else if (o)
+               put2(O_OFF, o);
+       return (p->type);
+bad:
+       cerror("Error occurred on qualification of %s", r[2]);
+       return (NIL);
+}
+
+/*
+ * Arycod does the
+ * code generation
+ * for subscripting.
+ */
+arycod(np, el)
+       struct nl *np;
+       int *el;
+{
+       register struct nl *p, *ap;
+       int i, d, v, v1;
+       int w;
+
+       p = np;
+       if (el == NIL)
+               return (0);
+       d = p->value[0];
+       /*
+        * Check each subscript
+        */
+       for (i = 1; i <= d; i++) {
+               if (el == NIL) {
+                       error("Too few subscripts (%d given, %d required)", i-1, d);
+                       return (-1);
+               }
+               p = p->chain;
+               ap = rvalue(el[1], NIL);
+               if (ap == NIL)
+                       return (0);
+               if (incompat(ap, p->type, el[1])) {
+                       cerror("Array index type incompatible with declared index type");
+                       if (d != 1)
+                               cerror("Error occurred on index number %d", i);
+                       return (-1);
+               }
+               w = aryconst(np, i);
+               if (opt('t') == 0)
+                       switch (w) {
+                               case 8:
+                                       w = 6;
+                               case 4:
+                               case 2:
+                               case 1:
+                                       put2((width(ap) != 4 ? O_INX2P2 : O_INX4P2) | (w &~ 1) << 7, p->value[1]);
+                                       el = el[2];
+                                       continue;
+                       }
+               put(4, width(ap) != 4 ? O_INX2 : O_INX4, w, p->value[1], p->value[3]-p->value[1]);
+               el = el[2];
+       }
+       if (el != NIL) {
+               do {
+                       el = el[2];
+                       i++;
+               } while (el != NIL);
+               error("Too many subscripts (%d given, %d required)", i-1, d);
+               return (-1);
+       }
+       return (1);
+}

diff --git a/pi/stat.c b/pi/stat.c
new file mode 100644 (file)
index 0000000..e922e76
--- /dev/null
+++ b/pi/stat.c
@@ -0,0 +1,553 @@
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.0 August 1977
+ */
+
+#include "whoami"
+#include "0.h"
+#include "tree.h"
+
+int cntstat;
+int 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;
+/*
+       register sudcnt;
+*/
+
+       s = r;
+       snlp = nlp;
+/*
+       sudcnt = udcnt;
+*/
+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.
+        */
+/*
+       if (sudcnt == udcnt)
+*/
+               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()
+{
+
+       if (opt('p') != 0)
+               put2(O_LINO, line);
+}
+
+/*
+ * 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 =- 2;
+               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;
+               put1(O_AS2);
+       }
+       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;
+       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.
+ */
+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));
+       }
+       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;
+       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);
+       /*
+        * 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(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;
+       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(r, NIL);
+       if (q == NIL)
+               return;
+       if (isnta(q, "b"))
+               error("Assert expression must be Boolean, not %ss", nameof(q));
+       put1(O_ASRT);
+}

diff --git a/pi/subr.c b/pi/subr.c
new file mode 100644 (file)
index 0000000..189604f
--- /dev/null
+++ b/pi/subr.c
@@ -0,0 +1,209 @@
+#include "whoami"
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.0 August 1977
+ *
+ *
+ * pxp - Pascal execution profiler
+ *
+ * Bill Joy UCB
+ * Version 1.0 August 1977
+ */
+
+#include "0.h"
+
+/*
+ * 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 the current file.
+ */
+gettime()
+{
+       int stbuf[18];
+
+       stat(filename, stbuf);
+       tvec[0] = stbuf[16];
+       tvec[1] = stbuf[17];
+}
+
+/*
+ * Convert a "ctime" into a Pascal styple time line
+ */
+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);
+}
+
+extern int errno;
+extern char *sys_errlist[];
+
+/*
+ * Boom!
+ */
+Perror(file, error)
+       char *file, *error;
+{
+
+       errno = 0;
+       sys_errlist[0] = error;
+       perror(file);
+}
+
+calloc(num, size)
+       int num, size;
+{
+       register int p1, *p2, nbyte;
+
+       nbyte = (num*size+1) & ~01;
+       if ((p1 = alloc(nbyte)) == -1 || p1==0)
+               return (-1);
+       p2 = p1;
+       nbyte =>> 1;            /* 2 bytes/word */
+       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;
+}
+
+opop(c)
+       register CHAR c;
+{
+
+       c =- 'a';
+       opts[c] = optstk[c] & 1;
+       optstk[c] =>> 1;
+}

diff --git a/pi/tree.c b/pi/tree.c
new file mode 100644 (file)
index 0000000..88a7bb1
--- /dev/null
+++ b/pi/tree.c
@@ -0,0 +1,189 @@
+#
+/*
+ * pi - Pascal interpreter code translator
+ *
+ * Charles Haley, Bill Joy UCB
+ * Version 1.0 August 1977
+ *
+ *
+ * pxp - Pascal execution profiler
+ *
+ * Bill Joy UCB
+ * Version 1.0 August 1977
+ */
+
+#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 = alloc(i*2);
+               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) + 2) & ~1;
+       tralloc(i >> 1);
+       strcpy(spacep, token);
+       cp = spacep;
+       spacep = cp + i;
+       tralloc(TREENMAX);
+       return (cp);
+}