home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Distributions / ucb / spencer_2bsd.tar.gz / 2bsd.tar / src / pi0 / nl.c < prev    next >
C/C++ Source or Header  |  1980-02-17  |  11KB  |  691 lines
  1. /* Copyright (c) 1979 Regents of the University of California */
  2. #
  3. /*
  4.  * pi - Pascal interpreter code translator
  5.  *
  6.  * Charles Haley, Bill Joy UCB
  7.  * Version 1.2 January 1979
  8.  */
  9.  
  10. #include "0.h"
  11. #include "opcode.h"
  12.  
  13. #ifdef PI
  14. /*
  15.  * Array of information about pre-defined, block 0 symbols.
  16.  */
  17. int    *biltins[] {
  18.  
  19.     /*
  20.      * Types
  21.      */
  22.     "boolean",
  23.     "char",
  24.     "integer",
  25.     "real",
  26.     "_nil",        /* dummy name */
  27.     0,
  28.  
  29.     /*
  30.      * Ranges
  31.      */
  32.     TINT,        0177777, 0177600, 0, 0177,
  33.     TINT,        0177777, 0100000, 0, 077777,
  34.     TINT,        0100000, 0, 077777, 0177777,
  35.     TCHAR,        0, 0, 0, 127,
  36.     TBOOL,        0, 0, 0, 1,
  37.     TDOUBLE,    0, 0, 0, 0,        /* fake for reals */
  38.     0,
  39.  
  40.     /*
  41.      * Built-in composite types
  42.      */
  43.     "Boolean",
  44.     "intset",
  45.     "alfa",
  46.     "text",
  47.     "input", 
  48.     "output", 
  49.  
  50.     /*
  51.      * Built-in constants
  52.      */
  53.     "true",     TBOOL,    1, 0,
  54.     "false",     TBOOL,    0, 0,
  55.     "minchar",    T1CHAR,    0, 0,
  56.     "maxchar",    T1CHAR,    0177, 0,
  57.     "bell",        T1CHAR,    07, 0,
  58.     "tab",        T1CHAR,    011, 0,
  59.     "minint",    T4INT,    0100000, 0,        /* Must be last 2! */
  60.     "maxint",    T4INT,    077777, 0177777,
  61.     0,
  62.  
  63.     /*
  64.      * Built-in functions
  65.      */
  66. #ifndef PI0
  67.     "abs",        O_ABS2,
  68.     "arctan",    O_ATAN,
  69.     "card",        O_CARD|NSTAND,
  70.     "chr",        O_CHR2,
  71.     "clock",    O_CLCK|NSTAND,
  72.     "cos",        O_COS,
  73.     "eof",        O_EOF,
  74.     "eoln",        O_EOLN,
  75.     "eos",        0,
  76.     "exp",        O_EXP,
  77.     "expo",        O_EXPO|NSTAND,
  78.     "ln",        O_LN,
  79.     "odd",        O_ODD2,
  80.     "ord",        O_ORD2,
  81.     "pred",        O_PRED2,
  82.     "round",    O_ROUND,
  83.     "sin",        O_SIN,
  84.     "sqr",        O_SQR2,
  85.     "sqrt",        O_SQRT,
  86.     "succ",        O_SUCC2,
  87.     "trunc",    O_TRUNC,
  88.     "undefined",    O_UNDEF|NSTAND,
  89.     /*
  90.      * Extensions
  91.      */
  92.     "argc",        O_ARGC|NSTAND,
  93.     "random",    O_RANDOM|NSTAND,
  94.     "seed",        O_SEED|NSTAND,
  95.     "wallclock",    O_WCLCK|NSTAND,
  96.     "sysclock",    O_SCLCK|NSTAND,
  97.     0,
  98.  
  99.     /*
  100.      * Built-in procedures
  101.      */
  102.     "date",        O_DATE|NSTAND,
  103.     "flush",    O_FLUSH|NSTAND,
  104.     "get",         O_GET,
  105.     "getseg",    0,
  106.     "halt",        O_HALT|NSTAND,
  107.     "linelimit",    O_LLIMIT|NSTAND,
  108.     "message",    O_MESSAGE|NSTAND,
  109.     "new",        O_NEW,
  110.     "pack",        O_PACK,
  111.     "page",        O_PAGE,
  112.     "put",        O_PUT,
  113.     "putseg",    0,
  114.     "read",        O_READ4,
  115.     "readln",    O_READLN,
  116.     "remove",    O_REMOVE|NSTAND,
  117.     "reset",    O_RESET,
  118.     "rewrite",    O_REWRITE,
  119.     "time",        O_TIME|NSTAND,
  120.     "unpack",    O_UNPACK,
  121.     "write",    O_WRIT2,
  122.     "writeln",    O_WRITLN,
  123.     /*
  124.      * Extensions
  125.      */
  126.     "argv",        O_ARGV|NSTAND,
  127.     "null",        O_NULL|NSTAND,
  128.     "stlimit",    O_STLIM|NSTAND,
  129.     0,
  130. #else
  131.     "abs",
  132.     "arctan",
  133.     "card",
  134.     "chr",
  135.     "clock",
  136.     "cos",
  137.     "eof",
  138.     "eoln",
  139.     "eos",
  140.     "exp",
  141.     "expo",
  142.     "ln",
  143.     "odd",
  144.     "ord",
  145.     "pred",
  146.     "round",
  147.     "sin",
  148.     "sqr",
  149.     "sqrt",
  150.     "succ",
  151.     "trunc",
  152.     "undefined",
  153.     /*
  154.      * Extensions
  155.      */
  156.     "argc",
  157.     "random",
  158.     "seed",
  159.     "wallclock",
  160.     "sysclock",
  161.     0,
  162.  
  163.     /*
  164.      * Built-in procedures
  165.      */
  166.     "date",
  167.     "flush",
  168.     "get",
  169.     "getseg",
  170.     "halt",
  171.     "linelimit",
  172.     "message",
  173.     "new",
  174.     "pack",
  175.     "page",
  176.     "put",
  177.     "putseg",
  178.     "read",
  179.     "readln",
  180.     "remove",
  181.     "reset",
  182.     "rewrite",
  183.     "time",
  184.     "unpack",
  185.     "write",
  186.     "writeln",
  187.     /*
  188.      * Extensions
  189.      */
  190.     "argv",
  191.     "null",
  192.     "stlimit",
  193.     0,
  194. #endif
  195. };
  196.  
  197. /*
  198.  * NAMELIST SEGMENT DEFINITIONS
  199.  */
  200. struct nls {
  201.     struct nl *nls_low;
  202.     struct nl *nls_high;
  203. } ntab[MAXNL], *nlact;
  204.  
  205. struct    nl nl[INL];
  206. struct    nl *nlp nl;
  207. struct    nls *nlact ntab;
  208. /*
  209.  * Initnl initializes the first namelist segment and then
  210.  * uses the array biltins to initialize the name list for
  211.  * block 0.
  212.  */
  213. initnl()
  214. {
  215.     register int *q;
  216.     register struct nl *p;
  217.     register int i;
  218.  
  219. #ifdef DEBUG
  220.     if (hp21mx) {
  221.         MININT = -32768.;
  222.         MAXINT = 32767.;
  223. #ifndef PI0
  224.         genmx();
  225. #endif
  226.     }
  227. #endif
  228.     ntab[0].nls_low = nl;
  229.     ntab[0].nls_high = &nl[INL];
  230.     defnl(0, 0, 0, 0);
  231.     /*
  232.      * Fundamental types
  233.      */
  234.     for (q = biltins; *q != 0; q++)
  235.         hdefnl(*q, TYPE, nlp, 0);
  236.     q++;
  237.  
  238.     /*
  239.      * Ranges
  240.      */
  241.     while (*q) {
  242.         p = defnl(0, RANGE, nl+*q, 0);
  243.         nl[*q++].type = p;
  244.         for (i = 0; i < 4; i++)
  245.             p->value[i] = *q++;
  246.     }
  247.     q++;
  248.  
  249. #ifdef DEBUG
  250.     if (hp21mx) {
  251.         nl[T4INT].range[0] = MININT;
  252.         nl[T4INT].range[1] = MAXINT;
  253.     }
  254. #endif
  255.  
  256.     /*
  257.      * Pre-defined composite types
  258.      */
  259.     hdefnl(*q++, TYPE, nl+T1BOOL, 0);
  260.     enter(defnl((intset = *q++), TYPE, nlp+1, 0));
  261.     defnl(0, SET, nlp+1, 0);
  262.     defnl(0, RANGE, nl+TINT, 0)->value[3] = 127;
  263.      p=    defnl(0, RANGE, nl+TINT, 0);
  264.     p->value[1] = 1;
  265.     p->value[3] = 10;
  266.     defnl(0, ARRAY, nl+T1CHAR, 1)->chain = p;
  267.     hdefnl(*q++, TYPE, nlp-1, 0);    /* "alfa" */
  268.     hdefnl(*q++, TYPE, nlp+1, 0);    /* "text" */
  269.      p=    defnl(0, FILE, nl+T1CHAR, 0);
  270.     p->nl_flags =| NFILES;
  271. #ifndef PI0
  272.     input = hdefnl(*q++, VAR, p, -2);    /* "input" */
  273.     output = hdefnl(*q++, VAR, p, -4);    /* "output" */
  274. #else
  275.     input = hdefnl(*q++, VAR, p, 0);    /* "input" */
  276.     output = hdefnl(*q++, VAR, p, 0);    /* "output" */
  277. #endif
  278.  
  279.     /*
  280.      * Pre-defined constants
  281.      */
  282.     for (; *q; q =+ 4)
  283.         hdefnl(q[0], CONST, nl+q[1], q[2])->value[1] = q[3];
  284.  
  285. #ifdef DEBUG
  286.     if (hp21mx) {
  287.         nlp[-2].range[0] = MININT;
  288.         nlp[-1].range[0] = MAXINT;
  289.     }
  290. #endif
  291.  
  292.     /*
  293.      * Built-in procedures and functions
  294.      */
  295. #ifndef PI0
  296.     for (q++; *q; q =+ 2)
  297.         hdefnl(q[0], FUNC, 0, q[1]);
  298.     for (q++; *q; q =+ 2)
  299.         hdefnl(q[0], PROC, 0, q[1]);
  300. #else
  301.     for (q++; *q;)
  302.         hdefnl(*q++, FUNC, 0, 0);
  303.     for (q++; *q;)
  304.         hdefnl(*q++, PROC, 0, 0);
  305. #endif
  306. }
  307.  
  308. hdefnl(sym, cls, typ, val)
  309. {
  310.     register struct nl *p;
  311.  
  312. #ifndef PI1
  313.     if (sym)
  314.         hash(sym, 0);
  315. #endif
  316.     p = defnl(sym, cls, typ, val);
  317.     if (sym)
  318.         enter(p);
  319.     return (p);
  320. }
  321.  
  322. /*
  323.  * Free up the name list segments
  324.  * at the end of a statement/proc/func
  325.  * All segments are freed down to the one in which
  326.  * p points.
  327.  */
  328. nlfree(p)
  329.     struct nl *p;
  330. {
  331.  
  332.     nlp = p;
  333.     while (nlact->nls_low > nlp || nlact->nls_high < nlp) {
  334.         free(nlact->nls_low);
  335.         nlact->nls_low = NIL;
  336.         nlact->nls_high = NIL;
  337.         --nlact;
  338.         if (nlact < &ntab[0])
  339.             panic("nlfree");
  340.     }
  341. }
  342. #endif
  343.  
  344. char    VARIABLE[]    "variable";
  345.  
  346. char    *classes[] {
  347.     "undefined",
  348.     "constant",
  349.     "type",
  350.     VARIABLE,
  351.     "array",
  352.     "pointer or file",
  353.     "record",
  354.     "field",
  355.     "procedure",
  356.     "function",
  357.     VARIABLE,
  358.     VARIABLE,
  359.     "pointer",
  360.     "file",
  361.     "set",
  362.     "subrange",
  363.     "label",
  364.     "withptr",
  365.     "scalar",
  366.     "string",
  367.     "program",
  368.     "improper",
  369. #ifdef DEBUG
  370.     "variant",
  371. #endif
  372. };
  373.  
  374. char    snark[]    "SNARK";
  375.  
  376. #ifdef PI
  377. #ifdef DEBUG
  378. char    *ctext[]
  379. {
  380.     "BADUSE",
  381.     "CONST",
  382.     "TYPE",
  383.     "VAR",
  384.     "ARRAY",
  385.     "PTRFILE",
  386.     "RECORD",
  387.     "FIELD",
  388.     "PROC",
  389.     "FUNC",
  390.     "FVAR",
  391.     "REF",
  392.     "PTR",
  393.     "FILE",
  394.     "SET",
  395.     "RANGE",
  396.     "LABEL",
  397.     "WITHPTR",
  398.     "SCAL",
  399.     "STR",
  400.     "PROG",
  401.     "IMPROPER",
  402.     "VARNT"
  403. };
  404.  
  405. char    *stars    "\t***";
  406.  
  407. /*
  408.  * Dump the namelist from the
  409.  * current nlp down to 'to'.
  410.  * All the namelist is dumped if
  411.  * to is NIL.
  412.  */
  413. dumpnl(to, rout)
  414.     struct nl *to;
  415. {
  416.     register struct nl *p;
  417.     register int j;
  418.     struct nls *nlsp;
  419.     int i, v, head;
  420.  
  421.     if (opt('y') == 0)
  422.         return;
  423.     if (to != NIL)
  424.         printf("\n\"%s\" Block=%d\n", rout, cbn);
  425.     nlsp = nlact;
  426.     head = NIL;
  427.     for (p = nlp; p != to;) {
  428.         if (p == nlsp->nls_low) {
  429.             if (nlsp == &ntab[0])
  430.                 break;
  431.             nlsp--;
  432.             p = nlsp->nls_high;
  433.         }
  434.         p--;
  435.         if (head == NIL) {
  436.             printf("\tName\tClass  Bn+Flags\tType\tVal\tChn\n");
  437.             head++;
  438.         }
  439.         printf("%3d:", nloff(p));
  440.         if (p->symbol)
  441.             printf("\t%.7s", p->symbol);
  442.         else
  443.             printf(stars);
  444.         if (p->class)
  445.             printf("\t%s", ctext[p->class]);
  446.         else
  447.             printf(stars);
  448.         if (p->nl_flags) {
  449.             putchar('\t');
  450.             if (p->nl_flags & 037)
  451.                 printf("%d ", p->nl_flags & 037);
  452. #ifndef PI0
  453.             if (p->nl_flags & NMOD)
  454.                 putchar('M');
  455.             if (p->nl_flags & NUSED)
  456.                 putchar('U');
  457. #endif
  458.             if (p->nl_flags & NFILES)
  459.                 putchar('F');
  460.         } else
  461.             printf(stars);
  462.         if (p->type)
  463.             printf("\t[%d]", nloff(p->type));
  464.         else
  465.             printf(stars);
  466.         v = p->value[0];
  467.         switch (p->class) {
  468.             case TYPE:
  469.                 break;
  470.             case VARNT:
  471.                 goto con;
  472.             case CONST:
  473.                 switch (nloff(p->type)) {
  474.                     default:
  475.                         printf("\t%d", v);
  476.                         break;
  477.                     case TDOUBLE:
  478.                         printf("\t%f", p->real);
  479.                         break;
  480.                     case TINT:
  481. con:
  482.                         printf("\t%ld", p->range[0]);
  483.                         break;
  484.                     case TSTR:
  485.                         printf("\t'%s'", v);
  486.                         break;
  487.                     }
  488.                 break;
  489.             case VAR:
  490.             case REF:
  491.             case WITHPTR:
  492.                 printf("\t%d,%d", cbn, v);
  493.                 break;
  494.             case SCAL:
  495.             case RANGE:
  496.                 printf("\t%ld..%ld", p->range[0], p->range[1]);
  497.                 break;
  498.             case RECORD:
  499.                 printf("\t%d(%d)", v, p->value[NL_FLDSZ]);
  500.                 break;
  501.             case FIELD:
  502.                 printf("\t%d", v);
  503.                 break;
  504.             case STR:
  505.                 printf("\t\"%s\"", p->value[1]);
  506.                 goto casedef;
  507.             case FVAR:
  508.             case FUNC:
  509.             case PROC:
  510.             case PROG:
  511.                 if (cbn == 0) {
  512.                     printf("\t<%o>", p->value[0] & 0377);
  513. #ifndef PI0
  514.                     if (p->value[0] & NSTAND)
  515.                         printf("\tNSTAND");
  516. #endif
  517.                     break;
  518.                 }
  519.                 v = p->value[1];
  520.             default:
  521. casedef:
  522.                 if (v)
  523.                     printf("\t<%d>", v);
  524.                 else
  525.                     printf(stars);
  526.         }
  527.         if (p->chain)
  528.             printf("\t[%d]", nloff(p->chain));
  529.         switch (p->class) {
  530.             case RECORD:
  531.                 if (p->value[NL_VARNT])
  532.                     printf("\tVARNT=[%d]", nloff(p->value[NL_VARNT]));
  533.                 if (p->value[NL_TAG])
  534.                     printf(" TAG=[%d]", nloff(p->value[NL_TAG]));
  535.                 break;
  536.             case VARNT:
  537.                 printf("\tVTOREC=[%d]", nloff(p->value[NL_VTOREC]));
  538.                 break;
  539.         }
  540.         putchar('\n');
  541.     }
  542.     if (head == 0)
  543.         printf("\tNo entries\n");
  544. }
  545. #endif
  546.  
  547.  
  548. /*
  549.  * Define a new name list entry
  550.  * with initial symbol, class, type
  551.  * and value[0] as given.  A new name
  552.  * list segment is allocated to hold
  553.  * the next name list slot if necessary.
  554.  */
  555. defnl(sym, cls, typ, val)
  556.     char *sym;
  557.     int cls;
  558.     struct nl *typ;
  559.     int val;
  560. {
  561.     register struct nl *p;
  562.     register int *q, i;
  563.     char *cp;
  564.  
  565.     p = nlp;
  566.  
  567.     /*
  568.      * Zero out this entry
  569.      */
  570.     q = p;
  571.     i = (sizeof *p)/2;
  572.     do
  573.         *q++ = 0;
  574.     while (--i);
  575.  
  576.     /*
  577.      * Insert the values
  578.      */
  579.     p->symbol = sym;
  580.     p->class = cls;
  581.     p->type = typ;
  582.     p->nl_block = cbn;
  583.     p->value[0] = val;
  584.  
  585.     /*
  586.      * Insure that the next namelist
  587.      * entry actually exists. This is
  588.      * really not needed here, it would
  589.      * suffice to do it at entry if we
  590.      * need the slot.  It is done this
  591.      * way because, historically, nlp
  592.      * always pointed at the next namelist
  593.      * slot.
  594.      */
  595.     nlp++;
  596.     if (nlp >= nlact->nls_high) {
  597.         i = NLINC;
  598.         cp = alloc(NLINC * sizeof *nlp);
  599.         if (cp == -1) {
  600.             i = NLINC / 2;
  601.             cp = alloc((NLINC / 2) * sizeof *nlp);
  602.         }
  603.         if (cp == -1) {
  604.             error("Ran out of memory (defnl)");
  605.             pexit(DIED);
  606.         }
  607.         nlact++;
  608.         if (nlact >= &ntab[MAXNL]) {
  609.             error("Ran out of name list tables");
  610.             pexit(DIED);
  611.         }
  612.         nlp = cp;
  613.         nlact->nls_low = nlp;
  614.         nlact->nls_high = nlact->nls_low + i;
  615.     }
  616.     return (p);
  617. }
  618.  
  619. /*
  620.  * Make a duplicate of the argument
  621.  * namelist entry for, e.g., type
  622.  * declarations of the form 'type a = b'
  623.  * and array indicies.
  624.  */
  625. nlcopy(p)
  626.     struct nl *p;
  627. {
  628.     register int *p1, *p2, i;
  629.  
  630.     p1 = p;
  631.     p = p2 = defnl(0, 0, 0, 0);
  632.     i = (sizeof *p)/2;
  633.     do
  634.         *p2++ = *p1++;
  635.     while (--i);
  636.     return (p);
  637. }
  638.  
  639. /*
  640.  * Compute a namelist offset
  641.  */
  642. nloff(p)
  643.     struct nl *p;
  644. {
  645.  
  646.     return (p - nl);
  647. }
  648.  
  649. /*
  650.  * Enter a symbol into the block
  651.  * symbol table.  Symbols are hashed
  652.  * 64 ways based on low 6 bits of the
  653.  * character pointer into the string
  654.  * table.
  655.  */
  656. enter(np)
  657.     struct nl *np;
  658. {
  659.     register struct nl *rp, *hp;
  660.     register struct nl *p;
  661.     int i;
  662.  
  663.     rp = np;
  664.     if (rp == NIL)
  665.         return (NIL);
  666. #ifndef PI1
  667.     if (cbn > 0)
  668.         if (rp->symbol == input->symbol || rp->symbol == output->symbol)
  669.             error("Pre-defined files input and output must not be redefined");
  670. #endif
  671.     i = rp->symbol;
  672.     i =& 077;
  673.     hp = disptab[i];
  674.     if (rp->class != BADUSE && rp->class != FIELD)
  675.     for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)
  676.         if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) {
  677. #ifndef PI1
  678.             error("%s is already defined in this block", rp->symbol);
  679. #endif
  680.             break;
  681.  
  682.         }
  683.     rp->nl_next = hp;
  684.     disptab[i] = rp;
  685.     return (rp);
  686. }
  687. #endif
  688.  
  689. double    MININT        -2147483648.;
  690. double    MAXINT        2147483647.;
  691.