```   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
2:
3: /*
4:   \$Header: b3typ.c,v 1.4 85/08/22 16:59:46 timo Exp \$
5: */
6:
7: /* Type matching */
8: #include "b.h"
9: #include "b1obj.h"
10: #include "b3env.h"
11: #include "b3sem.h"
12: #include "b3typ.h"
13:
14: #define Tnil ((btype) Vnil)
15:
16: Forward btype valtype();
17:
18: /* All the routines in this file are temporary */
19: /* Thus length() has been put here too */
20:
21: Visible int length(v) value v; {
22:     value s= size(v);
23:     int len= intval(s);
24:     release(s);
25:     return len;
26: }
27:
28: Visible btype loctype(l) loc l; {
29:     value *ll;
30:     if (Is_simploc(l)) {
31:         simploc *sl= Simploc(l);
32:         if (!in_env(sl->e->tab, sl->i, &ll)) return Tnil;
33:         return valtype(*ll);
34:     } else if (Is_tbseloc(l)) {
35:         tbseloc *tl= Tbseloc(l);
36:         btype tt= loctype(tl->R), associate;
37:         if (tt == Tnil) return Tnil;
38:         if (!empty(tt)) associate= th_of(one, tt);
39:         else associate= Tnil;
40:         release(tt);
41:         return associate;
42:     } else if (Is_trimloc(l)) {
43:         return mk_text("");
44:     } else if (Is_compound(l)) {
45:         btype ct= mk_compound(Nfields(l)); intlet k, len= Nfields(l);
46:         k_Overfields { *Field(ct, k)= loctype(*Field(l, k)); }
47:         return ct;
48:     } else {
49:         syserr(MESS(4200, "loctype asked of non-target"));
50:         return Tnil;
51:     }
52: }
53:
54: Visible btype valtype(v) value v; {
55:     if (Is_number(v)) return mk_integer(0);
56:     else if (Is_text(v)) return mk_text("");
57:     else if (Is_compound(v)) {
58:         btype ct= mk_compound(Nfields(v)); intlet k, len= Nfields(v);
59:         k_Overfields { *Field(ct, k)= valtype(*Field(v, k)); }
60:         return ct;
61:     } else if (Is_ELT(v)) {
62:         return mk_elt();
63:     } else if (Is_list(v)) {
64:         btype tt= mk_elt(), vt, ve;
65:         if (!empty(v)) {
66:             insert(vt= valtype(ve= min1(v)), &tt);
67:             release(vt); release(ve);
68:         }
69:         return tt;
70:     } else if (Is_table(v)) {
71:         btype tt= mk_elt(), vk, va;
72:         if (!empty(v)) {
73:             vk= valtype(*key(v, 0));
74:             va= valtype(*assoc(v, 0));
75:             replace(va, &tt, vk);
76:             release(vk); release(va);
77:         }
78:         return tt;
79:     } else {
80:         syserr(MESS(4201, "valtype called with unknown type"));
81:         return Tnil;
82:     }
83: }
84:
85: Visible Procedure must_agree(t, u, m) btype t, u; int m; {
86:     intlet k, len;
87:     value vt, vu;
88:     if (t == Tnil || u == Tnil || t == u) return;
89:     if (Is_number(t) && Is_number(u)) return;
90:     if (Is_text(t) && Is_text(u)) return;
91:     if (Is_ELT(u) && (Is_ELT(t) || Is_list(t) || Is_table(t))) return;
92:     if (Is_ELT(t) && (             Is_list(u) || Is_table(u))) return;
93:     if (Is_compound(t) && Is_compound(u)) {
94:         if ((len= Nfields(t)) != Nfields(u)) error(m);
95:         else k_Overfields { must_agree(*Field(t,k), *Field(u,k), m); }
96:     } else {
97:         if (Is_list(t) && Is_list(u)) {
98:             if (!empty(t) && !empty(u)) {
99:                 must_agree(vt= min1(t), vu= min1(u), m);
100:                 release(vt); release(vu);
101:             }
102:         } else if (Is_table(t) && Is_table(u)) {
103:             if (!empty(t) && !empty(u)) {
104:                 must_agree(*key(t, 0), *key(u, 0), m);
105:                 must_agree(*assoc(t, 0), *assoc(u, 0), m);
106:             }
107:         } else error(m);
108:     }
109: }
```

#### Defined functions

loctype defined in line 28; used 3 times
must_agree defined in line 85; used 5 times
valtype defined in line 54; used 12 times

#### Defined macros

Tnil defined in line 14; used 8 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 1077