home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / compiler.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-03-17  |  41.5 KB  |  1,470 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * compiler.c:  Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * This is the Gofer compiler, handling translation of typechecked code to
  7.  * `kernel' language, elimination of pattern matching and translation to
  8.  * super combinators (lambda lifting).
  9.  * ------------------------------------------------------------------------*/
  10.  
  11. #include "prelude.h"
  12. #include "storage.h"
  13. #include "connect.h"
  14.  
  15. #if MPW
  16. #pragma segment Compiler
  17. #endif
  18.  
  19. Bool useConformality = TRUE;        /* TRUE => check pat-bind conform'y*/
  20.  
  21. Addr inputCode;                /* Addr of compiled code for expr  */
  22.  
  23. Name nameResult, nameBind;        /* for translating monad comps       */
  24. Name nameZero;                /* for monads with a zero       */
  25.  
  26. /* --------------------------------------------------------------------------
  27.  * Local function prototypes:
  28.  * ------------------------------------------------------------------------*/
  29.  
  30. static Cell local translate        Args((Cell));
  31. static Void local transPair        Args((Pair));
  32. static Void local transTriple        Args((Triple));
  33. static Void local transAlt        Args((Cell));
  34. static Void local transCase        Args((Cell));
  35. static List local transBinds        Args((List));
  36. static Cell local transRhs        Args((Cell));
  37. static Cell local mkConsList        Args((List));
  38. static Cell local expandLetrec        Args((Cell));
  39.  
  40. static Cell local transComp        Args((Cell,List,Cell));
  41. static Cell local transMComp        Args((Cell,Cell,Cell,List));
  42.  
  43. static Cell local refutePat        Args((Cell));
  44. static List local remPat        Args((Cell,Cell,List));
  45. static List local remPat1        Args((Cell,Cell,List));
  46.  
  47. static Cell local pmcTerm        Args((Int,List,Cell));
  48. static Cell local pmcPair        Args((Int,List,Pair));
  49. static Cell local pmcTriple        Args((Int,List,Triple));
  50. static Cell local pmcVar        Args((List,Text));
  51. static Void local pmcLetrec        Args((Int,List,Pair));
  52. static Cell local pmcVarDef        Args((Int,List,List));
  53. static Void local pmcFunDef        Args((Int,List,Triple));
  54.  
  55. static Cell local match         Args((Int,List,List));
  56. static Void local tidyHdPat        Args((Offset,Cell));
  57. static Cell local hdDiscr        Args((List));
  58. static Int  local discrKind        Args((Cell));
  59.  
  60. static Cell local matchVar        Args((Int,List,List,Cell));
  61.  
  62. static Cell local matchCon        Args((Int,List,List,Cell));
  63. static List local addConTable        Args((Cell,Cell,List));
  64. static Cell local makeCases        Args((Int,List,List));
  65.  
  66. static Cell local matchInt        Args((Int,List,List,Cell));
  67.  
  68. static List local addOffsets        Args((Int,Int,List));
  69. static Cell local mkSwitch        Args((List,Pair));
  70. static Cell local joinSw        Args((Int,List));
  71. static Bool local canFail        Args((Cell));
  72.  
  73. static Cell local lift            Args((Int,List,Cell));
  74. static Void local liftPair        Args((Int,List,Pair));
  75. static Void local liftTriple        Args((Int,List,Triple));
  76. static Void local liftAlt        Args((Int,List,Cell));
  77. static Cell local liftVar        Args((List,Cell));
  78. static Cell local liftLetrec        Args((Int,List,Cell));
  79. static Void local liftFundef        Args((Int,List,Triple));
  80. static Void local solve         Args((List));
  81.  
  82. static Cell local preComp        Args((Cell));
  83. static Cell local preCompPair        Args((Pair));
  84. static Cell local preCompTriple     Args((Triple));
  85. static Void local preCompCase        Args((Pair));
  86. static Cell local preCompOffset     Args((Int));
  87.  
  88. static Void local compileGlobalFunction Args((Pair));
  89. static Void local compileMemberFunction Args((Name));
  90. static Void local newGlobalFunction    Args((Name,Int,List,Int,Cell));
  91.  
  92. /* --------------------------------------------------------------------------
  93.  * Transformation: Convert input expressions into a less complex language
  94.  *           of terms using only LETREC, AP, constants and vars.
  95.  *           Also remove pattern definitions on lhs of eqns.
  96.  * ------------------------------------------------------------------------*/
  97.  
  98. static Cell local translate(e)           /* Translate expression:        */
  99. Cell e; {
  100.     switch (whatIs(e)) {
  101.     case LETREC    : snd(snd(e)) = translate(snd(snd(e)));
  102.               return expandLetrec(e);
  103.  
  104.     case COND    : transTriple(snd(e));
  105.               break;
  106.  
  107.     case AP     : transPair(e);
  108.               break;
  109.  
  110.     case UNIT    :
  111.     case TUPLE    :
  112.     case NAME    :
  113.     case SELECT    :
  114.     case VAROPCELL    :
  115.     case VARIDCELL    :
  116.     case DICTVAR    :
  117.     case DICTCELL    :
  118.     case INTCELL    :
  119.     case FLOATCELL  :
  120.     case STRCELL    :
  121.     case CHARCELL    : break;
  122.  
  123.     case FINLIST    : mapOver(translate,snd(e));
  124.               return mkConsList(snd(e));
  125.  
  126.     case LISTCOMP    : return transComp(translate(fst(snd(e))),
  127.                        snd(snd(e)),
  128.                        nameNil);
  129.  
  130.     case MONADCOMP  : if (dictOf(fst(fst(snd(e)))) == listMonadDict())
  131.                   return transComp(translate(fst(snd(snd(e)))),
  132.                            snd(snd(snd(e))),
  133.                            nameNil);
  134.               else
  135.                   return transMComp(fst(fst(snd(e))),
  136.                         snd(fst(snd(e))),
  137.                         translate(fst(snd(snd(e)))),
  138.                         snd(snd(snd(e))));
  139.  
  140.     case ESIGN    : return translate(fst(snd(e)));
  141.  
  142.     case CASE    : {   Cell nv = inventVar();
  143.                   mapProc(transCase,snd(snd(e)));
  144.                   return ap(LETREC,
  145.                     pair(singleton(pair(nv,snd(snd(e)))),
  146.                          ap(nv,translate(fst(snd(e))))));
  147.               }
  148.  
  149.     case LAMBDA    : {   Cell nv = inventVar();
  150.                   transAlt(snd(e));
  151.                   return ap(LETREC,
  152.                     pair(singleton(pair(
  153.                             nv,
  154.                             singleton(snd(e)))),
  155.                          nv));
  156.               }
  157.  
  158.     default     : internal("translate");
  159.     }
  160.     return e;
  161. }
  162.  
  163. static Void local transPair(pr)        /* Translate each component in a    */
  164. Pair pr; {                   /* pair of expressions.           */
  165.     fst(pr) = translate(fst(pr));
  166.     snd(pr) = translate(snd(pr));
  167. }
  168.  
  169. static Void local transTriple(tr)      /* Translate each component in a    */
  170. Triple tr; {                   /* triple of expressions.       */
  171.     fst3(tr) = translate(fst3(tr));
  172.     snd3(tr) = translate(snd3(tr));
  173.     thd3(tr) = translate(thd3(tr));
  174. }
  175.  
  176. static Void local transAlt(e)           /* Translate alt:           */
  177. Cell e; {                   /* ([Pat], Rhs) ==> ([Pat], Rhs')   */
  178.     snd(e) = transRhs(snd(e));
  179. }
  180.  
  181. static Void local transCase(c)           /* Translate case:           */
  182. Cell c; {                   /* (Pat, Rhs) ==> ([Pat], Rhs')       */
  183.     fst(c) = singleton(fst(c));
  184.     snd(c) = transRhs(snd(c));
  185. }
  186.  
  187. static List local transBinds(bs)       /* Translate list of bindings:       */
  188. List bs; {                   /* eliminating pattern matching on  */
  189.     List newBinds;               /* lhs of bindings.           */
  190.  
  191.     for (newBinds=NIL; nonNull(bs); bs=tl(bs)) {
  192.     if (isVar(fst(hd(bs)))) {
  193.         mapProc(transAlt,snd(hd(bs)));
  194.         newBinds = cons(hd(bs),newBinds);
  195.     }
  196.     else
  197.         newBinds = remPat(fst(snd(hd(bs))),
  198.                   snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
  199.                   newBinds);
  200.     }
  201.  
  202.     return newBinds;
  203. }
  204.  
  205. static Cell local transRhs(rhs)        /* Translate rhs: removing line nos */
  206. Cell rhs; {
  207.     switch (whatIs(rhs)) {
  208.     case LETREC  : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
  209.                return expandLetrec(rhs);
  210.  
  211.     case GUARDED : mapOver(snd,snd(rhs));        /* discard line number */
  212.                mapProc(transPair,snd(rhs));
  213.                return rhs;
  214.  
  215.     default      : return translate(snd(rhs));  /* discard line number */
  216.     }
  217. }
  218.  
  219. static Cell local mkConsList(es)       /* Construct expression for list es */
  220. List es; {                   /* using nameNil and nameCons       */
  221.     if (isNull(es))
  222.     return nameNil;
  223.     else
  224.     return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
  225. }
  226.  
  227. static Cell local expandLetrec(root)   /* translate LETREC with list of    */
  228. Cell root; {                   /* groups of bindings (from depend. */
  229.     Cell e   = snd(snd(root));           /* analysis) to use nested LETRECs  */
  230.     List bss = fst(snd(root));
  231.     Cell temp;
  232.  
  233.     if (isNull(bss))               /* should never happen, but just in */
  234.     return e;               /* case:  LETREC [] IN e  ==>  e    */
  235.  
  236.     mapOver(transBinds,bss);           /* translate each group of bindings */
  237.  
  238.     for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
  239.     fst(snd(temp)) = hd(bss);
  240.     snd(snd(temp)) = ap(LETREC,pair(NIL,e));
  241.     temp           = snd(snd(temp));
  242.     }
  243.     fst(snd(temp)) = hd(bss);
  244.  
  245.     return root;
  246. }
  247.  
  248. /* --------------------------------------------------------------------------
  249.  * Transformation of list comprehensions is based on the description in
  250.  * `The Implementation of Functional Programming Languages':
  251.  *
  252.  * [ e | qs ] ++ L          => transComp e qs []
  253.  * transComp e []        l => e : l
  254.  * transComp e ((p<-xs):qs) l => LETREC _h []       = l
  255.  *                    _h (p:_xs) = transComp e qs (_h _xs)
  256.  *                    _h (_:_xs) = _h _xs --if p refutable.
  257.  *                 IN _h xs
  258.  * transComp e (b:qs)        l => if b then transComp e qs l else l
  259.  * transComp e (decls:qs)   l => LETREC decls IN transComp e qs l
  260.  * ------------------------------------------------------------------------*/
  261.  
  262. static Cell local transComp(e,qs,l)    /* Translate [e | qs] ++ l       */
  263. Cell e;
  264. List qs;
  265. Cell l; {
  266.     if (nonNull(qs)) {
  267.     Cell q     = hd(qs);
  268.     Cell qs1 = tl(qs);
  269.  
  270.     switch (fst(q)) {
  271.         case FROMQUAL : {    Cell ld    = NIL;
  272.                 Cell hVar  = inventVar();
  273.                 Cell xsVar = inventVar();
  274.  
  275.                 if (refutable(fst(snd(q))))
  276.                     ld = cons(pair(singleton(
  277.                             ap(ap(nameCons,
  278.                               WILDCARD),
  279.                               xsVar)),
  280.                            ap(hVar,xsVar)),
  281.                           ld);
  282.  
  283.                 ld = cons(pair(singleton(
  284.                         ap(ap(nameCons,
  285.                               fst(snd(q))),
  286.                               xsVar)),
  287.                            transComp(e,
  288.                              qs1,
  289.                              ap(hVar,xsVar))),
  290.                       ld);
  291.                 ld = cons(pair(singleton(nameNil),
  292.                            l),
  293.                       ld);
  294.  
  295.                 return ap(LETREC,
  296.                       pair(singleton(pair(hVar,
  297.                                   ld)),
  298.                            ap(hVar,
  299.                           translate(snd(snd(q))))));
  300.                 }
  301.  
  302.         case QWHERE   : return
  303.                 expandLetrec(ap(LETREC,
  304.                         pair(snd(q),
  305.                              transComp(e,qs1,l))));
  306.  
  307.         case BOOLQUAL : return ap(COND,
  308.                       triple(translate(snd(q)),
  309.                          transComp(e,qs1,l),
  310.                          l));
  311.     }
  312.     }
  313.  
  314.     return ap(ap(nameCons,e),l);
  315. }
  316.  
  317. /* --------------------------------------------------------------------------
  318.  * Transformation of monad comprehensions is based on the description in
  319.  * Comprehending monads / The essence of functional programming:
  320.  *
  321.  * [ e | ]                =>  return m e
  322.  * [ e | p <- exp, qs ]   =>  LETREC _h p = [ e | qs]
  323.  *                     _h _ = zero m0    -- if monad with 0
  324.  *                  IN bind m exp _h
  325.  * [ e | LET decls, qs ]  =>  LETREC decls IN [ e | qs ]
  326.  * [ e | guard, qs ]      =>  if guard then [ e | qs ] else zero m0
  327.  *
  328.  * where  m :: Monad f,  m0 :: Monad0 f
  329.  * ------------------------------------------------------------------------*/
  330.  
  331. static Cell local transMComp(m,m0,e,qs)    /* Translate [e | qs]           */
  332. Cell m;
  333. Cell m0;
  334. Cell e;
  335. List qs; {
  336.     if (nonNull(qs)) {
  337.     Cell q     = hd(qs);
  338.     Cell qs1 = tl(qs);
  339.  
  340.     switch (fst(q)) {
  341.         case FROMQUAL : {    Cell ld   = NIL;
  342.                 Cell hVar = inventVar();
  343.  
  344.                 if (refutable(fst(snd(q))) && nonNull(m0))
  345.                     ld = cons(pair(singleton(WILDCARD),
  346.                            ap(nameZero,m0)),ld);
  347.  
  348.                 ld = cons(pair(singleton(fst(snd(q))),
  349.                            transMComp(m,m0,e,qs1)),
  350.                       ld);
  351.  
  352.                 return ap(LETREC,
  353.                       pair(singleton(pair(hVar,ld)),
  354.                            ap(ap(ap(nameBind,
  355.                             m),
  356.                              translate(snd(snd(q)))),
  357.                           hVar)));
  358.                 }
  359.  
  360.         case QWHERE      : return
  361.                 expandLetrec(ap(LETREC,
  362.                         pair(snd(q),
  363.                              transMComp(m,m0,e,qs1))));
  364.  
  365.         case BOOLQUAL : return ap(COND,
  366.                       triple(translate(snd(q)),
  367.                          transMComp(m,m0,e,qs1),
  368.                          ap(nameZero,m0)));
  369.     }
  370.     }
  371.  
  372.     return ap(ap(nameResult,m),e);
  373. }
  374.  
  375. /* --------------------------------------------------------------------------
  376.  * Elimination of pattern bindings:
  377.  *
  378.  * The following code adopts the definition of irrefutable patterns as given
  379.  * in the Haskell report in which only variables, wildcards and ~pat patterns
  380.  * are irrefutable.  Note that the definition in Peyton Jones also includes
  381.  * product constructor functions (e.g. tuples) as irrefutable patterns.
  382.  * ------------------------------------------------------------------------*/
  383.  
  384. Bool refutable(pat)          /* is pattern refutable (do we need to   */
  385. Cell pat; {              /* to use a conformality check?)       */
  386.     Cell c = getHead(pat);
  387.  
  388.     switch (whatIs(c)) {
  389.     case ASPAT     : return refutable(snd(snd(pat)));
  390.  
  391.     case LAZYPAT   :
  392.     case VAROPCELL :
  393.     case VARIDCELL :
  394.     case DICTVAR   :
  395.     case WILDCARD  : return FALSE;
  396.  
  397.     default        : return TRUE;
  398.     }
  399. }
  400.  
  401. static Cell local refutePat(pat)  /* find pattern to refute in conformality*/
  402. Cell pat; {              /* test with pat.               */
  403.                   /* e.g. refPat  (x,y) == (_,_)       */
  404.                   /*      refPat ~(x,y) == _      etc..    */
  405.  
  406.     switch (whatIs(pat)) {
  407.     case ASPAT     : return refutePat(snd(snd(pat)));
  408.  
  409.     case FINLIST   : {   Cell ys = snd(pat);
  410.                  Cell xs = NIL;
  411.                  for (; nonNull(ys); ys=tl(ys))
  412.                  xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
  413.                  return revOnto(xs,nameNil);
  414.              }
  415.  
  416.     case VAROPCELL :
  417.     case VARIDCELL :
  418.     case DICTVAR   :
  419.     case WILDCARD  :
  420.     case LAZYPAT   : return WILDCARD;
  421.  
  422.     case INTCELL   :
  423.         case FLOATCELL :
  424.     case STRCELL   :
  425.     case CHARCELL  :
  426.     case ADDPAT    :
  427.     case MULPAT    :
  428.     case UNIT      :
  429.     case TUPLE     :
  430.     case NAME      : return pat;
  431.  
  432.     case AP        : return ap(refutePat(fun(pat)),refutePat(arg(pat)));
  433.  
  434.     default        : internal("refutePat");
  435.              return NIL; /*NOTREACHED*/
  436.     }
  437. }
  438.  
  439. #define addEqn(v,val,lds)  cons(pair(v,singleton(pair(NIL,val))),lds)
  440.  
  441. static List local remPat(pat,expr,lds)
  442. Cell pat;              /* Produce list of definitions for eqn   */
  443. Cell expr;              /* pat = expr, including a conformality  */
  444. List lds; {              /* check if required.            */
  445.  
  446.     /* Conformality test (if required):
  447.      *     pat = expr  ==>    nv = LETREC confCheck nv@pat = nv
  448.      *                 IN confCheck expr
  449.      *                remPat1(pat,nv,.....);
  450.      */
  451.  
  452.     if (useConformality && refutable(pat)) {
  453.     Cell confVar = inventVar();
  454.     Cell nv      = inventVar();
  455.     Cell locfun  = pair(confVar,         /* confVar [([nv@refPat],nv)] */
  456.                 singleton(pair(singleton(ap(ASPAT,
  457.                             pair(nv,
  458.                                  refutePat(pat)))),
  459.                        nv)));
  460.  
  461.     if (whatIs(expr)==GUARDED) {         /* A spanner ... special case */
  462.         lds  = addEqn(nv,expr,lds);         /* for guarded pattern binding*/
  463.         expr = nv;
  464.         nv   = inventVar();
  465.     }
  466.  
  467.     if (whatIs(pat)==ASPAT) {         /* avoid using new variable if*/
  468.         nv   = fst(snd(pat));         /* a variable is already given*/
  469.         pat  = snd(snd(pat));         /* by an as-pattern       */
  470.     }
  471.  
  472.     lds = addEqn(nv,                /* nv =        */
  473.              ap(LETREC,pair(singleton(locfun),    /* LETREC [locfun] */
  474.                     ap(confVar,expr))), /* IN confVar expr */
  475.              lds);
  476.  
  477.     return remPat1(pat,nv,lds);
  478.     }
  479.  
  480.     return remPat1(pat,expr,lds);
  481. }
  482.  
  483. static List local remPat1(pat,expr,lds)
  484. Cell pat;              /* Add definitions for: pat = expr to    */
  485. Cell expr;              /* list of local definitions in lds.       */
  486. List lds; {
  487.     Cell c;
  488.  
  489.     switch (whatIs(c=getHead(pat))) {
  490.     case WILDCARD  :
  491.     case UNIT      :
  492.     case INTCELL   :
  493.         case FLOATCELL :
  494.     case STRCELL   :
  495.     case CHARCELL  : break;
  496.  
  497.     case ASPAT     : return remPat1(snd(snd(pat)),       /* v@pat = expr */
  498.                     fst(snd(pat)),
  499.                     addEqn(fst(snd(pat)),expr,lds));
  500.  
  501.     case LAZYPAT   : {   Cell nv;
  502.  
  503.                  if (isVar(expr) || isName(expr))
  504.                  nv  = expr;
  505.                  else {
  506.                  nv  = inventVar();
  507.                  lds = addEqn(nv,expr,lds);
  508.                  }
  509.  
  510.                  return remPat(snd(pat),nv,lds);
  511.              }
  512.  
  513.     case ADDPAT    : return addEqn(snd(pat),       /* n + k = expr */
  514.                        ap(ap(nameMinus,expr),
  515.                       mkInt(intValOf(fst(pat)))),
  516.                        lds);
  517.  
  518.     case MULPAT    : return addEqn(snd(pat),       /* c * n = expr */
  519.                        ap(ap(nameDivide,expr),
  520.                       mkInt(intValOf(fst(pat)))),
  521.                        lds);
  522.  
  523.     case FINLIST   : return remPat1(mkConsList(snd(pat)),expr,lds);
  524.  
  525.     case DICTVAR   : /* shouldn't really occur */
  526.     case VARIDCELL :
  527.     case VAROPCELL : return addEqn(pat,expr,lds);
  528.  
  529.     case TUPLE     :
  530.     case NAME      : {   List ps = getArgs(pat);
  531.  
  532.                  if (nonNull(ps)) {
  533.                  Cell nv, sel;
  534.                  Int  i;
  535.  
  536.                  if (isVar(expr) || isName(expr))
  537.                      nv  = expr;
  538.                  else {
  539.                      nv  = inventVar();
  540.                      lds = addEqn(nv,expr,lds);
  541.                  }
  542.  
  543.                  sel = ap(ap(nameSel,c),nv);
  544.                  for (i=1; nonNull(ps); ++i, ps=tl(ps))
  545.                       lds = remPat1(hd(ps),
  546.                             ap(sel,mkInt(i)),
  547.                             lds);
  548.                  }
  549.              }
  550.              break;
  551.  
  552.     default        : internal("remPat1");
  553.              break;
  554.     }
  555.     return lds;
  556. }
  557.  
  558. /* --------------------------------------------------------------------------
  559.  * Eliminate pattern matching in function definitions -- pattern matching
  560.  * compiler:
  561.  *
  562.  * Based on Wadler's algorithms described in `Implementation of functional
  563.  * programming languages'.
  564.  *
  565.  * During the translation, in preparation for later stages of compilation,
  566.  * all local and bound variables are replaced by suitable offsets, and
  567.  * locally defined function symbols are given new names (which will
  568.  * eventually be their names when lifted to make top level definitions).
  569.  * ------------------------------------------------------------------------*/
  570.  
  571. static Offset freeBegin; /* only variables with offset <= freeBegin are of */
  572. static List   freeVars;  /* interest as `free' variables           */
  573. static List   freeFuns;  /* List of `free' local functions           */
  574.  
  575. static Cell local pmcTerm(co,sc,e)     /* apply pattern matching compiler  */
  576. Int  co;                   /* co = current offset           */
  577. List sc;                   /* sc = scope               */
  578. Cell e;  {                   /* e  = expr to transform       */
  579.     switch (whatIs(e)) {
  580.     case GUARDED  : map2Over(pmcPair,co,sc,snd(e));
  581.             break;
  582.  
  583.     case LETREC   : pmcLetrec(co,sc,snd(e));
  584.             break;
  585.  
  586.     case VARIDCELL:
  587.     case VAROPCELL:
  588.     case DICTVAR  : return pmcVar(sc,textOf(e));
  589.  
  590.     case COND     : return ap(COND,pmcTriple(co,sc,snd(e)));
  591.  
  592.     case AP       : return pmcPair(co,sc,e);
  593.  
  594.     case UNIT     :
  595.     case TUPLE    :
  596.     case NAME     :
  597.     case SELECT   :
  598.     case DICTCELL :
  599.     case CHARCELL :
  600.     case INTCELL  :
  601.         case FLOATCELL:
  602.     case STRCELL  : break;
  603.  
  604.     default       : internal("pmcTerm");
  605.             break;
  606.     }
  607.     return e;
  608. }
  609.  
  610. static Cell local pmcPair(co,sc,pr)    /* apply pattern matching compiler  */
  611. Int  co;                   /* to a pair of exprs           */
  612. List sc;
  613. Pair pr; {
  614.     return pair(pmcTerm(co,sc,fst(pr)),
  615.         pmcTerm(co,sc,snd(pr)));
  616. }
  617.  
  618. static Cell local pmcTriple(co,sc,tr)  /* apply pattern matching compiler  */
  619. Int    co;                   /* to a triple of exprs           */
  620. List   sc;
  621. Triple tr; {
  622.     return triple(pmcTerm(co,sc,fst3(tr)),
  623.           pmcTerm(co,sc,snd3(tr)),
  624.           pmcTerm(co,sc,thd3(tr)));
  625. }
  626.  
  627. static Cell local pmcVar(sc,t)           /* find translation of variable       */
  628. List sc;                   /* in current scope           */
  629. Text t; {
  630.     List xs;
  631.     Name n;
  632.  
  633.     for (xs=sc; nonNull(xs); xs=tl(xs)) {
  634.     Cell x = hd(xs);
  635.     if (t==textOf(fst(x)))
  636.         if (isOffset(snd(x))) {             /* local variable ... */
  637.         if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
  638.             freeVars = cons(snd(x),freeVars);
  639.         return snd(x);
  640.         }
  641.         else {                     /* local function ... */
  642.         if (!cellIsMember(snd(x),freeFuns))
  643.             freeFuns = cons(snd(x),freeFuns);
  644.         return fst3(snd(x));
  645.         }
  646.     }
  647.  
  648.     if (isNull(n=findName(t)))           /* Lookup global name - the only way*/
  649.     n = newName(t);            /* this (should be able to happen)  */
  650.                        /* is with new global var introduced*/
  651.                        /* after type check; e.g. remPat1   */
  652.     return n;
  653. }
  654.  
  655. static Void local pmcLetrec(co,sc,e)   /* apply pattern matching compiler  */
  656. Int  co;                   /* to LETREC, splitting decls into  */
  657. List sc;                   /* two sections               */
  658. Pair e; {
  659.     List fs = NIL;               /* local function definitions       */
  660.     List vs = NIL;               /* local variable definitions       */
  661.     List ds;
  662.  
  663.     for (ds=fst(e); nonNull(ds); ds=tl(ds)) {        /* Split decls into two */
  664.     Cell v       = fst(hd(ds));
  665.     Int  arity = length(fst(hd(snd(hd(ds)))));
  666.  
  667.     if (arity==0) {                /* Variable declaration */
  668.         vs = cons(snd(hd(ds)),vs);
  669.         sc = cons(pair(v,mkOffset(++co)),sc);
  670.     }
  671.     else {                       /* Function declaration */
  672.         fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
  673.         sc = cons(pair(v,hd(fs)),sc);
  674.     }
  675.     }
  676.     vs         = rev(vs);            /* Put declaration lists back in    */
  677.     fs         = rev(fs);            /* original order           */
  678.     fst(e)   = pair(vs,fs);           /* Store declaration lists       */
  679.     map2Over(pmcVarDef,co,sc,vs);      /* Translate variable definitions   */
  680.     map2Proc(pmcFunDef,co,sc,fs);      /* Translate function definitions   */
  681.     snd(e)   = pmcTerm(co,sc,snd(e));  /* Translate LETREC body        */
  682.     freeFuns = diffList(freeFuns,fs);  /* Delete any `freeFuns' bound in fs*/
  683. }
  684.  
  685. static Cell local pmcVarDef(co,sc,vd)  /* apply pattern matching compiler  */
  686. Int  co;                   /* to variable definition       */
  687. List sc;
  688. List vd; {                   /* vd :: [ ([], rhs) ]           */
  689.     Cell d = snd(hd(vd));
  690.     if (nonNull(tl(vd)) && canFail(d))
  691.     return ap(FATBAR,pair(pmcTerm(co,sc,d),
  692.                   pmcVarDef(co,sc,tl(vd))));
  693.     return pmcTerm(co,sc,d);
  694. }
  695.  
  696. static Void local pmcFunDef(co,sc,fd)  /* apply pattern matching compiler  */
  697. Int    co;                   /* to function definition       */
  698. List   sc;
  699. Triple fd; {                   /* fd :: (Var, Arity, [Alt])       */
  700.     Offset saveFreeBegin = freeBegin;
  701.     List   saveFreeVars  = freeVars;
  702.     List   saveFreeFuns  = freeFuns;
  703.     Int    arity     = intOf(snd3(fd));
  704.     Cell   temp      = thd3(fd);
  705.     Cell   xs;
  706.  
  707.     map1Over(mkSwitch,sc,temp);
  708.  
  709.     freeBegin = mkOffset(co);
  710.     freeVars  = NIL;
  711.     freeFuns  = NIL;
  712.     temp      = match(co+arity,temp,addOffsets(co+arity,co+1,NIL));
  713.     thd3(fd)  = triple(freeVars,freeFuns,temp);
  714.  
  715.     for (xs=freeVars; nonNull(xs); xs=tl(xs))
  716.     if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
  717.         saveFreeVars = cons(hd(xs),saveFreeVars);
  718.  
  719.     for (xs=freeFuns; nonNull(xs); xs=tl(xs))
  720.     if (!cellIsMember(hd(xs),saveFreeFuns))
  721.         saveFreeFuns = cons(hd(xs),saveFreeFuns);
  722.  
  723.     freeBegin = saveFreeBegin;
  724.     freeVars  = saveFreeVars;
  725.     freeFuns  = saveFreeFuns;
  726. }
  727.  
  728. /* --------------------------------------------------------------------------
  729.  * Main part of pattern matching compiler: convert lists of Alt to case
  730.  * construct:
  731.  *
  732.  * At each stage, each branch is represented by an element of type:
  733.  *    Switch ::= ([Pat],Scope,Rhs)
  734.  * which indicates that, if we can succeed in matching the given list of
  735.  * patterns, then the result will be the indicated Rhs.  The Scope component
  736.  * has type:
  737.  *    Scope  ::= [(Var,Expr)]
  738.  * and provides a mapping from variable names to offsets used in the matching
  739.  * process.
  740.  *
  741.  * ------------------------------------------------------------------------*/
  742.  
  743. #define switchPats(s)          fst3(s)
  744. #define switchSyms(s)          snd3(s)
  745. #define switchRhs(s)          thd3(s)
  746. #define addSym(v,o,s)          switchSyms(s) = cons(pair(v,o),switchSyms(s))
  747. #define matchMore(sw,c,co,us) nonNull(sw)?ap(FATBAR,pair(c,match(co,sw,us))):c
  748.  
  749.                        /* There are three kinds of case:   */
  750. #define CONDISCR          0        /* Constructor               */
  751. #define INTDISCR          1        /* Integer (integer const/n+k)       */
  752. #define VARDISCR          2        /* variable (or wildcard)       */
  753.  
  754. #define isConPat(discr)       (discrKind(discr)==CONDISCR)
  755. #define isVarPat(discr)       (discrKind(discr)==VARDISCR)
  756. #define isIntPat(discr)       (discrKind(discr)==INTDISCR)
  757.  
  758. static Cell local match(co,sws,us)     /* produce case statement to select */
  759. Int  co;                   /* between switches in sw, matching */
  760. List sws;                   /* pats against values at offsets   */
  761. List us; {                   /* given by us.    co is the current  */
  762.     if (nonNull(us)) {               /* offset at which new values are   */
  763.     Cell discr;               /* saved                */
  764.  
  765.     map1Proc(tidyHdPat,hd(us),sws);
  766.     switch (discrKind(discr=hdDiscr(sws))) {
  767.         case CONDISCR : return matchCon(co,sws,us,discr);
  768.         case INTDISCR : return matchInt(co,sws,us,discr);
  769.         case VARDISCR : return matchVar(co,sws,us,discr);
  770.     }
  771.     }
  772.     return joinSw(co,sws);
  773. }
  774.  
  775. static Void local tidyHdPat(u,s)       /* tidy head of pat list in a switch*/
  776. Offset u;                   /* (Principally eliminating @ pats) */
  777. Cell   s; {
  778.     Cell p = hd(switchPats(s));
  779.  
  780. thp:switch (whatIs(p)) {
  781.     case ASPAT   : addSym(fst(snd(p)),u,s);
  782.                p = snd(snd(p));
  783.                goto thp;
  784.  
  785.     case LAZYPAT : {   Cell nv    = inventVar();
  786.                switchRhs(s) = ap(LETREC,
  787.                          pair(remPat(snd(p),nv,NIL),
  788.                           switchRhs(s)));
  789.                p        = nv;
  790.                }
  791.                break;
  792.  
  793.     case FINLIST : p = mkConsList(snd(p));
  794.                break;
  795.  
  796.     case STRCELL : {   Text t = textOf(p);
  797.                Int  c;
  798.                p = NIL;
  799.                while ((c=textToStr(t++)[0])!='\0') {
  800.                    if (c=='\\' && (c=textToStr(t++)[0])!='\\')
  801.                    c = 0;
  802.                    p = ap(consChar(c),p);
  803.                }
  804.                p = revOnto(p,nameNil);
  805.                }
  806.                break;
  807.  
  808.     }
  809.     hd(switchPats(s)) = p;
  810. }
  811.  
  812. static Cell local hdDiscr(sws)           /* get discriminant of head pattern */
  813. List sws; {                   /* in first branch of a [Switch].   */
  814.     return getHead(hd(fst3(hd(sws))));
  815. }
  816.  
  817. static Int local discrKind(e)           /* find kind of discriminant       */
  818. Cell e; {
  819.     switch (whatIs(e)) {
  820.     case NAME      :
  821.     case TUPLE     :
  822.     case UNIT      :
  823.     case STRCELL   : /* shouldn't be here? */
  824.     case CHARCELL  : return CONDISCR;
  825.  
  826.     case INTCELL   :
  827.     case ADDPAT    :
  828.     case MULPAT    : return INTDISCR;
  829.  
  830.     case VARIDCELL :
  831.     case VAROPCELL :
  832.     case DICTVAR   :
  833.     case WILDCARD  : return VARDISCR;
  834.     }
  835.     internal("discrKind");
  836.     return 0;/*NOTREACHED*/
  837. }
  838.  
  839. Int discrArity(e)               /* find arity of discriminant       */
  840. Cell e; {
  841.     switch (whatIs(e)) {
  842.     case NAME      : return name(e).arity;
  843.  
  844.     case TUPLE     : return tupleOf(e);
  845.  
  846.     case UNIT      :
  847.     case STRCELL   : /* shouldn't be here? */
  848.         case FLOATCELL :
  849.     case CHARCELL  :
  850.     case INTCELL   : return 0;
  851.  
  852.     case ADDPAT    :
  853.     case MULPAT    :
  854.     case VARIDCELL :
  855.     case VAROPCELL :
  856.     case DICTVAR   :
  857.     case WILDCARD  : return 1;
  858.     }
  859.     internal("discrArity");
  860.     return 0;/*NOTREACHED*/
  861. }
  862.  
  863. /* --------------------------------------------------------------------------
  864.  * Match on variables:
  865.  * ------------------------------------------------------------------------*/
  866.  
  867. static Cell local matchVar(co,sws,us,discr)/* matching against a variable  */
  868. Int  co;                   /* does not trigger any evaluation, */
  869. List sws;                   /* but can extend the scope with a  */
  870. List us;                   /* new binding               */
  871. Cell discr; {
  872.     List varsw = NIL;
  873.     Cell s;
  874.  
  875.     do {
  876.     s = hd(sws);
  877.     if (discr!=WILDCARD)
  878.         addSym(discr,hd(us),s);
  879.     switchPats(s) = tl(switchPats(s));
  880.     varsw          = cons(s,varsw);
  881.     sws          = tl(sws);
  882.     } while (nonNull(sws) && isVarPat(discr=hdDiscr(sws)));
  883.  
  884.     s = match(co,rev(varsw),tl(us));
  885.     return matchMore(sws,s,co,us);
  886. }
  887.  
  888. /* --------------------------------------------------------------------------
  889.  * Match on constructors:
  890.  * ------------------------------------------------------------------------*/
  891.  
  892. static Cell local matchCon(co,sws,us,discr) /* matching against constructor*/
  893. Int  co;
  894. List sws;
  895. List us;
  896. Cell discr; {
  897.     List tab = NIL;               /* build table of (discr, [Switch]) */
  898.     Cell s;
  899.     List ps;
  900.  
  901.     do {
  902.     s          = hd(sws);
  903.     ps          = switchPats(s);
  904.     ps          = appendOnto(getArgs(hd(ps)),tl(ps));
  905.     switchPats(s) = ps;
  906.     tab          = addConTable(discr,s,tab);
  907.     sws          = tl(sws);
  908.      } while (nonNull(sws) && isConPat(discr=hdDiscr(sws)));
  909.  
  910.      s = ap(CASE,pair(hd(us),makeCases(co,rev(tab),tl(us))));
  911.      return matchMore(sws,s,co,us);
  912. }
  913.  
  914. /* type Table a b = [(a, [b])]
  915.  *
  916.  * addTable            :: a -> b -> Table a b -> Table a b
  917.  * addTable x y []         = [(x,[y])]
  918.  * addTable x y (z@(n,sws):zs)
  919.  *        | n == x     = (n,sws++[y]):zs
  920.  *        | otherwise  = (n,sws):addTable x y zs
  921.  */
  922.  
  923. static List local addConTable(x,y,tab) /* add element (x,y) to table       */
  924. Cell x, y;
  925. List tab; {
  926.     if (isNull(tab))
  927.     return singleton(pair(x,singleton(y)));
  928.     else if (fst(hd(tab))==x)
  929.     snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
  930.     else
  931.     tl(tab) = addConTable(x,y,tl(tab));
  932.  
  933.     return tab;
  934. }
  935.  
  936. static Cell local makeCases(co,tab,us) /* build CASE construct for constr  */
  937. Int  co;                   /* match                */
  938. List tab;
  939. List us; {
  940.      List cases;
  941.  
  942.      for (cases=NIL; nonNull(tab); tab=tl(tab)) {
  943.      Cell n   = fst(hd(tab));
  944.      Int  co1 = co+discrArity(n);
  945.      cases      = cons(pair(n,
  946.                   match(co1,
  947.                     snd(hd(tab)),
  948.                     addOffsets(co1,co+1,us))),
  949.              cases);
  950.      }
  951.      return cases;
  952. }
  953.  
  954. /* --------------------------------------------------------------------------
  955.  * Match on integers:
  956.  * ------------------------------------------------------------------------*/
  957.  
  958. static Cell local matchInt(co,sws,us,discr)/* match against integer values */
  959. Int  co;
  960. List sws;
  961. List us;
  962. Cell discr; {
  963.     List tab    = NIL;                /* table of (discr, [Switch]) pairs */
  964.     Cell s    = hd(sws);
  965.     Cell cnkPat = NIL;            /* current MULPAT or ADDPAT       */
  966.     List ps;
  967.  
  968.     do {
  969.     if (whatIs(discr)==INTCELL) {
  970.         if (nonNull(cnkPat))
  971.         break;
  972.     }
  973.     else if (isNull(cnkPat))
  974.         cnkPat = discr;
  975.     else if (fst(cnkPat)!=fst(discr) || intValOf(cnkPat)!=intValOf(discr))
  976.         break;
  977.     else
  978.         discr  = cnkPat;
  979.  
  980.     s          = hd(sws);
  981.     ps          = switchPats(s);
  982.     ps          = appendOnto(getArgs(hd(ps)),tl(ps));
  983.     switchPats(s) = ps;
  984.     tab          = addConTable(discr,s,tab);
  985.     sws          = tl(sws);
  986.      } while (nonNull(sws) && isIntPat(discr=hdDiscr(sws)));
  987.  
  988.      s = ap(CASE,pair(hd(us),makeCases(co,rev(tab),tl(us))));
  989.      return matchMore(sws,s,co,us);
  990. }
  991.  
  992. /* --------------------------------------------------------------------------
  993.  * Miscellaneous:
  994.  * ------------------------------------------------------------------------*/
  995.  
  996. static List local addOffsets(m,n,us)   /* addOffsets m n us           */
  997. Int  m, n;                   /*  = map mkOffset [m,m-1..n] ++ us */
  998. List us; {
  999.     for (; m>=n; n++)
  1000.     us = cons(mkOffset(n),us);
  1001.     return us;
  1002. }
  1003.  
  1004. static Cell local mkSwitch(sc,alt)     /* convert Alt into Switch:       */
  1005. List sc;                   /* mkSwitch sc (ps,r) = (ps,sc,r)   */
  1006. Pair alt; {
  1007.     return triple(fst(alt),sc,snd(alt));
  1008. }
  1009.  
  1010. static Cell local joinSw(co,sws)       /* Combine list of Switches into rhs*/
  1011. Int  co;                   /* using FATBARs as necessary       */
  1012. List sws; {                   /* :: [ ([], Scope, Rhs) ]       */
  1013.     Cell s = hd(sws);
  1014.  
  1015.     if (nonNull(tl(sws)) && canFail(thd3(s)))
  1016.     return ap(FATBAR,
  1017.           pair(pmcTerm(co,snd3(s),thd3(s)),
  1018.                joinSw(co,tl(sws))));
  1019.     return pmcTerm(co,snd3(s),thd3(s));
  1020. }
  1021.  
  1022. static Bool local canFail(rhs)           /* Determine if expression (as rhs) */
  1023. Cell rhs; {                   /* might ever be able to fail       */
  1024.     switch (whatIs(rhs)) {
  1025.     case LETREC  : return canFail(snd(snd(rhs)));
  1026.     case GUARDED : return TRUE;    /* could get more sophisticated ..? */
  1027.     default      : return FALSE;
  1028.     }
  1029. }
  1030.  
  1031. /* --------------------------------------------------------------------------
  1032.  * Lambda Lifter:    replace local function definitions with new global
  1033.  *             functions.  Based on Johnsson's algorithm.
  1034.  * ------------------------------------------------------------------------*/
  1035.  
  1036. static Cell local lift(co,tr,e)        /* lambda lift term           */
  1037. Int  co;
  1038. List tr;
  1039. Cell e; {
  1040.     switch (whatIs(e)) {
  1041.     case GUARDED   : map2Proc(liftPair,co,tr,snd(e));
  1042.              break;
  1043.  
  1044.     case FATBAR    : liftPair(co,tr,snd(e));
  1045.              break;
  1046.  
  1047.     case CASE      : map2Proc(liftAlt,co,tr,snd(snd(e)));
  1048.              break;
  1049.  
  1050.     case COND      : liftTriple(co,tr,snd(e));
  1051.              break;
  1052.  
  1053.     case AP        : liftPair(co,tr,e);
  1054.              break;
  1055.  
  1056.     case VAROPCELL :
  1057.     case VARIDCELL :
  1058.     case DICTVAR   : return liftVar(tr,e);
  1059.  
  1060.     case LETREC    : return liftLetrec(co,tr,e);
  1061.  
  1062.     case UNIT      :
  1063.     case TUPLE     :
  1064.     case NAME      :
  1065.     case SELECT    :
  1066.     case DICTCELL  :
  1067.     case INTCELL   :
  1068.     case FLOATCELL :
  1069.     case STRCELL   :
  1070.     case OFFSET    :
  1071.     case CHARCELL  : break;
  1072.  
  1073.     default        : internal("lift");
  1074.              break;
  1075.     }
  1076.     return e;
  1077. }
  1078.  
  1079. static Void local liftPair(co,tr,pr)   /* lift pair of terms           */
  1080. Int  co;
  1081. List tr;
  1082. Pair pr; {
  1083.     fst(pr) = lift(co,tr,fst(pr));
  1084.     snd(pr) = lift(co,tr,snd(pr));
  1085. }
  1086.  
  1087. static Void local liftTriple(co,tr,e)  /* lift triple of terms           */
  1088. Int    co;
  1089. List   tr;
  1090. Triple e; {
  1091.     fst3(e) = lift(co,tr,fst3(e));
  1092.     snd3(e) = lift(co,tr,snd3(e));
  1093.     thd3(e) = lift(co,tr,thd3(e));
  1094. }
  1095.  
  1096. static Void local liftAlt(co,tr,pr)    /* lift (discr,case) pair       */
  1097. Int  co;
  1098. List tr;
  1099. Cell pr; {                   /* pr :: (discr,case)           */
  1100.     snd(pr) = lift(co+discrArity(fst(pr)), tr, snd(pr));
  1101. }
  1102.  
  1103. static Cell local liftVar(tr,e)        /* lift variable            */
  1104. List tr;
  1105. Cell e; {
  1106.     Text t = textOf(e);
  1107.  
  1108.     while (nonNull(tr) && textOf(fst(hd(tr)))!=t)
  1109.     tr = tl(tr);
  1110.     if (isNull(tr))
  1111.     internal("liftVar");
  1112.     return snd(hd(tr));
  1113. }
  1114.  
  1115. static Cell local liftLetrec(co,tr,e)  /* lift letrec term           */
  1116. Int  co;
  1117. List tr;
  1118. Cell e; {
  1119.     List vs = fst(fst(snd(e)));
  1120.     List fs = snd(fst(snd(e)));
  1121.     List fds;
  1122.  
  1123.     co += length(vs);
  1124.     solve(fs);
  1125.  
  1126.     for (fds=fs; nonNull(fds); fds=tl(fds)) {
  1127.     Triple fundef = hd(fds);
  1128.     List   fvs    = fst3(thd3(fundef));
  1129.     Cell   n      = newName(textOf(fst3(fundef)));
  1130.     Cell   e0;
  1131.  
  1132.     for (e0=n; nonNull(fvs); fvs=tl(fvs))
  1133.         e0 = ap(e0,hd(fvs));
  1134.  
  1135.     tr         = cons(pair(fst3(fundef),e0),tr);
  1136.     fst3(fundef) = n;
  1137.     }
  1138.  
  1139.     map2Proc(liftFundef,co,tr,fs);
  1140.     if (isNull(vs))
  1141.     return lift(co,tr,snd(snd(e)));
  1142.     map2Over(lift,co,tr,vs);
  1143.     fst(snd(e)) = vs;
  1144.     snd(snd(e)) = lift(co,tr,snd(snd(e)));
  1145.     return e;
  1146. }
  1147.  
  1148. static Void local liftFundef(co,tr,fd) /* lift function definition       */
  1149. Int    co;
  1150. List   tr;
  1151. Triple fd; {
  1152.     Int arity = intOf(snd3(fd));
  1153.     newGlobalFunction(fst3(fd),              /* name       */
  1154.               arity,                 /* arity       */
  1155.               fst3(thd3(fd)),             /* free variables */
  1156.               co+arity,              /* current offset */
  1157.               lift(co+arity,tr,thd3(thd3(fd)))); /* lifted case    */
  1158. }
  1159.  
  1160. /* Each element in a list of fundefs has the form: (v,a,(fvs,ffs,rhs))
  1161.  * where fvs is a list of free variables which must be added as extra
  1162.  *         parameters to the lifted version of function v,
  1163.  *     ffs is a list of fundefs defined either in the group of definitions
  1164.  *         including v, or in some outer LETREC binding.
  1165.  *
  1166.  * In order to determine the correct value for fvs, we must include:
  1167.  * - all variables explicitly appearing in the body rhs (this much is
  1168.  *   achieved in pmcVar).
  1169.  * - all variables required for lifting those functions appearing in ffs.
  1170.  *   - If f is a fundef in an enclosing group of definitions then the
  1171.  *     correct list of variables to include with each occurrence of f will
  1172.  *     have already been calculated and stored in the fundef f.  We simply
  1173.  *     take the union of this list with fvs.
  1174.  *   - If f is a fundef in the same group of bindings as v, then we iterate
  1175.  *     to find the required solution.
  1176.  */
  1177.  
  1178. #ifdef DEBUG_CODE
  1179. static Void dumpFundefs(fs)
  1180. List fs; {
  1181.     printf("Dumping Fundefs:\n");
  1182.     for (; nonNull(fs); fs=tl(fs)) {
  1183.         Cell t   = hd(fs);
  1184.     List fvs = fst3(thd3(t));
  1185.     List ffs = snd3(thd3(t));
  1186.     printf("Var \"%s\", arity %d:\n",textToStr(textOf(fst3(t))),
  1187.                                          intOf(snd3(t)));
  1188.     printf("Free variables: ");
  1189.         printExp(stdout,fvs);
  1190.     putchar('\n');
  1191.     printf("Local functions: ");
  1192.         for (; nonNull(ffs); ffs=tl(ffs)) {
  1193.         printExp(stdout,fst3(hd(ffs)));
  1194.         printf("  ");
  1195.     }
  1196.     putchar('\n');
  1197.     }
  1198.     printf("----------------\n");
  1199. }
  1200. #endif
  1201.  
  1202. static Void local solve(fs)           /* Solve eqns for lambda-lifting    */
  1203. List fs; {                   /* of local function definitions    */
  1204.     Bool hasChanged;
  1205.     List fs0, fs1;
  1206.  
  1207.     /* initial pass distinguishes between those functions defined in fs and
  1208.      * those defined in enclosing LETREC clauses ...
  1209.      */
  1210.  
  1211.     for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
  1212.     List fvs = fst3(thd3(hd(fs0)));
  1213.     List ffs = NIL;
  1214.  
  1215.     for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1)) {
  1216.         if (cellIsMember(hd(fs1),fs))     /* function in same LETREC*/
  1217.         ffs = cons(hd(fs1),ffs);
  1218.         else {                 /* enclosing letrec       */
  1219.         List fvs1 = fst3(thd3(hd(fs1)));
  1220.         for (; nonNull(fvs1); fvs1=tl(fvs1))
  1221.             if (!cellIsMember(hd(fvs1),fvs))
  1222.             fvs = cons(hd(fvs1),fvs);
  1223.         }
  1224.     }
  1225.     fst3(thd3(hd(fs0))) = fvs;
  1226.     snd3(thd3(hd(fs0))) = ffs;
  1227.     }
  1228.  
  1229.     /* now that the ffs component of each fundef in fs has been restricted
  1230.      * to a list of fundefs in fs, we iterate to add any extra free variables
  1231.      * that are needed (in effect, calculating the reflexive transitive
  1232.      * closure of the local call graph of fs).
  1233.      */
  1234.  
  1235.     do {
  1236.     hasChanged = FALSE;
  1237.     for (fs0=fs; nonNull(fs0); fs0=tl(fs0)) {
  1238.         List fvs0 = fst3(thd3(hd(fs0)));
  1239.         for (fs1=snd3(thd3(hd(fs0))); nonNull(fs1); fs1=tl(fs1))
  1240.          if (hd(fs1)!=hd(fs0)) {
  1241.              List fvs1 = fst3(thd3(hd(fs1)));
  1242.              for (; nonNull(fvs1); fvs1=tl(fvs1))
  1243.              if (!cellIsMember(hd(fvs1),fvs0)) {
  1244.                  hasChanged = TRUE;
  1245.                  fvs0    = cons(hd(fvs1),fvs0);
  1246.              }
  1247.         }
  1248.         if (hasChanged) fst3(thd3(hd(fs0))) = fvs0;
  1249.     }
  1250.     } while (hasChanged);
  1251. }
  1252.  
  1253. /* --------------------------------------------------------------------------
  1254.  * Pre-compiler: Uses output from lambda lifter to produce terms suitable
  1255.  *         for input to code generator.
  1256.  * ------------------------------------------------------------------------*/
  1257.  
  1258. static List extraVars;       /* List of additional vars to add to function   */
  1259. static Int  numExtraVars;  /* Length of extraVars               */
  1260. static Int  localOffset;   /* offset value used in original definition       */
  1261. static Int  localArity;    /* arity of function being compiled w/o extras  */
  1262.  
  1263. /* --------------------------------------------------------------------------
  1264.  * Arrangement of arguments on stack prior to call of
  1265.  *           n x_1 ... x_e y_1 ... y_a
  1266.  * where
  1267.  *    e = numExtraVars,      x_1,...,x_e are the extra params to n
  1268.  *    a = localArity of n,   y_1,...,y_a are the original params
  1269.  *
  1270.  *    offset 1       :  y_a  }                   STACKPART1
  1271.  *    ..           }
  1272.  *    offset a       :  y_1  }
  1273.  *
  1274.  *    offset 1+a   :  x_e  }                   STACKPART2
  1275.  *    ..           }
  1276.  *    offset e+a   :  x_1  }
  1277.  *
  1278.  *    offset e+a+1 :  used for temporary results ...   STACKPART3
  1279.  *    ..
  1280.  *    ..
  1281.  *
  1282.  * In the original defn for n, the offsets in STACKPART1 and STACKPART3
  1283.  * are contiguous.  To add the extra parameters we need to insert the
  1284.  * offsets in STACKPART2, adjusting offset values as necessary.
  1285.  * ------------------------------------------------------------------------*/
  1286.  
  1287. static Cell local preComp(e)           /* Adjust output from compiler to   */
  1288. Cell e; {                   /* include extra parameters       */
  1289.     switch (whatIs(e)) {
  1290.     case GUARDED   : mapOver(preCompPair,snd(e));
  1291.                  break;
  1292.  
  1293.     case LETREC    : mapOver(preComp,fst(snd(e)));
  1294.                  snd(snd(e)) = preComp(snd(snd(e)));
  1295.                  break;
  1296.  
  1297.     case COND      : return ap(COND,preCompTriple(snd(e)));
  1298.  
  1299.     case FATBAR    : return ap(FATBAR,preCompPair(snd(e)));
  1300.  
  1301.     case AP        : return preCompPair(e);
  1302.  
  1303.     case CASE      : fst(snd(e)) = preComp(fst(snd(e)));
  1304.                  mapProc(preCompCase,snd(snd(e)));
  1305.                  break;
  1306.  
  1307.     case OFFSET    : return preCompOffset(offsetOf(e));
  1308.  
  1309.     case UNIT      :
  1310.     case TUPLE     :
  1311.     case NAME      :
  1312.     case SELECT    :
  1313.     case DICTCELL  :
  1314.     case INTCELL   :
  1315.     case FLOATCELL :
  1316.     case STRCELL   :
  1317.     case CHARCELL  : break;
  1318.  
  1319.     default        : internal("preComp");
  1320.     }
  1321.     return e;
  1322. }
  1323.  
  1324. static Cell local preCompPair(e)       /* Apply preComp to pair of Exprs   */
  1325. Pair e; {
  1326.     return pair(preComp(fst(e)),
  1327.         preComp(snd(e)));
  1328. }
  1329.  
  1330. static Cell local preCompTriple(e)     /* Apply preComp to triple of Exprs */
  1331. Triple e; {
  1332.     return triple(preComp(fst3(e)),
  1333.           preComp(snd3(e)),
  1334.           preComp(thd3(e)));
  1335. }
  1336.  
  1337. static Void local preCompCase(e)       /* Apply preComp to (Discr,Expr)    */
  1338. Pair e; {
  1339.     snd(e) = preComp(snd(e));
  1340. }
  1341.  
  1342. static Cell local preCompOffset(n)     /* Determine correct offset value   */
  1343. Int n; {                   /* for local variable/function arg. */
  1344.     if (n>localOffset-localArity)
  1345.     if (n>localOffset)                     /* STACKPART3 */
  1346.         return mkOffset(n-localOffset+localArity+numExtraVars);
  1347.     else                             /* STACKPART1 */
  1348.         return mkOffset(n-localOffset+localArity);
  1349.     else {                             /* STACKPART2 */
  1350.     List fvs = extraVars;
  1351.     Int  i     = localArity+numExtraVars;
  1352.  
  1353.     for (; nonNull(fvs) && offsetOf(hd(fvs))!=n; --i)
  1354.         fvs=tl(fvs);
  1355.     return mkOffset(i);
  1356.     }
  1357. }
  1358.  
  1359. /* --------------------------------------------------------------------------
  1360.  * Main entry points to compiler:
  1361.  * ------------------------------------------------------------------------*/
  1362.  
  1363. Void compileExp() {               /* compile input expression       */
  1364.     compiler(RESET);
  1365.  
  1366.     inputExpr     = lift(0,NIL,pmcTerm(0,NIL,translate(inputExpr)));
  1367.     extraVars     = NIL;
  1368.     numExtraVars = 0;
  1369.     localOffset  = 0;
  1370.     localArity     = 0;
  1371.     inputCode     = codeGen(NIL,0,preComp(inputExpr));
  1372.     inputExpr     = NIL;
  1373. }
  1374.  
  1375. Void compileDefns() {               /* compile script definitions       */
  1376.     Target t = length(valDefns) + length(overDefns);
  1377.     Target i = 0;
  1378.  
  1379.     setGoal("Compiling",t);
  1380.     for (; nonNull(valDefns); valDefns=tl(valDefns)) {
  1381.     mapProc(compileGlobalFunction,transBinds(hd(valDefns)));
  1382.     soFar(i++);
  1383.     }
  1384.     for (; nonNull(overDefns); overDefns=tl(overDefns)) {
  1385.         compileMemberFunction(hd(overDefns));
  1386.     soFar(i++);
  1387.     }
  1388.     done();
  1389. }
  1390.  
  1391. static Void local compileGlobalFunction(bind)
  1392. Pair bind; {
  1393.     Name n     = findName(textOf(fst(bind)));
  1394.     List defs  = snd(bind);
  1395.     Int  arity = length(fst(hd(defs)));
  1396.  
  1397.     if (isNull(n))
  1398.     internal("compileGlobalFunction");
  1399.     compiler(RESET);
  1400.     map1Over(mkSwitch,NIL,defs);
  1401.     newGlobalFunction(n,
  1402.               arity,
  1403.               NIL,
  1404.               arity,
  1405.               lift(arity,
  1406.                NIL,
  1407.                match(arity,
  1408.                  defs,
  1409.                  addOffsets(arity,1,NIL))));
  1410. }
  1411.  
  1412. static Void local compileMemberFunction(n)
  1413. Name n; {
  1414.     List defs  = name(n).defn;
  1415.     Int  arity = length(fst(hd(defs)));
  1416.  
  1417.     compiler(RESET);
  1418.     mapProc(transAlt,defs);
  1419.     map1Over(mkSwitch,NIL,defs);
  1420.     newGlobalFunction(n,
  1421.               arity,
  1422.               NIL,
  1423.               arity,
  1424.               lift(arity,
  1425.                NIL,
  1426.                match(arity,
  1427.                  defs,
  1428.                  addOffsets(arity,1,NIL))));
  1429. }
  1430.  
  1431. static Void local newGlobalFunction(n,arity,fvs,co,e)
  1432. Name n;
  1433. Int  arity;
  1434. List fvs;
  1435. Int  co;
  1436. Cell e; {
  1437.     extraVars      = fvs;
  1438.     numExtraVars  = length(extraVars);
  1439.     localOffset   = co;
  1440.     localArity      = arity;
  1441.     name(n).arity = arity+numExtraVars;
  1442.     name(n).code  = codeGen(n,name(n).arity,preComp(e));
  1443. }
  1444.  
  1445. /* --------------------------------------------------------------------------
  1446.  * Compiler control:
  1447.  * ------------------------------------------------------------------------*/
  1448.  
  1449. Void compiler(what)
  1450. Int what; {
  1451.     switch (what) {
  1452.     case INSTALL :
  1453.     case RESET   : freeVars      = NIL;
  1454.                freeFuns      = NIL;
  1455.                freeBegin     = mkOffset(0);
  1456.                extraVars     = NIL;
  1457.                numExtraVars  = 0;
  1458.                localOffset   = 0;
  1459.                localArity    = 0;
  1460.                break;
  1461.  
  1462.     case MARK    : mark(freeVars);
  1463.                mark(freeFuns);
  1464.                mark(extraVars);
  1465.                break;
  1466.     }
  1467. }
  1468.  
  1469. /*-------------------------------------------------------------------------*/
  1470.