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