4.3BSD - /usr/src/new/B/src/bint/b2gen.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /* $Header: b2gen.c,v 1.4 85/08/27 10:57:31 timo Exp $ */
   4: 
   5: /* Code generation */
   6: 
   7: #include "b.h"
   8: #include "b0fea.h"
   9: #include "b1obj.h"
  10: #include "b2exp.h"
  11: #include "b2nod.h"
  12: #include "b2gen.h" /* Must be after b2nod.h */
  13: #include "b3err.h"
  14: #include "b3env.h"
  15: #include "b3int.h"
  16: #include "b3sem.h"
  17: #include "b3sou.h"
  18: 
  19: Visible Procedure fix_nodes(pt, code) parsetree *pt; parsetree *code; {
  20:     context c; value *setup(), *su;
  21:     sv_context(&c);
  22:     curline= *pt; curlino= one;
  23:     su= setup(*pt);
  24:     if (su) analyze(*pt, su);
  25:     curline= *pt; curlino= one;
  26:     inithreads();
  27:     fix(pt, su ? 'x' : 'v');
  28:     endthreads(code);
  29:     cleanup();
  30: #ifdef TYPE_CHECK
  31:     if (cntxt != In_prmnv) type_check(*pt);
  32: #endif
  33:     set_context(&c);
  34: }
  35: 
  36: /* ******************************************************************** */
  37: 
  38: /* Utilities used by threading. */
  39: 
  40: /* A 'threaded tree' is, in our case, a fixed(*) parse tree with extra links
  41:    that are used by the interpreter to determine the execution order.
  42:    __________
  43:    (*) 'Fixed' means: processed by 'fix_nodes', which removes UNPARSED
  44:        nodes and distinguishes TAG nodes into local, global tags etc.
  45:        fix_nodes also creates the threads, but this is accidental, not
  46:        essential.  For UNPARSED nodes, the threads are actually laid
  47:        in a second pass through the subtree that was UNPARSED.
  48:    __________
  49: 
  50:    A small example: the parse tree for the expression  'a+b*c'  looks like
  51: 
  52: 	(DYOP,
  53: 		(TAGlocal, "a"),
  54: 		"+",
  55: 		(DYOP,
  56: 			(TAGlocal, "b"),
  57: 			"*",
  58: 			(TAGlocal, "c"))).
  59: 
  60:    The required execution order is here:
  61: 
  62: 	1) (TAGlocal, "a")
  63: 	2) (TAGlocal, "b")
  64: 	3) (TAGlocal, "c")
  65: 	4) (DYOP, ..., "*", ...)
  66: 	5) (DYOP, ..., "+", ...)
  67: 
  68:    Of course, the result of each operation (if it has a result) is pushed
  69:    on a stack, and the operands are popped from this same stack.  Think of
  70:    reversed polish notation (well-known by owners of HP pocket calculators).
  71: 
  72:    The 'threads' are explicit links from each node to its successor in this
  73:    execution order.  Conditional operations like IF and AND have two threads,
  74:    one for success and one for failure.  Loops can be made by having the
  75:    thread from the last node of the loop body point to the head of the loop.
  76: 
  77:    Threading expressions, locations and simple-commands is easy: recursively
  78:    thread each of the subtrees, then lay a thread from the last threaded
  79:    to the current node.  Nodes occurring in a 'location' context are
  80:    marked, so that the interpreter knows when to push a 'location' on
  81:    the stack.
  82: 
  83:    Tests and looping commands cause most of the complexity of the threading
  84:    utilities.  The basic technique is 'backpatching'.
  85:    Nodes that need a conditional forward jump are chained together in a
  86:    linked list, and when their destination is reached, all nodes in the
  87:    chain get its 'address' patched into their secondary thread.  There is
  88:    one such chain, called 'bpchain', which at all times contains those nodes
  89:    whose secondary destination would be the next generated instruction.
  90:    This is used by IF, WHILE, test-suites, AND and OR.
  91: 
  92:    To generate a loop, both this chain and the last normal instruction
  93:    (if any) are diverted to the node where the loop continues.
  94: 
  95:    For test-suites, we also need to be capable of jumping unconditionally
  96:    forward (over the remainder of the SELECT-command).  This is done by
  97:    saving both the backpatch chain and the last node visited, and restoring
  98:    them after the remainder has been processed.
  99: */
 100: 
 101: /* Implementation tricks: in order not to show circular lists to 'release',
 102:    parse tree nodes are generated as compounds where there is room for two
 103:    more fields than their length indicates.
 104: */
 105: 
 106: #define Flag (MkSmallInt(1))
 107:     /* Flag used to indicate Location or TestRefinement node */
 108: 
 109: Hidden parsetree start; /* First instruction.  Picked up by endthreads() */
 110: 
 111: Hidden parsetree last; /* Last visited node */
 112: 
 113: Hidden parsetree bpchain; /* Backpatch chain for conditional goto's */
 114: Hidden parsetree *wanthere; /* Chain of requests to return next tree */
 115: 
 116: extern string opcodes[];
 117: 
 118: 
 119: /* Start threading */
 120: 
 121: Hidden Procedure inithreads() {
 122:     bpchain= NilTree;
 123:     wanthere= 0;
 124:     last= 0;
 125:     here(&start);
 126: }
 127: 
 128: /* Finish threading */
 129: 
 130: Hidden Procedure endthreads(code) parsetree *code; {
 131:     jumpto(Stop);
 132:     if (!still_ok) start= NilTree;
 133:     *code= start;
 134: }
 135: 
 136: 
 137: /* Fill 't' as secondary thread for all nodes in the backpatch chain,
 138:    leaving the chain empty. */
 139: 
 140: Hidden Procedure backpatch(t) parsetree t; {
 141:     parsetree u;
 142:     while (bpchain != NilTree) {
 143:         u= Thread2(bpchain);
 144:         Thread2(bpchain)= t;
 145:         bpchain= u;
 146:     }
 147: }
 148: 
 149: Visible Procedure jumpto(t) parsetree t; {
 150:     parsetree u;
 151:     if (!still_ok) return;
 152:     while (wanthere != 0) {
 153:         u= *wanthere;
 154:         *wanthere= t;
 155:         wanthere= (parsetree*)u;
 156:     }
 157:     while (last != NilTree) {
 158:         u= Thread(last);
 159:         Thread(last)= t;
 160:         last= u;
 161:     }
 162:     backpatch(t);
 163: }
 164: 
 165: Hidden parsetree seterr(n) int n; {
 166:     return (parsetree)MkSmallInt(n);
 167: }
 168: 
 169: /* Visit node 't', and set its secondary thread to 't2'. */
 170: 
 171: Hidden Procedure visit2(t, t2) parsetree t, t2; {
 172:     if (!still_ok) return;
 173:     jumpto(t);
 174:     Thread2(t)= t2;
 175: #ifdef DEBUG
 176:     fprintf(stderr, "\tvisit %s %s\n", opcodes[Nodetype(t)],
 177:         t2 == NilTree ? "" : "[*]");
 178: #endif DEBUG
 179:     Thread(t)= NilTree;
 180:     last= t;
 181: }
 182: 
 183: /* Visit node 't' */
 184: 
 185: Hidden Procedure visit(t) parsetree t; {
 186:     visit2(t, NilTree);
 187: }
 188: 
 189: /* Visit node 't' and flag it as a location (or test-refinement). */
 190: 
 191: Hidden Procedure lvisit(t) parsetree t; {
 192:     visit2(t, Flag);
 193: }
 194: 
 195: #ifdef NOT_USED
 196: Hidden Procedure jumphere(t) parsetree t; {
 197:     Thread(t)= last;
 198:     last= t;
 199: }
 200: #endif
 201: 
 202: /* Add node 't' to the backpatch chain. */
 203: 
 204: Hidden Procedure jump2here(t) parsetree t; {
 205:     if (!still_ok) return;
 206:     Thread2(t)= bpchain;
 207:     bpchain= t;
 208: }
 209: 
 210: Hidden Procedure here(pl) parsetree *pl; {
 211:     if (!still_ok) return;
 212:     *pl= (parsetree) wanthere;
 213:     wanthere= pl;
 214: }
 215: 
 216: Visible Procedure hold(pl) struct state *pl; {
 217:     if (!still_ok) return;
 218:     pl->h_last= last; pl->h_bpchain= bpchain; pl->h_wanthere= wanthere;
 219:     last= bpchain= NilTree; wanthere= 0;
 220: }
 221: 
 222: Visible Procedure let_go(pl) struct state *pl; {
 223:     parsetree p, *w;
 224:     if (!still_ok) return;
 225:     if (last) {
 226:         for (p= last; Thread(p) != NilTree; p= Thread(p))
 227:             ;
 228:         Thread(p)= pl->h_last;
 229:     }
 230:     else last= pl->h_last;
 231:     if (bpchain) {
 232:         for (p= bpchain; Thread2(p) != NilTree; p= Thread2(p))
 233:             ;
 234:         Thread2(p)= pl->h_bpchain;
 235:     }
 236:     else bpchain= pl->h_bpchain;
 237:     if (wanthere) {
 238:         for (w= wanthere; *w != 0; w= (parsetree*) *w)
 239:             ;
 240:         *w= (parsetree) pl->h_wanthere;
 241:     }
 242:     else wanthere= pl->h_wanthere;
 243: }
 244: 
 245: Hidden bool reachable() {
 246:     return last != NilTree || bpchain != 0 || wanthere != 0;
 247: }
 248: 
 249: 
 250: /* ******************************************************************** */
 251: /* *********************** code generation **************************** */
 252: /* ******************************************************************** */
 253: 
 254: Forward bool is_variable();
 255: Forward bool is_cmd_ref();
 256: Forward value copydef();
 257: 
 258: Visible Procedure fix(pt, flag) parsetree *pt; char flag; {
 259:     struct state st; value v, function; parsetree t, l1= NilTree;
 260:     typenode nt; string s; char c; int n, k, len;
 261: 
 262:     t= *pt;
 263:     if (!Is_node(t) || !still_ok) return;
 264:     nt= Nodetype(t);
 265:     if (nt < 0 || nt >= NTYPES) syserr(MESS(2200, "fix bad tree"));
 266:     s= gentab[nt];
 267:     if (s == NULL) return;
 268:     n= First_fieldnr;
 269:     if (flag == 'x') curline= t;
 270:     while ((c= *s++) != '\0' && still_ok) {
 271:         switch (c) {
 272:         case '0':
 273:         case '1':
 274:         case '2':
 275:         case '3':
 276:         case '4':
 277:         case '5':
 278:         case '6':
 279:         case '7':
 280:         case '8':
 281:         case '9':
 282:             n= (c - '0') + First_fieldnr;
 283:             break;
 284:         case 'c':
 285:             v= *Branch(t, n);
 286:             if (v != Vnil) {
 287:                 len= Nfields(v);
 288:                 for (k= 0; k < len; ++k)
 289:                     fix(Field(v, k), flag);
 290:             }
 291:             ++n;
 292:             break;
 293:         case '#':
 294:             curlino= *Branch(t, n);
 295:             ++n;
 296:             break;
 297:         case 'g':
 298:         case 'h':
 299:             ++n;
 300:             break;
 301:         case 'a':
 302:         case 'l':
 303:             if (flag == 'v' || flag == 't')
 304:                 c= flag;
 305:             /* Fall through */
 306:         case '!':
 307:         case 't':
 308:         case 'u':
 309:         case 'v':
 310:         case 'x':
 311:             fix(Branch(t, n), c);
 312:             ++n;
 313:             break;
 314:         case 'f':
 315:             f_fpr_formals(*Branch(t, n));
 316:             ++n;
 317:             break;
 318: 
 319:         case '?':
 320:             if (flag == 'v')
 321:                 f_eunparsed(pt);
 322:             else if (flag == 't')
 323:                 f_cunparsed(pt);
 324:             else
 325:               syserr(MESS(2201, "fix unparsed with bad flag"));
 326:             fix(pt, flag);
 327:             break;
 328:         case 'C':
 329:             v= *Branch(t, REL_LEFT);
 330:             if (Comparison(Nodetype(v)))
 331:                 jump2here(v);
 332:             break;
 333:         case 'D':
 334:             v= (value)*Branch(t, DYA_NAME);
 335:             if (!is_dyafun(v, &function))
 336:               fixerr2(v, MESS(2202, " isn't a dyadic function"));
 337:             else
 338:                 *Branch(t, DYA_FCT)= copydef(function);
 339:             break;
 340:         case 'E':
 341:             v= (value)*Branch(t, DYA_NAME);
 342:             if (!is_dyaprd(v, &function))
 343:               fixerr2(v, MESS(2203, " isn't a dyadic predicate"));
 344:             else
 345:                 *Branch(t, DYA_FCT)= copydef(function);
 346:             break;
 347:         case 'G':
 348:             jumpto(l1);
 349:             break;
 350:         case 'H':
 351:             here(&l1);
 352:             break;
 353:         case 'I':
 354:             if (*Branch(t, n) == NilTree)
 355:                 break;
 356:             /* Else fall through */
 357:         case 'J':
 358:             jump2here(t);
 359:             break;
 360:         case 'K':
 361:             hold(&st);
 362:             break;
 363:         case 'L':
 364:             let_go(&st);
 365:             break;
 366:         case 'M':
 367:             v= (value)*Branch(t, MON_NAME);
 368:             if (is_variable(v) || !is_monfun(v, &function))
 369:               fixerr2(v, MESS(2204, " isn't a monadic function"));
 370:             else
 371:                 *Branch(t, MON_FCT)= copydef(function);
 372:             break;
 373:         case 'N':
 374:             v= (value)*Branch(t, MON_NAME);
 375:             if (is_variable(v) || !is_monprd(v, &function))
 376:               fixerr2(v, MESS(2205, " isn't a monadic predicate"));
 377:             else
 378:                 *Branch(t, MON_FCT)= copydef(function);
 379:             break;
 380: #ifdef REACH
 381:         case 'R':
 382:             if (*Branch(t, n) != NilTree && !reachable())
 383:                 fixerr(MESS(2206, "command cannot be reached"));
 384:             break;
 385: #endif
 386:         case 'S':
 387:             jumpto(Stop);
 388:             break;
 389:         case 'T':
 390:             if (flag == 't')
 391:                 f_ctag(pt);
 392:             else if (flag == 'v' || flag == 'x')
 393:                 f_etag(pt);
 394:             else
 395:                 f_ttag(pt);
 396:             break;
 397:         case 'U':
 398:             f_ucommand(pt);
 399:             break;
 400:         case 'V':
 401:             visit(t);
 402:             break;
 403:         case 'X':
 404:             if (flag == 'a' || flag == 'l' || flag == '!')
 405:                 lvisit(t);
 406:             else
 407:                 visit(t);
 408:             break;
 409:         case 'W':
 410: /*!*/           visit2(t, seterr(1));
 411:             break;
 412:         case 'Y':
 413:             if (still_ok && reachable()) {
 414:               if (nt == YIELD)
 415:                 fixerr(MESS(2207, "YIELD-unit returns no value"));
 416:               else
 417:                 fixerr(MESS(2208, "TEST-unit reports no outcome"));
 418:             }
 419:             break;
 420:         case 'Z':
 421:             if (!is_cmd_ref(t) && still_ok && reachable())
 422:   fixerr(MESS(2209, "refinement returns no value c.q. reports no outcome"));
 423:             *Branch(t, REF_START)= copy(l1);
 424:             break;
 425:         }
 426:     }
 427: }
 428: 
 429: /* ******************************************************************** */
 430: 
 431: Hidden bool is_cmd_ref(t) parsetree t; { /* HACK */
 432:     value name= *Branch(t, REF_NAME);
 433:     string s= strval(name);
 434:     /* return isupper(*s); */
 435:     return *s <= 'Z' && *s >= 'A';
 436: }
 437: 
 438: Visible value copydef(f) value f; {
 439:     funprd *fpr= Funprd(f);
 440:     if (fpr->pre == Use) return Vnil;
 441:     return copy(f);
 442: }
 443: 
 444: Hidden bool is_basic_target(v) value v; {
 445:     return envassoc(formals, v) ||
 446:         locals != Vnil && envassoc(locals, v) ||
 447:         envassoc(globals, v) ||
 448:         envassoc(mysteries, v);
 449: }
 450: 
 451: Hidden bool is_variable(v) value v; {
 452:     value f;
 453:     return is_basic_target(v) ||
 454:         envassoc(refinements, v) ||
 455:         is_zerfun(v, &f);
 456: }
 457: 
 458: Hidden bool is_target(p) parsetree p; {
 459:     value v= *Branch(p, First_fieldnr); int k, len;
 460:     switch (Nodetype(p)) {
 461: 
 462:     case TAG:
 463:         return is_basic_target(v);
 464: 
 465:     case SELECTION:
 466:     case BEHEAD:
 467:     case CURTAIL:
 468:     case COMPOUND:
 469:         return is_target(v);
 470: 
 471:     case COLLATERAL:
 472:         len= Nfields(v);
 473:         k_Overfields {
 474:             if (!is_target(*Field(v, k))) return No;
 475:         }
 476:         return Yes;
 477: 
 478:     default:
 479:         return No;
 480: 
 481:     }
 482: }
 483: 
 484: /* ******************************************************************** */
 485: 
 486: Hidden Procedure f_actuals(formals, pactuals) parsetree formals, *pactuals; {
 487:     /* name, actual, next */
 488:     value actuals= *pactuals, act, form, next_a, next_f, kw, *pact;
 489:     kw= *Branch(actuals, ACT_KEYW);
 490:     pact= Branch(actuals, ACT_EXPR); act= *pact;
 491:     form= *Branch(formals, FML_TAG);
 492:     next_a= *Branch(actuals, ACT_NEXT); next_f= *Branch(formals, FML_NEXT);
 493:     if (compare(*Branch(formals, FML_KEYW), kw) != 0)
 494:         fixerr3(MESS(2210, "wrong keyword "), kw, 0);
 495:     else if (act == Vnil && form != Vnil)
 496:         fixerr3(MESS(2211, "missing actual after "), kw, 0);
 497:     else if (next_a == Vnil && next_f != Vnil)
 498:         fixerr3(MESS(2212, "can't find expected "),
 499:             *Branch(next_f, FML_KEYW), 0);
 500:     else if (act != Vnil && form == Vnil)
 501:         fixerr3(MESS(2213, "unexpected actual after "), kw, 0);
 502:     else if (next_a != Vnil && next_f == Vnil)
 503:         fixerr3(MESS(2214, "unexpected keyword "),
 504:             *Branch(next_a, ACT_KEYW), 0);
 505:     else {
 506:         if (act != Vnil) {
 507:             parsetree st; struct state save;
 508:             hold(&save); here(&st);
 509:             if (is_target(act)) f_targ(pact);
 510:             else f_expr(pact);
 511:             jumpto(Stop); let_go(&save);
 512:             *Branch(actuals, ACT_START)= copy(st);
 513:         }
 514:         if (still_ok && next_a != Vnil)
 515:             f_actuals(next_f, Branch(actuals, ACT_NEXT));
 516:     }
 517: }
 518: 
 519: Hidden Procedure f_ucommand(pt) parsetree *pt; {
 520:     value t= *pt, *aa;
 521:     parsetree u, *f1= Branch(t, UCMD_NAME), *f2= Branch(t, UCMD_ACTUALS);
 522:     release(*Branch(t, UCMD_DEF));
 523:     *Branch(t, UCMD_DEF)= Vnil;
 524:     if ((aa= envassoc(refinements, *f1)) != Pnil) {
 525:         if (*Branch(*f2, ACT_EXPR) != Vnil
 526:                 || *Branch(*f2, ACT_NEXT) != Vnil)
 527:             fixerr(MESS(2215, "refinement with parameters"));
 528:         else *Branch(t, UCMD_DEF)= copy(*aa);
 529:     }
 530:     else if (is_unit(*f1, How, &aa)) {
 531:         u= How_to(*aa)->unit;
 532:         f_actuals(*Branch(u, HOW_FORMALS), f2);
 533:     }
 534:     else if (still_ok)
 535:         fixerr3(MESS(2216, "you haven't told me HOW'TO "), *f1, 0);
 536: }
 537: 
 538: Hidden Procedure f_fpr_formals(t) parsetree t; {
 539:     switch (Nodetype(t)) {
 540:     case TAG:
 541:         break;
 542:     case MONF: case MONPRD:
 543:         f_targ(Branch(t, MON_RIGHT));
 544:         break;
 545:     case DYAF: case DYAPRD:
 546:         f_targ(Branch(t, DYA_LEFT));
 547:         f_targ(Branch(t, DYA_RIGHT));
 548:         break;
 549:     default:
 550:         syserr(MESS(2217, "f_fpr_formals"));
 551:     }
 552: }
 553: 
 554: Visible bool modify_tag(name, tag) parsetree *tag; value name; {
 555:     value *aa, function;
 556:     *tag= NilTree;
 557:     if (aa= envassoc(formals, name))
 558:         *tag= node3(TAGformal, name, copy(*aa));
 559:     else if (locals != Vnil && (aa= envassoc(locals, name)))
 560:         *tag= node3(TAGlocal, name, copy(*aa));
 561:     else if (aa= envassoc(globals, name))
 562:         *tag= node2(TAGglobal, name);
 563:     else if (aa= envassoc(mysteries, name))
 564:         *tag= node3(TAGmystery, name, copy(*aa));
 565:     else if (aa= envassoc(refinements, name))
 566:         *tag= node3(TAGrefinement, name, copy(*aa));
 567:     else if (is_zerfun(name, &function))
 568:         *tag= node3(TAGzerfun, name, copydef(function));
 569:     else if (is_zerprd(name, &function))
 570:         *tag= node3(TAGzerprd, name, copydef(function));
 571:     else return No;
 572:     return Yes;
 573: }
 574: 
 575: Hidden Procedure f_etag(pt) parsetree *pt; {
 576:     parsetree t= *pt; value name= copy(*Branch(t, TAG_NAME));
 577:     if (modify_tag(name, &t)) {
 578:         release(*pt);
 579:         *pt= t;
 580:         if (Nodetype(t) == TAGzerprd)
 581:             fixerr2(name, MESS(2218, " cannot be used in an expression"));
 582:         else
 583:             visit(t);
 584:     } else {
 585:         fixerr2(name, MESS(2219, " has not yet received a value"));
 586:         release(name);
 587:     }
 588: }
 589: 
 590: Hidden Procedure f_ttag(pt) parsetree *pt; {
 591:     parsetree t= *pt; value name= copy(*Branch(t, TAG_NAME));
 592:     if (modify_tag(name, &t)) {
 593:         release(*pt);
 594:         *pt= t;
 595:         switch (Nodetype(t)) {
 596:         case TAGrefinement:
 597:             fixerr(MESS(2220, "a refinement may not be used as a target"));
 598:             break;
 599:         case TAGzerfun:
 600:         case TAGzerprd:
 601:             fixerr2(name, MESS(2221, " hasn't been initialised or defined"));
 602:             break;
 603:         default:
 604:             lvisit(t);
 605:             break;
 606:         }
 607:     } else {
 608:         fixerr2(name, MESS(2222, " hasn't been initialised or defined"));
 609:         release(name);
 610:     }
 611: }
 612: 
 613: Hidden Procedure f_ctag(pt) parsetree *pt; {
 614:     parsetree t= *pt; value name= copy(*Branch(t, TAG_NAME));
 615:     if (modify_tag(name, &t)) {
 616:         release(*pt);
 617:         *pt= t;
 618:         switch (Nodetype(t)) {
 619:         case TAGrefinement:
 620:             lvisit(t); /* 'Loc' flag here means 'Test' */
 621:             break;
 622:         case TAGzerprd:
 623:             visit(t);
 624:             break;
 625:         default:
 626:             fixerr2(name, MESS(2223, " is neither a refined test nor a zeroadic predicate"));
 627:             break;
 628:         }
 629:     } else {
 630:         fixerr2(name, MESS(2224, " is neither a refined test nor a zeroadic predicate"));
 631:         release(name);
 632:     }
 633: }

Defined functions

Defined variables

Defined macros