From 7244f996e30b8f6f664f380e74d748ac96285803 Mon Sep 17 00:00:00 2001 From: Bill Joy Date: Wed, 9 May 1979 18:50:13 -0800 Subject: [PATCH] BSD 2 development Work on file src/pi0/0.h Work on file src/pi0/TRdata.c Work on file src/pi0/Version.c Work on file src/pi0/ato.c Work on file src/pi0/clas.c Work on file src/pi0/const.c Work on file src/pi0/conv.c Work on file src/pi0/error.c Synthesized-from: 2bsd --- src/pi0/0.h | 552 ++++++++++++++++++++++++++++++++++++++++++++++ src/pi0/TRdata.c | 202 +++++++++++++++++ src/pi0/Version.c | 2 + src/pi0/ato.c | 43 ++++ src/pi0/clas.c | 210 ++++++++++++++++++ src/pi0/const.c | 217 ++++++++++++++++++ src/pi0/conv.c | 234 ++++++++++++++++++++ src/pi0/error.c | 123 +++++++++++ 8 files changed, 1583 insertions(+) create mode 100644 src/pi0/0.h create mode 100644 src/pi0/TRdata.c create mode 100644 src/pi0/Version.c create mode 100644 src/pi0/ato.c create mode 100644 src/pi0/clas.c create mode 100644 src/pi0/const.c create mode 100644 src/pi0/conv.c create mode 100644 src/pi0/error.c diff --git a/src/pi0/0.h b/src/pi0/0.h new file mode 100644 index 0000000000..086840c2fe --- /dev/null +++ b/src/pi0/0.h @@ -0,0 +1,552 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#include "send.h" +/* #define DEBUG */ +#define CHAR +#define STATIC +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy + * University of California, Berkeley (UCB) + * Version 1.2 January 1979 + */ + +/* + * Option flags + * + * The following options are recognized in the text of the program + * and also on the command line: + * + * b block buffer the file output + * + * i make a listing of the procedures and functions in + * the following include files + * + * l make a listing of the program + * + * n place each include file on a new page with a header + * + * p disable post mortem and statement limit counting + * + * t disable run-time tests + * + * u card image mode; only first 72 chars of input count + * + * w suppress special diagnostic warnings + * + * z generate counters for an execution profile + */ +#ifdef DEBUG +char fulltrace, errtrace, testtrace, yyunique; +#endif + +/* + * Each option has a stack of 17 option values, with opts giving + * the current, top value, and optstk the value beneath it. + * One refers to option `l' as, e.g., opt('l') in the text for clarity. + */ +char opts[26]; +int optstk[26]; + +#define opt(c) opts[c-'a'] + +/* + * Monflg is set when we are generating + * a profile + */ +char monflg; +/* + * NOTES ON THE DYNAMIC NATURE OF THE DATA STRUCTURES + * + * Pi uses expandable tables for + * its namelist (symbol table), string table + * hash table, and parse tree space. The following + * definitions specify the size of the increments + * for these items in fundamental units so that + * each uses approximately 1024 bytes. + */ + +#define STRINC 1024 /* string space increment */ +#define TRINC 512 /* tree space increment */ +#define HASHINC 509 /* hash table size in words, each increment */ +#define NLINC 56 /* namelist increment size in nl structs */ + +/* + * The initial sizes of the structures. + * These should be large enough to compile + * an "average" sized program so as to minimize + * storage requests. + * On a small system or and 11/34 or 11/40 + * these numbers can be trimmed to make the + * compiler smaller. + */ +#define ITREE 512 /* Must be the same as TRINC */ +#define INL 200 +#define IHASH 509 + +/* + * The following limits on hash and tree tables currently + * allow approximately 1200 symbols and 20k words of tree + * space. The fundamental limit of 64k total data space + * should be exceeded well before these are full. + */ +#define MAXHASH 4 +#define MAXNL 12 +#define MAXTREE 30 +#define MAXDEPTH 150 + +/* + * ERROR RELATED DEFINITIONS + */ + +/* + * Exit statuses to pexit + * + * AOK + * ERRS Compilation errors inhibit obj productin + * NOSTART Errors before we ever got started + * DIED We ran out of memory or some such + */ +#define AOK 0 +#define ERRS 1 +#define NOSTART 2 +#define DIED 3 + +char Recovery; + +#define eholdnl() Eholdnl = 1 +#define nocascade() Enocascade = 1 + +char Eholdnl, Enocascade; + + +/* + * The flag eflg is set whenever we have a hard error. + * The character in errpfx will precede the next error message. + */ +int eflg; +char errpfx; + +#define setpfx(x) errpfx = x + +#define standard() setpfx('s') +#define warning() setpfx('w') +#define recovered() setpfx('e') + + +/* + * The flag syneflg is used to suppress the diagnostics of the form + * E 10 a, defined in someprocedure, is neither used nor set + * when there were syntax errors in "someprocedure". + * In this case, it is likely that these warinings would be spurious. + */ +char syneflg; + +/* + * The compiler keeps its error messages in a file. + * The variable efil is the unit number on which + * this file is open for reading of error message text. + * Similarly, the file ofil is the unit of the file + * "obj" where we write the interpreter code. + */ +char efil, ofil; +/* int obuf[259]; */ + +#define elineoff() Enoline++ +#define elineon() Enoline = 0 + +char Enoline; + +/* + * SYMBOL TABLE STRUCTURE DEFINITIONS + * + * The symbol table is henceforth referred to as the "namelist". + * It consists of a number of structures of the form "nl" below. + * These are contained in a number of segments of the symbol + * table which are dynamically allocated as needed. + * The major namelist manipulation routines are contained in the + * file "nl.c". + * + * The major components of a namelist entry are the "symbol", giving + * a pointer into the string table for the string associated with this + * entry and the "class" which tells which of the (currently 19) + * possible types of structure this is. + * + * Many of the classes use the "type" field for a pointer to the type + * which the entry has. + * + * Other pieces of information in more than one class include the block + * in which the symbol is defined, flags indicating whether the symbol + * has been used and whether it has been assigned to, etc. + * + * A more complete discussion of the features of the namelist is impossible + * here as it would be too voluminous. Refer to the "PI 1.0 Implementation + * Notes" for more details. + */ + +/* + * The basic namelist structure. + * There are also two other variants, defining the real + * field as longs or integers given below. + * + * The array disptab defines the hash header for the symbol table. + * Symbols are hashed based on the low 6 bits of their pointer into + * the string table; see the routines in the file "lookup.c" and also "fdec.c" + * especially "funcend". + */ +struct nl { + char *symbol; + char class, nl_flags; + struct nl *type; + struct nl *chain, *nl_next; + double real; +} nl[], *nlp, *disptab[077+1]; + +struct { + char *symbol; + char class, nl_block; + struct nl *type; + struct nl *chain, *nl_next; + long range[2]; +}; + +struct { + char *symbol; + char class, nl_flags; + struct nl *type; + struct nl *chain, *nl_next; + int value[4]; +}; + +/* + * NL FLAGS BITS + * + * Definitions of the usage of the bits in + * the nl_flags byte. Note that the low 5 bits of the + * byte are the "nl_block" and that some classes make use + * of this byte as a "width". + * + * The only non-obvious bit definition here is "NFILES" + * which records whether a structure contains any files. + * Such structures are not allowed to be dynamically allocated. + */ +#define NPACKED 0200 +#define NFORWD 0200 +#define NFILES 0200 + +/* + * Definition of the commonly used "value" fields. + * The most important ones are NL_LOC which gives the location + * in the code of a label or procedure, and NL_OFFS which gives + * the offset of a variable in its stack mark. + */ +#define NL_OFFS 0 +#define NL_LOC 1 + +#define NL_FVAR 3 + +#define NL_GOLEV 2 +#define NL_GOLINE 3 +#define NL_FORV 1 + +#define NL_FLDSZ 1 +#define NL_VARNT 2 +#define NL_VTOREC 2 +#define NL_TAG 3 + +/* + * For BADUSE nl structures, NL_KINDS is a bit vector + * indicating the kinds of illegal usages complained about + * so far. For kind of bad use "kind", "1 << kind" is set. + * The low bit is reserved as ISUNDEF to indicate whether + * this identifier is totally undefined. + */ +#define NL_KINDS 0 + +#define ISUNDEF 1 + +/* + * NAMELIST CLASSES + * + * The following are the namelist classes. + * Different classes make use of the value fields + * of the namelist in different ways. + * + * The namelist should be redesigned by providing + * a number of structure definitions with one corresponding + * to each namelist class, ala a variant record in Pascal. + */ +#define BADUSE 0 +#define CONST 1 +#define TYPE 2 +#define VAR 3 +#define ARRAY 4 +#define PTRFILE 5 +#define RECORD 6 +#define FIELD 7 +#define PROC 8 +#define FUNC 9 +#define FVAR 10 +#define REF 11 +#define PTR 12 +#define FILE 13 +#define SET 14 +#define RANGE 15 +#define LABEL 16 +#define WITHPTR 17 +#define SCAL 18 +#define STR 19 +#define PROG 20 +#define IMPROPER 21 +#define VARNT 22 + +/* + * Clnames points to an array of names for the + * namelist classes. + */ +char **clnames; + +/* + * PRE-DEFINED NAMELIST OFFSETS + * + * The following are the namelist offsets for the + * primitive types. The ones which are negative + * don't actually exist, but are generated and tested + * internally. These definitions are sensitive to the + * initializations in nl.c. + */ +#define TFIRST -7 +#define TFILE -7 +#define TREC -6 +#define TARY -5 +#define TSCAL -4 +#define TPTR -3 +#define TSET -2 +#define TSTR -1 +#define NIL 0 +#define TBOOL 1 +#define TCHAR 2 +#define TINT 3 +#define TDOUBLE 4 +#define TNIL 5 +#define T1INT 6 +#define T2INT 7 +#define T4INT 8 +#define T1CHAR 9 +#define T1BOOL 10 +#define T8REAL 11 +#define TLAST 11 + +/* + * SEMANTIC DEFINITIONS + */ + +/* + * NOCON and SAWCON are flags in the tree telling whether + * a constant set is part of an expression. + */ +#define NOCON 0 +#define SAWCON 1 + +/* + * The variable cbn gives the current block number, + * the variable bn is set as a side effect of a call to + * lookup, and is the block number of the variable which + * was found. + */ +int bn, cbn; + +/* + * The variable line is the current semantic + * line and is set in stat.c from the numbers + * embedded in statement type tree nodes. + */ +int line; + +/* + * The size of the display + * which defines the maximum nesting + * of procedures and functions allowed. + * Because of the flags in the current namelist + * this must be no greater than 32. + */ +#define DSPLYSZ 20 + +/* + * The following structure is used + * to keep track of the amount of variable + * storage required by each block. + * "Max" is the high water mark, "off" + * the current need. Temporaries for "for" + * loops and "with" statements are allocated + * in the local variable area and these + * numbers are thereby changed if necessary. + */ +/* struct om { */ +/* long om_off; */ +/* long om_max; */ +/* } sizes[DSPLYSZ]; */ + +/* + * Structure recording information about a constant + * declaration. It is actually the return value from + * the routine "gconst", but since C doesn't support + * record valued functions, this is more convenient. + */ +struct { + int ctype; + int cival; + double crval; +} con; + +/* + * The set structure records the lower bound + * and upper bound with the lower bound normalized + * to zero when working with a set. It is set by + * the routine setran in var.c. + */ +struct { + int lwrb, uprbp; +} set; + +/* + * The following flags are passed on calls to lvalue + * to indicate how the reference is to affect the usage + * information for the variable being referenced. + * MOD is used to set the NMOD flag in the namelist + * entry for the variable, ASGN permits diagnostics + * to be formed when a for variable is assigned to in + * the range of the loop. + */ +#define NOMOD 0 +#define MOD 01 +#define ASGN 02 +#define NOUSE 04 + +double MAXINT, MININT; + +/* + * Variables for generation of profile information. + * Monflg is set when we want to generate a profile. + * Gocnt record the total number of goto's and + * cnts records the current counter for generating + * COUNT operators. + */ +int gocnt; +int cnts; + +/* + * Most routines call "incompat" rather than asking "!compat" + * for historical reasons. + */ +#define incompat !compat + +/* + * Parts records which declaration parts have been seen. + * The grammar allows the "const" "type" and "var" + * parts to be repeated and to be in any order, so that + * they can be detected semantically to give better + * error diagnostics. + */ +int parts; + +#define LPRT 01 +#define CPRT 02 +#define TPRT 04 +#define VPRT 08 + +/* + * Flags for the "you used / instead of div" diagnostic + */ +/* char divchk; */ +/* char divflg; */ + +int errcnt[DSPLYSZ]; + +/* + * Forechain links those types which are + * ^ sometype + * so that they can be evaluated later, permitting + * circular, recursive list structures to be defined. + */ +struct nl *forechain; + +/* + * Withlist links all the records which are currently + * opened scopes because of with statements. + */ +/* struct nl *withlist; */ + +char *intset; +char *input, *output; +struct nl *program; + +/* + * UNDEFINED VARIABLE REFERENCE STRUCTURES + */ +struct udinfo { + int ud_line; + struct udinfo *ud_next; + char nullch; +}; + + +/* + * Routines which need types + * other than "integer" to be + * assumed by the compiler. + */ +/* double atof(); */ +long lwidth(); +long aryconst(); +/* long a8tol(); */ +struct nl *lookup(); +double atof(); +int *tree(); +int *hash(); +char *alloc(); + +/* + * Funny structures to use + * pointers in wild and wooly ways + */ +struct { + char pchar; +}; +struct { + int pint; + int pint2; +}; +struct { + long plong; +}; +struct { + double pdouble; +}; + +#define OCT 1 +#define HEX 2 + +/* + * MAIN PROGRAM VARIABLES, MISCELLANY + */ + +/* + * Variables forming a data base referencing + * the command line arguments with the "i" option, e.g. + * in "pi -i scanner.i compiler.p". + */ +char **pflist; +int pflstc; +int pfcnt; + +char *filename; /* current source file name */ +int tvec[2]; /* mod time of the source file */ +char snark[]; /* SNARK */ +char *classes[]; /* maps namelist classes to string names */ +char *errfile; + +#define derror error +#ifdef DEBUG +char hp21mx; +#endif diff --git a/src/pi0/TRdata.c b/src/pi0/TRdata.c new file mode 100644 index 0000000000..0c7a376359 --- /dev/null +++ b/src/pi0/TRdata.c @@ -0,0 +1,202 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#include "0.h" +#ifdef PI1 +#ifdef DEBUG +char *trnames[] +{ + 0, + "MINUS", + "MOD", + "DIV", + "DIVD", + "MULT", + "ADD", + "SUB", + "EQ", + "NE", + "LT", + "GT", + "LE", + "GE", + "NOT", + "AND", + "OR", + "ASGN", + "PLUS", + "IN", + "LISTPP", + "PDEC", + "FDEC", + "PVAL", + "PVAR", + "PFUNC", + "PPROC", + "NIL", + "STRNG", + "CSTRNG", + "PLUSC", + "MINUSC", + "ID", + "INT", + "FINT", + "CINT", + "CFINT", + "TYPTR", + "TYPACK", + "TYSCAL", + "TYRANG", + "TYARY", + "TYFILE", + "TYSET", + "TYREC", + "TYFIELD", + "TYVARPT", + "TYVARNT", + "CSTAT", + "BLOCK", + "BSTL", + "LABEL", + "PCALL", + "FCALL", + "CASE", + "WITH", + "WHILE", + "REPEAT", + "FORU", + "FORD", + "GOTO", + "IF", + "ASRT", + "CSET", + "RANG", + "VAR", + "ARGL", + "ARY", + "FIELD", + "PTR", + "WEXP", + "PROG", + "BINT", + "CBINT", + "IFEL", + "IFX", + "TYID", + "COPSTR", + "BOTTLE", + "RFIELD", + "FLDLST", + "LAST" +}; +#endif +#endif + +char *trdesc[] +{ + 0, + "dp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dpp", + "dp", + "dpp", + "dpp", + "npp", + "dp", + "dpp", + "pp", + "n\"pp", + "n\"pp", + "pp", + "pp", + "pp", + "p", + "d", + "dp", + "p", + "p", + "p", + "p", + "dp", + "dp", + "p", + "p", + "np", + "np", + "np", + "npp", + "npp", + "np", + "np", + "np", + "pp", + "nppp", + "npp", + "npp", + "np", + "np", + "n\"p", + "n\"p", + "n\"p", + "npp", + "npp", + "npp", + "npp", + "nppp", + "nppp", + "n\"", + "nppp", + "np", + "dp", + "pp", + "n\"p", + "p", + "p", + "pp", + "", + "ppp", + "n\"pp", + "dp", + "p", + "nppp", + "nppp", + "np", + "s", + "nnnnn", + "npp", + "npp", + "x" +}; +#ifdef PI1 +char *opnames[] +{ + 0, + "unary -", + "mod", + "div", + "/", + "*", + "+", + "-", + "=", + "<>", + "<", + ">", + "<=", + ">=", + "not", + "and", + "or", + ":=", + "unary +", + "in" +}; +#endif diff --git a/src/pi0/Version.c b/src/pi0/Version.c new file mode 100644 index 0000000000..e4997a98da --- /dev/null +++ b/src/pi0/Version.c @@ -0,0 +1,2 @@ +/* Copyright (c) 1979 Regents of the University of California */ +char version[] "May 7, 1979"; diff --git a/src/pi0/ato.c b/src/pi0/ato.c new file mode 100644 index 0000000000..054c93a2a4 --- /dev/null +++ b/src/pi0/ato.c @@ -0,0 +1,43 @@ +/* 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" + +long a8tol(cp) + char *cp; +{ + int err; + long l; + register CHAR c; + + l = 0; + err = 0; + while ((c = *cp++) != '\0') { + if (c == '8' || c == '9') + if (err == 0) { + error("8 or 9 in octal number"); + err++; + } + c =- '0'; + if (((&l)->pint & 0160000) != 0) + if (err == 0) { + error("Number too large for this implementation"); + err++; + } + l = (l << 3) | c; + } + return (l); +} + +/* + * Note that the version of atof + * used in this compiler does not + * (sadly) complain when floating + * point numbers are too large. + */ diff --git a/src/pi0/clas.c b/src/pi0/clas.c new file mode 100644 index 0000000000..4c6a3dca65 --- /dev/null +++ b/src/pi0/clas.c @@ -0,0 +1,210 @@ +/* Copyright (c) 1979 Regents of the University of California */ +# +/* + * pi - Pascal interpreter code translator + * + * Charles Haley, Bill Joy UCB + * Version 1.2 January 1979 + */ + +#include "0.h" +#include "tree.h" +#include "opcode.h" + +/* + * This is the array of class + * names for the classes returned + * by classify. The order of the + * classes is the same as the base + * of the namelist, with special + * negative index entries for structures, + * scalars, pointers, sets and strings + * to be collapsed into. + */ +char *clnxxxx[] +{ + "file", /* -7 TFILE */ + "record", /* -6 TREC */ + "array", /* -5 TARY */ + "scalar", /* -4 TSCAL */ + "pointer", /* -3 TPTR */ + "set", /* -2 TSET */ + "string", /* -1 TSTR */ + snark, /* 0 NIL */ + "Boolean", /* 1 TBOOL */ + "char", /* 2 TCHAR */ + "integer", /* 3 TINT */ + "real", /* 4 TREAL */ + "\"nil\"", /* 5 TNIL */ +}; + +char **clnames &clnxxxx[-(TFIRST)]; + +/* + * Classify takes a pointer + * to a type and returns one + * of several interesting group + * classifications for easy use. + */ +classify(p1) + struct nl *p1; +{ + register struct nl *p; + + p = p1; +swit: + if (p == NIL) { + nocascade(); + return (NIL); + } + if (p == &nl[TSTR]) + return (TSTR); + switch (p->class) { + case PTR: + return (TPTR); + case ARRAY: + if (p->type == nl+T1CHAR) + return (TSTR); + return (TARY); + case STR: + return (TSTR); + case SET: + return (TSET); + case RANGE: + p = p->type; + goto swit; + case TYPE: + if (p <= nl+TLAST) + return (p - nl); + panic("clas2"); + case FILE: + return (TFILE); + case RECORD: + return (TREC); + case SCAL: + return (TSCAL); + default: + panic("clas"); + } +} + +#ifndef PI0 +/* + * Is p a text file? + */ +text(p) + struct nl *p; +{ + + return (p != NIL && p->class == FILE && p->type == nl+T1CHAR); +} +#endif + +/* + * Scalar returns a pointer to + * the the base scalar type of + * its argument if its argument + * is a SCALar else NIL. + */ +scalar(p1) + struct nl *p1; +{ + register struct nl *p; + + p = p1; + if (p == NIL) + return (NIL); + if (p->class == RANGE) + p = p->type; + if (p == NIL) + return (NIL); + return (p->class == SCAL ? p : NIL); +} + +/* + * Isa tells whether p + * is one of a group of + * namelist classes. The + * classes wanted are specified + * by the characters in s. + * (Note that s would more efficiently, + * if less clearly, be given by a mask.) + */ +isa(p, s) + register struct nl *p; + char *s; +{ + register i; + register char *cp; + + if (p == NIL) + return (NIL); + /* + * map ranges down to + * the base type + */ + if (p->class == RANGE) + p = p->type; + /* + * the following character/class + * associations are made: + * + * s scalar + * b Boolean + * c character + * i integer + * d double (real) + * t set + */ + switch (p->class) { + case SET: + i = TDOUBLE+1; + break; + case SCAL: + i = 0; + break; + default: + i = p - nl; + } + if (i >= 0 && i <= TDOUBLE+1) { + i = "sbcidt"[i]; + cp = s; + while (*cp) + if (*cp++ == i) + return (1); + } + return (NIL); +} + +/* + * Isnta is !isa + */ +isnta(p, s) +{ + + return (!isa(p, s)); +} + +/* + * "shorthand" + */ +nameof(p) +{ + + return (clnames[classify(p)]); +} + +#ifndef PI0 +nowexp(r) + int *r; +{ + if (r[0] == T_WEXP) { + if (r[2] == NIL) + error("Oct/hex allowed only on writeln/write calls"); + else + error("Width expressions allowed only in writeln/write calls"); + return (1); + } + return (NIL); +} +#endif diff --git a/src/pi0/const.c b/src/pi0/const.c new file mode 100644 index 0000000000..f6bd2af66c --- /dev/null +++ b/src/pi0/const.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 + */ + +#include "0.h" +#include "tree.h" + +/* + * Const enters the definitions + * of the constant declaration + * part into the namelist. + */ +#ifndef PI1 +constbeg() +{ + + if (parts & (TPRT|VPRT)) + error("Constant declarations must precede type and variable declarations"); + if (parts & CPRT) + error("All constants must be declared in one const part"); + parts =| CPRT; +} +#endif + +const(cline, cid, cdecl) + int cline; + register char *cid; + register int *cdecl; +{ + register struct nl *np; + +#ifdef PI0 + send(REVCNST, cline, cid, cdecl); +#endif + line = cline; + gconst(cdecl); + np = enter(defnl(cid, CONST, con.ctype, con.cival)); +#ifndef PI0 + np->nl_flags =| NMOD; +#endif + if (con.ctype == NIL) + return; + if (isa(con.ctype, "i")) + np->range[0] = con.crval; + else if (isa(con.ctype, "d")) + np->real = con.crval; +} + +#ifndef PI0 +#ifndef PI1 +constend() +{ + +} +#endif +#endif + +/* + * Gconst extracts + * a constant declaration + * from the tree for it. + * only types of constants + * are integer, reals, strings + * and scalars, the first two + * being possibly signed. + */ +gconst(r) + int *r; +{ + register struct nl *np; + register *cn; + char *cp; + int negd, sgnd; + long ci; + + con.ctype = NIL; + cn = r; + negd = sgnd = 0; +loop: + if (cn == NIL || cn[1] == NIL) + return (NIL); + switch (cn[0]) { + default: + panic("gconst"); + case T_MINUSC: + negd = 1 - negd; + case T_PLUSC: + sgnd++; + cn = cn[1]; + goto loop; + case T_ID: + np = lookup(cn[1]); + if (np == NIL) + return; + if (np->class != CONST) { + derror("%s is a %s, not a constant as required", cn[1], classes[np->class]); + return; + } + con.ctype = np->type; + switch (classify(np->type)) { + case TINT: + con.crval = np->range[0]; + break; + case TDOUBLE: + con.crval = np->real; + break; + case TBOOL: + case TCHAR: + case TSTR: + case TSCAL: + con.cival = np->value[0]; + con.crval = con.cival; + break; + case NIL: + con.ctype = NIL; + return; + default: + panic("gconst2"); + } + break; + case T_CBINT: + con.crval = a8tol(cn[1]); + goto restcon; + case T_CINT: + con.crval = atof(cn[1]); + if (con.crval > MAXINT || con.crval < MININT) { + derror("Constant too large for this implementation"); + con.crval = 0; + } +restcon: + ci = con.crval; +#ifndef PI0 + if (bytes(ci, ci) <= 2) + con.ctype = nl+T2INT; + else +#endif + con.ctype = nl+T4INT; + break; + case T_CFINT: + con.ctype = nl+TDOUBLE; + con.crval = atof(cn[1]); + break; + case T_CSTRNG: + cp = cn[1]; + if (cp[1] == 0) { + con.ctype = nl+T1CHAR; + con.cival = cp[0]; + con.crval = con.cival; + break; + } + con.ctype = nl+TSTR; + con.cival = savestr(cp); + con.crval = con.cival; + break; + } + if (sgnd) { + if (isnta(con.ctype, "id")) + derror("%s constants cannot be signed", nameof(con.ctype)); + else { + if (negd) + con.crval = -con.crval; + ci = con.crval; +#ifndef PI0 + if (bytes(ci, ci) <= 2) + con.ctype = nl+T2INT; +#endif + } + } +} + +#ifndef PI0 +isconst(r) + register int *r; +{ + + if (r == NIL) + return (1); + switch (r[0]) { + case T_MINUS: + r[0] = T_MINUSC; + r[1] = r[2]; + return (isconst(r[1])); + case T_PLUS: + r[0] = T_PLUSC; + r[1] = r[2]; + return (isconst(r[1])); + case T_VAR: + if (r[3] != NIL) + return (0); + r[0] = T_ID; + r[1] = r[2]; + return (1); + case T_BINT: + r[0] = T_CBINT; + r[1] = r[2]; + return (1); + case T_INT: + r[0] = T_CINT; + r[1] = r[2]; + return (1); + case T_FINT: + r[0] = T_CFINT; + r[1] = r[2]; + return (1); + case T_STRNG: + r[0] = T_CSTRNG; + r[1] = r[2]; + return (1); + } + return (0); +} +#endif diff --git a/src/pi0/conv.c b/src/pi0/conv.c new file mode 100644 index 0000000000..633ab15d53 --- /dev/null +++ b/src/pi0/conv.c @@ -0,0 +1,234 @@ +/* Copyright (c) 1979 Regents of the University of California */ +#ifdef PI +#include "0.h" +#include "opcode.h" + +#ifndef PI0 +/* + * Convert a p1 into a p2. + * Mostly used for different + * length integers and "to real" conversions. + */ +convert(p1, p2) + struct nl *p1, *p2; +{ + if (p1 == NIL || p2 == NIL) + return; + switch (width(p1) - width(p2)) { + case -7: + case -6: + put1(O_STOD); + return; + case -4: + put1(O_ITOD); + return; + case -3: + case -2: + put1(O_STOI); + return; + case -1: + case 0: + case 1: + return; + case 2: + case 3: + put1(O_ITOS); + return; + default: + panic("convert"); + } +} +#endif + +/* + * Compat tells whether + * p1 and p2 are compatible + * types for an assignment like + * context, i.e. value parameters, + * indicies for 'in', etc. + */ +compat(p1, p2, t) + struct nl *p1, *p2; +{ + register c1, c2; + + c1 = classify(p1); + if (c1 == NIL) + return (NIL); + c2 = classify(p2); + if (c2 == NIL) + return (NIL); + switch (c1) { + case TBOOL: + case TCHAR: + if (c1 == c2) + return (1); + break; + case TINT: + if (c2 == TINT) + return (1); + case TDOUBLE: + if (c2 == TDOUBLE) + return (1); +#ifndef PI0 + if (c2 == TINT && divflg == 0) { + divchk= 1; + c1 = classify(rvalue(t, NIL)); + divchk = NIL; + if (c1 == TINT) { + error("Type clash: real is incompatible with integer"); + cerror("This resulted because you used '/' which always returns real rather"); + cerror("than 'div' which divides integers and returns integers"); + divflg = 1; + return (NIL); + } + } +#endif + break; + case TSCAL: + if (c2 != TSCAL) + break; + if (scalar(p1) != scalar(p2)) { + derror("Type clash: non-identical scalar types"); + return (NIL); + } + return (1); + case TSTR: + if (c2 != TSTR) + break; + if (width(p1) != width(p2)) { + derror("Type clash: unequal length strings"); + return (NIL); + } + return (1); + case TNIL: + if (c2 != TPTR) + break; + return (1); + case TFILE: + if (c1 != c2) + break; + derror("Type clash: files not allowed in this context"); + return (NIL); + default: + if (c1 != c2) + break; + if (p1 != p2) { + derror("Type clash: non-identical %s types", clnames[c1]); + return (NIL); + } + if (p1->nl_flags & NFILES) { + derror("Type clash: %ss with file components not allowed in this context", clnames[c1]); + return (NIL); + } + return (1); + } + derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]); + return (NIL); +} + +#ifndef PI0 +/* + * Rangechk generates code to + * check if the type p on top + * of the stack is in range for + * assignment to a variable + * of type q. + */ +rangechk(p, q) + struct nl *p, *q; +{ + register struct nl *rp; + register op; + int wq, wrp; + + if (opt('t') == 0) + return; + rp = p; + if (rp == NIL) + return; + if (q == NIL) + return; + /* + * When op is 1 we are checking length + * 4 numbers against length 2 bounds, + * and adding it to the opcode forces + * generation of appropriate tests. + */ + op = 0; + wq = width(q); + wrp = width(rp); + op = wq != wrp && (wq == 4 || wrp == 4); + if (rp->class == TYPE) + rp = rp->type; + switch (rp->class) { + case RANGE: + if (rp->range[0] != 0) { +#ifndef DEBUG + if (wrp <= 2) + put3(O_RANG2+op, rp->value[1], rp->value[3]); + else if (rp != nl+T4INT) + put(5, O_RANG4+op, rp->range[0], rp->range[1]); +#else + if (!hp21mx) { + if (wrp <= 2) + put3(O_RANG2+op, rp->value[1], rp->value[3]); + else if (rp != nl+T4INT) + put(5, O_RANG4+op, rp->range[0], rp->range[1]); + } else + if (rp != nl+T2INT && rp != nl+T4INT) + put3(O_RANG2+op, rp->value[1], rp->value[3]); +#endif + break; + } + /* + * Range whose lower bounds are + * zero can be treated as scalars. + */ + case SCAL: + if (wrp <= 2) + put2(O_RSNG2+op, rp->value[3]); + else + put3(O_RSNG4+op, rp->range[1]); + break; + default: + panic("rangechk"); + } +} +#endif +#endif + +#ifdef DEBUG +conv(dub) + int *dub; +{ + int newfp[2]; + double *dp = dub; + long *lp = dub; + register int exp; + long mant; + + newfp[0] = dub[0] & 0100000; + newfp[1] = 0; + if (*dp == 0.0) + goto ret; + exp = ((dub[0] >> 7) & 0377) - 0200; + if (exp < 0) { + newfp[1] = 1; + exp = -exp; + } + if (exp > 63) + exp = 63; + dub[0] &= ~0177600; + dub[0] |= 0200; + mant = *lp; + mant =<< 8; + if (newfp[0]) + mant = -mant; + newfp[0] |= (mant >> 17) & 077777; + newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1); +ret: + dub[0] = newfp[0]; + dub[1] = newfp[1]; +} +#endif diff --git a/src/pi0/error.c b/src/pi0/error.c new file mode 100644 index 0000000000..131606f97e --- /dev/null +++ b/src/pi0/error.c @@ -0,0 +1,123 @@ +/* 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" +#ifndef PI1 +#include "yy.h" +#endif + +char errpfx 'E'; +extern int yyline; +/* + * Panic is called when impossible + * (supposedly, anyways) situations + * are encountered. + * Panic messages should be short + * as they do not go to the message + * file. + */ +panic(s) + char *s; +{ + +#ifdef DEBUG +#ifdef PI1 + printf("Snark (%s) line=%d\n", s, line); + abort(); +#else + printf("Snark (%s) line=%d, yyline=%d\n", s, line, yyline); +#endif +#endif +#ifdef PI1 + Perror( "Snark in pi1", s); +#else + Perror( "Snark in pi", s); +#endif + pexit(DIED); +} + +extern char *errfile; +/* + * Error is called for + * semantic errors and + * prints the error and + * a line number. + */ +error(a1, a2, a3, a4) + register char *a1; +{ + char buf[256]; + register int i; + + if (errpfx == 'w' && opt('w') != 0) + return; + Enocascade = 0; + geterr(a1, buf); + a1 = buf; + if (line < 0) + line = -line; +#ifndef PI1 + if (opt('l')) + yyoutline(); +#endif + yysetfile(filename); + if (errpfx == ' ') { + printf(" "); + for (i = line; i >= 10; i =/ 10) + putchar(' '); + printf("... "); + } else if (Enoline) + printf(" %c - ", errpfx); + else + printf("%c %d - ", errpfx, line); + printf(a1, a2, a3, a4); + if (errpfx == 'E') +#ifndef PI0 + eflg++, cgenflg++; +#else + eflg++; +#endif + errpfx = 'E'; + if (Eholdnl) + Eholdnl = 0; + else + putchar('\n'); +} + +cerror(a1, a2, a3, a4) +{ + + if (Enocascade) + return; + setpfx(' '); + error(a1, a2, a3, a4); +} + +#ifdef PI1 +derror(a1, a2, a3, a4) +{ + + if (!holdderr) + error(a1, a2, a3, a4); + errpfx = 'E'; +} + +char *lastname, printed, hadsome; + +yysetfile(name) + char *name; +{ + + if (lastname == name) + return; + printed =| 1; + printf("%s:\n", name); + lastname = name; +} +#endif -- 2.20.1