--- /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"
+
+long
+a8tol(cp)
+ char *cp;
+{
+ int err;
+ long l;
+ register CHAR c;
+
+ l = 0;
+ err = 0;
+ while ((c = *cp++) != '\0') {
+ if (c == '8' || c == '9')
+ if (err == 0) {
+ error("8 or 9 in octal number");
+ err++;
+ }
+ c -= '0';
+ if ((l & 0160000000000L) != 0)
+ if (err == 0) {
+ error("Number too large for this implementation");
+ err++;
+ }
+ l = (l << 3) | c;
+ }
+ return (l);
+}
+
+/*
+ * Note that the version of atof
+ * used in this compiler does not
+ * (sadly) complain when floating
+ * point numbers are too large.
+ */
--- /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"
+
+/*
+ * This is the array of class
+ * names for the classes returned
+ * by classify. The order of the
+ * classes is the same as the base
+ * of the namelist, with special
+ * negative index entries for structures,
+ * scalars, pointers, sets and strings
+ * to be collapsed into.
+ */
+char *clnxxxx[] =
+{
+ "file", /* -7 TFILE */
+ "record", /* -6 TREC */
+ "array", /* -5 TARY */
+ "scalar", /* -4 TSCAL */
+ "pointer", /* -3 TPTR */
+ "set", /* -2 TSET */
+ "string", /* -1 TSTR */
+ "SNARK", /* 0 NIL */
+ "Boolean", /* 1 TBOOL */
+ "char", /* 2 TCHAR */
+ "integer", /* 3 TINT */
+ "real", /* 4 TREAL */
+ "\"nil\"", /* 5 TNIL */
+};
+
+char **clnames = &clnxxxx[-(TFIRST)];
+
+/*
+ * Classify takes a pointer
+ * to a type and returns one
+ * of several interesting group
+ * classifications for easy use.
+ */
+classify(p1)
+ struct nl *p1;
+{
+ register struct nl *p;
+
+ p = p1;
+swit:
+ if (p == NIL) {
+ nocascade();
+ return (NIL);
+ }
+ if (p == &nl[TSTR])
+ return (TSTR);
+ switch (p->class) {
+ case PTR:
+ return (TPTR);
+ case ARRAY:
+ if (p->type == nl+T1CHAR)
+ return (TSTR);
+ return (TARY);
+ case STR:
+ return (TSTR);
+ case SET:
+ return (TSET);
+ case RANGE:
+ p = p->type;
+ goto swit;
+ case TYPE:
+ if (p <= nl+TLAST)
+ return (p - nl);
+ panic("clas2");
+ case FILET:
+ return (TFILE);
+ case RECORD:
+ return (TREC);
+ case SCAL:
+ return (TSCAL);
+ default:
+ panic("clas");
+ }
+}
+
+#ifndef PI0
+/*
+ * Is p a text file?
+ */
+text(p)
+ struct nl *p;
+{
+
+ return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
+}
+#endif
+
+/*
+ * Scalar returns a pointer to
+ * the the base scalar type of
+ * its argument if its argument
+ * is a SCALar else NIL.
+ */
+scalar(p1)
+ struct nl *p1;
+{
+ register struct nl *p;
+
+ p = p1;
+ if (p == NIL)
+ return (NIL);
+ if (p->class == RANGE)
+ p = p->type;
+ if (p == NIL)
+ return (NIL);
+ return (p->class == SCAL ? p : NIL);
+}
+
+/*
+ * Isa tells whether p
+ * is one of a group of
+ * namelist classes. The
+ * classes wanted are specified
+ * by the characters in s.
+ * (Note that s would more efficiently,
+ * if less clearly, be given by a mask.)
+ */
+isa(p, s)
+ register struct nl *p;
+ char *s;
+{
+ register i;
+ register char *cp;
+
+ if (p == NIL)
+ return (NIL);
+ /*
+ * map ranges down to
+ * the base type
+ */
+ if (p->class == RANGE)
+ p = p->type;
+ /*
+ * the following character/class
+ * associations are made:
+ *
+ * s scalar
+ * b Boolean
+ * c character
+ * i integer
+ * d double (real)
+ * t set
+ */
+ switch (p->class) {
+ case SET:
+ i = TDOUBLE+1;
+ break;
+ case SCAL:
+ i = 0;
+ break;
+ default:
+ i = p - nl;
+ }
+ if (i >= 0 && i <= TDOUBLE+1) {
+ i = "sbcidt"[i];
+ cp = s;
+ while (*cp)
+ if (*cp++ == i)
+ return (1);
+ }
+ return (NIL);
+}
+
+/*
+ * Isnta is !isa
+ */
+isnta(p, s)
+{
+
+ return (!isa(p, s));
+}
+
+/*
+ * "shorthand"
+ */
+nameof(p)
+{
+
+ return (clnames[classify(p)]);
+}
+
+#ifndef PI0
+nowexp(r)
+ int *r;
+{
+ if (r[0] == T_WEXP) {
+ if (r[2] == NIL)
+ error("Oct/hex allowed only on writeln/write calls");
+ else
+ error("Width expressions allowed only in writeln/write calls");
+ return (1);
+ }
+ return (NIL);
+}
+#endif
--- /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"
+
+/*
+ * Const enters the definitions
+ * of the constant declaration
+ * part into the namelist.
+ */
+#ifndef PI1
+constbeg()
+{
+
+ if (parts & (TPRT|VPRT))
+ error("Constant declarations must precede type and variable declarations");
+ if (parts & CPRT)
+ error("All constants must be declared in one const part");
+ parts |= CPRT;
+}
+#endif
+
+const(cline, cid, cdecl)
+ int cline;
+ register char *cid;
+ register int *cdecl;
+{
+ register struct nl *np;
+
+#ifdef PI0
+ send(REVCNST, cline, cid, cdecl);
+#endif
+ line = cline;
+ gconst(cdecl);
+ np = enter(defnl(cid, CONST, con.ctype, con.cival));
+#ifndef PI0
+ np->nl_flags |= NMOD;
+#endif
+# ifdef PTREE
+ {
+ pPointer Const = ConstDecl( cid , cdecl );
+ pPointer *Consts;
+
+ pSeize( PorFHeader[ nesting ] );
+ Consts = &( pDEF( PorFHeader[ nesting ] ).PorFConsts );
+ *Consts = ListAppend( *Consts , Const );
+ pRelease( PorFHeader[ nesting ] );
+ }
+# endif
+ if (con.ctype == NIL)
+ return;
+ if ( con.ctype == nl + TSTR )
+ np->ptr[0] = con.cpval;
+ if (isa(con.ctype, "i"))
+ np->range[0] = con.crval;
+ else if (isa(con.ctype, "d"))
+ np->real = con.crval;
+}
+
+#ifndef PI0
+#ifndef PI1
+constend()
+{
+
+}
+#endif
+#endif
+\f
+/*
+ * Gconst extracts
+ * a constant declaration
+ * from the tree for it.
+ * only types of constants
+ * are integer, reals, strings
+ * and scalars, the first two
+ * being possibly signed.
+ */
+gconst(r)
+ int *r;
+{
+ register struct nl *np;
+ register *cn;
+ char *cp;
+ int negd, sgnd;
+ long ci;
+
+ con.ctype = NIL;
+ cn = r;
+ negd = sgnd = 0;
+loop:
+ if (cn == NIL || cn[1] == NIL)
+ return (NIL);
+ switch (cn[0]) {
+ default:
+ panic("gconst");
+ case T_MINUSC:
+ negd = 1 - negd;
+ case T_PLUSC:
+ sgnd++;
+ cn = cn[1];
+ goto loop;
+ case T_ID:
+ np = lookup(cn[1]);
+ if (np == NIL)
+ return;
+ if (np->class != CONST) {
+ derror("%s is a %s, not a constant as required", cn[1], classes[np->class]);
+ return;
+ }
+ con.ctype = np->type;
+ switch (classify(np->type)) {
+ case TINT:
+ con.crval = np->range[0];
+ break;
+ case TDOUBLE:
+ con.crval = np->real;
+ break;
+ case TBOOL:
+ case TCHAR:
+ case TSCAL:
+ con.cival = np->value[0];
+ con.crval = con.cival;
+ break;
+ case TSTR:
+ con.cpval = np->ptr[0];
+ break;
+ case NIL:
+ con.ctype = NIL;
+ return;
+ default:
+ panic("gconst2");
+ }
+ break;
+ case T_CBINT:
+ con.crval = a8tol(cn[1]);
+ goto restcon;
+ case T_CINT:
+ con.crval = atof(cn[1]);
+ if (con.crval > MAXINT || con.crval < MININT) {
+ derror("Constant too large for this implementation");
+ con.crval = 0;
+ }
+restcon:
+ ci = con.crval;
+#ifndef PI0
+ if (bytes(ci, ci) <= 2)
+ con.ctype = nl+T2INT;
+ else
+#endif
+ con.ctype = nl+T4INT;
+ break;
+ case T_CFINT:
+ con.ctype = nl+TDOUBLE;
+ con.crval = atof(cn[1]);
+ break;
+ case T_CSTRNG:
+ cp = cn[1];
+ if (cp[1] == 0) {
+ con.ctype = nl+T1CHAR;
+ con.cival = cp[0];
+ con.crval = con.cival;
+ break;
+ }
+ con.ctype = nl+TSTR;
+ con.cpval = savestr(cp);
+ break;
+ }
+ if (sgnd) {
+ if (isnta(con.ctype, "id"))
+ derror("%s constants cannot be signed", nameof(con.ctype));
+ else {
+ if (negd)
+ con.crval = -con.crval;
+ ci = con.crval;
+#ifndef PI0
+ if (bytes(ci, ci) <= 2)
+ con.ctype = nl+T2INT;
+#endif
+ }
+ }
+}
+
+#ifndef PI0
+isconst(r)
+ register int *r;
+{
+
+ if (r == NIL)
+ return (1);
+ switch (r[0]) {
+ case T_MINUS:
+ r[0] = T_MINUSC;
+ r[1] = r[2];
+ return (isconst(r[1]));
+ case T_PLUS:
+ r[0] = T_PLUSC;
+ r[1] = r[2];
+ return (isconst(r[1]));
+ case T_VAR:
+ if (r[3] != NIL)
+ return (0);
+ r[0] = T_ID;
+ r[1] = r[2];
+ return (1);
+ case T_BINT:
+ r[0] = T_CBINT;
+ r[1] = r[2];
+ return (1);
+ case T_INT:
+ r[0] = T_CINT;
+ r[1] = r[2];
+ return (1);
+ case T_FINT:
+ r[0] = T_CFINT;
+ r[1] = r[2];
+ return (1);
+ case T_STRNG:
+ r[0] = T_CSTRNG;
+ r[1] = r[2];
+ return (1);
+ }
+ return (0);
+}
+#endif
--- /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"
+#ifdef PI
+#include "0.h"
+#include "opcode.h"
+
+#ifndef PI0
+/*
+ * Convert a p1 into a p2.
+ * Mostly used for different
+ * length integers and "to real" conversions.
+ */
+convert(p1, p2)
+ struct nl *p1, *p2;
+{
+ if (p1 == NIL || p2 == NIL)
+ return;
+ switch (width(p1) - width(p2)) {
+ case -7:
+ case -6:
+ put1(O_STOD);
+ return;
+ case -4:
+ put1(O_ITOD);
+ return;
+ case -3:
+ case -2:
+ put1(O_STOI);
+ return;
+ case -1:
+ case 0:
+ case 1:
+ return;
+ case 2:
+ case 3:
+ put1(O_ITOS);
+ return;
+ default:
+ panic("convert");
+ }
+}
+#endif
+
+/*
+ * Compat tells whether
+ * p1 and p2 are compatible
+ * types for an assignment like
+ * context, i.e. value parameters,
+ * indicies for 'in', etc.
+ */
+compat(p1, p2, t)
+ struct nl *p1, *p2;
+{
+ register c1, c2;
+
+ c1 = classify(p1);
+ if (c1 == NIL)
+ return (NIL);
+ c2 = classify(p2);
+ if (c2 == NIL)
+ return (NIL);
+ switch (c1) {
+ case TBOOL:
+ case TCHAR:
+ if (c1 == c2)
+ return (1);
+ break;
+ case TINT:
+ if (c2 == TINT)
+ return (1);
+ case TDOUBLE:
+ if (c2 == TDOUBLE)
+ return (1);
+#ifndef PI0
+ if (c2 == TINT && divflg == 0) {
+ divchk= 1;
+ c1 = classify(rvalue(t, NLNIL));
+ divchk = NIL;
+ if (c1 == TINT) {
+ error("Type clash: real is incompatible with integer");
+ cerror("This resulted because you used '/' which always returns real rather");
+ cerror("than 'div' which divides integers and returns integers");
+ divflg = 1;
+ return (NIL);
+ }
+ }
+#endif
+ break;
+ case TSCAL:
+ if (c2 != TSCAL)
+ break;
+ if (scalar(p1) != scalar(p2)) {
+ derror("Type clash: non-identical scalar types");
+ return (NIL);
+ }
+ return (1);
+ case TSTR:
+ if (c2 != TSTR)
+ break;
+ if (width(p1) != width(p2)) {
+ derror("Type clash: unequal length strings");
+ return (NIL);
+ }
+ return (1);
+ case TNIL:
+ if (c2 != TPTR)
+ break;
+ return (1);
+ case TFILE:
+ if (c1 != c2)
+ break;
+ derror("Type clash: files not allowed in this context");
+ return (NIL);
+ default:
+ if (c1 != c2)
+ break;
+ if (p1 != p2) {
+ derror("Type clash: non-identical %s types", clnames[c1]);
+ return (NIL);
+ }
+ if (p1->nl_flags & NFILES) {
+ derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
+ return (NIL);
+ }
+ return (1);
+ }
+ derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
+ return (NIL);
+}
+
+#ifndef PI0
+/*
+ * Rangechk generates code to
+ * check if the type p on top
+ * of the stack is in range for
+ * assignment to a variable
+ * of type q.
+ */
+rangechk(p, q)
+ struct nl *p, *q;
+{
+ register struct nl *rp;
+ register op;
+ int wq, wrp;
+
+ if (opt('t') == 0)
+ return;
+ rp = p;
+ if (rp == NIL)
+ return;
+ if (q == NIL)
+ return;
+ /*
+ * When op is 1 we are checking length
+ * 4 numbers against length 2 bounds,
+ * and adding it to the opcode forces
+ * generation of appropriate tests.
+ */
+ op = 0;
+ wq = width(q);
+ wrp = width(rp);
+ op = wq != wrp && (wq == 4 || wrp == 4);
+ if (rp->class == TYPE)
+ rp = rp->type;
+ switch (rp->class) {
+ case RANGE:
+ if (rp->range[0] != 0) {
+# ifndef DEBUG
+ if (wrp <= 2)
+ put3(O_RANG2+op, ( short ) rp->range[0],
+ ( short ) rp->range[1]);
+ else if (rp != nl+T4INT)
+ put(5, O_RANG4+op, rp->range[0], rp->range[1] );
+# else
+ if (!hp21mx) {
+ if (wrp <= 2)
+ put3(O_RANG2+op,( short ) rp->range[0],
+ ( short ) rp->range[1]);
+ else if (rp != nl+T4INT)
+ put(5,O_RANG4+op,rp->range[0],
+ rp->range[1]);
+ } else
+ if (rp != nl+T2INT && rp != nl+T4INT)
+ put3(O_RANG2+op,( short ) rp->range[0],
+ ( short ) rp->range[1]);
+# endif
+ break;
+ }
+ /*
+ * Range whose lower bounds are
+ * zero can be treated as scalars.
+ */
+ case SCAL:
+ if (wrp <= 2)
+ put2(O_RSNG2+op, ( short ) rp->range[1]);
+ else
+ put( 3 , O_RSNG4+op, rp->range[1]);
+ break;
+ default:
+ panic("rangechk");
+ }
+}
+#endif
+#endif
+
+#ifdef DEBUG
+conv(dub)
+ int *dub;
+{
+ int newfp[2];
+ double *dp = dub;
+ long *lp = dub;
+ register int exp;
+ long mant;
+
+ newfp[0] = dub[0] & 0100000;
+ newfp[1] = 0;
+ if (*dp == 0.0)
+ goto ret;
+ exp = ((dub[0] >> 7) & 0377) - 0200;
+ if (exp < 0) {
+ newfp[1] = 1;
+ exp = -exp;
+ }
+ if (exp > 63)
+ exp = 63;
+ dub[0] &= ~0177600;
+ dub[0] |= 0200;
+ mant = *lp;
+ mant <<= 8;
+ if (newfp[0])
+ mant = -mant;
+ newfp[0] |= (mant >> 17) & 077777;
+ newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1);
+ret:
+ dub[0] = newfp[0];
+ dub[1] = newfp[1];
+}
+#endif
--- /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"
+#include "opcode.h"
+
+/*
+ * Constant set constructor.
+ * settype is the type of the
+ * set if we think that we know it
+ * if not we try our damndest to figure
+ * out what the type should be.
+ */
+struct nl *
+cset(r, settype, x)
+ int *r;
+ struct nl *settype;
+ int x;
+{
+ register *e;
+ register struct nl *t, *exptype;
+ int n, *el;
+
+ if (settype == NIL) {
+ /*
+ * So far we have no indication
+ * of what the set type should be.
+ * We "look ahead" and try to infer
+ * The type of the constant set
+ * by evaluating one of its members.
+ */
+ e = r[2];
+ if (e == NIL)
+ return (nl+TSET); /* tenative for [] */
+ e = e[1];
+ if (e == NIL)
+ return (NIL);
+ if (e[0] == T_RANG)
+ e = e[1];
+ codeoff();
+ t = rvalue(e, NIL);
+ codeon();
+ if (t == NIL)
+ return (NIL);
+ /*
+ * The type of the set, settype, is
+ * deemed to be a set of the base type
+ * of t, which we call exptype. If,
+ * however, this would involve a
+ * "set of integer", we cop out
+ * and use "intset"'s current scoped
+ * type instead.
+ */
+ if (isa(t, "r")) {
+ error("Sets may not have 'real' elements");
+ return (NIL);
+ }
+ if (isnta(t, "bcsi")) {
+ error("Set elements must be scalars, not %ss", nameof(t));
+ return (NIL);
+ }
+ if (isa(t, "i")) {
+ settype = lookup(intset);
+ if (settype == NIL)
+ panic("intset");
+ settype = settype->type;
+ if (settype == NIL)
+ return (NIL);
+ if (isnta(settype, "t")) {
+ error("Set default type \"intset\" is not a set");
+ return (NIL);
+ }
+ exptype = settype->type;
+ } else {
+ exptype = t->type;
+ if (exptype == NIL)
+ return (NIL);
+ if (exptype->class != RANGE)
+ exptype = exptype->type;
+ settype = defnl(0, SET, exptype, 0);
+ }
+ } else {
+ if (settype->class != SET) {
+ /*
+ * e.g string context [1,2] = 'abc'
+ */
+ error("Constant set involved in non set context");
+ return (NIL);
+ }
+ exptype = settype->type;
+ }
+ if (x == NIL)
+ put2(O_PUSH, -width(settype));
+ n = 0;
+ for (el=r[2]; el; el=el[2]) {
+ n++;
+ e = el[1];
+ if (e == NIL)
+ return (NIL);
+ if (e[0] == T_RANG) {
+ t = rvalue(e[2], NIL);
+ if (t == NIL) {
+ rvalue(e[1], NIL);
+ continue;
+ }
+ if (incompat(t, exptype, e[2]))
+ cerror("Upper bound of element type clashed with set type in constant set");
+ else
+ convert(t, nl+T2INT);
+ t = rvalue(e[1], NIL);
+ if (t == NIL)
+ continue;
+ if (incompat(t, exptype, e[1]))
+ cerror("Lower bound of element type clashed with set type in constant set");
+ else
+ convert(t, nl+T2INT);
+ } else {
+ t = rvalue((int *) e, NLNIL);
+ if (t == NIL)
+ continue;
+ if (incompat(t, exptype, e))
+ cerror("Element type clashed with set type in constant set");
+ else
+ convert(t, nl+T2INT);
+ put1(O_SDUP);
+ }
+ }
+ if (x == NIL) {
+ setran(exptype);
+ put(4, O_CTTOT, n, set.lwrb, set.uprbp);
+ } else
+ put2(O_CON2, n);
+ return (settype);
+}