home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / compiler.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  42KB  |  1,477 lines

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