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