2.9BSD - /usr/src/ucb/pascal/pi/nl.c

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

Defined functions

Defined variables

Defined struct's