|
|
1.1 ! root 1: /* Copyright (c) 1979 Regents of the University of California */ ! 2: ! 3: static char sccsid[] = "@(#)nl.c 1.2 10/2/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: "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 == -1) { ! 684: i = NLINC / 2; ! 685: cp = malloc((NLINC / 2) * sizeof *nlp); ! 686: } ! 687: if (cp == -1) { ! 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
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.