1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)nl.c 1.14 09/19/83"; 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 }; 504 505 char *stars = "\t***"; 506 507 /* 508 * Dump the namelist from the 509 * current nlp down to 'to'. 510 * All the namelist is dumped if 511 * to is NIL. 512 */ 513 /*VARARGS*/ 514 dumpnl(to, rout) 515 struct nl *to; 516 { 517 register struct nl *p; 518 struct nls *nlsp; 519 int v, head; 520 521 if (opt('y') == 0) 522 return; 523 if (to != NIL) 524 printf("\n\"%s\" Block=%d\n", rout, cbn); 525 nlsp = nlact; 526 head = NIL; 527 for (p = nlp; p != to;) { 528 if (p == nlsp->nls_low) { 529 if (nlsp == &ntab[0]) 530 break; 531 nlsp--; 532 p = nlsp->nls_high; 533 } 534 p--; 535 if (head == NIL) { 536 printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n"); 537 head++; 538 } 539 printf("%3d:", nloff(p)); 540 if (p->symbol) 541 printf("\t%.7s", p->symbol); 542 else 543 printf(stars); 544 if (p->class) 545 printf("\t%s", ctext[p->class]); 546 else 547 printf(stars); 548 if (p->nl_flags) { 549 pchr('\t'); 550 if (p->nl_flags & 037) 551 printf("%d ", p->nl_flags & 037); 552 #ifndef PI0 553 if (p->nl_flags & NMOD) 554 pchr('M'); 555 if (p->nl_flags & NUSED) 556 pchr('U'); 557 #endif 558 if (p->nl_flags & NFILES) 559 pchr('F'); 560 } else 561 printf(stars); 562 if (p->type) 563 printf("\t[%d]", nloff(p->type)); 564 else 565 printf(stars); 566 v = p->value[0]; 567 switch (p->class) { 568 case TYPE: 569 break; 570 case VARNT: 571 goto con; 572 case CONST: 573 switch (nloff(p->type)) { 574 default: 575 printf("\t%d", v); 576 break; 577 case TDOUBLE: 578 printf("\t%f", p->real); 579 break; 580 case TINT: 581 case T4INT: 582 con: 583 printf("\t%ld", p->range[0]); 584 break; 585 case TSTR: 586 printf("\t'%s'", p->ptr[0]); 587 break; 588 } 589 break; 590 case VAR: 591 case REF: 592 case WITHPTR: 593 case FFUNC: 594 case FPROC: 595 printf("\t%d,%d", cbn, v); 596 break; 597 case SCAL: 598 case RANGE: 599 printf("\t%ld..%ld", p->range[0], p->range[1]); 600 break; 601 case RECORD: 602 printf("\t%d", v); 603 break; 604 case FIELD: 605 printf("\t%d", v); 606 break; 607 case STR: 608 printf("\t|%d|", p->value[0]); 609 break; 610 case FVAR: 611 case FUNC: 612 case PROC: 613 case PROG: 614 if (cbn == 0) { 615 printf("\t<%o>", p->value[0] & 0377); 616 #ifndef PI0 617 if (p->value[0] & NSTAND) 618 printf("\tNSTAND"); 619 #endif 620 break; 621 } 622 v = p->value[1]; 623 default: 624 625 if (v) 626 printf("\t<%d>", v); 627 else 628 printf(stars); 629 } 630 if (p->chain) 631 printf("\t[%d]", nloff(p->chain)); 632 switch (p->class) { 633 case RECORD: 634 printf("\tALIGN=%d", p->align_info); 635 if (p->ptr[NL_FIELDLIST]) { 636 printf(" FLIST=[%d]", 637 nloff(p->ptr[NL_FIELDLIST])); 638 } else { 639 printf(" FLIST=[]"); 640 } 641 if (p->ptr[NL_TAG]) { 642 printf(" TAG=[%d]", 643 nloff(p->ptr[NL_TAG])); 644 } else { 645 printf(" TAG=[]"); 646 } 647 if (p->ptr[NL_VARNT]) { 648 printf(" VARNT=[%d]", 649 nloff(p->ptr[NL_VARNT])); 650 } else { 651 printf(" VARNT=[]"); 652 } 653 break; 654 case FIELD: 655 if (p->ptr[NL_FIELDLIST]) { 656 printf("\tFLIST=[%d]", 657 nloff(p->ptr[NL_FIELDLIST])); 658 } else { 659 printf("\tFLIST=[]"); 660 } 661 break; 662 case VARNT: 663 printf("\tVTOREC=[%d]", 664 nloff(p->ptr[NL_VTOREC])); 665 break; 666 } 667 # ifdef PC 668 if ( p -> extra_flags != 0 ) { 669 pchr( '\t' ); 670 if ( p -> extra_flags & NEXTERN ) 671 printf( "NEXTERN " ); 672 if ( p -> extra_flags & NLOCAL ) 673 printf( "NLOCAL " ); 674 if ( p -> extra_flags & NPARAM ) 675 printf( "NPARAM " ); 676 if ( p -> extra_flags & NGLOBAL ) 677 printf( "NGLOBAL " ); 678 if ( p -> extra_flags & NREGVAR ) 679 printf( "NREGVAR " ); 680 } 681 # endif PC 682 # ifdef PTREE 683 pchr( '\t' ); 684 pPrintPointer( stdout , "%s" , p -> inTree ); 685 # endif 686 pchr('\n'); 687 } 688 if (head == 0) 689 printf("\tNo entries\n"); 690 } 691 #endif 692 693 694 /* 695 * Define a new name list entry 696 * with initial symbol, class, type 697 * and value[0] as given. A new name 698 * list segment is allocated to hold 699 * the next name list slot if necessary. 700 */ 701 struct nl * 702 defnl(sym, cls, typ, val) 703 char *sym; 704 int cls; 705 struct nl *typ; 706 int val; 707 { 708 register struct nl *p; 709 register int *q, i; 710 char *cp; 711 712 p = nlp; 713 714 /* 715 * Zero out this entry 716 */ 717 q = ((int *) p); 718 i = (sizeof *p)/(sizeof (int)); 719 do 720 *q++ = 0; 721 while (--i); 722 723 /* 724 * Insert the values 725 */ 726 p->symbol = sym; 727 p->class = cls; 728 p->type = typ; 729 p->nl_block = cbn; 730 p->value[0] = val; 731 732 /* 733 * Insure that the next namelist 734 * entry actually exists. This is 735 * really not needed here, it would 736 * suffice to do it at entry if we 737 * need the slot. It is done this 738 * way because, historically, nlp 739 * always pointed at the next namelist 740 * slot. 741 */ 742 nlp++; 743 if (nlp >= nlact->nls_high) { 744 i = NLINC; 745 cp = (char *) malloc(NLINC * sizeof *nlp); 746 if (cp == 0) { 747 i = NLINC / 2; 748 cp = (char *) malloc((NLINC / 2) * sizeof *nlp); 749 } 750 if (cp == 0) { 751 error("Ran out of memory (defnl)"); 752 pexit(DIED); 753 } 754 nlact++; 755 if (nlact >= &ntab[MAXNL]) { 756 error("Ran out of name list tables"); 757 pexit(DIED); 758 } 759 nlp = (struct nl *) cp; 760 nlact->nls_low = nlp; 761 nlact->nls_high = nlact->nls_low + i; 762 } 763 return (p); 764 } 765 766 /* 767 * Make a duplicate of the argument 768 * namelist entry for, e.g., type 769 * declarations of the form 'type a = b' 770 * and array indicies. 771 */ 772 struct nl * 773 nlcopy(p) 774 struct nl *p; 775 { 776 register struct nl *p1, *p2; 777 register int i; 778 779 p1 = p; 780 p = p2 = defnl((char *) 0, 0, NLNIL, 0); 781 i = (sizeof *p)/(sizeof (int)); 782 do 783 *p2++ = *p1++; 784 while (--i); 785 p->chain = NIL; 786 return (p); 787 } 788 789 /* 790 * Compute a namelist offset 791 */ 792 nloff(p) 793 struct nl *p; 794 { 795 796 return (p - nl); 797 } 798 799 /* 800 * Enter a symbol into the block 801 * symbol table. Symbols are hashed 802 * 64 ways based on low 6 bits of the 803 * character pointer into the string 804 * table. 805 */ 806 struct nl * 807 enter(np) 808 struct nl *np; 809 { 810 register struct nl *rp, *hp; 811 register struct nl *p; 812 int i; 813 814 rp = np; 815 if (rp == NIL) 816 return (NIL); 817 #ifndef PI1 818 if (cbn > 0) 819 if (rp->symbol == input->symbol || rp->symbol == output->symbol) 820 error("Pre-defined files input and output must not be redefined"); 821 #endif 822 i = (int) rp->symbol; 823 i &= 077; 824 hp = disptab[i]; 825 if (rp->class != BADUSE && rp->class != FIELD) 826 for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next) 827 if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) { 828 #ifndef PI1 829 error("%s is already defined in this block", rp->symbol); 830 #endif 831 break; 832 833 } 834 rp->nl_next = hp; 835 disptab[i] = rp; 836 return (rp); 837 } 838 #endif 839