2.11BSD#431 - /usr/src/new/PORT/B/src/bint/b1lta.c

   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

Defined functions

Defined variables

Defined macros