--- /dev/null
+/* 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"
+
+/*
+ * Funchdr inserts
+ * declaration of a the
+ * prog/proc/func into the
+ * namelist. It also handles
+ * the arguments and puts out
+ * a transfer which defines
+ * the entry point of a procedure.
+ */
+
+funchdr(r)
+ int *r;
+{
+ register struct nl *p;
+ register *il, **rl;
+ int *rll, o;
+ struct nl *cp, *dp, *sp;
+ int *pp;
+
+ send(REVFHDR, r);
+ if (inpflist(r[2])) {
+ opush('l');
+ yyretrieve(); /* kludge */
+ }
+ line = r[1];
+ if (r[3] == NIL && (p=lookup1(r[2])) != NIL && bn == cbn) {
+ /*
+ * Symbol already defined
+ * in this block. it is either
+ * a redeclared symbol (error)
+ * or a forward declaration.
+ */
+ if ((p->class == FUNC || p->class == PROC) && (p->nl_flags & NFORWD) != 0) {
+ /*
+ * Grammar doesnt forbid
+ * types on a resolution
+ * of a forward function
+ * declaration.
+ */
+ if (p->class == FUNC && r[4])
+ error("Function type should be given only in forward declaration");
+ return (p);
+ }
+ }
+ /*
+ * Declare the prog/proc/func
+ */
+ switch (r[0]) {
+ case T_PROG:
+ program = p = defnl(r[2], PROG, 0, 0);
+ break;
+ case T_PDEC:
+ if (r[4] != NIL)
+ error("Procedures do not have types, only functions do");
+ p = enter(defnl(r[2], PROC, 0, 0));
+ break;
+ case T_FDEC:
+ il = r[4];
+ if (il == NIL)
+ error("Function type must be specified");
+ else if (il[0] != T_TYID) {
+ il = NIL;
+ error("Function type can be specified only by using a type identifier");
+ } else
+ il = gtype(il);
+ p = enter(defnl(r[2], FUNC, il, NIL));
+ /*
+ * An arbitrary restriction
+ */
+ switch (o = classify(p->type)) {
+ case TFILE:
+ case TARY:
+ case TREC:
+ case TSET:
+ case TSTR:
+ warning();
+ if (opt('s'))
+ standard();
+ error("Functions should not return %ss", clnames[o]);
+ }
+ break;
+ default:
+ panic("funchdr");
+ }
+ if (r[0] != T_PROG) {
+ /*
+ * Mark this proc/func as
+ * begin forward declared
+ */
+ p->nl_flags =| NFORWD;
+ /*
+ * Enter the parameters
+ * in the next block for
+ * the time being
+ */
+ if (++cbn >= DSPLYSZ) {
+ error("Procedure/function nesting too deep");
+ pexit(ERRS);
+ }
+ /*
+ * For functions, the function variable
+ */
+ if (p->class == FUNC) {
+ cp = defnl(r[2], FVAR, p->type, 0);
+ cp->chain = p;
+ p->value[NL_FVAR] = cp;
+ }
+ /*
+ * Enter the parameters
+ */
+ cp = sp = p;
+ for (rl = r[3]; rl != NIL; rl = rl[2]) {
+ p = NIL;
+ if (rl[1] == NIL)
+ continue;
+ /*
+ * Parametric procedures
+ * don't have types
+ */
+ if (rl[1][0] != T_PPROC) {
+ rll = rl[1][2];
+ if (rll[0] != T_TYID) {
+ error("Types for arguments can be specified only by using type identifiers");
+ p = NIL;
+ } else
+ p = gtype(rll);
+ }
+ for (il = rl[1][1]; il != NIL; il = il[2]) {
+ switch (rl[1][0]) {
+ default:
+ panic("funchdr2");
+ case T_PVAL:
+ if (p != NIL) {
+ if (p->class == FILE)
+ error("Files cannot be passed by value");
+ else if (p->nl_flags & NFILES)
+ error("Files cannot be a component of %ss passed by value",
+ nameof(p));
+ }
+ dp = defnl(il[1], VAR, p, 0);
+ break;
+ case T_PVAR:
+ dp = defnl(il[1], REF, p, 0);
+ break;
+ case T_PFUNC:
+ case T_PPROC:
+ error("Procedure/function parameters not implemented");
+ continue;
+ }
+ if (dp != NIL) {
+ cp->chain = dp;
+ cp = dp;
+ }
+ }
+ }
+ cbn--;
+ p = sp;
+ } else {
+ cp = p;
+ for (rl = r[3]; rl; rl = rl[2]) {
+ if (rl[1] == NIL)
+ continue;
+ dp = defnl(rl[1], VAR, 0, 0);
+ cp->chain = dp;
+ cp = dp;
+ }
+ }
+ return (p);
+}
+
+/*
+ * Funcbody is called
+ * when the actual (resolved)
+ * declaration of a procedure is
+ * encountered. It puts the names
+ * of the (function) and parameters
+ * into the symbol table.
+ */
+funcbody(fp)
+ struct nl *fp;
+{
+ register struct nl *q, *p;
+
+ cbn++;
+ if (cbn >= DSPLYSZ) {
+ error("Too many levels of function/procedure nesting");
+ pexit(ERRS);
+ }
+ send(REVFBDY);
+ errcnt[cbn] = syneflg;
+ parts = NIL;
+ if (fp == NIL)
+ return (NIL);
+ /*
+ * Save the virtual name
+ * list stack pointer so
+ * the space can be freed
+ * later (funcend).
+ */
+ fp->value[2] = nlp;
+ if (fp->class != PROG)
+ for (q = fp->chain; q != NIL; q = q->chain)
+ enter(q);
+ if (fp->class == FUNC) {
+ /*
+ * For functions, enter the fvar
+ */
+ enter(fp->value[NL_FVAR]);
+ }
+ return (fp);
+}
+
+int pnumcnt;
+struct nl *Fp;
+/*
+ * Funcend is called to
+ * finish a block by generating
+ * the code for the statements.
+ * It then looks for unresolved declarations
+ * of labels, procedures and functions,
+ * and cleans up the name list.
+ * For the program, it checks the
+ * semantics of the program
+ * statement (yuchh).
+ */
+funcend(fp, bundle, endline)
+ struct nl *fp;
+ int *bundle;
+ int endline;
+{
+ register struct nl *p;
+ register int i, b;
+ int *blk;
+ char *cp;
+
+ blk = bundle[2];
+ if (fp == NIL) {
+ cbn--;
+ return;
+ }
+ send(REVFEND, bundle, endline, syneflg == errcnt[cbn]);
+ if (Fp != NIL)
+ Fp = fp;
+ /*
+ * Clean up the symbol table displays and check for unresolves
+ */
+ line = endline;
+ b = cbn;
+ for (i = 0; i <= 077; i++) {
+ for (p = disptab[i]; p != NIL && (p->nl_block & 037) == b; p = p->nl_next)
+ if (p->class == BADUSE) {
+ cp = "s";
+ if (p->chain->ud_next == NIL)
+ cp++;
+ eholdnl();
+ if (p->value[NL_KINDS] & ISUNDEF)
+ nerror("%s undefined on line%s", p->symbol, cp);
+ else
+ nerror("%s improperly used on line%s", p->symbol, cp);
+ pnumcnt = 10;
+ pnums(p->chain);
+ putchar('\n');
+ }
+ /*
+ * Pop this symbol
+ * table slot
+ */
+ disptab[i] = p;
+ }
+
+#ifdef DEBUG
+ dumpnl(fp->value[2], fp->symbol);
+#endif
+ /*
+ * Restore the
+ * (virtual) name list
+ * position
+ */
+ nlfree(fp->value[2]);
+ /*
+ * Proc/func has been
+ * resolved
+ */
+ fp->nl_flags =& ~NFORWD;
+ elineon();
+ cbn--;
+ if (inpflist(fp->symbol)) {
+ opop('l');
+ }
+}
+
+pnums(p)
+ struct udinfo *p;
+{
+
+ if (p->ud_next != NIL)
+ pnums(p->ud_next);
+ if (pnumcnt == 0) {
+ printf("\n\t");
+ pnumcnt = 20;
+ }
+ pnumcnt--;
+ printf(" %d", p->ud_line);
+}
+
+nerror(a1, a2, a3)
+{
+
+ if (Fp != NIL) {
+ yySsync();
+ printf("In %s %s:\n", classes[Fp->class], Fp->symbol);
+ Fp = NIL;
+ }
+ elineoff();
+ error(a1, a2, a3);
+}
--- /dev/null
+/* 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"
+#include "yy.h"
+
+/*
+ * The definition for the segmented hash tables.
+ */
+struct ht {
+ int *ht_low;
+ int *ht_high;
+ int ht_used;
+} htab[MAXHASH];
+
+/*
+ * This is the array of keywords and their
+ * token values, which are hashed into the table
+ * by inithash.
+ */
+struct kwtab yykey[] {
+ "and", YAND,
+ "array", YARRAY,
+ "assert", YASSERT,
+ "begin", YBEGIN,
+ "case", YCASE,
+ "const", YCONST,
+ "div", YDIV,
+ "do", YDO,
+ "downto", YDOWNTO,
+ "else", YELSE,
+ "end", YEND,
+ "file", YFILE,
+ "for", YFOR,
+ "forward", YFORWARD,
+ "function", YFUNCTION,
+ "goto", YGOTO,
+ "if", YIF,
+ "in", YIN,
+ "label", YLABEL,
+ "mod", YMOD,
+ "nil", YNIL,
+ "not", YNOT,
+ "of", YOF,
+ "or", YOR,
+ "packed", YPACKED,
+ "procedure", YPROCEDURE,
+ "program", YPROG,
+ "record", YRECORD,
+ "repeat", YREPEAT,
+ "set", YSET,
+ "then", YTHEN,
+ "to", YTO,
+ "type", YTYPE,
+ "until", YUNTIL,
+ "var", YVAR,
+ "while", YWHILE,
+ "with", YWITH,
+ "oct", YOCT, /* non-standard Pascal */
+ "hex", YHEX, /* non-standard Pascal */
+ 0
+};
+
+char *lastkey &yykey[sizeof yykey/sizeof yykey[0]];
+
+/*
+ * Inithash initializes the hash table routines
+ * by allocating the first hash table segment using
+ * an already existing memory slot.
+ */
+#ifndef PI0
+inithash()
+#else
+inithash(hshtab)
+ int *hshtab;
+#endif
+{
+ register int *ip;
+#ifndef PI0
+ static int hshtab[HASHINC];
+#endif
+
+ htab[0].ht_low = hshtab;
+ htab[0].ht_high = &hshtab[HASHINC];
+ for (ip = yykey; *ip; ip =+ 2)
+ hash(ip[0], 0)[0] = ip;
+}
+
+/*
+ * Hash looks up the s(ymbol) argument
+ * in the string table, entering it if
+ * it is not found. If save is 0, then
+ * the argument string is already in
+ * a safe place. Otherwise, if hash is
+ * entering the symbol for the first time
+ * it will save the symbol in the string
+ * table using savestr.
+ */
+int *hash(s, save)
+ char *s;
+ int save;
+{
+ register int *h;
+ register i;
+ register char *cp;
+ int *sym;
+ struct ht *htp;
+ int sh;
+
+ /*
+ * The hash function is a modular hash of
+ * the sum of the characters with the sum
+ * doubled before each successive character
+ * is added.
+ */
+ cp = s;
+ if (cp == NIL)
+ cp = token; /* default symbol to be hashed */
+ i = 0;
+ while (*cp)
+ i = i*2 + *cp++;
+ sh = (i&077777) % HASHINC;
+ cp = s;
+ if (cp == NIL)
+ cp = token;
+ /*
+ * There are as many as MAXHASH active
+ * hash tables at any given point in time.
+ * The search starts with the first table
+ * and continues through the active tables
+ * as necessary.
+ */
+ for (htp = htab; htp < &htab[MAXHASH]; htp++) {
+ if (htp->ht_low == NIL) {
+ cp = calloc(2, HASHINC);
+ if (cp == -1) {
+ yerror("Ran out of memory (hash)");
+ pexit(DIED);
+ }
+ htp->ht_low = cp;
+ htp->ht_high = htp->ht_low + HASHINC;
+ cp = s;
+ if (cp == NIL)
+ cp = token;
+ }
+ h = htp->ht_low + sh;
+ /*
+ * quadratic rehash increment
+ * starts at 1 and incremented
+ * by two each rehash.
+ */
+ i = 1;
+ do {
+ if (*h == 0) {
+ if (htp->ht_used > (HASHINC * 3)/4)
+ break;
+ htp->ht_used++;
+ if (save != 0) {
+ *h = savestr(cp);
+ } else
+ *h = s;
+ return (h);
+ }
+ sym = *h;
+ if (sym < lastkey && sym >= yykey)
+ sym = *sym;
+ if (sym->pchar == *cp && strcmp(sym, cp) == 0)
+ return (h);
+ h =+ i;
+ i =+ 2;
+ if (h >= htp->ht_high)
+ h =- HASHINC;
+ } while (i < HASHINC);
+ }
+ yerror("Ran out of hash tables");
+ pexit(DIED);
+}
--- /dev/null
+/* 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"
+
+/*
+ * Label enters the definitions
+ * of the label declaration part
+ * into the namelist.
+ */
+label(r, l)
+ int *r, l;
+{
+#ifndef PI0
+ register *ll;
+ register struct nl *p, *lp;
+
+ lp = NIL;
+#else
+ send(REVLAB, r);
+#endif
+ line = l;
+#ifndef PI1
+ if (parts & (CPRT|TPRT|VPRT))
+ error("Label declarations must precede const, type and var declarations");
+ if (parts & LPRT)
+ error("All labels must be declared in one label part");
+ parts =| LPRT;
+#endif
+#ifndef PI0
+ for (ll = r; ll != NIL; ll = ll[2]) {
+ l = getlab();
+ p = enter(defnl(ll[1], LABEL, 0, l));
+ /*
+ * Get the label for the eventual target
+ */
+ p->value[1] = getlab();
+ p->chain = lp;
+ p->nl_flags =| (NFORWD|NMOD);
+ p->value[NL_GOLEV] = NOTYET;
+ lp = p;
+ /*
+ * This operator is between
+ * the bodies of two procedures
+ * and provides a target for
+ * gotos for this label via TRA.
+ */
+ putlab(l);
+ put2(O_GOTO | cbn<<9, p->value[1]);
+ }
+ gotos[cbn] = lp;
+#endif
+}
+
+#ifndef PI0
+/*
+ * Gotoop is called when
+ * we get a statement "goto label"
+ * and generates the needed tra.
+ */
+gotoop(s)
+ char *s;
+{
+ register struct nl *p;
+
+ gocnt++;
+ p = lookup(s);
+ if (p == NIL)
+ return (NIL);
+ put2(O_TRA, p->value[0]);
+ if (bn == cbn)
+ if (p->nl_flags & NFORWD) {
+ if (p->value[NL_GOLEV] == NOTYET) {
+ p->value[NL_GOLEV] = level;
+ p->value[NL_GOLINE] = line;
+ }
+ } else
+ if (p->value[NL_GOLEV] == DEAD) {
+ recovered();
+ error("Goto %s is into a structured statement", p->symbol);
+ }
+}
+
+/*
+ * Labeled is called when a label
+ * definition is encountered, and
+ * marks that it has been found and
+ * patches the associated GOTO generated
+ * by gotoop.
+ */
+labeled(s)
+ char *s;
+{
+ register struct nl *p;
+
+ p = lookup(s);
+ if (p == NIL)
+ return (NIL);
+ if (bn != cbn) {
+ error("Label %s not defined in correct block", s);
+ return;
+ }
+ if ((p->nl_flags & NFORWD) == 0) {
+ error("Label %s redefined", s);
+ return;
+ }
+ p->nl_flags =& ~NFORWD;
+ patch(p->value[1]);
+ if (p->value[NL_GOLEV] != NOTYET)
+ if (p->value[NL_GOLEV] < level) {
+ recovered();
+ error("Goto %s from line %d is into a structured statement", s, p->value[NL_GOLINE]);
+ }
+ p->value[NL_GOLEV] = level;
+}
+#endif