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