![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b2typ.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / new / B / src / bsmall|
Return to b2typ.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / new / B / src / bsmall |
1.1 root 1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
2: /* $Header: b2typ.c,v 1.1 84/06/28 00:49:27 timo Exp $ */
3:
4: /* Type matching */
5: #include "b.h"
6: #include "b1obj.h"
7: #include "b2env.h"
8: #include "b2sem.h"
9: #include "b2typ.h"
10:
11: #define Tnil ((btype) Vnil)
12:
13: Forward btype valtype();
14:
15: /* All the routines in this file are temporary */
16: /* Thus length() and empty() have been put here too */
17:
18: Visible int length(v) value v; {
19: value s= size(v);
20: int len= intval(s);
21: release(s);
22: return len;
23: }
24:
25: Visible bool empty(v) value v; {
26: value s= size(v);
27: bool b= large(s) || intval(s)!=0;
28: release(s);
29: return !b;
30: }
31:
32: Visible btype loctype(l) loc l; {
33: value *ll;
34: if (Is_simploc(l)) {
35: simploc *sl= Simploc(l);
36: if (!in_env(sl->e->tab, sl->i, &ll)) return Tnil;
37: return valtype(*ll);
38: } else if (Is_tbseloc(l)) {
39: tbseloc *tl= Tbseloc(l);
40: btype tt= loctype(tl->R), associate;
41: if (tt == Tnil) return Tnil;
42: if (!empty(tt)) associate= th_of(one, tt);
43: else associate= Tnil;
44: release(tt);
45: return associate;
46: } else if (Is_trimloc(l)) {
47: return mk_text("");
48: } else if (Is_compound(l)) {
49: btype ct= mk_compound(Nfields(l)); intlet k, len= Nfields(l);
50: k_Overfields { put_in_field(loctype(*field(l, k)), &ct, k); }
51: return ct;
52: } else {
53: syserr("loctype asked of non-target");
54: return Tnil;
55: }
56: }
57:
58: Visible btype valtype(v) value v; {
59: if (Is_number(v)) return mk_integer(0);
60: else if (Is_text(v)) return mk_text("");
61: else if (Is_compound(v)) {
62: btype ct= mk_compound(Nfields(v)); intlet k, len= Nfields(v);
63: k_Overfields { put_in_field(valtype(*field(v, k)), &ct, k); }
64: return ct;
65: } else if (Is_ELT(v)) {
66: return mk_elt();
67: } else if (Is_list(v)) {
68: btype tt= mk_elt(), vt, ve;
69: if (!empty(v)) {
70: insert(vt= valtype(ve= min1(v)), &tt);
71: release(vt); release(ve);
72: }
73: return tt;
74: } else if (Is_table(v)) {
75: btype tt= mk_elt(), vk, va;
76: if (!empty(v)) {
77: vk= valtype(*key(v, 0));
78: va= valtype(*assoc(v, 0));
79: replace(va, &tt, vk);
80: release(vk); release(va);
81: }
82: return tt;
83: } else {
84: syserr("valtype called with unknown type");
85: return Tnil;
86: }
87: }
88:
89: Visible must_agree(t, u, m) btype t, u; string m; {
90: intlet k, len;
91: value vt, vu;
92: if (t == Tnil || u == Tnil || t == u) return;
93: if ((Is_number(t) && Is_number(u))
94: || (Is_text(t) && Is_text(u))
95: || (Is_ELT(u) && (Is_ELT(t) || Is_list(t) || Is_table(t)))
96: || (Is_ELT(t) && (Is_ELT(u) || Is_list(u) || Is_table(u)))) return;
97: else if (Is_compound(t) && Is_compound(u)) {
98: if ((len= Nfields(t)) != Nfields(u)) error(m);
99: else k_Overfields { must_agree(*field(t,k), *field(u,k), m); }
100: } else {
101: if (Is_list(t) && Is_list(u)) {
102: if (!empty(t) && !empty(u)) {
103: must_agree(vt= min1(t), vu= min1(u), m);
104: release(vt); release(vu);
105: }
106: } else if (Is_table(t) && Is_table(u)) {
107: if (!empty(t) && !empty(u)) {
108: must_agree(*key(t, 0), *key(u, 0), m);
109: must_agree(*assoc(t, 0), *assoc(u, 0), m);
110: }
111: } else error(m);
112: }
113: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.