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