![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b2tcU.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint|
Return to b2tcU.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint |
1.1 root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.