2.11BSD#431 - /usr/src/new/PORT/B/src/bint/b2tcU.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b2tcU.c,v 1.4 85/08/22 16:57:11 timo Exp $
   5: */
   6: 
   7: /* unification of polytypes */
   8: 
   9: #include "b.h"
  10: #include "b1obj.h"
  11: #include "b2tcP.h"
  12: #include "b2tcU.h"
  13: #include "b2tcE.h"
  14: 
  15: Hidden bool bad;
  16: Hidden bool cycling;
  17: Hidden bool badcycle;
  18: 
  19: Visible Procedure unify(a, b, pu)
  20: polytype a, b, *pu;
  21: {
  22:     bad = No;
  23:     cycling = No;
  24:     setreprtable();
  25:     u_unify(a, b, pu);
  26:     if (bad) badtyperr(a, b);
  27:     delreprtable();
  28: }
  29: 
  30: Hidden Procedure u_unify(a, b, pu)
  31: polytype a, b, *pu;
  32: {
  33:     typekind a_kind, b_kind;
  34:     polytype res;
  35: 
  36:     a_kind = kind(a);
  37:     b_kind = kind(b);
  38: 
  39:     if (are_same_types(a, b)) {
  40:         *pu = p_copy(a);
  41:     }
  42:     else if (t_is_var(a_kind) || t_is_var(b_kind)) {
  43:         substitute_for(a, b, pu);
  44:     }
  45:     else if (have_same_structure(a, b)) {
  46:         unify_subtypes(a, b, pu);
  47:     }
  48:     else if (has_number(a_kind) && has_number(b_kind)) {
  49:         *pu = mkt_number();
  50:     }
  51:     else if (has_text(a_kind) && has_text(b_kind)) {
  52:         *pu = mkt_text();
  53:     }
  54:     else if (has_text(a_kind) && t_is_tlt(b_kind)) {
  55:         u_unify(asctype(b), (res = mkt_text()), pu);
  56:         p_release(res);
  57:     }
  58:     else if (has_text(b_kind) && t_is_tlt(a_kind)) {
  59:         u_unify(asctype(a), (res = mkt_text()), pu);
  60:         p_release(res);
  61:     }
  62:     else if ((t_is_list(a_kind) && has_lt(b_kind))
  63:          ||
  64:          (t_is_list(b_kind) && has_lt(a_kind))
  65:     )
  66:     {
  67:         u_unify(asctype(a), asctype(b), &res);
  68:         *pu = mkt_list(res);
  69:     }
  70:     else if (t_is_table(a_kind) && has_lt(b_kind)) {
  71:         u_unify(asctype(a), asctype(b), &res);
  72:         *pu = mkt_table(p_copy(keytype(a)), res);
  73:     }
  74:     else if (t_is_table(b_kind) && has_lt(a_kind)) {
  75:         u_unify(asctype(a), asctype(b), &res);
  76:         *pu = mkt_table(p_copy(keytype(b)), res);
  77:     }
  78:     else if ((t_is_tlt(a_kind) && t_is_lt(b_kind))
  79:          ||
  80:          (t_is_lt(a_kind) && t_is_tlt(b_kind)))
  81:     {
  82:         u_unify(asctype(a), asctype(b), &res);
  83:         *pu = mkt_lt(res);
  84:     }
  85:     else if (t_is_error(a_kind) || t_is_error(b_kind)) {
  86:         *pu = mkt_error();
  87:     }
  88:     else {
  89:         *pu = mkt_error();
  90:         if (cycling)
  91:             badcycle = Yes;
  92:         else
  93:             bad = Yes;
  94:     }
  95: }
  96: 
  97: Hidden Procedure unify_subtypes(a, b, pu)
  98: polytype a, b, *pu;
  99: {
 100:     polytype sa, sb, s;
 101:     intlet nsub, is;
 102: 
 103:     nsub = nsubtypes(a);
 104:     *pu = mkt_polytype(kind(a), nsub);
 105:     for (is = 0; is < nsub; is++) {
 106:         sa = subtype(a, is);
 107:         sb = subtype(b, is);
 108:         u_unify(sa, sb, &s);
 109:         putsubtype(s, *pu, is);
 110:     }
 111: }
 112: 
 113: Forward bool contains();
 114: Forward bool equal_vars();
 115: 
 116: Hidden Procedure substitute_for(a, b, pu)
 117: polytype a, b, *pu;
 118: {
 119:     typekind a_kind, b_kind;
 120:     polytype ta, tb;
 121:     bool ta_is_a, tb_is_b;
 122: 
 123:     a_kind = kind(a);
 124:     b_kind = kind(b);
 125: 
 126:     if (t_is_var(a_kind) && table_has_type_of(a)) {
 127:         ta = type_of(a);
 128:         ta_is_a = No;
 129:     }
 130:     else {
 131:         ta = a;
 132:         ta_is_a = Yes;
 133:     }
 134:     if (t_is_var(b_kind) && table_has_type_of(b)) {
 135:         tb = type_of(b);
 136:         tb_is_b = No;
 137:     }
 138:     else {
 139:         tb = b;
 140:         tb_is_b = Yes;
 141:     }
 142: 
 143:     if (!(ta_is_a && tb_is_b))
 144:         u_unify(ta, tb, pu);
 145:     else if (!t_is_var(a_kind))
 146:         *pu = p_copy(a);
 147:     else
 148:         *pu = p_copy(b);
 149: 
 150:     if (t_is_var(a_kind)) {
 151:         if (contains(*pu, bottom_var(a)))
 152:             textify(a, pu);
 153:     }
 154:     if (t_is_var(b_kind)) {
 155:         if (contains(*pu, bottom_var(b)))
 156:             textify(b, pu);
 157:     }
 158: 
 159:     if (t_is_var(a_kind) && !are_same_types(*pu, a))
 160:         repl_type_of(a, *pu);
 161:     if (t_is_var(b_kind) && !are_same_types(*pu, b))
 162:         repl_type_of(b, *pu);
 163: }
 164: 
 165: Hidden Procedure textify(a, pu)
 166: polytype a, *pu;
 167: {
 168:     polytype ttext, text_hopefully;
 169: 
 170:     ttext = mkt_text();
 171:     cycling = Yes;
 172:     badcycle = No;
 173:     u_unify(*pu, ttext, &text_hopefully);
 174:     if (badcycle EQ No) {
 175:         p_release(text_hopefully);
 176:         u_unify(a, ttext, &text_hopefully);
 177:     }
 178:     if (badcycle EQ No) {
 179:         *pu = ttext;
 180:     }
 181:     else {
 182:         *pu = mkt_error();
 183:         cyctyperr(a);
 184:         p_release(ttext);
 185:     }
 186:     p_release(text_hopefully);
 187:     cycling = No;
 188: }
 189: 
 190: Visible bool contains(u, a) polytype u, a; {
 191:     bool result;
 192: 
 193:     result = No;
 194:     if (t_is_var(kind(u))) {
 195:         if (table_has_type_of(u)) {
 196:             result = contains(type_of(u), a);
 197:         }
 198:     }
 199:     else {
 200:         polytype s;
 201:         intlet is, nsub;
 202:         nsub = nsubtypes(u);
 203:         for (is = 0; is < nsub; is++) {
 204:             s = subtype(u, is);
 205:             if (equal_vars(s, a) || contains(s, a)) {
 206:                 result = Yes;
 207:                 break;
 208:             }
 209:         }
 210:     }
 211:     return (result);
 212: }
 213: 
 214: Visible bool equal_vars(s, a) polytype s, a; {
 215:     return (are_same_types(bottom_var(s), a));
 216: }

Defined functions

Defined variables