home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / static.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  85KB  |  2,677 lines
  1. /* --------------------------------------------------------------------------
  2.  * static.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.  * Static Analysis for Hugs
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13.  
  14. /* --------------------------------------------------------------------------
  15.  * local function prototypes:
  16.  * ------------------------------------------------------------------------*/
  17.  
  18. static Void  local checkTyconDefn    Args((Tycon));
  19. static Type  local depTypeExp        Args((Int,List,Type));
  20. static Type  local depTypeVar        Args((Int,List,Text));
  21. static Void  local depConstr        Args((Int,List,Cell));
  22. static Void  local addConstrs        Args((Tycon));
  23. static Name  local newConstr        Args((Tycon,Int,List,Type,Cell));
  24. static List  local selectCtxt        Args((List,List));
  25. static Void  local checkSynonyms    Args((List));
  26. static List  local visitSyn        Args((List,Tycon,List));
  27.  
  28. static Type  local fullExpand        Args((Type));
  29. static Type  local instantiateSyn    Args((Type,Type));
  30.  
  31. static List  local typeVarsIn        Args((Cell,List));
  32. static List  local maybeAppendVar    Args((Cell,List));
  33.  
  34. static List  local offsetTyvarsIn    Args((Type,List));
  35.  
  36. static Type  local checkSigType        Args((Int,String,Cell,Type));
  37.  
  38. static Void  local checkClassDefn    Args((Class));
  39. static Void  local depPredExp        Args((Int,List,Cell));
  40. static Void  local checkMems        Args((Cell,List,Cell));
  41. static Void  local addMembers        Args((Class));
  42. static Name  local newMember        Args((Int,Int,Cell,Type));
  43. static Int   local visitClass        Args((Class));
  44.  
  45. static Void  local checkInstDefn        Args((Inst));
  46. static Void  local checkInstSC        Args((Inst));
  47. static Cell  local scEvidFrom        Args((Cell,List));
  48.  
  49. static List  local classBindings        Args((String,Class,List));
  50. static Int   local memberNumber         Args((Class,Text));
  51. static List  local numInsert            Args((Int,Cell,List));
  52.  
  53. static Void  local checkDerive        Args((Tycon,List,List,Cell));
  54. static Void  local addDerInst        Args((Int,Class,List,List,Type,Int));
  55. static Void  local deriveContexts    Args((List));
  56. static List  local superSimp        Args((List));
  57. static Void  local maybeAddPred        Args((Cell,List));
  58. static Cell  local instPred        Args((Cell,Type));
  59. static Void  local calcInstPreds    Args((Inst));
  60.  
  61. static Void  local addDerivImp        Args((Inst));
  62. static List  local getDiVars        Args((Int));
  63. static Cell  local mkBind        Args((String,List));
  64. static Cell  local mkVarAlts        Args((Int,Cell));
  65.  
  66. static List  local deriveEq        Args((Tycon));
  67. static Pair  local mkAltEq        Args((Int,List));
  68. static List  local deriveOrd        Args((Tycon));
  69. static Pair  local mkAltOrd        Args((Int,List));
  70. static List  local makeDPats2        Args((Cell,Int,List));
  71.  
  72. static List  local deriveIx        Args((Tycon));
  73. static List  local deriveEnum        Args((Tycon));
  74. static Bool  local isEnumType        Args((Tycon));
  75. static List  local mkIxBinds        Args((Int,Cell,Int));
  76. static Cell  local prodRange        Args((Int,List,Cell,Cell,Cell));
  77. static Cell  local prodIndex        Args((Int,List,Cell,Cell,Cell));
  78. static Cell  local prodInRange        Args((Int,List,Cell,Cell,Cell));
  79.  
  80. static List  local deriveText        Args((Tycon));
  81. static Cell  local mkAltText        Args((Int,Cell,Int));
  82. static Cell  local showsPrecRhs        Args((Cell,Cell));
  83.  
  84. static Void  local checkPrimDefn    Args((Triple));
  85. static Void  local addNewPrim        Args((Int,Text,String,Cell));
  86.  
  87. static Void  local checkDefaultDefns    Args((Void));
  88.  
  89. static Cell  local checkPat        Args((Int,Cell));
  90. static Cell  local checkMaybeCnkPat    Args((Int,Cell));
  91. static Cell  local checkApPat        Args((Int,Int,Cell));
  92. static Void  local addPatVar        Args((Int,Cell));
  93. static Name  local conDefined        Args((Int,Text));
  94. static Void  local checkIsCfun        Args((Int,Cell));
  95. static Void  local checkCfunArgs    Args((Int,Cell,Int));
  96.  
  97. static Cell  local bindPat        Args((Int,Cell));
  98. static Void  local bindPats        Args((Int,List));
  99.  
  100. static List  local extractSigdecls    Args((List));
  101. static List  local extractBindings    Args((List));
  102. static List  local eqnsToBindings    Args((List));
  103. static Void  local notDefined        Args((Int,List,Cell));
  104. static Cell  local findBinding        Args((Text,List));
  105. static Void  local addSigDecl        Args((List,Cell));
  106. static Void  local setType        Args((Int,Cell,Cell,List));
  107.  
  108. static List  local dependencyAnal    Args((List));
  109. static List  local topDependAnal    Args((List));
  110. static Void  local addDepField        Args((Cell));
  111. static Void  local remDepField        Args((List));
  112. static Void  local remDepField1        Args((Cell));
  113. static Void  local clearScope        Args((Void));
  114. static Void  local withinScope        Args((List));
  115. static Void  local leaveScope        Args((Void));
  116.  
  117. static Void  local depBinding        Args((Cell));
  118. static Void  local depDefaults          Args((Class));
  119. static Void  local depInsts             Args((Inst));
  120. static Void  local depClassBindings     Args((List));
  121. static Void  local depAlt        Args((Cell));
  122. static Void  local depRhs        Args((Cell));
  123. static Void  local depGuard        Args((Cell));
  124. static Cell  local depExpr        Args((Int,Cell));
  125. static Void  local depPair        Args((Int,Cell));
  126. static Void  local depTriple        Args((Int,Cell));
  127. static Void  local depComp        Args((Int,Cell,List));
  128. static Void  local depCaseAlt        Args((Int,Cell));
  129. static Cell  local depVar        Args((Int,Cell));
  130.  
  131. static Int   local sccMin        Args((Int,Int));
  132. static List  local tcscc        Args((List,List));
  133. static List  local bscc            Args((List));
  134.  
  135. static Void  local addRSsigdecls    Args((Pair));
  136. static Void  local opDefined        Args((List,Cell));
  137. static Void  local allNoPrevDef        Args((Cell));
  138. static Void  local noPrevDef        Args((Int,Cell));
  139. static Void  local checkTypeIn        Args((Pair));
  140.  
  141. /* --------------------------------------------------------------------------
  142.  * Static analysis of type declarations:
  143.  *
  144.  * Type declarations come in two forms:
  145.  * - data declarations - define new constructed data types
  146.  * - type declarations - define new type synonyms
  147.  *
  148.  * A certain amount of work is carried out as the declarations are
  149.  * read during parsing.  In particular, for each type constructor
  150.  * definition encountered:
  151.  * - check that there is no previous definition of constructor
  152.  * - ensure type constructor not previously used as a class name
  153.  * - make a new entry in the type constructor table
  154.  * - record line number of declaration
  155.  * - Build separate lists of newly defined constructors for later use.
  156.  * ------------------------------------------------------------------------*/
  157.  
  158. Void tyconDefn(line,lhs,rhs,what)    /* process new type definition       */
  159. Int  line;                /* definition line number       */
  160. Cell lhs;                /* left hand side of definition       */
  161. Cell rhs;                /* right hand side of definition   */
  162. Cell what; {                /* SYNONYM/DATATYPE/etc...       */
  163.     Cell  t   = getHead(lhs);
  164.     Tycon new = findTycon(textOf(t));
  165.  
  166.     if (isNull(new)) {
  167.     if (nonNull(findClass(textOf(t)))) {
  168.         ERROR(line) "\"%s\" used as both class and type constructor",
  169.             textToStr(textOf(t))
  170.         EEND;
  171.     }
  172.     new = newTycon(textOf(t));
  173.     }
  174.     else if (tycon(new).defn!=PREDEFINED) {
  175.     ERROR(line) "Repeated definition of type constructor \"%s\"",
  176.             textToStr(textOf(t))
  177.     EEND;
  178.     }
  179.  
  180.     tycon(new).line  = line;
  181.     tycon(new).arity = argCount;
  182.     tycon(new).defn  = pair(lhs,rhs);
  183.     tycon(new).what  = what;
  184.     tyconDefns       = cons(new,tyconDefns);
  185.     if (what!=DATATYPE && what!=SYNONYM && fst(what)!=DERIVE) {
  186.     typeInDefns     = cons(pair(new,what),typeInDefns);
  187.     tycon(new).what = RESTRICTSYN;
  188.     }
  189. }
  190.  
  191. Void setTypeIns(bs)            /* set local synonyms for given       */
  192. List bs; {                /* binding group           */
  193.     List cvs = typeInDefns;
  194.     for (; nonNull(cvs); cvs=tl(cvs)) {
  195.     Tycon c  = fst(hd(cvs));
  196.     List  vs = snd(hd(cvs));
  197.     for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
  198.         if (nonNull(findBinding(textOf(hd(vs)),bs))) {
  199.         tycon(c).what = SYNONYM;
  200.         break;
  201.         }
  202.     }
  203.     }
  204. }
  205.  
  206. Void clearTypeIns() {            /* clear list of local synonyms       */
  207.     for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
  208.     tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
  209. }
  210.  
  211. /* --------------------------------------------------------------------------
  212.  * Further analysis of Type declarations:
  213.  *
  214.  * In order to allow the definition of mutually recursive families of
  215.  * data types, the static analysis of the right hand sides of type
  216.  * declarations cannot be performed until all of the type declarations
  217.  * have been read.
  218.  *
  219.  * Once parsing is complete, we carry out the following:
  220.  *
  221.  * - check format of lhs, extracting list of bound vars and ensuring that
  222.  *   there are no repeated variables.
  223.  * - run dependency analysis on rhs to check that only bound type vars
  224.  *   appear in type and that all constructors are defined.
  225.  *   Replace type variables by offsets, constructors by Tycons.
  226.  * - use list of dependents to sort into strongly connected components.
  227.  * - ensure that there is not more than one synonym in each group.
  228.  * - kind-check each group of type definitions.
  229.  *
  230.  * - check that there are no previous definitions for constructor
  231.  *   functions in data type definitions.
  232.  * - install synonym expansions and constructor definitions.
  233.  * ------------------------------------------------------------------------*/
  234.  
  235. static List tcDeps = NIL;        /* list of dependent tycons/classes*/
  236.  
  237. static Void local checkTyconDefn(d)    /* validate type constructor defn  */
  238. Tycon d; {
  239.     Cell lhs    = fst(tycon(d).defn);
  240.     Cell rhs    = snd(tycon(d).defn);
  241.     Int  line   = tycon(d).line;
  242.     List tyvars = getArgs(lhs);
  243.     List temp;
  244.                     /* check for repeated tyvars on lhs*/
  245.     for (temp=tyvars; nonNull(temp); temp=tl(temp))
  246.     if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
  247.         ERROR(line) "Repeated type variable \"%s\" on left hand side",
  248.             textToStr(textOf(hd(temp)))
  249.         EEND;
  250.     }
  251.  
  252.     tcDeps = NIL;            /* find dependents           */
  253.     switch (whatIs(tycon(d).what)) {
  254.     case RESTRICTSYN :
  255.     case SYNONYM     : rhs = depTypeExp(line,tyvars,rhs);
  256.                if (cellIsMember(d,tcDeps)) {
  257.                    ERROR(line) "Recursive type synonym \"%s\"",
  258.                        textToStr(tycon(d).text)
  259.                    EEND;
  260.                }
  261.                break;
  262.  
  263.     case DERIVE     :
  264.     case DATATYPE     : if (whatIs(rhs)==QUAL) {
  265.                    map2Proc(depPredExp,line,tyvars,fst(snd(rhs)));
  266.                    map2Proc(depConstr,line,tyvars,snd(snd(rhs)));
  267.                }
  268.                else
  269.                    map2Proc(depConstr,line,tyvars,rhs);
  270.                break;
  271.  
  272.     default         : internal("checkTyconDefn");
  273.     }
  274.  
  275.     tycon(d).defn = rhs;
  276.     tycon(d).kind = tcDeps;
  277.     tcDeps      = NIL;
  278. }
  279.  
  280. static Type local depTypeExp(line,tyvars,type)
  281. Int  line;
  282. List tyvars;
  283. Type type; {
  284.     switch (whatIs(type)) {
  285.     case AP        : fst(type) = depTypeExp(line,tyvars,fst(type));
  286.               snd(type) = depTypeExp(line,tyvars,snd(type));
  287.               break;
  288.  
  289.     case VARIDCELL    : return depTypeVar(line,tyvars,textOf(type));
  290.  
  291.     case CONIDCELL    : {   Tycon tc = findTycon(textOf(type));
  292.                   if (isNull(tc)) {
  293.                   ERROR(line)
  294.                       "Undefined type constructor \"%s\"",
  295.                       textToStr(textOf(type))
  296.                   EEND;
  297.                   }
  298.                   if (cellIsMember(tc,tyconDefns) &&
  299.                   !cellIsMember(tc,tcDeps))
  300.                   tcDeps = cons(tc,tcDeps);
  301.                   return tc;
  302.               }
  303.  
  304.     case TUPLE    :
  305.     case UNIT    :
  306.     case LIST    :
  307.     case ARROW    : break;
  308.  
  309.     default        : internal("depTypeExp");
  310.     }
  311.     return type;
  312. }
  313.  
  314. static Type local depTypeVar(line,tyvars,tv)
  315. Int  line;
  316. List tyvars;
  317. Text tv; {
  318.     Int offset = 0;
  319.  
  320.     for (; nonNull(tyvars) && tv!=textOf(hd(tyvars)); offset++)
  321.     tyvars = tl(tyvars);
  322.     if (isNull(tyvars)) {
  323.     ERROR(line) "Undefined type variable \"%s\"", textToStr(tv)
  324.     EEND;
  325.     }
  326.     return mkOffset(offset);
  327. }
  328.  
  329. static Void local depConstr(line,tyvars,constr)
  330. Int  line;
  331. List tyvars;
  332. Cell constr; {
  333.     for (; isAp(constr); constr=fun(constr))
  334.     arg(constr) = depTypeExp(line,tyvars,arg(constr));
  335. }
  336.  
  337. static Void local addConstrs(t)        /* Add definitions of constructor  */
  338. Tycon t; {
  339.     Bool hasDerivs = whatIs(tycon(t).what)==DERIVE;
  340.     if (tycon(t).what==DATATYPE || hasDerivs) {
  341.     Type lhs      = t;
  342.     List cs          = tycon(t).defn;
  343.     List ctxt     = NIL;
  344.     Int  constrNo = 0;
  345.     Int  i;
  346.  
  347.     if (whatIs(cs)==QUAL) {        /* allow for possible context       */
  348.         ctxt      = fst(snd(cs));
  349.         tycon(t).defn = cs = snd(snd(cs));
  350.     }
  351.  
  352.     if (hasDerivs) {        /* allow for deriving clause       */
  353.         List ctypes = NIL;        /* calculate component types       */
  354.         List cs1    = cs;
  355.         for (; nonNull(cs1); cs1=tl(cs1)) {
  356.         Cell c = hd(cs1);
  357.         for (; isAp(c); c=fun(c))
  358.             ctypes = cons(fullExpand(arg(c)),ctypes);
  359.         }
  360.         map3Proc(checkDerive,t,ctxt,ctypes,tl(tycon(t).what));
  361.         tycon(t).what = DATATYPE;
  362.     }
  363.  
  364.     for (i=0; i<tycon(t).arity; ++i)
  365.         lhs = ap(lhs,mkOffset(i));
  366.  
  367.     for (; nonNull(cs); cs=tl(cs))
  368.         hd(cs) = newConstr(t,constrNo++,ctxt,lhs,hd(cs));
  369.     }
  370. }
  371.  
  372. static Name local newConstr(t,num,ctxt,lhs,c)
  373. Tycon t;                /* Make definition for constructor */
  374. Int   num;
  375. List  ctxt;
  376. Type  lhs;
  377. Cell  c; {
  378.     Type type = lhs;
  379.     Int  arity;
  380.     Name n;
  381.  
  382.     if (nonNull(ctxt))
  383.     ctxt = selectCtxt(ctxt,offsetTyvarsIn(c,NIL));
  384.     for (arity=0; isAp(c); arity++) {    /* calculate type of constructor   */
  385.     Type t = fun(c);
  386.     fun(c) = ARROW;
  387.     type   = ap(c,type);
  388.     c      = t;
  389.     }
  390.     if (nonNull(ctxt))            /* add context part           */
  391.     type = ap(QUAL,pair(ctxt,type));
  392.     if (tycon(t).arity>0)        /* add `universal quantifiers'       */
  393.     type = mkPolyType(tycon(t).kind,type);
  394.  
  395.     n = findName(textOf(c));        /* add definition to name table       */
  396.  
  397.     if (isNull(n))
  398.     n = newName(textOf(c));
  399.     else if (name(n).defn!=PREDEFINED) {
  400.     ERROR(tycon(t).line)
  401.         "Repeated definition for constructor function \"%s\"",
  402.         textToStr(name(n).text)
  403.     EEND;
  404.     }
  405.  
  406.     name(n).line   = tycon(t).line;
  407.     name(n).arity  = arity;
  408.     name(n).number = num;
  409.     name(n).type   = type;
  410.     name(n).defn   = CFUN;
  411.  
  412.     return n;
  413. }
  414.  
  415. static List local selectCtxt(ctxt,vs)    /* calculate subset of context       */
  416. List ctxt;
  417. List vs; {
  418.     if (isNull(vs))
  419.     return NIL;
  420.     else {
  421.     List ps = NIL;
  422.     for (; nonNull(ctxt); ctxt=tl(ctxt)) {
  423.         List us = offsetTyvarsIn(hd(ctxt),NIL);
  424.         for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us))
  425.         ;
  426.         if (isNull(us))
  427.         ps = cons(hd(ctxt),ps);
  428.     }
  429.     return rev(ps);
  430.     }
  431. }
  432.  
  433. static Void local checkSynonyms(ts)    /* check for mutually recursive       */
  434. List ts; {                /* synonyms in list of tycons ts   */
  435.     List syns = NIL;
  436.     for (; nonNull(ts); ts=tl(ts))    /* build list of all synonyms       */
  437.     switch (whatIs(tycon(hd(ts)).what)) {
  438.         case SYNONYM     :
  439.         case RESTRICTSYN : syns = cons(hd(ts),syns);
  440.     }
  441.     while (nonNull(syns))        /* then visit each synonym       */
  442.     syns = visitSyn(NIL,hd(syns),syns);
  443. }
  444.  
  445. static List local visitSyn(path,t,syns)    /* visit synonym definition to look*/
  446. List  path;                /* for cycles               */
  447. Tycon t;
  448. List  syns; {
  449.     if (cellIsMember(t,path)) {        /* every elt in path depends on t  */
  450.     ERROR(tycon(t).line)
  451.         "Type synonyms \"%s\" and \"%s\" are mutually recursive",
  452.         textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
  453.     EEND;
  454.     }
  455.     else {
  456.     List ds    = tycon(t).kind;
  457.         List path1 = NIL;
  458.     for (; nonNull(ds); ds=tl(ds))
  459.         if (cellIsMember(hd(ds),syns)) {
  460.         if (isNull(path1))
  461.             path1 = cons(t,path);
  462.         syns = visitSyn(path1,hd(ds),syns);
  463.         }
  464.     }
  465.     tycon(t).defn = fullExpand(tycon(t).defn);
  466.     return removeCell(t,syns);
  467. }
  468.  
  469. /* --------------------------------------------------------------------------
  470.  * Expanding out all type synonyms in a type expression:
  471.  * ------------------------------------------------------------------------*/
  472.  
  473. static Type local fullExpand(t)        /* find full expansion of type exp */
  474. Type t; {                /* assuming that all relevant      */
  475.     Cell h = t;                /* synonym defns of lower rank have*/
  476.     Int  n = 0;                /* already been fully expanded       */
  477.     List args;
  478.     for (args=NIL; isAp(h); h=fun(h), n++)
  479.     args = cons(fullExpand(arg(h)),args);
  480.     t = applyToArgs(h,args);
  481.     if (isSynonym(h) && n>=tycon(h).arity)
  482.     if (n==tycon(h).arity)
  483.         t = instantiateSyn(tycon(h).defn,t);
  484.     else {
  485.         Type p = t;
  486.         while (--n > tycon(h).arity)
  487.         p = fun(p);
  488.         fun(p) = instantiateSyn(tycon(h).defn,fun(p));
  489.     }
  490.     return t;
  491. }
  492.  
  493. static Type local instantiateSyn(t,env)    /* instantiate type according using*/
  494. Type t;                    /* env to determine appropriate    */
  495. Type env; {                /* values for OFFSET type vars       */
  496.     switch (whatIs(t)) {
  497.     case AP      : return ap(instantiateSyn(fun(t),env),
  498.                  instantiateSyn(arg(t),env));
  499.  
  500.     case OFFSET  : return nthArg(offsetOf(t),env);
  501.  
  502.     default         : return t;
  503.     }
  504. }
  505.  
  506. /* --------------------------------------------------------------------------
  507.  * Calculate set of variables appearing in a given type expression (possibly
  508.  * qualified) as a list of distinct values.  The order in which variables
  509.  * appear in the list is the same as the order in which those variables
  510.  * occur in the type expression when read from left to right.
  511.  * ------------------------------------------------------------------------*/
  512.  
  513. static List local typeVarsIn(type,vs)  /* calculate list of type variables */
  514. Cell type;                   /* used in type expression, reading */
  515. List vs; {                   /* from left to right           */
  516.     switch (whatIs(type)) {
  517.     case AP        : return typeVarsIn(snd(type),
  518.                        typeVarsIn(fst(type),
  519.                               vs));
  520.     case VARIDCELL :
  521.     case VAROPCELL : return maybeAppendVar(type,vs);
  522.  
  523.     case QUAL      : {   List qs = fst(snd(type));
  524.                  vs = typeVarsIn(snd(snd(type)),vs);
  525.                  for (; nonNull(qs); qs=tl(qs))
  526.                  vs = typeVarsIn(hd(qs),vs);
  527.                  return vs;
  528.              }
  529.     }
  530.     return vs;
  531. }
  532.  
  533. static List local maybeAppendVar(v,vs) /* append variable to list if not   */
  534. Cell v;                    /* already included           */
  535. List vs; {
  536.     Text t = textOf(v);
  537.     List p = NIL;
  538.     List c = vs;
  539.  
  540.     while (nonNull(c)) {
  541.     if (textOf(hd(c))==t)
  542.         return vs;
  543.     p = c;
  544.     c = tl(c);
  545.     }
  546.  
  547.     if (nonNull(p))
  548.     tl(p) = cons(v,NIL);
  549.     else
  550.     vs    = cons(v,NIL);
  551.  
  552.     return vs;
  553. }
  554.  
  555. /* --------------------------------------------------------------------------
  556.  * Check for ambiguous types:
  557.  * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
  558.  * ------------------------------------------------------------------------*/
  559.  
  560. static List local offsetTyvarsIn(t,vs)    /* add list of offset tyvars in t  */
  561. Type t;                    /* to list vs               */
  562. List vs; {
  563.     switch (whatIs(t)) {
  564.     case AP        : return offsetTyvarsIn(fun(t),offsetTyvarsIn(snd(t),vs));
  565.  
  566.     case OFFSET : if (cellIsMember(t,vs))
  567.               return vs;
  568.               else
  569.               return cons(t,vs);
  570.  
  571.     case QUAL   : return offsetTyvarsIn(snd(t),vs);
  572.  
  573.     default        : return vs;
  574.     }
  575. }
  576.  
  577. Bool isAmbiguous(type)            /* Determine whether type is       */
  578. Type type; {                /* ambiguous                */
  579.     if (isPolyType(type))
  580.     type = monoTypeOf(type);
  581.     if (whatIs(type)==QUAL) {        /* only qualified types can be       */
  582.     List tvps = offsetTyvarsIn(fst(snd(type)),NIL);    /* ambiguous       */
  583.     List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
  584.     while (nonNull(tvps) && cellIsMember(hd(tvps),tvts))
  585.         tvps = tl(tvps);
  586.     return nonNull(tvps);
  587.     }
  588.     return FALSE;
  589. }
  590.  
  591. Void ambigError(line,where,e,type)    /* produce error message for       */
  592. Int    line;                /* ambiguity               */
  593. String where;
  594. Cell   e;
  595. Type   type; {
  596.     ERROR(line) "Ambiguous type signature in %s", where ETHEN
  597.     ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
  598.     ERRTEXT "\n*** assigned to    : " ETHEN ERREXPR(e);
  599.     ERRTEXT "\n"
  600.     EEND;
  601. }
  602.  
  603. /* --------------------------------------------------------------------------
  604.  * Type expressions appearing in type signature declarations and expressions
  605.  * also require static checking, but unlike type expressions in type decls,
  606.  * they may introduce arbitrary new type variables.  The static analysis
  607.  * required here is:
  608.  *   - ensure that each type constructor is defined and used with the
  609.  *     correct number of arguments.
  610.  *   - replace type variables by offsets, constructor names by Tycons.
  611.  *   - ensure that type is well-kinded.
  612.  * ------------------------------------------------------------------------*/
  613.  
  614. static Type local checkSigType(line,where,e,type)
  615. Int    line;                   /* check validity of type expression*/
  616. String where;                   /* in explicit type signature       */
  617. Cell   e;
  618. Type   type; {
  619.     List tyvars = typeVarsIn(type,NIL);
  620.     Int  n      = length(tyvars);
  621.  
  622.     if (whatIs(type)==QUAL) {
  623.     map2Proc(depPredExp,line,tyvars,fst(snd(type)));
  624.     snd(snd(type)) = depTypeExp(line,tyvars,snd(snd(type)));
  625.  
  626.     if (isAmbiguous(type))
  627.         ambigError(line,where,e,type);
  628.     }
  629.     else
  630.     type = depTypeExp(line,tyvars,type);
  631.  
  632.     if (n>0) {
  633.     if (n>=NUM_OFFSETS) {
  634.         ERROR(line) "Too many type variables in %s\n", where
  635.         EEND;
  636.     }
  637.     type = mkPolyType(mkSelect(n),type);
  638.     }
  639.  
  640.     kindSigType(line,type);        /* check that type is well-kinded  */
  641.     return type;
  642. }
  643.  
  644. /* --------------------------------------------------------------------------
  645.  * Static analysis of class declarations:
  646.  *
  647.  * Performed in a similar manner to that used for type declarations.
  648.  *
  649.  * The first part of the static analysis is performed as the declarations
  650.  * are read during parsing.  The parser ensures that:
  651.  * - the class header and all superclass predicates are of the form
  652.  *   ``Class var''
  653.  *
  654.  * The classDefn() function:
  655.  * - ensures that there is no previous definition for class
  656.  * - checks that class name has not previously been used as a type constr.
  657.  * - make new entry in class table
  658.  * - record line number of declaration
  659.  * - build list of classes defined in current script for use in later
  660.  *   stages of static analysis.
  661.  * ------------------------------------------------------------------------*/
  662.  
  663. Void classDefn(line,head,ms)           /* process new class definition       */
  664. Int  line;                   /* definition line number       */
  665. Cell head;                   /* class header :: ([Supers],Class) */
  666. List ms; {                   /* class definition body           */
  667.     Text ct = textOf(fun(snd(head)));
  668.  
  669.     if (nonNull(findClass(ct))) {
  670.     ERROR(line) "Repeated definition of type class \"%s\"",
  671.             textToStr(ct)
  672.     EEND;
  673.     }
  674.     else if (nonNull(findTycon(ct))) {
  675.     ERROR(line) "\"%s\" used as both class and type constructor",
  676.             textToStr(ct)
  677.     EEND;
  678.     }
  679.     else {
  680.     Class new       = newClass(ct);
  681.     class(new).line       = line;
  682.     class(new).supers  = head;
  683.     class(new).members = ms;
  684.     class(new).level   = 0;
  685.     classDefns       = cons(new,classDefns);
  686.     }
  687. }
  688.  
  689. /* --------------------------------------------------------------------------
  690.  * Further analysis of class declarations:
  691.  *
  692.  * Full static analysis of class definitions must be postponed until the
  693.  * complete script has been read and all static analysis on type definitions
  694.  * has been completed.
  695.  *
  696.  * Once this has been achieved, we carry out the following checks on each
  697.  * class definition:
  698.  * - check superclass declarations, replace by list of classes
  699.  * - split body of class into members and declarations
  700.  * - make new name entry for each member function
  701.  * - record member function number (eventually an offset into dictionary!)
  702.  * - no member function has a previous definition ...
  703.  * - no member function is mentioned more than once in the list of members
  704.  * - each member function type is valid, replace vars by offsets
  705.  * - qualify each member function type by class header
  706.  * - only bindings for members appear in defaults
  707.  * - only function bindings appear in defaults
  708.  * - check that extended class hierarchy does not contain any cycles
  709.  * ------------------------------------------------------------------------*/
  710.  
  711. static Void local checkClassDefn(c)    /* validate class definition       */
  712. Class c; {
  713.     Cell head          = snd(class(c).supers);
  714.     List tyvars        = singleton(arg(head));
  715.  
  716.     class(c).supers    = fst(class(c).supers);            /* supercl.*/
  717.     tcDeps           = NIL;
  718.     map2Proc(depPredExp,class(c).line,tyvars,class(c).supers);
  719.     class(c).numSupers = length(class(c).supers);
  720.     mapOver(fst,class(c).supers);
  721.  
  722.     class(c).defaults  = extractBindings(class(c).members);    /* defaults*/
  723.     class(c).members   = extractSigdecls(class(c).members);
  724.     fun(head)           = c;
  725.     arg(head)           = mkOffset(0);
  726.     map2Proc(checkMems,head,tyvars,class(c).members);
  727.     class(c).sig       = tcDeps;
  728.     tcDeps             = NIL;
  729. }
  730.  
  731. static Void local depPredExp(line,tyvars,pred)
  732. Int  line;
  733. List tyvars;
  734. Cell pred; {
  735.     Class c = findClass(textOf(fun(pred)));
  736.     if (isNull(c)) {
  737.     ERROR(line) "Undefined class \"%s\"", textToStr(textOf(fun(pred)))
  738.     EEND;
  739.     }
  740.     fun(pred) = c;
  741.     arg(pred) = depTypeExp(line,tyvars,arg(pred));
  742.     if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps))
  743.     tcDeps = cons(c,tcDeps);
  744. }
  745.  
  746. static Void local checkMems(h,tyvars,m)    /* check member function details   */
  747. Cell h;
  748. List tyvars;
  749. Cell m; {
  750.     Int  line = intOf(fst3(m));
  751.     List vs   = snd3(m);
  752.     Type t    = thd3(m);
  753.  
  754.     tyvars    = typeVarsIn(t,tyvars);
  755.     if (whatIs(t)==QUAL) {        /* overloaded member signatures?  */
  756.     List qs = fst(snd(t));
  757.     for (; nonNull(qs); qs=tl(qs)) {
  758.         depPredExp(line,tyvars,hd(qs));
  759.         if (arg(hd(qs))==mkOffset(0)) {
  760.         ERROR(line) "Illegal constraints on class variable \"%s\"",
  761.                 textToStr(textOf(hd(tyvars)))
  762.         ETHEN ERRTEXT " in type of member function \"%s\"",
  763.                 textToStr(textOf(hd(vs)))
  764.         EEND;
  765.         }
  766.     }
  767.     
  768.     map2Proc(depPredExp,line,tyvars,qs);
  769.     }
  770.     else
  771.     t = ap(QUAL,pair(NIL,t));
  772.     fst(snd(t)) = cons(h,fst(snd(t)));
  773.     snd(snd(t)) = depTypeExp(line,tyvars,snd(snd(t)));
  774.     t           = mkPolyType(mkSelect(length(tyvars)),t);
  775.  
  776.     if (isAmbiguous(t))
  777.     ambigError(line,"class declaration",hd(vs),t);
  778.  
  779.     thd3(m)    = t;                /* save type           */
  780.     tl(tyvars) = NIL;                /* delete extra type vars  */
  781. }
  782.  
  783. static Void local addMembers(c)        /* Add definitions of member funs  */
  784. Class c; {
  785.     Int  mno   = 1;            /* member function number       */
  786.     List mfuns = NIL;            /* list of member functions       */
  787.     List ms    = class(c).members;
  788.  
  789.     for (; nonNull(ms); ms=tl(ms)) {    /* cycle through each sigdecl       */
  790.     Int  line = intOf(fst3(hd(ms)));
  791.     List vs   = rev(snd3(hd(ms)));
  792.     Type t    = thd3(hd(ms));
  793.     for (; nonNull(vs); vs=tl(vs))
  794.         mfuns = cons(newMember(line,mno++,hd(vs),t),mfuns);
  795.     }
  796.     class(c).members    = rev(mfuns);    /* save list of members           */
  797.     class(c).numMembers = length(class(c).members);
  798.     class(c).defaults   = classBindings("class",c,class(c).defaults);
  799. }
  800.  
  801. static Name local newMember(l,no,v,t)    /* Make definition for member fn   */
  802. Int  l;
  803. Int  no;
  804. Cell v;
  805. Type t; {
  806.     Name m = findName(textOf(v));
  807.  
  808.     if (isNull(m))
  809.     m = newName(textOf(v));
  810.     else if (name(m).defn!=PREDEFINED) {
  811.     ERROR(l) "Repeated definition for member function \"%s\"",
  812.          textToStr(name(m).text)
  813.     EEND;
  814.     }
  815.  
  816.     name(m).line   = l;
  817.     name(m).arity  = 1;
  818.     name(m).number = no;
  819.     name(m).type   = t;
  820.     name(m).defn   = MFUN;
  821.  
  822.     return m;
  823. }
  824.  
  825. static Int local visitClass(c)        /* visit class defn to check that  */
  826. Class c; {                /* class hierarchy is acyclic       */
  827.     if (class(c).level < 0) {        /* already visiting this class?       */
  828.     ERROR(class(c).line) "Class hierarchy for \"%s\" is not acyclic",
  829.                  textToStr(class(c).text)
  830.     EEND;
  831.     }
  832.     else if (class(c).level == 0) {    /* visiting class for first time   */
  833.     List scs = class(c).supers;
  834.     Int  lev = 0;
  835.     class(c).level = (-1);
  836.     for (; nonNull(scs); scs=tl(scs)) {
  837.         Int l = visitClass(hd(scs));
  838.         if (l>lev) lev=l;
  839.     }
  840.     class(c).level = 1+lev;        /* level = 1 + max level of supers */
  841.     }
  842.     return class(c).level;
  843. }
  844.  
  845. /* --------------------------------------------------------------------------
  846.  * Static analysis of instance declarations:
  847.  *
  848.  * The first part of the static analysis is performed as the declarations
  849.  * are read during parsing:
  850.  * - make new entry in instance table
  851.  * - record line number of declaration
  852.  * - build list of instances defined in current script for use in later
  853.  *   stages of static analysis.
  854.  * ------------------------------------------------------------------------*/
  855.  
  856. Void instDefn(line,head,ms)           /* process new instance definition  */
  857. Int  line;                   /* definition line number       */
  858. Cell head;                   /* inst header :: (context,Class)   */
  859. List ms; {                   /* instance members           */
  860.     Inst new             = newInst();
  861.     inst(new).line       = line;
  862.     inst(new).specifics  = head;
  863.     inst(new).implements = ms;
  864.     instDefns            = cons(new,instDefns);
  865. }
  866.  
  867. /* --------------------------------------------------------------------------
  868.  * Further static analysis of instance declarations:
  869.  *
  870.  * Makes the following checks:
  871.  * - Class part of header has form C (T a1 ... an) where C is a known
  872.  *   class, and T is a known datatype constructor (or restricted synonym),
  873.  *   and there is no previous C-T instance, and (T a1 ... an) has a kind
  874.  *   appropriate for the class C.
  875.  * - Each element of context is a valid class expression, with type vars
  876.  *   drawn from a1, ..., an.
  877.  * - All bindings are function bindings
  878.  * - All bindings define member functions for class C
  879.  * - Arrange bindings into appropriate order for member list
  880.  * - No top level type signature declarations
  881.  * ------------------------------------------------------------------------*/
  882.  
  883. static Void local checkInstDefn(in)    /* validate instance declaration    */
  884. Inst in; {
  885.     Int  line   = inst(in).line;
  886.     Cell head   = snd(inst(in).specifics);
  887.     List tyvars = getArgs(arg(head));
  888.     Cell tmp;
  889.  
  890.     for (tmp=tyvars; nonNull(tmp); tmp=tl(tmp))    /* check for repeated var  */
  891.     if (nonNull(varIsMember(textOf(hd(tmp)),tl(tmp)))) {
  892.         ERROR(line) "Repeated type variable \"%s\" in instance predicate",
  893.             textToStr(textOf(hd(tmp)))
  894.         EEND;
  895.     }
  896.     depPredExp(line,tyvars,head);
  897.     inst(in).specifics = fst(inst(in).specifics);
  898.     map2Proc(depPredExp,line,tyvars,inst(in).specifics);
  899.     inst(in).numSpecifics = length(inst(in).specifics);
  900.  
  901.     tmp = getHead(arg(head));
  902.     if (!isTycon(tmp) && !isTuple(tmp) &&
  903.     tmp!=ARROW && tmp!=LIST && tmp!=UNIT) {
  904.     ERROR(line) "Simple type required in instance declaration"
  905.     EEND;
  906.     }
  907.     if (isSynonym(tmp)) {
  908.     ERROR(line) "Type synonym \"%s\" not permitted in instance of \"%s\"",
  909.             textToStr(tycon(tmp).text),
  910.             textToStr(class(fun(head)).text)
  911.     EEND;
  912.     }
  913.  
  914.     inst(in).c     = fun(head);
  915.     inst(in).t     = tmp;
  916.     inst(in).arity = argCount;
  917.     kindInst(in,head);
  918.  
  919.     if (nonNull(findInst(inst(in).c,inst(in).t))) {
  920.     ERROR(line) "Repeated instance declaration for "
  921.     ETHEN ERRPRED(head);
  922.     ERRTEXT "\n"
  923.     EEND;
  924.     }
  925.     else
  926.     class(inst(in).c).instances
  927.         = appendOnto(class(inst(in).c).instances,singleton(in));
  928.  
  929.     if (nonNull(extractSigdecls(inst(in).implements))) {
  930.         ERROR(line) "Type signature decls not permitted in instance decl"
  931.         EEND;
  932.     }
  933.     inst(in).implements = classBindings("instance",
  934.                     inst(in).c,
  935.                     extractBindings(inst(in).implements));
  936. }
  937.  
  938. /* --------------------------------------------------------------------------
  939.  * Verifying superclass constraints:
  940.  *
  941.  * Unlike Gofer, the Haskell report requires strict static checks on
  942.  * instance declarations to ensure that superclass hierarchies can be
  943.  * constructed.  The restrictions are outlined on Pages 32--33 of the
  944.  * Haskell 1.2 report.  The effect of these rules is that, for each
  945.  * pair of declarations:
  946.  *
  947.  *    class C a => D a where ...
  948.  *    instance ps => D (T a1 ... an) where ...
  949.  *
  950.  * there must also be an instance:
  951.  *
  952.  *    instance ps1 => C (T a1 ... an) where ...
  953.  *
  954.  * such that ps1 is always implied by ps.  Since Haskell and Hugs restrict
  955.  * these two contexts to predicates of the form Class var, this is equivalent
  956.  * to requiring that each pi' in ps1 is a subclass (not necessarily proper)
  957.  * of some pi in ps.
  958.  * ------------------------------------------------------------------------*/
  959.  
  960. static Void local checkInstSC(in)    /* check superclass constraints for*/
  961. Inst in; {                /* a given instance, in           */
  962.     Class c   = inst(in).c;
  963.     List  scs = class(c).supers;
  964.     List  ps  = inst(in).specifics;
  965.  
  966.     for (; nonNull(scs); scs=tl(scs)) {
  967.     Class sc   = hd(scs);
  968.     Inst  scin = findInst(sc,inst(in).t);
  969.     List  ps1;
  970.  
  971.     if (isNull(scin)) {            /* condition 1, page 32       */
  972.         Cell cpi  = makeInstPred(in);
  973.         Cell scpi = ap(sc,arg(cpi));
  974.         ERROR(inst(in).line) "Definition of "    ETHEN ERRPRED(cpi);
  975.         ERRTEXT " requires superclass instance " ETHEN ERRPRED(scpi);
  976.         ERRTEXT "\n"
  977.         EEND;
  978.     }
  979.  
  980.     for (ps1=inst(scin).specifics; nonNull(ps1); ps1=tl(ps1)) {
  981.         Cell e = scEvidFrom(hd(ps1),ps);    /* condition 2, page 32       */
  982.         if (nonNull(e))
  983.         scin = ap(scin,e);
  984.         else {
  985.         Cell cpi  = makeInstPred(in);
  986.         Cell scpi = ap(sc,arg(cpi));
  987.         ERROR(inst(in).line) "Cannot build superclass instance "
  988.                          ETHEN ERRPRED(scpi);
  989.         ERRTEXT " of "             ETHEN ERRPRED(cpi);
  990.         ERRTEXT ":\n*** Context  : " ETHEN ERRCONTEXT(ps);
  991.         ERRTEXT "\n*** Required : "  ETHEN ERRPRED(hd(ps1));
  992.         ERRTEXT "\n"
  993.         EEND;
  994.         }
  995.     }
  996.  
  997.     inst(in).superBuild = cons(scin,inst(in).superBuild);
  998.     }
  999.     inst(in).superBuild = rev(inst(in).superBuild);
  1000. }
  1001.  
  1002. static Cell local scEvidFrom(pi,ps)    /* Calculate evidence for pred       */
  1003. Cell pi;                /* pi from ps using superclass       */
  1004. List ps; {                /* entailment               */
  1005.     Int n = 0;
  1006.     for (; nonNull(ps); ps=tl(ps), n++)
  1007.     if (arg(pi)==arg(hd(ps))) {
  1008.         Cell e = superEvid(mkOffset(n),fun(hd(ps)),fun(pi));
  1009.         if (nonNull(e))
  1010.         return e;
  1011.     }
  1012.     return NIL;
  1013. }
  1014.  
  1015. /* --------------------------------------------------------------------------
  1016.  * Process class and instance declaration binding groups:
  1017.  * ------------------------------------------------------------------------*/
  1018.  
  1019. static List local classBindings(where,c,bs)
  1020. String where;                          /* check validity of bindings bs for*/
  1021. Class  c;                              /* class c (or an instance of c)    */
  1022. List   bs; {                           /* sort into approp. member order   */
  1023.     List nbs = NIL;
  1024.  
  1025.     for (; nonNull(bs); bs=tl(bs)) {
  1026.     Cell b  = hd(bs);
  1027.         Name nm = newName(inventText());   /* pick name for implementation */
  1028.     Int  mno;
  1029.  
  1030.     if (!isVar(fst(b))) {          /* only allows function bindings    */
  1031.             ERROR(rhsLine(snd(snd(snd(b)))))
  1032.                "Pattern binding illegal in %s declaration", where
  1033.         EEND;
  1034.         }
  1035.  
  1036.     if ((mno=memberNumber(c,textOf(fst(b))))==0) {
  1037.         ERROR(rhsLine(snd(hd(snd(snd(b))))))
  1038.         "No member \"%s\" in class \"%s\"",
  1039.         textToStr(textOf(fst(b))), textToStr(class(c).text)
  1040.         EEND;
  1041.     }
  1042.  
  1043.     name(nm).defn = snd(snd(b));   /* save definition of implementation*/
  1044.     nbs = numInsert(mno-1,nm,nbs);
  1045.     }
  1046.     return nbs;
  1047. }
  1048.  
  1049. static Int local memberNumber(c,t)     /* return number of member function */
  1050. Class c;                               /* with name t in class c           */
  1051. Text  t; {                             /* return 0 if not a member         */
  1052.     List ms = class(c).members;
  1053.     for (; nonNull(ms); ms=tl(ms))
  1054.         if (t==name(hd(ms)).text)
  1055.             return name(hd(ms)).number;
  1056.     return 0;
  1057. }
  1058.  
  1059. static List local numInsert(n,x,xs)    /* insert x at nth position in xs,  */
  1060. Int  n;                                /* filling gaps with NIL            */
  1061. Cell x;
  1062. List xs; {
  1063.     List start = isNull(xs) ? cons(NIL,NIL) : xs;
  1064.  
  1065.     for (xs=start; 0<n--; xs=tl(xs))
  1066.     if (isNull(tl(xs)))
  1067.         tl(xs) = cons(NIL,NIL);
  1068.     hd(xs) = x;
  1069.     return start;
  1070. }
  1071.  
  1072. /* --------------------------------------------------------------------------
  1073.  * Process derived instance requests:
  1074.  * ------------------------------------------------------------------------*/
  1075.  
  1076. static List derivedInsts;        /* list of derived instances       */
  1077. static Bool instsChanged;
  1078.  
  1079. static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
  1080. Tycon t;                /* for tycon t, with explicit       */
  1081. List  p;                /* context p, component types ts   */
  1082. List  ts;                /* and named class ct           */
  1083. Cell  ct; {
  1084.     Int   line = tycon(t).line;
  1085.     Class c    = findClass(textOf(ct));
  1086.     if (isNull(c)) {
  1087.     ERROR(line) "Unknown class \"%s\" in derived instance",
  1088.             textToStr(textOf(ct))
  1089.     EEND;
  1090.     }
  1091.     addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
  1092. }
  1093.  
  1094. static Void local addDerInst(line,c,p,cts,t,a)
  1095. Int   line;                /* add a derived instance      */
  1096. Class c;
  1097. List  p, cts;
  1098. Type  t;
  1099. Int   a; {
  1100.     Inst in = newInst();
  1101.  
  1102.     if (nonNull(findInst(c,t))) {
  1103.     ERROR(line) "Duplicate derived instance for class \"%s\"",
  1104.             textToStr(class(c).text)
  1105.     EEND;
  1106.     }
  1107.  
  1108.     p = appendOnto(dupList(p),singleton(NIL));    /* set initial values for  */
  1109. #define applyClass(t) ap(c,t)            /* derived instance calc.  */
  1110.     mapOver(applyClass,cts);
  1111. #undef  applyClass
  1112.  
  1113.     in                = newInst();
  1114.     inst(in).c          = c;
  1115.     inst(in).t          = t;
  1116.     inst(in).arity      = a;
  1117.     inst(in).line       = line;
  1118.     inst(in).specifics  = ap(DERIVE,pair(p,cts));
  1119.     inst(in).implements = NIL;
  1120.     class(c).instances  = appendOnto(class(c).instances,singleton(in));
  1121.     derivedInsts        = cons(in,derivedInsts);
  1122. }
  1123.  
  1124. Void addTupInst(c,n)            /* Request derived instance of c   */
  1125. Class c;                /* for mkTuple(n) constructor       */
  1126. Int   n; {
  1127.     Int  m              = n;
  1128.     List cts            = NIL;
  1129.     while (0<m--)
  1130.     cts = cons(mkOffset(m),cts);
  1131.     addDerInst(0,c,NIL,cts,mkTuple(n),n);
  1132. }
  1133.  
  1134. static Void local deriveContexts(is)    /* calculate contexts for derived  */
  1135. List is; {                /* instances               */
  1136.  
  1137.     mapProc(addDerivImp,is);        /* first, add implementations       */
  1138.  
  1139.     instsChanged = TRUE;        /* main calculation of contexts       */
  1140.     while (instsChanged) {
  1141.     instsChanged = FALSE;
  1142.     mapProc(calcInstPreds,derivedInsts);
  1143.     }
  1144.  
  1145.     for (; nonNull(is); is=tl(is)) {    /* extract and simplify results       */
  1146.     inst(hd(is)).specifics
  1147.         = superSimp(initSeg(fst(snd(inst(hd(is)).specifics))));
  1148.     inst(hd(is)).numSpecifics = length(inst(hd(is)).specifics);
  1149.     }
  1150. }
  1151.  
  1152. static List local superSimp(ps)        /* Simplify preds in ps using super*/
  1153. List ps; {                /* class hierarchy ...           */
  1154.     Int n = length(ps);
  1155.  
  1156.     while (0<n--)
  1157.     if (nonNull(scEvidFrom(hd(ps),tl(ps))))
  1158.         ps = tl(ps);
  1159.     else {
  1160.         Cell tmp = tl(ps);
  1161.         tl(ps)   = NIL;
  1162.         ps       = appendOnto(tmp,ps);
  1163.     }
  1164.     return ps;
  1165. }
  1166.  
  1167. static Void local maybeAddPred(pi,ps)    /* Add predicate pi to the list ps,*/
  1168. Cell pi;                /* setting the instsChanged flag if*/
  1169. List ps; {                /* pi is not already a member.       */
  1170.     Class c = fun(pi);
  1171.     Cell  v = arg(pi);
  1172.     for (; nonNull(ps); ps=tl(ps))
  1173.     if (isNull(hd(ps))) {        /* reached the `dummy' end of list?*/
  1174.         hd(ps)       = pi;
  1175.         tl(ps)       = pair(NIL,NIL);
  1176.         instsChanged = TRUE;
  1177.         return;
  1178.     }
  1179.     else if (fun(hd(ps))==c && arg(hd(ps))==v)
  1180.         return;
  1181. }
  1182.  
  1183. static Cell local instPred(pi,t)    /* Create instance of Hask pred pi */
  1184. Cell pi;                /* under the simple substitution   */
  1185. Type t; {                /* represented by t           */
  1186.     return ap(fun(pi),nthArg(offsetOf(arg(pi)),t));
  1187. }
  1188.  
  1189. static Void local calcInstPreds(in)    /* Calculate next approximation       */
  1190. Inst in; {                /* of the context for a derived       */
  1191.     List retain = NIL;            /* instance               */
  1192.     List ps     = snd(snd(inst(in).specifics));
  1193.     List spcs   = fst(snd(inst(in).specifics));
  1194.  
  1195.     while (nonNull(ps)) {
  1196.     Cell pi = hd(ps);
  1197.     ps      = tl(ps);
  1198.     if (isClass(fun(pi))) {            /* Class type           */
  1199.         if (isOffset(arg(pi)))        /* Class variable       */
  1200.         maybeAddPred(pi,spcs);
  1201.         else {                /* Class (T t1 ... tn)       */
  1202.         Class c   = fun(pi);
  1203.         Cell  t   = getHead(arg(pi));
  1204.         Inst  in1 = findInst(c,t);
  1205.  
  1206.         if (isNull(in1)) {        /* No suitable instance       */
  1207.             Cell bpi = makeInstPred(in);
  1208.             ERROR(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
  1209.             ERRTEXT " is required to derive "      ETHEN ERRPRED(bpi);
  1210.             ERRTEXT "\n"
  1211.             EEND;
  1212.         }                /* previously defined inst */
  1213.         else if (whatIs(inst(in1).specifics)!=DERIVE) {
  1214.             List qs = inst(in1).specifics;
  1215.             for (; nonNull(qs); qs=tl(qs))
  1216.             ps = cons(instPred(hd(qs),arg(pi)),ps);
  1217.         }
  1218.         else {                /* still being derived       */
  1219.             List qs = fst(snd(inst(in1).specifics));
  1220.             for (; nonNull(hd(qs)); qs=tl(qs))
  1221.             ps = cons(instPred(hd(qs),arg(pi)),ps);
  1222.             retain = cons(pair(arg(pi),qs),retain);
  1223.             instsChanged = TRUE;
  1224.         }
  1225.         }
  1226.     }
  1227.     else {                    /* Application of a subst  */
  1228.         List qs = snd(pi);            /* to a list of predicates,*/
  1229.         if (nonNull(hd(qs)))        /* given by a variable       */
  1230.         instsChanged = TRUE;
  1231.         for (; nonNull(hd(qs)); qs=tl(qs))
  1232.         ps = cons(instPred(hd(qs),fst(pi)),ps);
  1233.         retain = cons(pair(fst(pi),qs),retain);
  1234.     }
  1235.     }
  1236.  
  1237.     snd(snd(inst(in).specifics)) = retain;
  1238. }
  1239.  
  1240. /* --------------------------------------------------------------------------
  1241.  * Generate code for derived instances:
  1242.  * ------------------------------------------------------------------------*/
  1243.  
  1244. static Void local addDerivImp(Inst in) {
  1245.     List imp = NIL;
  1246.     if (inst(in).c==classEq)
  1247.     imp = deriveEq(inst(in).t);
  1248.     else if (inst(in).c==classOrd)
  1249.     imp = deriveOrd(inst(in).t);
  1250.     else if (inst(in).c==classEnum)
  1251.     imp = deriveEnum(inst(in).t);
  1252.     else if (inst(in).c==classIx)
  1253.     imp = deriveIx(inst(in).t);
  1254.     else if (inst(in).c==classText)
  1255.     imp = deriveText(inst(in).t);
  1256.     else if (inst(in).c==classBinary) {
  1257.     /* intentionally left blank; Hugs does not implement the Binary
  1258.      * class or the Bin datatype, but permits use of class Binary
  1259.      * in deriving lists for compatibility with Haskell.
  1260.      */
  1261.     }
  1262.     else {
  1263.     ERROR(inst(in).line) "Cannot derive instances of class \"%s\"",
  1264.                  textToStr(class(inst(in).c).text)
  1265.     EEND;
  1266.     }
  1267.  
  1268.     inst(in).implements = classBindings("derived instance",
  1269.                     inst(in).c,
  1270.                     imp);
  1271. }
  1272.  
  1273. static List diVars = NIL;        /* Acts as a cache of invented vars*/
  1274. static Int  diNum  = 0;
  1275.  
  1276. static List local getDiVars(n)        /* get list of at least n vars for */
  1277. Int n; {                /* derived instance generation       */
  1278.     for (; diNum<n; diNum++)
  1279.     diVars = cons(inventVar(),diVars);
  1280.     return diVars;
  1281. }
  1282.  
  1283. static Cell local mkBind(s,alts)    /* make a binding for a variable   */
  1284. String s;
  1285. List   alts; {
  1286.     return pair(mkVar(findText(s)),pair(NIL,alts));
  1287. }
  1288.  
  1289. static Cell local mkVarAlts(line,r)    /* make alts for binding a var to  */
  1290. Int  line;                /* a simple expression           */
  1291. Cell r; {
  1292.     return singleton(pair(NIL,pair(mkInt(line),r)));
  1293. }
  1294.  
  1295. /* --------------------------------------------------------------------------
  1296.  * Given a datatype:   data T a b = A a b | B Int | C  deriving (Eq, Ord)
  1297.  * The derived definitions of equality and ordering are given by:
  1298.  *
  1299.  *   A a b == A x y  =  a==x && b==y
  1300.  *   B a   == B x    =  a==x
  1301.  *   C     == C      =  True
  1302.  *   _     == _      =  False
  1303.  *
  1304.  *   ordcmp (A a b) (A x y) s  =  ordcmp a x (ordcmp b y s)
  1305.  *   ordcmp (B a)   (B x)   s  =  ordcmp a x s
  1306.  *   ordcmp C       C       s  =  s
  1307.  *   ordcmp a       x       s  =  cmpConstr a x
  1308.  *
  1309.  * In each case, the last line is only needed if there are multiple
  1310.  * constructors in the datatype definition.
  1311.  * ------------------------------------------------------------------------*/
  1312.  
  1313. #define ap2(f,x,y) ap(ap(f,x),y)
  1314.  
  1315. static List local deriveEq(t)        /* generate binding for derived == */
  1316. Type t; {                /* for some TUPLE or DATATYPE t       */
  1317.     List alts = NIL;
  1318.     if (isTycon(t)) {            /* deal with type constrs       */
  1319.     List cs = tycon(t).defn;
  1320.     for (; nonNull(cs); cs=tl(cs))
  1321.         alts = cons(mkAltEq(tycon(t).line,
  1322.                 makeDPats2(hd(cs),name(hd(cs)).arity,NIL)),
  1323.             alts);
  1324.     if (nonNull(tl(tycon(t).defn)))
  1325.         alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
  1326.                  pair(mkInt(tycon(t).line),nameFalse)),alts);
  1327.     alts = rev(alts);
  1328.     }
  1329.     else                /* special case for tuples       */
  1330.     alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t),NIL)));
  1331.  
  1332.     return singleton(mkBind("==",alts));
  1333. }
  1334.  
  1335. static Pair local mkAltEq(line,pats)    /* make alt for an equation for == */
  1336. Int  line;                /* using patterns in pats for lhs  */
  1337. List pats; {                /* arguments (assume same CFUN)    */
  1338.     Cell p = hd(pats);
  1339.     Cell q = hd(tl(pats));
  1340.     Cell e = nameTrue;
  1341.  
  1342.     if (isAp(p)) {
  1343.     e = ap2(nameEq,arg(p),arg(q));
  1344.     for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q))
  1345.         e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
  1346.     }
  1347.     return pair(pats,pair(mkInt(line),e));
  1348. }
  1349.  
  1350. static List local deriveOrd(t)        /* make binding for derived ordcmp */
  1351. Type t; {                /* for some TUPLE or DATATYPE t       */
  1352.     List vs   = singleton(inventVar());
  1353.     List alts = NIL;
  1354.     if (isEnumType(t))            /* special case for enumerations   */
  1355.     alts = mkVarAlts(tycon(t).line,nameConCmp);
  1356.     else if (isTycon(t)) {        /* deal with type constrs       */
  1357.     List cs = tycon(t).defn;
  1358.  
  1359.     for (; nonNull(cs); cs=tl(cs))
  1360.         alts = cons(mkAltOrd(tycon(t).line,
  1361.                  makeDPats2(hd(cs),name(hd(cs)).arity,vs)),
  1362.             alts);
  1363.  
  1364.     if (nonNull(tl(tycon(t).defn))) {
  1365.         Cell u = inventVar();
  1366.         Cell w = inventVar();
  1367.         alts   = cons(pair(cons(u,cons(w,vs)),
  1368.                    pair(mkInt(tycon(t).line),
  1369.                     ap(ap2(nameConCmp,u,w),nameTrue))),alts);
  1370.     }
  1371.     alts = rev(alts);
  1372.     }
  1373.     else                /* special case for tuples       */
  1374.     alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t),vs)));
  1375.  
  1376.     return singleton(mkBind("ordcmp",alts));
  1377. }
  1378.  
  1379. static Pair local mkAltOrd(line,pats)    /* make alt for equation for ordcmp*/
  1380. Int  line;                /* using patterns in pats for lhs  */
  1381. List pats; {                /* arguments (assume same CFUN)    */
  1382.     Cell p = hd(pats);
  1383.     Cell q = hd(tl(pats));
  1384.     Cell e = hd(tl(tl(pats)));
  1385.  
  1386.     for (; isAp(p); p=fun(p), q=fun(q))
  1387.     e = ap(ap2(nameOrdcmp,arg(p),arg(q)),e);
  1388.  
  1389.     return pair(pats,pair(mkInt(line),e));
  1390. }
  1391.  
  1392. static List local makeDPats2(h,n,vs)    /* generate pattern list       */
  1393. Cell h;                    /* by putting two new patterns with*/
  1394. Int  n;                    /* head h and new var components   */
  1395. List vs; {                /* onto the front of vs           */
  1396.     List us = getDiVars(2*n);
  1397.     Cell p;
  1398.     Int  i;
  1399.  
  1400.     for (i=0, p=h; i<n; ++i) {        /* make first version of pattern   */
  1401.     p  = ap(p,hd(us));
  1402.     us = tl(us);
  1403.     }
  1404.     vs = cons(p,vs);
  1405.  
  1406.     for (i=0, p=h; i<n; ++i) {        /* make second version of pattern  */
  1407.     p  = ap(p,hd(us));
  1408.     us = tl(us);
  1409.     }
  1410.     return cons(p,vs);
  1411. }
  1412.  
  1413. /* --------------------------------------------------------------------------
  1414.  * Deriving Ix and Enum:
  1415.  * ------------------------------------------------------------------------*/
  1416.  
  1417. static List local deriveEnum(t)    /* Construct definition of enumeration       */
  1418. Tycon t; {
  1419.     if (!isEnumType(t)) {
  1420.     ERROR(tycon(t).line)
  1421.         "Can only derive instances of Enum for enumeration types"
  1422.     EEND;
  1423.     }
  1424.  
  1425.     return cons(mkBind("enumFrom",mkVarAlts(tycon(t).line,nameEnFrom)),
  1426.         cons(mkBind("enumFromTo",mkVarAlts(tycon(t).line,nameEnFrTo)),
  1427.          cons(mkBind("enumFromThen",mkVarAlts(tycon(t).line,nameEnFrTh)),
  1428.           NIL)));
  1429. }
  1430.  
  1431. static List local deriveIx(t)    /* Construct definition of indexing       */
  1432. Tycon t; {
  1433.     if (isEnumType(t))        /* Definitions for enumerations           */
  1434.     return cons(mkBind("range",mkVarAlts(tycon(t).line,nameEnRange)),
  1435.         cons(mkBind("index",mkVarAlts(tycon(t).line,nameEnIndex)),
  1436.          cons(mkBind("inRange",mkVarAlts(tycon(t).line,nameEnInRng)),
  1437.           NIL)));
  1438.     else if (isTuple(t))    /* Definitions for product types       */
  1439.     return mkIxBinds(0,t,tupleOf(t));
  1440.     else if (isTycon(t) && tycon(t).what==DATATYPE
  1441.             && isNull(tl(tycon(t).defn)))
  1442.     return mkIxBinds(tycon(t).line,
  1443.              hd(tycon(t).defn),
  1444.              name(hd(tycon(t).defn)).arity);
  1445.  
  1446.     ERROR(tycon(t).line)
  1447.     "Can only derive instances of Ix for enumeration or product types"
  1448.     EEND;
  1449.     return NIL;/* NOTREACHED*/
  1450. }
  1451.  
  1452. static Bool local isEnumType(t)    /* Determine whether t is an enumeration   */
  1453. Tycon t; {            /* type (i.e. all constructors arity == 0) */
  1454.     if (isTycon(t) && tycon(t).what==DATATYPE) {
  1455.     List cs = tycon(t).defn;
  1456.     for (; nonNull(cs); cs=tl(cs))
  1457.         if (name(hd(cs)).arity!=0)
  1458.         return FALSE;
  1459.     addCfunTable(t);
  1460.     return TRUE;
  1461.     }
  1462.     return FALSE;
  1463. }
  1464.  
  1465. static List local mkIxBinds(line,h,n)    /* build bindings for derived Ix on*/
  1466. Int  line;                /* a product type           */
  1467. Cell h;
  1468. Int  n; {
  1469.     List vs   = getDiVars(3*n);
  1470.     Cell ls   = h;
  1471.     Cell us   = h;
  1472.     Cell is   = h;
  1473.     Cell pr   = NIL;
  1474.     Cell pats = NIL;
  1475.     Int  i;
  1476.  
  1477.     for (i=0; i<n; ++i, vs=tl(vs)) {/* build three patterns for values */
  1478.     ls = ap(ls,hd(vs));        /* of the datatype concerned       */
  1479.     us = ap(us,hd(vs=tl(vs)));
  1480.     is = ap(is,hd(vs=tl(vs)));
  1481.     }
  1482.     pr   = ap2(mkTuple(2),ls,us);    /* Build (ls,us)           */
  1483.     pats = cons(pr,cons(is,NIL));    /* Build [(ls,us),is]           */
  1484.  
  1485.     return cons(prodRange(line,singleton(pr),ls,us,is),
  1486.         cons(prodIndex(line,pats,ls,us,is),
  1487.              cons(prodInRange(line,pats,ls,us,is),NIL)));
  1488. }
  1489.  
  1490. static Cell local prodRange(line,pats,ls,us,is)
  1491. Int  line;                /* Make definition of range for a  */
  1492. List pats;                /* product type               */
  1493. Cell ls, us, is; {
  1494.     /* range :: (a,a) -> [a]
  1495.      * range (X a b c, X p q r)
  1496.      *   = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
  1497.      */
  1498.     Cell is1 = is;
  1499.     List e   = NIL;
  1500.     for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is))
  1501.     e = cons(ap(FROMQUAL,pair(arg(is),
  1502.                   ap(nameRange,ap2(mkTuple(2),
  1503.                            arg(ls),
  1504.                            arg(us))))),e);
  1505.     e = ap(COMP,pair(is1,e));
  1506.     e = singleton(pair(pats,pair(mkInt(line),e)));
  1507.     return mkBind("range",e);
  1508. }
  1509.  
  1510. static Cell local prodIndex(line,pats,ls,us,is)
  1511. Int  line;                /* Make definition of index for a  */
  1512. List pats;                /* product type               */
  1513. Cell ls, us, is; {
  1514.     /* index :: (a,a) -> a -> Bool
  1515.      * index (X a b c, X p q r) (X x y z)
  1516.      *  = index (c,r) z + rangeSize (c,r) * (
  1517.      *     index (b,q) y + rangeSize (b,q) * (
  1518.      *      index (a,x) x))
  1519.      */
  1520.     List xs = NIL;
  1521.     Cell e  = NIL;
  1522.     for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is))
  1523.     xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
  1524.     for (e=hd(xs); nonNull(xs=tl(xs));) {
  1525.     Cell x = hd(xs);
  1526.     e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
  1527.     }
  1528.     e = singleton(pair(pats,pair(mkInt(line),e)));
  1529.     return mkBind("index",e);
  1530. }
  1531.  
  1532. static Cell local prodInRange(line,pats,ls,us,is)
  1533. Int  line;                /* Make definition of inRange for a*/
  1534. List pats;                /* product type               */
  1535. Cell ls, us, is; {
  1536.     /* inRange :: (a,a) -> a -> Bool
  1537.      * inRange (X a b c, X p q r) (X x y z)
  1538.      *          = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
  1539.      */
  1540.     Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
  1541.     while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls))
  1542.     e = ap2(nameAnd,
  1543.         ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
  1544.         e);
  1545.     e = singleton(pair(pats,pair(mkInt(line),e)));
  1546.     return mkBind("inRange",e);
  1547. }
  1548.  
  1549. /* --------------------------------------------------------------------------
  1550.  * Deriving Text:
  1551.  * ------------------------------------------------------------------------*/
  1552.  
  1553. static List local deriveText(t)    /* Construct definition of text conversion */
  1554. Tycon t; {
  1555.     List alts = NIL;
  1556.     if (isTycon(t)) {            /* deal with type constrs       */
  1557.     List cs = tycon(t).defn;
  1558.     for (; nonNull(cs); cs=tl(cs))
  1559.         alts = cons(mkAltText(tycon(t).line,hd(cs),name(hd(cs)).arity),
  1560.             alts);
  1561.     alts = rev(alts);
  1562.     }
  1563.     else                /* special case for tuples       */
  1564.     alts = singleton(mkAltText(0,t,tupleOf(t)));
  1565.  
  1566.     return singleton(mkBind("showsPrec",alts));
  1567. }
  1568.  
  1569. static Cell local mkAltText(line,h,a)    /* make alt for showsPrec eqn       */
  1570. Int  line;
  1571. Cell h;
  1572. Int  a; {
  1573.     List vs   = getDiVars(a+1);
  1574.     Cell d    = hd(vs);
  1575.     Cell pat  = h;
  1576.     List pats = NIL;
  1577.     while (vs=tl(vs), 0<a--)
  1578.     pat = ap(pat,hd(vs));
  1579.     pats = cons(d,cons(pat,NIL));
  1580.     return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat)));
  1581. }
  1582.  
  1583. static Cell showsOB, showsCM, showsSP, showsBQ, showsCB;
  1584. #define shows0   ap(nameShowsPrec,mkInt(0))
  1585. #define shows10  ap(nameShowsPrec,mkInt(10))
  1586.  
  1587. static Cell local showsPrecRhs(d,pat)    /* build a rhs for showsPrec for a */
  1588. Cell d, pat; {                /* given pattern, pat           */
  1589.     Cell h = getHead(pat);
  1590.  
  1591.     if (isNull(showsOB)) {        /* check constants installed       */
  1592.     showsOB = ap(nameComp,ap(nameCons,mkChar('(')));
  1593.     showsCM = ap(nameComp,ap(nameCons,mkChar(',')));
  1594.     showsSP = ap(nameComp,ap(nameCons,mkChar(' ')));
  1595.     showsBQ = ap(nameComp,ap(nameCons,mkChar('`')));
  1596.     showsCB = ap(nameCons,mkChar(')'));
  1597.     }
  1598.  
  1599.     if (isTuple(h)) {
  1600.     /* To display a tuple:
  1601.      *    showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
  1602.      *                  showChar ',' . showsPrec 0 b .
  1603.      *                  showChar ',' . showsPrec 0 c .
  1604.      *                  showChar ',' . showsPrec 0 d .
  1605.      *                  showChar ')'
  1606.      */
  1607.     Int  i   = tupleOf(h);
  1608.     Cell rhs = showsCB;
  1609.     for (; i>1; --i) {
  1610.             rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
  1611.         pat = fun(pat);
  1612.     }
  1613.     return ap(showsOB,ap2(nameComp,ap(shows0,arg(pat)),rhs));
  1614.     }
  1615.     else if (name(h).arity==0)
  1616.     /* To display a nullary constructor:
  1617.      *    showsPrec d Foo = showString "Foo"
  1618.      */
  1619.     return ap(nameApp,mkStr(name(h).text));
  1620.     else {
  1621.     Syntax s = syntaxOf(name(h).text);
  1622.     if (name(h).arity==2 && assocOf(s)!=APPLIC) {
  1623.         /* For a binary constructor with prec p:
  1624.          * showsPrec d (a :* b) = showParen (d > p)
  1625.          *                (showsPrec lp a . showChar ' ' .
  1626.          *                 showsString s  . showChar ' ' .
  1627.          *                 showsPrec rp b)
  1628.          */
  1629.         Int  p   = precOf(s);
  1630.         Int  lp  = (assocOf(s)==LEFT_ASS)  ? p : (p+1);
  1631.         Int  rp  = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
  1632.             Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
  1633.         if (defaultSyntax(name(h).text)==APPLIC)
  1634.         rhs = ap(showsBQ,
  1635.              ap2(nameComp,
  1636.                  ap(nameApp,mkStr(name(h).text)),
  1637.                  ap(showsBQ,rhs)));
  1638.         else
  1639.         rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
  1640.  
  1641.             rhs = ap2(nameComp,
  1642.               ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
  1643.               ap(showsSP,rhs));
  1644.         rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
  1645.         return rhs;
  1646.     }
  1647.     else {
  1648.         /* To display a non-nullary constructor with applicative syntax:
  1649.          *    showsPrec d (Foo x y) = showParen (d>=10)
  1650.          *                   (showString "Foo" .
  1651.          *                    showChar ' ' . showsPrec 10 x .
  1652.          *                    showChar ' ' . showsPrec 10 y)
  1653.          */
  1654.         Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
  1655.         for (pat=fun(pat); isAp(pat); pat=fun(pat))
  1656.         rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
  1657.         rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
  1658.         rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
  1659.         return rhs;
  1660.     }
  1661.     }
  1662. }
  1663. #undef  shows10
  1664. #undef  shows0
  1665.  
  1666. /* --------------------------------------------------------------------------
  1667.  * Primitive definitions are usually only included in the first script
  1668.  * file read - the prelude.  A primitive definition associates a variable
  1669.  * name with a string (which identifies a built-in primitive) and a type.
  1670.  * ------------------------------------------------------------------------*/
  1671.  
  1672. Void primDefn(line,prims,type)        /* Handle primitive definitions       */
  1673. Cell line;
  1674. List prims;
  1675. Cell type; {
  1676.     primDefns = cons(triple(line,prims,type),primDefns);
  1677. }
  1678.  
  1679. static Void local checkPrimDefn(p)    /* Check primitive definition       */
  1680. Triple p; {
  1681.     Int  line  = intOf(fst3(p));
  1682.     List prims = snd3(p);
  1683.     Type type  = thd3(p);
  1684.     type = checkSigType(line,"primitive definition",fst(hd(prims)),type);
  1685.     for (; nonNull(prims); prims=tl(prims))
  1686.     addNewPrim(line,
  1687.            textOf(fst(hd(prims))),
  1688.            textToStr(textOf(snd(hd(prims)))),
  1689.            type);
  1690. }
  1691.  
  1692. static Void local addNewPrim(l,vn,s,t)    /* make binding of variable vn to  */
  1693. Int    l;                /* primitive function referred       */
  1694. Text   vn;                /* to by s, with given type t       */
  1695. String s;
  1696. Cell   t;{
  1697.     Name n = findName(vn);
  1698.  
  1699.     if (isNull(n))
  1700.         n = newName(vn);
  1701.     else if (name(n).defn!=PREDEFINED) {
  1702.         ERROR(l) "Redeclaration of primitive \"%s\"", textToStr(vn)
  1703.         EEND;
  1704.     }
  1705.  
  1706.     addPrim(l,n,s,t);
  1707. }
  1708.  
  1709. /* --------------------------------------------------------------------------
  1710.  * Default definitions; only one default definition is permitted in a
  1711.  * given script file.  If no default is supplied, then a standard system
  1712.  * default will be used where necessary.
  1713.  * ------------------------------------------------------------------------*/
  1714.  
  1715. Void defaultDefn(line,defs)        /* Handle default types definition */
  1716. Int  line;
  1717. List defs; {
  1718.     if (defaultLine!=0) {
  1719.         ERROR(line) "Multiple default declarations are not permitted in" ETHEN
  1720.         ERRTEXT     "a single script file.\n"
  1721.     EEND;
  1722.     }
  1723.     defaultDefns = defs;
  1724.     defaultLine  = line;
  1725. }
  1726.  
  1727. static Void local checkDefaultDefns() {    /* check that default types are       */
  1728.     List  ds = NIL;            /* well-kinded instances of Num       */
  1729.  
  1730.     if (defaultLine!=0) {
  1731.     map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
  1732.     kindDefaults(defaultLine,defaultDefns);
  1733.     mapOver(fullExpand,defaultDefns);
  1734.     }
  1735.  
  1736.     if (isNull(classNum))
  1737.     classNum = findClass(findText("Num"));
  1738.  
  1739.     for (ds=defaultDefns; nonNull(ds); ds=tl(ds))
  1740.     if (!mtInst(classNum,hd(ds))) {
  1741.         ERROR(defaultLine)
  1742.         "Default types must be instances of the Num class"
  1743.         EEND;
  1744.     }
  1745. }
  1746.  
  1747. /* --------------------------------------------------------------------------
  1748.  * Static analysis of patterns:
  1749.  *
  1750.  * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
  1751.  * makes the following checks:
  1752.  *  - Patterns are well formed (according to pattern syntax), including the
  1753.  *    special case of (n+k) patterns.
  1754.  *  - All constructor functions have been defined and are used with the
  1755.  *    correct number of arguments.
  1756.  *  - No variable name is used more than once in a pattern.
  1757.  *
  1758.  * The list of pattern variables occuring in each pattern is accumulated in
  1759.  * a global list `patVars', which must be initialised to NIL at appropriate
  1760.  * points before using these routines to check for valid patterns.  This
  1761.  * mechanism enables the pattern checking routine to be mapped over a list
  1762.  * of patterns, ensuring that no variable occurs more than once in the
  1763.  * complete pattern list (as is required on the lhs of a function defn).
  1764.  * ------------------------------------------------------------------------*/
  1765.  
  1766. static List patVars;               /* list of vars bound in pattern    */
  1767.  
  1768. static Cell local checkPat(line,p)     /* Check valid pattern syntax       */
  1769. Int  line;
  1770. Cell p; {
  1771.     switch (whatIs(p)) {
  1772.     case VARIDCELL :
  1773.     case VAROPCELL : addPatVar(line,p);
  1774.              break;
  1775.  
  1776.     case AP        : return checkMaybeCnkPat(line,p);
  1777.  
  1778.     case NAME      :
  1779.     case CONIDCELL :
  1780.     case CONOPCELL : return checkApPat(line,0,p);
  1781.  
  1782. #if BIGNUMS
  1783.     case ZERONUM   :
  1784.     case POSNUM    :
  1785.     case NEGNUM    :
  1786. #endif
  1787.     case UNIT      :
  1788.     case WILDCARD  :
  1789.     case STRCELL   :
  1790.     case CHARCELL  :
  1791.     case INTCELL   : break;
  1792.  
  1793.     case ASPAT     : addPatVar(line,fst(snd(p)));
  1794.              snd(snd(p)) = checkPat(line,snd(snd(p)));
  1795.              break;
  1796.  
  1797.     case LAZYPAT   : snd(p) = checkPat(line,snd(p));
  1798.              break;
  1799.  
  1800.     case FINLIST   : map1Over(checkPat,line,snd(p));
  1801.              break;
  1802.  
  1803.     default        : ERROR(line) "Illegal pattern syntax"
  1804.              EEND;
  1805.     }
  1806.     return p;
  1807. }
  1808.  
  1809. static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with   */
  1810. Int  l;                       /* the possibility of n+k pattern   */
  1811. Cell p; {
  1812. #if NPLUSK
  1813.     Cell h = getHead(p);
  1814.  
  1815.     if (argCount==2 && isVar(h) && textOf(h)==textPlus) {    /* n+k       */
  1816.     Cell v = arg(fun(p));
  1817.     if (!isInt(arg(p))) {
  1818.         ERROR(l) "Second argument in (n+k) pattern must be an integer"
  1819.         EEND;
  1820.     }
  1821.     if (intOf(arg(p))<=0) {
  1822.         ERROR(l) "Integer k in (n+k) pattern must be > 0"
  1823.         EEND;
  1824.     }
  1825.     fst(fun(p))     = ADDPAT;
  1826.     intValOf(fun(p)) = intOf(arg(p));
  1827.     arg(p)         = checkPat(l,v);
  1828.     return p;
  1829.     }
  1830. #endif
  1831.     return checkApPat(l,0,p);
  1832. }
  1833.  
  1834. static Cell local checkApPat(line,args,p)
  1835. Int  line;                   /* check validity of application    */
  1836. Int  args;                   /* of constructor to arguments       */
  1837. Cell p; {
  1838.     switch (whatIs(p)) {
  1839.     case AP        : fun(p) = checkApPat(line,args+1,fun(p));
  1840.              arg(p) = checkPat(line,arg(p));
  1841.              break;
  1842.  
  1843.     case TUPLE     : if (tupleOf(p)!=args) {
  1844.                  ERROR(line) "Illegal tuple pattern"
  1845.                  EEND;
  1846.              }
  1847.              break;
  1848.  
  1849.     case CONIDCELL :
  1850.     case CONOPCELL : p = conDefined(line,textOf(p));
  1851.              checkCfunArgs(line,p,args);
  1852.              break;
  1853.  
  1854.     case NAME      : checkIsCfun(line,p);
  1855.              checkCfunArgs(line,p,args);
  1856.              break;
  1857.  
  1858.     default        : ERROR(line) "Illegal pattern syntax"
  1859.              EEND;
  1860.     }
  1861.     return p;
  1862. }
  1863.  
  1864. static Void local addPatVar(line,v)    /* add variable v to list of vars   */
  1865. Int  line;                   /* in current pattern, checking for */
  1866. Cell v; {                   /* repeated variables.           */
  1867.      Text t = textOf(v);
  1868.      List p = NIL;
  1869.      List n = patVars;
  1870.  
  1871.      for (; nonNull(n); p=n, n=tl(n))
  1872.      if (textOf(hd(n))==t) {
  1873.          ERROR(line) "Repeated variable \"%s\" in pattern",
  1874.              textToStr(t)
  1875.          EEND;
  1876.      }
  1877.  
  1878.      if (isNull(p))
  1879.      patVars = cons(v,NIL);
  1880.      else
  1881.      tl(p)     = cons(v,NIL);
  1882. }
  1883.  
  1884. static Name local conDefined(line,t)   /* check that t is the name of a    */
  1885. Int line;                   /* previously defined constructor   */
  1886. Text t; {                   /* function.               */
  1887.     Cell c=findName(t);
  1888.     if (isNull(c)) {
  1889.     ERROR(line) "Undefined constructor function \"%s\"", textToStr(t)
  1890.     EEND;
  1891.     }
  1892.     checkIsCfun(line,c);
  1893.     return c;
  1894. }
  1895.  
  1896. static Void local checkIsCfun(line,c)  /* Check that c is a constructor fn */
  1897. Int  line;
  1898. Cell c; {
  1899.     if (name(c).defn!=CFUN) {
  1900.     ERROR(line) "\"%s\" is not a constructor function",
  1901.             textToStr(name(c).text)
  1902.     EEND;
  1903.     }
  1904. }
  1905.  
  1906. static Void local checkCfunArgs(line,c,args)
  1907. Int  line;                   /* Check constructor applied with   */
  1908. Cell c;                    /* correct number of arguments       */
  1909. Int  args; {
  1910.     if (name(c).arity!=args) {
  1911.     ERROR(line) "Constructor function \"%s\" needs %d args in pattern",
  1912.             textToStr(name(c).text), name(c).arity
  1913.     EEND;
  1914.     }
  1915. }
  1916.  
  1917. /* --------------------------------------------------------------------------
  1918.  * Maintaining lists of bound variables and local definitions, for
  1919.  * dependency and scope analysis.
  1920.  * ------------------------------------------------------------------------*/
  1921.  
  1922. static List bounds;               /* list of lists of bound vars       */
  1923. static List bindings;               /* list of lists of binds in scope  */
  1924. static List depends;               /* list of lists of dependents       */
  1925.  
  1926. #define saveBvars()     hd(bounds)    /* list of bvars in current scope   */
  1927. #define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables  */
  1928.  
  1929. static Cell local bindPat(line,p)      /* add new bound vars for pattern   */
  1930. Int  line;
  1931. Cell p; {
  1932.     patVars    = NIL;
  1933.     p           = checkPat(line,p);
  1934.     hd(bounds) = revOnto(patVars,hd(bounds));
  1935.     return p;
  1936. }
  1937.  
  1938. static Void local bindPats(line,ps)    /* add new bound vars for patterns  */
  1939. Int  line;
  1940. List ps; {
  1941.     patVars    = NIL;
  1942.     map1Over(checkPat,line,ps);
  1943.     hd(bounds) = revOnto(patVars,hd(bounds));
  1944. }
  1945.  
  1946. /* --------------------------------------------------------------------------
  1947.  * Before processing value and type signature declarations, all data and
  1948.  * type definitions have been processed so that:
  1949.  * - all valid type constructors (with their arities) are known.
  1950.  * - all valid constructor functions (with their arities and types) are
  1951.  *   known.
  1952.  *
  1953.  * The result of parsing a list of value declarations is a list of Eqns:
  1954.  *     Eqn ::= (SIGDECL,(Line,[Var],type))  |  (Expr,Rhs)
  1955.  * The ordering of the equations in this list is the reverse of the original
  1956.  * ordering in the script parsed.  This is a consequence of the structure of
  1957.  * the parser ... but also turns out to be most convenient for the static
  1958.  * analysis.
  1959.  *
  1960.  * As the first stage of the static analysis of value declarations, each
  1961.  * list of Eqns is converted to a list of Bindings.  As part of this
  1962.  * process:
  1963.  * - The ordering of the list of Bindings produced is the same as in the
  1964.  *   original script.
  1965.  * - When a variable (function) is defined over a number of lines, all
  1966.  *   of the definitions should appear together and each should give the
  1967.  *   same arity to the variable being defined.
  1968.  * - No variable can have more than one definition.
  1969.  * - For pattern bindings:
  1970.  *   - Each lhs is a valid pattern/function lhs, all constructor functions
  1971.  *     have been defined and are used with the correct number of arguments.
  1972.  *   - Each lhs contains no repeated pattern variables.
  1973.  *   - Each equation defines at least one variable (e.g. True = False is
  1974.  *     not allowed).
  1975.  * - Types appearing in type signatures are well formed:
  1976.  *    - Type constructors used are defined and used with correct number
  1977.  *    of arguments.
  1978.  *    - type variables are replaced by offsets, type constructor names
  1979.  *    by Tycons.
  1980.  * - Every variable named in a type signature declaration is defined by
  1981.  *   one or more equations elsewhere in the script.
  1982.  * - No variable has more than one type declaration.
  1983.  *
  1984.  * ------------------------------------------------------------------------*/
  1985.  
  1986. #define bindingType(b) fst(snd(b))     /* type (or types) for binding       */
  1987. #define fbindAlts(b)   snd(snd(b))     /* alternatives for function binding*/
  1988.  
  1989. static List local extractSigdecls(es)  /* extract the SIGDECLS from list   */
  1990. List es; {                   /* of equations               */
  1991.     List sigDecls  = NIL;           /* :: [(Line,[Var],Type)]       */
  1992.  
  1993.     for(; nonNull(es); es=tl(es))
  1994.     if (fst(hd(es))==SIGDECL)             /* type-declaration?  */
  1995.         sigDecls = cons(snd(hd(es)),sigDecls);   /* discard SIGDECL tag*/
  1996.  
  1997.     return sigDecls;
  1998. }
  1999.  
  2000. static List local extractBindings(es)  /* extract untyped bindings from    */
  2001. List es; {                   /* given list of equations       */
  2002.     Cell lastVar   = NIL;           /* = var def'd in last eqn (if any) */
  2003.     Int  lastArity = 0;            /* = number of args in last defn    */
  2004.     List bs       = NIL;           /* :: [Binding]               */
  2005.  
  2006.     for(; nonNull(es); es=tl(es)) {
  2007.     Cell e = hd(es);
  2008.  
  2009.     if (fst(e)!=SIGDECL) {
  2010.         Int  line     = rhsLine(snd(e));
  2011.         Cell lhsHead = getHead(fst(e));
  2012.  
  2013.         switch (whatIs(lhsHead)) {
  2014.         case VARIDCELL :
  2015.         case VAROPCELL : {              /* function-binding? */
  2016.             Cell newAlt = pair(getArgs(fst(e)), snd(e));
  2017.             if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
  2018.             if (argCount!=lastArity) {
  2019.                 ERROR(line)
  2020.                 "Equations give different arities for \"%s\"",
  2021.                 textToStr(textOf(lhsHead))
  2022.                 EEND;
  2023.             }
  2024.             fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
  2025.             }
  2026.             else {
  2027.             lastVar   = lhsHead;
  2028.             lastArity = argCount;
  2029.             notDefined(line,bs,lhsHead);
  2030.             bs      = cons(pair(lhsHead,
  2031.                           pair(NIL,
  2032.                            singleton(newAlt))),
  2033.                      bs);
  2034.             }
  2035.         }
  2036.         break;
  2037.  
  2038.         case CONOPCELL :
  2039.         case CONIDCELL :
  2040.         case FINLIST   :
  2041.         case TUPLE     :
  2042.         case UNIT      :
  2043.         case ASPAT     : lastVar = NIL;       /* pattern-binding?  */
  2044.                  patVars = NIL;
  2045.                  fst(e)  = checkPat(line,fst(e));
  2046.                  if (isNull(patVars)) {
  2047.                      ERROR(line)
  2048.                       "No variables defined in lhs pattern"
  2049.                      EEND;
  2050.                  }
  2051.                  map2Proc(notDefined,line,bs,patVars);
  2052.                  bs = cons(pair(patVars,pair(NIL,e)),bs);
  2053.                  break;
  2054.  
  2055.         default        : ERROR(line) "Improper left hand side"
  2056.                  EEND;
  2057.         }
  2058.     }
  2059.     }
  2060.     return bs;
  2061. }
  2062.  
  2063. static List local eqnsToBindings(es)   /* Convert list of equations to list*/
  2064. List es; {                   /* of typed bindings           */
  2065.     List bs = extractBindings(es);
  2066.     map1Proc(addSigDecl,bs,extractSigdecls(es));
  2067.     return bs;
  2068. }
  2069.  
  2070. static Void local notDefined(line,bs,v)/* check if name already defined in */
  2071. Int  line;                   /* list of bindings           */
  2072. List bs;
  2073. Cell v; {
  2074.     if (nonNull(findBinding(textOf(v),bs))) {
  2075.     ERROR(line) "\"%s\" multiply defined", textToStr(textOf(v))
  2076.     EEND;
  2077.     }
  2078. }
  2079.  
  2080. static Cell local findBinding(t,bs)    /* look for binding for variable t  */
  2081. Text t;                    /* in list of bindings bs       */
  2082. List bs; {
  2083.     for (; nonNull(bs); bs=tl(bs))
  2084.     if (isVar(fst(hd(bs)))) {              /* function-binding? */
  2085.         if (textOf(fst(hd(bs)))==t)
  2086.         return hd(bs);
  2087.     }
  2088.     else if (nonNull(varIsMember(t,fst(hd(bs))))) /* pattern-binding?  */
  2089.         return hd(bs);
  2090.     return NIL;
  2091. }
  2092.  
  2093. static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
  2094. List bs;                   /* :: [Binding]               */
  2095. Cell sigDecl; {                /* :: (Line,[Var],Type)           */
  2096.     Int  line = intOf(fst3(sigDecl));
  2097.     Cell vs   = snd3(sigDecl);
  2098.     Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
  2099.  
  2100.     map3Proc(setType,line,type,bs,vs);
  2101. }
  2102.  
  2103. static Void local setType(line,type,bs,v)
  2104. Int  line;                   /* Set type of variable           */
  2105. Cell type;
  2106. Cell v;
  2107. List bs; {
  2108.     Text t = textOf(v);
  2109.     Cell b = findBinding(t,bs);
  2110.  
  2111.     if (isNull(b)) {
  2112.     ERROR(line) "Type declaration for variable \"%s\" with no body",
  2113.             textToStr(t)
  2114.     EEND;
  2115.     }
  2116.  
  2117.     if (isVar(fst(b))) {                  /* function-binding? */
  2118.     if (isNull(bindingType(b))) {
  2119.         bindingType(b) = type;
  2120.         return;
  2121.     }
  2122.     }
  2123.     else {                          /* pattern-binding?  */
  2124.     List vs = fst(b);
  2125.     List ts = bindingType(b);
  2126.  
  2127.     if (isNull(ts))
  2128.         bindingType(b) = ts = copy(length(vs),NIL);
  2129.  
  2130.     while (nonNull(vs) && t!=textOf(hd(vs))) {
  2131.         vs = tl(vs);
  2132.         ts = tl(ts);
  2133.     }
  2134.  
  2135.     if (nonNull(vs) && isNull(hd(ts))) {
  2136.         hd(ts) = type;
  2137.         return;
  2138.     }
  2139.     }
  2140.  
  2141.     ERROR(line) "Repeated type declaration for \"%s\"", textToStr(t)
  2142.     EEND;
  2143. }
  2144.  
  2145. /* --------------------------------------------------------------------------
  2146.  * To facilitate dependency analysis, lists of bindings are temporarily
  2147.  * augmented with an additional field, which is used in two ways:
  2148.  * - to build the `adjacency lists' for the dependency graph. Represented by
  2149.  *   a list of pointers to other bindings in the same list of bindings.
  2150.  * - to hold strictly positive integer values (depth first search numbers) of
  2151.  *   elements `on the stack' during the strongly connected components search
  2152.  *   algorithm, or a special value mkInt(0), once the binding has been added
  2153.  *   to a particular strongly connected component.
  2154.  *
  2155.  * Using this extra field, the type of each list of declarations during
  2156.  * dependency analysis is [Binding'] where:
  2157.  *
  2158.  *    Binding' ::= (Var, (Dep, (Type, [Alt])))          -- function binding
  2159.  *        |  ([Var], (Dep, (Type, (Pat,Rhs))))  -- pattern binding
  2160.  *
  2161.  * ------------------------------------------------------------------------*/
  2162.  
  2163. #define depVal(d) (fst(snd(d)))        /* Access to dependency information */
  2164.  
  2165. static List local dependencyAnal(bs)   /* Separate lists of bindings into  */
  2166. List bs; {                   /* mutually recursive groups in       */
  2167.                        /* order of dependency           */
  2168.  
  2169.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  2170.     mapProc(depBinding,bs);           /* find dependents of each binding  */
  2171.     bs = bscc(bs);               /* sort to strongly connected comps */
  2172.     mapProc(remDepField,bs);           /* remove dependency info field       */
  2173.     return bs;
  2174. }
  2175.  
  2176. static List local topDependAnal(bs)    /* Like dependencyAnal(), but at    */
  2177. List bs; {                   /* top level, reporting on progress */
  2178.     List xs;
  2179.     Int  i = 0;
  2180.  
  2181.     setGoal("Dependency analysis",(Target)(length(bs)));
  2182.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  2183.     for (xs=bs; nonNull(xs); xs=tl(xs)) {
  2184.     depBinding(hd(xs));
  2185.     soFar((Target)(i++));
  2186.     }
  2187.     bs = bscc(bs);               /* sort to strongly connected comps */
  2188.     mapProc(remDepField,bs);           /* remove dependency info field       */
  2189.     done();
  2190.     return bs;
  2191. }
  2192.  
  2193. static Void local addDepField(b)       /* add extra field to binding to    */
  2194. Cell b; {                   /* hold list of dependents       */
  2195.     snd(b) = pair(NIL,snd(b));
  2196. }
  2197.  
  2198. static Void local remDepField(bs)      /* remove dependency field from       */
  2199. List bs; {                   /* list of bindings           */
  2200.     mapProc(remDepField1,bs);
  2201. }
  2202.  
  2203. static Void local remDepField1(b)      /* remove dependency field from       */
  2204. Cell b; {                   /* single binding           */
  2205.     snd(b) = snd(snd(b));
  2206. }
  2207.  
  2208. static Void local clearScope() {       /* initialise dependency scoping    */
  2209.     bounds   = NIL;
  2210.     bindings = NIL;
  2211.     depends  = NIL;
  2212. }
  2213.  
  2214. static Void local withinScope(bs)      /* enter scope of bindings bs       */
  2215. List bs; {
  2216.     bounds   = cons(NIL,bounds);
  2217.     bindings = cons(bs,bindings);
  2218.     depends  = cons(NIL,depends);
  2219. }
  2220.  
  2221. static Void local leaveScope() {       /* leave scope of last withinScope  */
  2222.     bounds   = tl(bounds);
  2223.     bindings = tl(bindings);
  2224.     depends  = tl(depends);
  2225. }
  2226.  
  2227. /* --------------------------------------------------------------------------
  2228.  * As a side effect of the dependency analysis we also make the following
  2229.  * checks:
  2230.  * - Each lhs is a valid pattern/function lhs, all constructor functions
  2231.  *   have been defined and are used with the correct number of arguments.
  2232.  * - No lhs contains repeated pattern variables.
  2233.  * - Expressions used on the rhs of an eqn should be well formed.  This
  2234.  *   includes:
  2235.  *   - Checking for valid patterns (including repeated vars) in lambda,
  2236.  *     case, and list comprehension expressions.
  2237.  *   - Recursively checking local lists of equations.
  2238.  * - No free (i.e. unbound) variables are used in the declaration list.
  2239.  * ------------------------------------------------------------------------*/
  2240.  
  2241. static Void local depBinding(b)        /* find dependents of binding       */
  2242. Cell b; {
  2243.     Cell defpart = snd(snd(snd(b)));   /* definition part of binding       */
  2244.  
  2245.     hd(depends) = NIL;
  2246.  
  2247.     if (isVar(fst(b))) {           /* function-binding?           */
  2248.     mapProc(depAlt,defpart);
  2249.     }
  2250.     else {                   /* pattern-binding?           */
  2251.     depRhs(snd(defpart));
  2252.     }
  2253.  
  2254.     depVal(b) = hd(depends);
  2255. }
  2256.  
  2257. static Void local depDefaults(c)       /* dependency analysis on defaults  */
  2258. Class c; {                             /* from class definition            */
  2259.     depClassBindings(class(c).defaults);
  2260. }
  2261.  
  2262. static Void local depInsts(in)         /* dependency analysis on instance  */
  2263. Inst in; {                             /* bindings                         */
  2264.     depClassBindings(inst(in).implements);
  2265. }
  2266.  
  2267. static Void local depClassBindings(bs) /* dependency analysis on list of   */
  2268. List bs; {                             /* bindings, possibly containing    */
  2269.     for (; nonNull(bs); bs=tl(bs))     /* NIL bindings ...                 */
  2270.         if (nonNull(hd(bs)))           /* No need to add extra field for   */
  2271.             mapProc(depAlt,name(hd(bs)).defn); /* dependency information.. */
  2272. }
  2273.  
  2274. static Void local depAlt(a)           /* find dependents of alternative   */
  2275. Cell a; {
  2276.     List origBvars = saveBvars();      /* save list of bound variables       */
  2277.     bindPats(rhsLine(snd(a)),fst(a));  /* add new bound vars for patterns  */
  2278.     depRhs(snd(a));               /* find dependents of rhs       */
  2279.     restoreBvars(origBvars);           /* restore original list of bvars   */
  2280. }
  2281.  
  2282. static Void local depRhs(r)           /* find dependents of rhs       */
  2283. Cell r; {
  2284.     switch (whatIs(r)) {
  2285.     case GUARDED : mapProc(depGuard,snd(r));
  2286.                break;
  2287.  
  2288.     case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
  2289.                withinScope(fst(snd(r)));
  2290.                fst(snd(r)) = dependencyAnal(fst(snd(r)));
  2291.                hd(depends) = fst(snd(r));
  2292.                depRhs(snd(snd(r)));
  2293.                leaveScope();
  2294.                break;
  2295.  
  2296.     default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
  2297.                break;
  2298.     }
  2299. }
  2300.  
  2301. static Void local depGuard(g)           /* find dependents of single guarded*/
  2302. Cell g; {                   /* expression               */
  2303.     depPair(intOf(fst(g)),snd(g));
  2304. }
  2305.  
  2306. static Cell local depExpr(line,e)      /* find dependents of expression    */
  2307. Int  line;
  2308. Cell e; {
  2309.     switch (whatIs(e)) {
  2310.  
  2311.     case VARIDCELL    :
  2312.     case VAROPCELL    : return depVar(line,e);
  2313.  
  2314.     case CONIDCELL    :
  2315.     case CONOPCELL    : return conDefined(line,textOf(e));
  2316.  
  2317.     case AP     : depPair(line,e);
  2318.               break;
  2319.  
  2320. #if BIGNUMS
  2321.     case ZERONUM    :
  2322.     case POSNUM    :
  2323.     case NEGNUM    :
  2324. #endif
  2325.     case NAME    :
  2326.     case UNIT    :
  2327.     case TUPLE    :
  2328.     case STRCELL    :
  2329.     case CHARCELL    :
  2330.     case FLOATCELL  :
  2331.     case INTCELL    : break;
  2332.  
  2333.     case COND    : depTriple(line,snd(e));
  2334.               break;
  2335.  
  2336.     case FINLIST    : map1Over(depExpr,line,snd(e));
  2337.               break;
  2338.  
  2339.     case LETREC    : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
  2340.               withinScope(fst(snd(e)));
  2341.               fst(snd(e)) = dependencyAnal(fst(snd(e)));
  2342.               hd(depends) = fst(snd(e));
  2343.               snd(snd(e)) = depExpr(line,snd(snd(e)));
  2344.               leaveScope();
  2345.               break;
  2346.  
  2347.     case LAMBDA    : depAlt(snd(e));
  2348.               break;
  2349.  
  2350.     case COMP    : depComp(line,snd(e),snd(snd(e)));
  2351.               break;
  2352.  
  2353. #if IO_MONAD
  2354.     case RUNST    : snd(e) = depExpr(line,snd(e));
  2355.               break;
  2356. #endif
  2357.  
  2358.     case ESIGN    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  2359.               snd(snd(e)) = checkSigType(line,
  2360.                              "expression",
  2361.                              fst(snd(e)),
  2362.                              snd(snd(e)));
  2363.               break;
  2364.  
  2365.     case CASE    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  2366.               map1Proc(depCaseAlt,line,snd(snd(e)));
  2367.               break;
  2368.  
  2369.     case ASPAT    : ERROR(line) "Illegal `@' in expression"
  2370.               EEND;
  2371.  
  2372.     case LAZYPAT    : ERROR(line) "Illegal `~' in expression"
  2373.               EEND;
  2374.  
  2375.     case WILDCARD    : ERROR(line) "Illegal `_' in expression"
  2376.               EEND;
  2377.  
  2378.     default     : internal("in depExpr");
  2379.    }
  2380.    return e;
  2381. }
  2382.  
  2383. static Void local depPair(line,e)    /* find dependents of pair of exprs*/
  2384. Int  line;
  2385. Cell e; {
  2386.     fst(e) = depExpr(line,fst(e));
  2387.     snd(e) = depExpr(line,snd(e));
  2388. }
  2389.  
  2390. static Void local depTriple(line,e)    /* find dependents of triple exprs */
  2391. Int  line;
  2392. Cell e; {
  2393.     fst3(e) = depExpr(line,fst3(e));
  2394.     snd3(e) = depExpr(line,snd3(e));
  2395.     thd3(e) = depExpr(line,thd3(e));
  2396. }
  2397.  
  2398. static Void local depComp(l,e,qs)    /* find dependents of comprehension*/
  2399. Int  l;
  2400. Cell e;
  2401. List qs; {
  2402.     if (isNull(qs))
  2403.     fst(e) = depExpr(l,fst(e));
  2404.     else {
  2405.     Cell q   = hd(qs);
  2406.     List qs1 = tl(qs);
  2407.     switch (whatIs(q)) {
  2408.         case FROMQUAL : {   List origBvars = saveBvars();
  2409.                                 snd(snd(q))    = depExpr(l,snd(snd(q)));
  2410.                 fst(snd(q))    = bindPat(l,fst(snd(q)));
  2411.                 depComp(l,e,qs1);
  2412.                 restoreBvars(origBvars);
  2413.                 }
  2414.                 break;
  2415.  
  2416.         case QWHERE   : snd(q)      = eqnsToBindings(snd(q));
  2417.                 withinScope(snd(q));
  2418.                             snd(q)      = dependencyAnal(snd(q));
  2419.                 hd(depends) = snd(q);
  2420.                 depComp(l,e,qs1);
  2421.                 leaveScope();
  2422.                 break;
  2423.  
  2424.         case BOOLQUAL : snd(q) = depExpr(l,snd(q));
  2425.                 depComp(l,e,qs1);
  2426.                 break;
  2427.     }
  2428.     }
  2429. }
  2430.  
  2431. static Void local depCaseAlt(line,a)    /* find dependents of case altern. */
  2432. Int  line;
  2433. Cell a; {
  2434.     List origBvars = saveBvars();    /* save list of bound variables       */
  2435.     fst(a) = bindPat(line,fst(a));    /* add new bound vars for patterns */
  2436.     depRhs(snd(a));            /* find dependents of rhs       */
  2437.     restoreBvars(origBvars);        /* restore original list of bvars  */
  2438. }
  2439.  
  2440. static Cell local depVar(line,e)    /* register occurrence of variable */
  2441. Int line;
  2442. Cell e; {
  2443.     List bounds1   = bounds;
  2444.     List bindings1 = bindings;
  2445.     List depends1  = depends;
  2446.     Text t       = textOf(e);
  2447.     Cell n;
  2448.  
  2449.     while (nonNull(bindings1)) {
  2450.     n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
  2451.     if (nonNull(n))
  2452.         return n;
  2453.  
  2454.     n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
  2455.     if (nonNull(n)) {
  2456.        if (!cellIsMember(n,hd(depends1)))
  2457.            hd(depends1) = cons(n,hd(depends1));
  2458.        return (isVar(fst(n)) ? fst(n) : e);
  2459.     }
  2460.  
  2461.     bounds1   = tl(bounds1);
  2462.     bindings1 = tl(bindings1);
  2463.     depends1  = tl(depends1);
  2464.     }
  2465.  
  2466.     if (isNull(n=findName(t))) {           /* check global definitions */
  2467.     ERROR(line) "Undefined variable \"%s\"", textToStr(t)
  2468.     EEND;
  2469.     }
  2470.  
  2471.     return n;
  2472. }
  2473.  
  2474. /* --------------------------------------------------------------------------
  2475.  * Several parts of this program require an algorithm for sorting a list
  2476.  * of values (with some added dependency information) into a list of strongly
  2477.  * connected components in which each value appears before its dependents.
  2478.  *
  2479.  * Each of these algorithms is obtained by parameterising a standard
  2480.  * algorithm in "scc.c" as shown below.
  2481.  * ------------------------------------------------------------------------*/
  2482.  
  2483. #define visited(d) (isInt(DEPENDS(d)))    /* binding already visited ?       */
  2484.  
  2485. static Cell daSccs = NIL;
  2486. static Int  daCount;
  2487.  
  2488. static Int local sccMin(x,y)           /* calculate minimum of x,y (unless */
  2489. Int x,y; {                   /* y is zero)               */
  2490.     return (x<=y || y==0) ? x : y;
  2491. }
  2492.  
  2493. #define  SCC2         tcscc        /* make scc algorithm for Tycons   */
  2494. #define  LOWLINK     tclowlink
  2495. #define  DEPENDS(c)      (isTycon(c) ? tycon(c).kind : class(c).sig)
  2496. #define  SETDEPENDS(c,v) if(isTycon(c)) tycon(c).kind=v; else class(c).sig=v
  2497. #include "scc.c"
  2498. #undef   SETDEPENDS
  2499. #undef     DEPENDS
  2500. #undef      LOWLINK
  2501. #undef     SCC2
  2502.  
  2503. #define  SCC         bscc        /* make scc algorithm for Bindings */
  2504. #define  LOWLINK     blowlink
  2505. #define  DEPENDS(t)     depVal(t)
  2506. #define  SETDEPENDS(c,v) depVal(c)=v
  2507. #include "scc.c"
  2508. #undef   SETDEPENDS
  2509. #undef     DEPENDS
  2510. #undef      LOWLINK
  2511. #undef     SCC
  2512.  
  2513. /* --------------------------------------------------------------------------
  2514.  * Main static analysis:
  2515.  * ------------------------------------------------------------------------*/
  2516.  
  2517. Void checkExp() {            /* Top level static check on Expr  */
  2518.     staticAnalysis(RESET);
  2519.     clearScope();            /* Analyse expression in the scope */
  2520.     withinScope(NIL);            /* of no local bindings           */
  2521.     inputExpr = depExpr(0,inputExpr);
  2522.     leaveScope();
  2523.     staticAnalysis(RESET);
  2524. }
  2525.  
  2526. Void checkDefns() {            /* Top level static analysis       */
  2527.     staticAnalysis(RESET);
  2528.  
  2529.     mapProc(checkTyconDefn,tyconDefns);    /* validate tycon definitions       */
  2530.     checkSynonyms(tyconDefns);        /* check synonym definitions       */
  2531.     mapProc(checkClassDefn,classDefns);    /* process class definitions       */
  2532.     mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds       */
  2533.     mapProc(addConstrs,tyconDefns);    /* add definitions for constr funs */
  2534.     mapProc(addMembers,classDefns);    /* add definitions for member funs */
  2535.     mapProc(visitClass,classDefns);    /* check class hierarchy       */
  2536.     tyconDefns = NIL;
  2537.  
  2538.     mapProc(checkPrimDefn,primDefns);    /* check primitive declarations       */
  2539.     primDefns = NIL;
  2540.  
  2541.     instDefns = rev(instDefns);        /* process instance definitions       */
  2542.     mapProc(checkInstDefn,instDefns);
  2543.  
  2544.     linkPreludeCore();            /* check for required items       */
  2545.  
  2546.     deriveContexts(derivedInsts);    /* check derived instances       */
  2547.     instDefns = appendOnto(instDefns,derivedInsts);
  2548.     mapProc(checkInstSC,instDefns);
  2549.     checkDefaultDefns();        /* validate default definitions       */
  2550.  
  2551.     mapProc(addRSsigdecls,typeInDefns);    /* add sigdecls for RESTRICTSYN       */
  2552.     valDefns = eqnsToBindings(valDefns);/* translate value equations       */
  2553.     map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound       */
  2554.     mapProc(allNoPrevDef,valDefns);    /* check against previous defns       */
  2555.  
  2556.     mapProc(checkTypeIn,typeInDefns);    /* check restricted synonym defns  */
  2557.  
  2558.     clearScope();
  2559.     withinScope(valDefns);
  2560.     valDefns = topDependAnal(valDefns); /* top level dependency ordering   */
  2561.     mapProc(depDefaults,classDefns);    /* dep. analysis on class defaults */
  2562.     mapProc(depInsts,instDefns);        /* dep. analysis on inst defns       */
  2563.     leaveScope();
  2564.  
  2565.     evalDefaults = defaultDefns;    /* Set defaults for evaluator       */
  2566.  
  2567.     staticAnalysis(RESET);
  2568. }
  2569.  
  2570. static Void local addRSsigdecls(pr)    /* add sigdecls from TYPE ... IN ..*/
  2571. Pair pr; {
  2572.     List vs = snd(pr);            /* get list of variables       */
  2573.     for (; nonNull(vs); vs=tl(vs)) {
  2574.     if (fst(hd(vs))==SIGDECL) {    /* find a sigdecl           */
  2575.         valDefns = cons(hd(vs),valDefns);    /* add to valDefns       */
  2576.         hd(vs)   = hd(snd3(snd(hd(vs))));    /* and replace with var       */
  2577.     }
  2578.     }
  2579. }
  2580.  
  2581. static Void local opDefined(bs,op)     /* check that op bound in bs       */
  2582. List bs;                 /* (or in current module for       */
  2583. Cell op; {                 /* constructor functions etc...)  */
  2584.     Name n;
  2585.  
  2586.     if (isNull(findBinding(textOf(op),bs))
  2587.            && (isNull(n=findName(textOf(op))) || !nameThisModule(n))) {
  2588.     ERROR(0) "No top level definition for operator symbol \"%s\"",
  2589.          textToStr(textOf(op))
  2590.     EEND;
  2591.     }
  2592. }
  2593.  
  2594. static Void local allNoPrevDef(b)     /* ensure no previous bindings for*/
  2595. Cell b; {                 /* variables in new binding       */
  2596.     if (isVar(fst(b)))
  2597.     noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
  2598.     else {
  2599.     Int line = rhsLine(snd(snd(snd(b))));
  2600.     map1Proc(noPrevDef,line,fst(b));
  2601.     }
  2602. }
  2603.  
  2604. static Void local noPrevDef(line,v)     /* ensure no previous binding for */
  2605. Int  line;                 /* new variable           */
  2606. Cell v; {
  2607.     Name n = findName(textOf(v));
  2608.  
  2609.     if (isNull(n)) {
  2610.     n            = newName(textOf(v));
  2611.     name(n).defn = PREDEFINED;
  2612.     }
  2613.     else if (name(n).defn!=PREDEFINED) {
  2614.     ERROR(line) "Attempt to redefine variable \"%s\"",
  2615.             textToStr(name(n).text)
  2616.     EEND;
  2617.     }
  2618.     name(n).line = line;
  2619. }
  2620.  
  2621. static Void local checkTypeIn(cvs)    /* Check that vars in restricted   */
  2622. Pair cvs; {                /* synonym are defined, and replace*/
  2623.     Tycon c  = fst(cvs);        /* vars with names           */
  2624.     List  vs = snd(cvs);
  2625.  
  2626.     for (; nonNull(vs); vs=tl(vs))
  2627.     if (isNull(findName(textOf(hd(vs))))) {
  2628.         ERROR(tycon(c).line)
  2629.         "No top level binding of \"%s\" for restricted synonym \"%s\"",
  2630.         textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
  2631.         EEND;
  2632.     }
  2633. }
  2634.  
  2635. /* --------------------------------------------------------------------------
  2636.  * Static Analysis control:
  2637.  * ------------------------------------------------------------------------*/
  2638.  
  2639. Void staticAnalysis(what)
  2640. Int what; {
  2641.     switch (what) {
  2642.     case INSTALL :
  2643.     case RESET   : showsOB        = NIL;
  2644.                showsCM        = NIL;
  2645.                showsSP        = NIL;
  2646.                showsBQ        = NIL;
  2647.                showsCB        = NIL;
  2648.                daSccs        = NIL;
  2649.                patVars        = NIL;
  2650.                bounds        = NIL;
  2651.                bindings        = NIL;
  2652.                depends      = NIL;
  2653.                tcDeps        = NIL;
  2654.                derivedInsts = NIL;
  2655.                diVars        = NIL;
  2656.                diNum        = 0;
  2657.                break;
  2658.  
  2659.     case MARK    : mark(daSccs);
  2660.                mark(patVars);
  2661.                mark(bounds);
  2662.                mark(bindings);
  2663.                mark(depends);
  2664.                mark(tcDeps);
  2665.                mark(derivedInsts);
  2666.                mark(diVars);
  2667.                mark(showsOB);
  2668.                mark(showsCM);
  2669.                mark(showsSP);
  2670.                mark(showsBQ);
  2671.                mark(showsCB);
  2672.                break;
  2673.     }
  2674. }
  2675.  
  2676. /*-------------------------------------------------------------------------*/
  2677.