1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)nl.c 1.8 08/27/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(%d)", v, p->value[NL_FLDSZ]); 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 if (p->ptr[NL_VARNT]) 619 printf("\tVARNT=[%d]", nloff(p->ptr[NL_VARNT])); 620 if (p->ptr[NL_TAG]) 621 printf(" TAG=[%d]", nloff(p->ptr[NL_TAG])); 622 break; 623 case VARNT: 624 printf("\tVTOREC=[%d]", nloff(p->ptr[NL_VTOREC])); 625 break; 626 } 627 # ifdef PC 628 if ( p -> extra_flags != 0 ) { 629 pchr( '\t' ); 630 if ( p -> extra_flags & NEXTERN ) 631 printf( "NEXTERN " ); 632 if ( p -> extra_flags & NLOCAL ) 633 printf( "NLOCAL " ); 634 if ( p -> extra_flags & NPARAM ) 635 printf( "NPARAM " ); 636 if ( p -> extra_flags & NGLOBAL ) 637 printf( "NGLOBAL " ); 638 if ( p -> extra_flags & NREGVAR ) 639 printf( "NREGVAR " ); 640 } 641 # endif PC 642 # ifdef PTREE 643 pchr( '\t' ); 644 pPrintPointer( stdout , "%s" , p -> inTree ); 645 # endif 646 pchr('\n'); 647 } 648 if (head == 0) 649 printf("\tNo entries\n"); 650 } 651 #endif 652 653 654 /* 655 * Define a new name list entry 656 * with initial symbol, class, type 657 * and value[0] as given. A new name 658 * list segment is allocated to hold 659 * the next name list slot if necessary. 660 */ 661 struct nl * 662 defnl(sym, cls, typ, val) 663 char *sym; 664 int cls; 665 struct nl *typ; 666 int val; 667 { 668 register struct nl *p; 669 register int *q, i; 670 char *cp; 671 672 p = nlp; 673 674 /* 675 * Zero out this entry 676 */ 677 q = p; 678 i = (sizeof *p)/(sizeof (int)); 679 do 680 *q++ = 0; 681 while (--i); 682 683 /* 684 * Insert the values 685 */ 686 p->symbol = sym; 687 p->class = cls; 688 p->type = typ; 689 p->nl_block = cbn; 690 p->value[0] = val; 691 692 /* 693 * Insure that the next namelist 694 * entry actually exists. This is 695 * really not needed here, it would 696 * suffice to do it at entry if we 697 * need the slot. It is done this 698 * way because, historically, nlp 699 * always pointed at the next namelist 700 * slot. 701 */ 702 nlp++; 703 if (nlp >= nlact->nls_high) { 704 i = NLINC; 705 cp = malloc(NLINC * sizeof *nlp); 706 if (cp == 0) { 707 i = NLINC / 2; 708 cp = malloc((NLINC / 2) * sizeof *nlp); 709 } 710 if (cp == 0) { 711 error("Ran out of memory (defnl)"); 712 pexit(DIED); 713 } 714 nlact++; 715 if (nlact >= &ntab[MAXNL]) { 716 error("Ran out of name list tables"); 717 pexit(DIED); 718 } 719 nlp = cp; 720 nlact->nls_low = nlp; 721 nlact->nls_high = nlact->nls_low + i; 722 } 723 return (p); 724 } 725 726 /* 727 * Make a duplicate of the argument 728 * namelist entry for, e.g., type 729 * declarations of the form 'type a = b' 730 * and array indicies. 731 */ 732 struct nl * 733 nlcopy(p) 734 struct nl *p; 735 { 736 register int *p1, *p2, i; 737 738 p1 = p; 739 p = p2 = defnl(0, 0, 0, 0); 740 i = (sizeof *p)/(sizeof (int)); 741 do 742 *p2++ = *p1++; 743 while (--i); 744 p->chain = NIL; 745 return (p); 746 } 747 748 /* 749 * Compute a namelist offset 750 */ 751 nloff(p) 752 struct nl *p; 753 { 754 755 return (p - nl); 756 } 757 758 /* 759 * Enter a symbol into the block 760 * symbol table. Symbols are hashed 761 * 64 ways based on low 6 bits of the 762 * character pointer into the string 763 * table. 764 */ 765 struct nl * 766 enter(np) 767 struct nl *np; 768 { 769 register struct nl *rp, *hp; 770 register struct nl *p; 771 int i; 772 773 rp = np; 774 if (rp == NIL) 775 return (NIL); 776 #ifndef PI1 777 if (cbn > 0) 778 if (rp->symbol == input->symbol || rp->symbol == output->symbol) 779 error("Pre-defined files input and output must not be redefined"); 780 #endif 781 i = rp->symbol; 782 i &= 077; 783 hp = disptab[i]; 784 if (rp->class != BADUSE && rp->class != FIELD) 785 for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next) 786 if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) { 787 #ifndef PI1 788 error("%s is already defined in this block", rp->symbol); 789 #endif 790 break; 791 792 } 793 rp->nl_next = hp; 794 disptab[i] = rp; 795 return (rp); 796 } 797 #endif 798