```   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; {
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: }
```

#### Defined functions

deltypetable defined in line 291; used 1 times
has_lt defined in line 245; used 5 times
ident defined in line 82; used 12 times
initpol defined in line 297; used 1 times
kind defined in line 62; used 54 times
mkt_polytype defined in line 49; used 11 times
mkt_var defined in line 141; used 5 times
p_release defined in line 164; used 94 times
putsubtype defined in line 58; used 7 times
repl_type_of defined in line 258; used 2 times
type_of defined in line 266; used 5 times
usetypetable defined in line 287; used 1 times

#### Defined variables

nnewvar defined in line 150; used 5 times
typeof defined in line 256; used 6 times

#### Defined macros

Asc defined in line 24; used 5 times
Id defined in line 23; used 2 times
Ident defined in line 29; used 6 times
Key defined in line 25; used 2 times
Kin defined in line 21; used 3 times
Kind defined in line 27; used 8 times
Psubtypes defined in line 28; used 5 times
Sub defined in line 22; used 3 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 3242