From 16494185d6b18dafab9e4fdbcf9cec0e8df4a183 Mon Sep 17 00:00:00 2001 From: Bill Joy Date: Wed, 9 May 1979 19:02:05 -0800 Subject: [PATCH] BSD 2 development Work on file src/pi1/proc.c Work on file src/pi1/put.c Work on file src/pi1/rec.c Work on file src/pi1/receive.c Work on file src/pi1/rval.c Work on file src/pi1/send.h Work on file src/pi1/stat.c Work on file src/pi1/string.c Work on file src/pi1/subr.c Work on file src/pi1/tree.c Work on file src/pi1/tree.h Work on file src/pi1/type.c Work on file src/pi1/var.c Work on file src/pi1/yyerror.c Work on file src/pi1/yymain.c Synthesized-from: 2bsd --- src/pi1/proc.c | 793 ++++++++++++++++++++++++++++++++++++++++++++++ src/pi1/put.c | 332 +++++++++++++++++++ src/pi1/rec.c | 241 ++++++++++++++ src/pi1/receive.c | 440 +++++++++++++++++++++++++ src/pi1/rval.c | 551 ++++++++++++++++++++++++++++++++ src/pi1/send.h | 29 ++ src/pi1/stat.c | 576 +++++++++++++++++++++++++++++++++ src/pi1/string.c | 158 +++++++++ src/pi1/subr.c | 217 +++++++++++++ src/pi1/tree.c | 299 +++++++++++++++++ src/pi1/tree.h | 82 +++++ src/pi1/type.c | 324 +++++++++++++++++++ src/pi1/var.c | 236 ++++++++++++++ src/pi1/yyerror.c | 17 + src/pi1/yymain.c | 84 +++++ 15 files changed, 4379 insertions(+) create mode 100644 src/pi1/proc.c create mode 100644 src/pi1/put.c create mode 100644 src/pi1/rec.c create mode 100644 src/pi1/receive.c create mode 100644 src/pi1/rval.c create mode 100644 src/pi1/send.h create mode 100644 src/pi1/stat.c create mode 100644 src/pi1/string.c create mode 100644 src/pi1/subr.c create mode 100644 src/pi1/tree.c create mode 100644 src/pi1/tree.h create mode 100644 src/pi1/type.c create mode 100644 src/pi1/var.c create mode 100644 src/pi1/yyerror.c create mode 100644 src/pi1/yymain.c diff --git a/src/pi1/proc.c b/src/pi1/proc.c new file mode 100644 index 0000000000..25065f4880 --- /dev/null +++ b/src/pi1/proc.c @@ -0,0 +1,793 @@ +/* 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" + +/* + * The following arrays are used to determine which classes may be + * read and written to/from text files. + * They are indexed by the return types from classify. + */ +#define rdops(x) rdxxxx[(x)-(TFIRST)] +#define wrops(x) wrxxxx[(x)-(TFIRST)] + +int rdxxxx[] { + 0, /* -7 file types */ + 0, /* -6 record types */ + 0, /* -5 array types */ + 0, /* -4 scalar types */ + 0, /* -3 pointer types */ + 0, /* -2 set types */ + 0, /* -1 string types */ + 0, /* 0 nil - i.e. no type */ + 0, /* 1 booleans */ + O_READC, /* 2 character */ + O_READ4, /* 3 integer */ + O_READ8 /* 4 real */ +}; + +int wrxxxx[] { + 0, /* -7 file types */ + 0, /* -6 record types */ + 0, /* -5 array types */ + 0, /* -4 scalar types */ + 0, /* -3 pointer types */ + 0, /* -2 set types */ + O_WRITG, /* -1 string types */ + 0, /* 0 nil - i.e. no type */ + O_WRITB, /* 1 booleans */ + O_WRITC, /* 2 character */ + O_WRIT4, /* 3 integer */ + O_WRIT8, /* 4 real */ +}; + +/* + * Proc handles procedure calls. + * Non-builtin procedures are "buck-passed" to func (with a flag + * indicating that they are actually procedures. + * builtin procedures are handled here. + */ +proc(r) + int *r; +{ + register struct nl *p; + register int *al, op; + struct nl *filetype, *ap; + int argc, *argv, c, two, oct, hex, *file; + int pu; + int *pua, *pui, *puz; + int i, j, k; + + /* + * Verify that the name is + * defined and is that of a + * procedure. + */ + p = lookup(r[2]); + if (p == NIL) { + rvlist(r[3]); + return; + } + if (p->class != PROC) { + error("Can't call %s, its %s not a procedure", p->symbol, classes[p->class]); + rvlist(r[3]); + return; + } + argv = r[3]; + + /* + * Call handles user defined + * procedures and functions. + */ + if (bn != 0) { + call(p, argv, PROC, bn); + return; + } + + /* + * Call to built-in procedure. + * Count the arguments. + */ + argc = 0; + for (al = argv; al != NIL; al = al[2]) + argc++; + + /* + * Switch on the operator + * associated with the built-in + * procedure in the namelist + */ + op = p->value[0] &~ NSTAND; + if (opt('s') && (p->value[0] & NSTAND)) { + standard(); + error("%s is a nonstandard procedure", p->symbol); + } + switch (op) { + + case O_NULL: + if (argc != 0) + error("null takes no arguments"); + return; + + case O_FLUSH: + if (argc == 0) { + put1(O_MESSAGE); + return; + } + if (argc != 1) { + error("flush takes at most one argument"); + return; + } + ap = rvalue(argv[1], NIL); + if (ap == NIL) + return; + if (ap->class != FILE) { + error("flush's argument must be a file, not %s", nameof(ap)); + return; + } + put1(op); + return; + + case O_MESSAGE: + case O_WRIT2: + case O_WRITLN: + /* + * Set up default file "output"'s type + */ + file = NIL; + filetype = nl+T1CHAR; + /* + * Determine the file implied + * for the write and generate + * code to make it the active file. + */ + if (op == O_MESSAGE) { + /* + * For message, all that matters + * is that the filetype is + * a character file. + * Thus "output" will suit us fine. + */ + put1(O_MESSAGE); + } else if (argv != NIL && (al = argv[1])[0] != T_WEXP) { + /* + * If there is a first argument which has + * no write widths, then it is potentially + * a file name. + */ + codeoff(); + ap = rvalue(argv[1], NIL); + codeon(); + if (ap == NIL) + argv = argv[2]; + if (ap != NIL && ap->class == FILE) { + /* + * Got "write(f, ...", make + * f the active file, and save + * it and its type for use in + * processing the rest of the + * arguments to write. + */ + file = argv[1]; + filetype = ap->type; + rvalue(argv[1], NIL); + put1(O_UNIT); + /* + * Skip over the first argument + */ + argv = argv[2]; + argc--; + } else + /* + * Set up for writing on + * standard output. + */ + put1(O_UNITOUT); + } else + put1(O_UNITOUT); + /* + * Loop and process each + * of the arguments. + */ + for (; argv != NIL; argv = argv[2]) { + al = argv[1]; + if (al == NIL) + continue; + /* + * Op will be used to + * accumulate width information, + * and two records the fact + * that we saw two write widths + */ + op = 0; + two = 0; + oct = 0; + hex = 0; + if (al[0] == T_WEXP) { + if (filetype != nl+T1CHAR) { + error("Write widths allowed only with text files"); + continue; + } + /* + * Handle width expressions. + * The basic game here is that width + * expressions get evaluated and left + * on the stack and their width's get + * packed into the high byte of the + * affected opcode (subop). + */ + if (al[3] == OCT) + oct++; + else if (al[3] == HEX) + hex++; + else if (al[3] != NIL) { + two++; + /* + * Arrange for the write + * opcode that takes two widths + */ + op =| O_WRIT82-O_WRIT8; + ap = rvalue(al[3], NIL); + if (ap == NIL) + continue; + if (isnta(ap, "i")) { + error("Second write width must be integer, not %s", nameof(ap)); + continue; + } + op =| even(width(ap)) << 11; + } + if (al[2] != NIL) { + ap = rvalue(al[2], NIL); + if (ap == NIL) + continue; + if (isnta(ap, "i")) { + error("First write width must be integer, not %s", nameof(ap)); + continue; + } + op =| even(width(ap)) << 8; + } + al = al[1]; + if (al == NIL) + continue; + } + if (filetype != nl+T1CHAR) { + if (oct || hex) { + error("Oct/hex allowed only on text files"); + continue; + } + if (op) { + error("Write widths allowed only on text files"); + continue; + } + /* + * Generalized write, i.e. + * to a non-textfile. + */ + rvalue(file, NIL); + put1(O_FNIL); + /* + * file^ := ... + */ + ap = rvalue(argv[1], NIL); + if (ap == NIL) + continue; + if (incompat(ap, filetype, argv[1])) { + cerror("Type mismatch in write to non-text file"); + continue; + } + convert(ap, filetype); + put2(O_AS, width(filetype)); + /* + * put(file) + */ + put1(O_PUT); + continue; + } + /* + * Write to a textfile + * + * Evaluate the expression + * to be written. + */ + ap = rvalue(al, NIL); + if (ap == NIL) + continue; + c = classify(ap); + if (two && c != TDOUBLE) { + if (isnta(ap, "i")) { + error("Only reals can have two write widths"); + continue; + } + convert(ap, nl+TDOUBLE); + c = TDOUBLE; + } + if (oct || hex) { + if (opt('s')) { + standard(); + error("Oct and hex are non-standard"); + } + switch (c) { + case TREC: + case TARY: + case TFILE: + case TSTR: + case TSET: + case TDOUBLE: + error("Can't write %ss with oct/hex", clnames[c]); + continue; + } + put1(op | (oct ? O_WROCT2 : O_WRHEX2) | (width(ap) >> 2)); + continue; + } + if (wrops(c) == NIL) { + error("Can't write %ss to a text file", clnames[c]); + continue; + } + if (c == TINT && width(ap) != 4) + op =| O_WRIT2; + else + op =| wrops(c); + if (c == TSTR) + put2(op, width(ap)); + else + put1(op); + } + /* + * Done with arguments. + * Handle writeln and + * insufficent number of args. + */ + switch (p->value[0] &~ NSTAND) { + case O_WRIT2: + if (argc == 0) + error("Write requires an argument"); + break; + case O_MESSAGE: + if (argc == 0) + error("Message requires an argument"); + case O_WRITLN: + if (filetype != nl+T1CHAR) + error("Can't 'writeln' a non text file"); + put1(O_WRITLN); + break; + } + return; + + case O_READ4: + case O_READLN: + /* + * Set up default + * file "input". + */ + file = NIL; + filetype = nl+T1CHAR; + /* + * Determine the file implied + * for the read and generate + * code to make it the active file. + */ + if (argv != NIL) { + codeoff(); + ap = rvalue(argv[1], NIL); + codeon(); + if (ap == NIL) + argv = argv[2]; + if (ap != NIL && ap->class == FILE) { + /* + * Got "read(f, ...", make + * f the active file, and save + * it and its type for use in + * processing the rest of the + * arguments to read. + */ + file = argv[1]; + filetype = ap->type; + rvalue(argv[1], NIL); + put1(O_UNIT); + argv = argv[2]; + argc--; + } else { + /* + * Default is read from + * standard input. + */ + put1(O_UNITINP); + input->nl_flags =| NUSED; + } + } else { + put1(O_UNITINP); + input->nl_flags =| NUSED; + } + /* + * Loop and process each + * of the arguments. + */ + for (; argv != NIL; argv = argv[2]) { + /* + * Get the address of the target + * on the stack. + */ + al = argv[1]; + if (al == NIL) + continue; + if (al[0] != T_VAR) { + error("Arguments to %s must be variables, not expressions", p->symbol); + continue; + } + ap = lvalue(al, MOD|ASGN|NOUSE); + if (ap == NIL) + continue; + if (filetype != nl+T1CHAR) { + /* + * Generalized read, i.e. + * from a non-textfile. + */ + if (incompat(filetype, ap, NIL)) { + error("Type mismatch in read from non-text file"); + continue; + } + /* + * var := file ^; + */ + if (file != NIL) + rvalue(file, NIL); + else /* Magic */ + put2(O_RV2, input->value[0]); + put1(O_FNIL); + put2(O_IND, width(filetype)); + convert(filetype, ap); + if (isa(ap, "bsci")) + rangechk(ap, ap); + put2(O_AS, width(ap)); + /* + * get(file); + */ + put1(O_GET); + continue; + } + c = classify(ap); + op = rdops(c); + if (op == NIL) { + error("Can't read %ss from a text file", clnames[c]); + continue; + } + put1(op); + /* + * Data read is on the stack. + * Assign it. + */ + if (op != O_READ8) + rangechk(ap, op == O_READC ? ap : nl+T4INT); + gen(O_AS2, O_AS2, width(ap), + op == O_READ8 ? 8 : op == O_READ4 ? 4 : 2); + } + /* + * Done with arguments. + * Handle readln and + * insufficient number of args. + */ + if (p->value[0] == O_READLN) { + if (filetype != nl+T1CHAR) + error("Can't 'readln' a non text file"); + put1(O_READLN); + } + else if (argc == 0) + error("read requires an argument"); + return; + + case O_GET: + case O_PUT: + if (argc != 1) { + error("%s expects one argument", p->symbol); + return; + } + ap = rvalue(argv[1], NIL); + if (ap == NIL) + return; + if (ap->class != FILE) { + error("Argument to %s must be a file, not %s", p->symbol, nameof(ap)); + return; + } + put1(O_UNIT); + put1(op); + return; + + case O_RESET: + case O_REWRITE: + if (argc == 0 || argc > 2) { + error("%s expects one or two arguments", p->symbol); + return; + } + if (opt('s') && argc == 2) { + standard(); + error("Two argument forms of reset and rewrite are non-standard"); + } + ap = lvalue(argv[1], MOD|NOUSE); + if (ap == NIL) + return; + if (ap->class != FILE) { + error("First argument to %s must be a file, not %s", p->symbol, nameof(ap)); + return; + } + if (argc == 2) { + /* + * Optional second argument + * is a string name of a + * UNIX (R) file to be associated. + */ + al = argv[2]; + al = rvalue(al[1], NIL); + if (al == NIL) + return; + if (classify(al) != TSTR) { + error("Second argument to %s must be a string, not %s", p->symbol, nameof(al)); + return; + } + c = width(al); + } else + c = 0; + if (c > 127) { + error("File name too long"); + return; + } + put2(op | c << 8, text(ap) ? 0: width(ap->type)); + return; + + case O_NEW: + case O_DISPOSE: + if (argc == 0) { + error("%s expects at least one argument", p->symbol); + return; + } + ap = lvalue(argv[1], MOD|NOUSE); + if (ap == NIL) + return; + if (ap->class != PTR) { + error("(First) argument to %s must be a pointer, not %s", p->symbol, nameof(ap)); + return; + } + ap = ap->type; + if (ap == NIL) + return; + argv = argv[2]; + if (argv != NIL) { + if (ap->class != RECORD) { + error("Record required when specifying variant tags"); + return; + } + for (; argv != NIL; argv = argv[2]) { + if (ap->value[NL_VARNT] == NIL) { + error("Too many tag fields"); + return; + } + if (!isconst(argv[1])) { + error("Second and successive arguments to %s must be constants", p->symbol); + return; + } + gconst(argv[1]); + if (con.ctype == NIL) + return; + if (incompat(con.ctype, ap->value[NL_TAG]->type)) { + cerror("Specified tag constant type clashed with variant case selector type"); + return; + } + for (ap = ap->value[NL_VARNT]; ap != NIL; ap = ap->chain) + if (ap->range[0] == con.crval) + break; + if (ap == NIL) { + error("No variant case label value equals specified constant value"); + return; + } + ap = ap->value[NL_VTOREC]; + } + } + put2(op, width(ap)); + return; + + case O_DATE: + case O_TIME: + if (argc != 1) { + error("%s expects one argument", p->symbol); + return; + } + ap = lvalue(argv[1], MOD|NOUSE); + if (ap == NIL) + return; + if (classify(ap) != TSTR || width(ap) != 10) { + error("Argument to %s must be a alfa, not %s", p->symbol, nameof(ap)); + return; + } + put1(op); + return; + + case O_HALT: + if (argc != 0) { + error("halt takes no arguments"); + return; + } + put1(op); + noreach = 1; + return; + + case O_ARGV: + if (argc != 2) { + error("argv takes two arguments"); + return; + } + ap = rvalue(argv[1], NIL); + if (ap == NIL) + return; + if (isnta(ap, "i")) { + error("argv's first argument must be an integer, not %s", nameof(ap)); + return; + } + convert(ap, nl+T2INT); + al = argv[2]; + ap = lvalue(al[1], MOD|NOUSE); + if (ap == NIL) + return; + if (classify(ap) != TSTR) { + error("argv's second argument must be a string, not %s", nameof(ap)); + return; + } + put2(op, width(ap)); + return; + + case O_STLIM: + if (argc != 1) { + error("stlimit requires one argument"); + return; + } + ap = rvalue(argv[1], NIL); + if (ap == NIL) + return; + if (isnta(ap, "i")) { + error("stlimit's argument must be an integer, not %s", nameof(ap)); + return; + } + if (width(ap) != 4) + put1(O_STOI); + put1(op); + return; + + case O_REMOVE: + if (argc != 1) { + error("remove expects one argument"); + return; + } + ap = rvalue(argv[1], NIL); + if (ap == NIL) + return; + if (classify(ap) != TSTR) { + error("remove's argument must be a string, not %s", nameof(ap)); + return; + } + put2(op, width(ap)); + return; + + case O_LLIMIT: + if (argc != 2) { + error("linelimit expects two arguments"); + return; + } + ap = lvalue(argv[1], NOMOD|NOUSE); + if (ap == NIL) + return; + if (!text(ap)) { + error("linelimit's first argument must be a text file, not %s", nameof(ap)); + return; + } + al = argv[2]; + ap = rvalue(al[1], NIL); + if (ap == NIL) + return; + if (isnta(ap, "i")) { + error("linelimit's second argument must be an integer, not %s", nameof(ap)); + return; + } + convert(ap, nl+T2INT); + put1(op); + return; + case O_PAGE: + if (argc != 1) { + error("page expects one argument"); + return; + } + ap = rvalue(argv[1], NIL); + if (ap == NIL) + return; + if (!text(ap)) { + error("Argument to page must be a text file, not %s", nameof(ap)); + return; + } + put1(O_UNIT); + put1(op); + return; + + case O_PACK: + if (argc != 3) { + error("pack expects three arguments"); + return; + } + pu = "pack(a,i,z)"; + pua = (al = argv)[1]; + pui = (al = al[2])[1]; + puz = (al = al[2])[1]; + goto packunp; + case O_UNPACK: + if (argc != 3) { + error("unpack expects three arguments"); + return; + } + pu = "unpack(z,a,i)"; + puz = (al = argv)[1]; + pua = (al = al[2])[1]; + pui = (al = al[2])[1]; +packunp: + ap = rvalue(pui, NIL); + if (ap == NIL) + return; + if (width(ap) == 4) + put1(O_ITOS); + ap = lvalue(pua, op == O_PACK ? NOMOD : MOD|NOUSE); + if (ap == NIL) + return; + if (ap->class != ARRAY) { + error("%s requires a to be an unpacked array, not %s", pu, nameof(ap)); + return; + } + al = lvalue(puz, op == O_UNPACK ? NOMOD : MOD|NOUSE); + if (al->class != ARRAY) { + error("%s requires z to be a packed array, not %s", pu, nameof(ap)); + return; + } + if (al->type == NIL || ap->type == NIL) + return; + if (al->type != ap->type) { + error("%s requires a and z to be arrays of the same type", pu, nameof(ap)); + return; + } + k = width(al); + ap = ap->chain; + al = al->chain; + if (ap->chain != NIL || al->chain != NIL) { + error("%s requires a and z to be single dimension arrays", pu); + return; + } + if (ap == NIL || al == NIL) + return; + /* + * al is the range for z i.e. u..v + * ap is the range for a i.e. m..n + * i will be n-m+1 + * j will be v-u+1 + */ + i = ap->range[1] - ap->range[0] + 1; + j = al->range[1] - al->range[0] + 1; + if (i < j) { + error("%s cannot have more elements in a (%d) than in z (%d)", pu, j, i); + return; + } + /* + * get n-m-(v-u) and m for the interpreter + */ + i =- j; + j = ap->range[0]; + put(5, op, width(ap), j, i, k); + return; + case 0: + error("%s is an unimplemented 6400 extension", p->symbol); + return; + + default: + panic("proc case"); + } +} diff --git a/src/pi1/put.c b/src/pi1/put.c new file mode 100644 index 0000000000..0d2be05137 --- /dev/null +++ b/src/pi1/put.c @@ -0,0 +1,332 @@ +/* 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 "opcode.h" +#include "0.h" + +int *obufp { obuf }; + +/* + * If DEBUG is defined, include the table + * of the printing opcode names. + */ +#ifdef DEBUG +char *otext[] { +#include "OPnames.h" +}; +#endif + +/* + * Put is responsible for the interpreter equivalent of code + * generation. Since the interpreter is specifically designed + * for Pascal, little work is required here. + */ +put(a) +{ + register int *p, i; + register char *cp; + int n, subop, suboppr, op, oldlc, w; + char *string; + static int casewrd; + + /* + * It would be nice to do some more + * optimizations here. The work + * done to collapse offsets in lval + * should be done here, the IFEQ etc + * relational operators could be used + * etc. + */ + oldlc = lc; + if (cgenflg) + /* + * code disabled - do nothing + */ + return (oldlc); + p = &a; + n = *p++; + suboppr = subop = (*p>>8) & 0377; + op = *p & 0377; + string = 0; +#ifdef DEBUG + if ((cp = otext[op]) == NIL) { + printf("op= %o\n", op); + panic("put"); + } +#endif + switch (op) { +/***** + case O_LINO: + if (line == codeline) + return (oldlc); + codeline = line; +*****/ + case O_PUSH: + case O_POP: + if (p[1] == 0) + return (oldlc); + case O_NEW: + case O_DISPOSE: + case O_AS: + case O_IND: + case O_OFF: + case O_INX2: + case O_INX4: + case O_CARD: + case O_ADDT: + case O_SUBT: + case O_MULT: + case O_IN: + case O_CASE1OP: + case O_CASE2OP: + case O_CASE4OP: + case O_PACK: + case O_UNPACK: + case O_RANG2: + case O_RSNG2: + case O_RANG42: + case O_RSNG42: + if (p[1] == 0) + break; + case O_CON2: + if (p[1] < 128 && p[1] >= -128) { + suboppr = subop = p[1]; + p++; + n--; + if (op == O_CON2) + op = O_CON1; + } + break; + default: + if (op >= O_REL2 && op <= O_REL84) { + if ((i = (subop >> 1) * 5 ) >= 30) + i =- 30; + else + i =+ 2; +#ifdef DEBUG + string = &"IFEQ\0IFNE\0IFLT\0IFGT\0IFLE\0IFGE"[i]; +#endif + suboppr = 0; + } + break; + case O_IF: + case O_TRA: +/***** + codeline = 0; +*****/ + case O_CALL: + case O_FOR1U: + case O_FOR2U: + case O_FOR4U: + case O_FOR1D: + case O_FOR2D: + case O_FOR4D: + p[1] =- lc + 2; + break; + case O_WRIT82: +#ifdef DEBUG + string = &"22\024\042\044"[subop*3]; +#endif + suboppr = 0; + break; + case O_CONG: + i = p[1]; + cp = p[2]; +#ifdef DEBUG + if (opt('c')) + printf("%5d\tCONG:%d\t%s\n", lc, i, cp); +#endif + if (i <= 127) + word(O_CON | i << 8); + else { + word(O_CON); + word(i); + } + while (i > 0) { + w = *cp ? *cp++ : ' '; + w =| (*cp ? *cp++ : ' ') << 8; + word(w); + i =- 2; + } + return (oldlc); + case O_CONC: +#ifdef DEBUG + (string = "'x'")[1] = p[1]; +#endif + suboppr = 0; + op = O_CON1; + subop = p[1]; + goto around; + case O_CON1: + suboppr = subop = p[1]; +around: + n--; + break; + case O_CASEBEG: + casewrd = 0; + return (oldlc); + case O_CASEEND: + if (lc & 1) { + lc--; + word(casewrd); + } + return (oldlc); + case O_CASE1: +#ifdef DEBUG + if (opt('c')) + printf("%5d\tCASE1\t%d\n", lc, p[2]); +#endif + lc++; + if (lc & 1) + casewrd = p[2]; + else { + lc =- 2; + word(casewrd | p[2] << 8); + } + return (oldlc); + case O_CASE2: +#ifdef DEBUG + if (opt('c')) + printf("%5d\tCASE2\t%d\n", lc, p[2]); +#endif + word(p[2]); + return (oldlc); + case O_CASE4: +#ifdef DEBUG + if (opt('c')) + printf("%5d\tCASE4\t%d %d\n", lc, p[1], p[2]); +#endif + word(p[1]); + word(p[2]); + return (oldlc); + } +#ifdef DEBUG + if (opt('c')) { + printf("%5d\t%s", lc, cp); + if (suboppr) + printf(":%d", suboppr); + if (string) + printf("\t%s",string); + if (n > 1) + putchar('\t'); + for (i=1; i 0; i =- 2) + word(0); +} + +/* + * Patch repairs the branch + * at location loc to come + * to the current location. + */ +patch(loc) +{ + + patchfil(loc, lc-loc-2); +} + +/* + * Patchfil makes loc+2 have value + * as its contents. + */ +patchfil(loc, value) + char *loc; + int value; +{ + register i; + + if (cgenflg < 0) + return; + if (loc > lc) + panic("patchfil"); +#ifdef DEBUG + if (opt('c')) + printf("\tpatch %u %d\n", loc, value); +#endif + i = (loc + 2 - (lc & ~0777))/2; + if (i >= 0 && i < 512) + obuf[i] = value; + else { + seek(ofil, loc+2, 0); + write(ofil, &value, 2); + seek(ofil, 0, 2); + } +} + +/* + * Put the word o into the code + */ +word(o) + int o; +{ + + *obufp = o; + obufp++; + lc =+ 2; + if (obufp >= obuf+256) + pflush(); +} + +char *obj; +/* + * Flush the code buffer + */ +pflush() +{ + register i; + + i = (obufp - obuf) * 2; + if (i != 0 && write(ofil, obuf, i) != i) + perror(obj), pexit(DIED); + obufp = obuf; +} + +/* + * Getlab - returns the location counter. + * included here for the eventual code generator. + */ +getlab() +{ + + return (lc); +} + +/* + * Putlab - lay down a label. + */ +putlab(l) + int l; +{ + + return (l); +} diff --git a/src/pi1/rec.c b/src/pi1/rec.c new file mode 100644 index 0000000000..49d0b08570 --- /dev/null +++ b/src/pi1/rec.c @@ -0,0 +1,241 @@ +/* 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" + +/* + * Build a record namelist entry. + * Some of the processing here is somewhat involved. + * The basic structure we are building is as follows. + * + * Each record has a main RECORD entry, with an attached + * chain of fields as ->chain; these include all the fields in all + * the variants of this record. + * + * Attached to NL_VARNT is a chain of VARNT structures + * describing each of the variants. These are further linked + * through ->chain. Each VARNT has, in ->range[0] the value of + * the associated constant, and each points at a RECORD describing + * the subrecord through NL_VTOREC. These pointers are not unique, + * more than one VARNT may reference the same RECORD. + * + * The involved processing here is in computing the NL_OFFS entry + * by maxing over the variants. This works as follows. + * + * Each RECORD has two size counters. NL_OFFS is the maximum size + * so far of any variant of this record; NL_FLDSZ gives the size + * of just the FIELDs to this point as a base for further variants. + * + * As we process each variant record, we start its size with the + * NL_FLDSZ we have so far. After processing it, if its NL_OFFS + * is the largest so far, we update the NL_OFFS of this subrecord. + * This will eventually propagate back and update the NL_OFFS of the + * entire record. + */ + +/* + * P0 points to the outermost RECORD for name searches. + */ +struct nl *P0; + +tyrec(r, off) + int *r, off; +{ + + tyrec1(r, off, 1); +} + +/* + * Define a record namelist entry. + * R is the tree for the record to be built. + * Off is the offset for the first item in this (sub)record. + */ +tyrec1(r, off, first) + register int *r; + int off; + char first; +{ + register struct nl *p, *P0was; + + p = defnl(0, RECORD, 0, 0); + P0was = P0; + if (first) + P0 = p; +#ifndef PI0 + p->value[NL_FLDSZ] = p->value[NL_OFFS] = off; +#endif + if (r != NIL) { + fields(p, r[2]); + variants(p, r[3]); + } + P0 = P0was; + return (p); +} + +/* + * Define the fixed part fields for p. + */ +fields(p, r) + struct nl *p; + int *r; +{ + register int *fp, *tp, *ip; + struct nl *jp; + + for (fp = r; fp != NIL; fp = fp[2]) { + tp = fp[1]; + if (tp == NIL) + continue; + jp = gtype(tp[3]); + line = tp[1]; + for (ip = tp[2]; ip != NIL; ip = ip[2]) + deffld(p, ip[1], jp); + } +} + +/* + * Define the variants for RECORD p. + */ +variants(p, r) + struct nl *p; + register int *r; +{ + register int *vc, *v; + int *vr; + struct nl *ct; + + if (r == NIL) + return; + ct = gtype(r[3]); + line = r[1]; + /* + * Want it even if r[2] is NIL so + * we check its type in "new" and "dispose" + * calls -- link it to NL_TAG. + */ + p->value[NL_TAG] = deffld(p, r[2], ct); + for (vc = r[4]; vc != NIL; vc = vc[2]) { + v = vc[1]; + if (v == NIL) + continue; + vr = tyrec1(v[3], p->value[NL_FLDSZ], 0); +#ifndef PI0 + if (vr->value[NL_OFFS] > p->value[NL_OFFS]) + p->value[NL_OFFS] = vr->value[NL_OFFS]; +#endif + line = v[1]; + for (v = v[2]; v != NIL; v = v[2]) + defvnt(p, v[1], vr, ct); + } +} + +/* + * Define a field in subrecord p of record P0 + * with name s and type t. + */ +deffld(p, s, t) + struct nl *p; + register char *s; + register struct nl *t; +{ + register struct nl *fp; + + if (reclook(P0, s) != NIL) { +#ifndef PI1 + error("%s is a duplicate field name in this record", s); +#endif + s = NIL; + } +#ifndef PI0 + fp = enter(defnl(s, FIELD, t, p->value[NL_OFFS])); +#else + fp = enter(defnl(s, FIELD, t, 0)); +#endif + if (s != NIL) { + fp->chain = P0->chain; + P0->chain = fp; +#ifndef PI0 + p->value[NL_FLDSZ] = p->value[NL_OFFS] =+ even(width(t)); +#endif + if (t != NIL) { + P0->nl_flags =| t->nl_flags & NFILES; + p->nl_flags =| t->nl_flags & NFILES; + } + } + return (fp); +} + +/* + * Define a variant from the constant tree of t + * in subrecord p of record P0 where the casetype + * is ct and the variant record to be associated is vr. + */ +defvnt(p, t, vr, ct) + struct nl *p, *vr; + int *t; + register struct nl *ct; +{ + register struct nl *av; + + gconst(t); + if (ct != NIL && incompat(con.ctype, ct)) { +#ifndef PI1 + cerror("Variant label type incompatible with selector type"); +#endif + ct = NIL; + } + av = defnl(0, VARNT, ct, 0); +#ifndef PI1 + if (ct != NIL) + uniqv(p); +#endif + av->chain = p->value[NL_VARNT]; + p->value[NL_VARNT] = av; + av->value[NL_VTOREC] = vr; + av->range[0] = con.crval; + return (av); +} + +#ifndef PI1 +/* + * Check that the constant label value + * is unique among the labels in this variant. + */ +uniqv(p) + struct nl *p; +{ + register struct nl *vt; + + for (vt = p->value[NL_VARNT]; vt != NIL; vt = vt->chain) + if (vt->range[0] == con.crval) { + error("Duplicate variant case label in record"); + return; + } +} +#endif + +/* + * See if the field name s is defined + * in the record p, returning a pointer + * to it namelist entry if it is. + */ +reclook(p, s) + register struct nl *p; + char *s; +{ + + if (p == NIL || s == NIL) + return (NIL); + for (p = p->chain; p != NIL; p = p->chain) + if (p->symbol == s) + return (p); + return (NIL); +} diff --git a/src/pi1/receive.c b/src/pi1/receive.c new file mode 100644 index 0000000000..1e8a8b9f18 --- /dev/null +++ b/src/pi1/receive.c @@ -0,0 +1,440 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#include "0.h" +#include "send.h" +#include "tree.h" +/* + * Pi - Pascal interpreter code translator + * + * Bill Joy UCB February 6, 1978 + */ + +int fp2[DSPLYSZ]; +int pin[259]; /* Unit 0 */ +int ackd, acker; + +#ifdef DEBUG +extern char *trnames[]; +#endif +extern int *spacep; +extern char printed, hadsome, *lastname, *obj; + +#ifdef DEBUG +char *rnames[] { + "", + "RINIT", + "RENQ", + "RTREE", + "RTRFREE", + "RTRCHK", + "REVENIT", + "RSTRING", + "REVLAB", + "REVCNST", + "REVTBEG", + "REVTYPE", + "REVTEND", + "REVVBEG", + "REVVAR", + "REVVEND", + "REVFHDR", + "REVFFWD", + "REVFBDY", + "REVFEND", + "ROPUSH", + "ROPOP", + "ROSET", + "RKILL", + "RFINISH", +}; +#endif + +#define getaw() getw(pin) +#define getac() getc(pin) +#define sgetaw() sreloc(getaw()) +#define tgetaw() treloc(getaw()) + +receive() +{ + register int i, *ip; + register char *cp; +#define TREENMAX 6 /* From tree.c */ + int loctree[TREENMAX * 2], locstring[514]; + int ch, j; + + for (;;) { + i = getac(); +#ifdef DEBUG + if (i > 0 && i <= RLAST) + dprintf("%s\t", rnames[i]); + else if (i == -1) + dprintf("EOF\t"); + else + dprintf("OOPS!\t"); +#endif + holdderr = 1; + switch (i) { + + case RINIT: + lastname = sreloc(getaw()); + obj = sreloc(getaw()); + ackd = getac(); + for (i = 0; i < 26; i++) + opts[i] = getac(); + efil = getac(); + errfile = sreloc(getaw()); + ofil = getac(); + magic(); +#ifdef DEBUG + dprintf("RINIT\n\t"); + dprintf("lastname \"%s\"\n\t", lastname); + dprintf("ackd %d\n\t", ackd); + dprintf("options: "); + for (i = 0; i < 26; i++) + if (opts[i]) + if (i == 1) + dprintf("b%d ", opts[1]); + else + dprintf("%c ", i + 'a'); + dprintf("\n\tefil %d\n", efil); + dprintf("\terrfile \"%s\"\n", errfile); + dprintf("\tofil %d\n", ofil); +#endif + break; + + case RENQ: +#ifdef DEBUG + dprintf("\tACK\n"); +#endif + ack(); + break; + + case RTREE: +#ifdef DEBUG + dprintf("%d ", toffset(spacep)); +#endif + i = getac(); + if (i < 0 || i > T_LAST) { +#ifdef DEBUG + dprintf("\tBAD: %d\n", i); +#endif + panic("recv RTREE"); + exit(1); + } + cp = trdesc[i]; +#ifdef DEBUG + dprintf("\t%s:", trnames[i]); +#endif + ip = loctree; + *ip++ = i; + j = 1; + while (*cp) { + j++; + switch (*cp++) { + + case 's': + cp = locstring; + i = 512; +#ifdef DEBUG + dprintf(" \""); +#endif + while ((ch = getac()) && ch != -1) { + if (--i == 0) + panic("RTREE case s"); + *cp++ = ch; +#ifdef DEBUG + dprintf("%c", ch); +#endif + } +#ifdef DEBUG + dprintf("\"\n"); +#endif + *cp++ = 0; + copystr(locstring); + goto out; + + case 'd': + *ip++ = getac(); +#ifdef DEBUG + dprintf(" d%d", ip[-1]); +#endif + continue; + + case 'n': + *ip++ = getaw(); +#ifdef DEBUG + dprintf(" n%d", ip[-1]); +#endif + continue; + + case '"': + *ip++ = sreloc(getaw()); +#ifdef DEBUG + if (ip[-1] == NIL) + dprintf(" NIL\""); + else + dprintf(" \"%s\"", ip[-1]); +#endif + continue; + + case 'p': + *ip++ = treloc(getaw()); +#ifdef DEBUG + dptree(ip[-1]); +#endif + continue; + } + } +#ifdef DEBUG + dprintf("\n"); +#endif + treev(j, loctree); +out: + break; + + case RTRCHK: + i = getaw(); +#ifdef DEBUG + dprintf(" %d\n", i); + if (i != toffset(spacep)) + dprintf("trchk %d, have %d\n", i, toffset(spacep)); +#endif + break; + + case RTRFREE: +#ifdef DEBUG + dprintf("\t%d\n", toffset(spacep)); +#endif + trfree(); + break; + + case REVTBEG: +#ifdef DEBUG + dprintf("\n"); +#endif + typebeg(); + break; + + case REVTEND: +#ifdef DEBUG + dprintf("\n"); +#endif + typeend(); + break; + + case REVVBEG: +#ifdef DEBUG + dprintf("\n"); +#endif + varbeg(); + break; + + case REVVEND: +#ifdef DEBUG + dprintf("\n"); +#endif + varend(); + break; + + case REVENIT: +#ifdef DEBUG + dprintf("\n"); +#endif + evenit(); + break; + + case RSTRING: +#ifdef DEBUG + dprintf(" \""); +#endif + cp = locstring; + i = 512; + while ((ch = getac()) && ch != -1) { + if (--i == 0) + panic("RSTRING length"); + *cp++ = ch; +#ifdef DEBUG + dprintf("%c", ch); +#endif + } +#ifdef DEBUG + dprintf("\"\n"); +#endif + *cp++ = 0; + savestr(locstring); + break; + + case REVLAB: + loctree[0] = treloc(getaw()); +#ifdef DEBUG + dptree(loctree[0]); + dprintf("\n"); +#endif + label(loctree[0]); + break; + + case REVCNST: + loctree[0] = getaw(); + loctree[1] = sreloc(getaw()); + loctree[2] = treloc(getaw()); +#ifdef DEBUG + dprintf(" %d", loctree[0]); + dprintf(" \"%s\"", loctree[1]); + dptree(loctree[2]); + dprintf("\n"); +#endif + const(loctree[0], loctree[1], loctree[2]); + break; + + case REVTYPE: + loctree[0] = getaw(); + loctree[1] = sreloc(getaw()); + loctree[2] = treloc(getaw()); +#ifdef DEBUG + dprintf(" %d", loctree[0]); + dprintf(" \"%s\"", loctree[1]); + dptree(loctree[2]); + dprintf("\n"); +#endif + type(loctree[0], loctree[1], loctree[2]); + break; + + case REVVAR: + loctree[0] = getaw(); + loctree[1] = treloc(getaw()); + loctree[2] = treloc(getaw()); +#ifdef DEBUG + dprintf(" %d", loctree[0]); + dptree(loctree[1]); + dptree(loctree[2]); + dprintf("\n"); +#endif + var(loctree[0], loctree[1], loctree[2]); + break; + + case REVFHDR: + loctree[0] = treloc(getaw()); +#ifdef DEBUG + dptree(loctree[0]); + dprintf("\n"); +#endif + fp2[cbn] = funchdr(loctree[0]); + break; + + case REVFBDY: +#ifdef DEBUG + dprintf("\n"); +#endif + funcbody(fp2[cbn]); + break; + + case REVFEND: + holdderr = 0; + loctree[0] = treloc(getaw()); + loctree[1] = getaw(); + loctree[2] = getaw(); + lastname = sreloc(getaw()); + filename = sreloc(getaw()); + printed = getac(); + hadsome = getac(); +#ifdef DEBUG + dptree(loctree[0]); + dprintf(" %d", loctree[1]); + dprintf(" %d", loctree[2]); + dprintf(" lastname=%s", lastname); + dprintf(" filename=%s", filename); + dprintf(" printed=%d", printed); + dprintf(" hadsome=%d", hadsome); + dprintf("\n"); +#endif + funcend(fp2[cbn-1], loctree[0], loctree[1], loctree[2]); + break; + + case ROPUSH: + i = getaw(); + opush(i); +#ifdef DEBUG + dprintf(" %c\n", i); +#endif + break; + + case ROPOP: + i = getaw(); + opop(i); +#ifdef DEBUG + dprintf(" %c\n", i); +#endif + break; + + case ROSET: + ch = getac(); + i = getaw(); +#ifdef DEBUG + dprintf(" %c=", ch); + dprintf("%d\n", i); +#endif + opt(ch) = i; + break; + + case RKILL: +#ifdef DEBUG + dprintf("I should be dead!\n"); +#endif + panic("RKILL"); + break; + + case RFINISH: +#ifdef DEBUG + dprintf("\n"); +#endif + magic2(); + write(ackd, &eflg, 2); + break; + + case -1: + ack(); +#ifdef DEBUG + dprintf("\nEXIT\n"); +#endif + exit(0); + + default: +#ifdef DEBUG + dprintf("CODE=%d\n", i); +#endif + panic("rcv CODE"); + } + } +} + +ack() +{ + extern Fp; + int i[3]; + + i[0] = lastname; + i[1] = Fp; + i[2] = (hadsome << 8) | printed; + write(ackd, i, 6); +} + +#ifdef DEBUG +dprintf(a1, a2, a3, a4, a5) +{ + if (opt('d')) + printf(a1, a2, a3, a4, a5); +} + +dptree(j) + int j; +{ + register int i; + + i = toffset(j); + if (i >= ITREE) + dprintf(" p%d", i); + else if (i == 0) + dprintf(" NIL"); + else + dprintf(" \"%s\"", j); +} +#endif diff --git a/src/pi1/rval.c b/src/pi1/rval.c new file mode 100644 index 0000000000..b12b149947 --- /dev/null +++ b/src/pi1/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 + put3(O_CON4, f); +#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/pi1/send.h b/src/pi1/send.h new file mode 100644 index 0000000000..28663ca45d --- /dev/null +++ b/src/pi1/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/pi1/stat.c b/src/pi1/stat.c new file mode 100644 index 0000000000..15213b62fa --- /dev/null +++ b/src/pi1/stat.c @@ -0,0 +1,576 @@ +/* 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" + +int cntstat; +int cnts 2; +#include "opcode.h" + +/* + * Statement list + */ +statlist(r) + int *r; +{ + register *sl; + + for (sl=r; sl != NIL; sl=sl[2]) + statement(sl[1]); +} + +/* + * Statement + */ +statement(r) + int *r; +{ + register *s; + register struct nl *snlp; + + s = r; + snlp = nlp; +top: + if (cntstat) { + cntstat = 0; + putcnt(); + } + if (s == NIL) + return; + line = s[1]; + if (s[0] == T_LABEL) { + labeled(s[2]); + s = s[3]; + noreach = 0; + cntstat = 1; + goto top; + } + if (noreach) { + noreach = 0; + warning(); + error("Unreachable statement"); + } + switch (s[0]) { + case T_PCALL: + putline(); + proc(s); + break; + case T_ASGN: + putline(); + asgnop(s); + break; + case T_GOTO: + putline(); + gotoop(s[2]); + noreach = 1; + cntstat = 1; + break; + default: + level++; + switch (s[0]) { + default: + panic("stat"); + case T_IF: + case T_IFEL: + ifop(s); + break; + case T_WHILE: + whilop(s); + noreach = 0; + break; + case T_REPEAT: + repop(s); + break; + case T_FORU: + case T_FORD: + forop(s); + noreach = 0; + break; + case T_BLOCK: + statlist(s[2]); + break; + case T_CASE: + putline(); + caseop(s); + break; + case T_WITH: + withop(s); + break; + case T_ASRT: + putline(); + asrtop(s); + break; + } + --level; + if (gotos[cbn]) + ungoto(); + break; + } + /* + * Free the temporary name list entries defined in + * expressions, e.g. STRs, and WITHPTRs from withs. + */ + nlfree(snlp); +} + +ungoto() +{ + register struct nl *p; + + for (p = gotos[cbn]; p != NIL; p = p->chain) + if ((p->nl_flags & NFORWD) != 0) { + if (p->value[NL_GOLEV] != NOTYET) + if (p->value[NL_GOLEV] > level) + p->value[NL_GOLEV] = level; + } else + if (p->value[NL_GOLEV] != DEAD) + if (p->value[NL_GOLEV] > level) + p->value[NL_GOLEV] = DEAD; +} + +putcnt() +{ + + if (monflg == 0) + return; + cnts++; + put2(O_COUNT, cnts); +} + +putline() +{ + + if (opt('p') != 0) + put2(O_LINO, line); +} + +/* + * With varlist do stat + * + * With statement requires an extra word + * in automatic storage for each level of withing. + * These indirect pointers are initialized here, and + * the scoping effect of the with statement occurs + * because lookup examines the field names of the records + * associated with the WITHPTRs on the withlist. + */ +withop(s) + int *s; +{ + register *p; + register struct nl *r; + int i; + int *swl; + long soffset; + + putline(); + swl = withlist; + soffset = sizes[cbn].om_off; + for (p = s[2]; p != NIL; p = p[2]) { + sizes[cbn].om_off =- 2; + put2(O_LV | cbn <<9, i = sizes[cbn].om_off); + r = lvalue(p[1], MOD); + if (r == NIL) + continue; + if (r->class != RECORD) { + error("Variable in with statement refers to %s, not to a record", nameof(r)); + continue; + } + r = defnl(0, WITHPTR, r, i); + r->nl_next = withlist; + withlist = r; + put1(O_AS2); + } + if (sizes[cbn].om_off < sizes[cbn].om_max) + sizes[cbn].om_max = sizes[cbn].om_off; + statement(s[3]); + sizes[cbn].om_off = soffset; + withlist = swl; +} + +extern flagwas; +/* + * var := expr + */ +asgnop(r) + int *r; +{ + register struct nl *p; + register *av; + + if (r == NIL) + return (NIL); + /* + * Asgnop's only function is + * to handle function variable + * assignments. All other assignment + * stuff is handled by asgnop1. + */ + av = r[2]; + if (av != NIL && av[0] == T_VAR && av[3] == NIL) { + p = lookup1(av[2]); + if (p != NIL) + p->nl_flags = flagwas; + if (p != NIL && p->class == FVAR) { + /* + * Give asgnop1 the func + * which is the chain of + * the FVAR. + */ + p->nl_flags =| NUSED|NMOD; + p = p->chain; + if (p == NIL) { + rvalue(r[3], NIL); + return; + } + put2(O_LV | bn << 9, p->value[NL_OFFS]); + if (isa(p->type, "i") && width(p->type) == 1) + asgnop1(r, nl+T2INT); + else + asgnop1(r, p->type); + return; + } + } + asgnop1(r, NIL); +} + +/* + * Asgnop1 handles all assignments. + * If p is not nil then we are assigning + * to a function variable, otherwise + * we look the variable up ourselves. + */ +asgnop1(r, p) + int *r; + register struct nl *p; +{ + register struct nl *p1; + + if (r == NIL) + return (NIL); + if (p == NIL) { + p = lvalue(r[2], MOD|ASGN|NOUSE); + if (p == NIL) { + rvalue(r[3], NIL); + return (NIL); + } + } + p1 = rvalue(r[3], p); + if (p1 == NIL) + return (NIL); + if (incompat(p1, p, r[3])) { + cerror("Type of expression clashed with type of variable in assignment"); + return (NIL); + } + switch (classify(p)) { + case TBOOL: + case TCHAR: + case TINT: + case TSCAL: + rangechk(p, p1); + case TDOUBLE: + case TPTR: + gen(O_AS2, O_AS2, width(p), width(p1)); + break; + default: + put2(O_AS, width(p)); + } + return (p); /* Used by for statement */ +} + +/* + * for var := expr [down]to expr do stat + */ +forop(r) + int *r; +{ + register struct nl *t1, *t2; + int l1, l2, l3; + long soffset; + register op; + struct nl *p; + int *rr, goc, i; +#ifdef DEBUG + int limitrv = (hp21mx ? O_RV2 : O_RV4) | cbn << 9; + int limitsz = (hp21mx ? 2 : 4); +#endif + + p = NIL; + goc = gocnt; + if (r == NIL) + goto aloha; + putline(); + /* + * Allocate automatic + * space for limit variable + */ +#ifndef DEBUG + sizes[cbn].om_off =- 4; +#else + sizes[cbn].om_off =- limitsz; +#endif + if (sizes[cbn].om_off < sizes[cbn].om_max) + sizes[cbn].om_max = sizes[cbn].om_off; + i = sizes[cbn].om_off; + /* + * Initialize the limit variable + */ + put2(O_LV | cbn<<9, i); + t2 = rvalue(r[3], NIL); +#ifndef DEBUG + put1(width(t2) <= 2 ? O_AS24 : O_AS4); +#else + if (hp21mx) + put1(O_AS2); + else + put1(width(t2) <= 2 ? O_AS24 : O_AS4); +#endif + /* + * Assignment of initial value to for variable + */ + t1 = asgnop1(r[2], NIL); + if (t1 == NIL) { + rvalue(r[3], NIL); + statement(r[4]); + goto aloha; + } + rr = r[2]; /* Assignment */ + rr = rr[2]; /* Lhs variable */ + if (rr[3] != NIL) { + error("For variable must be unqualified"); + rvalue(r[3], NIL); + statement(r[4]); + goto aloha; + } + p = lookup(rr[2]); + p->value[NL_FORV] = 1; + if (isnta(t1, "bcis")) { + error("For variables cannot be %ss", nameof(t1)); + statement(r[4]); + goto aloha; + } + if (incompat(t2, t1, r[3])) { + cerror("Limit type clashed with index type in 'for' statement"); + statement(r[4]); + goto aloha; + } + /* + * See if we can skip the loop altogether + */ + rr = r[2]; + if (rr != NIL) + rvalue(rr[2], NIL); +#ifndef DEBUG + put2(O_RV4 | cbn<<9, i); + gen(NIL, r[0] == T_FORU ? T_LE : T_GE, width(t1), 4); +#else + put1(limitrv, i); + gen(NIL, r[0] == T_FORU ? T_LE : T_GE, width(t1), limitsz); +#endif + /* + * L1 will be patched to skip the body of the loop. + * L2 marks the top of the loop when we go around. + */ + put2(O_IF, (l1 = getlab())); + putlab(l2 = getlab()); + putcnt(); + statement(r[4]); + /* + * now we see if we get to go again + */ + if (opt('t') == 0) { + /* + * Easy if we dont have to test + */ +#ifndef DEBUG + put2(O_RV4 | cbn<<9, i); +#else + put2(limitrv, i); +#endif + if (rr != NIL) + lvalue(rr[2], MOD); + put2((r[0] == T_FORU ? O_FOR1U : O_FOR1D) + (width(t1) >> 1), l2); + } else { + line = r[1]; + putline(); + if (rr != NIL) + rvalue(rr[2], NIL); +#ifndef DEBUG + put2(O_RV4 | cbn << 9, i); + gen(NIL, (r[0] == T_FORU ? T_LT : T_GT), width(t1), 4); +#else + put2(limitrv, i); + gen(NIL, (r[0] == T_FORU ? T_LT : T_GT), width(t1), limitsz); +#endif + l3 = put2(O_IF, getlab()); + lvalue(rr[2], MOD); + rvalue(rr[2], NIL); + put2(O_CON2, 1); + t2 = gen(NIL, r[0] == T_FORU ? T_ADD: T_SUB, width(t1), 2); + rangechk(t1, t2); /* The point of all this */ + gen(O_AS2, O_AS2, width(t1), width(t2)); + put2(O_TRA, l2); + patch(l3); + } +#ifdef DEBUG + sizes[cbn].om_off =+ limitsz; +#else + sizes[cbn].om_off =+ 4; +#endif + patch(l1); +aloha: + noreach = 0; + if (p != NIL) + p->value[NL_FORV] = 0; + if (goc != gocnt) + putcnt(); +} + +/* + * if expr then stat [ else stat ] + */ +ifop(r) + int *r; +{ + register struct nl *p; + register l1, l2; + int nr, goc; + + goc = gocnt; + if (r == NIL) + return; + putline(); + p = rvalue(r[2], NIL); + if (p == NIL) { + statement(r[3]); + noreach = 0; + statement(r[4]); + noreach = 0; + return; + } + if (isnta(p, "b")) { + error("Type of expression in if statement must be Boolean, not %s", nameof(p)); + statement(r[3]); + noreach = 0; + statement(r[4]); + noreach = 0; + return; + } + l1 = put2(O_IF, getlab()); + putcnt(); + statement(r[3]); + nr = noreach; + if (r[4] != NIL) { + /* + * else stat + */ + --level; + ungoto(); + ++level; + l2 = put2(O_TRA, getlab()); + patch(l1); + noreach = 0; + statement(r[4]); + noreach =& nr; + l1 = l2; + } else + noreach = 0; + patch(l1); + if (goc != gocnt) + putcnt(); +} + +/* + * while expr do stat + */ +whilop(r) + int *r; +{ + register struct nl *p; + register l1, l2; + int goc; + + goc = gocnt; + if (r == NIL) + return; + putlab(l1 = getlab()); + putline(); + p = rvalue(r[2], NIL); + if (p == NIL) { + statement(r[3]); + noreach = 0; + return; + } + if (isnta(p, "b")) { + error("Type of expression in while statement must be Boolean, not %s", nameof(p)); + statement(r[3]); + noreach = 0; + return; + } + put2(O_IF, (l2 = getlab())); + putcnt(); + statement(r[3]); + put2(O_TRA, l1); + patch(l2); + if (goc != gocnt) + putcnt(); +} + +/* + * repeat stat* until expr + */ +repop(r) + int *r; +{ + register struct nl *p; + register l; + int goc; + + goc = gocnt; + if (r == NIL) + return; + l = putlab(getlab()); + putcnt(); + statlist(r[2]); + line = r[1]; + p = rvalue(r[3], NIL); + if (p == NIL) + return; + if (isnta(p,"b")) { + error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p)); + return; + } + put2(O_IF, l); + if (goc != gocnt) + putcnt(); +} + +/* + * assert expr + */ +asrtop(r) + register int *r; +{ + register struct nl *q; + + if (opt('s')) { + standard(); + error("Assert statement is non-standard"); + } + if (!opt('t')) + return; + r = r[2]; + q = rvalue(r, NIL); + if (q == NIL) + return; + if (isnta(q, "b")) + error("Assert expression must be Boolean, not %ss", nameof(q)); + put1(O_ASRT); +} diff --git a/src/pi1/string.c b/src/pi1/string.c new file mode 100644 index 0000000000..90271c2af6 --- /dev/null +++ b/src/pi1/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/pi1/subr.c b/src/pi1/subr.c new file mode 100644 index 0000000000..62e5673c1c --- /dev/null +++ b/src/pi1/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/pi1/tree.c b/src/pi1/tree.c new file mode 100644 index 0000000000..fa018b3f85 --- /dev/null +++ b/src/pi1/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/pi1/tree.h b/src/pi1/tree.h new file mode 100644 index 0000000000..0221a38a9c --- /dev/null +++ b/src/pi1/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/pi1/type.c b/src/pi1/type.c new file mode 100644 index 0000000000..989083d5a5 --- /dev/null +++ b/src/pi1/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/pi1/var.c b/src/pi1/var.c new file mode 100644 index 0000000000..e32193e466 --- /dev/null +++ b/src/pi1/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); +} diff --git a/src/pi1/yyerror.c b/src/pi1/yyerror.c new file mode 100644 index 0000000000..3c024fe260 --- /dev/null +++ b/src/pi1/yyerror.c @@ -0,0 +1,17 @@ +/* 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" + +yerror(s, a1, a2) + char *s; +{ + + error(s, a1, a2); +} diff --git a/src/pi1/yymain.c b/src/pi1/yymain.c new file mode 100644 index 0000000000..030add0e14 --- /dev/null +++ b/src/pi1/yymain.c @@ -0,0 +1,84 @@ +/* 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" + +int line 1; + +/* + * Yymain initializes each of the utility + * clusters and then starts the processing + * by calling yyparse. + */ +yymain() +{ + + /* + * Initialize the clusters + */ + initstring(); + inittree(); + initnl(); + + /* + * Process the input + */ + receive(); + /* no return */ +} + +static +struct { + int magic; + int txt_size; + int data_size; +} header; + +magic() +{ + int buf[512]; + register int hf, i; + + hf = open("/usr/lib/px_header", 0); + if (hf >= 0 && read(hf, buf, 1024) > 16) { + header.magic = buf[0]; + header.txt_size = buf[1]; + header.data_size = buf[2]; + for (i = 0; i < 512; i++) + word(buf[i]); + } + close(hf); +#ifdef DEBUG + word(hp21mx ? 0403 : 0404); +#else + word(0404); +#endif +} + +magic2() +{ + int i; + + pflush(); + if (header.magic != 0407) + return; + seek(ofil, 0, 0); + header.data_size = lc - header.txt_size; + header.data_size =- 16; + write(ofil, &header, sizeof header); + seek(ofil, 1022, 0); + i = ((int) lc) - 1024; + write(ofil, &i, 2); +} -- 2.20.1