```   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
2: /* \$Header: b2loc.c,v 1.1 84/06/28 00:49:16 timo Exp \$ */
3:
4: /* B locations and environments */
5: #include "b.h"
6: #include "b0con.h"
7: #include "b1obj.h"
8: #include "b2env.h" /* for bndtgs */
9: #include "b2sem.h"
10:
11: Hidden value* location(l) loc l; {
12:     value *ll;
13:     if (Is_simploc(l)) {
14:         simploc *sl= Simploc(l);
15:         if (!in_env(sl->e->tab, sl->i, &ll)) error("target still empty");
16:         return ll;
17:     } else if (Is_tbseloc(l)) {
18:         tbseloc *tl= Tbseloc(l);
19:         ll= adrassoc(*location(tl->R), tl->K);
20:         if (ll == Pnil) error("key not in table");
21:         return ll;
22:     } else {
23:         syserr("call of location with improper type");
24:         return (value *) Dummy;
25:     }
26: }
27:
28: Hidden Procedure uniquify(l) loc l; {
29:     if (Is_simploc(l)) {
30:         simploc *sl= Simploc(l);
31:         value *ta= &(sl->e->tab), ke= sl->i;
32:         uniql(ta);
33:         check_location(l);
34:         uniq_assoc(*ta, ke);
35:     } else if (Is_tbseloc(l)) {
36:         tbseloc *tl= Tbseloc(l);
37:         value t, ke;
38:         uniquify(tl->R);
39:         t= *location(tl->R); ke= tl->K;
40:         if (!Is_table(t)) error("selection on non-table");
41:         if (empty(t)) error("selection on empty table");
42:         check_location(l);
43:         uniq_assoc(t, ke);
44:     } else if (Is_trimloc(l)) { syserr("uniquifying trimloc");
45:     } else if (Is_compound(l)) { syserr("uniquifying comploc");
46:     } else syserr("uniquifying non-location");
47: }
48:
49: Visible Procedure check_location(l) loc l; {
50:     VOID location(l);
51:     /* location may produce an error message */
52: }
53:
54: Visible value content(l) loc l; {
55:     return copy(*location(l));
56: }
57:
58: Visible loc trim_loc(R, B, C) loc R; intlet B, C; {
59:     if (Is_trimloc(R)) {
60:         trimloc *rr= Trimloc(R);
61:         return mk_trimloc(rr->R, B, C);
62:     } else if (Is_simploc(R) || Is_tbseloc(R)) {
63:         return mk_trimloc(R, B, C);
64:     } else {
65:         error("trim (@ or |) on target of improper type");
66:         /* NOTREACHED */
67:     }
68: }
69:
70: Visible loc tbsel_loc(R, K) loc R; value K; {
71:     if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
72:     else error("selection on target of improper type");
73:     /* NOTREACHED */
74: }
75:
76: Visible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }
77:
78: Visible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }
79:
80: Visible Procedure put(v, l) value v; loc l; {
81:     if (Is_simploc(l)) {
82:         simploc *sl= Simploc(l);
83:         e_replace(v, &(sl->e->tab), sl->i);
84:     } else if (Is_trimloc(l)) {
85:         trimloc *tl= Trimloc(l);
86:         value rr, nn, head, tail, part;
87:         intlet B= tl->B, C= tl->C, len;
88:         rr= *location(tl->R);
89:         if (!Is_text(rr)) error("trim target contains no text");
90:         if (!Is_text(v))
91:             error("putting non-text in trim(@ or|) on text location");
92:         len= length(rr);
93:         if (B < 0 || C < 0 || B+C > len)
94:             error("trim (@ or |) on text location out of bounds");
95:         head= trim(rr, 0, len-B); /* rr|B */
96:         tail= trim(rr, len-C, 0); /* rr@(#rr-C+1) */
97:         part= concat(head, v);
98:         nn= concat(part, tail);
99:         put(nn, tl->R);
100:         release(nn); release(head); release(tail); release(part);
101:     } else if (Is_compound(l)) {
102:         intlet k, len= Nfields(l);
103:         if (!Is_compound(v))
104:             error("putting non-compound in compound location");
105:         if (Nfields(v) != Nfields(l))
106:             error("putting compound in compound location of different length");
107:         k_Overfields { put(*field(v, k), *field(l, k)); }
108:     } else if (Is_tbseloc(l)) {
109:         tbseloc *tl= Tbseloc(l);
110:         uniquify(tl->R);
111:         replace(v, location(tl->R), tl->K);
112:     } else error("putting in non-target");
113: }
114:
115: Hidden bool l_exists(l) loc l; {
116:     if (Is_simploc(l)) {
117:         simploc *sl= Simploc(l);
118:         return in_keys(sl->i, sl->e->tab);
119:     } else if (Is_trimloc(l)) {
120:         error("deleting trimmed (@ or |) target");
121:         return No;
122:     } else if (Is_compound(l)) {
123:         intlet k, len= Nfields(l);
124:         k_Overfields { if (!l_exists(*field(l, k))) return No; }
125:         return Yes;
126:     } else if (Is_tbseloc(l)) {
127:         tbseloc *tl= Tbseloc(l);
128:         uniquify(tl->R);
129:         return in_keys(tl->K, *location(tl->R));
130:     } else {
131:         error("deleting non-target");
132:         return No;
133:     }
134: }
135:
136: Hidden Procedure l_del(l) loc l; {
137:     if (Is_simploc(l)) {
138:         simploc *sl= Simploc(l);
139:         if (in_keys(sl->i, sl->e->tab)) {
140:             uniql(&(sl->e->tab)); /*no need?: see delete*/
141:             e_delete(&(sl->e->tab), sl->i);
142:         }
143:     } else if (Is_trimloc(l)) {
144:         error("deleting trimmed (@ or |) target");
145:     } else if (Is_compound(l)) {
146:         intlet k, len= Nfields(l);
147:         k_Overfields { l_del(*field(l, k)); }
148:     } else if (Is_tbseloc(l)) {
149:         tbseloc *tl= Tbseloc(l);
150:         value *lc;
151:         uniquify(tl->R);
152:         lc= location(tl->R);
153:         if (in_keys(tl->K, *lc)) delete(lc, tl->K);
154:     } else error("deleting non-target");
155: }
156:
157: Visible Procedure l_delete(l) loc l; {
158:     if (l_exists(l)) l_del(l);
159:     else error("deleting non-existent target");
160: }
161:
162: Visible Procedure l_insert(v, l) value v; loc l; {
163:     value *ll;
164:     uniquify(l);
165:     ll= location(l);
166:     insert(v, ll);
167: }
168:
169: Visible Procedure l_remove(v, l) value v; loc l; {
170:     uniquify(l);
171:     remove(v, location(l));
172: }
173:
174: Visible Procedure choose(l, v) loc l; value v; {
175:     value w, s, r;
176:     if (!Is_tlt(v)) error("choosing from non-text, -list or -table");
177:     s= size(v);
178:     if (compare(s, zero) == 0)
179:         error("choosing from empty text, list or table");
180:     /* PUT (floor(random*#v) + 1) th'of v IN l */
181:     r= prod(w= random(), s); release(w); release(s);
182:     w= floorf(r); release(r);
183:     r= sum(w, one); release(w);
184:     put(w= th_of(r, v), l); release(w);
185: }
186:
187: Visible Procedure draw(l) loc l; {
188:     value r= random();
189:     put(r, l);
190:     release(r);
191: }
192:
193: Visible Procedure bind(l) loc l; {
194:     if (Is_simploc(l)) {
195:         simploc *ll= Simploc(l);
196:         if (!in(ll->i, *bndtgs)) /* kludge */
197:             insert(ll->i, bndtgs);
198:     } else if (Is_compound(l)) {
199:         intlet k, len= Nfields(l);
200:         k_Overfields { bind(*field(l, k)); }
201:     } else if (Is_trimloc(l)) {
202:         pprerr("t@p or t|p not allowed in ranger", "");
203:     } else if (Is_tbseloc(l)) {
204:         pprerr("t[e] not allowed in ranger", "");
205:     } else error("binding non-identifier");
206: }
```

#### Defined functions

check_location defined in line 49; used 3 times
choose defined in line 174; used 1 times
content defined in line 54; used 3 times
draw defined in line 187; used 1 times
global_loc defined in line 78; used 3 times
l_del defined in line 136; used 2 times
l_delete defined in line 157; used 1 times
l_exists defined in line 115; used 2 times
l_insert defined in line 162; used 1 times
l_remove defined in line 169; used 1 times
location defined in line 11; used 10 times
uniquify defined in line 28; used 6 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 2906