![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b2tcP.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 b2tcP.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: b2tcP.c,v 1.4 85/08/22 16:57:02 timo Exp $
5: */
6:
7: /* polytype representation */
8:
9: #include "b.h"
10: #include "b1obj.h"
11: #include "b2tcP.h"
12:
13: /* A polytype is a compound with two fields.
14: * The first field is a B text, and holds the typekind.
15: * If the typekind is 'Variable', the second field is
16: * a B text, holding the identifier of the variable;
17: * otherwise, the second field is a compound of sub(poly)types,
18: * indexed from 0 to one less then the number of subtypes.
19: */
20:
21: #define Kin 0
22: #define Sub 1
23: #define Id Sub
24: #define Asc 0
25: #define Key 1
26:
27: #define Kind(u) ((typekind) *Field((value) (u), Kin))
28: #define Psubtypes(u) (Field((value) (u), Sub))
29: #define Ident(u) (*Field((value) (u), Id))
30:
31: typekind var_kind;
32: typekind num_kind;
33: typekind tex_kind;
34: typekind lis_kind;
35: typekind tab_kind;
36: typekind com_kind;
37: typekind t_n_kind;
38: typekind l_t_kind;
39: typekind tlt_kind;
40: typekind err_kind;
41:
42: polytype num_type;
43: polytype tex_type;
44: polytype err_type;
45: polytype t_n_type;
46:
47: /* Making, setting and accessing (the fields of) polytypes */
48:
49: Visible polytype mkt_polytype(k, nsub) typekind k; intlet nsub; {
50: value u;
51:
52: u = mk_compound(2);
53: *Field(u, Kin)= copy((value) k);
54: *Field(u, Sub)= mk_compound(nsub);
55: return ((polytype) u);
56: }
57:
58: Procedure putsubtype(sub, u, isub) polytype sub, u; intlet isub; {
59: *Field(*Psubtypes(u), isub)= (value) sub;
60: }
61:
62: typekind kind(u) polytype u; {
63: return (Kind(u));
64: }
65:
66: intlet nsubtypes(u) polytype u; {
67: return (Nfields(*Psubtypes(u)));
68: }
69:
70: polytype subtype(u, i) polytype u; intlet i; {
71: return ((polytype) *Field(*Psubtypes(u), i));
72: }
73:
74: polytype asctype(u) polytype u; {
75: return (subtype(u, Asc));
76: }
77:
78: polytype keytype(u) polytype u; {
79: return (subtype(u, Key));
80: }
81:
82: value ident(u) polytype u; {
83: return (Ident(u));
84: }
85:
86: /* making new polytypes */
87:
88: polytype mkt_number() {
89: return(p_copy(num_type));
90: }
91:
92: polytype mkt_text() {
93: return(p_copy(tex_type));
94: }
95:
96: polytype mkt_tn() {
97: return(p_copy(t_n_type));
98: }
99:
100: polytype mkt_error() {
101: return(p_copy(err_type));
102: }
103:
104: polytype mkt_list(s) polytype s; {
105: polytype u;
106:
107: u = mkt_polytype(lis_kind, 1);
108: putsubtype(s, u, Asc);
109: return (u);
110: }
111:
112: polytype mkt_table(k, a) polytype k, a; {
113: polytype u;
114:
115: u = mkt_polytype(tab_kind, 2);
116: putsubtype(a, u, Asc);
117: putsubtype(k, u, Key);
118: return (u);
119: }
120:
121: polytype mkt_lt(s) polytype s; {
122: polytype u;
123:
124: u = mkt_polytype(l_t_kind, 1);
125: putsubtype(s, u, Asc);
126: return (u);
127: }
128:
129: polytype mkt_tlt(s) polytype s; {
130: polytype u;
131:
132: u = mkt_polytype(tlt_kind, 1);
133: putsubtype(s, u, Asc);
134: return (u);
135: }
136:
137: polytype mkt_compound(nsub) intlet nsub; {
138: return mkt_polytype(com_kind, nsub);
139: }
140:
141: polytype mkt_var(id) value id; {
142: polytype u;
143:
144: u = mk_compound(2);
145: *Field(u, Kin)= copy((value) var_kind);
146: *Field(u, Id)= id;
147: return (u);
148: }
149:
150: Hidden value nnewvar;
151:
152: polytype mkt_newvar() {
153: value v;
154: v = sum(nnewvar, one);
155: release(nnewvar);
156: nnewvar = v;
157: return mkt_var(convert(nnewvar, No, No));
158: }
159:
160: polytype p_copy(u) polytype u; {
161: return((polytype) copy((polytype) u));
162: }
163:
164: Procedure p_release(u) polytype u; {
165: release((polytype) u);
166: }
167:
168: /* predicates */
169:
170: bool are_same_types(u, v) polytype u, v; {
171: if (compare((value) Kind(u), (value) Kind(v)) NE 0)
172: return (No);
173: else if (t_is_var(Kind(u)))
174: return (compare(Ident(u), Ident(v)) EQ 0);
175: else
176: return (
177: (nsubtypes(u) EQ nsubtypes(v))
178: &&
179: (compare(*Psubtypes(u), *Psubtypes(v)) EQ 0)
180: );
181: }
182:
183: bool have_same_structure(u, v) polytype u, v; {
184: return(
185: (compare((value) Kind(u), (value) Kind(v)) EQ 0)
186: &&
187: nsubtypes(u) EQ nsubtypes(v)
188: );
189: }
190:
191: bool t_is_number(kind) typekind kind; {
192: return (compare((value) kind, (value) num_kind) EQ 0 ? Yes : No);
193: }
194:
195: bool t_is_text(kind) typekind kind; {
196: return (compare((value) kind, (value) tex_kind) EQ 0 ? Yes : No);
197: }
198:
199: bool t_is_tn(kind) typekind kind; {
200: return (compare((value) kind, (value) t_n_kind) EQ 0 ? Yes : No);
201: }
202:
203: bool t_is_error(kind) typekind kind; {
204: return (compare((value) kind, (value) err_kind) EQ 0 ? Yes : No);
205: }
206:
207: bool t_is_list(kind) typekind kind; {
208: return (compare((value) kind, (value) lis_kind) EQ 0 ? Yes : No);
209: }
210:
211: bool t_is_table(kind) typekind kind; {
212: return (compare((value) kind, (value) tab_kind) EQ 0 ? Yes : No);
213: }
214:
215: bool t_is_lt(kind) typekind kind; {
216: return (compare((value) kind, (value) l_t_kind) EQ 0 ? Yes : No);
217: }
218:
219: bool t_is_tlt(kind) typekind kind; {
220: return (compare((value) kind, (value) tlt_kind) EQ 0 ? Yes : No);
221: }
222:
223: bool t_is_compound(kind) typekind kind; {
224: return (compare((value) kind, (value) com_kind) EQ 0 ? Yes : No);
225: }
226:
227: bool t_is_var(kind) typekind kind; {
228: return (compare((value) kind, (value) var_kind) EQ 0 ? Yes : No);
229: }
230:
231: bool has_number(kind) typekind kind; {
232: if (compare(kind, num_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
233: return (Yes);
234: else
235: return (No);
236: }
237:
238: bool has_text(kind) typekind kind; {
239: if (compare(kind, tex_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
240: return (Yes);
241: else
242: return (No);
243: }
244:
245: bool has_lt(kind) typekind kind; {
246: if (compare(kind, l_t_kind) EQ 0 || compare(kind, tlt_kind) EQ 0)
247: return (Yes);
248: else
249: return (No);
250: }
251:
252: /* The table "typeof" maps the identifiers of the variables (B texts)
253: * to polytypes.
254: */
255:
256: value typeof;
257:
258: Procedure repl_type_of(u, p) polytype u, p; {
259: replace((value) p, &typeof, Ident(u));
260: }
261:
262: bool table_has_type_of(u) polytype u; {
263: return(in_keys(Ident(u), typeof));
264: }
265:
266: polytype type_of(u) polytype u; {
267: return((polytype) *adrassoc(typeof, Ident(u)));
268: }
269:
270: polytype bottom_var(u) polytype u; {
271: polytype b;
272:
273: if (!t_is_var(Kind(u)))
274: return (u);
275: /* Kind(u) == Variable */
276: while (table_has_type_of(u)) {
277: b = type_of(u);
278: if (t_is_var(Kind(b)))
279: u = b;
280: else
281: break;
282: }
283: /* Kind(u) == Variable && !table_has_type_of(u)*/
284: return (u);
285: }
286:
287: Visible Procedure usetypetable(t) value t; {
288: typeof = t;
289: }
290:
291: Visible Procedure deltypetable() {
292: release(typeof);
293: }
294:
295: /* init */
296:
297: Visible Procedure initpol() {
298: num_kind = mk_text("Number");
299: num_type = mkt_polytype(num_kind, 0);
300: tex_kind = mk_text("Text");
301: tex_type = mkt_polytype(tex_kind, 0);
302: t_n_kind = mk_text("TN");
303: t_n_type = mkt_polytype(t_n_kind, 0);
304: err_kind = mk_text("Error");
305: err_type = mkt_polytype(err_kind, 0);
306:
307: lis_kind = mk_text("List");
308: tab_kind = mk_text("Table");
309: com_kind = mk_text("Compound");
310: l_t_kind = mk_text("LT");
311: tlt_kind = mk_text("TLT");
312: var_kind = mk_text("Variable");
313:
314: nnewvar = zero;
315: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.