![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b2loc.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 / bsmall|
Return to b2loc.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bsmall |
1.1 root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.