home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / static.c < prev    next >
Encoding:
Text File  |  1993-05-11  |  57.2 KB  |  1,073 lines  |  [TEXT/MPS ]
  1. urn vs;
  2. }
  3.  
  4. /* --------------------------------------------------------------------------
  5.  * Check for ambiguous types:
  6.  * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. static List local offsetTyvarsIn(t,vs)    /* add list of offset tyvars in t  */
  10. Type t;                    /* to list vs               */
  11. List vs; {
  12.     switch (whatIs(t)) {
  13.     case AP        : return offsetTyvarsIn(fun(t),offsetTyvarsIn(snd(t),vs));
  14.  
  15.     case OFFSET : if (cellIsMember(t,vs))
  16.               return vs;
  17.               else
  18.               return cons(t,vs);
  19.  
  20.     case QUAL   : return offsetTyvarsIn(snd(t),vs);
  21.  
  22.     default        : return vs;
  23.     }
  24. }
  25.  
  26. Bool isAmbiguous(type)            /* Determine whether type is       */
  27. Type type; {                /* ambiguous                */
  28.     if (isPolyType(type))
  29.     type = monoTypeOf(type);
  30.     if (whatIs(type)==QUAL) {        /* only qualified types can be       */
  31.     List tvps = offsetTyvarsIn(fst(snd(type)),NIL);    /* ambiguous       */
  32.     List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
  33.     while (nonNull(tvps) && cellIsMember(hd(tvps),tvts))
  34.         tvps = tl(tvps);
  35.     return nonNull(tvps);
  36.     }
  37.     return FALSE;
  38. }
  39.  
  40. Void ambigError(line,where,e,type)    /* produce error message for       */
  41. Int    line;                /* ambiguity               */
  42. String where;
  43. Cell   e;
  44. Type   type; {
  45.     ERROR(line) "Ambiguous type signature in %s", where ETHEN
  46.     ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
  47.     ERRTEXT "\n*** assigned to    : " ETHEN ERREXPR(e);
  48.     ERRTEXT "\n"
  49.     EEND;
  50. }
  51.  
  52. /* --------------------------------------------------------------------------
  53.  * Type expressions appearing in type signature declarations and expressions
  54.  * also require static checking, but unlike type expressions in type decls,
  55.  * they may introduce arbitrary new type variables.  The static analysis
  56.  * required here is:
  57.  *   - ensure that each type constructor is defined and used with the
  58.  *     correct number of arguments.
  59.  *   - replace type variables by offsets, constructor names by Tycons.
  60.  *   - ensure that type is well-kinded.
  61.  * ------------------------------------------------------------------------*/
  62.  
  63. static Type local checkSigType(line,where,e,type)
  64. Int    line;                   /* check validity of type expression*/
  65. String where;                   /* in explicit type signature       */
  66. Cell   e;
  67. Type   type; {
  68.     List tyvars = typeVarsIn(type,NIL);
  69.     Int  n      = length(tyvars);
  70.  
  71.     if (whatIs(type)==QUAL) {
  72.     map2Proc(depPredExp,line,tyvars,fst(snd(type)));
  73.     snd(snd(type)) = depTypeExp(line,tyvars,snd(snd(type)));
  74.  
  75.     if (isAmbiguous(type))
  76.         ambigError(line,where,e,type);
  77.     }
  78.     else
  79.     type = depTypeExp(line,tyvars,type);
  80.  
  81.     if (n>0) {
  82.     if (n>=num_offsets) {
  83.         ERROR(line) "Too many type variables (%d offsets) in %s\n", 
  84.                 num_offsets, where
  85.         EEND;
  86.     }
  87.     type = mkPolyType(mkSelect(n),type);
  88.     }
  89.  
  90.     kindSigType(line,type);        /* check that type is well-kinded  */
  91.     return type;
  92. }
  93.  
  94. /* --------------------------------------------------------------------------
  95.  * Static analysis of class declarations:
  96.  *
  97.  * Performed in a similar manner to that used for type declarations.
  98.  *
  99.  * The first part of the static analysis is performed as the declarations
  100.  * are read during parsing:
  101.  * - no previous definition for class
  102.  * - class name not previously used as a type constructor
  103.  * - make new entry in class table
  104.  * - determine arity of class
  105.  * - record line number of declaration
  106.  * - build list of classes defined in current script for use in later
  107.  *   stages of static analysis.
  108.  * ------------------------------------------------------------------------*/
  109.  
  110. Void classDefn(line,head,ms)           /* process new class definition       */
  111. Int  line;                   /* definition line number       */
  112. Cell head;                   /* class header :: ([Supers],Class) */
  113. List ms; {                   /* class definition body           */
  114.     Text  ct    = textOf(getHead(snd(head)));
  115.     Int   arity = argCount;
  116.     Class new   = findClass(ct);
  117.  
  118.     if (isNull(new)) {
  119.     if (nonNull(findTycon(ct))) {
  120.         ERROR(line) "\"%s\" used as both class and type constructor",
  121.             textToStr(ct)
  122.         EEND;
  123.     }
  124.     new = newClass(ct)p(cs)    /* validate mutually recursive gp  */
  125. List cs; {                /* of type classes           */
  126.     kindClassGroup(cs);
  127.     mapProc(addMembers,cs);
  128. }
  129.  
  130. static Void local addMembers(c)        /* Add definitions of member funs  */
  131. Class c; {
  132.     Int  mno   = 1;            /* member function number       */
  133.     List mfuns = NIL;            /* list of member functions       */
  134.     List ms    = class(c).members;
  135.  
  136.     for (; nonNull(ms); ms=tl(ms)) {    /* cycle through each sigdecl       */
  137.     Int  line = intOf(fst3(hd(ms)));
  138.     List vs   = rev(snd3(hd(ms)));
  139.     Type t    = thd3(hd(ms));
  140.     for (; nonNull(vs); vs=tl(vs))
  141.         mfuns = cons(newMember(line,mno++,hd(vs),t),mfuns);
  142.     }
  143.     class(c).members    = rev(mfuns);    /* save list of members           */
  144.     class(c).numMembers = length(class(c).members);
  145.     class(c).defaults   = classBindings("class",c,class(c).defaults);
  146. }
  147.  
  148. static Name local newMember(l,no,v,t)    /* Make definition for member fn   */
  149. Int  l;
  150. Int  no;
  151. Cell v;
  152. Type t; {
  153.     Name m = findName(textOf(v));
  154.  
  155.     if (isNull(m))
  156.     m = newName(textOf(v));
  157.     else if (name(m).defn!=PREDEFINED) {
  158.     ERROR(l) "Repeated definition for member function \"%s\"",
  159.          textToStr(name(m).text)
  160.     EEND;
  161.     }
  162.  
  163.     name(m).line   = l;
  164.     name(m).arity  = 1;
  165.     name(m).number = no;
  166.     name(m).type   = t;
  167.     name(m).defn   = MFUN;
  168.  
  169.     return m;
  170. }
  171.  
  172. /* --------------------------------------------------------------------------
  173.  * Static analysis of instance declarations:
  174.  *
  175.  * The first part of the static analysis is performed as the declarations
  176.  * are read during parsing:
  177.  * - make new entry in instance table
  178.  * - record line number of declaration
  179.  * - build list of instances defined in current script for use in later
  180.  *   stages of static analysis.
  181.  * ------------------------------------------------------------------------*/
  182.  
  183. Void instDefn(line,head,ms)           /* process new instance definition  */
  184. Int  line;                   /* definition line number       */
  185. Cell head;                   /* inst header :: (context,Class)   */
  186. List ms; {                   /* instance members           */
  187.     Inst new             = newInst();
  188.     inst(new).line       = line;
  189.     inst(new).specifics  = fst(head);
  190.     inst(new).head     = snd(head);
  191.     inst(new).implements = ms;
  192.     instDefns            = cons(new,instDefns);
  193. }
  194.  
  195. /* --------------------------------------------------------------------------
  196.  * Further static analysis of instance declarations:
  197.  *
  198.  * Makes the following checks:
  199.  * - Class part of header is a valid class expression C t1 ... tn not
  200.  *   overlapping with any other instance in class C.
  201.  * - Each element of context is a valid class expression, with type vars
  202.  *   drawn from the types t1,...,tn.
  203.  * - replace type vars in class header by offsets, validate all types etc.
  204.  * - All bindings are function bindings
  205.  * - All bindings define member functions for class C
  206.  * - Arrange bindings into appropriate order for member list
  207.  * - No top level type signature declarations
  208.  * ------------------------------------------------------------------------*/
  209.  
  210. static Void local checkInstDefn(in)    /* validate instance declaration    */
  211. Inst in; {
  212.     Int  line   = inst(in).line;
  213.     List tyvars = typeVarsIn(inst(in).head,NIL);
  214.  
  215.     depPredExp(line,tyvars,inst(in).head);
  216.     map2Proc(depPredExp,line,tyvars,inst(in).specifics);
  217.     inst(in).cl = getHead(inst(in).head);
  218.     kindInst(in,length(tyvars));
  219.     inst(in).head = fullExpPred(inst(in).head);
  220.     insertInst(line,inst(in).cl,in);
  221.     inst(in).numSpecifics = length(inst(in).specifics);
  222.  
  223.     if (nonNull(extractSigdecls(inst(in).implements))) {
  224.         ERROR(line) "Type signature decls not permitted in instance decl"
  225.         EEND;
  226.     }
  227.  
  228.     inst(in).implements = classBindings("instance",
  229.                                         inst(in).cl,
  230.                                         extractBindings(inst(in).implements));
  231. }
  232.  
  233. /* --------------------------------------------------------------------------
  234.  * Process class and instance declaration binding groups:
  235.  * ------------------------------------------------------------------------*/
  236.  
  237. static List local classBindings(where,c,bs)
  238. String where;                          /* check validity of bindings bs for*/
  239. Class  c;                              /* class c (or an instance of c)    */
  240. List   bs; {                           /* sort into approp. member order   */
  241.     List nbs = NIL;
  242.  
  243.     for (; nonNull(bs); bs=tl(bs)) {
  244.         Cell b  = hd(bs);
  245.         Name nm = newName(inventText());   /* pick name for implementation */
  246.         Int  mno;
  247.  
  248.         if (!isVar(fst(b))) {          /* only allows function bindings    */
  249.             ERROR(rhsLine(snd(snd(snd(b)))))
  250.                "Pattern binding illegal in %s declaration", where
  251.             EEND;
  252.         }
  253.  
  254.         mno = memberNumber(c,textOf(fst(b)));
  255.  
  256.         if (mno==0) {
  257.             ERROR(rhsLine(snd(hd(snd(snd(b))))))
  258.                 "No member \"%s\" in class \"%s\"",
  259.                 textToStr(textOf(fst(b))),
  260.                 textToStr(class(c).text)
  261.             EEND;
  262.         }
  263.  
  264.         name(nm).defn = snd(snd(b));   /* save definition of implementation*/
  265.         nbs = numInsert(mno-1,nm,nbs);
  266.     }
  267.     return nbs;
  268. }
  269.  
  270. static Int local memberNumber(c,t)     /* return number of member function */
  271. Class c;                               /* with name t in class c           */
  272. Text  t; {                             /* return 0 if not a member         */
  273.     List ms = class(c).members;
  274.     for (; nonNull(ms); ms=tl(ms))
  275.         if (t==name(hd(ms)).text)
  276.             return name(hd(ms)).number;
  277.     return 0;
  278. }
  279.  
  280. static List local numInsert(n,x,xs)    /* insert x at nth position in xs,  */
  281. Int  n;                                /* filling gaps with NIL            */
  282. Cell x;
  283. List xs; {
  284.     List start = isNull(xs) ? cons(NIL,NIL) : xs;
  285.  
  286.     for (xs=start; 0<n--; xs=tl(xs))
  287.         if (isNull(tl(xs)))
  288.             tl(xs) = cons(NIL,NIL);
  289.     hd(xs) = x;
  290.     return start;
  291. }
  292.  
  293. /* --------------------------------------------------------------------------
  294.  * Primitive definitions are usually only included in the first script
  295.  * file read - the prelude.  A primitive definition associates a variable
  296.  * name with a string (which identifies a built-in primitive) and a type.
  297.  * ------------------------------------------------------------------------*/
  298.  
  299. Void primDefn(line,prims,type)           /* Handle primitive definitions       */
  300. Int  line;
  301. List prims;
  302. Cell type; {
  303.     type = checkSigType(line,"primitive definition",fst(hd(prims)),type);
  304.     for (; nonNull(prims); prims=tl(prims))
  305.     addNewPrim(line,
  306.            textOf(fst(hd(prims))),
  307.            textToStr(textOf(snd(hd(prims)))),
  308.            type);
  309. }
  310.  
  311. static Void local addNewPrim(l,vn,s,t)    /* make binding of variable vn to  */
  312. Int    l;                /* primitive function referred       */
  313. Text   vn;                /* to by s, with given type t       */
  314. String s;                /* return TRUE if vn already bound */
  315. Cell   t;{
  316.     Name n = findName(vn);
  317.  
  318.     if (isNull(n))
  319.         n = newName(vn);
  320.     else if (name(n).defn!=PREDEFINED) {
  321.         ERROR(l) "Redeclaration of primitive \"%s\"", textToStr(vn)
  322.         EEND;
  323.     }
  324.  
  325.     addPrim(l,n,s,t);
  326. }
  327.  
  328. /* --------------------------------------------------------------------------
  329.  * Static analysis of patterns:
  330.  *
  331.  * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
  332.  * makes the following checks:
  333.  *  - Patterns are well formed (according to pattern syntax), including the
  334.  *    special case of (n+k) patterns.
  335.  *  - All constructor functions have been defined and are used with the
  336.  *    correct number of arguments.
  337.  *  - No variable name is used more than once in a pattern.
  338.  *
  339.  * The list of pattern variables occuring in each pattern is accumulated in
  340.  * a global list `patVars', which must be initialised to NIL at appropriate
  341.  * points before using these routines to check for valid patterns.  This
  342.  * mechanism enables the pattern checking routine to be mapped over a list
  343.  * of patterns, ensuring that no variable occurs more than once in the
  344.  * complete pattern list (as is required on the lhs of a function defn).
  345.  * ------------------------------------------------------------------------*/
  346.  
  347. static List patVars;               /* list of vars bound in pattern    */
  348.  
  349. static Cell local checkPat(l-------------*/
  350.  
  351. static List bounds;               /* list of lists of bound vars       */
  352. static List bindings;               /* list of lists of binds in scope  */
  353. static List depends;               /* list of lists of dependents       */
  354.  
  355. #define saveBvars()     hd(bounds)    /* list of bvars in current scope   */
  356. #define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables  */
  357.  
  358. static Cell local bindPat(line,p)      /* add new bound vars for pattern   */
  359. Int  line;
  360. Cell p; {
  361.     patVars    = NIL;
  362.     p           = checkPat(line,p);
  363.     hd(bounds) = revOnto(patVars,hd(bounds));
  364.     return p;
  365. }
  366.  
  367. static Void local bindPats(line,ps)    /* add new bound vars for patterns  */
  368. Int  line;
  369. List ps; {
  370.     patVars    = NIL;
  371.     map1Over(checkPat,line,ps);
  372.     hd(bounds) = revOnto(patVars,hd(bounds));
  373. }
  374.  
  375. /* --------------------------------------------------------------------------
  376.  * Before processing value and type signature declarations, all data and
  377.  * type definitions have been processed so that:
  378.  * - all valid type constructors (with their arities) are known.
  379.  * - all valid constructor functions (with their arities and types) are
  380.  *   known.
  381.  *
  382.  * The result of parsing a list of value declarations is a list of Eqns:
  383.  *     Eqn ::= (SIGDECL,(Line,[Var],type))  |  (Expr,Rhs)
  384.  * The ordering of the equations in this list is the reverse of the original
  385.  * ordering in the script parsed.  This is a consequence of the structure of
  386.  * the parser ... but also turns out to be most convenient for the static
  387.  * analysis.
  388.  *
  389.  * As the first stage of the static analysis of value declarations, each
  390.  * list of Eqns is converted to a list of Bindings.  As part of this
  391.  * process:
  392.  * - The ordering of the list of Bindings produced is the same as in the
  393.  *   original script.
  394.  * - When a variable (function) is defined over a number of lines, all
  395.  *   of the definitions should appear together and each should give the
  396.  *   same arity to the variable being defined.
  397.  * - No variable can have more than one definition.
  398.  * - For pattern bindings:
  399.  *   - Each lhs is a valid pattern/function lhs, all constructor functions
  400.  *     have been defined and are used with the correct number of arguments.
  401.  *   - Each lhs contains no repeated pattern variables.
  402.  *   - Each equation defines at least one variable (e.g. True = False is
  403.  *     not allowed).
  404.  * - Types appearing in type signatures are well formed:
  405.  *    - Type constructors used are defined and used with correct number
  406.  *    of arguments.
  407.  *    - type variables are replaced by offsets, type constructor names
  408.  *    by Tycons.
  409.  * - Every variable named in a type signature declaration is defined by
  410.  *   one or more equations elsewhere in the script.
  411.  * - No variable has more than one type declaration.
  412.  *
  413.  * ------------------------------------------------------------------------*/
  414.  
  415. #define bindingType(b) fst(snd(b))     /* type (or types) for binding       */
  416. #define fbindAlts(b)   snd(snd(b))     /* alternatives for function binding*/
  417.  
  418. static List local extractSigdecls(es)  /* extract the SIGDECLS from list   */
  419. List es; {                   /* of equations               */
  420.     List sigDecls  = NIL;           /* :: [(Line,[Var],Type)]       */
  421.  
  422.     for(; nonNull(es); es=tl(es))
  423.     if (fst(hd(es))==SIGDECL)             /* type-declaration?  */
  424.         sigDecls = cons(snd(hd(es)),sigDecls);   /* discard SIGDECL tag*/
  425.  
  426.     return sigDecls;
  427. }
  428.  
  429. static List local extractBindings(es)  /* extract untyped bindings from    */
  430. List es; {                   /* given list of equations       */
  431.     Cell lastVar   = NIL;           /* = var def'd in last eqn (if any) */
  432.     Int  lastArity = 0;            /* = number of args in last defn    */
  433.     List bs       = NIL;           /* :: [Binding]               */
  434.  
  435.     for(; nonNull(es); es=tl(es)) {
  436.     Cell e = hd(es);
  437.  
  438.     if (fst(e)!=SIGDECL) {
  439.         Int  line     = rhsLine(snd(e));
  440.         Cell lhsHead = getHead(fst(e));
  441.  
  442.         switch (whatIs(lhsHead)) {
  443.         case VARIDCELL :
  444.         case VAROPCELL : {              /* function-binding? */
  445.             Cell newAlt = pair(getArgs(fst(e)), snd(e));
  446.             if (nonNull(lastVar) && textOf(lhsHead)==textOf(lastVar)) {
  447.             if (argCount!=lastArity) {
  448.                 ERROR(line)
  449.                 "Equations give different arities for \"%s\"",
  450.                 textToStr(textOf(lhsHead))
  451.                 EEND;
  452.             }
  453.             fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
  454.             }
  455.             else {
  456.             lastVar   = lhsHead;
  457.             lastArity = argCount;
  458.             notDefined(line,bs,lhsHead);
  459.             bs      = cons(pair(lhsHead,
  460.                           pair(NIL,
  461.                            singleton(newAlt))),
  462.                      bs);
  463.             }
  464.         }
  465.         break;
  466.  
  467.         case CONOPCELL :
  468.         case CONIDCELL :
  469.         case FINLIST   :
  470.         case TUPLE     :
  471.         case UNIT      :
  472.         case ASPAT     : lastVar = NIL;       /* pattern-binding?  */
  473.                  patVars = NIL;
  474.                  fst(e)  = checkPat(line,fst(e));
  475.                  if (isNull(patVars)) {
  476.                      ERROR(line)
  477.                       "No variables defined in lhs pattern"
  478.                      EEND;
  479.                  }
  480.                  map2Proc(notDefined,line,bs,patVars);
  481.                  bs = cons(pair(patVars,pair(NIL,e)),bs);
  482.                  break;
  483.  
  484.         default        : ERROR(line) "Improper left hand side"
  485.                  EEND;
  486.         }
  487.     }
  488.     }
  489.     return bs;
  490. }
  491.  
  492. static List local eqnsToBindings(es)   /* Convert list of equations to list*/
  493. List es; {                   /* of typed bindings           */
  494.     List bs = extractBindings(es);
  495.     map1Proc(addSigDecl,bs,extractSigdecls(es));
  496.     return bs;
  497. }
  498.  
  499. static Void local notDefined(line,bs,v)/* check if name already defined in */
  500. Int  line;                   /* list of bindings           */
  501. List bs;
  502. Cell v; {
  503.     if (nonNull(findBinding(textOf(v),bs))) {
  504.     ERROR(line) "\"%s\" multiply defined", textToStr(textOf(v))
  505.     EEND;
  506.     }
  507. }
  508.  
  509. static Cell local findBinding(t,bs)    /* look for binding for variable t  */
  510. Text t;                    /* in list of bindings bs       */
  511. List bs; {
  512.     for (; nonNull(bs); bs=tl(bs))
  513.     if (isVar(fst(hd(bs)))) {              /* function-binding? */
  514.         if (textOf(fst(hd(bs)))==t)
  515.         return hd(bs);
  516.     }
  517.     else if (nonNull(varIsMember(t,fst(hd(bs))))) /* pattern-binding?  */
  518.         return hd(bs);
  519.     return NIL;
  520. }
  521.  
  522. static Void local addSigDecl(bs,sigDecl)/* add type information to bindings*/
  523. List bs;                   /* :: [Binding]               */
  524. Cell sigDecl; {                /* :: (Line,[Var],Type)           */
  525.     Int  line = intOf(fst3(sigDecl));
  526.     Cell vs   = snd3(sigDecl);
  527.     Cell type = checkSigType(line,"type declaration",hd(vs),thd3(sigDecl));
  528.  
  529.     map3Proc(setType,line,type,bs,vs);
  530. }
  531.  
  532. static Void local setType(line,type,bs,v)
  533. Int  line;                   /* Set type of variable           */
  534. Cell type;
  535. Cell v;
  536. List bs; {
  537.     Text t = textOf(v);
  538.     Cell b = findBinding(t,bs);
  539.  
  540.     if (isNull(b)) {
  541.     ERROR(line) "Type declaration for variable \"%s\" with no body",
  542.             textToStr(t)
  543.     EEND;
  544.     }
  545.  
  546.     if (isVar(fst(b))) {                  /* function-binding? */
  547.     if (isNull(bindingType(b))) {
  548.         bindingType(b) = type;
  549.         return;
  550.     }
  551.     }
  552.     else {                          /* pattern-binding?  */
  553.     List vs = fst(b);
  554.     List ts = bindingType(b);
  555.  
  556.     if (isNull(ts))
  557.         bindingType(b) = ts = copy(length(vs),NIL);
  558.  
  559.     while (nonNull(vs) && t!=textOf(hd(vs))) {
  560.         vs = tl(vs);
  561.         ts = tl(ts);
  562.     }
  563.  
  564.     if (nonNull(vs) && isNull(hd(ts))) {
  565.         hd(ts) = type;
  566.         return;
  567.     }
  568.     }
  569.  
  570.     ERROR(line) "Repeated type declaration for \"%s\"", textToStr(t)
  571.     EEND;
  572. }
  573.  
  574. /* --------------------------------------------------------------------------
  575.  * To facilitate dependency analysis, lists of bindings are temporarily
  576.  * augmented with an additional field, which is used in two ways:
  577.  * - to build the `adjacency lists' for the dependency graph. Represented by
  578.  *   a list of pointers to other bindings in the same list of bindings.
  579.  * - to hold strictly positive integer values (depth first search numbers) of
  580.  *   elements `on the stack' during the strongly connected components search
  581.  *   algorithm, or a special value mkInt(0), once the binding has been added
  582.  *   to a particular strongly connected component.
  583.  *
  584.  * Using this extra field, the type of each list of declarations during
  585.  * dependency analysis is [Binding'] where:
  586.  *
  587.  *    Binding' ::= (Var, (Dep, (Type, [Alt])))          -- function binding
  588.  *        |  ([Var], (Dep, (Type, (Pat,Rhs))))  -- pattern binding
  589.  *
  590.  * ------------------------------------------------------------------------*/
  591.  
  592. #define depVal(d) (fst(snd(d)))        /* Access to dependency information */
  593.  
  594. static List local dependencyAnal(bs)   /* Separate lists of bindings into  */
  595. List bs; {                   /* mutually recursive groups in       */
  596.                        /* order of dependency           */
  597.  
  598.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  599.     mapProc(depBinding,bs);           /* find dependents of each binding  */
  600.     bs = bscc(bs);               /* sort to strongly connected comps */
  601.     mapProc(remDepField,bs);           /* remove dependency info field       */
  602.     return bs;
  603. }
  604.  
  605. static List local topDependAnal(bs)    /* Like dependencyAnal(), but at    */
  606. List bs; {                   /* top level, reporting on progress */
  607.     List xs;
  608.     Int  i = 0;
  609.  
  610.     setGoal("Dependency analysis",(Target)(length(bs)));
  611.     mapProc(addDepField,bs);           /* add extra field for dependents   */
  612.     for (xs=bs; nonNull(xs); xs=tl(xs)) {
  613.     depBinding(hd(xs));
  614.     soFar((Target)(i++));
  615.     }
  616.     bs = bscc(bs);               /* sort to strongly connected comps */
  617.     mapProc(remDepField,bs);           /* remove dependency info field       */
  618.     done();
  619.     return bs;
  620. }
  621.  
  622. static Void local addDepField(b)       /* add extra field to binding to    */
  623. Cell b; {                   /* hold list of dependents       */
  624.     snd(b) = pair(NIL,snd(b));
  625. }
  626.  
  627. static Void local remDepField(bs)      /* remove dependency field from       */
  628. List bs; {                   /* list of bindings           */
  629.     mapProc(remDepField1,bs);
  630. }
  631.  
  632. static Void local remDepField1(b)      /* remove dependency field from       */
  633. Cell b; {                   /* single binding           */
  634.     snd(b) = snd(snd(b));
  635. }
  636.  
  637. static Void local clearScope() {       /* initialise dependency scoping    */
  638.     bounds   = NIL;
  639.     bindings = NIL;
  640.     depends  = NIL;
  641. }
  642.  
  643. static Void local withinScope(bs)      /* enter scope of bindings bs       */
  644. List bs; {
  645.     bounds   = cons(NIL,bounds);
  646.     bindings = cons(bs,bindings);
  647.     depends  = cons(NIL,depends);
  648. }
  649.  
  650. static Void local leaveScope() {       /* leave scope of last withinScope  */
  651.     bounds   = tl(bounds);
  652.     bindings = tl(bindings);
  653.     depends  = tl(depends);
  654. }
  655.  
  656. /* --------------------------------------------------------------------------
  657.  * As a side effect of the dependency analysis we also make the following
  658.  * checks:
  659.  * - Each lhs is a valid pattern/function lhs, all constructor functions
  660.  *   have been defined and are used with the correct number of arguments.
  661.  * - No lhs contains repeated pattern variables.
  662.  * - Expressions used on the rhs of an eqn should be well formed.  This
  663.  *   includes:
  664.  *   - Checking for valid patterns (including repeated vars) in lambda,
  665.  *     case, and list comprehension expressions.
  666.  *   - Recursively checking local lists of equations.
  667.  * - No free (i.e. unbound) variables are used in the declaration list.
  668.  * ------------------------------------------------------------------------*/
  669.  
  670. static Void local depBinding(b)        /* find dependents of binding       */
  671. Cell b; {
  672.     Cell defpart = snd(snd(snd(b)));   /* definition part of binding       */
  673.  
  674.     hd(depends) = NIL;
  675.  
  676.     if (isVar(fst(b))) {           /* function-binding?           */
  677.     mapProc(depAlt,defpart);
  678.     }
  679.     else {                   /* pattern-binding?           */
  680.     depRhs(snd(defpart));
  681.     }
  682.  
  683.     depVal(b) = hd(depends);
  684. }
  685.  
  686. static Void local depDefaults(c)       /* dependency analysis on defaults  */
  687. Class c; {                             /* from class definition            */
  688.     depClassBindings(class(c).defaults);
  689. }
  690.  
  691. static Void local depInsts(in)         /* dependency analysis on instance  */
  692. Inst in; {                             /* bindings                         */
  693.     depClassBindings(inst(in).implements);
  694. }
  695.  
  696. static Void local depClassBindings(bs) /* dependency analysis on list of   */
  697. List bs; {                             /* bindings, possibly containing    */
  698.     for (; nonNull(bs); bs=tl(bs))     /* NIL bindings ...                 */
  699.         if (nonNull(hd(bs)))           /* No need to add extra field for   */
  700.             mapProc(depAlt,name(hd(bs)).defn); /* dependency information.. */
  701. }
  702.  
  703. static Void local depAlt(a)           /* find dependents of alternative   */
  704. Cell a; {
  705.     List origBvars = saveBvars();      /* save list of bound variables       */
  706.     bindPats(rhsLine(snd(a)),fst(a));  /* add new bound vars for patterns  */
  707.     depRhs(snd(a));               /* find dependents of rhs       */
  708.     restoreBvars(origBvars);           /* restore original list of bvars   */
  709. }
  710.  
  711. static Void local depRhs(r)           /* find dependents of rhs       */
  712. Cell r; {
  713.     switch (whatIs(r)) {
  714.     case GUARDED : mapProc(depGuard,snd(r));
  715.                break;
  716.  
  717.     case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)));
  718.                withinScope(fst(snd(r)));
  719.                fst(snd(r)) = dependencyAnal(fst(snd(r)));
  720.                hd(depends) = fst(snd(r));
  721.                depRhs(snd(snd(r)));
  722.                leaveScope();
  723.                break;
  724.  
  725.     default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
  726.                break;
  727.     }
  728. }
  729.  
  730. static Void local depGuard(g)           /* find dependents of single guarded*/
  731. Cell g; {                   /* expression               */
  732.     depPair(intOf(fst(g)),snd(g));
  733. }
  734.  
  735. static Cell local depExpr(line,e)      /* find dependents of expression    */
  736. Int  line;
  737. Cell e; {
  738.     switch (whatIs(e)) {
  739.  
  740.     case VARIDCELL    :
  741.     case VAROPCELL    : return depVar(line,e);
  742.  
  743.     case CONIDCELL    :
  744.     case CONOPCELL    : return conDefined(line,textOf(e));
  745.  
  746.     case AP     : depPair(line,e);
  747.               break;
  748.  
  749.     case NAME    :
  750.     case UNIT    :
  751.     case TUPLE    :
  752.     case STRCELL    :
  753.     case CHARCELL    :
  754.     case FLOATCELL  :
  755.     case INTCELL    : break;
  756.  
  757.     case COND    : depTriple(line,snd(e));
  758.               break;
  759.  
  760.     case FINLIST    : map1Over(depExpr,line,snd(e));
  761.               break;
  762.  
  763.     case LETREC    : fst(snd(e)) = eqnsToBindings(fst(snd(e)));
  764.               withinScope(fst(snd(e)));
  765.               fst(snd(e)) = dependencyAnal(fst(snd(e)));
  766.               hd(depends) = fst(snd(e));
  767.               snd(snd(e)) = depExpr(line,snd(snd(e)));
  768.               leaveScope();
  769.               break;
  770.  
  771.     case LAMBDA    : depAlt(snd(e));
  772.               break;
  773.  
  774.     case COMP    : depComp(line,snd(e),snd(snd(e)));
  775.               break;
  776.  
  777.     case ESIGN    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  778.               snd(snd(e)) = checkSigType(line,
  779.                              "expression",
  780.                              fst(snd(e)),
  781.                              snd(snd(e)));
  782.               break;
  783.  
  784.     case CASE    : fst(snd(e)) = depExpr(line,fst(snd(e)));
  785.               map1Proc(depCaseAlt,line,snd(snd(e)));
  786.               break;
  787.  
  788.     case ASPAT    : ERROR(line) "Illegal `@' in expression"
  789.               EEND;
  790.  
  791.     case LAZYPAT    : ERROR(line) "Illegal `~' in expression"
  792.               EEND;
  793.  
  794.     case WILDCARD    : ERROR(line) "Illegal `_' in expression"
  795.               EEND;
  796.  
  797.     default     : internal("in depExpr");
  798.    }
  799.    return e;
  800. }
  801.  
  802. static Void local depPair(line,e)    /* find dependents of pair of exprs*/
  803. Int  line;
  804. Cell e; {
  805.     fst(e) = depExpr(line,fst(e));
  806.     snd(e) = depExpr(line,snd(e));
  807. }
  808.  
  809. static Void local depTriple(line,e)    /* find dependents of triple exprs */
  810. Int  line;
  811. Cell e; {
  812.     fst3(e) = depExpr(line,fst3(e));
  813.     snd3(e) = depExpr(line,snd3(e));
  814.     thd3(e) = depExpr(line,thd3(e));
  815. }
  816.  
  817. static Void local depComp(l,e,qs)    /* find dependents of comprehension*/
  818. Int  l;
  819. Cell e;
  820. List qs; {
  821.     if (isNull(qs))
  822.     fst(e) = depExpr(l,fst(e));
  823.     else {
  824.     Cell q   = hd(qs);
  825.     List qs1 = tl(qs);
  826.     switch (whatIs(q)) {
  827.         case FROMQUAL : {   List origBvars = saveBvars();
  828.                                 snd(snd(q))    = depExpr(l,snd(snd(q)));
  829.                 fst(snd(q))    = bindPat(l,fst(snd(q)));
  830.                 depComp(l,e,qs1);
  831.                 restoreBvars(origBvars);
  832.                 }
  833.                 break;
  834.  
  835.         case QWHERE   : snd(q)      = eqnsToBindings(snd(q));
  836.                 withinScope(snd(q));
  837.                             snd(q)      = dependencyAnal(snd(q));
  838.                 hd(depends) = snd(q);
  839.                 depComp(l,e,qs1);
  840.                 leaveScope();
  841.                 break;
  842.  
  843.         case BOOLQUAL : snd(q) = depExpr(l,snd(q));
  844.                 depComp(l,e,qs1);
  845.                 break;
  846.     }
  847.     }
  848. }
  849.  
  850. static Void local depCaseAlt(line,a)    /* find dependents of case altern. */
  851. Int  line;
  852. Cell a; {
  853.     List origBvars = saveBvars();    /* save list of bound variables       */
  854.     fst(a) = bindPat(line,fst(a));    /* add new bound vars for patterns */
  855.     depRhs(snd(a));            /* find dependents of rhs       */
  856.     restoreBvars(origBvars);        /* restore original list of bvars  */
  857. }
  858.  
  859. static Cell local depVar(line,e)    /* register occurrence of variable */
  860. Int line;
  861. Cell e; {
  862.     List bounds1   = bounds;
  863.     List bindings1 = bindings;
  864.     List depends1  = depends;
  865.     Text t       = textOf(e);
  866.     Cell n;
  867.  
  868.     while (nonNull(bindings1)) {
  869.     n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
  870.     if (nonNull(n))
  871.         return n;
  872.  
  873.     n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
  874.     if (nonNull(n)) {
  875.        if (!cellIsMember(n,hd(depends1)))
  876.            hd(depends1) = cons(n,hd(depends1));
  877.        return (isVar(fst(n)) ? fst(n) : e);
  878.     }
  879.  
  880.     bounds1   = tl(bounds1);
  881.     bindings1 = tl(bindings1);
  882.     depends1  = tl(depends1);
  883.     }
  884.  
  885.     if (isNull(n=findName(t))) {           /* check global definitions */
  886.     ERROR(line) "Undefined variable \"%s\"", textToStr(t)
  887.     EEND;
  888.     }
  889.  
  890.     return n;
  891. }
  892.  
  893. /* --------------------------------------------------------------------------
  894.  * Several parts of this program require an algorithm for sorting a list
  895.  * of values (with some added dependency information) into a list of strongly
  896.  * connected components in which each value appears before its dependents.
  897.  *
  898.  * Each of these algorithms is obtained by parameterising a standard
  899.  * algorithm in "scc.c" as shown below.
  900.  * ------------------------------------------------------------------------*/
  901.  
  902. #define visited(d) (isInt(DEPENDS(d)))    /* binding already visited ?       */
  903.  
  904. static Cell daSccs = NIL;
  905. static Int  daCount;
  906.  
  907. static Int local sccMin(x,y)           /* calculate minimum of x,y (unless */
  908. Int x,y; {                   /* y is zero)               */
  909.     return (x<=y || y==0) ? x : y;
  910. }
  911.  
  912. #define  SCC        tscc        /* make scc algorithm for Tycons   */
  913. #define  LOWLINK    tlowlink
  914. #define  DEPENDS(t) tycon(t).kind
  915. #include "scc.c"
  916. #undef     DEPENDS
  917. #undef      LOWLINK
  918. #undef     SCC
  919.  
  920. #define  SCC        cscc        /* make scc algorithm for Classes  */
  921. #define  LOWLINK    clowlink
  922. #define  DEPENDS(c) class(c).sig
  923. #include "scc.c"
  924. #undef     DEPENDS
  925. #undef      LOWLINK
  926. #undef     SCC
  927.  
  928. #define  SCC        bscc        /* make scc algorithm for Bindings */
  929. #define  LOWLINK    blowlink
  930. #define  DEPENDS(t) depVal(t)
  931. #include "scc.c"
  932. #undef     DEPENDS
  933. #undef      LOWLINK
  934. #undef     SCC
  935.  
  936. /* --------------------------------------------------------------------------
  937.  * Main static analysis:
  938.  * ------------------------------------------------------------------------*/
  939.  
  940. Void checkExp() {            /* Top level static check on Expr  */
  941.     staticAnalysis(RESET);
  942.     clearScope();            /* Analyse expression in the scope */
  943.     withinScope(NIL);            /* of no local bindings           */
  944.     inputExpr = depExpr(0,inputExpr);
  945.     leaveScope();
  946.     staticAnalysis(RESET);
  947. }
  948.  
  949. Void checkDefns() {            /* Top level static analysis       */
  950.     staticAnalysis(RESET);
  951.  
  952.     mapProc(checkTyconDefn,tyconDefns);    /* validate tycon definitions       */
  953.     checkSynonyms(tyconDefns);        /* check synonym definitions       */
  954.     tyconDefns = tscc(tyconDefns);    /* sort into sc components       */
  955.     mapProc(checkTyconGroup,tyconDefns);/* validate each group           */
  956.     tyconDefns = NIL;
  957.  
  958.     mapProc(checkClassDefn,classDefns);    /* process class definitions       */
  959.     mapProc(checkClassGroup,cscc(classDefns));
  960.  
  961.     instDefns = rev(instDefns);        /* process instance definitions       */
  962.     mapProc(checkInstDefn,instDefns);
  963.  
  964.     mapProc(addRSsigdecls,typeInDefns);    /* add sigdecls for RESTRICTSYN       */
  965.     valDefns = eqnsToBindings(valDefns);/* translate value equations       */
  966.     map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound       */
  967.     mapProc(allNoPrevDef,valDefns);    /* check against previous defns       */
  968.  
  969.     mapProc(checkTypeIn,typeInDefns);    /* check restricted synonym defns  */
  970.  
  971.     clearScope();
  972.     withinScope(valDefns);
  973.     valDefns = topDependAnal(valDefns); /* top level dependency ordering   */
  974.     mapProc(depDefaults,classDefns);    /* dep. analysis on class defaults */
  975.     mapProc(depInsts,instDefns);        /* dep. analysis on inst defns       */
  976.     leaveScope();
  977.  
  978.     staticAnalysis(RESET);
  979. }
  980.  
  981. static Void local addRSsigdecls(pr)    /* add sigdecls from TYPE ... IN ..*/
  982. Pair pr; {
  983.     List vs = snd(pr);            /* get list of variables       */
  984.     for (; nonNull(vs); vs=tl(vs)) {
  985.     if (fst(hd(vs))==SIGDECL) {    /* find a sigdecl           */
  986.         valDefns = cons(hd(vs),valDefns);    /* add to valDefns       */
  987.         hd(vs)   = hd(snd3(snd(hd(vs))));    /* and replace with var       */
  988.     }
  989.     }
  990. }
  991.  
  992. static Void local opDefined(bs,op)     /* check that op bound in bs       */
  993. List bs;                 /* (or in current module for       */
  994. Cell op; {                 /* constructor functions etc...)  */
  995.     Name n;
  996.  
  997.     if (isNull(findBinding(textOf(op),bs))
  998.            && (isNull(n=findName(textOf(op))) || !nameThisModule(n))) {
  999.     ERROR(0) "No top level definition for operator symbol \"%s\"",
  1000.          textToStr(textOf(op))
  1001.     EEND;
  1002.     }
  1003. }
  1004.  
  1005. static Void local allNoPrevDef(b)     /* ensure no previous bindings for*/
  1006. Cell b; {                 /* variables in new binding       */
  1007.     if (isVar(fst(b)))
  1008.     noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
  1009.     else {
  1010.     Int line = rhsLine(snd(snd(snd(b))));
  1011.     map1Proc(noPrevDef,line,fst(b));
  1012.     }
  1013. }
  1014.  
  1015. static Void local noPrevDef(line,v)     /* ensure no previous binding for */
  1016. Int  line;                 /* new variable           */
  1017. Cell v; {
  1018.     Name n = findName(textOf(v));
  1019.  
  1020.     if (isNull(n)) {
  1021.     n            = newName(textOf(v));
  1022.     name(n).defn = PREDEFINED;
  1023.     }
  1024.     else if (name(n).defn!=PREDEFINED) {
  1025.     ERROR(line) "Attempt to redefine variable \"%s\"",
  1026.             textToStr(name(n).text)
  1027.     EEND;
  1028.     }
  1029.     name(n).line = line;
  1030. }
  1031.  
  1032. static Void local checkTypeIn(cvs)    /* Check that vars in restricted   */
  1033. Pair cvs; {                /* synonym are defined, and replace*/
  1034.     Tycon c  = fst(cvs);        /* vars with names           */
  1035.     List  vs = snd(cvs);
  1036.  
  1037.     for (; nonNull(vs); vs=tl(vs))
  1038.     if (isNull(findName(textOf(hd(vs))))) {
  1039.         ERROR(tycon(c).line)
  1040.         "No top level binding of \"%s\" for restricted synonym \"%s\"",
  1041.         textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
  1042.         EEND;
  1043.     }
  1044. }
  1045.  
  1046. /* --------------------------------------------------------------------------
  1047.  * Static Analysis control:
  1048.  * ------------------------------------------------------------------------*/
  1049.  
  1050. Void staticAnalysis(what)
  1051. Int what; {
  1052.     switch (what) {
  1053.     case INSTALL :
  1054.     case RESET   : daSccs     = NIL;
  1055.                patVars     = NIL;
  1056.                bounds     = NIL;
  1057.                bindings     = NIL;
  1058.                depends   = NIL;
  1059.                tyconDeps = NIL;
  1060.                break;
  1061.  
  1062.     case MARK    : mark(daSccs);
  1063.                mark(patVars);
  1064.                mark(bounds);
  1065.                mark(bindings);
  1066.                mark(depends);
  1067.                mark(tyconDeps);
  1068.                break;
  1069.     }
  1070. }
  1071.  
  1072. /*-------------------------------------------------------------------------*/
  1073.