| 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 January 1979 |
| 8 | */ |
| 9 | |
| 10 | #include "0.h" |
| 11 | #include "tree.h" |
| 12 | |
| 13 | int cntstat; |
| 14 | int cnts 2; |
| 15 | #include "opcode.h" |
| 16 | |
| 17 | /* |
| 18 | * Statement list |
| 19 | */ |
| 20 | statlist(r) |
| 21 | int *r; |
| 22 | { |
| 23 | register *sl; |
| 24 | |
| 25 | for (sl=r; sl != NIL; sl=sl[2]) |
| 26 | statement(sl[1]); |
| 27 | } |
| 28 | |
| 29 | /* |
| 30 | * Statement |
| 31 | */ |
| 32 | statement(r) |
| 33 | int *r; |
| 34 | { |
| 35 | register *s; |
| 36 | register struct nl *snlp; |
| 37 | |
| 38 | s = r; |
| 39 | snlp = nlp; |
| 40 | top: |
| 41 | if (cntstat) { |
| 42 | cntstat = 0; |
| 43 | putcnt(); |
| 44 | } |
| 45 | if (s == NIL) |
| 46 | return; |
| 47 | line = s[1]; |
| 48 | if (s[0] == T_LABEL) { |
| 49 | labeled(s[2]); |
| 50 | s = s[3]; |
| 51 | noreach = 0; |
| 52 | cntstat = 1; |
| 53 | goto top; |
| 54 | } |
| 55 | if (noreach) { |
| 56 | noreach = 0; |
| 57 | warning(); |
| 58 | error("Unreachable statement"); |
| 59 | } |
| 60 | switch (s[0]) { |
| 61 | case T_PCALL: |
| 62 | putline(); |
| 63 | proc(s); |
| 64 | break; |
| 65 | case T_ASGN: |
| 66 | putline(); |
| 67 | asgnop(s); |
| 68 | break; |
| 69 | case T_GOTO: |
| 70 | putline(); |
| 71 | gotoop(s[2]); |
| 72 | noreach = 1; |
| 73 | cntstat = 1; |
| 74 | break; |
| 75 | default: |
| 76 | level++; |
| 77 | switch (s[0]) { |
| 78 | default: |
| 79 | panic("stat"); |
| 80 | case T_IF: |
| 81 | case T_IFEL: |
| 82 | ifop(s); |
| 83 | break; |
| 84 | case T_WHILE: |
| 85 | whilop(s); |
| 86 | noreach = 0; |
| 87 | break; |
| 88 | case T_REPEAT: |
| 89 | repop(s); |
| 90 | break; |
| 91 | case T_FORU: |
| 92 | case T_FORD: |
| 93 | forop(s); |
| 94 | noreach = 0; |
| 95 | break; |
| 96 | case T_BLOCK: |
| 97 | statlist(s[2]); |
| 98 | break; |
| 99 | case T_CASE: |
| 100 | putline(); |
| 101 | caseop(s); |
| 102 | break; |
| 103 | case T_WITH: |
| 104 | withop(s); |
| 105 | break; |
| 106 | case T_ASRT: |
| 107 | putline(); |
| 108 | asrtop(s); |
| 109 | break; |
| 110 | } |
| 111 | --level; |
| 112 | if (gotos[cbn]) |
| 113 | ungoto(); |
| 114 | break; |
| 115 | } |
| 116 | /* |
| 117 | * Free the temporary name list entries defined in |
| 118 | * expressions, e.g. STRs, and WITHPTRs from withs. |
| 119 | */ |
| 120 | nlfree(snlp); |
| 121 | } |
| 122 | |
| 123 | ungoto() |
| 124 | { |
| 125 | register struct nl *p; |
| 126 | |
| 127 | for (p = gotos[cbn]; p != NIL; p = p->chain) |
| 128 | if ((p->nl_flags & NFORWD) != 0) { |
| 129 | if (p->value[NL_GOLEV] != NOTYET) |
| 130 | if (p->value[NL_GOLEV] > level) |
| 131 | p->value[NL_GOLEV] = level; |
| 132 | } else |
| 133 | if (p->value[NL_GOLEV] != DEAD) |
| 134 | if (p->value[NL_GOLEV] > level) |
| 135 | p->value[NL_GOLEV] = DEAD; |
| 136 | } |
| 137 | |
| 138 | putcnt() |
| 139 | { |
| 140 | |
| 141 | if (monflg == 0) |
| 142 | return; |
| 143 | cnts++; |
| 144 | put2(O_COUNT, cnts); |
| 145 | } |
| 146 | |
| 147 | putline() |
| 148 | { |
| 149 | |
| 150 | if (opt('p') != 0) |
| 151 | put2(O_LINO, line); |
| 152 | } |
| 153 | |
| 154 | /* |
| 155 | * With varlist do stat |
| 156 | * |
| 157 | * With statement requires an extra word |
| 158 | * in automatic storage for each level of withing. |
| 159 | * These indirect pointers are initialized here, and |
| 160 | * the scoping effect of the with statement occurs |
| 161 | * because lookup examines the field names of the records |
| 162 | * associated with the WITHPTRs on the withlist. |
| 163 | */ |
| 164 | withop(s) |
| 165 | int *s; |
| 166 | { |
| 167 | register *p; |
| 168 | register struct nl *r; |
| 169 | int i; |
| 170 | int *swl; |
| 171 | long soffset; |
| 172 | |
| 173 | putline(); |
| 174 | swl = withlist; |
| 175 | soffset = sizes[cbn].om_off; |
| 176 | for (p = s[2]; p != NIL; p = p[2]) { |
| 177 | sizes[cbn].om_off =- 2; |
| 178 | put2(O_LV | cbn <<9, i = sizes[cbn].om_off); |
| 179 | r = lvalue(p[1], MOD); |
| 180 | if (r == NIL) |
| 181 | continue; |
| 182 | if (r->class != RECORD) { |
| 183 | error("Variable in with statement refers to %s, not to a record", nameof(r)); |
| 184 | continue; |
| 185 | } |
| 186 | r = defnl(0, WITHPTR, r, i); |
| 187 | r->nl_next = withlist; |
| 188 | withlist = r; |
| 189 | put1(O_AS2); |
| 190 | } |
| 191 | if (sizes[cbn].om_off < sizes[cbn].om_max) |
| 192 | sizes[cbn].om_max = sizes[cbn].om_off; |
| 193 | statement(s[3]); |
| 194 | sizes[cbn].om_off = soffset; |
| 195 | withlist = swl; |
| 196 | } |
| 197 | |
| 198 | extern flagwas; |
| 199 | /* |
| 200 | * var := expr |
| 201 | */ |
| 202 | asgnop(r) |
| 203 | int *r; |
| 204 | { |
| 205 | register struct nl *p; |
| 206 | register *av; |
| 207 | |
| 208 | if (r == NIL) |
| 209 | return (NIL); |
| 210 | /* |
| 211 | * Asgnop's only function is |
| 212 | * to handle function variable |
| 213 | * assignments. All other assignment |
| 214 | * stuff is handled by asgnop1. |
| 215 | */ |
| 216 | av = r[2]; |
| 217 | if (av != NIL && av[0] == T_VAR && av[3] == NIL) { |
| 218 | p = lookup1(av[2]); |
| 219 | if (p != NIL) |
| 220 | p->nl_flags = flagwas; |
| 221 | if (p != NIL && p->class == FVAR) { |
| 222 | /* |
| 223 | * Give asgnop1 the func |
| 224 | * which is the chain of |
| 225 | * the FVAR. |
| 226 | */ |
| 227 | p->nl_flags =| NUSED|NMOD; |
| 228 | p = p->chain; |
| 229 | if (p == NIL) { |
| 230 | rvalue(r[3], NIL); |
| 231 | return; |
| 232 | } |
| 233 | put2(O_LV | bn << 9, p->value[NL_OFFS]); |
| 234 | if (isa(p->type, "i") && width(p->type) == 1) |
| 235 | asgnop1(r, nl+T2INT); |
| 236 | else |
| 237 | asgnop1(r, p->type); |
| 238 | return; |
| 239 | } |
| 240 | } |
| 241 | asgnop1(r, NIL); |
| 242 | } |
| 243 | |
| 244 | /* |
| 245 | * Asgnop1 handles all assignments. |
| 246 | * If p is not nil then we are assigning |
| 247 | * to a function variable, otherwise |
| 248 | * we look the variable up ourselves. |
| 249 | */ |
| 250 | asgnop1(r, p) |
| 251 | int *r; |
| 252 | register struct nl *p; |
| 253 | { |
| 254 | register struct nl *p1; |
| 255 | |
| 256 | if (r == NIL) |
| 257 | return (NIL); |
| 258 | if (p == NIL) { |
| 259 | p = lvalue(r[2], MOD|ASGN|NOUSE); |
| 260 | if (p == NIL) { |
| 261 | rvalue(r[3], NIL); |
| 262 | return (NIL); |
| 263 | } |
| 264 | } |
| 265 | p1 = rvalue(r[3], p); |
| 266 | if (p1 == NIL) |
| 267 | return (NIL); |
| 268 | if (incompat(p1, p, r[3])) { |
| 269 | cerror("Type of expression clashed with type of variable in assignment"); |
| 270 | return (NIL); |
| 271 | } |
| 272 | switch (classify(p)) { |
| 273 | case TBOOL: |
| 274 | case TCHAR: |
| 275 | case TINT: |
| 276 | case TSCAL: |
| 277 | rangechk(p, p1); |
| 278 | case TDOUBLE: |
| 279 | case TPTR: |
| 280 | gen(O_AS2, O_AS2, width(p), width(p1)); |
| 281 | break; |
| 282 | default: |
| 283 | put2(O_AS, width(p)); |
| 284 | } |
| 285 | return (p); /* Used by for statement */ |
| 286 | } |
| 287 | |
| 288 | /* |
| 289 | * for var := expr [down]to expr do stat |
| 290 | */ |
| 291 | forop(r) |
| 292 | int *r; |
| 293 | { |
| 294 | register struct nl *t1, *t2; |
| 295 | int l1, l2, l3; |
| 296 | long soffset; |
| 297 | register op; |
| 298 | struct nl *p; |
| 299 | int *rr, goc, i; |
| 300 | #ifdef DEBUG |
| 301 | int limitrv = (hp21mx ? O_RV2 : O_RV4) | cbn << 9; |
| 302 | int limitsz = (hp21mx ? 2 : 4); |
| 303 | #endif |
| 304 | |
| 305 | p = NIL; |
| 306 | goc = gocnt; |
| 307 | if (r == NIL) |
| 308 | goto aloha; |
| 309 | putline(); |
| 310 | /* |
| 311 | * Allocate automatic |
| 312 | * space for limit variable |
| 313 | */ |
| 314 | #ifndef DEBUG |
| 315 | sizes[cbn].om_off =- 4; |
| 316 | #else |
| 317 | sizes[cbn].om_off =- limitsz; |
| 318 | #endif |
| 319 | if (sizes[cbn].om_off < sizes[cbn].om_max) |
| 320 | sizes[cbn].om_max = sizes[cbn].om_off; |
| 321 | i = sizes[cbn].om_off; |
| 322 | /* |
| 323 | * Initialize the limit variable |
| 324 | */ |
| 325 | put2(O_LV | cbn<<9, i); |
| 326 | t2 = rvalue(r[3], NIL); |
| 327 | #ifndef DEBUG |
| 328 | put1(width(t2) <= 2 ? O_AS24 : O_AS4); |
| 329 | #else |
| 330 | if (hp21mx) |
| 331 | put1(O_AS2); |
| 332 | else |
| 333 | put1(width(t2) <= 2 ? O_AS24 : O_AS4); |
| 334 | #endif |
| 335 | /* |
| 336 | * Assignment of initial value to for variable |
| 337 | */ |
| 338 | t1 = asgnop1(r[2], NIL); |
| 339 | if (t1 == NIL) { |
| 340 | rvalue(r[3], NIL); |
| 341 | statement(r[4]); |
| 342 | goto aloha; |
| 343 | } |
| 344 | rr = r[2]; /* Assignment */ |
| 345 | rr = rr[2]; /* Lhs variable */ |
| 346 | if (rr[3] != NIL) { |
| 347 | error("For variable must be unqualified"); |
| 348 | rvalue(r[3], NIL); |
| 349 | statement(r[4]); |
| 350 | goto aloha; |
| 351 | } |
| 352 | p = lookup(rr[2]); |
| 353 | p->value[NL_FORV] = 1; |
| 354 | if (isnta(t1, "bcis")) { |
| 355 | error("For variables cannot be %ss", nameof(t1)); |
| 356 | statement(r[4]); |
| 357 | goto aloha; |
| 358 | } |
| 359 | if (incompat(t2, t1, r[3])) { |
| 360 | cerror("Limit type clashed with index type in 'for' statement"); |
| 361 | statement(r[4]); |
| 362 | goto aloha; |
| 363 | } |
| 364 | /* |
| 365 | * See if we can skip the loop altogether |
| 366 | */ |
| 367 | rr = r[2]; |
| 368 | if (rr != NIL) |
| 369 | rvalue(rr[2], NIL); |
| 370 | #ifndef DEBUG |
| 371 | put2(O_RV4 | cbn<<9, i); |
| 372 | gen(NIL, r[0] == T_FORU ? T_LE : T_GE, width(t1), 4); |
| 373 | #else |
| 374 | put1(limitrv, i); |
| 375 | gen(NIL, r[0] == T_FORU ? T_LE : T_GE, width(t1), limitsz); |
| 376 | #endif |
| 377 | /* |
| 378 | * L1 will be patched to skip the body of the loop. |
| 379 | * L2 marks the top of the loop when we go around. |
| 380 | */ |
| 381 | put2(O_IF, (l1 = getlab())); |
| 382 | putlab(l2 = getlab()); |
| 383 | putcnt(); |
| 384 | statement(r[4]); |
| 385 | /* |
| 386 | * now we see if we get to go again |
| 387 | */ |
| 388 | if (opt('t') == 0) { |
| 389 | /* |
| 390 | * Easy if we dont have to test |
| 391 | */ |
| 392 | #ifndef DEBUG |
| 393 | put2(O_RV4 | cbn<<9, i); |
| 394 | #else |
| 395 | put2(limitrv, i); |
| 396 | #endif |
| 397 | if (rr != NIL) |
| 398 | lvalue(rr[2], MOD); |
| 399 | put2((r[0] == T_FORU ? O_FOR1U : O_FOR1D) + (width(t1) >> 1), l2); |
| 400 | } else { |
| 401 | line = r[1]; |
| 402 | putline(); |
| 403 | if (rr != NIL) |
| 404 | rvalue(rr[2], NIL); |
| 405 | #ifndef DEBUG |
| 406 | put2(O_RV4 | cbn << 9, i); |
| 407 | gen(NIL, (r[0] == T_FORU ? T_LT : T_GT), width(t1), 4); |
| 408 | #else |
| 409 | put2(limitrv, i); |
| 410 | gen(NIL, (r[0] == T_FORU ? T_LT : T_GT), width(t1), limitsz); |
| 411 | #endif |
| 412 | l3 = put2(O_IF, getlab()); |
| 413 | lvalue(rr[2], MOD); |
| 414 | rvalue(rr[2], NIL); |
| 415 | put2(O_CON2, 1); |
| 416 | t2 = gen(NIL, r[0] == T_FORU ? T_ADD: T_SUB, width(t1), 2); |
| 417 | rangechk(t1, t2); /* The point of all this */ |
| 418 | gen(O_AS2, O_AS2, width(t1), width(t2)); |
| 419 | put2(O_TRA, l2); |
| 420 | patch(l3); |
| 421 | } |
| 422 | #ifdef DEBUG |
| 423 | sizes[cbn].om_off =+ limitsz; |
| 424 | #else |
| 425 | sizes[cbn].om_off =+ 4; |
| 426 | #endif |
| 427 | patch(l1); |
| 428 | aloha: |
| 429 | noreach = 0; |
| 430 | if (p != NIL) |
| 431 | p->value[NL_FORV] = 0; |
| 432 | if (goc != gocnt) |
| 433 | putcnt(); |
| 434 | } |
| 435 | |
| 436 | /* |
| 437 | * if expr then stat [ else stat ] |
| 438 | */ |
| 439 | ifop(r) |
| 440 | int *r; |
| 441 | { |
| 442 | register struct nl *p; |
| 443 | register l1, l2; |
| 444 | int nr, goc; |
| 445 | |
| 446 | goc = gocnt; |
| 447 | if (r == NIL) |
| 448 | return; |
| 449 | putline(); |
| 450 | p = rvalue(r[2], NIL); |
| 451 | if (p == NIL) { |
| 452 | statement(r[3]); |
| 453 | noreach = 0; |
| 454 | statement(r[4]); |
| 455 | noreach = 0; |
| 456 | return; |
| 457 | } |
| 458 | if (isnta(p, "b")) { |
| 459 | error("Type of expression in if statement must be Boolean, not %s", nameof(p)); |
| 460 | statement(r[3]); |
| 461 | noreach = 0; |
| 462 | statement(r[4]); |
| 463 | noreach = 0; |
| 464 | return; |
| 465 | } |
| 466 | l1 = put2(O_IF, getlab()); |
| 467 | putcnt(); |
| 468 | statement(r[3]); |
| 469 | nr = noreach; |
| 470 | if (r[4] != NIL) { |
| 471 | /* |
| 472 | * else stat |
| 473 | */ |
| 474 | --level; |
| 475 | ungoto(); |
| 476 | ++level; |
| 477 | l2 = put2(O_TRA, getlab()); |
| 478 | patch(l1); |
| 479 | noreach = 0; |
| 480 | statement(r[4]); |
| 481 | noreach =& nr; |
| 482 | l1 = l2; |
| 483 | } else |
| 484 | noreach = 0; |
| 485 | patch(l1); |
| 486 | if (goc != gocnt) |
| 487 | putcnt(); |
| 488 | } |
| 489 | |
| 490 | /* |
| 491 | * while expr do stat |
| 492 | */ |
| 493 | whilop(r) |
| 494 | int *r; |
| 495 | { |
| 496 | register struct nl *p; |
| 497 | register l1, l2; |
| 498 | int goc; |
| 499 | |
| 500 | goc = gocnt; |
| 501 | if (r == NIL) |
| 502 | return; |
| 503 | putlab(l1 = getlab()); |
| 504 | putline(); |
| 505 | p = rvalue(r[2], NIL); |
| 506 | if (p == NIL) { |
| 507 | statement(r[3]); |
| 508 | noreach = 0; |
| 509 | return; |
| 510 | } |
| 511 | if (isnta(p, "b")) { |
| 512 | error("Type of expression in while statement must be Boolean, not %s", nameof(p)); |
| 513 | statement(r[3]); |
| 514 | noreach = 0; |
| 515 | return; |
| 516 | } |
| 517 | put2(O_IF, (l2 = getlab())); |
| 518 | putcnt(); |
| 519 | statement(r[3]); |
| 520 | put2(O_TRA, l1); |
| 521 | patch(l2); |
| 522 | if (goc != gocnt) |
| 523 | putcnt(); |
| 524 | } |
| 525 | |
| 526 | /* |
| 527 | * repeat stat* until expr |
| 528 | */ |
| 529 | repop(r) |
| 530 | int *r; |
| 531 | { |
| 532 | register struct nl *p; |
| 533 | register l; |
| 534 | int goc; |
| 535 | |
| 536 | goc = gocnt; |
| 537 | if (r == NIL) |
| 538 | return; |
| 539 | l = putlab(getlab()); |
| 540 | putcnt(); |
| 541 | statlist(r[2]); |
| 542 | line = r[1]; |
| 543 | p = rvalue(r[3], NIL); |
| 544 | if (p == NIL) |
| 545 | return; |
| 546 | if (isnta(p,"b")) { |
| 547 | error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p)); |
| 548 | return; |
| 549 | } |
| 550 | put2(O_IF, l); |
| 551 | if (goc != gocnt) |
| 552 | putcnt(); |
| 553 | } |
| 554 | |
| 555 | /* |
| 556 | * assert expr |
| 557 | */ |
| 558 | asrtop(r) |
| 559 | register int *r; |
| 560 | { |
| 561 | register struct nl *q; |
| 562 | |
| 563 | if (opt('s')) { |
| 564 | standard(); |
| 565 | error("Assert statement is non-standard"); |
| 566 | } |
| 567 | if (!opt('t')) |
| 568 | return; |
| 569 | r = r[2]; |
| 570 | q = rvalue(r, NIL); |
| 571 | if (q == NIL) |
| 572 | return; |
| 573 | if (isnta(q, "b")) |
| 574 | error("Assert expression must be Boolean, not %ss", nameof(q)); |
| 575 | put1(O_ASRT); |
| 576 | } |