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