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