home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b2gen.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  15.5 KB  |  634 lines
  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. }
  634.