From: Bill Joy Date: Thu, 10 May 1979 02:52:52 +0000 (-0800) Subject: BSD 2 development X-Git-Tag: BSD-2~10 X-Git-Url: https://git.subgeniuskitty.com/unix-history/.git/commitdiff_plain/a0ce3a0c20147a6b8317807d32824950008eb2e9 BSD 2 development Work on file src/pi0/rval.c Work on file src/pi0/send.c Work on file src/pi0/send.h Work on file src/pi0/string.c Work on file src/pi0/subr.c Work on file src/pi0/tree.c Work on file src/pi0/tree.h Work on file src/pi0/type.c Work on file src/pi0/var.c Synthesized-from: 2bsd --- diff --git a/src/pi0/rval.c b/src/pi0/rval.c new file mode 100644 index 0000000000..e20884bf49 --- /dev/null +++ b/src/pi0/rval.c @@ -0,0 +1,551 @@ +/* Copyright (c) 1979 Regents of the University of California */ +# +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + * Version 1.2 January 1979 + */ + +#include "0.h" +#include "tree.h" +#include "opcode.h" + +extern char *opnames[]; +/* + * Rvalue - an expression. + * + * Contype is the type that the caller would prefer, nand is important + * if constant sets or constant strings are involved, the latter + * because of string padding. + */ +rvalue(r, contype) + int *r; + struct nl *contype; +{ + register struct nl *p, *p1; + register struct nl *q; + int c, c1, *rt, w, g; + char *cp, *cp1, *opname; + long l; + double f; + + if (r == NIL) + return (NIL); + if (nowexp(r)) + return (NIL); + /* + * Pick up the name of the operation + * for future error messages. + */ + if (r[0] <= T_IN) + opname = opnames[r[0]]; + + /* + * The root of the tree tells us what sort of expression we have. + */ + switch (r[0]) { + + /* + * The constant nil + */ + case T_NIL: + put2(O_CON2, 0); + return (nl+TNIL); + + /* + * Function call with arguments. + */ + case T_FCALL: + return (funccod(r)); + + case T_VAR: + p = lookup(r[2]); + if (p == NIL || p->class == BADUSE) + return (NIL); + switch (p->class) { + case VAR: + /* + * If a variable is + * qualified then get + * the rvalue by a + * lvalue and an ind. + */ + if (r[3] != NIL) + goto ind; + q = p->type; + if (q == NIL) + return (NIL); + w = width(q); + switch (w) { + case 8: + w = 6; + case 4: + case 2: + case 1: + put2(O_RV1 + (w >> 1) | bn << 9, p->value[0]); + break; + default: + put3(O_RV | bn << 9, p->value[0], w); + } + return (q); + + case WITHPTR: + case REF: + /* + * A lvalue for these + * is actually what one + * might consider a rvalue. + */ +ind: + q = lvalue(r, NOMOD); + if (q == NIL) + return (NIL); + w = width(q); + switch (w) { + case 8: + w = 6; + case 4: + case 2: + case 1: + put1(O_IND1 + (w >> 1)); + break; + default: + put2(O_IND, w); + } + return (q); + + case CONST: + if (r[3] != NIL) { + error("%s is a constant and cannot be qualified", r[2]); + return (NIL); + } + q = p->type; + if (q == NIL) + return (NIL); + if (q == nl+TSTR) { + /* + * Find the size of the string + * constant if needed. + */ + cp = p->value[0]; +cstrng: + cp1 = cp; + for (c = 0; *cp++; c++) + continue; + if (contype != NIL && !opt('s')) { + if (width(contype) < c && classify(contype) == TSTR) { + error("Constant string too long"); + return (NIL); + } + c = width(contype); + } + put3(O_CONG, c, cp1); + /* + * Define the string temporarily + * so later people can know its + * width. + * cleaned out by stat. + */ + q = defnl(0, STR, 0, c); + q->type = q; + return (q); + } + if (q == nl+T1CHAR) { + put2(O_CONC, p->value[0]); + return (q); + } + /* + * Every other kind of constant here + */ + switch (width(q)) { + case 8: +#ifndef DEBUG + put(5, O_CON8, p->real); +#else + if (hp21mx) { + f = p->real; + conv(&f); + l = f.plong; + put3(O_CON4, l); + } else + put(5, O_CON8, p->real); +#endif + break; + case 4: + put3(O_CON4, p->range[0]); + break; + case 2: + put2(O_CON2, p->value[1]); + break; + case 1: + put2(O_CON1, p->value[0]); + break; + default: + panic("rval"); + } + return (q); + + case FUNC: + /* + * Function call with no arguments. + */ + if (r[3]) { + error("Can't qualify a function result value"); + return (NIL); + } + return (funccod(r)); + + case TYPE: + error("Type names (e.g. %s) allowed only in declarations", p->symbol); + return (NIL); + + case PROC: + error("Procedure %s found where expression required", p->symbol); + return (NIL); + default: + panic("rvid"); + } + /* + * Constant sets + */ + case T_CSET: + return (cset(r, contype, NIL)); + + /* + * Unary plus and minus + */ + case T_PLUS: + case T_MINUS: + q = rvalue(r[2], NIL); + if (q == NIL) + return (NIL); + if (isnta(q, "id")) { + error("Operand of %s must be integer or real, not %s", opname, nameof(q)); + return (NIL); + } + if (r[0] == T_MINUS) { + put1(O_NEG2 + (width(q) >> 2)); + return (isa(q, "d") ? q : nl+T4INT); + } + return (q); + + case T_NOT: + q = rvalue(r[2], NIL); + if (q == NIL) + return (NIL); + if (isnta(q, "b")) { + error("not must operate on a Boolean, not %s", nameof(q)); + return (NIL); + } + put1(O_NOT); + return (nl+T1BOOL); + + case T_AND: + case T_OR: + p = rvalue(r[2], NIL); + p1 = rvalue(r[3], NIL); + if (p == NIL || p1 == NIL) + return (NIL); + if (isnta(p, "b")) { + error("Left operand of %s must be Boolean, not %s", opname, nameof(p)); + return (NIL); + } + if (isnta(p1, "b")) { + error("Right operand of %s must be Boolean, not %s", opname, nameof(p1)); + return (NIL); + } + put1(r[0] == T_AND ? O_AND : O_OR); + return (nl+T1BOOL); + + case T_DIVD: + p = rvalue(r[2], NIL); + p1 = rvalue(r[3], NIL); + if (p == NIL || p1 == NIL) + return (NIL); + if (isnta(p, "id")) { + error("Left operand of / must be integer or real, not %s", nameof(p)); + return (NIL); + } + if (isnta(p1, "id")) { + error("Right operand of / must be integer or real, not %s", nameof(p1)); + return (NIL); + } + return (gen(NIL, r[0], width(p), width(p1))); + + case T_MULT: + case T_SUB: + case T_ADD: + /* + * If the context hasn't told us + * the type and a constant set is + * present on the left we need to infer + * the type from the right if possible + * before generating left side code. + */ + if (contype == NIL && (rt = r[2]) != NIL && rt[1] == SAWCON) { + codeoff(); + contype = rvalue(r[3], NIL); + codeon(); + if (contype == NIL) + return (NIL); + } + p = rvalue(r[2], contype); + p1 = rvalue(r[3], p); + if (p == NIL || p1 == NIL) + return (NIL); + if (isa(p, "id") && isa(p1, "id")) + return (gen(NIL, r[0], width(p), width(p1))); + if (isa(p, "t") && isa(p1, "t")) { + if (p != p1) { + error("Set types of operands of %s must be identical", opname); + return (NIL); + } + gen(TSET, r[0], width(p), 0); + /* + * Note that set was filled in by the call + * to width above. + */ + if (r[0] == T_SUB) + put2(NIL, 0177777 << ((set.uprbp & 017) + 1)); + return (p); + } + if (isnta(p, "idt")) { + error("Left operand of %s must be integer, real or set, not %s", opname, nameof(p)); + return (NIL); + } + if (isnta(p1, "idt")) { + error("Right operand of %s must be integer, real or set, not %s", opname, nameof(p1)); + return (NIL); + } + error("Cannot mix sets with integers and reals as operands of %s", opname); + return (NIL); + + case T_MOD: + case T_DIV: + p = rvalue(r[2], NIL); + p1 = rvalue(r[3], NIL); + if (p == NIL || p1 == NIL) + return (NIL); + if (isnta(p, "i")) { + error("Left operand of %s must be integer, not %s", opname, nameof(p)); + return (NIL); + } + if (isnta(p1, "i")) { + error("Right operand of %s must be integer, not %s", opname, nameof(p1)); + return (NIL); + } + return (gen(NIL, r[0], width(p), width(p1))); + + case T_EQ: + case T_NE: + case T_GE: + case T_LE: + case T_GT: + case T_LT: + /* + * Since there can be no, a priori, knowledge + * of the context type should a constant string + * or set arise, we must poke around to find such + * a type if possible. Since constant strings can + * always masquerade as identifiers, this is always + * necessary. + */ + codeoff(); + p1 = rvalue(r[3], NIL); + codeon(); + if (p1 == NIL) + return (NIL); + contype = p1; + if (p1 == nl+TSET || p1->class == STR) { + /* + * For constant strings we want + * the longest type so as to be + * able to do padding (more importantly + * avoiding truncation). For clarity, + * we get this length here. + */ + codeoff(); + p = rvalue(r[2], NIL); + codeon(); + if (p == NIL) + return (NIL); + if (p1 == nl+TSET || width(p) > width(p1)) + contype = p; + } + /* + * Now we generate code for + * the operands of the relational + * operation. + */ + p = rvalue(r[2], contype); + if (p == NIL) + return (NIL); + p1 = rvalue(r[3], p); + if (p1 == NIL) + return (NIL); + c = classify(p); + c1 = classify(p1); + if (nocomp(c) || nocomp(c1)) + return (NIL); + g = NIL; + switch (c) { + case TBOOL: + case TCHAR: + if (c != c1) + goto clash; + break; + case TINT: + case TDOUBLE: + if (c1 != TINT && c1 != TDOUBLE) + goto clash; + break; + case TSCAL: + if (c1 != TSCAL) + goto clash; + if (scalar(p) != scalar(p1)) + goto nonident; + break; + case TSET: + if (c1 != TSET) + goto clash; + if (p != p1) + goto nonident; + g = TSET; + break; + case TPTR: + case TNIL: + if (c1 != TPTR && c1 != TNIL) + goto clash; + if (r[0] != T_EQ && r[0] != T_NE) { + error("%s not allowed on pointers - only allow = and <>"); + return (NIL); + } + break; + case TSTR: + if (c1 != TSTR) + goto clash; + if (width(p) != width(p1)) { + error("Strings not same length in %s comparison", opname); + return (NIL); + } + g = TSTR; + break; + default: + panic("rval2"); + } + return (gen(g, r[0], width(p), width(p1))); +clash: + error("%ss and %ss cannot be compared - operator was %s", clnames[c], clnames[c1], opname); + return (NIL); +nonident: + error("%s types must be identical in comparisons - operator was %s", clnames[c1], opname); + return (NIL); + + case T_IN: + rt = r[3]; + if (rt != NIL && rt[0] == T_CSET) + p1 = cset(rt, NIL, 1); + else { + p1 = rvalue(r[3], NIL); + rt = NIL; + } + if (p1 == nl+TSET) { + warning(); + error("... in [] makes little sense, since it is always false!"); + put1(O_CON1, 0); + return (nl+T1BOOL); + } + p = rvalue(r[2], NIL); + if (p == NIL || p1 == NIL) + return (NIL); + if (p1->class != SET) { + error("Right operand of 'in' must be a set, not %s", nameof(p1)); + return (NIL); + } + if (incompat(p, p1->type, r[2])) { + cerror("Index type clashed with set component type for 'in'"); + return (NIL); + } + convert(p, nl+T2INT); + setran(p1->type); + if (rt == NIL) + put4(O_IN, width(p1), set.lwrb, set.uprbp); + else + put1(O_INCT); + return (nl+T1BOOL); + + default: + if (r[2] == NIL) + return (NIL); + switch (r[0]) { + default: + panic("rval3"); + + + /* + * An octal number + */ + case T_BINT: + f = a8tol(r[2]); + goto conint; + + /* + * A decimal number + */ + case T_INT: + f = atof(r[2]); +conint: + if (f > MAXINT || f < MININT) { + error("Constant too large for this implementation"); + return (NIL); + } + l = f; + if (bytes(l, l) <= 2) { + put2(O_CON2, c=l); + return (nl+T2INT); + } + put3(O_CON4, l); + return (nl+T4INT); + + /* + * A floating point number + */ + case T_FINT: + put(5, O_CON8, atof(r[2])); + return (nl+TDOUBLE); + + /* + * Constant strings. Note that constant characters + * are constant strings of length one; there is + * no constant string of length one. + */ + case T_STRNG: + cp = r[2]; + if (cp[1] == 0) { + put2(O_CONC, cp[0]); + return (nl+T1CHAR); + } + goto cstrng; + } + + } +} + +/* + * Can a class appear + * in a comparison ? + */ +nocomp(c) + int c; +{ + + switch (c) { + case TFILE: + case TARY: + case TREC: + error("%ss may not participate in comparisons", clnames[c]); + return (1); + } + return (NIL); +} diff --git a/src/pi0/send.c b/src/pi0/send.c new file mode 100644 index 0000000000..3d8bbecc08 --- /dev/null +++ b/src/pi0/send.c @@ -0,0 +1,295 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#include "0.h" +#include "tree.h" +/* + * pi - Pascal interpreter code translator + * Bill Joy UCB + * February 5, 1978 + */ + +int pipbuf[259]; +int pv[2], pv2[2]; +int pid -1; + +char *PI1 "/usr/lib/pi1"; + +#define ETXTBSY 26 + +char printed, hadsome; +#ifdef PC0 +char fileout; +#endif + +send(i, a1, a2, a3, a4) + register int i; +{ + register int *ap; + register char *cp; + int x; + extern errno; + extern char *lastname, *obj; + + switch (i) { + + case RINIT: +#ifdef PC0 + if (opt('f')) { + fileout++; + if (fcreat(pipbuf, "tree") < 0) { + perror( "tree"); + pexit(NOSTART); + } + } else { +#endif + if (pipe(pv) || pipe(pv2)) { + perror( "pipe"); + pexit(NOSTART); + } + pid = fork(); + if (pid == -1) { + perror(0); + pexit(NOSTART); + } + if (pid == 0) { + close(0); + dup(pv[0]); + close(pv[0]); + close(pv[1]); + close(pv2[0]); + for (;;) { +#ifdef DEBUG + execl(PI1, "pi1", hp21mx ? "" : 0, 0); +#else + execl(PI1, "pi1", 0); +#endif + if (errno != ETXTBSY) + break; + sleep(2); + } + perror(PI1); + exit(1); + } + pipbuf[0] = pv[1]; + close(pv[0]); + pv[0] = pv2[0]; + close(pv2[1]); +#ifdef PC0 + } +#endif + filename = lastname = savestr(filename); + obj = savestr(obj); + errfile = savestr(errfile); + putac(i); + putaw(soffset(lastname)); + putaw(soffset(obj)); + putac(pv2[1]); + for (i = 0; i < 26; i++) + putac(opts[i]); + putac(efil); + putaw(soffset(errfile)); + putac(ofil); + break; + + case RENQ: +ackit: + if (opt('l')) + yyoutline(); + putac(RENQ); + ack(); + break; + + case RTREE: + ap = a1; + putac(i); + i = *ap++; + if (i < 0 || i > T_LAST) + panic("send RTREE"); + putac(i); + cp = trdesc[i]; + while (*cp) switch (*cp++) { + + case 's': + cp = ap; + while (*cp) + putac(*cp++); + putac(0); + ap = (((unsigned) cp) + 2) &~ 1; + return (ap); + + case 'd': + putac(*ap++); + continue; + + case 'n': + putaw(*ap++); + continue; + + case '"': + putaw(soffset(*ap++)); + continue; + + case 'p': + putaw(toffset(*ap++)); + continue; + + default: + panic("send RTREE case"); + } +#ifdef DEBUG + if (*ap < 0 || *ap > T_LAST) + printf("trdesc[%d] flunks\n", i); +#endif + return (ap); + +#ifdef DEBUG + case RTRCHK: + putac(i); + putaw(a1); + break; +#endif + + case RTRFREE: + tsend(); + case REVTBEG: + case REVVBEG: + case REVTEND: + case REVVEND: + case REVENIT: + putac(i); + break; + + case RSTRING: + putac(RSTRING); + for (cp = a1; *cp; cp) + putac(*cp++); + putac(0); + break; + + case REVLAB: + tsend(); + putac(i); + putaw(toffset(a1)); + break; + + case REVCNST: + tsend(); + putac(i); + putaw(a1); + putaw(soffset(a2)); + putaw(toffset(a3)); + break; + + case REVTYPE: + tsend(); + putac(i); + putaw(a1); + putaw(soffset(a2)); + putaw(toffset(a3)); + break; + + case REVVAR: + tsend(); + putac(i); + putaw(a1); + putaw(toffset(a2)); + putaw(toffset(a3)); + break; + + case REVFHDR: + tsend(); + putac(i); + putaw(toffset(a1)); + break; + + case REVFBDY: + putac(i); + break; + + case REVFEND: + tsend(); + putac(i); + putaw(toffset(a1)); + putaw(a2); + putaw(a3); + putaw(soffset(lastname)); + putaw(soffset(filename)); + putac(printed); + putac(hadsome); + goto ackit; + + case ROPUSH: + case ROPOP: + putac(i); + putac(a1); + break; + + case ROSET: + putac(i); + putac(a1); + putaw(a2); + break; + + case RKILL: + kill(pid, 1); + /* wait(&status); */ + break; + + case RFINISH: + putac(i); + fflush(pipbuf); +#ifdef PC0 + if (!fileout) { +#endif + if (read(pv[0], &x, 2) != 2) + panic("RFINISH"); + eflg =| x; +#ifdef PC0 + } else + pexit(NOSTART); +#endif + return; + + default: + panic("send"); + } +} + +putaw(i) + int i; +{ + + putw(i, pipbuf); +} + +putac(i) + int i; +{ + + putc(i, pipbuf); +} + +extern struct nl *Fp; + +ack() +{ + int i[3], j; + +#ifdef PC0 + if (!fileout) { +#endif + fflush(pipbuf); + j = read(pv[0], &i, 6); + if (j != 6) { + error("Fatal error in pass 2"); + pexit(DIED); + } + if (soffset(lastname) != i[0]) + lastname = filename; + Fp = i[1]; + printed = i[2] & 0377; + hadsome = (i[2] >> 8) & 0377; +#ifdef PC0 + } else + Fp = NIL; +#endif +} diff --git a/src/pi0/send.h b/src/pi0/send.h new file mode 100644 index 0000000000..28663ca45d --- /dev/null +++ b/src/pi0/send.h @@ -0,0 +1,29 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#define RINIT 1 +#define RENQ 2 +#define RTREE 3 +#define RTRFREE 4 +#define RTRCHK 5 +#define REVENIT 6 +#define RSTRING 7 +#define REVLAB 8 +#define REVCNST 9 +#define REVTBEG 10 +#define REVTYPE 11 +#define REVTEND 12 +#define REVVBEG 13 +#define REVVAR 14 +#define REVVEND 15 +#define REVFHDR 16 +#define REVFFWD 17 +#define REVFBDY 18 +#define REVFEND 19 +#define ROPUSH 20 +#define ROPOP 21 +#define ROSET 22 +#define RKILL 23 +#define RFINISH 24 + +#define RLAST 24 + +extern char *trdesc[]; diff --git a/src/pi0/string.c b/src/pi0/string.c new file mode 100644 index 0000000000..90271c2af6 --- /dev/null +++ b/src/pi0/string.c @@ -0,0 +1,158 @@ +/* Copyright (c) 1979 Regents of the University of California */ +# +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + * Version 1.2 January 1979 + * + * pxp - Pascal execution profiler + * + * Bill Joy UCB + * Version 1.2 January 1979 + */ + +#include "0.h" +#ifndef PI01 +#ifndef PXP +#include "send.h" +#endif +#endif + +/* + * STRING SPACE DECLARATIONS + * + * Strng is the base of the current + * string space and strngp the + * base of the free area therein. + * Strp is the array of descriptors. + */ +#ifndef PI0 +static char strings[STRINC]; +static char *strng strings; +static char *strngp strings; +#else +char *strng, *strngp; +#endif +#ifndef PI01 +#ifndef PXP +static char *strp[20]; +static char **stract strp; +int strmax; +#endif +#endif + +#ifndef PI01 +#ifndef PXP +#ifndef PI0 +initstring() +#else +initstring(strings) + char *strings; +#endif +{ + + *stract++ = strings; +#ifdef PI0 + strng = strngp = strings; +#endif + strmax = STRINC * 2; +} +#endif +#endif + +/* + * Copy a string into the string area. + */ +savestr(cp) + register char *cp; +{ + register int i; + + i = strlen(cp) + 1; + if (strngp + i >= strng + STRINC) { + strngp = alloc(STRINC); + if (strngp == -1) { + yerror("Ran out of memory (string)"); + pexit(DIED); + } +#ifndef PI01 +#ifndef PXP + *stract++ = strngp; + strmax =+ STRINC; +#endif +#endif + strng = strngp; + } + strcpy(strngp, cp); + cp = strngp; + strngp = cp + i; +#ifdef PI0 + send(RSTRING, cp); +#endif + return (cp); +} + +#ifndef PI1 +#ifndef PXP +esavestr(cp) + char *cp; +{ + +#ifdef PI0 + send(REVENIT); +#endif + strngp = (strngp + 1) &~ 1; + return (savestr(cp)); +} +#endif +#endif + +#ifndef PI01 +#ifndef PXP +soffset(cp) + register char *cp; +{ + register char **sp; + register int i; + + if (cp == NIL || cp == OCT || cp == HEX) + return (-cp); + for (i = STRINC, sp = strp; sp < stract; sp++) { + if (cp >= *sp && cp < (*sp + STRINC)) + return (i + (cp - *sp)); + i =+ STRINC; + } + i = nlfund(cp); + if (i != 0) + return (i); + panic("soffset"); +} +#ifdef PI1 +sreloc(i) + register int i; +{ + + if (i == 0 || i == -OCT || i == -HEX) + return (-i); + if (i < STRINC) { + if (i >= INL) + panic("sreloc INL"); + i = nl[i].symbol; + if (i == 0) + panic("sreloc nl[i]"); + return (i); + } + if (i > strmax || i < 0) + panic("sreloc"); + return (strp[(i / STRINC) - 1] + (i % STRINC)); +} + +evenit() +{ + + strngp = (strngp + 1) &~ 1; +} +#endif +#endif +#endif diff --git a/src/pi0/subr.c b/src/pi0/subr.c new file mode 100644 index 0000000000..62e5673c1c --- /dev/null +++ b/src/pi0/subr.c @@ -0,0 +1,217 @@ +/* Copyright (c) 1979 Regents of the University of California */ +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + * Version 1.2 January 1979 + * + * + * pxp - Pascal execution profiler + * + * Bill Joy UCB + * Version 1.2 January 1979 + */ + +#include "0.h" + +#ifndef PI1 +/* + * Does the string fp end in '.' and the character c ? + */ +dotted(fp, c) + register char *fp; + char c; +{ + register int i; + + i = strlen(fp); + return (i > 1 && fp[i - 2] == '.' && fp[i - 1] == c); +} + +/* + * Toggle the option c. + */ +togopt(c) + char c; +{ + register char *tp; + + tp = &opts[c-'a']; + *tp = 1 - *tp; +} + +/* + * Set the time vector "tvec" to the + * modification time stamp of 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); +} +#endif + +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> 1; +#ifdef PI0 + send(ROPOP, c); +#endif +} diff --git a/src/pi0/tree.c b/src/pi0/tree.c new file mode 100644 index 0000000000..fa018b3f85 --- /dev/null +++ b/src/pi0/tree.c @@ -0,0 +1,299 @@ +/* Copyright (c) 1979 Regents of the University of California */ +# +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + */ + +#include "tree.h" +#include "0.h" + +/* + * TREE SPACE DECLARATIONS + */ +struct tr { + int *tr_low; + int *tr_high; +} ttab[MAXTREE], *tract; + +static int *ltsnt; + +/* + * 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 + +#ifndef PI0 +int trspace[ITREE]; +int *space trspace; +int *spacep trspace; +#endif +struct tr *tract ttab; + +int treemax; + +/* + * Inittree allocates the first tree slot + * and sets up the first segment descriptor. + * A lot of this work is actually done statically + * above. + */ +#ifndef PI0 +inittree() +#else +inittree(trspace) + int *trspace; +#endif +{ + +#ifdef PI0 + space = spacep = trspace; +#endif + ttab[0].tr_low = space; + ttab[0].tr_high = &space[ITREE - 1]; +#ifndef PI1 + ltsnt = space; +#endif + treemax = ITREE; + *spacep = 0; +} + +#ifndef PI1 +/* + * 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); + *p = 0; + 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); +} +#else +treev(i, q) + register int i, *q; +{ + register int *p; + + p = spacep; + do + *p++ = *q++; + while (--i); + *p = 0; + q = spacep; + spacep = p; + if (p+TREENMAX >= tract->tr_high) + tralloc(TREENMAX); + return (q); +} +#endif +/* + * 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) { + talloc(++tract); + spacep = tract->tr_low; + *spacep = 0; + } +} + +talloc(tp) + register struct tr *tp; +{ + register char *cp; + register int i; + + if (tp >= &ttab[MAXTREE]) { + yerror("Ran out of tree tables"); + pexit(DIED); + } + if (tp->tr_low != NIL) + return; + cp = alloc(TRINC * 2); + if (cp == -1) { + yerror("Ran out of memory (talloc)"); + pexit(DIED); + } + tp->tr_low = cp; + tp->tr_high = tp->tr_low + (TRINC - 1); + i = (tp - ttab + 1) * TRINC; + if (i > treemax) + treemax = i; +} +#ifndef PI1 +extern int yylacnt; +extern bottled; +#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() +{ + +#ifndef PI1 + if (yylacnt != 0 || bottled != NIL) + return; +#endif +#ifndef PI1 + send(RTRFREE); + ltsnt = space; +#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"); + } + treemax = ITREE; +} + +/* + * 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) + 4) & ~1; + tralloc(i >> 1); + *spacep++ = T_COPSTR; + i =- 2; + strcpy(spacep, token); + cp = spacep; + spacep = cp + i; + *spacep = 0; + tralloc(TREENMAX); + return (cp); +} + +/* actually needed in PI1 only if DEBUG... */ +toffset(ap) + register int *ap; +{ + register struct tr *tp; + register int i; + + if (ap == 0) + return (0); + i = TRINC; + for (tp = ttab; tp->tr_low != NIL && tp < &ttab[MAXTREE]; tp++) { + if (ap >= tp->tr_low && ap < tp->tr_high) + return (i + (ap - tp->tr_low)); + i =+ TRINC; + } + return (-soffset(ap)); +} + +#ifndef PI1 +tsend() +{ + register struct tr *trp; + register int *ap; + + ap = ltsnt; + for (trp = &ttab[(toffset(ltsnt) / TRINC) - 1]; trp <= tract; trp++) { + while (ap < trp->tr_high && *ap) + ap = send(RTREE, ap); + ltsnt = ap; + ap = trp[1].tr_low; + } +#ifdef DEBUG + send(RTRCHK, toffset(ltsnt)); +#endif +} +#endif +#ifdef PI1 +treloc(i) + register int i; +{ + + if (i == 0) + return (0); + if (i < TRINC) + return (sreloc(-i)); + i =- TRINC; + if (i >= treemax) + trmax(i); + return (ttab[i / TRINC].tr_low + i % TRINC); +} + +trmax(i) + register int i; +{ + register struct tr *tp; + + i = (i + TRINC) / TRINC; + for (tp = ttab; i > 0; tp++, i--) + talloc(tp); +} +#endif diff --git a/src/pi0/tree.h b/src/pi0/tree.h new file mode 100644 index 0000000000..0221a38a9c --- /dev/null +++ b/src/pi0/tree.h @@ -0,0 +1,82 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#define T_MINUS 1 +#define T_MOD 2 +#define T_DIV 3 +#define T_DIVD 4 +#define T_MULT 5 +#define T_ADD 6 +#define T_SUB 7 +#define T_EQ 8 +#define T_NE 9 +#define T_LT 10 +#define T_GT 11 +#define T_LE 12 +#define T_GE 13 +#define T_NOT 14 +#define T_AND 15 +#define T_OR 16 +#define T_ASGN 17 +#define T_PLUS 18 +#define T_IN 19 +#define T_LISTPP 20 +#define T_PDEC 21 +#define T_FDEC 22 +#define T_PVAL 23 +#define T_PVAR 24 +#define T_PFUNC 25 +#define T_PPROC 26 +#define T_NIL 27 +#define T_STRNG 28 +#define T_CSTRNG 29 +#define T_PLUSC 30 +#define T_MINUSC 31 +#define T_ID 32 +#define T_INT 33 +#define T_FINT 34 +#define T_CINT 35 +#define T_CFINT 36 +#define T_TYPTR 37 +#define T_TYPACK 38 +#define T_TYSCAL 39 +#define T_TYRANG 40 +#define T_TYARY 41 +#define T_TYFILE 42 +#define T_TYSET 43 +#define T_TYREC 44 +#define T_TYFIELD 45 +#define T_TYVARPT 46 +#define T_TYVARNT 47 +#define T_CSTAT 48 +#define T_BLOCK 49 +#define T_BSTL 50 +#define T_LABEL 51 +#define T_PCALL 52 +#define T_FCALL 53 +#define T_CASE 54 +#define T_WITH 55 +#define T_WHILE 56 +#define T_REPEAT 57 +#define T_FORU 58 +#define T_FORD 59 +#define T_GOTO 60 +#define T_IF 61 +#define T_ASRT 62 +#define T_CSET 63 +#define T_RANG 64 +#define T_VAR 65 +#define T_ARGL 66 +#define T_ARY 67 +#define T_FIELD 68 +#define T_PTR 69 +#define T_WEXP 70 +#define T_PROG 71 +#define T_BINT 72 +#define T_CBINT 73 +#define T_IFEL 74 +#define T_IFX 75 +#define T_TYID 76 +#define T_COPSTR 77 +#define T_BOTTLE 78 +#define T_RFIELD 79 +#define T_FLDLST 80 +#define T_LAST 81 diff --git a/src/pi0/type.c b/src/pi0/type.c new file mode 100644 index 0000000000..989083d5a5 --- /dev/null +++ b/src/pi0/type.c @@ -0,0 +1,324 @@ +/* Copyright (c) 1979 Regents of the University of California */ +# +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + * Version 1.2 January 1979 + */ + +#include "0.h" +#include "tree.h" + +/* + * Type declaration part + */ +typebeg() +{ + +#ifndef PI1 + if (parts & VPRT) + error("Type declarations must precede var declarations"); + if (parts & TPRT) + error("All types must be declared in one type part"); + parts =| TPRT; +#endif + /* + * Forechain is the head of a list of types that + * might be self referential. We chain them up and + * process them later. + */ + forechain = NIL; +#ifdef PI0 + send(REVTBEG); +#endif +} + +type(tline, tid, tdecl) + int tline; + char *tid; + register int *tdecl; +{ + register struct nl *np; + + np = gtype(tdecl); + line = tline; + if (np != NIL && (tdecl[0] == T_ID || tdecl[0] == T_TYID)) + np = nlcopy(np); +#ifndef PI0 + enter(defnl(tid, TYPE, np, 0))->nl_flags =| NMOD; +#else + enter(defnl(tid, TYPE, np, 0)); + send(REVTYPE, tline, tid, tdecl); +#endif +} + +typeend() +{ + +#ifdef PI0 + send(REVTEND); +#endif + foredecl(); +} + +/* + * Return a type pointer (into the namelist) + * from a parse tree for a type, building + * namelist entries as needed. + */ +gtype(r) + register int *r; +{ + register struct nl *np; + register char *cp; + int oline; + + if (r == NIL) + return (NIL); + oline = line; + if (r[0] != T_ID) + oline = line = r[1]; + switch (r[0]) { + default: + panic("type"); + case T_TYID: + r++; + case T_ID: + np = lookup(r[1]); + if (np == NIL) + break; + if (np->class != TYPE) { +#ifndef PI1 + error("%s is a %s, not a type as required", r[1], classes[np->class]); +#endif + np = NIL; + break; + } + np = np->type; + break; + case T_TYSCAL: + np = tyscal(r); + break; + case T_TYRANG: + np = tyrang(r); + break; + case T_TYPTR: + np = defnl(0, PTR, 0, r[2]); + np->nl_next = forechain; + forechain = np; + break; + case T_TYPACK: + np = gtype(r[2]); + break; + case T_TYARY: + np = tyary(r); + break; + case T_TYREC: + np = tyrec(r[2], 0); + break; + case T_TYFILE: + np = gtype(r[2]); + if (np == NIL) + break; +#ifndef PI1 + if (np->nl_flags & NFILES) + error("Files cannot be members of files"); +#endif + np = defnl(0, FILE, np, 0); + np->nl_flags =| NFILES; + break; + case T_TYSET: + np = gtype(r[2]); + if (np == NIL) + break; + if (np->type == nl+TDOUBLE) { +#ifndef PI1 + error("Set of real is not allowed"); +#endif + np = NIL; + break; + } + if (np->class != RANGE && np->class != SCAL) { +#ifndef PI1 + error("Set type must be range or scalar, not %s", nameof(np)); +#endif + np = NIL; + break; + } +#ifndef PI1 + if (width(np) > 2) + error("Implementation restriction: sets must be indexed by 16 bit quantities"); +#endif + np = defnl(0, SET, np, 0); + break; + } + line = oline; + return (np); +} + +/* + * Scalar (enumerated) types + */ +tyscal(r) + int *r; +{ + register struct nl *np, *op; + register *v; + int i; + + np = defnl(0, SCAL, 0, 0); + np->type = np; + v = r[2]; + if (v == NIL) + return (NIL); + i = -1; + for (; v != NIL; v = v[2]) { + op = enter(defnl(v[1], CONST, np, ++i)); +#ifndef PI0 + op->nl_flags =| NMOD; +#endif + op->value[1] = i; + } + np->range[1] = i; + return (np); +} + +/* + * Declare a subrange. + */ +tyrang(r) + register int *r; +{ + register struct nl *lp, *hp; + double high; + int c, c1; + + gconst(r[3]); + hp = con.ctype; + high = con.crval; + gconst(r[2]); + lp = con.ctype; + if (lp == NIL || hp == NIL) + return (NIL); + if (norange(lp) || norange(hp)) + return (NIL); + c = classify(lp); + c1 = classify(hp); + if (c != c1) { +#ifndef PI1 + error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp)); +#endif + return (NIL); + } + if (c == TSCAL && scalar(lp) != scalar(hp)) { +#ifndef PI1 + error("Scalar types must be identical in subranges"); +#endif + return (NIL); + } + if (con.crval > high) { +#ifndef PI1 + error("Range lower bound exceeds upper bound"); +#endif + return (NIL); + } + lp = defnl(0, RANGE, hp->type, 0); + lp->range[0] = con.crval; + lp->range[1] = high; + return (lp); +} + +norange(p) + register struct nl *p; +{ + if (isa(p, "d")) { +#ifndef PI1 + error("Subrange of real is not allowed"); +#endif + return (1); + } + if (isnta(p, "bcsi")) { +#ifndef PI1 + error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p)); +#endif + return (1); + } + return (0); +} + +/* + * Declare arrays and chain together the dimension specification + */ +tyary(r) + int *r; +{ + struct nl *np; + register *tl; + register struct nl *tp, *ltp; + int i; + + tp = gtype(r[3]); + if (tp == NIL) + return (NIL); + np = defnl(0, ARRAY, tp, 0); + np->nl_flags =| (tp->nl_flags) & NFILES; + ltp = np; + i = 0; + for (tl = r[2]; tl != NIL; tl = tl[2]) { + tp = gtype(tl[1]); + if (tp == NIL) { + np = NIL; + continue; + } + if (tp->class == RANGE && tp->type == nl+TDOUBLE) { +#ifndef PI1 + error("Index type for arrays cannot be real"); +#endif + np = NIL; + continue; + } + if (tp->class != RANGE && tp->class != SCAL) { +#ifndef PI1 + error("Array index type is a %s, not a range or scalar as required", classes[tp->class]); +#endif + np = NIL; + continue; + } + if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { +#ifndef PI1 + error("Value of dimension specifier too large or small for this implementation"); +#endif + continue; + } + tp = nlcopy(tp); + i++; + ltp->chain = tp; + ltp = tp; + } + if (np != NIL) + np->value[0] = i; + return (np); +} + +/* + * Delayed processing for pointers to + * allow self-referential and mutually + * recursive pointer constructs. + */ +foredecl() +{ + register struct nl *p, *q; + + for (p = forechain; p != NIL; p = p->nl_next) { + if (p->class == PTR && p->value[0] != 0) + { + p->type = gtype(p->value[0]); +#ifndef PI1 + if (p->type != NIL && (p->type->nl_flags & NFILES)) + error("Files cannot be members of dynamic structures"); +#endif + p->value[0] = 0; + } + } +} diff --git a/src/pi0/var.c b/src/pi0/var.c new file mode 100644 index 0000000000..e32193e466 --- /dev/null +++ b/src/pi0/var.c @@ -0,0 +1,236 @@ +/* Copyright (c) 1979 Regents of the University of California */ +# +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + * Version 1.2 January 1979 + */ + +#include "0.h" +#include "tree.h" +#include "opcode.h" + +/* + * Declare variables of a var part. DPOFF1 is + * the local variable storage for all prog/proc/func + * modules aside from the block mark. The total size + * of all the local variables is entered into the + * size array. + */ +varbeg() +{ + +#ifndef PI1 + if (parts & VPRT) + error("All variables must be declared in one var part"); + parts =| VPRT; +#endif +#ifndef PI0 + sizes[cbn].om_max = sizes[cbn].om_off = -DPOFF1; +#endif + forechain = NIL; +#ifdef PI0 + send(REVVBEG); +#endif +} + +var(vline, vidl, vtype) +#ifdef PI0 + int vline, *vidl, *vtype; +{ + register struct nl *np; + register int *vl; + + np = gtype(vtype); + line = vline; + for (vl = vidl; vl != NIL; vl = vl[2]) + enter(defnl(vl[1], VAR, np, 0)); + send(REVVAR, vline, vidl, vtype); +#else + int vline; + register int *vidl; + int *vtype; +{ + register struct nl *np; + register struct om *op; + long w; + int o2; + + np = gtype(vtype); + line = vline; + w = (lwidth(np) + 1) &~ 1; + op = &sizes[cbn]; + for (; vidl != NIL; vidl = vidl[2]) { + op->om_off =- w; + o2 = op->om_off; + enter(defnl(vidl[1], VAR, np, o2)); + } +#endif +} + +varend() +{ + + foredecl(); +#ifndef PI0 + sizes[cbn].om_max = sizes[cbn].om_off; +#else + send(REVVEND); +#endif +} + +/* + * Evening + */ +even(w) + register int w; +{ + if (w < 0) + return (w & ~1); + return ((w+1) & ~1); +} + +/* + * Find the width of a type in bytes. + */ +width(np) + struct nl *np; +{ + + return (lwidth(np)); +} + +long lwidth(np) + struct nl *np; +{ + register struct nl *p; + long w; + + p = np; + if (p == NIL) + return (0); +loop: + switch (p->class) { + case TYPE: + switch (nloff(p)) { + case TNIL: + return (2); + case TSTR: + case TSET: + panic("width"); + default: + p = p->type; + goto loop; + } + case ARRAY: + return (aryconst(p, 0)); + case PTR: + case FILE: + return (2); + case RANGE: + if (p->type == nl+TDOUBLE) +#ifdef DEBUG + return (hp21mx ? 4 : 8); +#else + return (8); +#endif + case SCAL: + return (bytes(p->range[0], p->range[1])); + case SET: + setran(p->type); + return ( (set.uprbp>>3) + 1); + case STR: + case RECORD: + w = 0; + w.pint2 = p->value[NL_OFFS]; + return (w); + default: + panic("wclass"); + } +} + +/* + * Return the width of an element + * of a n time subscripted np. + */ +long aryconst(np, n) + struct nl *np; + int n; +{ + register struct nl *p; + long s, d; + + if ((p = np) == NIL) + return (NIL); + if (p->class != ARRAY) + panic("ary"); + s = width(p->type); + /* + * Arrays of anything but characters are word aligned. + */ + if (s & 1) + if (s != 1) + s++; + /* + * Skip the first n subscripts + */ + while (n >= 0) { + p = p->chain; + n--; + } + /* + * Sum across remaining subscripts. + */ + while (p != NIL) { + if (p->class != RANGE && p->class != SCAL) + panic("aryran"); + d = p->range[1] - p->range[0] + 1; + s =* d; + p = p->chain; + } + return (s); +} + +/* + * Find the lower bound of a set, and also its size in bits. + */ +setran(q) + struct nl *q; +{ + register lb, ub; + register struct nl *p; + + p = q; + if (p == NIL) + return (NIL); + lb = p->range[0]; + ub = p->range[1]; + if (p->class != RANGE && p->class != SCAL) + panic("setran"); + set.lwrb = lb; + /* set.(upperbound prime) = number of bits - 1; */ + set.uprbp = ub-lb; +} + +/* + * Return the number of bytes required to hold an arithmetic quantity + */ +bytes(lb, ub) + long lb, ub; +{ + +#ifndef DEBUG + if (lb < -32768 || ub > 32767) + return (4); + else if (lb < -128 || ub > 127) + return (2); +#else + if (!hp21mx && (lb < -32768 || ub > 32767)) + return (4); + if (lb < -128 || ub > 127) + return (2); +#endif + else + return (1); +}