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