![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b1lta.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 b1lta.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: b1lta.c,v 1.4 85/08/22 16:49:05 timo Exp $
5: */
6:
7: /* Access and update lists and tables */
8:
9: #include "b.h"
10: #include "b0con.h"
11: #include "b1obj.h"
12: #ifndef INTEGRATION
13: #include "b1btr.h"
14: #include "b1val.h"
15: #include "b3err.h"
16: #include "b3scr.h" /* For at_nwl */
17: #endif
18: #include "b1tlt.h"
19:
20: #ifndef INTEGRATION
21:
22: #ifndef DEBUG
23: #define check(v, where) /*nothing*/
24: #endif DEBUG
25:
26: #define IsInner(p) (Flag(p) == Inner)
27: #define IsBottom(p) (Flag(p) == Bottom)
28:
29: #define _Pxitm(p, l, iw) (IsInner(p) ? Piitm(p, l, iw) : Pbitm(p, l, iw))
30:
31: Hidden itemptr Pxitm(p, l, iw) btreeptr p; intlet l, iw; {
32: return _Pxitm(p, l, iw);
33: }
34:
35: #define Inil ((itemptr)0)
36:
37: #define Incr(p, n) ((p) += (n))
38:
39: Visible width itemwidth[4]= {Cw, Lw, Tw, Kw};
40:
41: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
42:
43: typedef struct {
44: btreeptr s_ptr;
45: int s_lim;
46: } finger[Maxheight], *fingertip;
47:
48: #define Snil ((fingertip)0)
49:
50: #define Push(s, p, l) ((s)->s_ptr= (p), ((s)->s_lim= (l)), (s)++)
51: #define Top(s, p, l) ((p)= ((s)-1)->s_ptr, (l)= ((s)-1)->s_lim)
52: #define Drop(s) (--(s))
53: #define Pop(s, p, l) (--(s), (p)= (s)->s_ptr, (l)= (s)->s_lim)
54: /* Pop(s, p, l) is equivalent to Top(s, p, l); Drop(s) */
55:
56: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
57:
58: Visible fingertip unzip(p, at, s) btreeptr p; int at; fingertip s; {
59: int syz; intlet l;
60: if (p == Bnil) return s;
61: for (;;) {
62: if (at <= 0) l= 0;
63: else if (at >= Size(p)) l= Lim(p);
64: else if (IsInner(p)) {
65: l= 0;
66: while (at > (syz= Size(Ptr(p, l)))) {
67: ++l;
68: at -= syz+1;
69: }
70: }
71: else if (at >= Lim(p)) l= Lim(p) - 1; /* for Irange/Crange */
72: else l= at; /* Assume Bottom */
73: Push(s, p, l);
74: if (!IsInner(p)) break;
75: p= Ptr(p, l);
76: }
77: return s;
78: }
79:
80: Visible Procedure cpynptrs(to, from, n) btreeptr *to, *from; int n; {
81: while (--n >= 0) {
82: *to= copybtree(*from);
83: Incr(to, 1);
84: Incr(from, 1);
85: }
86: }
87:
88: Visible int movnptrs(to, from, n) btreeptr *to, *from; int n; {
89: int syz= 0; /* Collects sum of sizes */
90: while (--n >= 0) {
91: *to= *from;
92: syz += Size(*from);
93: Incr(to, 1);
94: Incr(from, 1);
95: }
96: return syz;
97: }
98:
99: /* The following two routines may prove machine-dependent when moving
100: N pointers is not equivalent to moving N*sizeof(pointer) characters.
101: Also, the latter may be slower. */
102:
103: Visible Procedure movnitms(to, from, n, iw) itemptr to, from; intlet n, iw; {
104: register char *t= (char *)to, *f= (char *)from;
105: n *= iw;
106: while (--n >= 0) *t++ = *f++;
107: }
108:
109: Hidden Procedure shift(p, l, iw) btreeptr p; intlet l, iw; {
110: /* Move items and pointers from l upwards one to the right */
111: btreeptr *to, *from;
112: intlet n= (Lim(p)-l) * iw; bool inner= IsInner(p);
113: char *f= (char *) Pxitm(p, Lim(p), iw);
114: char *t= f+iw;
115: while (--n >= 0) *--t = *--f;
116: if (inner) {
117: from= &Ptr(p, Lim(p));
118: to= from;
119: Incr(to, 1);
120: n= Lim(p)-l;
121: while (--n >= 0) {
122: *to= *from;
123: Incr(to, -1);
124: Incr(from, -1);
125: }
126: }
127: }
128:
129: Visible Procedure cpynitms(to, from, n, it) itemptr to, from; intlet n, it; {
130: intlet i, iw= Itemwidth(it);
131: movnitms(to, from, n, iw);
132: switch (it) {
133: case Lt:
134: case Kt:
135: case Tt:
136: for (i= 0; i < n; ++i) {
137: copy(Keyval(to));
138: if (it == Tt) copy(Ascval(to));
139: else if (it == Kt) Ascval(to)= Vnil;
140: to= (itemptr) ((char*)to + iw);
141: }
142: }
143: }
144:
145: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
146:
147: /* Uflow uses a character array to hold the items. This may be wrong. */
148:
149: Visible Procedure uflow(n, l, cbuf, pbuf, it)
150: intlet n, l; char cbuf[]; btreeptr pbuf[]; intlet it; {
151: char ncbuf[3*Maxbottom*sizeof(item)], *cp= ncbuf;
152: btreeptr npbuf[3*Maxinner], *pp= npbuf, q;
153: intlet iw= Itemwidth(it); bool inner= IsInner(pbuf[0]);
154: intlet i, j, k, nn, l1= l>0 ? l-1 : l, l2= l<n ? l+1 : l;
155: for (i= l1; i <= l2; ++i) {
156: q= pbuf[i]; j= Lim(q);
157: cpynitms((itemptr)cp, Pxitm(q, 0, iw), j, it);
158: cp += j*iw;
159: if (inner) {
160: cpynptrs(pp, &Ptr(q, 0), j+1);
161: Incr(pp, j+1);
162: }
163: if (i < l2) {
164: movnitms((itemptr)cp, (itemptr)(cbuf+i*iw), 1, iw);
165: cp += iw;
166: }
167: relbtree(q, it);
168: }
169: nn= (cp-ncbuf)/iw;
170: k= inner ? Maxinner : Maxbottom;
171: if (nn <= k) k= 1;
172: else if (nn <= 2*k) k= 2;
173: else k= 3;
174: /* (k <= l2-l1+1) */
175: cp= ncbuf; pp= npbuf;
176: for (i= 0; i < k; ++i) {
177: if (i > 0) {
178: movnitms((itemptr)(cbuf+(l1+i-1)*iw), (itemptr)cp, 1, iw);
179: cp += iw;
180: --nn;
181: }
182: pbuf[l1+i]= q= grabbtreenode(inner ? Inner : Bottom, it);
183: Lim(q)= Size(q)= j= nn/(k-i); nn -= j;
184: movnitms(Pxitm(q, 0, iw), (itemptr)cp, j, iw);
185: cp += j*iw;
186: if (inner) {
187: Size(q) += movnptrs(&Ptr(q, 0), pp, j+1);
188: Incr(pp, j+1);
189: }
190: }
191: if (k < l2-l1+1) {
192: movnitms((itemptr)(cbuf+(l1+k-1)*iw), (itemptr)(cbuf+l2*iw), n-l2, iw);
193: VOID movnptrs(pbuf+l1+k, pbuf+l2+1, n-l2);
194: n -= l2-l1+1 - k;
195: }
196: return n;
197: }
198:
199: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
200:
201: /* Low level access routines */
202:
203: /* Meaning of 'flags' parameter to searchkey: */
204: #define NORMAL 0
205: #define UNIQUE 1 /* uniquify visited nodes */
206: #define DYAMAX 2 /* special for dyadic max (= previous element) */
207: #define DYAMIN 4 /* special for dyadic min (= next element) */
208:
209: Hidden bool searchkey(v, pw, flags, ft)
210: value v, *pw; int flags; fingertip *ft; {
211: btreeptr p, *pp;
212: intlet l, mid, h, it= Itemtype(*pw), iw= Itemwidth(it);
213: bool inner; relation r;
214: pp= &Root(*pw);
215: if (*pp == Bnil) return No;
216: if (flags&UNIQUE) {
217: killranges(pw);
218: uniql(pw);
219: pp= &Root(*pw);
220: }
221: for (;;) {
222: if (flags&UNIQUE) uniqlbtreenode(pp, it);
223: p= *pp;
224: inner= IsInner(p);
225: l= 0; h= Lim(p);
226: r= 1; /* For the (illegal?) case that there are no items */
227: while (l < h) { /* Binary search in {l..h-1} */
228: mid= (l+h)/2;
229: r= compare(v, Keyval(Pxitm(p, mid, iw)));
230: if (!comp_ok) return No;
231: if (r == 0) { /* Found it */
232: if (flags&(DYAMIN|DYAMAX)) {
233: /* Pretend not found */
234: if (flags&DYAMIN) r= 1;
235: else r= -1;
236: }
237: else { /* Normal case, report success */
238: l= mid;
239: break;
240: }
241: }
242: if (r < 0) h= mid; /* Continue in {l..mid-1} */
243: else if (r > 0) l= mid+1; /* Cont. in {mid+1..h-i} */
244: }
245: Push(*ft, p, l);
246: if (r == 0) return Yes;
247: if (!inner) {
248: switch (Flag(p)) {
249: case Irange: return h > 0 && l < Lim(p) && integral(v);
250: case Crange: return h > 0 && l < Lim(p) && character(v);
251: default: case Bottom: return No;
252: }
253: }
254: pp= &Ptr(p, l);
255: }
256: }
257:
258: Hidden Procedure killranges(pv) value *pv; {
259: btreeptr p= Root(*pv);
260: if (p == Bnil) return;
261: switch (Flag(p)) {
262: case Crange: killCrange(p, pv); break;
263: case Irange: killIrange(p, pv); break;
264: }
265: }
266:
267: Hidden Procedure killCrange(p, pv) btreeptr p; value *pv; {
268: value w; intlet lwbchar= Lwbchar(p), upbchar= Upbchar(p);
269: release(*pv);
270: *pv= mk_elt();
271: do {
272: w= mkchar(lwbchar);
273: insert(w, pv);
274: release(w);
275: } while (++lwbchar <= upbchar);
276: }
277:
278: Hidden Procedure killIrange(p, pv) btreeptr p; value *pv; {
279: value w, lwb= copy(Lwbval(p)), upb= copy(Upbval(p));
280: release(*pv);
281: *pv= mk_elt();
282: do {
283: insert(lwb, pv);
284: if (compare(lwb, upb) >= 0) break;
285: w= lwb;
286: lwb= sum(lwb, one);
287: release(w);
288: } while (still_ok);
289: release(lwb);
290: release(upb);
291: }
292:
293: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
294:
295: Hidden btreeptr rem(f, ft, it) fingertip f, ft; intlet it; {
296: btreeptr p, q, *pp; itemptr ip; intlet l, iw= Itemwidth(it);
297: bool inner, underflow;
298: Pop(ft, p, l);
299: inner= IsInner(p);
300: if (!inner) ip= Pbitm(p, l, iw);
301: else {
302: ip= Piitm(p, l, iw);
303: do {
304: Push(ft, p, l);
305: uniqlbtreenode(pp= &Ptr(p, l), it);
306: p= *pp;
307: l= Lim(p);
308: } while (IsInner(p));
309: inner= No;
310: l -= 2; /* So the movnitms below works fine */
311: }
312: release(Keyval(ip));
313: if (it == Tt || it == Kt) release(Ascval(ip));
314: --Lim(p);
315: movnitms(ip, Pbitm(p, l+1, iw), Lim(p)-l, iw);
316: for (;;) {
317: underflow= Lim(p) < (inner ? Mininner : Minbottom);
318: --Size(p);
319: if (ft == f) break;
320: Pop(ft, p, l);
321: if (underflow)
322: Lim(p)= uflow(Lim(p), l, (string)Piitm(p, 0, iw), &Ptr(p, 0), it);
323: inner= Yes;
324: }
325: if (Lim(p) == 0) { /* Reduce tree level */
326: q= p;
327: p= inner ? copybtree(Ptr(p, 0)) : Bnil;
328: relbtree(q, it);
329: }
330: return p;
331: }
332:
333: Hidden btreeptr ins(ip, f, ft, it) itemptr ip; fingertip f, ft; intlet it; {
334: item new, old; btreeptr p, q= Bnil, pq, oldq, *pp;
335: intlet l, iw= Itemwidth(it), nn, np, nq; bool inner, overflow;
336: if (ft == f) {
337: /* unify with rest? */
338: p= grabbtreenode(Bottom, it);
339: movnitms(Pbitm(p, 0, iw), ip, 1, iw);
340: Lim(p)= Size(p)= 1;
341: return p;
342: }
343: Pop(ft, p, l);
344: while (IsInner(p)) {
345: Push(ft, p, l);
346: uniqlbtreenode(pp= &Ptr(p, l), it);
347: p= *pp;
348: l= Lim(p);
349: }
350: overflow= Yes; inner= No;
351: for (;;) {
352: pq= p;
353: if (overflow) {
354: oldq= q;
355: movnitms(&old, ip, 1, iw);
356: ip= &new;
357: overflow= Lim(p) == (inner ? Maxinner : Maxbottom);
358: if (overflow) {
359: nn= Lim(p); np= nn/2; nq= nn-np-1;
360: q= grabbtreenode(inner ? Inner : Bottom, it);
361: Size(q)= Lim(q)= nq;
362: movnitms(&new, Pxitm(p, np, iw), 1, iw);
363: movnitms(Pxitm(q, 0, iw), Pxitm(p, np+1, iw), nq, iw);
364: if (inner)
365: Size(q) += movnptrs(&Ptr(q, 0), &Ptr(p, np+1), nq+1);
366: Lim(p)= np;
367: Size(p) -= Size(q)+1;
368: if (l > np) {
369: l -= np+1;
370: pq= q;
371: }
372: }
373: shift(pq, l, iw);
374: movnitms(Pxitm(pq, l, iw), &old, 1, iw);
375: ++Lim(pq);
376: if (inner) {
377: Size(p) -= Size(oldq);
378: Size(pq) += movnptrs(&Ptr(pq, l+1), &oldq, 1);
379: }
380: }
381: ++Size(pq);
382: if (ft == f) break;
383: Pop(ft, p, l);
384: inner= Yes;
385: }
386: if (overflow)
387: p= mknewroot(p, ip, q, it);
388: return p;
389: }
390:
391: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
392:
393: /* Tables */
394:
395: Visible Procedure replace(a, pt, k) value a, *pt, k; {
396: item new; finger f; fingertip ft= f; btreeptr p; value *pp;
397: intlet it, iw, l;
398: check(*pt, " (replace in)");
399: if (Is_ELT(*pt)) { (*pt)->type= Tab; Itemtype(*pt)= Tt; }
400: it= Itemtype(*pt);
401: if (searchkey(k, pt, UNIQUE, &ft)) {
402: iw= Itemwidth(it);
403: Pop(ft, p, l);
404: pp= &Ascval(Pxitm(p, l, iw));
405: release(*pp);
406: *pp= copy(a);
407: }
408: else {
409: if (!comp_ok) return;
410: Keyval(&new)= copy(k); Ascval(&new)= copy(a);
411: Root(*pt)= ins(&new, f, ft, it);
412: }
413: check(*pt, " (replace out)");
414: }
415:
416: Visible /*bool*/ delete(pt, k) value *pt, k; {
417: finger f; fingertip ft= f; intlet it= Itemtype(*pt);
418: check(*pt, " (delete in)");
419: if (!searchkey(k, pt, UNIQUE, &ft)) return No;
420: Root(*pt)= rem(f, ft, it);
421: check(*pt, " (delete out)");
422: return Yes;
423: }
424:
425: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
426:
427: /* Lists */
428:
429: Visible Procedure insert(v, pl) value v, *pl; {
430: item new; finger f; fingertip ft= f; intlet it= Itemtype(*pl);
431: check(*pl, " (insert in)");
432: if (Is_ELT(*pl)) (*pl)->type= Lis;
433: VOID searchkey(v, pl, UNIQUE, &ft);
434: if (!comp_ok) return;
435: Keyval(&new)= copy(v); Ascval(&new)= Vnil;
436: Root(*pl)= ins(&new, f, ft, it);
437: check(*pl, " (insert out)");
438: }
439:
440: Visible Procedure remove(v, pl) value v, *pl; {
441: if (!delete(pl, v) && still_ok)
442: error(MESS(100, "removing non-existent list entry"));
443: }
444:
445: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
446:
447: /* Miscellaneous accesses */
448:
449: Hidden itemptr findkey(key, pv, flags) value key, *pv; int flags; {
450: finger f; fingertip ft= f; btreeptr p;
451: intlet it= Itemtype(*pv), iw= Itemwidth(it), l;
452: if (!searchkey(key, pv, flags, &ft)) return Inil;
453: Pop(ft, p, l);
454: return Pxitm(p, l, iw);
455: }
456:
457: Visible value associate(t, k) value t, k; { /* t[k] */
458: itemptr ip;
459: if (!Is_table(t)) {
460: error(MESS(101, "in t[k], t is not a table"));
461: return Vnil;
462: }
463: ip= findkey(k, &t, NORMAL);
464: if (!ip) {
465: if (still_ok) /* Could be type error; then shut up! */
466: error(MESS(102, "key not in table"));
467: return Vnil;
468: }
469: return copy(Ascval(ip));
470: }
471:
472: Visible value* adrassoc(t, k) value t, k; { /* &t[k] */
473: itemptr ip= findkey(k, &t, NORMAL);
474: if (!ip) return Pnil;
475: return &Ascval(ip);
476: }
477:
478: Visible bool uniq_assoc(t, k) value t, k; { /* uniql(&t[k]) */
479: itemptr ip= findkey(k, &t, UNIQUE);
480: if (ip == Inil) return No;
481: uniql(&Ascval(ip));
482: return Yes;
483: }
484:
485: Visible bool in_keys(k, t) value k, t; { /* k in keys t */
486: return findkey(k, &t, NORMAL) != Inil;
487: }
488:
489: Visible value keys(t) value t; { /* keys t */
490: value v;
491: if (!Is_table(t)) {
492: error(MESS(103, "in keys t, t is not a table"));
493: return Vnil;
494: }
495: v= grab_tlt(Lis, Kt);
496: Root(v)= copybtree(Root(t));
497: return v;
498: }
499:
500: /* WARNING! The following routine is not reentrant, since (for range lists)
501: it may return a pointer to static storage. */
502:
503: Hidden itemptr getkth(k, v) int k; value v; {
504: finger f; fingertip ft; btreeptr p;
505: intlet it= Itemtype(v), iw= Itemwidth(it), l;
506: static item baked; value vk;
507: if (Root(v) == Bnil) return Inil;
508: ft= unzip(Root(v), k, f);
509: do {
510: if (ft == f) return Inil;
511: Pop(ft, p, l);
512: } while (l >= Lim(p));
513: switch (Flag(p)) {
514: default:
515: case Inner:
516: case Bottom:
517: return Pxitm(p, l, iw);
518: case Irange:
519: release(Keyval(&baked));
520: Keyval(&baked)= sum(Lwbval(p), vk= mk_integer(k));
521: release(vk);
522: return &baked;
523: case Crange:
524: release(Keyval(&baked));
525: Keyval(&baked)= mkchar(Lwbchar(p) + k);
526: return &baked;
527: }
528: }
529:
530: Visible value* key(v, k) value v; intlet k; { /* &(++k th'of keys v) */
531: itemptr ip= getkth(k, v);
532: return ip ? &Keyval(ip) : Pnil;
533: }
534:
535: Visible value* assoc(v, k) value v; intlet k; { /* &v[++k th'of keys v] */
536: itemptr ip= getkth(k, v);
537: return ip ? &Ascval(ip) : Pnil;
538: }
539:
540: Visible value thof(k, v) int k; value v; { /* k th'of v */
541: itemptr ip= getkth(k-1, v);
542: if (!ip) return Vnil;
543: switch (Type(v)) {
544: case Tex: return mkchar(Charval(ip));
545: case Lis: return copy(Keyval(ip));
546: case Tab: return copy(Ascval(ip));
547: default: return Vnil;
548: }
549: }
550:
551: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
552:
553: /* Compare B-trees. Should use fingers, but to keep things simple
554: (especially in the presence of range type nodes), doesn't. This
555: makes its behaviour O(N log N), where it could be O(N), alas. */
556:
557: /* WARNING! getkth may return a pointer to static storage (when retrieving
558: elements from a range list). Therefore after the second call to getkth,
559: the return value of the first may be invalid, but only for lists.
560: So we extract the 'Key' values immediately after the call to getkth. */
561:
562: Visible relation comp_tlt(u, v) value u, v; {
563: itemptr up, vp; int k, ulen, vlen, len; relation r= 0;
564: bool tex= Is_text(u), tab= Is_table(u);
565: value key_u;
566: len= ulen= Tltsize(u); vlen= Tltsize(v);
567: if (vlen < len) len= vlen;
568: for (k= 0; k < len; ++k) {
569: up= getkth(k, u);
570: if (!tex) key_u= copy(Keyval(up));
571: vp= getkth(k, v);
572: if (tex) r= Charval(up) - Charval(vp);
573: else {
574: r= compare(key_u, Keyval(vp));
575: release(key_u);
576: if (tab && r == 0)
577: r= compare(Ascval(up), Ascval(vp));
578: }
579: if (r != 0) break;
580: }
581: if (r == 0) r= ulen - vlen;
582: return r;
583: }
584:
585: /* Compare texts. When both texts are bottom nodes, compare with
586: strncmp(), to speed up the most common use (look-up by the
587: system of tags in a symbol table). Otherwise, call comp_tlt(). */
588:
589: Visible relation comp_text(u, v) value u, v; {
590: btreeptr p, q; int len; relation r;
591: if (!Is_text(u) || !Is_text(v)) syserr(MESS(104, "comp_text"));
592: p= Root(u), q= Root(v);
593: if (p EQ Bnil) return (q EQ Bnil) ? 0 : -1;
594: if (q EQ Bnil) return 1;
595: if (Flag(p) EQ Bottom && Flag(q) EQ Bottom) {
596: len= Lim(p);
597: if (Lim(q) < len) len= Lim(q);
598: r= strncmp(&Bchar(p, 0), &Bchar(q, 0), len);
599: if (r NE 0) return r;
600: return Lim(p) - Lim(q);
601: }
602: return comp_tlt(u, v);
603: }
604:
605: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
606:
607: /* Range type nodes */
608:
609: Visible value mk_numrange(lwb, upb) value lwb, upb; {
610: value lis;
611: btreeptr proot;
612:
613: lis= grab_tlt(Lis, Lt);
614: if (numcomp(lwb, upb) > 0)
615: Root(lis)= Bnil;
616: else {
617: Root(lis)= proot= grabbtreenode(Irange, Lt);
618: Lwbval(proot)= copy(lwb);
619: Upbval(proot)= copy(upb);
620: set_size_and_lim(proot);
621: }
622: return(lis);
623: }
624:
625: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
626:
627: Visible value mk_charrange(lwb, upb) value lwb, upb; {
628: value lis;
629: btreeptr proot;
630: intlet rsyz;
631:
632: lis= grab_tlt(Lis, Lt);
633: rsyz= Bchar(Root(upb), 0) - Bchar(Root(lwb), 0) + 1;
634: if (rsyz <= 0)
635: Root(lis)= Bnil;
636: else {
637: Root(lis)= proot= grabbtreenode(Crange, Lt);
638: Size(proot)= rsyz;
639: Lim(proot)= rsyz > 1 ? 2 : 1;
640: Lwbval(proot)= copy(lwb);
641: Upbval(proot)= copy(upb);
642: }
643: return lis;
644: }
645:
646:
647: /* set size and lim for integer range node */
648:
649: Hidden Procedure set_size_and_lim(pnode) btreeptr pnode; {
650: value uml, uml1;
651:
652: uml= diff(Upbval(pnode), Lwbval(pnode));
653: uml1= sum(uml, one);
654: if (large(uml1)) {
655: Size(pnode)= Bigsize;
656: Lim(pnode)= 2;
657: error(MESS(105, "creating list of too many entries"));
658: }
659: else {
660: Size(pnode)= intval(uml1);
661: Lim(pnode)= Size(pnode) > 1 ? 2 : 1;
662: }
663: release(uml);
664: release(uml1);
665: }
666:
667: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
668:
669: /* Dyadic min, max, size of lists */
670:
671: Visible value l2min(e, v) value e, v; { /* e min v */
672: finger f; fingertip ft= f; btreeptr p;
673: intlet it= Itemtype(v), iw= Itemwidth(it), l;
674: VOID searchkey(e, &v, DYAMIN, &ft);
675: for (;;) {
676: if (ft == f) return Vnil;
677: Top(ft, p, l);
678: if (l < Lim(p)) {
679: switch (Flag(p)) {
680: case Inner:
681: return copy(Keyval(Piitm(p, l, iw)));
682: case Bottom:
683: return copy(Keyval(Pbitm(p, l, iw)));
684: case Irange:
685: if (l == 0) return copy(Lwbval(p));
686: if (integral(e)) return sum(e, one);
687: return ceilf(e);
688: case Crange:
689: if (l == 0) return copy(Lwbval(p));
690: return mkchar(Bchar(Root(e), 0) + 1);
691: }
692: }
693: Drop(ft);
694: }
695: }
696:
697: Visible value l2max(e, v) value e, v; { /* e max v */
698: finger f; fingertip ft= f; btreeptr p;
699: intlet it= Itemtype(v), iw= Itemwidth(it), l;
700: VOID searchkey(e, &v, DYAMAX, &ft);
701: for (;;) {
702: if (ft == f) return Vnil;
703: Top(ft, p, l);
704: --l;
705: if (l >= 0) {
706: switch (Flag(p)) {
707: case Inner:
708: return copy(Keyval(Piitm(p, l, iw)));
709: case Bottom:
710: return copy(Keyval(Pbitm(p, l, iw)));
711: case Irange:
712: if (l == 1) return copy(Upbval(p));
713: if (integral(e)) return diff(e, one);
714: return floorf(e);
715: case Crange:
716: if (l == 1) return copy(Upbval(p));
717: return mkchar(Bchar(Root(e), 0) - 1);
718: }
719: }
720: Drop(ft);
721: }
722: }
723:
724: Visible int l2size(e, v) value e, v; { /* e#v */
725: finger f; fingertip ft= f; btreeptr p;
726: int count= 0; intlet it= Itemtype(v), iw= Itemwidth(it), l, r;
727: VOID searchkey(e, &v, DYAMIN, &ft);
728: for (;;) {
729: if (ft == f) return count;
730: Pop(ft, p, l);
731: while (--l >= 0) {
732: r= compare(Keyval(Pxitm(p, l, iw)), e);
733: if (r != 0) {
734: switch (Flag(p)) {
735: case Irange: /* See footnote */
736: if (l==0 && count==0 && integral(e))
737: ++count;
738: break;
739: case Crange: /* See footnote */
740: if (l==0 && count==0 && !character(e))
741: ++count;
742: break;
743: }
744: return count;
745: }
746: ++count;
747: while (IsInner(p)) {
748: Push(ft, p, l);
749: p= Ptr(p, l);
750: l= Lim(p);
751: }
752: }
753: }
754: }
755:
756: /* Clarification of what happens for x#{a..b}:
757: * Consider these five cases: x<a; x=a; a<x<b; x=b; b<x.
758: * Only the case a<x<b need be treated specially. How do we find which
759: * case we're in?
760: * Searchkey gives us the following values for l on the stack, respectively:
761: * 0; 1; 1; 2; 2. After --l, this becomes -1; 0; 0; 1; 1.
762: * In cases x=a or x=b, the compare returns 0, and we go another time
763: * through the loop. So when the compare returns r!=0, the value of l
764: * is, respectively: -1; -1; 0; 0; 1. The -1 cases in fact don't even
765: * get at the compare, and the correct count is returned automatically.
766: * So we need to do extra work only if l==0, except if x==b.
767: * The latter condition is cared for by count==0 (if x==b, count is
768: * surely >= 1; if a<x<b, count is surely 0). This works even when
769: * range nodes may be mixed with other node types in one tree.
770: */
771:
772: /*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*/
773:
774: #ifdef DEBUG
775: /* Debug code */
776:
777: Hidden Procedure check(v, whence) value v; string whence; {
778: if (!still_ok) return;
779: switch (Type(v)) {
780: case ELT:
781: return;
782: case Lis:
783: case Tab:
784: break;
785: default:
786: error3(MESS(106, "value not a list or table"), Vnil,
787: MESSMAKE(whence));
788: return;
789: }
790: if (Root(v) != Bnil)
791: VOID cktree(Inil, Root(v), Inil, Itemtype(v), whence);
792: if (!still_ok && !interrupted) {
793: dumptree(Root(v), 0, Itemtype(v));
794: printf("\n");
795: fflush(stdout);
796: }
797: }
798:
799: Hidden int cktree(left, p, right, it, whence)
800: itemptr left; btreeptr p; itemptr right; intlet it; string whence; {
801: /* returns size of checked subtree */
802: intlet i, iw= Itemwidth(it); int sz= 0;
803: if (!still_ok) return 0;
804: if (p == Bnil) {
805: error3(MESS(107, "unexpected nil subtree"), Vnil,
806: MESSMAKE(whence));
807: return 0;
808: }
809: switch (Flag(p)) {
810: case Inner:
811: for (i= 0; i < Lim(p); ++i) {
812: sz += 1 +
813: cktree(left, Ptr(p, i), Piitm(p, i, iw), it, whence);
814: if (!still_ok) return;
815: left= Piitm(p, i, iw);
816: }
817: sz += cktree(left, Ptr(p, i), right, it, whence);
818: if (still_ok && sz != Size(p))
819: error3(MESS(108, "size mismatch"), Vnil,
820: MESSMAKE(whence));
821: break;
822: case Bottom:
823: for (i= 0; i < Lim(p); ++i) {
824: if (left != Inil && compare(Keyval(left),
825: Keyval(Pbitm(p, i, iw))) > 0) {
826: error3(MESS(109, "bottom items out of order"),
827: Vnil, MESSMAKE(whence));
828: break;
829: }
830: left= Pbitm(p, i, iw);
831: sz++;
832: }
833: if (still_ok && right != Inil
834: && compare(Keyval(left), Keyval(right)) > 0)
835: error3(MESS(110, "bottom items out of order"),
836: Vnil, MESSMAKE(whence));
837: return sz;
838: case Irange:
839: if (left != Inil && compare(Keyval(left), Lwbval(p)) > 0
840: || right != Inil
841: && compare(Upbval(p), Keyval(right)) > 0)
842: error3(MESS(111, "irange items out of order"), Vnil,
843: MESSMAKE(whence));
844: sz= Size(p);
845: default:
846: error3(MESS(112, "bad node type"), Vnil, MESSMAKE(whence));
847: }
848: return sz;
849: }
850: #endif DEBUG
851:
852: #ifdef NOT_USED
853: Visible Procedure e_dumptree(v) value v; {
854: check(v, "");
855: if (still_ok) {
856: if (!at_nwl) printf("\n");
857: dumptree(Root(v), 0, Itemtype(v));
858: printf("\n");
859: fflush(stdout);
860: at_nwl= Yes;
861: }
862: }
863: #endif
864:
865: Hidden Procedure dumptree(p, indent, it) btreeptr p; intlet indent, it; {
866: intlet i, iw= Itemwidth(it);
867: if (interrupted) return;
868: printf("%*s", 3*indent, "");
869: if (p == Bnil) { printf("<nil>"); return; }
870: switch (Flag(p)) {
871: case Inner:
872: printf("(\n");
873: for (i= 0; !interrupted && i <= Lim(p); ++i) {
874: if (i > 0) {
875: printf("%*s", 3*indent, "");
876: dumpval(Keyval(Piitm(p, i-1, iw)));
877: printf("\n");
878: }
879: dumptree(Ptr(p, i), indent+1, it);
880: printf("\n");
881: }
882: printf("%*s", 3*indent, "");
883: printf(")");
884: break;
885: case Bottom:
886: printf("[");
887: for (i= 0; i < Lim(p); ++i) {
888: if (i > 0) printf(" ");
889: dumpval(Keyval(Pbitm(p, i, iw)));
890: }
891: printf("]");
892: break;
893: case Irange:
894: printf("{");
895: dumpval(Lwbval(p));
896: printf(" .. ");
897: dumpval(Upbval(p));
898: printf("}");
899: break;
900: default:
901: printf("?type='%c'?", Flag(p));
902: break;
903: }
904: }
905:
906: Hidden Procedure dumpval(v) value v; {
907: if (interrupted) return;
908: if (v == Vnil) printf("(nil)");
909: else switch(Type(v)) {
910: case Num: case Tex: case Lis: case Tab: case ELT: case Com:
911: wri(v, No, No, No);
912: break;
913: default:
914: printf("0x%lx", (long)v);
915: }
916: }
917:
918: #else INTEGRATION
919:
920: /* B lists */
921:
922: Visible value list_elem(l, i) value l; intlet i; {
923: return List_elem(l, i);
924: }
925:
926: Visible insert(v, ll) value v, *ll; {
927: intlet len= Length(*ll); register value *lp, *lq;
928: intlet k; register intlet kk;
929: if (!Is_list(*ll)) {
930: error(MESS(113, "inserting in non-list"));
931: return;
932: }
933: VOID found(list_elem, *ll, v, &k);
934: if (Unique(*ll) && !Is_ELT(*ll)) {
935: xtndlt(ll, 1);
936: lq= Ats(*ll)+len; lp= lq-1;
937: for (kk= len; kk > k; kk--) *lq--= *lp--;
938: *lq= copy(v);
939: } else {
940: lp= Ats(*ll);
941: release(*ll);
942: *ll= grab_lis(++len);
943: lq= Ats(*ll);
944: for (kk= 0; kk < len; kk++) *lq++= copy (kk == k ? v : *lp++);
945: }
946: }
947:
948: Visible remove(v, ll) value v; value *ll; {
949: register value *lp, *lq;
950: intlet k, len= Length(*ll);
951: if (!Is_list(*ll))
952: error(MESS(114, "removing from non-list"));
953: else if (len == 0)
954: error(MESS(115, "removing from empty list"));
955: else if (!found(list_elem, *ll, v, &k))
956: error(MESS(116, "removing non-existing list entry"));
957: else {
958: lp= Ats(*ll); /* lp[k] = v */
959: if (Unique(*ll)) {
960: release(*(lp+=k));
961: for (k= k; k < len; k++) {*lp= *(lp+1); lp++;}
962: xtndlt(ll, -1);
963: } else {
964: intlet kk= k;
965: lq= Ats(*ll);
966: release(*ll);
967: *ll= grab_lis(--len);
968: lp= Ats(*ll);
969: Overall {
970: *lp++= copy (*lq++);
971: if (k == kk) lq++;
972: }
973: }
974: }
975: }
976:
977: Visible value mk_numrange(a, z) value a, z; {
978: value l= mk_elt(), m= copy(a), n;
979:
980: while (compare(m, z)<=0) {
981: insert(m, &l);
982: m= sum(n=m, one);
983: release(n);
984: }
985: release(m);
986: return l;
987: }
988:
989: Visible value mk_charrange(av, zv) value av, zv; {
990: char a= charval(av), z= charval(zv);
991: value l= grab_lis((intlet) (z-a+1)); register value *ep= Ats(l);
992: char m[2];
993: m[1]= '\0';
994: for (m[0]= a; m[0] <= z; m[0]++) {
995: *ep++= mk_text(m);
996: }
997: return l;
998: }
999:
1000: /**********************************************************************/
1001:
1002: /* B tables */
1003:
1004: Visible value* key(v, k) value v; intlet k; { /* k in {0..size-1}; no copy */
1005: return Key(v, k);
1006: }
1007:
1008: Visible value* assoc(v, k) value v; intlet k; { /* k in {0..size-1}; no copy */
1009: return Assoc(v, k);
1010: }
1011:
1012: Visible value associate(v, k) value v; value k; {
1013: value *p= adrassoc(v, k);
1014: if (p) return copy(*p);
1015: error(MESS(117, "key not in table"));
1016: return Vnil;
1017: }
1018:
1019: Visible value keys(ta) value ta; {
1020:
1021: if(!Is_table(ta)) {
1022: error(MESS(118, "in keys t, t is not a table"));
1023: return grab_lis(0);
1024: } else {
1025: value li= grab_lis(Length(ta)), *le, *te= (value *)Ats(ta);
1026: int k, len= Length(ta);
1027: le= (value *)Ats(li);
1028: Overall { *le++= copy(Cts(*te++)); }
1029: return li;
1030: }
1031: }
1032:
1033: Visible value key_elem(t, i) value t; intlet i; { /*The key of the i-th entry*/
1034: return *Key(t, i);
1035: }
1036:
1037: /* adrassoc returns a pointer to the associate, rather than
1038: the associate itself, so that the caller can decide if a copy
1039: should be taken or not. If the key is not found, Pnil is returned. */
1040: Visible value* adrassoc(t, ke) value t, ke; {
1041: intlet where;
1042: if (Type(t) != Tab && Type(t) != ELT) {
1043: error(MESS(119, "selection on non-table"));
1044: return Pnil;
1045: }
1046: return found(key_elem, t, ke, &where) ? Assoc(t, where) : Pnil;
1047: }
1048:
1049: Visible Procedure uniq_assoc(ta, ke) value ta, ke; {
1050: intlet k;
1051: if (found(key_elem, ta, ke, &k)) {
1052: uniql(Ats(ta)+k);
1053: uniql(Assoc(ta,k));
1054: } else syserr(MESS(120, "uniq_assoc called for non-existent table entry"));
1055: }
1056:
1057: Visible Procedure replace(v, ta, ke) value *ta, ke, v; {
1058: intlet len= Length(*ta); value *tp, *tq;
1059: intlet k, kk;
1060: uniql(ta);
1061: if (Type(*ta) == ELT) (*ta)->type = Tab;
1062: else if (Type(*ta) != Tab) {
1063: error(MESS(121, "replacing in non-table"));
1064: return;
1065: }
1066: if (found(key_elem, *ta, ke, &k)) {
1067: value *a;
1068: uniql(Ats(*ta)+k);
1069: a= Assoc(*ta, k);
1070: uniql(a);
1071: release(*a);
1072: *a= copy(v);
1073: return;
1074: } else {
1075: xtndlt(ta, 1);
1076: tq= Ats(*ta)+len; tp= tq-1;
1077: for (kk= len; kk > k; kk--) *tq--= *tp--;
1078: *tq= grab_com(2);
1079: Cts(*tq)= copy(ke);
1080: Dts(*tq)= copy(v);
1081: }
1082: }
1083:
1084: Visible bool in_keys(ke, tl) value ke, tl; {
1085: intlet dummy;
1086: if (Type(tl) == ELT) return No;
1087: if (Type(tl) != Tab) syserr(MESS(122, "in_keys applied to non-table"));
1088: return found(key_elem, tl, ke, &dummy);
1089: }
1090:
1091: Visible Procedure delete(tl, ke) value *tl, ke; {
1092: intlet len, k; value *tp;
1093: if (Type(*tl) == ELT) syserr(MESS(123, "deleting table entry from empty table"));
1094: if (Type(*tl) != Tab) syserr(MESS(124, "deleting table entry from non-table"));
1095: tp= Ats(*tl); len= Length(*tl);
1096: if (!found(key_elem, *tl, ke, &k))
1097: syserr(MESS(125, "deleting non-existent table entry"));
1098: if (Unique(*tl)) {
1099: release(*(tp+=k));
1100: for (k= k; k < len; k++) {*tp= *(tp+1); tp++;}
1101: xtndlt(tl, -1);
1102: } else {
1103: intlet kk; value *tq= Ats(*tl);
1104: release(*tl);
1105: *tl= grab_tab(--len);
1106: tp= Ats(*tl);
1107: for (kk= 0; kk < len; kk++) {
1108: *tp++= copy (*tq++);
1109: if (kk == k) tq++;
1110: }
1111: }
1112: }
1113:
1114: #endif INTEGRATION
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.