home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / gofer / Sources / c / preds < prev    next >
Encoding:
Text File  |  1993-02-12  |  23.0 KB  |  775 lines
  1. /* --------------------------------------------------------------------------
  2.  * preds.c:     Copyright (c) Mark P Jones 1991-1993.   All rights reserved.
  3.  *              See goferite.h for details and conditions of use etc...
  4.  *              Gofer version 2.28 January 1993
  5.  *
  6.  * Part of type checker dealing with predicates and entailment.
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. Bool anyEvidence  = TRUE;        /* no need to search for `best'    */
  10.                     /* evidence - any will do.       */
  11. Int  maxEvidLevel = 8;            /* maximum no. of dict selects     */
  12. Bool silentEvFail = TRUE;        /* TRUE => fail silently if       */
  13.                     /*         maxEvidLevel exceeded   */
  14.  
  15. /* --------------------------------------------------------------------------
  16.  * Local function prototypes:
  17.  * ------------------------------------------------------------------------*/
  18.  
  19. static Cell   local assumeEvid        Args((Cell,Int));
  20. static List   local makeEvidArgs      Args((List,Int));
  21. static Void   local markPred          Args((Cell));
  22. static List   local copyPreds         Args((List));
  23. static Cell   local copyPred          Args((Cell,Int));
  24. static Void   local qualify           Args((List,Cell));
  25. static Void   local qualifyBinding    Args((List,Cell));
  26.  
  27. static Cell   local instsOverlap      Args((Inst,Inst));
  28. static Bool   local instsCompare      Args((Inst,Inst));
  29.  
  30. static Bool   local oneWayMatches     Args((Cell,Int,Cell,Int));
  31. static Bool   local oneWayTypeMatches Args((Type,Int,Type,Int));
  32.  
  33. static Cell   local proveFrom         Args((List,Cell,Int));
  34. static List   local evidFrom          Args((Cell,Int));
  35. static Void   local explicitProve     Args((Int,String,Cell,List,List));
  36. static Cell   local addEvidArgs          Args((Int,String,Cell,List,List,Cell));
  37. static Void   local cantProve          Args((Int,String,List,Cell,Cell));
  38. static List   local simplify          Args((List));
  39. static Void   local overEvid          Args((Cell,Cell));
  40.  
  41. static List   local elimConstPreds    Args((Int,String,Cell,List));
  42. static Bool   local scanPred          Args((Cell,Int));
  43. static Bool   local scanTyvar         Args((Int));
  44. static Bool   local scanType          Args((Type,Int));
  45.  
  46. static Cell   local makeInst          Args((Int,String,Cell,Cell,Int));
  47. static Cell   local makeDict          Args((Cell,Int));
  48.  
  49. static Void   local indexPred          Args((Class,Cell,Int));
  50. static Void   local indexType          Args((Type,Int));
  51. static Void   local indexLeaf          Args((Cell));
  52.  
  53. /* --------------------------------------------------------------------------
  54.  * Predicate sets:
  55.  *
  56.  * A predicate set is represented by a list of triples (pi, o, used)
  57.  * where o is the offset for types in pi, with evidence required at the
  58.  * node pointed to by used (which is taken as a dictionary parameter if
  59.  * no other evidence is available).  Note that the used node will be
  60.  * overwritten at a later stage if evidence for that predicate is found
  61.  * subsequently.
  62.  * ------------------------------------------------------------------------*/
  63.  
  64. static List preds;               /* current predicate list       */
  65.  
  66. static Cell local assumeEvid(pi,o)     /* add predicate pi (offset o) to   */
  67. Cell pi;                   /* preds with new dictionary var and*/
  68. Int  o; {                   /* return that dictionary variable  */
  69.     Cell nd = inventDictVar();
  70.     preds   = cons(triple(pi,mkInt(o),nd),preds);
  71.     return nd;
  72. }
  73.  
  74. static List local makeEvidArgs(qs,o)   /* make list of predicate assumps.  */
  75. List qs;                   /* from qs (offset o), with new dict*/
  76. Int  o; {                   /* vars for each predicate       */
  77.     List result;
  78.     for (result=NIL; nonNull(qs); qs=tl(qs))
  79.     result = cons(triple(hd(qs),mkInt(o),inventDictVar()),result);
  80.     return rev(result);
  81. }
  82.  
  83. static Void local markPred(pi)           /* marked fixed type variables in pi*/
  84. Cell pi; {
  85.     Cell cl = fst3(pi);
  86.     Int  o  = intOf(snd3(pi));
  87.  
  88.     for (; isAp(cl); cl=fun(cl))
  89.     markType(arg(cl),o);
  90. }
  91.  
  92. static List local copyPreds(qs)        /* copy list of predicates          */
  93. List qs; {
  94.     List result;
  95.     for (result=NIL; nonNull(qs); qs=tl(qs)) {
  96.     Cell pi = hd(qs);
  97.     result  = cons(copyPred(fst3(pi),intOf(snd3(pi))),result);
  98.     }
  99.     return rev(result);
  100. }
  101.  
  102. static Cell local copyPred(pi,o)    /* copy single predicate (or part  */
  103. Cell pi;                /* thereof) ...               */
  104. Int  o; {
  105.     if (isAp(pi)) {
  106.     Cell temp = copyPred(fun(pi),o);/* to ensure correct order of eval.*/
  107.     return ap(temp,copyType(arg(pi),o));
  108.     }
  109.     else
  110.     return pi;
  111. }
  112.  
  113. static Void local qualify(qs,alt)    /* Add extra dictionary args to       */
  114. List qs;                /* qualify alt by predicates in qs */
  115. Cell alt; {                /* :: ([Pat],Rhs)           */
  116.     List ds;
  117.     for (ds=NIL; nonNull(qs); qs=tl(qs))
  118.     ds = cons(thd3(hd(qs)),ds);
  119.     fst(alt) = revOnto(ds,fst(alt));
  120. }
  121.  
  122. static Void local qualifyBinding(qs,b)    /* Add extra dict args to each       */
  123. List qs;                /* alternative in function binding */
  124. Cell b ; {
  125.     if (!isVar(fst(b)))            /* check for function binding       */
  126.     internal("qualifyBinding");
  127.     map1Proc(qualify,qs,snd(snd(b)));
  128. }
  129.  
  130. /* --------------------------------------------------------------------------
  131.  * Check for overlapping instances of class:
  132.  * ------------------------------------------------------------------------*/
  133.  
  134. static Cell local instsOverlap(ia,ib)    /* see if heads of instances can be*/
  135. Inst ia, ib; {                /* unified               */
  136.     Int  alpha, beta;
  137.     Cell pa, pb;
  138.  
  139.     emptySubstitution();
  140.     matchMode = FALSE;
  141.     alpha     = newKindedVars(inst(ia).sig);
  142.     pa          = inst(ia).head;
  143.     beta      = newKindedVars(inst(ib).sig);
  144.     pb          = inst(ib).head;
  145.     while (isAp(pa) && isAp(pb)) {
  146.     if (!unify(arg(pa),alpha,arg(pb),beta))
  147.         return NIL;
  148.     pa = fun(pa);
  149.     pb = fun(pb);
  150.     }
  151.     return copyPred(inst(ia).head,alpha);
  152. }
  153.  
  154. static Bool local instsCompare(ia,ib)    /* see if ib is an instance of ia  */
  155. Inst ia, ib; {
  156.     Int  alpha, beta;
  157.     Cell pa, pb;
  158.  
  159.     emptySubstitution();
  160.     alpha = newKindedVars(inst(ia).sig);
  161.     pa      = inst(ia).head;
  162.     beta  = newKindedVars(inst(ib).sig);
  163.     pb      = inst(ib).head;
  164.     return oneWayMatches(pa,alpha,pb,beta);
  165. }
  166.  
  167. Void insertInst(line,cl,in)        /* insert instance into class       */
  168. Int   line;
  169. Class cl;
  170. Inst  in; {
  171.     List done = NIL;
  172.     List ins  = class(cl).instances;
  173.  
  174.     while (nonNull(ins)) {
  175.     Cell tmp = tl(ins);
  176.     Cell pi  = instsOverlap(in,hd(ins));
  177.     if (nonNull(pi)) {
  178.         Bool bef = instsCompare(hd(ins),in);
  179.         Bool aft = instsCompare(in,hd(ins));
  180.         if (bef==aft) {
  181.         ERROR(line) "Overlapping instances for class \"%s\"",
  182.                 textToStr(class(inst(in).cl).text)
  183.         ETHEN
  184.         ERRTEXT "\n*** This instance   : " ETHEN ERRPRED(inst(in).head);
  185.         ERRTEXT "\n*** Overlaps with   : " ETHEN
  186.                            ERRPRED(inst(hd(ins)).head);
  187.         ERRTEXT "\n*** Common instance : " ETHEN
  188.                                ERRPRED(pi);
  189.         ERRTEXT "\n"
  190.         EEND;
  191.         }
  192.         if (bef)
  193.         break;
  194.     }
  195.     tl(ins) = done;
  196.     done    = ins;
  197.     ins     = tmp;
  198.     }
  199.     class(cl).instances = revOnto(done,cons(in,ins));
  200. }
  201.  
  202. /* --------------------------------------------------------------------------
  203.  * One way matching of instance headers with predicates:
  204.  * ------------------------------------------------------------------------*/
  205.  
  206. static Bool local oneWayMatches(p1,o1,p2,o2)
  207. Cell p1, p2;                /* determine if S(p1,o1) = (p2,o2) */
  208. Int  o1, o2; {                /* for some substitution S       */
  209.     while (isAp(p1) && isAp(p2)) {
  210.     if (!oneWayTypeMatches(arg(p1),o1,arg(p2),o2))
  211.         return FALSE;
  212.     p1 = fun(p1);
  213.     p2 = fun(p2);
  214.     }
  215.     return TRUE;
  216. }
  217.  
  218. static Bool local oneWayTypeMatches(t1,o1,t2,o2)
  219. Type t1, t2;                /* determine if S(t1,o1) = (t2,o2) */
  220. Int  o1, o2; {                /* for some substitution S       */
  221.     Tyvar *tyv;
  222.     Cell  h1,h2;            /* heads of (t1,o1) and (t2,o2)       */
  223.     Int   a1,a2;            /* #args of (t1,o1) and (t2,o2)       */
  224.  
  225.     while (h1=getDerefHead(t1,o1),    /* eliminate synonym at hd (t1,o1) */
  226.        a1=argCount,
  227.        (isSynonym(h1) && tycon(h1).arity==a1)) {
  228.     expandSynonym(h1,&t1,&o1);
  229.     if (isOffset(t1)) {
  230.         tyv = tyvar (o1 + offsetOf(t1));
  231.         t1  = tyv -> bound;
  232.         o1  = tyv -> offs;
  233.     }
  234.     }
  235.  
  236.     deRef(tyv,t2,o2);            /* eliminate synonym at hd (t2,o2) */
  237.     while (h2=getDerefHead(t2,o2),
  238.        a2=argCount,
  239.        (isSynonym(h2) && tycon(h2).arity==a2)) {
  240.     expandSynonym(h2,&t2,&o2);
  241.     deRef(tyv,t2,o2);
  242.     }
  243.  
  244.     /* there are certain conditions under which there is no way to match   */
  245.     /* the type (t1,o1) with (t2,o2):                       */
  246.     /* - if (t1,o1) has more arguments than (t2,o2)               */
  247.     /* - if (t1,o1) has fewer arguments than (t2,o2) and h1 not a variable */
  248.     /* - if h1 not a variable and h2!=h1                   */
  249.  
  250.     if (a1>a2 || (!isOffset(h1) && (a1<a2 || h1!=h2)))
  251.     return FALSE;
  252.  
  253.     while (isAp(t1)) {            /* loop through arguments       */
  254.     if (!oneWayTypeMatches(arg(t1),o1,arg(t2),o2))
  255.         return FALSE;
  256.     t1 = fun(t1);
  257.     t2 = fun(t2);
  258.     deRef(tyv,t2,o2);
  259.     }
  260.  
  261.     if (isOffset(t1)) {            /* (t1,o1) is a variable       */
  262.     tyv = tyvar(o1 + offsetOf(t1));
  263.     if (tyv->bound)
  264.         return sameType(tyv->bound,tyv->offs,t2,o2);
  265.         if (!eqKind(tyv->kind,getKind(t2,o2)))
  266.         return FALSE;
  267.     tyv->bound = t2;
  268.     tyv->offs  = o2;
  269.     }
  270.     return TRUE;
  271. }
  272.  
  273. Bool typeInstOf(type,pt)        /* test if type is instance of poly*/
  274. Type type, pt; {            /* type pt (not-overloaded)       */
  275.     Bool result;
  276.     Int  alpha = 0, beta = 0;
  277.     typeChecker(RESET);
  278.  
  279.     instantiate(pt);            /* instantiate given polytype       */
  280.     alpha = typeOff;
  281.     pt    = typeIs;
  282.     if (predsAre)
  283.     internal("typeInstOf"); 
  284.  
  285.     instantiate(type);            /* and type against which it will  */
  286.     beta = typeOff;            /* be compared               */
  287.     type = typeIs;
  288.     if (predsAre)
  289.     internal("typeInstOf"); 
  290.  
  291.     result = oneWayTypeMatches(pt,alpha,type,beta);
  292.     typeChecker(RESET);
  293.     return result;
  294. }
  295.  
  296. /* --------------------------------------------------------------------------
  297.  * Predicate entailment:
  298.  * ------------------------------------------------------------------------*/
  299.  
  300. static Cell  classProve;
  301. static Cell  predProve;
  302. static Int   offsetProve;
  303. static Int   evDepth;
  304. static Int   evidLevel;
  305.  
  306. static Cell local proveFrom(qs,pi,o)    /* Construct evidence for predicate*/
  307. List  qs;                /* pi, offset o from predicates qs,*/
  308. Cell  pi;                               /* returning NIL if qs ||- (pi,o)  */
  309. Int   o; {                              /* does not hold.                  */
  310.     List  bestEvid  = NIL;
  311.     Int   bestDepth = (-1);
  312.  
  313.     classProve  = getHead(pi);
  314.     predProve   = pi;
  315.     offsetProve = o;
  316.     evidLevel   = 0;
  317.  
  318.     for (; nonNull(qs); qs=tl(qs)) {
  319.     Cell qpi   = hd(qs);
  320.     List dSels = evidFrom(fst3(qpi),intOf(snd3(qpi)));
  321.  
  322.     if (evDepth>=0 && (isNull(bestEvid) || evDepth<bestDepth)) {
  323.         bestEvid  = revOnto(dSels,thd3(qpi));
  324.         bestDepth = evDepth;
  325.         if (anyEvidence)
  326.         return bestEvid;
  327.     }
  328.     }
  329.     return bestEvid;
  330. }
  331.  
  332. static List local evidFrom(pi,o)    /* recursive part of proveFrom       */
  333. Cell pi;                /* return list of dict selectors   */
  334. Int  o; {                /* for optimal (shortest) evidence */
  335.     Class cpi        = getHead(pi);    /* returns evDepth for number of   */
  336.     List  bestYet   = NIL;        /* selectors used, or (-1) if no   */
  337.     Int   bestDepth = (-1);        /* solution possible.           */
  338.     Int   doffs;
  339.     Int   beta;
  340.     List  cs, is;
  341.  
  342.     if (evidLevel++ >= maxEvidLevel) {    /* crude attempt to catch loops       */
  343.     if (silentEvFail)
  344.         goto end;
  345.  
  346.     ERROR(0) "Possible loop for instance " ETHEN
  347.          ERRPRED(copyPred(predProve,offsetProve));
  348.     ERRTEXT  "\n"
  349.     EEND;
  350.     }
  351.  
  352.     if (classProve==cpi) {                /* preds match?       */
  353.     Cell pi1 = pi;
  354.     Cell pi2 = predProve;
  355.     do {
  356.         if (!sameType(arg(pi1),o,arg(pi2),offsetProve))
  357.         break;
  358.         pi1 = fun(pi1);
  359.         pi2 = fun(pi2);
  360.     } while (isAp(pi1) && isAp(pi2));
  361.  
  362.     if (!isAp(pi1) && !isAp(pi2)) {
  363.         evDepth = 0;
  364.         return NIL;
  365.     }
  366.     }
  367.  
  368.     doffs = 1 + class(cpi).numMembers;            /* 1st superclass  */
  369.  
  370.     beta  = newKindedVars(class(cpi).sig);        /* match predicate */
  371.     if (!oneWayMatches(class(cpi).head,beta,pi,o))    /* against class   */
  372.     internal("evidFrom");                /* header       */
  373.  
  374.     for (cs=class(cpi).supers; nonNull(cs); cs=tl(cs)) {/* scan supers...  */
  375.     List dSels = evidFrom(hd(cs),beta);
  376.     if (evDepth>=0 && (isNull(bestYet) || evDepth+1<bestDepth)) {
  377.         bestYet   = cons(mkSelect(doffs),dSels);
  378.         bestDepth = evDepth+1;
  379.         if (anyEvidence)
  380.         goto end;
  381.     }
  382.     doffs++;
  383.     }
  384.  
  385.     for (is=class(cpi).instances; nonNull(is); is=tl(is)) {
  386.     Inst in = hd(is);                /* look through       */
  387.     beta    = newKindedVars(inst(in).sig);        /* instances       */
  388.     if (oneWayMatches(inst(in).head,beta,pi,o)) {
  389.         for (cs=inst(in).specifics; nonNull(cs); cs=tl(cs)) {
  390.         List dSels = evidFrom(hd(cs),beta);
  391.         if (evDepth>=0 && (isNull(bestYet) || evDepth+1<bestDepth)) {
  392.             bestYet   = cons(mkSelect(doffs),dSels);
  393.             bestDepth = evDepth+1;
  394.             if (anyEvidence)
  395.             goto end;
  396.         }
  397.         doffs++;
  398.         }
  399.         break; /* at most one instance matches... */
  400.     }
  401.         else
  402.         freeTypeVars(beta);
  403.     }
  404.  
  405. end:evidLevel--;
  406.     evDepth = bestDepth;
  407.     return bestYet;
  408. }
  409.  
  410. static Void local explicitProve(l,wh,e,given,reqd)
  411. Int    l;                /* construct evidence for reqd       */
  412. String wh;                /* predicates from given preds       */
  413. Cell   e;
  414. List   given, reqd; {
  415.     for (; nonNull(reqd); reqd=tl(reqd)) {
  416.     Cell pi = hd(reqd);
  417.     Cell ev = proveFrom(given,fst3(pi),intOf(snd3(pi)));
  418.     if (isNull(ev))
  419.         cantProve(l,wh,copyPreds(given),e,
  420.               copyPred(fst3(pi),intOf(snd3(pi))));
  421.     overEvid(thd3(pi),ev);
  422.     }
  423. }
  424.  
  425. static Cell local addEvidArgs(l,wh,e,given,reqd,f)
  426. Int    l;
  427. String wh;
  428. Cell   e;
  429. List   given, reqd;
  430. Cell   f; {
  431.     for (; nonNull(reqd); reqd=tl(reqd)) {
  432.     Cell pi = hd(reqd);
  433.     Cell ev = proveFrom(given,fst3(pi),intOf(snd3(pi)));
  434.     if (isNull(ev))
  435.         cantProve(l,wh,copyPreds(given),e,
  436.               copyPred(fst3(pi),intOf(snd3(pi))));
  437.     f = ap(f,ev);
  438.     }
  439.     return f;
  440. }
  441.  
  442. static Void local cantProve(l,wh,context,e,pi)
  443. Int    l;                /* produce error message when an   */
  444. String wh;                /* instance of a class cannot be   */
  445. List   context;                /* constructed               */
  446. Cell   e;
  447. Cell   pi; {
  448.     ERROR(l) "Cannot derive instance in %s", wh ETHEN
  449.     ERRTEXT  "\n*** Expression        : " ETHEN ERREXPR(e);
  450.     ERRTEXT  "\n*** Context           : " ETHEN ERRCONTEXT(context);
  451.     ERRTEXT  "\n*** Required instance : " ETHEN ERRPRED(pi);
  452.     ERRTEXT  "\n"
  453.     EEND;
  454. }
  455.  
  456. /* --------------------------------------------------------------------------
  457.  * Predicate set Simplification:
  458.  *
  459.  * This function calculates a minimal equivalent subset of a given set of
  460.  * predicates.  I believe this algorithm will work for any entailment
  461.  * relation, although I have only checked this for the particular relation
  462.  * coded in the above.
  463.  * ------------------------------------------------------------------------*/
  464.  
  465. static List local simplify(qs)        /* Simplify predicates in qs,      */
  466. List qs; {                /* returning equiv minmal subset   */
  467.     List result = qs;
  468.     Int  n      = length(qs);
  469.  
  470.     while (0<n--) {
  471.     Cell pi = hd(result);
  472.     Cell ev = proveFrom(tl(result),fst3(pi),intOf(snd3(pi)));
  473.     if (nonNull(ev)) {
  474.         overEvid(thd3(pi),ev);
  475.         result = tl(result);
  476.     }
  477.     else {
  478.         Cell temp  = tl(result);
  479.         tl(result) = NIL;
  480.         result     = appendOnto(temp,result);
  481.     }
  482.     }
  483.     return result;
  484. }
  485.  
  486. static Void local overEvid(c,ev)    /* overwrite evidence (possibly       */
  487. Cell c;                    /* including indirection; select0) */
  488. Cell ev; {
  489.     if (isPair(ev) && isSelect(fst(ev)))
  490.     overwrite(c,ev);        /* overwrite with dict selection   */
  491.     else {
  492.     fst(c) = mkSelect(0);        /* indirect to dict variable       */
  493.     snd(c) = ev;
  494.     }
  495. }
  496.  
  497. /* --------------------------------------------------------------------------
  498.  * Deal with constant and locally constant predicates:
  499.  * ------------------------------------------------------------------------*/
  500.  
  501. static Int numFixedVars;        /* number of fixed vars found       */
  502.  
  503. static List local elimConstPreds(l,wh,e,ps)
  504. Int    l;
  505. String wh;
  506. Cell   e;
  507. List   ps; {
  508.     List qs = NIL;
  509.  
  510.     while (nonNull(preds)) {
  511.     Cell pi = hd(preds);
  512.     Cell nx = tl(preds);
  513.  
  514.     numFixedVars = 0;
  515.     if (scanPred(fst3(pi),intOf(snd3(pi)))) {    /* contains generic*/
  516.         tl(preds) = qs;
  517.         qs          = preds;
  518.     }
  519.     else if (numFixedVars>0) {            /* only fixed vars */
  520.         tl(preds) = ps;
  521.         ps          = preds;
  522.     }
  523.     else                        /* constant types  */
  524.         overwrite(thd3(pi),makeInst(l,wh,e,fst3(pi),intOf(snd3(pi))));
  525.  
  526.     preds = nx;
  527.     }
  528.     preds = qs;
  529.     return ps;
  530. }
  531.  
  532. static Bool local scanPred(pi,o)    /* scan pred (pi,o) to determine if*/
  533. Cell pi;                /* it is constant or locally-const */
  534. Int  o; {                /* by counting fixed & generic vars*/
  535.     for (; isAp(pi); pi=fun(pi))
  536.     if (scanType(arg(pi),o))
  537.         return TRUE;
  538.     return FALSE;
  539. }
  540.  
  541. static Bool local scanTyvar(vn)        /* return TRUE if type var contains*/
  542. Int vn; {                /* a generic variable, counting the*/
  543.     Tyvar *tyv = tyvar(vn);        /* number of fixed variables       */
  544.  
  545.     if (tyv->bound)
  546.     return scanType(tyv->bound, tyv->offs);
  547.     else if (tyv->offs == FIXED_TYVAR) {
  548.     numFixedVars++;
  549.     return FALSE;
  550.     }
  551.     return TRUE;
  552. }
  553.  
  554. static Bool local scanType(t,o)        /* Return TRUE if (t,o) contains   */
  555. Type t;                 /* a generic variable           */
  556. Int  o; {
  557.     switch (whatIs(t)) {
  558.     case AP      : return scanType(fst(t),o) || scanType(snd(t),o);
  559.     case OFFSET  : return scanTyvar(o+offsetOf(t));
  560.     case INTCELL : return scanTyvar(intOf(t));
  561.     }
  562.     return FALSE;
  563. }
  564.  
  565. /* -----------------------------------------------------------------------
  566.  * Dictionary construction:
  567.  *
  568.  * 0 | class(c).numMembers | class(c).numSupers | inst(in).numSpecifics |
  569.  * ----------------------------------------------------------------------- */
  570.  
  571. static Cell   instPred;
  572. static Int    instOffs;
  573. static Int    instDepth;
  574. static Cell   instExpr;
  575. static String instWhere;
  576. static Int    instLine;
  577.  
  578. static Cell local makeInst(l,wh,e,pi,o)    /* Build instance, keeping track of*/
  579. Int    l;                /* top-level required instance for */
  580. String wh;                /* benefit of error reporting...   */
  581. Cell   e;
  582. Cell   pi;
  583. Int    o; {
  584.     Cell result;
  585.  
  586.     instPred  = pi;
  587.     instOffs  = o;
  588.     instDepth = 0;
  589.     instExpr  = e;
  590.     instWhere = wh;
  591.     instLine  = l;
  592.     result    = makeDict(pi,o);
  593.     instPred  = NIL;
  594.     instExpr  = NIL;
  595.     return result;
  596. }
  597.  
  598. static Idx  lastIdx, currIdx;        /* used to describe position in idx*/
  599.  
  600. static Cell local makeDict(pi,o)    /* Build dictionary for predicate  */
  601. Cell   pi;
  602. Int    o; {
  603.     Class c = getHead(pi);
  604.     List  xs, is, ds;
  605.     Int   alpha, beta, doffs;
  606.     Dict  dc;
  607.     Inst  in;
  608.  
  609.     indexPred(c,pi,o);                              /* dict has already*/
  610.     if (currIdx!=NODICT)                /* been built?     */
  611.     return dict(currIdx);
  612.  
  613.     for (xs=class(c).instances; nonNull(xs); xs=tl(xs)){/* No; then try and*/
  614.     in   = hd(xs);                    /* find a matching */
  615.     beta = newKindedVars(inst(in).sig);        /* instance to use */
  616.         if (oneWayMatches(inst(in).head,beta,pi,o))    /* to construct the*/
  617.         break;                    /* required dict   */
  618.     else
  619.         freeTypeVars(beta);
  620.     }
  621.  
  622.     if (isNull(xs)) {                    /* No suitable inst*/
  623.     clearMarks();
  624.     ERROR(instLine) "Cannot derive instance in %s", instWhere ETHEN
  625.     ERRTEXT        "\n*** Expression        : " ETHEN
  626.         ERREXPR(instExpr);
  627.     ERRTEXT        "\n*** Required instance : " ETHEN
  628.     ERRPRED(copyPred(instPred,instOffs));
  629.     if (instDepth>0) {
  630.         ERRTEXT     "\n*** No subdictionary  : " ETHEN
  631.         ERRPRED(copyPred(pi,o));
  632.     }
  633.     ERRTEXT  "\n"
  634.     EEND;
  635.     }
  636.  
  637.     alpha = newKindedVars(class(c).sig);        /* match against   */
  638.     if (!oneWayMatches(class(c).head,alpha,pi,o))    /* class header       */
  639.     internal("makeDict");
  640.  
  641.     instDepth++;
  642.  
  643.     dc       = idx(lastIdx).match            /* alloc new dict  */
  644.          = newDict(1 + class(c).numMembers        /* and add to index*/
  645.              + class(c).numSupers
  646.              + inst(in).numSpecifics);
  647.     dict(dc) = mkDict(dc);                /* self reference  */
  648.     doffs    = 1 + class(c).numMembers;
  649.     for (xs=class(c).supers; nonNull(xs); xs=tl(xs))    /* super classes   */
  650.     dict(dc+doffs++) = makeDict(hd(xs),alpha);
  651.     for (xs=inst(in).specifics; nonNull(xs); xs=tl(xs))    /* specifics       */
  652.     dict(dc+doffs++) = makeDict(hd(xs),beta);
  653.  
  654.     xs = class(c).members;                /* member function */
  655.     ds = class(c).defaults;                /* implementations */
  656.     is = inst(in).implements;
  657.     for (doffs=1; nonNull(xs); xs=tl(xs)) {
  658.     if (nonNull(is) && nonNull(hd(is)))
  659.         dict(dc+doffs++) = ap(hd(is),dict(dc));
  660.     else if (nonNull(ds) && nonNull(hd(ds)))
  661.             dict(dc+doffs++) = ap(hd(ds),dict(dc));
  662.     else
  663.         dict(dc+doffs++) = ap(nameUndefMem,hd(xs));
  664.  
  665.     if (nonNull(is)) is=tl(is);
  666.     if (nonNull(ds)) ds=tl(ds);
  667.     }
  668.  
  669. #ifdef DEBUG_CODE
  670. printf("Just made dictionary {dict%d}@%d for ",dc,dict(dc));
  671. printPred(stdout,copyPred(pi,o));
  672. putchar('\n');
  673. printf("breakdown = 1+%d+%d+%d\n",class(c).numMembers,
  674.                   class(c).numSupers,
  675.                   inst(in).numSpecifics);
  676. {
  677.     int i;
  678.     int size = 1+class(c).numMembers+class(c).numSupers+inst(in).numSpecifics;
  679.     for (i=0; i<size; i++) {
  680.          printf("dict(%d) = ",dc+i);
  681.          printExp(stdout,dict(dc+i));
  682.          putchar('\n');
  683.     }
  684.     printf("--------------------\n");
  685. }
  686. #endif
  687.     instDepth--;
  688.     return dict(dc);
  689. }
  690.  
  691. /* --------------------------------------------------------------------------
  692.  * Locate entry in an index corresponding to a given (constant) predicate:
  693.  * ------------------------------------------------------------------------*/
  694.  
  695. static Idx firstIdx;
  696.  
  697. static Void local indexPred(c,pi,o)    /* scan over a monopredicate (i.e a*/
  698. Class c;                /* predicate with monotype args),  */
  699. Cell  pi;                /* producing an indexing string of */
  700. Int   o; {                /* type constrs, and using them to */
  701.     firstIdx =                /* move through a particular index */
  702.     lastIdx  =
  703.     currIdx  = class(c).dictIndex;
  704.     for (; isAp(pi); pi=fun(pi))
  705.      indexType(arg(pi),o);
  706.     class(c).dictIndex = firstIdx;
  707. }
  708.  
  709. static Void local indexType(t,o)    /* scan a monotype as part of the  */
  710. Type t;                    /* indexPred process.           */
  711. Int  o; {
  712.     Cell  temp;
  713.     Tyvar *tyv;
  714.  
  715.     for (;;) {                /* dereference bound vars/synonyms */
  716.     deRef(tyv,t,o);
  717.     if (tyv) internal("indexType");    /* monotypes cannot contain tyvars */
  718.  
  719.     temp = getDerefHead(t,o);    /* check for type synonym...       */
  720.     if (isSynonym(temp) && argCount==tycon(temp).arity)
  721.         expandSynonym(temp,&t,&o);
  722.     else
  723.         break;
  724.     }
  725.  
  726.     /* now we've `evaluated (t,o) to whnf': Con t1 t2 ... tn, we output the*/
  727.     /* constructor Con as a leaf and then go thru' tn, ..., t2, t1 in turn.*/
  728.     /* Admittedly, this gives a less than intuitive mapping of monopreds to*/
  729.     /* strings of type constructors, but it is sufficient for the moment.  */
  730.  
  731.     indexLeaf(temp);
  732.     while (isAp(t)) {
  733.     indexType(arg(t),o);
  734.     t = fun(t);
  735.     deRef(tyv,t,o);
  736.     }
  737. }
  738.  
  739. static Void local indexLeaf(lf)        /* adjust pointers into current idx*/
  740. Cell lf; {                /* having detected type constructor*/
  741.     if (currIdx==NOIDX) {        /* lf whilst indexing over a type  */
  742.     if (lastIdx==NOIDX)
  743.         lastIdx = firstIdx = newIdx(lf);
  744.     else
  745.         lastIdx = idx(lastIdx).match = newIdx(lf);
  746.     currIdx = NOIDX;
  747.     }
  748.     else {
  749.     while (idx(currIdx).test!=lf) {
  750.         if (idx(currIdx).fail==NOIDX) {
  751.         lastIdx = idx(currIdx).fail = newIdx(lf);
  752.         currIdx = NOIDX;
  753.         return;
  754.         }
  755.         else
  756.         currIdx = idx(currIdx).fail;
  757.     }
  758.     lastIdx = currIdx;
  759.     currIdx = idx(currIdx).match;
  760.     }
  761. }
  762.  
  763. Dict listMonadDict() {            /* look for a dict for Monad [ ]   */
  764.     if (nonNull(classMonad)) {
  765.     currIdx = class(classMonad).dictIndex;
  766.     while (currIdx!=NOIDX && idx(currIdx).test!=LIST)
  767.         currIdx = idx(currIdx).fail;
  768.     if (currIdx!=NOIDX)
  769.         return idx(currIdx).match;
  770.     }
  771.     return NODICT;
  772. }
  773.  
  774. /*-------------------------------------------------------------------------*/
  775.