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