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