BSD 3 development

Work on file usr/src/cmd/pi/ato.c
Work on file usr/src/cmd/pi/clas.c
Work on file usr/src/cmd/pi/const.c
Work on file usr/src/cmd/pi/conv.c
Work on file usr/src/cmd/pi/cset.c

Co-Authored-By: Bill Joy <wnj@ucbvax.Berkeley.EDU>
Co-Authored-By: Ken Thompson <ken@research.uucp>
Synthesized-from: 3bsd

diff --git a/usr/src/cmd/pi/ato.c b/usr/src/cmd/pi/ato.c
new file mode 100644 (file)
index 0000000..1e92dd4
--- /dev/null
+++ b/usr/src/cmd/pi/ato.c
@@ -0,0 +1,45 @@
+/* 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.
+ */

diff --git a/usr/src/cmd/pi/clas.c b/usr/src/cmd/pi/clas.c
new file mode 100644 (file)
index 0000000..13929cc
--- /dev/null
+++ b/usr/src/cmd/pi/clas.c
@@ -0,0 +1,210 @@
+/* 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

diff --git a/usr/src/cmd/pi/const.c b/usr/src/cmd/pi/const.c
new file mode 100644 (file)
index 0000000..34414b2
--- /dev/null
+++ b/usr/src/cmd/pi/const.c
@@ -0,0 +1,232 @@
+/* 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

diff --git a/usr/src/cmd/pi/conv.c b/usr/src/cmd/pi/conv.c
new file mode 100644 (file)
index 0000000..4bfca60
--- /dev/null
+++ b/usr/src/cmd/pi/conv.c
@@ -0,0 +1,247 @@
+/* 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

diff --git a/usr/src/cmd/pi/cset.c b/usr/src/cmd/pi/cset.c
new file mode 100644 (file)
index 0000000..0e3af24
--- /dev/null
+++ b/usr/src/cmd/pi/cset.c
@@ -0,0 +1,142 @@
+/* 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);
+}