home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGofer 0.22d / MacGofer Sources / kind.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-08-19  |  12.8 KB  |  415 lines  |  [TEXT/MPS ]
  1. /* --------------------------------------------------------------------------
  2.  * kind.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 kind inference
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #if MPW
  10. #pragma segment Kind
  11. #endif
  12.  
  13. #define newKindvars(n)    newTyvars(n)    /* to highlight uses of type vars  */
  14.                     /* as kind variables           */
  15.  
  16. Bool kindExpert = FALSE;        /* TRUE => display kind errors in  */
  17.                     /*       full detail           */
  18.  
  19. /* --------------------------------------------------------------------------
  20.  * Kind checking code:
  21.  * ------------------------------------------------------------------------*/
  22.  
  23. static Void local kindError(l,c,in,wh,k,o)
  24. Int    l;                /* line number near constuctor exp */
  25. Constr c;                /* constructor               */
  26. Constr in;                /* context (if any)           */
  27. String wh;                /* place in which error occurs       */
  28. Kind   k;                /* expected kind (k,o)           */
  29. Int    o; {                /* inferred kind (typeIs,typeOff)  */
  30.     clearMarks();
  31.  
  32.     if (!kindExpert) {            /* for those with a fear of kinds  */
  33.     ERROR(l) "Illegal type" ETHEN
  34.     if (nonNull(in)) {
  35.         ERRTEXT " \"" ETHEN ERRTYPE(in);
  36.         ERRTEXT "\""  ETHEN
  37.     }
  38.     ERRTEXT " in %s\n", wh
  39.     EEND;
  40.     }
  41.  
  42.     ERROR(l) "Kind error in %s", wh ETHEN
  43.     if (nonNull(in)) {
  44.     ERRTEXT "\n*** expression     : " ETHEN ERRTYPE(in);
  45.     }
  46.     ERRTEXT "\n*** constructor    : " ETHEN ERRTYPE(c);
  47.     ERRTEXT "\n*** kind           : " ETHEN ERRKIND(copyType(typeIs,typeOff));
  48.     ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
  49.     if (unifyFails) {
  50.     ERRTEXT "\n*** because        : %s", unifyFails ETHEN
  51.     }
  52.     ERRTEXT "\n"
  53.     EEND;
  54. }
  55.  
  56. #define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
  57.                       kindError(l,c,in,wh,k,o)
  58. #define checkKind(l,c,in,wh,k,o)  kindConstr(l,c); shouldKind(l,c,in,wh,k,o)
  59. #define inferKind(k,o)          typeIs=k; typeOff=o
  60.  
  61. static Int  locCVars;            /* offset to local variable kinds  */
  62. static List unkindTypes;        /* types in need of kind annotation*/
  63.  
  64. static Void local kindConstr(l,c)    /* Determine kind of constructor   */
  65. Int  l;
  66. Cell c; {
  67.     Cell h = getHead(c);
  68.     Int  n = argCount;
  69.  
  70.     if (isSynonym(h) && n!=tycon(h).arity) {
  71.     ERROR(l) "Wrong number of arguments for type synonym \"%s\"",
  72.          textToStr(tycon(h).text)
  73.     EEND;
  74.     }
  75.  
  76.     if (n==0)                /* trivial case, no arguments       */
  77.     typeIs = kindAtom(c);
  78.     else {                /* non-trivial application       */
  79.     static String app = "constructor application";
  80.     Cell   a = c;
  81.     Int    i;
  82.     Kind   k;
  83.     Int    beta;
  84.  
  85.     varKind(n);
  86.     beta   = typeOff;
  87.     k      = typeIs;
  88.  
  89.     typeIs = kindAtom(h);        /* h  :: v1 => ... => vn => w       */
  90.         shouldKind(l,h,c,app,k,beta);
  91.  
  92.     for (i=n; i>0; --i) {        /* ci :: vi for each 1 <- 1..n       */
  93.         checkKind(l,arg(a),c,app,var,beta+i-1);
  94.         a = fun(a);
  95.     }
  96.     tyvarType(beta+n);        /* inferred kind is w           */
  97.     }
  98. }
  99.  
  100. static Kind local kindAtom(c)        /* Find kind of atomic constructor */
  101. Cell c; {
  102.     switch (whatIs(c)) {
  103.     case LIST   : return simpleKind(1);        /*[_]::* -> *       */
  104.     case UNIT   : return STAR;            /*() ::*       */
  105.     case TUPLE  : return simpleKind(tupleOf(c));    /*(,)::* -> * -> * */
  106.     case ARROW  : return simpleKind(2);        /* ->::* -> * -> * */
  107.     case OFFSET : return mkInt(locCVars+offsetOf(c));
  108.     case TYCON  : return tycon(c).kind;
  109.     }
  110.     internal("kindAtom");
  111.     return STAR;/* not reached */
  112. }
  113.  
  114. static Void local kindPred(line,pred)    /* Check kinds of arguments in pred*/
  115. Int  line;
  116. Cell pred; {
  117.     static String predicate = "class constraint";
  118.     Class c   = getHead(pred);        /* get class name           */
  119.     List  as  = getArgs(pred);        /* get arguments           */
  120.     Cell  sig = class(c).sig;        /* get kind signature to match       */
  121.  
  122.     while (nonNull(sig)) {
  123.     checkKind(line,hd(as),NIL,predicate,hd(sig),0);
  124.     sig = tl(sig);
  125.     as  = tl(as);
  126.     }
  127. }
  128.  
  129. static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
  130. Int    line;                /* is well-kinded           */
  131. String wh;
  132. Type   type; {
  133.     locCVars = 0;
  134.     if (isPolyType(type)) {        /* local constructor vars reqd?       */
  135.     locCVars    = newKindvars(selectOf(polySigOf(type)));
  136.     unkindTypes = cons(pair(mkInt(locCVars),snd(type)),unkindTypes);
  137.     type        = monoTypeOf(type);
  138.     }
  139.     if (whatIs(type)==QUAL) {        /* examine context (if any)       */
  140.     map1Proc(kindPred,line,fst(snd(type)));
  141.     type = snd(snd(type));
  142.     }
  143.     checkKind(line,type,NIL,wh,STAR,0);    /* finally, check type part       */
  144. }
  145.  
  146. static Void local fixKinds() {        /* add kind annotations to types   */
  147.     for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
  148.     Pair pr   = hd(unkindTypes);
  149.     if (isSelect(fst(snd(pr)))) {    /* just in case two refs point to a*/
  150.         Int  beta = intOf(fst(pr));    /* single type               */
  151.         Int  n    = selectOf(fst(snd(pr)));
  152.         Kind k    = STAR;
  153.         while (n-- > 0)
  154.         k = ap(copyKindvar(beta+n),k);
  155.         fst(snd(pr)) = k;
  156. #ifdef DEBUG_KINDS
  157. printf("Type expression: ");
  158. printType(stdout,snd(snd(pr)));
  159. printf(" ::: ");
  160. printKind(stdout,k);
  161. printf("\n");
  162. #endif
  163.     }
  164.     }
  165. }
  166.  
  167. /* --------------------------------------------------------------------------
  168.  * Kind checking of groups of type constructors:
  169.  * ------------------------------------------------------------------------*/
  170.  
  171. Void kindTyconGroup(ts)            /* find kinds for mutually rec. gp */
  172. List ts; {                /* of Tycon values           */
  173.    typeChecker(RESET);
  174.    mapProc(initTyconKind,ts);
  175.    mapProc(kindTycon,ts);
  176.    mapProc(genTycon,ts);
  177.    typeChecker(RESET);
  178. }
  179.  
  180. static Void local initTyconKind(t)    /* build initial kind for a tycon  */
  181. Tycon t; {                /* of the form:               */
  182.     Int beta = newKindvars(1);        /*     v1 => ... => vn => *       */
  183.     varKind(tycon(t).arity);
  184.     bindTv(beta,typeIs,typeOff);
  185.     bindTv(typeOff+tycon(t).arity,STAR,0);
  186.     tycon(t).kind = mkInt(beta);
  187. }
  188.  
  189. static Void local kindTycon(t)        /* check each part of a tycon defn */
  190. Tycon t; {                /* is a well-kinded type       */
  191.     static String data = "datatype definition";
  192.     static String tsyn = "synonym definition";
  193.     Int line = tycon(t).line;
  194.  
  195.     locCVars = tyvar(intOf(tycon(t).kind))->offs;
  196.     if (tycon(t).what == DATATYPE) {    /* check components of constr fns  */
  197.     List cs = tycon(t).defn;
  198.     for (; nonNull(cs); cs=tl(cs)) {
  199.         Constr c = hd(cs);
  200.         for (; isAp(c); c=fun(c)) {
  201.         checkKind(line,arg(c),NIL,data,STAR,0);
  202.         }
  203.     }
  204.     }
  205.     else {                /* check synonym expansion       */
  206.     checkKind(line,tycon(t).defn,NIL,tsyn,STAR,0);
  207.     }
  208. }
  209.  
  210. static Void local genTycon(t)        /* generalise kind inferred for       */
  211. Tycon t; {                /* given tycon               */
  212.     tycon(t).kind = copyKindvar(intOf(tycon(t).kind));
  213. #ifdef DEBUG_KINDS
  214. printf("%s :: ",textToStr(tycon(t).text));
  215. printKind(stdout,tycon(t).kind);
  216. putchar('\n');
  217. #endif
  218. }
  219.  
  220. static Kind local copyKindvar(vn)          /* build kind attatched to variable*/
  221. Int vn; {
  222.     Tyvar *tyv = tyvar(vn);
  223.     if (tyv->bound)
  224.     return copyKind(tyv->bound,tyv->offs);
  225.     return STAR;            /* any unbound variable defaults to*/
  226. }                    /* the kind of all types       */
  227.  
  228. static Kind local copyKind(k,o)            /* build kind expression from       */
  229. Kind k;                        /* given skeleton           */
  230. Int  o; {
  231.     switch (whatIs(k)) {
  232.     case AP      : {   Kind l = copyKind(fst(k),o);  /* ensure correct */
  233.                Kind r = copyKind(snd(k),o);  /* eval. order    */
  234.                return ap(l,r);
  235.                }
  236.     case OFFSET  : return copyKindvar(o+offsetOf(k));
  237.     case INTCELL : return copyKindvar(intOf(k));
  238.     }
  239.     return k;
  240. }
  241.  
  242. /* --------------------------------------------------------------------------
  243.  * Kind checking of groups of classes:
  244.  * ------------------------------------------------------------------------*/
  245.  
  246. Void kindClassGroup(cs)            /* find kind signatures for each   */
  247. List cs; {                /* class in the group cs       */
  248.     typeChecker(RESET);
  249.     mapProc(initClassKind,cs);
  250.     mapProc(kindClass,cs);
  251.     mapProc(genClassSig,cs);
  252.     fixKinds();
  253.     typeChecker(RESET);
  254. }
  255.  
  256. static Void local initClassKind(c)    /* build initial signature for a   */
  257. Class c; {                /* given class               */
  258.     Int n     = class(c).arity;
  259.     Int beta     = newKindvars(n);
  260.     class(c).sig = NIL;
  261.     do {
  262.     n--;
  263.     class(c).sig = pair(mkInt(beta+n),class(c).sig);
  264.     } while (n>0);
  265. }
  266.  
  267. static Void local kindClass(c)        /* scan type exprs in class defn to*/
  268. Class c; {                /* determine the class signature   */
  269.     List ms = class(c).members;
  270.  
  271.     locCVars = newKindvars(class(c).arity);
  272.     kindPred(class(c).line,class(c).head);
  273.     map1Proc(kindPred,class(c).line,class(c).supers);
  274.     for (; nonNull(ms); ms=tl(ms)) {
  275.     Int  line = intOf(fst3(hd(ms)));
  276.     Type type = thd3(hd(ms));
  277.     kindType(line,"member function type signature",type);
  278.     }
  279. }
  280.  
  281. static Void local genClassSig(c)    /* `generalise' kind signature for */
  282. Class c; {                /* class -- except, polykinds are  */
  283.     Cell sig = class(c).sig;        /* not permitted           */
  284.     for (; nonNull(sig); sig=tl(sig))
  285.     hd(sig) = copyKindvar(intOf(hd(sig)));
  286. #ifdef DEBUG_KINDS
  287. printf("%s :: ",textToStr(class(c).text));
  288. printSig(stdout,class(c).sig);
  289. putchar('\n');
  290. #endif
  291. }
  292.  
  293. /* --------------------------------------------------------------------------
  294.  * Kind checking of instance declaration headers:
  295.  * ------------------------------------------------------------------------*/
  296.  
  297. Void kindInst(in,freedom)        /* check predicates in instance    */
  298. Inst in;
  299. Int  freedom; {
  300.     typeChecker(RESET);
  301.     locCVars = newKindvars(freedom);
  302.     kindPred(inst(in).line,inst(in).head);
  303.     map1Proc(kindPred,inst(in).line,inst(in).specifics);
  304.     inst(in).sig = NIL;
  305.     while (0<freedom--)
  306.         inst(in).sig = ap(copyKindvar(locCVars+freedom),inst(in).sig);
  307. #ifdef DEBUG_KINDS
  308. printf("instance ");
  309. printPred(stdout,inst(in).head);
  310. printf(" :: ");
  311. printSig(stdout,inst(in).sig);
  312. putchar('\n');
  313. #endif
  314.     typeChecker(RESET);
  315. }
  316.  
  317. /* --------------------------------------------------------------------------
  318.  * Kind checking of individual type signatures:
  319.  * ------------------------------------------------------------------------*/
  320.  
  321. Void kindSigType(line,type)        /* check that type is well-kinded  */
  322. Int  line;
  323. Type type; {
  324.     typeChecker(RESET);
  325.     kindType(line,"type expression",type);
  326.     fixKinds();
  327.     typeChecker(RESET);
  328. }
  329.  
  330. /* --------------------------------------------------------------------------
  331.  * Support for `kind preserving substitutions' from unification:
  332.  * ------------------------------------------------------------------------*/
  333.  
  334. static Bool local eqKind(k1,k2)        /* check that two (mono)kinds are  */
  335. Kind k1, k2; {                /* equal               */
  336.     return k1==k2
  337.        || (isPair(k1) && isPair(k2)
  338.           && eqKind(fst(k1),fst(k2))
  339.           && eqKind(snd(k1),snd(k2)));
  340. }
  341.  
  342. static Kind local getKind(c,o)        /* Find kind of constr during type */
  343. Cell c;                    /* checking process           */
  344. Int  o; {
  345.     if (isAp(c))                    /* application       */
  346.     return snd(getKind(fst(c),o));
  347.     switch (whatIs(c)) {
  348.     case LIST   : return simpleKind(1);        /*[_]::* -> *       */
  349.     case UNIT   : return STAR;            /*() ::*       */
  350.     case TUPLE  : return simpleKind(tupleOf(c));    /*(,)::* -> * -> * */
  351.     case ARROW  : return simpleKind(2);        /*-> ::* -> * -> * */
  352.     case OFFSET : return tyvar(o+offsetOf(c))->kind;
  353.     case INTCELL: return tyvar(intOf(c))->kind;
  354.     case TYCON  : return tycon(c).kind;
  355.     }
  356. #ifdef DEBUG_KINDS
  357. printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
  358. #endif
  359.     internal("getKind");
  360.     return STAR;/* not reached */
  361. }
  362.  
  363. /* --------------------------------------------------------------------------
  364.  * Two forms of kind expression are used quite frequently:
  365.  *    *  => *  => ... => *  => *    for kinds of ->, [], ->, (,) etc...
  366.  *    v1 => v2 => ... => vn => vn+1    skeletons for constructor kinds
  367.  * Expressions of these forms are produced by the following functions which
  368.  * use a cache to avoid repeated construction of commonly used values.
  369.  * A similar approach is used to store the types of tuple constructors in the
  370.  * main type checker.
  371.  * ------------------------------------------------------------------------*/
  372.  
  373. #define MAXKINDFUN 10
  374. static  Kind simpleKindCache[MAXKINDFUN];
  375. static  Kind varKindCache[MAXKINDFUN];
  376.  
  377. static Kind local makeSimpleKind(n)    /* construct * => ... => * (n args)*/
  378. Int n; {
  379.     Kind k = STAR;
  380.     while (n-- > 0)
  381.     k = ap(STAR,k);
  382.     return k;
  383. }
  384.  
  385. static Kind local simpleKind(n)        /* return (possibly cached) simple */
  386. Int n; {                /* function kind           */
  387.     if (n>=MAXKINDFUN)
  388.     return makeSimpleKind(n);
  389.     else if (nonNull(simpleKindCache[n]))
  390.     return simpleKindCache[n];
  391.     else
  392.     return simpleKindCache[n] = makeSimpleKind(n);
  393. }
  394.  
  395. static Kind local makeVarKind(n)    /* construct v0 => .. => vn       */
  396. Int n; {
  397.     Kind k = mkOffset(n);
  398.     while (n-- > 0)
  399.     k = ap(mkOffset(n),k);
  400.     return k;
  401. }
  402.  
  403. static Void local varKind(n)        /* return (possibly cached) var       */
  404. Int n; {                /* function kind           */
  405.     typeOff = newKindvars(n+1);
  406.     if (n>=MAXKINDFUN)
  407.     typeIs = makeVarKind(n);
  408.     else if (nonNull(varKindCache[n]))
  409.     typeIs = varKindCache[n];
  410.     else
  411.     typeIs = varKindCache[n] = makeVarKind(n);
  412. }
  413.  
  414. /*-------------------------------------------------------------------------*/
  415.