![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b3loc.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 b3loc.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: b3loc.c,v 1.4 85/08/27 10:56:45 timo Exp $
5: */
6:
7: /* B locations and environments */
8: #include "b.h"
9: #include "b0con.h"
10: #include "b1obj.h"
11: #include "b3env.h" /* for bndtgs */
12: #include "b3sem.h"
13: #include "b3sou.h" /* for tarvalue() */
14: #include "b3err.h" /* for still_ok */
15:
16: Hidden value* location(l) loc l; {
17: value *ll;
18: if (Is_locloc(l)) {
19: if (!in_env(curnv->tab, l, &ll))
20: error(MESS(3600, "target not initialised"));
21: return ll;
22: } else if (Is_simploc(l)) {
23: simploc *sl= Simploc(l);
24: if (!in_env(sl->e->tab, sl->i, &ll))
25: if (Is_locloc(sl->i))
26: error(MESS(3601, "target not initialised"));
27: else error3(0, sl->i,
28: MESS(3602, " hasn't been initialised"));
29: return ll;
30: } else if (Is_tbseloc(l)) {
31: tbseloc *tl= Tbseloc(l);
32: ll= location(tl->R);
33: if (still_ok) {
34: ll= adrassoc(*ll, tl->K);
35: if (ll == Pnil && still_ok) error(MESS(3603, "key not in table"));
36: }
37: return ll;
38: } else {
39: syserr(MESS(3604, "call of location with improper type"));
40: return (value *) Dummy;
41: }
42: }
43:
44: Hidden Procedure uniquify(l) loc l; {
45: if (Is_simploc(l)) {
46: simploc *sl= Simploc(l);
47: value *ta= &(sl->e->tab), ke= sl->i;
48: uniql(ta);
49: check_location(l);
50: if (still_ok) {
51: if (Is_compound(*ta)) uniql(Field(*ta, intval(ke)));
52: else { value *aa, v;
53: VOID uniq_assoc(*ta, ke);
54: aa= adrassoc(*ta, ke);
55: v= copy(tarvalue(ke, *aa));
56: release(*aa);
57: *aa= v;
58: uniql(aa);
59: }
60: }
61: } else if (Is_tbseloc(l)) {
62: tbseloc *tl= Tbseloc(l);
63: value t, ke;
64: uniquify(tl->R);
65: if (still_ok) { t= *location(tl->R); ke= tl->K; }
66: if (still_ok) {
67: if (!Is_table(t)) error(MESS(3605, "selection on non-table"));
68: else if (empty(t)) error(MESS(3606, "selection on empty table"));
69: else {
70: check_location(l);
71: if (still_ok) VOID uniq_assoc(t, ke);
72: }
73: }
74: } else if (Is_trimloc(l)) { syserr(MESS(3607, "uniquifying trimloc"));
75: } else if (Is_compound(l)) { syserr(MESS(3608, "uniquifying comploc"));
76: } else syserr(MESS(3609, "uniquifying non-location"));
77: }
78:
79: Visible Procedure check_location(l) loc l; {
80: VOID location(l);
81: /* location may produce an error message */
82: }
83:
84: Visible value content(l) loc l; {
85: value *ll= location(l);
86: return still_ok ? copy(*ll) : Vnil;
87: }
88:
89: Visible loc trim_loc(l, v, sign) loc l; value v; char sign; {
90: loc root, res; value text, B, C;
91: if (Is_simploc(l) || Is_tbseloc(l)) {
92: uniquify(l); /* Call tarvalue at proper time */
93: root= l;
94: B= zero; C= zero;
95: } else if (Is_trimloc(l)) {
96: trimloc *rr= Trimloc(l);
97: root= rr->R;
98: B= rr->B; C= rr->C;
99: } else {
100: error(MESS(3610, "trim (@ or |) on target of improper type"));
101: return Lnil;
102: }
103: text= content(root);
104: if (!still_ok);
105: else if (!Is_text(text)) {
106: error(MESS(3611, "in the target t@p or t|p, t does not contain a text"));
107: } else {
108: value s= size(text), w, x, b_plus_c;
109: if (sign == '@') B= sum(B, w=diff(v, one));
110: else { C= sum(C, w=diff(x= diff(s, B), v)); release(x); }
111: release(w);
112: b_plus_c= sum(B, C);
113: if (still_ok && (compare(B,zero)<0 || compare(C,zero)<0
114: || compare(b_plus_c,s)>0))
115: error(MESS(3612, "in the target t@p or t|p, p is out of bounds"));
116: else res= mk_trimloc(root, B, C);
117: if (sign == '@') release(B);
118: else release(C);
119: release(s); release(b_plus_c);
120: }
121: release(text);
122: if (still_ok) return res; else return Lnil;
123: }
124:
125: Visible loc tbsel_loc(R, K) loc R; value K; {
126: if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
127: else error(MESS(3613, "selection on target of improper type"));
128: return Lnil;
129: }
130:
131: Visible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }
132:
133: Visible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }
134:
135: Hidden Procedure put_trim(v, tl) value v; trimloc *tl; {
136: value rr, nn, head, tail, part;
137: value B= tl->B, C= tl->C, len, len_minus_c, tail_start;
138: rr= *location(tl->R);
139: len= size(rr);
140: len_minus_c= diff(len, C); release(len);
141: tail_start= sum(len_minus_c, one); release(len_minus_c);
142: if (compare(B, zero)<0 || compare(C, zero)<0
143: || compare(B, tail_start)>=0)
144: error(MESS(3614, "trim (@ or |) on text location out of bounds"));
145: else {
146: head= curtail(rr, B); /* rr|B */
147: tail= behead(rr, tail_start); /* rr@(#rr-C+1) */
148: part= concat(head, v); release(head);
149: nn= concat(part, tail); release(part); release(tail);
150: put(nn, tl->R); release(nn);
151: }
152: release(tail_start);
153: }
154:
155: Visible Procedure put(v, l) value v; loc l; {
156: if (Is_locloc(l)) {
157: e_replace(v, &curnv->tab, l);
158: } else if (Is_simploc(l)) {
159: simploc *sl= Simploc(l);
160: e_replace(v, &(sl->e->tab), sl->i);
161: } else if (Is_trimloc(l)) {
162: if (!Is_text(v)) error(MESS(3615, "putting non-text in trim (@ or |)"));
163: else put_trim(v, Trimloc(l));
164: } else if (Is_compound(l)) {
165: intlet k, len= Nfields(l);
166: if (!Is_compound(v))
167: error(MESS(3616, "putting non-compound in compound location"));
168: else if (Nfields(v) != Nfields(l))
169: error(MESS(3617, "putting compound in compound location of different length"));
170: else k_Overfields { put(*Field(v, k), *Field(l, k)); }
171: } else if (Is_tbseloc(l)) {
172: tbseloc *tl= Tbseloc(l); value *rootloc;
173: uniquify(tl->R);
174: if (still_ok) {
175: rootloc= location(tl->R);
176: if (still_ok && !Is_table(*rootloc))
177: error(MESS(3621, "selection on non-table"));
178: if (still_ok) replace(v, rootloc, tl->K);
179: }
180: } else error(MESS(3618, "putting in non-target"));
181: }
182:
183: /* Check for correct effect of multiple put-command: catches PUT 1, 2 IN x, x.
184: The assignment cannot be undone, but this is not considered a problem.
185: For trimmed-texts, no checks are made because the language definition
186: itself causes problem (try PUT "abc", "" IN x@2|1, x@3|1). */
187:
188: Hidden bool putck(v, l) value v; loc l; {
189: intlet k, len; value w;
190: if (!still_ok) return No;
191: if (Is_compound(l)) {
192: if (!Is_compound(v) || Nfields(v) != (len= Nfields(l)))
193: return No; /* Severe type error */
194: k_Overfields
195: { if (!putck(*Field(v, k), *Field(l, k))) return No; }
196: return Yes;
197: }
198: if (Is_trimloc(l)) return Yes; /* Don't check trim locations */
199: w= *location(l);
200: /* Unfortunately, this may already cause an error, e.g. after
201: PUT 1, {} IN t[1], t. This can't be helped unless we introduce
202: a flag so that location will shut up. */
203: return still_ok && compare(v, w) == 0;
204: }
205:
206: /* The check can't be called from within put because put is recursive,
207: and so is the check: then, for the inner levels the check would be done
208: twice. Moreover, we don't want to clutter up put, which is called
209: internally in, many places. */
210:
211: Visible Procedure put_with_check(v, l) value v; loc l; {
212: intlet i, k, len; bool ok;
213: put(v, l);
214: if (!still_ok || !Is_compound(l))
215: return; /* Single target can't be wrong */
216: len= Nfields(l); ok= Yes;
217: /* Quick check for putting in all different local targets: */
218: k_Overfields {
219: if (!IsSmallInt(*Field(l, k))) { ok= No; break; }
220: for (i= k-1; i >= 0; --i) {
221: if (*Field(l, i) == *Field(l, k)) { ok= No; break; }
222: }
223: if (!ok) break;
224: }
225: if (ok) return; /* All different local basic-targets */
226: if (!putck(v, l))
227: error(MESS(3619, "putting different values in same location"));
228: }
229:
230:
231: Hidden bool l_exists(l) loc l; {
232: if (Is_simploc(l)) {
233: simploc *sl= Simploc(l);
234: return envassoc(sl->e->tab, sl->i) != Pnil;
235: } else if (Is_trimloc(l)) {
236: error(MESS(3620, "deleting trimmed (@ or |) target"));
237: return No;
238: } else if (Is_compound(l)) {
239: intlet k, len= Nfields(l);
240: k_Overfields { if (!l_exists(*Field(l, k))) return No; }
241: return Yes;
242: } else if (Is_tbseloc(l)) {
243: tbseloc *tl= Tbseloc(l); value *ll;
244: uniquify(tl->R); /* call tarvalue() at proper place */
245: if (still_ok) ll= location(tl->R);
246: if (still_ok && !Is_table(*ll))
247: error(MESS(3621, "selection on non-table"));
248: return still_ok && in_keys(tl->K, *ll);
249: } else {
250: error(MESS(3622, "deleting non-target"));
251: return No;
252: }
253: }
254:
255: /* Delete a location if it exists */
256:
257: Hidden Procedure l_del(l) loc l; {
258: if (Is_simploc(l)) {
259: simploc *sl= Simploc(l);
260: e_delete(&(sl->e->tab), sl->i);
261: } else if (Is_trimloc(l)) {
262: error(MESS(3623, "deleting trimmed (@ or |) target"));
263: } else if (Is_compound(l)) {
264: intlet k, len= Nfields(l);
265: k_Overfields { l_del(*Field(l, k)); }
266: } else if (Is_tbseloc(l)) {
267: tbseloc *tl= Tbseloc(l);
268: value *lc;
269: uniquify(tl->R);
270: if (still_ok) {
271: lc= location(tl->R);
272: if (in_keys(tl->K, *lc)) delete(lc, tl->K);
273: }
274: } else error(MESS(3624, "deleting non-target"));
275: }
276:
277: Visible Procedure l_delete(l) loc l; {
278: if (l_exists(l)) l_del(l);
279: else if (still_ok) error(MESS(3625, "deleting non-existent target"));
280: }
281:
282: Visible Procedure l_insert(v, l) value v; loc l; {
283: value *ll;
284: uniquify(l);
285: if (still_ok) {
286: ll= location(l);
287: if (!Is_list(*ll)) error(MESS(3626, "inserting in non-list"));
288: else insert(v, ll);
289: }
290: }
291:
292: Visible Procedure l_remove(v, l) value v; loc l; {
293: value *ll;
294: uniquify(l);
295: if (still_ok) {
296: ll= location(l);
297: if (!Is_list(*ll)) error(MESS(3627, "removing from non-list"));
298: else if (empty(*ll)) error(MESS(3628, "removing from empty list"));
299: else remove(v, ll);
300: }
301: }
302:
303: /* Warning: choose is only as good as the accuracy of the random-number */
304: /* generator. In particular, for very large values of v, elements will */
305: /* be chosen unfairly. Choose should be rewritten to cope with this */
306:
307: Visible Procedure choose(l, v) loc l; value v; {
308: value w, s, r;
309: if (!Is_tlt(v)) error(MESS(3629, "choosing from non-text, -list or -table"));
310: else if (empty(v)) error(MESS(3630, "choosing from empty text, list or table"));
311: else {
312: /* PUT (floor(random*#v) + 1) th'of v IN l */
313: s= size(v);
314: r= prod(w= random(), s); release(w); release(s);
315: w= floorf(r); release(r);
316: r= sum(w, one); release(w);
317: put(w= th_of(r, v), l); release(w); release(r);
318: }
319: }
320:
321: Visible Procedure draw(l) loc l; {
322: value r= random();
323: put(r, l);
324: release(r);
325: }
326:
327: Visible Procedure bind(l) loc l; {
328: if (*bndtgs != Vnil) {
329: if (Is_simploc(l)) {
330: simploc *ll= Simploc(l);
331: if (!in(ll->i, *bndtgs)) /* kludge */ /* what for? */
332: insert(ll->i, bndtgs);
333: } else if (Is_compound(l)) {
334: intlet k, len= Nfields(l);
335: k_Overfields { bind(*Field(l, k)); }
336: } else error(MESS(3631, "binding non-identifier"));
337: }
338: l_del(l);
339: }
340:
341: Visible Procedure unbind(l) loc l; {
342: if (*bndtgs != Vnil) {
343: if (Is_simploc(l)) {
344: simploc *ll= Simploc(l);
345: if (in(ll->i, *bndtgs))
346: remove(ll->i, bndtgs);
347: } else if (Is_compound(l)) {
348: intlet k, len= Nfields(l);
349: k_Overfields { unbind(*Field(l, k)); }
350: } else error(MESS(3632, "unbinding non-identifier"));
351: }
352: l_del(l);
353: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.