From 1bbf66cfa8d4bce84261143b05ad0a438067e71d Mon Sep 17 00:00:00 2001 From: "Charles B. Haley" Date: Wed, 31 Oct 1979 20:24:37 -0800 Subject: [PATCH] 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 Co-Authored-By: Ken Thompson Synthesized-from: 3bsd --- usr/src/cmd/pi/ato.c | 45 ++++++++ usr/src/cmd/pi/clas.c | 210 +++++++++++++++++++++++++++++++++++ usr/src/cmd/pi/const.c | 232 ++++++++++++++++++++++++++++++++++++++ usr/src/cmd/pi/conv.c | 247 +++++++++++++++++++++++++++++++++++++++++ usr/src/cmd/pi/cset.c | 142 +++++++++++++++++++++++ 5 files changed, 876 insertions(+) create mode 100644 usr/src/cmd/pi/ato.c create mode 100644 usr/src/cmd/pi/clas.c create mode 100644 usr/src/cmd/pi/const.c create mode 100644 usr/src/cmd/pi/conv.c create mode 100644 usr/src/cmd/pi/cset.c diff --git a/usr/src/cmd/pi/ato.c b/usr/src/cmd/pi/ato.c new file mode 100644 index 0000000000..1e92dd4e17 --- /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 index 0000000000..13929ccba1 --- /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 index 0000000000..34414b2d4a --- /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 + +/* + * 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 index 0000000000..4bfca60693 --- /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 index 0000000000..0e3af24164 --- /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); +} -- 2.20.1