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