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