ghc/interpreter/preds.c

   1 /* -*- mode: hugs-c; -*- */
   2 /* --------------------------------------------------------------------------
   3  * preds.c:     Copyright (c) Mark P Jones 1991-1998.   All rights reserved.
   4  *              See NOTICE for details and conditions of use etc...
   5  *              Hugs version 1.3c, March 1998
   6  *
   7  * Part of type checker dealing with predicates and entailment.
   8  * ------------------------------------------------------------------------*/
   9
  10 /* --------------------------------------------------------------------------
  11  * Local function prototypes:
  12  * ------------------------------------------------------------------------*/
  13
  14 static Cell   local assumeEvid        Args((Cell,Int));
  15 static List   local makePredAss       Args((List,Int));
  16 static List   local copyPreds         Args((List));
  17 static Void   local qualify           Args((List,Cell));
  18 static Void   local qualifyBinding    Args((List,Cell));
  19 static Cell   local qualifyExpr       Args((Int,List,Cell));
  20 static Void   local overEvid          Args((Cell,Cell));
  21
  22 static Cell   local scFind            Args((Cell,Cell,Int,Cell,Int));
  23 static Cell   local scEntail          Args((List,Cell,Int));
  24 static Cell   local entail            Args((List,Cell,Int));
  25 static Cell   local inEntail          Args((List,Cell,Int));
  26 #if TREX
  27 static Cell   local lacksNorm         Args((Type,Int,Cell));
  28 #endif
  29
  30 static List   local scSimplify        Args((List));
  31 static Void   local elimTauts         Args((Void));
  32 static Bool   local anyGenerics       Args((Type,Int));
  33 static List   local elimOuterPreds    Args((List));
  34 static List   local elimPredsUsing    Args((List,List));
  35 static Void   local reducePreds       Args((Void));
  36 static Void   local normPreds         Args((Int));
  37
  38 static Bool   local resolveDefs       Args((List));
  39 static Bool   local resolveVar        Args((Int));
  40 static Class  local classConstraining Args((Int,Cell,Int));
  41
  42 /* --------------------------------------------------------------------------
  43  * Predicate assignments:
  44  *
  45  * A predicate assignment is represented by a list of triples (pi,o,ev)
  46  * where o is the offset for types in pi, with evidence required at the
  47  * node pointed to by ev (which is taken as a dictionary parameter if
  48  * no other evidence is available).  Note that the ev node will be
  49  * overwritten at a later stage if evidence for that predicate is found
  50  * subsequently.
  51  * ------------------------------------------------------------------------*/
  52
  53 static List preds;                      /* Current predicate assignment    */
  54
  55 static Cell local assumeEvid(pi,o)      /* Add predicate pi (offset o) to  */
  56 Cell pi;                                /* preds with new dict var nd      */
  57 Int  o; {
  58     Cell nd = inventDictVar();
  59     preds   = cons(triple(pi,mkInt(o),nd),preds);
  60     return nd;
  61 }
  62
  63 static List local makePredAss(qs,o)     /* Make list of predicate assumps. */
  64 List qs;                                /* from qs (offset o), w/ new dict */
  65 Int  o; {                               /* vars for each predicate         */
  66     List result = NIL;
  67     for (; nonNull(qs); qs=tl(qs))
  68         result = cons(triple(hd(qs),mkInt(o),inventDictVar()),result);
  69     return rev(result);
  70 }
  71
  72 static List local copyPreds(qs)         /* Copy list of predicates         */
  73 List qs; {
  74     List result = NIL;
  75     for (; nonNull(qs); qs=tl(qs)) {
  76         Cell pi = hd(qs);
  77         result  = cons(copyPred(fst3(pi),intOf(snd3(pi))),result);
  78     }
  79     return rev(result);
  80 }
  81
  82 static Void local qualify(qs,alt)       /* Add extra dictionary args to    */
  83 List qs;                                /* qualify alt by predicates in qs */
  84 Cell alt; {                             /* :: ([Pat],Rhs)                  */
  85     List ds;
  86     for (ds=NIL; nonNull(qs); qs=tl(qs))
  87         ds = cons(thd3(hd(qs)),ds);
  88     fst(alt) = revOnto(ds,fst(alt));
  89 }
  90
  91 static Void local qualifyBinding(qs,b)  /* Add extra dict args to each     */
  92 List qs;                                /* alternative in function binding */
  93 Cell b ; {
  94     if (!isVar(fst(b)))                 /* check for function binding      */
  95         internal("qualifyBinding");
  96     map1Proc(qualify,qs,snd(snd(b)));
  97 }
  98
  99 static Cell local qualifyExpr(l,ps,e)   /* Add dictionary params to expr   */
 100 Int  l;
 101 List ps;
 102 Cell e; {
 103     if (nonNull(ps)) {                  /* Qualify input expression with   */
 104         if (whatIs(e)!=LAMBDA)          /* additional dictionary params    */
 105             e = ap(LAMBDA,pair(NIL,pair(mkInt(l),e)));
 106         qualify(ps,snd(e));
 107     }
 108     return e;
 109 }
 110
 111 static Void local overEvid(dv,ev)       /* Overwrite dict var dv with      */
 112 Cell dv;                                /* evidence ev                     */
 113 Cell ev; {
 114     fst(dv) = nameInd;
 115     snd(dv) = ev;
 116 }
 117
 118 /* --------------------------------------------------------------------------
 119  * Predicate entailment:
 120  *
 121  * Entailment plays a prominent role in the theory of qualified types, and
 122  * so, unsurprisingly, in the implementation too.  For practical reasons,
 123  * we break down entailment into two pieces.  The first, scEntail, uses
 124  * only the information provided by class declarations, while the second,
 125  * entail, also uses the information in instance declarations.
 126  *
 127  * scEntail uses the following auxiliary function to do its work:
 128  *
 129  *   scFind (e : pi') pi : Find evidence for predicate pi using only
 130  *                           equality of predicates, superclass entailment,
 131  *                           and the evidence e for pi'.
 132  *
 133  *   scFind (e : pi') pi =
 134  *
 135  *      if pi = pi' then
 136  *          return e
 137  *
 138  *      if (pi.class.level < pi'.class.level)
 139  *          get superclass entailment pi' ||- P
 140  *          for each (sc, pi0) in P
 141  *              if (ev := scFind (sc e : pi0) pi) /= NIL
 142  *                  return ev
 143  *
 144  *      return NIL
 145  *
 146  * This code assumes that the class hierarchy is acyclic, and that
 147  * each class has been assigned a `level', which is its height in
 148  * the hierachy.  The first of the assumptions guarantees that the
 149  * algorithm will terminate.  The comparison of levels is an
 150  * optimization that cuts down the search space: given that superclass
 151  * entailments can only be used to descend the hierarchy, there is no
 152  * way we can reach a higher level than the one that we start with,
 153  * and hence there is no point in looking if we reach such a position.
 154  *
 155  * scEntail extends scFind to work on whole predicate assignments:
 156  *
 157  *   scEntail P pi : Find evidence for predicate pi using the evidence
 158  *                   provided by the predicate assignment P, and using
 159  *                   only superclass entailments.
 160  *
 161  *   scEntail P pi =
 162  *
 163  *       for each (v:pi') in P
 164  *           if (ev := scFind (v:pi') pi) /= NIL
 165  *               return ev;
 166  *       return NIL
 167  *
 168  * ------------------------------------------------------------------------*/
 169
 170 static Cell local scFind(e,pi1,o1,pi,o) /* Use superclass entailment to    */
 171 Cell e;                                 /* find evidence for (pi,o) using  */
 172 Cell pi1;                               /* the evidence e for (pi1,o1).    */
 173 Int  o1;
 174 Cell pi;
 175 Int  o; {
 176     Class h1 = getHead(pi1);
 177     Class h  = getHead(pi);
 178
 179     if (h==h1 && samePred(pi1,o1,pi,o))
 180         return e;
 181
 182     if (isClass(h1) && (!isClass(h) || cclass(h).level<cclass(h1).level)) {
 183         Int  beta  = newKindedVars(cclass(h1).kinds);
 184         List scs   = cclass(h1).supers;
 185         List dsels = cclass(h1).dsels;
 186         if (!matchPred(pi1,o1,cclass(h1).head,beta))
 187             internal("scFind");
 188         for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels)) {
 189             Cell ev = scFind(ap(hd(dsels),e),hd(scs),beta,pi,o);
 190             if (nonNull(ev))
 191                 return ev;
 192         }
 193     }
 194
 195     return NIL;
 196 }
 197
 198 static Cell local scEntail(ps,pi,o)     /* Calc evidence for (pi,o) from ps*/
 199 List ps;                                /* Using superclasses and equality.*/
 200 Cell pi;
 201 Int  o; {
 202     for (; nonNull(ps); ps=tl(ps)) {
 203         Cell pi1 = hd(ps);
 204         Cell ev  = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o);
 205         if (nonNull(ev))
 206             return ev;
 207     }
 208     return NIL;
 209 }
 210
 211 /* --------------------------------------------------------------------------
 212  * Now we reach the main entailment routine:
 213  *
 214  *   entail P pi : Find evidence for predicate pi using the evidence
 215  *                 provided by the predicate assignment P.
 216  *
 217  *   entail P pi =
 218  *
 219  *       if (ev := scEntail P pi) /= NIL
 220  *           return ev;
 221  *
 222  *       if there is an instance entailment i : Q ||- pi
 223  *           for each pi' in Q
 224  *               if (ev := entail P pi') /= NIL
 225  *                   i := ap(i,ev)
 226  *               else
 227  *                   return NIL
 228  *           return i
 229  *
 230  *       return NIL;
 231  *
 232  * The form of evidence expressions produced by scEntail can be described
 233  * by the grammar:
 234  *
 235  *    e  =  v  |  sc e            (v = evidence var, sc = superclass sel)
 236  *
 237  * while entail extends this to include dictionary expressions given by:
 238  *
 239  *    d  =  e  |  mki d1 ... dn   (mki = dictionary constructor)
 240  *
 241  * A full grammar for evidence expressions is:
 242  *
 243  *    d   =   v   |   sc d   |   mki d1 ... dn
 244  *
 245  * and this includes evidence expressions of the form  sc (mki d1 ... dn)
 246  * that can never be produced by either of the entail functions described
 247  * above.  This is good, from a practical perspective, because t means
 248  * that we won't waste effort building a dictionary (mki d1 ... dn) only
 249  * to extract just one superclass component and throw the rest away.
 250  * Moreover, conditions on instance decls already guarantee that any
 251  * expression of this form can be rewritten in the form  mki' d1' ... dn'.
 252  * (Minor point: they don't guarantee that such rewritings will lead to
 253  * smaller terms, and hence to termination.  However, we have already
 254  * accepted the benefits of an undecidable entailment relation over
 255  * guarantees of termination, and this additional quirk is unlikely
 256  * to cause any further concern, except in pathological cases.)
 257  * ------------------------------------------------------------------------*/
 258
 259 static Cell local entail(ps,pi,o)       /* Calc evidence for (pi,o) from ps*/
 260 List ps;                                /* Uses superclasses, equality,    */
 261 Cell pi;                                /* tautology, and construction     */
 262 Int  o; {
 263     Cell ev = scEntail(ps,pi,o);
 264     return nonNull(ev) ? ev : inEntail(ps,pi,o);
 265 }
 266
 267 static Cell local inEntail(ps,pi,o)     /* Calc evidence for (pi,o) from ps*/
 268 List ps;                                /* using a top-level instance      */
 269 Cell pi;                                /* entailment                      */
 270 Int  o; {
 271 #if TREX
 272     if (isAp(pi) && isExt(fun(pi))) {   /* Lacks predicates                */
 273         Cell e  = fun(pi);
 274         Cell l;
 275         l  = lacksNorm(arg(pi),o,e);
 276         if (isNull(l) || isInt(l))
 277             return l;
 278         else {
 279             List qs = ps;
 280             for (; nonNull(qs); qs=tl(qs)) {
 281                 Cell qi = fst3(hd(qs));
 282                 if (isAp(qi) && fun(qi)==e) {
 283                     Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
 284                     if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
 285                         Int f = intOf(snd(l)) - intOf(snd(lq));
 286                         return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
 287                                                            mkInt(f),
 288                                                            thd3(hd(qs)));
 289                     }
 290                 }
 291             }
 292             return NIL;
 293         }
 294     }
 295     else {
 296 #endif
 297     Inst in = findInstFor(pi,o);        /* Class predicates                */
 298     if (nonNull(in)) {
 299         Int  beta = typeOff;
 300         Cell d    = inst(in).builder;
 301         Cell ds   = inst(in).specifics;
 302         for (; nonNull(ds); ds=tl(ds)) {
 303             Cell ev = entail(ps,hd(ds),beta);
 304             if (nonNull(ev))
 305                 d = ap(d,ev);
 306             else
 307                 return NIL;
 308         }
 309         return d;
 310     }
 311     return NIL;
 312 #if TREX
 313     }
 314 #endif
 315 }
 316
 317 Cell provePred(ks,ps,pi)                /* Find evidence for predicate pi  */
 318 Kinds ks;                               /* assuming ps.  If ps is null,    */
 319 List  ps;                               /* then we get to decide whether   */
 320 Cell  pi; {                             /* is tautological, and we can use */
 321     Int  beta;                          /* the evidence as a dictionary.   */
 322     Cell ev;
 323     emptySubstitution();
 324     beta = newKindedVars(ks);           /* (ks provides kinds for any      */
 325     ps   = makePredAss(ps,beta);        /*  vars that appear in pi.)       */
 326     ev   = entail(ps,pi,beta);
 327     emptySubstitution();
 328     return ev;
 329 }
 330
 331 #if TREX
 332 static Cell local lacksNorm(t,o,e)      /* Normalize lacks pred (t,o)\l    */
 333 Type t;                                 /* returning NIL (unsatisfiable),  */
 334 Int  o;                                 /* Int (tautological) or pair (v,a)*/
 335 Cell e; {                               /* such that, if e is evid for v\l,*/
 336     Text l = extText(e);                /* then (e+a) is evid for (t,o)\l. */
 337     Int  a = 0;
 338     for (;;) {
 339         Tyvar *tyv;
 340         deRef(tyv,t,o);
 341         if (tyv)
 342             return pair(mkInt(tyvNum(tyv)),mkInt(a));
 343         else {
 344             Cell h = getDerefHead(t,o);
 345             if (h==typeNoRow && argCount==0)
 346                 return mkInt(a);
 347             else if (isExt(h) && argCount==2) {
 348                 Text l1 = extText(h);
 349                 if (l1==l)
 350                     return NIL;
 351                 else if (strcmp(textToStr(l1),textToStr(l))<0)
 352                     a++;
 353                 t = arg(t);
 354             }
 355             else
 356                 return NIL;
 357         }
 358     }
 359 }
 360 #endif
 361
 362 /* --------------------------------------------------------------------------
 363  * Predicate set Simplification:
 364  *
 365  * Calculate a minimal equivalent subset of a given set of predicates.
 366  * ------------------------------------------------------------------------*/
 367
 368 static List local scSimplify(qs)        /* Simplify predicates in qs,      */
 369 List qs; {                              /* returning equiv minimal subset  */
 370     Int n = length(qs);
 371
 372     while (0<n--) {
 373         Cell pi = hd(qs);
 374         Cell ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)));
 375         if (nonNull(ev)) {
 376             overEvid(thd3(pi),ev);      /* Overwrite dict var with evidence*/
 377             qs      = tl(qs);           /* ... and discard predicate       */
 378         }
 379         else {                          /* Otherwise, retain predicate     */
 380             Cell tmp = tl(qs);
 381             tl(qs)   = NIL;
 382             qs       = appendOnto(tmp,qs);
 383         }
 384     }
 385     return qs;
 386 }
 387
 388 List simpleContext(ps,o)                /* Simplify context of skeletons   */
 389 List ps;                                /* skeletons, offset o, using      */
 390 Int  o; {                               /* superclass hierarchy            */
 391     return copyPreds(scSimplify(makePredAss(ps,o)));
 392 }
 393
 394 /* --------------------------------------------------------------------------
 395  * Context splitting --- tautological and locally tautological predicates:
 396  * ------------------------------------------------------------------------*/
 397
 398 static Void local elimTauts() {         /* Remove tautological constraints */
 399     List ps = preds;                    /* from preds                      */
 400     preds   = NIL;
 401     while (nonNull(ps)) {
 402         Cell pi = hd(ps);
 403         Cell ev = entail(NIL,fst3(pi),intOf(snd3(pi)));
 404         if (nonNull(ev)) {
 405             overEvid(thd3(pi),ev);
 406             ps = tl(ps);
 407         }
 408         else {
 409             List tmp = tl(ps);
 410             tl(ps)   = preds;
 411             preds    = ps;
 412             ps       = tmp;
 413         }
 414     }
 415 }
 416
 417 static Int numFixedVars = 0;            /* Number of fixed vars found      */
 418
 419 static Bool local anyGenerics(t,o)      /* Test for generic vars, and count*/
 420 Type t;                                 /* fixed variables                 */
 421 Int  o; {
 422     Type h = getDerefHead(t,o);         /* This code is careful to expand  */
 423     Int  a = argCount;                  /* synonyms; mark* & copy* do not. */
 424     if (isSynonym(h) && a>=tycon(h).arity) {
 425         expandSyn(h,a,&t,&o);
 426         return anyGenerics(t,o);
 427     }
 428     else {
 429         Tyvar* tyv;
 430         for (; 0<a--; t=fun(t)) {       /* cycle through any arguments     */
 431             deRef(tyv,t,o);
 432             if (anyGenerics(arg(t),o))
 433                 return TRUE;
 434         }
 435         deRef(tyv,t,o);
 436         if (tyv)
 437             if (tyv->offs == FIXED_TYVAR) {
 438                 numFixedVars++;
 439                 return FALSE;
 440             }
 441             else
 442                 return TRUE;
 443         else
 444             return FALSE;
 445     }
 446 }
 447
 448 static List local elimOuterPreds(sps)   /* Simplify and defer any remaining*/
 449 List sps; {                             /* preds that contain no generics. */
 450     List qs = NIL;
 451     elimTauts();
 452     for (preds=scSimplify(preds); nonNull(preds); ) {
 453         Cell pi = hd(preds);
 454         Cell nx = tl(preds);
 455         if (anyGenerics(fst3(pi),intOf(snd3(pi)))) {    /* Retain predicate*/
 456             tl(preds) = qs;
 457             qs        = preds;
 458         }
 459         else {                                          /* Defer predicate */
 460             tl(preds) = sps;
 461             sps       = preds;
 462         }
 463         preds = nx;
 464     }
 465     preds = qs;
 466     return sps;
 467 }
 468
 469 static List local elimPredsUsing(ps,sps)/* Try to discharge or defer preds,*/
 470 List ps;                                /* splitting if necessary to match */
 471 List sps; {                             /* context ps.  sps = savePreds.   */
 472     List rems = NIL;
 473     while (nonNull(preds)) {            /* Pick a predicate from preds     */
 474         Cell p  = preds;
 475         Cell pi = fst3(hd(p));
 476         Int  o  = intOf(snd3(hd(p)));
 477         Cell ev = entail(ps,pi,o);
 478         preds   = tl(preds);
 479
 480         if (nonNull(ev))                /* Discharge if ps ||- (pi,o)      */
 481             overEvid(thd3(hd(p)),ev);
 482         else if (!anyGenerics(pi,o)) {  /* Defer if no generics            */
 483             tl(p) = sps;
 484             sps   = p;
 485         }
 486         else {                          /* Try to split generics and fixed */
 487             Inst in;
 488             if (numFixedVars>0 && nonNull(in=findInstFor(pi,o))) {
 489                 List qs = inst(in).specifics;
 490                 for (ev=inst(in).builder; nonNull(qs); qs=tl(qs))
 491                     ev = ap(ev,assumeEvid(hd(qs),typeOff));
 492                 overEvid(thd3(hd(p)),ev);
 493             }
 494             else {                      /* No worthwhile progress possible */
 495                 tl(p) = rems;
 496                 rems  = p;
 497             }
 498         }
 499     }
 500     preds = rems;                       /* Return any remaining predicates */
 501     return sps;
 502 }
 503
 504 static Void local reducePreds() {       /* Context reduce predicates: uggh!*/
 505     List rems = NIL;                    /* (A last resort for defaulting)  */
 506     while (nonNull(preds)) {            /* Pick a predicate from preds     */
 507         Cell p  = preds;
 508         Cell pi = fst3(hd(p));
 509         Int  o  = intOf(snd3(hd(p)));
 510         Inst in = findInstFor(pi,o);
 511         preds   = tl(preds);
 512         if (nonNull(in)) {
 513             List qs = inst(in).specifics;
 514             Cell ev = inst(in).builder;
 515             for (; nonNull(qs); qs=tl(qs))
 516                 ev = ap(ev,assumeEvid(hd(qs),typeOff));
 517             overEvid(thd3(hd(p)),ev);
 518         }
 519         else {                          /* No worthwhile progress possible */
 520             tl(p) = rems;
 521             rems  = p;
 522         }
 523     }
 524     preds = scSimplify(rems);           /* Return any remaining predicates */
 525 }
 526
 527 static Void local normPreds(line)       /* Normalize each element of preds */
 528 Int line; {                             /* in some appropriate manner      */
 529 #if TREX
 530     List ps = preds;
 531     List pr = NIL;
 532     while (nonNull(ps)) {
 533         Cell pi = fst3(hd(ps));
 534         Cell ev = thd3(hd(ps));
 535         if (isAp(pi) && isExt(fun(pi))) {
 536             Cell r = lacksNorm(arg(pi),intOf(snd3(hd(ps))),fun(pi));
 537             if (isNull(r)) {
 538                 ERRMSG(line) "Cannot satisfy constraint " ETHEN
 539                 ERRPRED(copyPred(pi,intOf(snd3(hd(ps)))));
 540                 ERRTEXT      "\n"
 541                 EEND;
 542             }
 543             else if (isInt(r)) {
 544                 overEvid(ev,r);
 545                 ps = tl(ps);
 546                 if (isNull(pr))
 547                     preds  = ps;
 548                 else
 549                     tl(pr) = ps;
 550             }
 551             else if (intOf(snd(r))!=0) {
 552                 Cell nd  = inventDictVar();
 553                 Cell ev1 = ap2(nameAddEv,snd(r),nd);
 554                 pi       = ap(fun(pi),aVar);
 555                 hd(ps)   = triple(pi,fst(r),nd);
 556                 overEvid(ev,ev1);
 557                 pr       = ps;
 558                 ps       = tl(ps);
 559             }
 560             else {
 561                 fst3(hd(ps)) = ap(fun(pi),fst(r));
 562                 pr = ps;
 563                 ps = tl(ps);
 564             }
 565         }
 566         else {
 567             pr = ps;
 568             ps = tl(ps);
 569         }
 570     }
 571 #endif
 572 }
 573
 574 /* --------------------------------------------------------------------------
 575  * Mechanisms for dealing with defaults:
 576  * ------------------------------------------------------------------------*/
 577
 578 static Bool local resolveDefs(vs)       /* Attempt to resolve defaults  */
 579 List vs; {                              /* for variables vs subject to  */
 580     List pvs       = NIL;               /* constraints in preds         */
 581     List qs        = preds;
 582     Bool defaulted = FALSE;
 583
 584 #ifdef DEBUG_DEFAULTS
 585     printf("Attempt to resolve variables ");
 586     printExp(stdout,vs);
 587     printf(" with context ");
 588     printContext(stdout,copyPreds(preds));
 589     printf("\n");
 590 #endif
 591
 592     resetGenerics();                    /* find type variables in ps    */
 593     for (; nonNull(qs); qs=tl(qs)) {
 594         Cell pi = fst3(hd(qs));
 595         Int  o  = intOf(snd3(hd(qs)));
 596         for (; isAp(pi); pi=fun(pi))
 597             pvs = genvarType(arg(pi),o,pvs);
 598     }
 599
 600     for (; nonNull(pvs); pvs=tl(pvs)) { /* now try defaults             */
 601         Int vn = intOf(hd(pvs));
 602
 603 #ifdef DEBUG_DEFAULTS
 604         printf("is var %d included in ",vn);
 605         printExp(stdout,vs);
 606         printf("?\n");
 607 #endif
 608
 609         if (!intIsMember(vn,vs))
 610             defaulted |= resolveVar(vn);
 611 #ifdef DEBUG_DEFAULTS
 612         else
 613             printf("Yes, so no ambiguity!\n");
 614 #endif
 615     }
 616
 617     return defaulted;
 618 }
 619
 620 static Bool local resolveVar(vn)        /* Determine whether an ambig.  */
 621 Int  vn; {                              /* variable vn can be resolved  */
 622     List ps        = preds;             /* by default in the context of */
 623     List cs        = NIL;               /* the predicates in ps         */
 624     Bool aNumClass = FALSE;
 625
 626     if (tyvar(vn)->bound == SKOLEM)
 627         return FALSE;
 628
 629     /* According to the Haskell definition, we can only default an ambiguous
 630      * variable if the set of classes that constrain it:
 631      *   (a) includes at least one numeric class.
 632      *   (b) includes only numeric or standard classes.
 633      * In addition, we will not allow a variable to be defaulted unless it
 634      * appears only in predicates of the form (Class var).
 635      */
 636
 637 #ifdef DEBUG_DEFAULTS
 638     printf("Trying to default variable %d\n",vn);
 639 #endif
 640
 641     for (; nonNull(ps); ps=tl(ps)) {
 642         Cell  pi = hd(ps);
 643         Class c  = classConstraining(vn,fst3(pi),intOf(snd3(pi)));
 644         if (nonNull(c)) {
 645             if (c==classRealFrac   || c==classRealFloat ||
 646                 c==classFractional || c==classFloating  ||
 647                 c==classReal       || c==classIntegral  || c==classNum)
 648                 aNumClass = TRUE;
 649             else if (c!=classEq    && c!=classOrd  && c!=classShow &&
 650                      c!=classRead  && c!=classIx   && c!=classEnum &&
 651 #if EVAL_INSTANCES
 652                      c!=classEval &&
 653 #endif
 654                      c!=classBounded)
 655                 return FALSE;
 656
 657             {   Type  t = arg(fst3(pi));/* Check for single var as arg     */
 658                 Int   o = intOf(snd3(pi));
 659                 Tyvar *tyv;
 660                 deRef(tyv,t,o);
 661                 if (!tyv || tyvNum(tyv)!=vn)
 662                     return FALSE;
 663             }
 664             if (!cellIsMember(c,cs))
 665                 cs = cons(c,cs);
 666         }
 667     }
 668
 669     /* Now find the first class (if any) in the list of defaults that
 670      * is an instance of all of the required classes.
 671      *
 672      * If we get this far, then cs only mentions classes from the list
 673      * above, all of which have only a single parameter of kind *.
 674      */
 675
 676     if (aNumClass) {
 677         List ds = defaultDefns;         /* N.B. guaranteed to be monotypes */
 678 #ifdef DEBUG_DEFAULTS
 679         printf("Default conditions met, looking for type\n");
 680 #endif
 681         for (; nonNull(ds); ds=tl(ds)) {
 682             List cs1 = cs;
 683             while (nonNull(cs1) && nonNull(entail(NIL,ap(hd(cs1),hd(ds)),0)))
 684                 cs1 = tl(cs1);
 685             if (isNull(cs1)) {
 686                 bindTv(vn,hd(ds),0);
 687 #ifdef DEBUG_DEFAULTS
 688                 printf("Default type for variable %d is ",vn);
 689                 printType(stdout,hd(ds));
 690                 printf("\n");
 691 #endif
 692                 return TRUE;
 693             }
 694         }
 695     }
 696
 697 #ifdef DEBUG_DEFAULTS
 698     printf("No default permitted/found\n");
 699 #endif
 700     return FALSE;
 701 }
 702
 703 static Class local classConstraining(vn,pi,o)
 704 Int  vn;                                /* Return class constraining var*/
 705 Cell pi;                                /* vn in predicate pi, or NIL if*/
 706 Int  o; {                               /* vn is not involved           */
 707     for (; isAp(pi); pi=fun(pi))
 708         if (!doesntOccurIn(tyvar(vn),arg(pi),o))
 709             return getHead(pi);
 710     return NIL;
 711 }
 712
 713 /*-------------------------------------------------------------------------*/