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

diff --git a/src/pi0/0.h b/src/pi0/0.h
new file mode 100644 (file)
index 0000000..086840c
--- /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
+\f
+/*
+ * 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')
+\f
+
+/*
+ * 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;
+\f
+/*
+ * 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
+\f
+/*
+ * 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
+\f
+/*
+ * 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;
+\f
+/*
+ * 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
+\f
+/*
+ * 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]; */
+\f
+/*
+ * 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;
+\f
+/*
+ * 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;
+\f
+/*
+ * UNDEFINED VARIABLE REFERENCE STRUCTURES
+ */
+struct udinfo {
+       int     ud_line;
+       struct  udinfo *ud_next;
+       char    nullch;
+};
+\f
+
+/*
+ * 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
+\f
+/*
+ * 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 (file)
index 0000000..0c7a376
--- /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 (file)
index 0000000..e4997a9
--- /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 (file)
index 0000000..054c93a
--- /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 (file)
index 0000000..4c6a3dc
--- /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 (file)
index 0000000..f6bd2af
--- /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
+\f
+/*
+ * 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 (file)
index 0000000..633ab15
--- /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 (file)
index 0000000..131606f
--- /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