home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / subst.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-05-11  |  14.5 KB  |  552 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * subst.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 operations on current substitution.
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #if MPW
  10. #pragma segment Subst
  11. #endif
  12.  
  13. static Void local emptySubstitution() {    /* clear current substitution       */
  14.     numTyvars   = 0;
  15.     nextGeneric = 0;
  16.     genericVars = NIL;
  17.     typeIs      = NIL;
  18.     predsAre    = NIL;
  19. }
  20.  
  21. static Int local newTyvars(n)            /* allocate new type variables       */
  22. Int n; {                /* all of kind STAR           */
  23.     Int beta = numTyvars;
  24.  
  25.     if (numTyvars+n>num_tyvars) {
  26.     ERROR(0) "Too many type variables (%d) in type checker", (Int)(numTyvars + n)
  27.     EEND;
  28.     }
  29.     for (numTyvars+=n; n>0; n--) {
  30.     tyvars[numTyvars-n].offs  = UNUSED_GENERIC;
  31.     tyvars[numTyvars-n].bound = NIL;
  32.     tyvars[numTyvars-n].kind  = STAR;
  33. #ifdef DEBUG_TYPES
  34. printf("new type variable: _%d ::: ",numTyvars-n);
  35. printKind(stdout,tyvars[numTyvars-n].kind);
  36. putchar('\n');
  37. #endif
  38.     }
  39.     return beta;
  40. }
  41.  
  42. static Int local newKindedVars(k)    /* allocate new variables with       */
  43. Kind k; {                /* specified kinds           */
  44.     Int beta = numTyvars;        /* if k = k0 -> k1 -> ... -> kn       */
  45.     for (; isAp(k); k=snd(k)) {        /* then allocate n vars with kinds */
  46.     if (numTyvars+1>num_tyvars) {    /* k0, k1, ..., k(n-1)           */
  47.         ERROR(0) "Too many type variables in type checker (%d+1)",
  48.         num_tyvars
  49.         EEND;
  50.     }
  51.     tyvars[numTyvars].offs  = UNUSED_GENERIC;
  52.     tyvars[numTyvars].bound = NIL;
  53.     tyvars[numTyvars].kind  = fst(k);
  54. #ifdef DEBUG_TYPES
  55. printf("new type variable: _%d ::: ",numTyvars);
  56. printKind(stdout,tyvars[numTyvars].kind);
  57. putchar('\n');
  58. #endif
  59.     numTyvars++;
  60.     }
  61.     return beta;
  62. }
  63.  
  64. #define freeTypeVars(beta) numTyvars=beta
  65.  
  66. #define deRef(tyv,t,o)  while ((tyv=getTypeVar(t,o)) && tyv->bound) { \
  67.                             t = tyv->bound;                           \
  68.                             o = tyv->offs;                            \
  69.                         }
  70.  
  71. static Tyvar *local getTypeVar(t,o)    /* get number of type variable       */
  72. Type t;                 /* represented by (t,o) [if any].  */
  73. Int  o; {
  74.     switch (whatIs(t)) {
  75.     case INTCELL : return tyvar(intOf(t));
  76.     case OFFSET  : return tyvar(o+offsetOf(t));
  77.     }
  78.     return ((Tyvar *)0);
  79. }
  80.  
  81. static Void local tyvarType(vn)           /* load type held in type variable */
  82. Int vn; {                       /* vn into (typeIs,typeOff)       */
  83.     Tyvar *tyv;
  84.  
  85.     while ((tyv=tyvar(vn))->bound)
  86.     switch(whatIs(tyv->bound)) {
  87.         case INTCELL : vn = intOf(tyv->bound);
  88.                break;
  89.  
  90.         case OFFSET  : vn = offsetOf(tyv->bound)+(tyv->offs);
  91.                break;
  92.  
  93.         default     : typeIs  = tyv->bound;
  94.                typeOff = tyv->offs;
  95.                return;
  96.     }
  97.     typeIs  = var;
  98.     typeOff = vn;
  99. }
  100.  
  101. static Void local bindTv(vn,t,o)           /* set type variable vn to (t,o)   */
  102. Int  vn;
  103. Type t;
  104. Int  o; {
  105.     Tyvar *tyv = tyvar(vn);
  106.     tyv->bound = t;
  107.     tyv->offs  = o;
  108. #ifdef DEBUG_TYPES
  109. printf("binding type variable: _%d to ",vn);
  110. printType(stdout,debugType(t,o));
  111. putchar('\n');
  112. #endif
  113. }
  114.  
  115. static Void local expandSynonym(h,at,ao)/* Expand type synonym with head h */
  116. Tycon h;                 /* original expression (*at,*ao)   */
  117. Type  *at;                    /* expansion returned in (*at,*ao) */
  118. Int   *ao; {
  119.     Int   n = tycon(h).arity;
  120.     Type  t = *at;
  121.     Int   o = *ao;
  122.     Tyvar *tyv;
  123.  
  124.     *at = tycon(h).defn;
  125.     *ao = newKindedVars(tycon(h).kind);
  126.     for (; 0<n--; t=fun(t)) {
  127.     deRef(tyv,t,o);
  128.     if (tyv || !isAp(t))
  129.         internal("expandSynonym");
  130.     bindTv(*ao+n,arg(t),o);
  131.     }
  132. }
  133.  
  134. static Cell local getDerefHead(t,o)    /* get value at head of type exp.  */
  135. Type t;
  136. Int  o; {
  137.     Tyvar *tyv;
  138.     argCount = 0;
  139.     for (;;) {
  140.     while (isAp(t)) {
  141.         argCount++;
  142.         t = fun(t);
  143.     }
  144.     tyv = getTypeVar(t,o);
  145.     if (tyv && tyv->bound) {
  146.         t = tyv->bound;
  147.         o = tyv->offs;
  148.     }
  149.     else
  150.         break;
  151.     }
  152.     return t;
  153. }
  154.  
  155. /* --------------------------------------------------------------------------
  156.  * Mark type expression, so that all variables are marked as unused generics
  157.  * ------------------------------------------------------------------------*/
  158.  
  159. static Void local clearMarks() {           /* set all unbound type vars to       */
  160.     Int i;                       /* unused generic variables       */
  161.     for (i=0; i<numTyvars; ++i)
  162.     if (isNull(tyvars[i].bound))
  163.         tyvars[i].offs = UNUSED_GENERIC;
  164.     nextGeneric = 0;
  165.     genericVars = NIL;
  166. }
  167.  
  168. static Void local resetGenericsFrom(n)    /* reset all generic vars to unused*/
  169. Int n; {                /* for generics >= n           */
  170.     Int i;
  171.  
  172.     if (n==0)                /* reset generic variables list       */
  173.     genericVars = NIL;        /* most common case: reset to zero */
  174.     else
  175.     for (i=length(genericVars); i>n; i--)
  176.         genericVars = tl(genericVars);
  177.  
  178.     for (i=0; i<numTyvars; ++i)
  179.     if (isNull(tyvars[i].bound) && tyvars[i].offs>=GENERIC+n)
  180.         tyvars[i].offs = UNUSED_GENERIC;
  181.     nextGeneric = n;
  182. }
  183.  
  184. static Void local markTyvar(vn)            /* mark fixed vars in type bound to*/
  185. Int vn; {                       /* given type variable           */
  186.     Tyvar *tyv = tyvar(vn);
  187.  
  188.     if (tyv->bound)
  189.     markType(tyv->bound, tyv->offs);
  190.     else
  191.     (tyv->offs) = FIXED_TYVAR;
  192. }
  193.  
  194. static Void local markType(t,o)            /* mark fixed vars in type (t,o)   */
  195. Type t;
  196. Int  o; {
  197.     STACK_CHECK;            /* KH */
  198.  
  199.     switch (whatIs(t)) {
  200.     case TYCON   :
  201.     case TUPLE   :
  202.     case UNIT    :
  203.     case ARROW   :
  204.     case LIST    : return;
  205.  
  206.     case AP      : markType(fst(t),o);
  207.                markType(snd(t),o);
  208.                return;
  209.  
  210.     case OFFSET  : markTyvar(o+offsetOf(t));
  211.                return;
  212.  
  213.     case INTCELL : markTyvar(intOf(t));
  214.                return;
  215.  
  216.     default      : internal("markType");
  217.     }
  218. }
  219.  
  220. /* --------------------------------------------------------------------------
  221.  * Copy type expression from substitution to make a single type expression:
  222.  * ------------------------------------------------------------------------*/
  223.  
  224. static Type local copyTyvar(vn)            /* calculate most general form of  */
  225. Int vn; {                       /* type bound to given type var       */
  226.     Tyvar *tyv = tyvar(vn);
  227.  
  228.     if (tyv->bound)
  229.     return copyType(tyv->bound,tyv->offs);
  230.  
  231.     switch (tyv->offs) {
  232.     case FIXED_TYVAR    : return mkInt(vn);
  233.  
  234.     case UNUSED_GENERIC : (tyv->offs) = GENERIC + nextGeneric++;
  235.                   if (nextGeneric>=num_offsets) {
  236.                   ERROR(0)
  237.                       "Too many polymorphic type variables (%d)",
  238.                       num_offsets
  239.                   EEND;
  240.                   }
  241.                   genericVars = cons(mkInt(vn),genericVars);
  242.  
  243.     default         : return mkOffset(tyv->offs - GENERIC);
  244.     }
  245. }
  246.  
  247. static Type local copyType(t,o)            /* calculate most general form of  */
  248. Type t;                        /* type expression (t,o)        */
  249. Int  o; {
  250.     STACK_CHECK;            /* KH */
  251.  
  252.     switch (whatIs(t)) {
  253.     case AP      : {   Type l = copyType(fst(t),o);  /* ensure correct */
  254.                Type r = copyType(snd(t),o);  /* eval. order    */
  255.                return ap(l,r);
  256.                }
  257.     case OFFSET  : return copyTyvar(o+offsetOf(t));
  258.     case INTCELL : return copyTyvar(intOf(t));
  259.     }
  260.  
  261.     return t;
  262. }
  263.  
  264. #ifdef DEBUG_TYPES
  265. static Type local debugTyvar(vn)    /* expand type structure in full   */
  266. Int vn; {                /* detail               */
  267.     Tyvar *tyv = tyvar(vn);
  268.  
  269.     if (tyv->bound)
  270.     return debugType(tyv->bound,tyv->offs);
  271.     return mkInt(vn);
  272. }
  273.  
  274. static Type local debugType(t,o)
  275. Type t;
  276. Int  o; {
  277.     STACK_CHECK;            /* KH */
  278.  
  279.     switch (whatIs(t)) {
  280.     case AP      : {   Type l = debugType(fst(t),o);
  281.                Type r = debugType(snd(t),o);
  282.                return ap(l,r);
  283.                }
  284.     case OFFSET  : return debugTyvar(o+offsetOf(t));
  285.     case INTCELL : return debugTyvar(intOf(t));
  286.     }
  287.  
  288.     return t;
  289. }
  290. #endif /*DEBUG_TYPES*/
  291.  
  292. /* --------------------------------------------------------------------------
  293.  * Occurs check:
  294.  * ------------------------------------------------------------------------*/
  295.  
  296. static Tyvar *lookingFor;               /* var to look for in occurs check */
  297.  
  298. static Bool local doesntOccurIn(t,o)       /* Return TRUE if var lookingFor   */
  299. Type t;                        /* isn't referenced in (t,o)       */
  300. Int o; {
  301.     Tyvar *tyv;
  302.  
  303.     STACK_CHECK;            /* KH */
  304.  
  305.     for (;;) {
  306.     deRef(tyv,t,o);
  307.     if (tyv)            /* type variable           */
  308.         return tyv!=lookingFor;
  309.         else if (isAp(t)) {        /* application               */
  310.         if (doesntOccurIn(snd(t),o))
  311.         t = fst(t);
  312.         else
  313.         return FALSE;
  314.     }
  315.     else                            /* no variable found           */
  316.         break;
  317.     }
  318.     return TRUE;
  319. }
  320.  
  321. /* --------------------------------------------------------------------------
  322.  * Unification algorithm:
  323.  * ------------------------------------------------------------------------*/
  324.  
  325. static char *unifyFails = 0;        /* unification error message       */
  326. static Bool matchMode    = FALSE;    /* set to TRUE to prevent binding  */
  327.                            /* during matching process       */
  328.  
  329. static Bool local varToVarBind(tyv1,tyv2)/* Make binding tyv1 := tyv2       */
  330. Tyvar *tyv1, *tyv2; {
  331.     if (tyv1!=tyv2)
  332.     if (matchMode)
  333.         return FALSE;
  334.     else {
  335.         if (!eqKind(tyv1->kind,tyv2->kind)) {
  336.         unifyFails = "constructor variable kinds do not match";
  337.         return FALSE;
  338.         }
  339.         tyv1->bound = var;
  340.         tyv1->offs    = tyvNum(tyv2);
  341. #ifdef DEBUG_TYPES
  342. printf("vv binding type variable: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
  343. #endif
  344.     }
  345.     return TRUE;
  346. }
  347.  
  348. static Bool local varToTypeBind(tyv,t,o)/* Make binding tyv := (t,o)       */
  349. Tyvar *tyv;
  350. Type  t;                /* guaranteed not to be a v'ble or */
  351. Int   o; {                /* have synonym as outermost constr*/
  352.     if (!matchMode) {
  353.     lookingFor = tyv;
  354.     if (doesntOccurIn(t,o)) {
  355.         if (!eqKind(tyv->kind,getKind(t,o))) {
  356.         unifyFails = "constructor variable kinds do not match";
  357.         return FALSE;
  358.         }
  359.         tyv->bound = t;
  360.         tyv->offs  = o;
  361. #ifdef DEBUG_TYPES
  362. printf("vt binding type variable: _%d to ",tyvNum(tyv));
  363. printType(stdout,debugType(t,o));
  364. putchar('\n');
  365. #endif
  366.         return TRUE;
  367.     }
  368.     }
  369.     unifyFails = "unification would give infinite type";
  370.     return FALSE;    /* INFINITE TYPE (or failed match in matchMode)    */
  371. }
  372.  
  373. static Bool local kvarToVarBind(tyv1,tyv2)/* Make binding tyv1 := tyv2       */
  374. Tyvar *tyv1, *tyv2; {              /* for kind variable bindings       */
  375.     if (tyv1!=tyv2) {
  376.     tyv1->bound = var;
  377.     tyv1->offs  = tyvNum(tyv2);
  378.     }
  379.     return TRUE;
  380. }
  381.  
  382. static Bool local kvarToTypeBind(tyv,t,o)/* Make binding tyv := (t,o)       */
  383. Tyvar *tyv;                /* for kind variable bindings       */
  384. Type  t;                /* guaranteed not to be a v'ble or */
  385. Int   o; {                /* have synonym as outermost constr*/
  386.     lookingFor = tyv;
  387.     if (doesntOccurIn(t,o)) {
  388.     tyv->bound = t;
  389.     tyv->offs  = o;
  390.     return TRUE;
  391.     }
  392.     unifyFails = "unification would give infinite kind";
  393.     return FALSE;
  394. }
  395.  
  396. static Bool local unify(t1,o1,t2,o2)    /* Main unification routine       */
  397. Type t1,t2;                /* unify (t1,o1) with (t2,o2)       */
  398. Int  o1,o2; {
  399.     Tyvar *tyv1, *tyv2;
  400.  
  401.     STACK_CHECK;            /* KH */
  402.  
  403.     deRef(tyv1,t1,o1);
  404.     deRef(tyv2,t2,o2);
  405.  
  406. un: if (tyv1)
  407.         if (tyv2)
  408.         return varToVarBind(tyv1,tyv2);        /* t1, t2 variables    */
  409.         else {
  410.         Cell h2 = getDerefHead(t2,o2);        /* t1 variable, t2 not */
  411.         if (isSynonym(h2) && argCount==tycon(h2).arity) {
  412.         expandSynonym(h2,&t2,&o2);
  413.         deRef(tyv2,t2,o2);
  414.         goto un;
  415.         }
  416.         return varToTypeBind(tyv1,t2,o2);
  417.         }
  418.     else
  419.         if (tyv2) {
  420.         Cell h1 = getDerefHead(t1,o1);        /* t2 variable, t1 not */
  421.         if (isSynonym(h1) && argCount==tycon(h1).arity) {
  422.         expandSynonym(h1,&t1,&o1);
  423.         deRef(tyv1,t1,o1);
  424.         goto un;
  425.         }
  426.         return varToTypeBind(tyv2,t1,o1);
  427.         }
  428.     else {                        /* t1, t2 not vars       */
  429.         Type h1 = getDerefHead(t1,o1);
  430.         Int  a1 = argCount;
  431.         Type h2 = getDerefHead(t2,o2);
  432.         Int  a2 = argCount;
  433.  
  434.         if (isOffset(h1) || isInt(h1)) h1=NIL;  /* represent var by NIL*/
  435.         if (isOffset(h2) || isInt(h2)) h2=NIL;
  436.  
  437.         if (nonNull(h1) && h1==h2) {/* Assuming well-formed types, both*/
  438.         if (a1!=a2)        /* t1, t2 must have same no of args*/
  439.             internal("unify");
  440.         while (isAp(t1)) {
  441.             if (!unify(arg(t1),o1,arg(t2),o2))
  442.             return FALSE;
  443.             t1 = fun(t1);
  444.             deRef(tyv1,t1,o1);
  445.             t2 = fun(t2);
  446.             deRef(tyv2,t2,o2);
  447.         }
  448.         return TRUE;
  449.         }
  450.  
  451.         /* Types do not match -- look for type synonyms to expand */
  452.  
  453.         if (isSynonym(h1) && a1==tycon(h1).arity) {
  454.         expandSynonym(h1,&t1,&o1);
  455.         deRef(tyv1,t1,o1);
  456.         goto un;
  457.         }
  458.         if (isSynonym(h2) && a2==tycon(h2).arity) {
  459.         expandSynonym(h2,&t2,&o2);
  460.                 deRef(tyv2,t2,o2);
  461.         goto un;
  462.         }
  463.  
  464.         if ((isNull(h1) && a1<=a2) ||       /* last attempt -- maybe   */
  465.         (isNull(h2) && a2<=a1))    {    /* one head is a variable? */
  466.         for (;;) {
  467.             deRef(tyv1,t1,o1);
  468.             deRef(tyv2,t2,o2);
  469.  
  470.             if (tyv1)                /* unify heads!       */
  471.             if (tyv2)
  472.                 return varToVarBind(tyv1,tyv2);
  473.             else
  474.                 return varToTypeBind(tyv1,t2,o2);
  475.             else if (tyv2)
  476.             return varToTypeBind(tyv2,t1,o1);
  477.  
  478.             /* at this point, neither t1 nor t2 is a variable. In  */
  479.             /* addition, they must both be APs unless one of the   */
  480.             /* head variables has been bound during unification of */
  481.             /* the arguments.                       */
  482.  
  483.             if (!isAp(t1) || !isAp(t2)) {    /* might not be APs*/
  484.             unifyFails = 0;
  485.             return t1==t2;
  486.             }
  487.             if (!unify(arg(t1),o1,arg(t2),o2))    /* o/w must be APs */
  488.             return FALSE;
  489.             t1 = fun(t1);
  490.             t2 = fun(t2);
  491.         }
  492.         }
  493.     }
  494.     unifyFails = 0;
  495.     return FALSE;
  496. }
  497.  
  498. static Bool local sameType(t1,o1,t2,o2)/* Compare types without binding    */
  499. Type t1,t2;
  500. Int  o1,o2; {
  501.     Bool result;
  502.     matchMode = TRUE;
  503.     result    = unify(t1,o1,t2,o2);
  504.     matchMode = FALSE;
  505.     return result;
  506. }
  507.  
  508. Bool typeMatches(type,mt)        /* test if type matches monotype mt*/
  509. Type type, mt; {
  510.     Bool result;
  511.     if (isPolyType(type) || whatIs(type)==QUAL)
  512.     return FALSE;
  513.     typeChecker(RESET);
  514.     matchMode = TRUE;
  515.     result    = unify(mt,0,type,0);
  516.     matchMode = FALSE;
  517.     typeChecker(RESET);
  518.     return result;
  519. }
  520.  
  521. /* --------------------------------------------------------------------------
  522.  * Unify kind expressions:
  523.  * ------------------------------------------------------------------------*/
  524.  
  525. static Bool local kunify(k1,o1,k2,o2)    /* Unify kind expr (k1,o1) with       */
  526. Kind k1,k2;                /* (k2,o2)               */
  527. Int  o1,o2; {
  528.     Tyvar *kyv1, *kyv2;
  529.  
  530.     deRef(kyv1,k1,o1);
  531.     deRef(kyv2,k2,o2);
  532.  
  533.     if (kyv1)
  534.         if (kyv2)
  535.         return kvarToVarBind(kyv1,kyv2);        /* k1, k2 variables    */
  536.         else
  537.         return kvarToTypeBind(kyv1,k2,o2);        /* k1 variable, k2 not */
  538.     else
  539.         if (kyv2)
  540.         return kvarToTypeBind(kyv2,k1,o1);        /* k2 variable, k1 not */
  541.     else
  542.         if (k1==STAR && k2==STAR)            /* k1, k2 not vars       */
  543.         return TRUE;
  544.         else if (isAp(k1) && isAp(k2))
  545.         return kunify(fst(k1),o1,fst(k2),o2) &&
  546.                kunify(snd(k1),o1,snd(k2),o2);
  547.     unifyFails = 0;
  548.     return FALSE;
  549. }
  550.  
  551. /*-------------------------------------------------------------------------*/
  552.