home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / nl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  15.5 KB  |  872 lines
  1. /*-
  2.  * Copyright (c) 1980 The Regents of the University of California.
  3.  * All rights reserved.
  4.  *
  5.  * Redistribution and use in source and binary forms, with or without
  6.  * modification, are permitted provided that the following conditions
  7.  * are met:
  8.  * 1. Redistributions of source code must retain the above copyright
  9.  *    notice, this list of conditions and the following disclaimer.
  10.  * 2. Redistributions in binary form must reproduce the above copyright
  11.  *    notice, this list of conditions and the following disclaimer in the
  12.  *    documentation and/or other materials provided with the distribution.
  13.  * 3. All advertising materials mentioning features or use of this software
  14.  *    must display the following acknowledgement:
  15.  *    This product includes software developed by the University of
  16.  *    California, Berkeley and its contributors.
  17.  * 4. Neither the name of the University nor the names of its contributors
  18.  *    may be used to endorse or promote products derived from this software
  19.  *    without specific prior written permission.
  20.  *
  21.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  22.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  23.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  24.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  25.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  26.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  27.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  29.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  30.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  31.  * SUCH DAMAGE.
  32.  */
  33.  
  34. #ifndef lint
  35. static char sccsid[] = "@(#)nl.c    5.2 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #include "0.h"
  40. #ifdef PI
  41. #include "opcode.h"
  42. #include "objfmt.h"
  43.  
  44. /*
  45.  * NAMELIST SEGMENT DEFINITIONS
  46.  */
  47. struct nls {
  48.     struct nl *nls_low;
  49.     struct nl *nls_high;
  50. } ntab[MAXNL], *nlact;
  51.  
  52. struct    nl nl[INL];
  53. struct    nl *nlp = nl;
  54. struct    nls *nlact = ntab;
  55.  
  56.     /*
  57.      *    all these strings must be places where people can find them
  58.      *    since lookup only looks at the string pointer, not the chars.
  59.      *    see, for example, pTreeInit.
  60.      */
  61.  
  62.     /*
  63.      *    built in constants
  64.      */
  65. char    *in_consts[] = {
  66.         "true" ,
  67.         "false" ,
  68.         "TRUE",
  69.         "FALSE",
  70.         "minint" ,
  71.         "maxint" ,
  72.         "minchar" ,
  73.         "maxchar" ,
  74.         "bell" ,
  75.         "tab" ,
  76.         0
  77.     };
  78.  
  79.     /*
  80.      *    built in simple types
  81.      */
  82. char *in_types[] = 
  83.     {
  84.     "boolean",
  85.     "char",
  86.     "integer",
  87.     "real",
  88.     "_nil",        /* dummy name */
  89.     0
  90.     };
  91.  
  92. int in_rclasses[] =
  93.     {
  94.     TINT , 
  95.     TINT ,
  96.     TINT ,
  97.     TCHAR ,
  98.     TBOOL ,
  99.     TDOUBLE ,
  100.     0
  101.     };
  102.  
  103. long in_ranges[] =
  104.     {
  105.     -128L     , 127L ,
  106.     -32768L     , 32767L ,
  107.     -2147483648L , 2147483647L ,
  108.     0L         , 127L ,
  109.     0L         , 1L ,
  110.     0L         , 0L         /* fake for reals */
  111.     };
  112.  
  113.     /*
  114.      *    built in constructed types
  115.      */
  116. char    *in_ctypes[] = {
  117.         "Boolean" ,
  118.         "intset" ,
  119.         "alfa" ,
  120.         "text" ,
  121.         0
  122.     };
  123.  
  124.     /*
  125.      *    built in variables
  126.      */
  127. char    *in_vars[] = {
  128.         "input" ,
  129.         "output" ,
  130.         0
  131.     };
  132.  
  133.     /*
  134.      *    built in functions 
  135.      */
  136. char *in_funcs[] =
  137.     {
  138.     "abs" ,
  139.     "arctan" ,
  140.     "card" ,
  141.     "chr" ,
  142.     "clock" ,
  143.     "cos" ,
  144.     "eof" ,
  145.     "eoln" ,
  146.     "eos" ,
  147.     "exp" ,
  148.     "expo" ,
  149.     "ln" ,
  150.     "odd" ,
  151.     "ord" ,
  152.     "pred" ,
  153.     "round" ,
  154.     "sin" ,
  155.     "sqr" ,
  156.     "sqrt" ,
  157.     "succ" ,
  158.     "trunc" ,
  159.     "undefined" ,
  160.     /*
  161.      * Extensions
  162.      */
  163.     "argc" ,
  164.     "random" ,
  165.     "seed" ,
  166.     "wallclock" ,
  167.     "sysclock" ,
  168.     0
  169.     };
  170.  
  171.     /*
  172.      * Built-in procedures
  173.      */
  174. char *in_procs[] =
  175.     {
  176.     "assert",
  177.     "date" ,
  178.     "dispose" ,
  179.     "flush" ,
  180.     "get" ,
  181.     "getseg" ,
  182.     "halt" ,
  183.     "linelimit" ,
  184.     "message" ,
  185.     "new" ,
  186.     "pack" ,
  187.     "page" ,
  188.     "put" ,
  189.     "putseg" ,
  190.     "read" ,
  191.     "readln" ,
  192.     "remove" ,
  193.     "reset" ,
  194.     "rewrite" ,
  195.     "time" ,
  196.     "unpack" ,
  197.     "write" ,
  198.     "writeln" ,
  199.     /*
  200.      * Extensions
  201.      */
  202.     "argv" ,
  203.     "null" ,
  204.     "stlimit" ,
  205.     0
  206.     };
  207.  
  208. #ifndef PI0
  209.     /*
  210.      *    and their opcodes
  211.      */
  212. int in_fops[] =
  213.     {
  214.     O_ABS2,
  215.     O_ATAN,
  216.     O_CARD|NSTAND,
  217.     O_CHR2,
  218.     O_CLCK|NSTAND,
  219.     O_COS,
  220.     O_EOF,
  221.     O_EOLN,
  222.     0,
  223.     O_EXP,
  224.     O_EXPO|NSTAND,
  225.     O_LN,
  226.     O_ODD2,
  227.     O_ORD2,
  228.     O_PRED2,
  229.     O_ROUND,
  230.     O_SIN,
  231.     O_SQR2,
  232.     O_SQRT,
  233.     O_SUCC2,
  234.     O_TRUNC,
  235.     O_UNDEF|NSTAND,
  236.     /*
  237.      * Extensions
  238.      */
  239.     O_ARGC|NSTAND,
  240.     O_RANDOM|NSTAND,
  241.     O_SEED|NSTAND,
  242.     O_WCLCK|NSTAND,
  243.     O_SCLCK|NSTAND
  244.     };
  245.  
  246.     /*
  247.      * Built-in procedures
  248.      */
  249. int in_pops[] =
  250.     {
  251.     O_ASRT|NSTAND,
  252.     O_DATE|NSTAND,
  253.     O_DISPOSE,
  254.     O_FLUSH|NSTAND,
  255.     O_GET,
  256.     0,
  257.     O_HALT|NSTAND,
  258.     O_LLIMIT|NSTAND,
  259.     O_MESSAGE|NSTAND,
  260.     O_NEW,
  261.     O_PACK,
  262.     O_PAGE,
  263.     O_PUT,
  264.     0,
  265.     O_READ4,
  266.     O_READLN,
  267.     O_REMOVE|NSTAND,
  268.     O_RESET,
  269.     O_REWRITE,
  270.     O_TIME|NSTAND,
  271.     O_UNPACK,
  272.     O_WRITEF,
  273.     O_WRITLN,
  274.     /*
  275.      * Extensions
  276.      */
  277.     O_ARGV|NSTAND,
  278.     O_ABORT|NSTAND,
  279.     O_STLIM|NSTAND
  280.     };
  281. #endif
  282.  
  283. /*
  284.  * Initnl initializes the first namelist segment and then
  285.  * initializes the name list for block 0.
  286.  */
  287. initnl()
  288.     {
  289.     register char        **cp;
  290.     register struct nl    *np;
  291.     struct nl        *fp;
  292.     int            *ip;
  293.     long            *lp;
  294.  
  295. #ifdef    DEBUG
  296.     if ( hp21mx )
  297.         {
  298.         MININT = -32768.;
  299.         MAXINT = 32767.;
  300. #ifndef    PI0
  301. #ifdef OBJ
  302.         genmx();
  303. #endif OBJ
  304. #endif
  305.         }
  306. #endif
  307.     ntab[0].nls_low = nl;
  308.     ntab[0].nls_high = &nl[INL];
  309.     (void) defnl ( (char *) 0 , 0 , NLNIL , 0 );
  310.  
  311.     /*
  312.      *    Types
  313.      */
  314.     for ( cp = in_types ; *cp != 0 ; cp ++ )
  315.         (void) hdefnl ( *cp , TYPE , nlp , 0 );
  316.  
  317.     /*
  318.      *    Ranges
  319.      */
  320.     lp = in_ranges;
  321.     for ( ip = in_rclasses ; *ip != 0 ; ip ++ )
  322.         {
  323.         np = defnl ( (char *) 0 , RANGE , nl+(*ip) , 0 );
  324.         nl[*ip].type = np;
  325.         np -> range[0] = *lp ++ ;
  326.         np -> range[1] = *lp ++ ;
  327.     
  328.         };
  329.  
  330.     /*
  331.      *    built in constructed types
  332.      */
  333.     
  334.     cp = in_ctypes;
  335.     /*
  336.      *    Boolean = boolean;
  337.      */
  338.     (void) hdefnl ( *cp++ , TYPE , (struct nl *) (nl+T1BOOL) , 0 );
  339.  
  340.     /*
  341.      *    intset = set of 0 .. 127;
  342.      */
  343.     intset = ((struct nl *) *cp++);
  344.     (void) hdefnl( (char *) intset , TYPE , nlp+1 , 0 );
  345.     (void) defnl ( (char *) 0 , SET , nlp+1 , 0 );
  346.     np = defnl ( (char *) 0 , RANGE , nl+TINT , 0 );
  347.     np -> range[0] = 0L;
  348.     np -> range[1] = 127L;
  349.  
  350.     /*
  351.      *    alfa = array [ 1 .. 10 ] of char;
  352.      */
  353.     np = defnl ( (char *) 0 , RANGE , nl+TINT , 0 );
  354.     np -> range[0] = 1L;
  355.     np -> range[1] = 10L;
  356.     defnl ( (char *) 0 , ARRAY , nl+T1CHAR , 1 ) -> chain = np;
  357.     (void) hdefnl ( *cp++ , TYPE , nlp-1 , 0 );
  358.  
  359.     /*
  360.      *    text = file of char;
  361.      */
  362.     (void) hdefnl ( *cp++ , TYPE , nlp+1 , 0 );
  363.     np = defnl ( (char *) 0 , FILET , nl+T1CHAR , 0 );
  364.     np -> nl_flags |= NFILES;
  365.  
  366.     /*
  367.      *    input,output : text;
  368.      */
  369.     cp = in_vars;
  370. #    ifndef    PI0
  371.         input = hdefnl ( *cp++ , VAR , np , INPUT_OFF );
  372.         output = hdefnl (  *cp++ , VAR , np , OUTPUT_OFF );
  373. #    else
  374.         input = hdefnl ( *cp++ , VAR , np , 0 );
  375.         output = hdefnl ( *cp++ , VAR , np , 0 );
  376. #    endif
  377. #    ifdef PC
  378.         input -> extra_flags |= NGLOBAL;
  379.         output -> extra_flags |= NGLOBAL;
  380. #    endif PC
  381.  
  382.     /*
  383.      *    built in constants
  384.      */
  385.     cp = in_consts;
  386.     np = hdefnl ( *cp++ , CONST , nl + TBOOL , 1 );
  387.     fp = hdefnl ( *cp++ , CONST , nl + TBOOL , 0 );
  388.     (nl + TBOOL)->chain = fp;
  389.     fp->chain = np;
  390.     np = hdefnl ( *cp++ , CONST , nl + TBOOL , 1 );
  391.     fp = hdefnl ( *cp++ , CONST , nl + TBOOL , 0 );
  392.     fp->chain = np;
  393.     if (opt('s'))
  394.         (nl + TBOOL)->chain = fp;
  395.     hdefnl ( *cp++ , CONST , nl + T4INT , 0 ) -> range[0] = MININT;
  396.     hdefnl ( *cp++ , CONST , nl + T4INT , 0 ) -> range[0] = MAXINT;
  397.     (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , 0 );
  398.     (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , 127 );
  399.     (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , '\007' );
  400.     (void) hdefnl ( *cp++ , CONST , nl + T1CHAR , '\t' );
  401.  
  402.     /*
  403.      * Built-in functions and procedures
  404.      */
  405. #ifndef PI0
  406.     ip = in_fops;
  407.     for ( cp = in_funcs ; *cp != 0 ; cp ++ )
  408.         (void) hdefnl ( *cp , FUNC , NLNIL , * ip ++ );
  409.     ip = in_pops;
  410.     for ( cp = in_procs ; *cp != 0 ; cp ++ )
  411.         (void) hdefnl ( *cp , PROC , NLNIL , * ip ++ );
  412. #else
  413.     for ( cp = in_funcs ; *cp != 0 ; cp ++ )
  414.         (void) hdefnl ( *cp , FUNC , NLNIL , 0 );
  415.     for ( cp = in_procs ; *cp != 0 , cp ++ )
  416.         (void) hdefnl ( *cp , PROC , NLNIL , 0 );
  417. #endif
  418. #    ifdef PTREE
  419.         pTreeInit();
  420. #    endif
  421.     }
  422.  
  423. struct nl *
  424. hdefnl(sym, cls, typ, val)
  425.     char *sym;
  426.     int  cls;
  427.     struct nl *typ;
  428.     int val;
  429. {
  430.     register struct nl *p;
  431.  
  432. #ifndef PI1
  433.     if (sym)
  434.         (void) hash(sym, 0);
  435. #endif
  436.     p = defnl(sym, cls, typ, val);
  437.     if (sym)
  438.         (void) enter(p);
  439.     return (p);
  440. }
  441.  
  442. /*
  443.  * Free up the name list segments
  444.  * at the end of a statement/proc/func
  445.  * All segments are freed down to the one in which
  446.  * p points.
  447.  */
  448. nlfree(p)
  449.     struct nl *p;
  450. {
  451.  
  452.     nlp = p;
  453.     while (nlact->nls_low > nlp || nlact->nls_high < nlp) {
  454.         free((char *) nlact->nls_low);
  455.         nlact->nls_low = NIL;
  456.         nlact->nls_high = NIL;
  457.         --nlact;
  458.         if (nlact < &ntab[0])
  459.             panic("nlfree");
  460.     }
  461. }
  462. #endif PI
  463.  
  464.  
  465. #ifndef PC
  466. #ifndef OBJ
  467. char    *VARIABLE    = "variable";
  468. #endif PC
  469. #endif OBJ
  470.  
  471. char    *classes[ ] = {
  472.     "undefined",
  473.     "constant",
  474.     "type",
  475.     "variable",    /*    VARIABLE    */
  476.     "array",
  477.     "pointer or file",
  478.     "record",
  479.     "field",
  480.     "procedure",
  481.     "function",
  482.     "variable",    /*    VARIABLE    */
  483.     "variable",    /*    VARIABLE    */
  484.     "pointer",
  485.     "file",
  486.     "set",
  487.     "subrange",
  488.     "label",
  489.     "withptr",
  490.     "scalar",
  491.     "string",
  492.     "program",
  493.     "improper",
  494.     "variant",
  495.     "formal procedure",
  496.     "formal function"
  497. };
  498.  
  499. #ifndef PC
  500. #ifndef OBJ
  501. char    *snark    = "SNARK";
  502. #endif
  503. #endif
  504.  
  505. #ifdef PI
  506. #ifdef DEBUG
  507. char    *ctext[] =
  508. {
  509.     "BADUSE",
  510.     "CONST",
  511.     "TYPE",
  512.     "VAR",
  513.     "ARRAY",
  514.     "PTRFILE",
  515.     "RECORD",
  516.     "FIELD",
  517.     "PROC",
  518.     "FUNC",
  519.     "FVAR",
  520.     "REF",
  521.     "PTR",
  522.     "FILET",
  523.     "SET",
  524.     "RANGE",
  525.     "LABEL",
  526.     "WITHPTR",
  527.     "SCAL",
  528.     "STR",
  529.     "PROG",
  530.     "IMPROPER",
  531.     "VARNT",
  532.     "FPROC",
  533.     "FFUNC",
  534.     "CRANGE"
  535. };
  536.  
  537. char    *stars    = "\t***";
  538.  
  539. /*
  540.  * Dump the namelist from the
  541.  * current nlp down to 'to'.
  542.  * All the namelist is dumped if
  543.  * to is NIL.
  544.  */
  545. /*VARARGS*/
  546. dumpnl(to, rout)
  547.     struct nl *to;
  548. {
  549.     register struct nl *p;
  550.     struct nls *nlsp;
  551.     int v, head;
  552.  
  553.     if (opt('y') == 0)
  554.         return;
  555.     if (to != NIL)
  556.         printf("\n\"%s\" Block=%d\n", rout, cbn);
  557.     nlsp = nlact;
  558.     head = NIL;
  559.     for (p = nlp; p != to;) {
  560.         if (p == nlsp->nls_low) {
  561.             if (nlsp == &ntab[0])
  562.                 break;
  563.             nlsp--;
  564.             p = nlsp->nls_high;
  565.         }
  566.         p--;
  567.         if (head == NIL) {
  568.             printf("\tName\tClass  Bn+Flags\tType\tVal\tChn\n");
  569.             head++;
  570.         }
  571.         printf("%3d:", nloff(p));
  572.         if (p->symbol)
  573.             printf("\t%.7s", p->symbol);
  574.         else
  575.             printf(stars);
  576.         if (p->class)
  577.             printf("\t%s", ctext[p->class]);
  578.         else
  579.             printf(stars);
  580.         if (p->nl_flags) {
  581.             pchr('\t');
  582.             if (p->nl_flags & 037)
  583.                 printf("%d ", p->nl_flags & 037);
  584. #ifndef PI0
  585.             if (p->nl_flags & NMOD)
  586.                 pchr('M');
  587.             if (p->nl_flags & NUSED)
  588.                 pchr('U');
  589. #endif
  590.             if (p->nl_flags & NFILES)
  591.                 pchr('F');
  592.         } else
  593.             printf(stars);
  594.         if (p->type)
  595.             printf("\t[%d]", nloff(p->type));
  596.         else
  597.             printf(stars);
  598.         v = p->value[0];
  599.         switch (p->class) {
  600.             case TYPE:
  601.                 break;
  602.             case VARNT:
  603.                 goto con;
  604.             case CONST:
  605.                 switch (nloff(p->type)) {
  606.                     default:
  607.                         printf("\t%d", v);
  608.                         break;
  609.                     case TDOUBLE:
  610.                         printf("\t%f", p->real);
  611.                         break;
  612.                     case TINT:
  613.                     case T4INT:
  614. con:
  615.                         printf("\t%ld", p->range[0]);
  616.                         break;
  617.                     case TSTR:
  618.                         printf("\t'%s'", p->ptr[0]);
  619.                         break;
  620.                     }
  621.                 break;
  622.             case VAR:
  623.             case REF:
  624.             case WITHPTR:
  625.             case FFUNC:
  626.             case FPROC:
  627.                 printf("\t%d,%d", cbn, v);
  628.                 break;
  629.             case SCAL:
  630.             case RANGE:
  631.                 printf("\t%ld..%ld", p->range[0], p->range[1]);
  632.                 break;
  633.             case CRANGE:
  634.                 printf("\t%s..%s", p->nptr[0]->symbol,
  635.                     p->nptr[1]->symbol);
  636.                 break;
  637.             case RECORD:
  638.                 printf("\t%d", v);
  639.                 break;
  640.             case FIELD:
  641.                 printf("\t%d", v);
  642.                 break;
  643.             case STR:
  644.                 printf("\t|%d|", p->value[0]);
  645.                 break;
  646.             case FVAR:
  647.             case FUNC:
  648.             case PROC:
  649.             case PROG:
  650.                 if (cbn == 0) {
  651.                     printf("\t<%o>", p->value[0] & 0377);
  652. #ifndef PI0
  653.                     if (p->value[0] & NSTAND)
  654.                         printf("\tNSTAND");
  655. #endif
  656.                     break;
  657.                 }
  658.                 v = p->value[1];
  659.             default:
  660.  
  661.                 if (v)
  662.                     printf("\t<%d>", v);
  663.                 else
  664.                     printf(stars);
  665.         }
  666.         if (p->chain)
  667.             printf("\t[%d]", nloff(p->chain));
  668.         switch (p->class) {
  669.             case RECORD:
  670.                 printf("\tALIGN=%d", p->align_info);
  671.                 if (p->ptr[NL_FIELDLIST]) {
  672.                     printf(" FLIST=[%d]",
  673.                     nloff(p->ptr[NL_FIELDLIST]));
  674.                 } else {
  675.                     printf(" FLIST=[]");
  676.                 }
  677.                 if (p->ptr[NL_TAG]) {
  678.                     printf(" TAG=[%d]",
  679.                     nloff(p->ptr[NL_TAG]));
  680.                 } else {
  681.                     printf(" TAG=[]");
  682.                 }
  683.                 if (p->ptr[NL_VARNT]) {
  684.                     printf(" VARNT=[%d]",
  685.                     nloff(p->ptr[NL_VARNT]));
  686.                 } else {
  687.                     printf(" VARNT=[]");
  688.                 }
  689.                 break;
  690.             case FIELD:
  691.                 if (p->ptr[NL_FIELDLIST]) {
  692.                     printf("\tFLIST=[%d]",
  693.                     nloff(p->ptr[NL_FIELDLIST]));
  694.                 } else {
  695.                     printf("\tFLIST=[]");
  696.                 }
  697.                 break;
  698.             case VARNT:
  699.                 printf("\tVTOREC=[%d]",
  700.                     nloff(p->ptr[NL_VTOREC]));
  701.                 break;
  702.         }
  703. #        ifdef PC
  704.             if ( p -> extra_flags != 0 ) {
  705.             pchr( '\t' );
  706.             if ( p -> extra_flags & NEXTERN )
  707.                 printf( "NEXTERN " );
  708.             if ( p -> extra_flags & NLOCAL )
  709.                 printf( "NLOCAL " );
  710.             if ( p -> extra_flags & NPARAM )
  711.                 printf( "NPARAM " );
  712.             if ( p -> extra_flags & NGLOBAL )
  713.                 printf( "NGLOBAL " );
  714.             if ( p -> extra_flags & NREGVAR )
  715.                 printf( "NREGVAR " );
  716.             }
  717. #        endif PC
  718. #        ifdef PTREE
  719.             pchr( '\t' );
  720.             pPrintPointer( stdout , "%s" , p -> inTree );
  721. #        endif
  722.         pchr('\n');
  723.     }
  724.     if (head == 0)
  725.         printf("\tNo entries\n");
  726. }
  727. #endif
  728.  
  729.  
  730. /*
  731.  * Define a new name list entry
  732.  * with initial symbol, class, type
  733.  * and value[0] as given.  A new name
  734.  * list segment is allocated to hold
  735.  * the next name list slot if necessary.
  736.  */
  737. struct nl *
  738. defnl(sym, cls, typ, val)
  739.     char *sym;
  740.     int cls;
  741.     struct nl *typ;
  742.     int val;
  743. {
  744.     register struct nl *p;
  745.     register int *q, i;
  746.     char *cp;
  747.  
  748.     p = nlp;
  749.  
  750.     /*
  751.      * Zero out this entry
  752.      */
  753.     q = ((int *) p);
  754.     i = (sizeof *p)/(sizeof (int));
  755.     do
  756.         *q++ = 0;
  757.     while (--i);
  758.  
  759.     /*
  760.      * Insert the values
  761.      */
  762.     p->symbol = sym;
  763.     p->class = cls;
  764.     p->type = typ;
  765.     p->nl_block = cbn;
  766.     p->value[0] = val;
  767.  
  768.     /*
  769.      * Insure that the next namelist
  770.      * entry actually exists. This is
  771.      * really not needed here, it would
  772.      * suffice to do it at entry if we
  773.      * need the slot.  It is done this
  774.      * way because, historically, nlp
  775.      * always pointed at the next namelist
  776.      * slot.
  777.      */
  778.     nlp++;
  779.     if (nlp >= nlact->nls_high) {
  780.         i = NLINC;
  781.         cp = (char *) malloc(NLINC * sizeof *nlp);
  782.         if (cp == 0) {
  783.             i = NLINC / 2;
  784.             cp = (char *) malloc((NLINC / 2) * sizeof *nlp);
  785.         }
  786.         if (cp == 0) {
  787.             error("Ran out of memory (defnl)");
  788.             pexit(DIED);
  789.         }
  790.         nlact++;
  791.         if (nlact >= &ntab[MAXNL]) {
  792.             error("Ran out of name list tables");
  793.             pexit(DIED);
  794.         }
  795.         nlp = (struct nl *) cp;
  796.         nlact->nls_low = nlp;
  797.         nlact->nls_high = nlact->nls_low + i;
  798.     }
  799.     return (p);
  800. }
  801.  
  802. /*
  803.  * Make a duplicate of the argument
  804.  * namelist entry for, e.g., type
  805.  * declarations of the form 'type a = b'
  806.  * and array indicies.
  807.  */
  808. struct nl *
  809. nlcopy(p)
  810.     struct nl *p;
  811. {
  812.     register struct nl *p1, *p2;
  813.  
  814.     p1 = p;
  815.     p2 = defnl((char *) 0, 0, NLNIL, 0);
  816.     *p2 = *p1;
  817.     p2->chain = NLNIL;
  818.     return (p2);
  819. }
  820.  
  821. /*
  822.  * Compute a namelist offset
  823.  */
  824. nloff(p)
  825.     struct nl *p;
  826. {
  827.  
  828.     return (p - nl);
  829. }
  830.  
  831. /*
  832.  * Enter a symbol into the block
  833.  * symbol table.  Symbols are hashed
  834.  * 64 ways based on low 6 bits of the
  835.  * character pointer into the string
  836.  * table.
  837.  */
  838. struct nl *
  839. enter(np)
  840.     struct nl *np;
  841. {
  842.     register struct nl *rp, *hp;
  843.     register struct nl *p;
  844.     int i;
  845.  
  846.     rp = np;
  847.     if (rp == NIL)
  848.         return (NIL);
  849. #ifndef PI1
  850.     if (cbn > 0)
  851.         if (rp->symbol == input->symbol || rp->symbol == output->symbol)
  852.             error("Pre-defined files input and output must not be redefined");
  853. #endif
  854.     i = (int) rp->symbol;
  855.     i &= 077;
  856.     hp = disptab[i];
  857.     if (rp->class != BADUSE && rp->class != FIELD)
  858.     for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next)
  859.         if (p->symbol == rp->symbol && p->symbol != NIL &&
  860.             p->class != BADUSE && p->class != FIELD) {
  861. #ifndef PI1
  862.             error("%s is already defined in this block", rp->symbol);
  863. #endif
  864.             break;
  865.  
  866.         }
  867.     rp->nl_next = hp;
  868.     disptab[i] = rp;
  869.     return (rp);
  870. }
  871. #endif
  872.