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

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

Defined functions

Defined variables

Defined struct's