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