1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)nl.c 1.1 08/27/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, 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 #ifdef DEBUG 444 ,"variant" 445 #endif 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 }; 478 479 char *stars = "\t***"; 480 481 /* 482 * Dump the namelist from the 483 * current nlp down to 'to'. 484 * All the namelist is dumped if 485 * to is NIL. 486 */ 487 dumpnl(to, rout) 488 struct nl *to; 489 { 490 register struct nl *p; 491 register int j; 492 struct nls *nlsp; 493 int i, v, head; 494 495 if (opt('y') == 0) 496 return; 497 if (to != NIL) 498 printf("\n\"%s\" Block=%d\n", rout, cbn); 499 nlsp = nlact; 500 head = NIL; 501 for (p = nlp; p != to;) { 502 if (p == nlsp->nls_low) { 503 if (nlsp == &ntab[0]) 504 break; 505 nlsp--; 506 p = nlsp->nls_high; 507 } 508 p--; 509 if (head == NIL) { 510 printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n"); 511 head++; 512 } 513 printf("%3d:", nloff(p)); 514 if (p->symbol) 515 printf("\t%.7s", p->symbol); 516 else 517 printf(stars); 518 if (p->class) 519 printf("\t%s", ctext[p->class]); 520 else 521 printf(stars); 522 if (p->nl_flags) { 523 pchr('\t'); 524 if (p->nl_flags & 037) 525 printf("%d ", p->nl_flags & 037); 526 #ifndef PI0 527 if (p->nl_flags & NMOD) 528 pchr('M'); 529 if (p->nl_flags & NUSED) 530 pchr('U'); 531 #endif 532 if (p->nl_flags & NFILES) 533 pchr('F'); 534 } else 535 printf(stars); 536 if (p->type) 537 printf("\t[%d]", nloff(p->type)); 538 else 539 printf(stars); 540 v = p->value[0]; 541 switch (p->class) { 542 case TYPE: 543 break; 544 case VARNT: 545 goto con; 546 case CONST: 547 switch (nloff(p->type)) { 548 default: 549 printf("\t%d", v); 550 break; 551 case TDOUBLE: 552 printf("\t%f", p->real); 553 break; 554 case TINT: 555 case T4INT: 556 con: 557 printf("\t%ld", p->range[0]); 558 break; 559 case TSTR: 560 printf("\t'%s'", p->ptr[0]); 561 break; 562 } 563 break; 564 case VAR: 565 case REF: 566 case WITHPTR: 567 printf("\t%d,%d", cbn, v); 568 break; 569 case SCAL: 570 case RANGE: 571 printf("\t%ld..%ld", p->range[0], p->range[1]); 572 break; 573 case RECORD: 574 printf("\t%d(%d)", v, p->value[NL_FLDSZ]); 575 break; 576 case FIELD: 577 printf("\t%d", v); 578 break; 579 case STR: 580 printf("\t|%d|", p->value[0]); 581 break; 582 case FVAR: 583 case FUNC: 584 case PROC: 585 case PROG: 586 if (cbn == 0) { 587 printf("\t<%o>", p->value[0] & 0377); 588 #ifndef PI0 589 if (p->value[0] & NSTAND) 590 printf("\tNSTAND"); 591 #endif 592 break; 593 } 594 v = p->value[1]; 595 default: 596 casedef: 597 if (v) 598 printf("\t<%d>", v); 599 else 600 printf(stars); 601 } 602 if (p->chain) 603 printf("\t[%d]", nloff(p->chain)); 604 switch (p->class) { 605 case RECORD: 606 if (p->ptr[NL_VARNT]) 607 printf("\tVARNT=[%d]", nloff(p->ptr[NL_VARNT])); 608 if (p->ptr[NL_TAG]) 609 printf(" TAG=[%d]", nloff(p->ptr[NL_TAG])); 610 break; 611 case VARNT: 612 printf("\tVTOREC=[%d]", nloff(p->ptr[NL_VTOREC])); 613 break; 614 } 615 # ifdef PTREE 616 pchr( '\t' ); 617 pPrintPointer( stdout , "%s" , p -> inTree ); 618 # endif 619 pchr('\n'); 620 } 621 if (head == 0) 622 printf("\tNo entries\n"); 623 } 624 #endif 625 626 627 /* 628 * Define a new name list entry 629 * with initial symbol, class, type 630 * and value[0] as given. A new name 631 * list segment is allocated to hold 632 * the next name list slot if necessary. 633 */ 634 struct nl * 635 defnl(sym, cls, typ, val) 636 char *sym; 637 int cls; 638 struct nl *typ; 639 int val; 640 { 641 register struct nl *p; 642 register int *q, i; 643 char *cp; 644 645 p = nlp; 646 647 /* 648 * Zero out this entry 649 */ 650 q = p; 651 i = (sizeof *p)/(sizeof (int)); 652 do 653 *q++ = 0; 654 while (--i); 655 656 /* 657 * Insert the values 658 */ 659 p->symbol = sym; 660 p->class = cls; 661 p->type = typ; 662 p->nl_block = cbn; 663 p->value[0] = val; 664 665 /* 666 * Insure that the next namelist 667 * entry actually exists. This is 668 * really not needed here, it would 669 * suffice to do it at entry if we 670 * need the slot. It is done this 671 * way because, historically, nlp 672 * always pointed at the next namelist 673 * slot. 674 */ 675 nlp++; 676 if (nlp >= nlact->nls_high) { 677 i = NLINC; 678 cp = malloc(NLINC * sizeof *nlp); 679 if (cp == -1) { 680 i = NLINC / 2; 681 cp = malloc((NLINC / 2) * sizeof *nlp); 682 } 683 if (cp == -1) { 684 error("Ran out of memory (defnl)"); 685 pexit(DIED); 686 } 687 nlact++; 688 if (nlact >= &ntab[MAXNL]) { 689 error("Ran out of name list tables"); 690 pexit(DIED); 691 } 692 nlp = cp; 693 nlact->nls_low = nlp; 694 nlact->nls_high = nlact->nls_low + i; 695 } 696 return (p); 697 } 698 699 /* 700 * Make a duplicate of the argument 701 * namelist entry for, e.g., type 702 * declarations of the form 'type a = b' 703 * and array indicies. 704 */ 705 struct nl * 706 nlcopy(p) 707 struct nl *p; 708 { 709 register int *p1, *p2, i; 710 711 p1 = p; 712 p = p2 = defnl(0, 0, 0, 0); 713 i = (sizeof *p)/(sizeof (int)); 714 do 715 *p2++ = *p1++; 716 while (--i); 717 p->chain = NIL; 718 return (p); 719 } 720 721 /* 722 * Compute a namelist offset 723 */ 724 nloff(p) 725 struct nl *p; 726 { 727 728 return (p - nl); 729 } 730 731 /* 732 * Enter a symbol into the block 733 * symbol table. Symbols are hashed 734 * 64 ways based on low 6 bits of the 735 * character pointer into the string 736 * table. 737 */ 738 struct nl * 739 enter(np) 740 struct nl *np; 741 { 742 register struct nl *rp, *hp; 743 register struct nl *p; 744 int i; 745 746 rp = np; 747 if (rp == NIL) 748 return (NIL); 749 #ifndef PI1 750 if (cbn > 0) 751 if (rp->symbol == input->symbol || rp->symbol == output->symbol) 752 error("Pre-defined files input and output must not be redefined"); 753 #endif 754 i = rp->symbol; 755 i &= 077; 756 hp = disptab[i]; 757 if (rp->class != BADUSE && rp->class != FIELD) 758 for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next) 759 if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) { 760 #ifndef PI1 761 error("%s is already defined in this block", rp->symbol); 762 #endif 763 break; 764 765 } 766 rp->nl_next = hp; 767 disptab[i] = rp; 768 return (rp); 769 } 770 #endif 771