```   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:
16: Hidden bool cycling;
18:
19: Visible Procedure unify(a, b, pu)
20: polytype a, b, *pu;
21: {
23:     cycling = No;
24:     setreprtable();
25:     u_unify(a, b, pu);
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)
92:         else
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;
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

contains defined in line 190; used 7 times
substitute_for defined in line 116; used 1 times
• in line 43
textify defined in line 165; used 2 times
u_unify defined in line 30; used 11 times
unify defined in line 19; used 36 times
unify_subtypes defined in line 97; used 1 times
• in line 46

#### Defined variables

bad defined in line 15; used 3 times
badcycle defined in line 17; used 4 times
cycling defined in line 16; used 4 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 2421