| 1 | /* Copyright (c) 1979 Regents of the University of California */ |
| 2 | # |
| 3 | /* |
| 4 | * pi - Pascal interpreter code translator |
| 5 | * |
| 6 | * Charles Haley, Bill Joy UCB |
| 7 | * Version 1.2 November 1978 |
| 8 | */ |
| 9 | |
| 10 | #include "whoami" |
| 11 | #include "0.h" |
| 12 | #include "opcode.h" |
| 13 | |
| 14 | /* |
| 15 | * NAMELIST SEGMENT DEFINITIONS |
| 16 | */ |
| 17 | struct nls { |
| 18 | struct nl *nls_low; |
| 19 | struct nl *nls_high; |
| 20 | } ntab[MAXNL], *nlact; |
| 21 | |
| 22 | struct nl nl[INL]; |
| 23 | struct nl *nlp = nl; |
| 24 | struct nls *nlact = ntab; |
| 25 | \f |
| 26 | /* |
| 27 | * all these strings must be places where people can find them |
| 28 | * since lookup only looks at the string pointer, not the chars. |
| 29 | * see, for example, pTreeInit. |
| 30 | */ |
| 31 | |
| 32 | /* |
| 33 | * built in constants |
| 34 | */ |
| 35 | char *in_consts[] = { |
| 36 | "true" , |
| 37 | "false" , |
| 38 | "minint" , |
| 39 | "maxint" , |
| 40 | "minchar" , |
| 41 | "maxchar" , |
| 42 | "bell" , |
| 43 | "tab" , |
| 44 | 0 |
| 45 | }; |
| 46 | |
| 47 | /* |
| 48 | * built in simple types |
| 49 | */ |
| 50 | char *in_types[] = |
| 51 | { |
| 52 | "boolean", |
| 53 | "char", |
| 54 | "integer", |
| 55 | "real", |
| 56 | "_nil", /* dummy name */ |
| 57 | 0 |
| 58 | }; |
| 59 | |
| 60 | int in_rclasses[] = |
| 61 | { |
| 62 | TINT , |
| 63 | TINT , |
| 64 | TINT , |
| 65 | TCHAR , |
| 66 | TBOOL , |
| 67 | TDOUBLE , |
| 68 | 0 |
| 69 | }; |
| 70 | |
| 71 | long in_ranges[] = |
| 72 | { |
| 73 | -128L , 128L , |
| 74 | -32768L , 32767L , |
| 75 | -2147483648L , 2147483647L , |
| 76 | 0L , 127L , |
| 77 | 0L , 1L , |
| 78 | 0L , 0L /* fake for reals */ |
| 79 | }; |
| 80 | |
| 81 | /* |
| 82 | * built in constructed types |
| 83 | */ |
| 84 | char *in_ctypes[] = { |
| 85 | "Boolean" , |
| 86 | "intset" , |
| 87 | "alfa" , |
| 88 | "text" , |
| 89 | 0 |
| 90 | }; |
| 91 | |
| 92 | /* |
| 93 | * built in variables |
| 94 | */ |
| 95 | char *in_vars[] = { |
| 96 | "input" , |
| 97 | "output" , |
| 98 | 0 |
| 99 | }; |
| 100 | |
| 101 | /* |
| 102 | * built in functions |
| 103 | */ |
| 104 | char *in_funcs[] = |
| 105 | { |
| 106 | "abs" , |
| 107 | "arctan" , |
| 108 | "card" , |
| 109 | "chr" , |
| 110 | "clock" , |
| 111 | "cos" , |
| 112 | "eof" , |
| 113 | "eoln" , |
| 114 | "eos" , |
| 115 | "exp" , |
| 116 | "expo" , |
| 117 | "ln" , |
| 118 | "odd" , |
| 119 | "ord" , |
| 120 | "pred" , |
| 121 | "round" , |
| 122 | "sin" , |
| 123 | "sqr" , |
| 124 | "sqrt" , |
| 125 | "succ" , |
| 126 | "trunc" , |
| 127 | "undefined" , |
| 128 | /* |
| 129 | * Extensions |
| 130 | */ |
| 131 | "argc" , |
| 132 | "random" , |
| 133 | "seed" , |
| 134 | "wallclock" , |
| 135 | "sysclock" , |
| 136 | 0 |
| 137 | }; |
| 138 | |
| 139 | /* |
| 140 | * Built-in procedures |
| 141 | */ |
| 142 | char *in_procs[] = |
| 143 | { |
| 144 | "date" , |
| 145 | "dispose" , |
| 146 | "flush" , |
| 147 | "get" , |
| 148 | "getseg" , |
| 149 | "halt" , |
| 150 | "linelimit" , |
| 151 | "message" , |
| 152 | "new" , |
| 153 | "pack" , |
| 154 | "page" , |
| 155 | "put" , |
| 156 | "putseg" , |
| 157 | "read" , |
| 158 | "readln" , |
| 159 | "remove" , |
| 160 | "reset" , |
| 161 | "rewrite" , |
| 162 | "time" , |
| 163 | "unpack" , |
| 164 | "write" , |
| 165 | "writeln" , |
| 166 | /* |
| 167 | * Extensions |
| 168 | */ |
| 169 | "argv" , |
| 170 | "null" , |
| 171 | "stlimit" , |
| 172 | 0 |
| 173 | }; |
| 174 | |
| 175 | #ifndef PI0 |
| 176 | /* |
| 177 | * and their opcodes |
| 178 | */ |
| 179 | int in_fops[] = |
| 180 | { |
| 181 | O_ABS2, |
| 182 | O_ATAN, |
| 183 | O_CARD|NSTAND, |
| 184 | O_CHR2, |
| 185 | O_CLCK|NSTAND, |
| 186 | O_COS, |
| 187 | O_EOF, |
| 188 | O_EOLN, |
| 189 | 0, |
| 190 | O_EXP, |
| 191 | O_EXPO|NSTAND, |
| 192 | O_LN, |
| 193 | O_ODD2, |
| 194 | O_ORD2, |
| 195 | O_PRED2, |
| 196 | O_ROUND, |
| 197 | O_SIN, |
| 198 | O_SQR2, |
| 199 | O_SQRT, |
| 200 | O_SUCC2, |
| 201 | O_TRUNC, |
| 202 | O_UNDEF|NSTAND, |
| 203 | /* |
| 204 | * Extensions |
| 205 | */ |
| 206 | O_ARGC|NSTAND, |
| 207 | O_RANDOM|NSTAND, |
| 208 | O_SEED|NSTAND, |
| 209 | O_WCLCK|NSTAND, |
| 210 | O_SCLCK|NSTAND |
| 211 | }; |
| 212 | |
| 213 | /* |
| 214 | * Built-in procedures |
| 215 | */ |
| 216 | int in_pops[] = |
| 217 | { |
| 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_WRIT2, |
| 239 | O_WRITLN, |
| 240 | /* |
| 241 | * Extensions |
| 242 | */ |
| 243 | O_ARGV|NSTAND, |
| 244 | O_NULL|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 | int *ip; |
| 258 | long *lp; |
| 259 | |
| 260 | #ifdef DEBUG |
| 261 | if ( hp21mx ) |
| 262 | { |
| 263 | MININT = -32768.; |
| 264 | MAXINT = 32767.; |
| 265 | #ifndef PI0 |
| 266 | genmx(); |
| 267 | #endif |
| 268 | } |
| 269 | #endif |
| 270 | ntab[0].nls_low = nl; |
| 271 | ntab[0].nls_high = &nl[INL]; |
| 272 | defnl ( 0 , 0 , 0 , 0 ); |
| 273 | |
| 274 | /* |
| 275 | * Types |
| 276 | */ |
| 277 | for ( cp = in_types ; *cp != 0 ; cp ++ ) |
| 278 | hdefnl ( *cp , TYPE , nlp , 0 ); |
| 279 | |
| 280 | /* |
| 281 | * Ranges |
| 282 | */ |
| 283 | lp = in_ranges; |
| 284 | for ( ip = in_rclasses ; *ip != 0 ; ip ++ ) |
| 285 | { |
| 286 | np = defnl ( 0 , RANGE , nl+(*ip) , 0 ); |
| 287 | nl[*ip].type = np; |
| 288 | np -> range[0] = *lp ++ ; |
| 289 | np -> range[1] = *lp ++ ; |
| 290 | |
| 291 | }; |
| 292 | |
| 293 | /* |
| 294 | * built in constructed types |
| 295 | */ |
| 296 | |
| 297 | cp = in_ctypes; |
| 298 | /* |
| 299 | * Boolean = boolean; |
| 300 | */ |
| 301 | hdefnl ( *cp++ , TYPE , nl+T1BOOL , 0 ); |
| 302 | |
| 303 | /* |
| 304 | * intset = set of 0 .. 127; |
| 305 | */ |
| 306 | intset = *cp++; |
| 307 | enter ( defnl ( intset , TYPE , nlp+1 , 0 ) ); |
| 308 | defnl ( 0 , SET , nlp+1 , 0 ); |
| 309 | np = defnl ( 0 , RANGE , nl+TINT , 0 ); |
| 310 | np -> range[0] = 0L; |
| 311 | np -> range[1] = 127L; |
| 312 | |
| 313 | /* |
| 314 | * alfa = array [ 1 .. 10 ] of char; |
| 315 | */ |
| 316 | np = defnl ( 0 , RANGE , nl+TINT , 0 ); |
| 317 | np -> range[0] = 1L; |
| 318 | np -> range[1] = 10L; |
| 319 | defnl ( 0 , ARRAY , nl+T1CHAR , 1 ) -> chain = np; |
| 320 | hdefnl ( *cp++ , TYPE , nlp-1 , 0 ); |
| 321 | |
| 322 | /* |
| 323 | * text = file of char; |
| 324 | */ |
| 325 | hdefnl ( *cp++ , TYPE , nlp+1 , 0 ); |
| 326 | np = defnl ( 0 , FILET , nl+T1CHAR , 0 ); |
| 327 | np -> nl_flags |= NFILES; |
| 328 | |
| 329 | /* |
| 330 | * input,output : text; |
| 331 | */ |
| 332 | cp = in_vars; |
| 333 | # ifndef PI0 |
| 334 | # ifdef VAX |
| 335 | input = hdefnl ( *cp++ , VAR , np , -8 ); |
| 336 | # endif |
| 337 | # ifdef PDP11 |
| 338 | input = hdefnl ( *cp++ , VAR , np , -2 ); |
| 339 | # endif |
| 340 | output = hdefnl ( *cp++ , VAR , np , -4 ); |
| 341 | # else |
| 342 | input = hdefnl ( *cp++ , VAR , np , 0 ); |
| 343 | output = hdefnl ( *cp++ , VAR , np , 0 ); |
| 344 | # endif |
| 345 | |
| 346 | /* |
| 347 | * built in constants |
| 348 | */ |
| 349 | cp = in_consts; |
| 350 | hdefnl ( *cp++ , CONST , nl + TBOOL , 1 ); |
| 351 | hdefnl ( *cp++ , CONST , nl + TBOOL , 0 ); |
| 352 | hdefnl ( *cp++ , CONST , nl + T4INT , 0 ) -> range[0] = MININT; |
| 353 | hdefnl ( *cp++ , CONST , nl + T4INT , 0 ) -> range[0] = MAXINT; |
| 354 | hdefnl ( *cp++ , CONST , nl + T1CHAR , 0 ); |
| 355 | hdefnl ( *cp++ , CONST , nl + T1CHAR , 127 ); |
| 356 | hdefnl ( *cp++ , CONST , nl + T1CHAR , '\007' ); |
| 357 | hdefnl ( *cp++ , CONST , nl + T1CHAR , '\t' ); |
| 358 | |
| 359 | /* |
| 360 | * Built-in functions and procedures |
| 361 | */ |
| 362 | #ifndef PI0 |
| 363 | ip = in_fops; |
| 364 | for ( cp = in_funcs ; *cp != 0 ; cp ++ ) |
| 365 | hdefnl ( *cp , FUNC , 0 , * ip ++ ); |
| 366 | ip = in_pops; |
| 367 | for ( cp = in_procs ; *cp != 0 ; cp ++ ) |
| 368 | hdefnl ( *cp , PROC , 0 , * ip ++ ); |
| 369 | #else |
| 370 | for ( cp = in_funcs ; *cp != 0 ; cp ++ ) |
| 371 | hdefnl ( *cp , FUNC , 0 , 0 ); |
| 372 | for ( cp = in_procs ; *cp != 0 , cp ++ ) |
| 373 | hdefnl ( *cp , PROC , 0 , 0 ); |
| 374 | #endif |
| 375 | # ifdef PTREE |
| 376 | pTreeInit(); |
| 377 | # endif |
| 378 | } |
| 379 | |
| 380 | struct nl * |
| 381 | hdefnl(sym, cls, typ, val) |
| 382 | { |
| 383 | register struct nl *p; |
| 384 | |
| 385 | #ifndef PI1 |
| 386 | if (sym) |
| 387 | hash(sym, 0); |
| 388 | #endif |
| 389 | p = defnl(sym, cls, typ, val); |
| 390 | if (sym) |
| 391 | enter(p); |
| 392 | return (p); |
| 393 | } |
| 394 | |
| 395 | /* |
| 396 | * Free up the name list segments |
| 397 | * at the end of a statement/proc/func |
| 398 | * All segments are freed down to the one in which |
| 399 | * p points. |
| 400 | */ |
| 401 | nlfree(p) |
| 402 | struct nl *p; |
| 403 | { |
| 404 | |
| 405 | nlp = p; |
| 406 | while (nlact->nls_low > nlp || nlact->nls_high < nlp) { |
| 407 | free(nlact->nls_low); |
| 408 | nlact->nls_low = NIL; |
| 409 | nlact->nls_high = NIL; |
| 410 | --nlact; |
| 411 | if (nlact < &ntab[0]) |
| 412 | panic("nlfree"); |
| 413 | } |
| 414 | } |
| 415 | \f |
| 416 | |
| 417 | char *VARIABLE = "variable"; |
| 418 | |
| 419 | char *classes[ ] = { |
| 420 | "undefined", |
| 421 | "constant", |
| 422 | "type", |
| 423 | "variable", /* VARIABLE */ |
| 424 | "array", |
| 425 | "pointer or file", |
| 426 | "record", |
| 427 | "field", |
| 428 | "procedure", |
| 429 | "function", |
| 430 | "variable", /* VARIABLE */ |
| 431 | "variable", /* VARIABLE */ |
| 432 | "pointer", |
| 433 | "file", |
| 434 | "set", |
| 435 | "subrange", |
| 436 | "label", |
| 437 | "withptr", |
| 438 | "scalar", |
| 439 | "string", |
| 440 | "program", |
| 441 | "improper" |
| 442 | #ifdef DEBUG |
| 443 | ,"variant" |
| 444 | #endif |
| 445 | }; |
| 446 | |
| 447 | char *snark = "SNARK"; |
| 448 | |
| 449 | #ifdef PI |
| 450 | #ifdef DEBUG |
| 451 | char *ctext[] = |
| 452 | { |
| 453 | "BADUSE", |
| 454 | "CONST", |
| 455 | "TYPE", |
| 456 | "VAR", |
| 457 | "ARRAY", |
| 458 | "PTRFILE", |
| 459 | "RECORD", |
| 460 | "FIELD", |
| 461 | "PROC", |
| 462 | "FUNC", |
| 463 | "FVAR", |
| 464 | "REF", |
| 465 | "PTR", |
| 466 | "FILET", |
| 467 | "SET", |
| 468 | "RANGE", |
| 469 | "LABEL", |
| 470 | "WITHPTR", |
| 471 | "SCAL", |
| 472 | "STR", |
| 473 | "PROG", |
| 474 | "IMPROPER", |
| 475 | "VARNT" |
| 476 | }; |
| 477 | |
| 478 | char *stars = "\t***"; |
| 479 | |
| 480 | /* |
| 481 | * Dump the namelist from the |
| 482 | * current nlp down to 'to'. |
| 483 | * All the namelist is dumped if |
| 484 | * to is NIL. |
| 485 | */ |
| 486 | dumpnl(to, rout) |
| 487 | struct nl *to; |
| 488 | { |
| 489 | register struct nl *p; |
| 490 | register int j; |
| 491 | struct nls *nlsp; |
| 492 | int i, v, head; |
| 493 | |
| 494 | if (opt('y') == 0) |
| 495 | return; |
| 496 | if (to != NIL) |
| 497 | printf("\n\"%s\" Block=%d\n", rout, cbn); |
| 498 | nlsp = nlact; |
| 499 | head = NIL; |
| 500 | for (p = nlp; p != to;) { |
| 501 | if (p == nlsp->nls_low) { |
| 502 | if (nlsp == &ntab[0]) |
| 503 | break; |
| 504 | nlsp--; |
| 505 | p = nlsp->nls_high; |
| 506 | } |
| 507 | p--; |
| 508 | if (head == NIL) { |
| 509 | printf("\tName\tClass Bn+Flags\tType\tVal\tChn\n"); |
| 510 | head++; |
| 511 | } |
| 512 | printf("%3d:", nloff(p)); |
| 513 | if (p->symbol) |
| 514 | printf("\t%.7s", p->symbol); |
| 515 | else |
| 516 | printf(stars); |
| 517 | if (p->class) |
| 518 | printf("\t%s", ctext[p->class]); |
| 519 | else |
| 520 | printf(stars); |
| 521 | if (p->nl_flags) { |
| 522 | pchr('\t'); |
| 523 | if (p->nl_flags & 037) |
| 524 | printf("%d ", p->nl_flags & 037); |
| 525 | #ifndef PI0 |
| 526 | if (p->nl_flags & NMOD) |
| 527 | pchr('M'); |
| 528 | if (p->nl_flags & NUSED) |
| 529 | pchr('U'); |
| 530 | #endif |
| 531 | if (p->nl_flags & NFILES) |
| 532 | pchr('F'); |
| 533 | } else |
| 534 | printf(stars); |
| 535 | if (p->type) |
| 536 | printf("\t[%d]", nloff(p->type)); |
| 537 | else |
| 538 | printf(stars); |
| 539 | v = p->value[0]; |
| 540 | switch (p->class) { |
| 541 | case TYPE: |
| 542 | break; |
| 543 | case VARNT: |
| 544 | goto con; |
| 545 | case CONST: |
| 546 | switch (nloff(p->type)) { |
| 547 | default: |
| 548 | printf("\t%d", v); |
| 549 | break; |
| 550 | case TDOUBLE: |
| 551 | printf("\t%f", p->real); |
| 552 | break; |
| 553 | case TINT: |
| 554 | case T4INT: |
| 555 | con: |
| 556 | printf("\t%ld", p->range[0]); |
| 557 | break; |
| 558 | case TSTR: |
| 559 | printf("\t'%s'", p->ptr[0]); |
| 560 | break; |
| 561 | } |
| 562 | break; |
| 563 | case VAR: |
| 564 | case REF: |
| 565 | case WITHPTR: |
| 566 | printf("\t%d,%d", cbn, v); |
| 567 | break; |
| 568 | case SCAL: |
| 569 | case RANGE: |
| 570 | printf("\t%ld..%ld", p->range[0], p->range[1]); |
| 571 | break; |
| 572 | case RECORD: |
| 573 | printf("\t%d(%d)", v, p->value[NL_FLDSZ]); |
| 574 | break; |
| 575 | case FIELD: |
| 576 | printf("\t%d", v); |
| 577 | break; |
| 578 | case STR: |
| 579 | printf("\t|%d|", p->value[0]); |
| 580 | break; |
| 581 | case FVAR: |
| 582 | case FUNC: |
| 583 | case PROC: |
| 584 | case PROG: |
| 585 | if (cbn == 0) { |
| 586 | printf("\t<%o>", p->value[0] & 0377); |
| 587 | #ifndef PI0 |
| 588 | if (p->value[0] & NSTAND) |
| 589 | printf("\tNSTAND"); |
| 590 | #endif |
| 591 | break; |
| 592 | } |
| 593 | v = p->value[1]; |
| 594 | default: |
| 595 | casedef: |
| 596 | if (v) |
| 597 | printf("\t<%d>", v); |
| 598 | else |
| 599 | printf(stars); |
| 600 | } |
| 601 | if (p->chain) |
| 602 | printf("\t[%d]", nloff(p->chain)); |
| 603 | switch (p->class) { |
| 604 | case RECORD: |
| 605 | if (p->ptr[NL_VARNT]) |
| 606 | printf("\tVARNT=[%d]", nloff(p->ptr[NL_VARNT])); |
| 607 | if (p->ptr[NL_TAG]) |
| 608 | printf(" TAG=[%d]", nloff(p->ptr[NL_TAG])); |
| 609 | break; |
| 610 | case VARNT: |
| 611 | printf("\tVTOREC=[%d]", nloff(p->ptr[NL_VTOREC])); |
| 612 | break; |
| 613 | } |
| 614 | # ifdef PTREE |
| 615 | pchr( '\t' ); |
| 616 | pPrintPointer( stdout , "%s" , p -> inTree ); |
| 617 | # endif |
| 618 | pchr('\n'); |
| 619 | } |
| 620 | if (head == 0) |
| 621 | printf("\tNo entries\n"); |
| 622 | } |
| 623 | #endif |
| 624 | |
| 625 | \f |
| 626 | /* |
| 627 | * Define a new name list entry |
| 628 | * with initial symbol, class, type |
| 629 | * and value[0] as given. A new name |
| 630 | * list segment is allocated to hold |
| 631 | * the next name list slot if necessary. |
| 632 | */ |
| 633 | struct nl * |
| 634 | defnl(sym, cls, typ, val) |
| 635 | char *sym; |
| 636 | int cls; |
| 637 | struct nl *typ; |
| 638 | int val; |
| 639 | { |
| 640 | register struct nl *p; |
| 641 | register int *q, i; |
| 642 | char *cp; |
| 643 | |
| 644 | p = nlp; |
| 645 | |
| 646 | /* |
| 647 | * Zero out this entry |
| 648 | */ |
| 649 | q = p; |
| 650 | i = (sizeof *p)/(sizeof (int)); |
| 651 | do |
| 652 | *q++ = 0; |
| 653 | while (--i); |
| 654 | |
| 655 | /* |
| 656 | * Insert the values |
| 657 | */ |
| 658 | p->symbol = sym; |
| 659 | p->class = cls; |
| 660 | p->type = typ; |
| 661 | p->nl_block = cbn; |
| 662 | p->value[0] = val; |
| 663 | |
| 664 | /* |
| 665 | * Insure that the next namelist |
| 666 | * entry actually exists. This is |
| 667 | * really not needed here, it would |
| 668 | * suffice to do it at entry if we |
| 669 | * need the slot. It is done this |
| 670 | * way because, historically, nlp |
| 671 | * always pointed at the next namelist |
| 672 | * slot. |
| 673 | */ |
| 674 | nlp++; |
| 675 | if (nlp >= nlact->nls_high) { |
| 676 | i = NLINC; |
| 677 | cp = malloc(NLINC * sizeof *nlp); |
| 678 | if (cp == -1) { |
| 679 | i = NLINC / 2; |
| 680 | cp = malloc((NLINC / 2) * sizeof *nlp); |
| 681 | } |
| 682 | if (cp == -1) { |
| 683 | error("Ran out of memory (defnl)"); |
| 684 | pexit(DIED); |
| 685 | } |
| 686 | nlact++; |
| 687 | if (nlact >= &ntab[MAXNL]) { |
| 688 | error("Ran out of name list tables"); |
| 689 | pexit(DIED); |
| 690 | } |
| 691 | nlp = cp; |
| 692 | nlact->nls_low = nlp; |
| 693 | nlact->nls_high = nlact->nls_low + i; |
| 694 | } |
| 695 | return (p); |
| 696 | } |
| 697 | |
| 698 | /* |
| 699 | * Make a duplicate of the argument |
| 700 | * namelist entry for, e.g., type |
| 701 | * declarations of the form 'type a = b' |
| 702 | * and array indicies. |
| 703 | */ |
| 704 | struct nl * |
| 705 | nlcopy(p) |
| 706 | struct nl *p; |
| 707 | { |
| 708 | register int *p1, *p2, i; |
| 709 | |
| 710 | p1 = p; |
| 711 | p = p2 = defnl(0, 0, 0, 0); |
| 712 | i = (sizeof *p)/(sizeof (int)); |
| 713 | do |
| 714 | *p2++ = *p1++; |
| 715 | while (--i); |
| 716 | return (p); |
| 717 | } |
| 718 | |
| 719 | /* |
| 720 | * Compute a namelist offset |
| 721 | */ |
| 722 | nloff(p) |
| 723 | struct nl *p; |
| 724 | { |
| 725 | |
| 726 | return (p - nl); |
| 727 | } |
| 728 | \f |
| 729 | /* |
| 730 | * Enter a symbol into the block |
| 731 | * symbol table. Symbols are hashed |
| 732 | * 64 ways based on low 6 bits of the |
| 733 | * character pointer into the string |
| 734 | * table. |
| 735 | */ |
| 736 | struct nl * |
| 737 | enter(np) |
| 738 | struct nl *np; |
| 739 | { |
| 740 | register struct nl *rp, *hp; |
| 741 | register struct nl *p; |
| 742 | int i; |
| 743 | |
| 744 | rp = np; |
| 745 | if (rp == NIL) |
| 746 | return (NIL); |
| 747 | #ifndef PI1 |
| 748 | if (cbn > 0) |
| 749 | if (rp->symbol == input->symbol || rp->symbol == output->symbol) |
| 750 | error("Pre-defined files input and output must not be redefined"); |
| 751 | #endif |
| 752 | i = rp->symbol; |
| 753 | i &= 077; |
| 754 | hp = disptab[i]; |
| 755 | if (rp->class != BADUSE && rp->class != FIELD) |
| 756 | for (p = hp; p != NIL && (p->nl_block & 037) == cbn; p = p->nl_next) |
| 757 | if (p->symbol == rp->symbol && p->class != BADUSE && p->class != FIELD) { |
| 758 | #ifndef PI1 |
| 759 | error("%s is already defined in this block", rp->symbol); |
| 760 | #endif |
| 761 | break; |
| 762 | |
| 763 | } |
| 764 | rp->nl_next = hp; |
| 765 | disptab[i] = rp; |
| 766 | return (rp); |
| 767 | } |
| 768 | #endif |