home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / subst.c < prev    next >
Encoding:
Text File  |  1993-05-11  |  14.5 KB  |  240 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 = ty
  106.     else
  107.         if (tyv2) {
  108.         Cell h1 = getDerefHead(t1,o1);        /* t2 variable, t1 not */
  109.         if (isSynonym(h1) && argCount==tycon(h1).arity) {
  110.         expandSynonym(h1,&t1,&o1);
  111.         deRef(tyv1,t1,o1);
  112.         goto un;
  113.         }
  114.         return varToTypeBind(tyv2,t1,o1);
  115.         }
  116.     else {                        /* t1, t2 not vars       */
  117.         Type h1 = getDerefHead(t1,o1);
  118.         Int  a1 = argCount;
  119.         Type h2 = getDerefHead(t2,o2);
  120.         Int  a2 = argCount;
  121.  
  122.         if (isOffset(h1) || isInt(h1)) h1=NIL;  /* represent var by NIL*/
  123.         if (isOffset(h2) || isInt(h2)) h2=NIL;
  124.  
  125.         if (nonNull(h1) && h1==h2) {/* Assuming well-formed types, both*/
  126.         if (a1!=a2)        /* t1, t2 must have same no of args*/
  127.             internal("unify");
  128.         while (isAp(t1)) {
  129.             if (!unify(arg(t1),o1,arg(t2),o2))
  130.             return FALSE;
  131.             t1 = fun(t1);
  132.             deRef(tyv1,t1,o1);
  133.             t2 = fun(t2);
  134.             deRef(tyv2,t2,o2);
  135.         }
  136.         return TRUE;
  137.         }
  138.  
  139.         /* Types do not match -- look for type synonyms to expand */
  140.  
  141.         if (isSynonym(h1) && a1==tycon(h1).arity) {
  142.         expandSynonym(h1,&t1,&o1);
  143.         deRef(tyv1,t1,o1);
  144.         goto un;
  145.         }
  146.         if (isSynonym(h2) && a2==tycon(h2).arity) {
  147.         expandSynonym(h2,&t2,&o2);
  148.                 deRef(tyv2,t2,o2);
  149.         goto un;
  150.         }
  151.  
  152.         if ((isNull(h1) && a1<=a2) ||       /* last attempt -- maybe   */
  153.         (isNull(h2) && a2<=a1))    {    /* one head is a variable? */
  154.         for (;;) {
  155.             deRef(tyv1,t1,o1);
  156.             deRef(tyv2,t2,o2);
  157.  
  158.             if (tyv1)                /* unify heads!       */
  159.             if (tyv2)
  160.                 return varToVarBind(tyv1,tyv2);
  161.             else
  162.                 return varToTypeBind(tyv1,t2,o2);
  163.             else if (tyv2)
  164.             return varToTypeBind(tyv2,t1,o1);
  165.  
  166.             /* at this point, neither t1 nor t2 is a variable. In  */
  167.             /* addition, they must both be APs unless one of the   */
  168.             /* head variables has been bound during unification of */
  169.             /* the arguments.                       */
  170.  
  171.             if (!isAp(t1) || !isAp(t2)) {    /* might not be APs*/
  172.             unifyFails = 0;
  173.             return t1==t2;
  174.             }
  175.             if (!unify(arg(t1),o1,arg(t2),o2))    /* o/w must be APs */
  176.             return FALSE;
  177.             t1 = fun(t1);
  178.             t2 = fun(t2);
  179.         }
  180.         }
  181.     }
  182.     unifyFails = 0;
  183.     return FALSE;
  184. }
  185.  
  186. static Bool local sameType(t1,o1,t2,o2)/* Compare types without binding    */
  187. Type t1,t2;
  188. Int  o1,o2; {
  189.     Bool result;
  190.     matchMode = TRUE;
  191.     result    = unify(t1,o1,t2,o2);
  192.     matchMode = FALSE;
  193.     return result;
  194. }
  195.  
  196. Bool typeMatches(type,mt)        /* test if type matches monotype mt*/
  197. Type type, mt; {
  198.     Bool result;
  199.     if (isPolyType(type) || whatIs(type)==QUAL)
  200.     return FALSE;
  201.     typeChecker(RESET);
  202.     matchMode = TRUE;
  203.     result    = unify(mt,0,type,0);
  204.     matchMode = FALSE;
  205.     typeChecker(RESET);
  206.     return result;
  207. }
  208.  
  209. /* --------------------------------------------------------------------------
  210.  * Unify kind expressions:
  211.  * ------------------------------------------------------------------------*/
  212.  
  213. static Bool local kunify(k1,o1,k2,o2)    /* Unify kind expr (k1,o1) with       */
  214. Kind k1,k2;                /* (k2,o2)               */
  215. Int  o1,o2; {
  216.     Tyvar *kyv1, *kyv2;
  217.  
  218.     deRef(kyv1,k1,o1);
  219.     deRef(kyv2,k2,o2);
  220.  
  221.     if (kyv1)
  222.         if (kyv2)
  223.         return kvarToVarBind(kyv1,kyv2);        /* k1, k2 variables    */
  224.         else
  225.         return kvarToTypeBind(kyv1,k2,o2);        /* k1 variable, k2 not */
  226.     else
  227.         if (kyv2)
  228.         return kvarToTypeBind(kyv2,k1,o1);        /* k2 variable, k1 not */
  229.     else
  230.         if (k1==STAR && k2==STAR)            /* k1, k2 not vars       */
  231.         return TRUE;
  232.         else if (isAp(k1) && isAp(k2))
  233.         return kunify(fst(k1),o1,fst(k2),o2) &&
  234.                kunify(snd(k1),o1,snd(k2),o2);
  235.     unifyFails = 0;
  236.     return FALSE;
  237. }
  238.  
  239. /*-------------------------------------------------------------------------*/
  240.