4.3BSD - /usr/src/new/B/src/bsmall/b2loc.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
   2: /* $Header: b2loc.c,v 1.1 84/06/28 00:49:16 timo Exp $ */
   3: 
   4: /* B locations and environments */
   5: #include "b.h"
   6: #include "b0con.h"
   7: #include "b1obj.h"
   8: #include "b2env.h" /* for bndtgs */
   9: #include "b2sem.h"
  10: 
  11: Hidden value* location(l) loc l; {
  12:     value *ll;
  13:     if (Is_simploc(l)) {
  14:         simploc *sl= Simploc(l);
  15:         if (!in_env(sl->e->tab, sl->i, &ll)) error("target still empty");
  16:         return ll;
  17:     } else if (Is_tbseloc(l)) {
  18:         tbseloc *tl= Tbseloc(l);
  19:         ll= adrassoc(*location(tl->R), tl->K);
  20:         if (ll == Pnil) error("key not in table");
  21:         return ll;
  22:     } else {
  23:         syserr("call of location with improper type");
  24:         return (value *) Dummy;
  25:     }
  26: }
  27: 
  28: Hidden Procedure uniquify(l) loc l; {
  29:     if (Is_simploc(l)) {
  30:         simploc *sl= Simploc(l);
  31:         value *ta= &(sl->e->tab), ke= sl->i;
  32:         uniql(ta);
  33:         check_location(l);
  34:         uniq_assoc(*ta, ke);
  35:     } else if (Is_tbseloc(l)) {
  36:         tbseloc *tl= Tbseloc(l);
  37:         value t, ke;
  38:         uniquify(tl->R);
  39:         t= *location(tl->R); ke= tl->K;
  40:         if (!Is_table(t)) error("selection on non-table");
  41:         if (empty(t)) error("selection on empty table");
  42:         check_location(l);
  43:         uniq_assoc(t, ke);
  44:     } else if (Is_trimloc(l)) { syserr("uniquifying trimloc");
  45:     } else if (Is_compound(l)) { syserr("uniquifying comploc");
  46:     } else syserr("uniquifying non-location");
  47: }
  48: 
  49: Visible Procedure check_location(l) loc l; {
  50:     VOID location(l);
  51:     /* location may produce an error message */
  52: }
  53: 
  54: Visible value content(l) loc l; {
  55:     return copy(*location(l));
  56: }
  57: 
  58: Visible loc trim_loc(R, B, C) loc R; intlet B, C; {
  59:     if (Is_trimloc(R)) {
  60:         trimloc *rr= Trimloc(R);
  61:         return mk_trimloc(rr->R, B, C);
  62:     } else if (Is_simploc(R) || Is_tbseloc(R)) {
  63:         return mk_trimloc(R, B, C);
  64:     } else {
  65:         error("trim (@ or |) on target of improper type");
  66:         /* NOTREACHED */
  67:     }
  68: }
  69: 
  70: Visible loc tbsel_loc(R, K) loc R; value K; {
  71:     if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
  72:     else error("selection on target of improper type");
  73:     /* NOTREACHED */
  74: }
  75: 
  76: Visible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }
  77: 
  78: Visible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }
  79: 
  80: Visible Procedure put(v, l) value v; loc l; {
  81:     if (Is_simploc(l)) {
  82:         simploc *sl= Simploc(l);
  83:         e_replace(v, &(sl->e->tab), sl->i);
  84:     } else if (Is_trimloc(l)) {
  85:         trimloc *tl= Trimloc(l);
  86:         value rr, nn, head, tail, part;
  87:         intlet B= tl->B, C= tl->C, len;
  88:         rr= *location(tl->R);
  89:         if (!Is_text(rr)) error("trim target contains no text");
  90:         if (!Is_text(v))
  91:             error("putting non-text in trim(@ or|) on text location");
  92:         len= length(rr);
  93:         if (B < 0 || C < 0 || B+C > len)
  94:             error("trim (@ or |) on text location out of bounds");
  95:         head= trim(rr, 0, len-B); /* rr|B */
  96:         tail= trim(rr, len-C, 0); /* rr@(#rr-C+1) */
  97:         part= concat(head, v);
  98:         nn= concat(part, tail);
  99:         put(nn, tl->R);
 100:         release(nn); release(head); release(tail); release(part);
 101:     } else if (Is_compound(l)) {
 102:         intlet k, len= Nfields(l);
 103:         if (!Is_compound(v))
 104:             error("putting non-compound in compound location");
 105:         if (Nfields(v) != Nfields(l))
 106:             error("putting compound in compound location of different length");
 107:         k_Overfields { put(*field(v, k), *field(l, k)); }
 108:     } else if (Is_tbseloc(l)) {
 109:         tbseloc *tl= Tbseloc(l);
 110:         uniquify(tl->R);
 111:         replace(v, location(tl->R), tl->K);
 112:     } else error("putting in non-target");
 113: }
 114: 
 115: Hidden bool l_exists(l) loc l; {
 116:     if (Is_simploc(l)) {
 117:         simploc *sl= Simploc(l);
 118:         return in_keys(sl->i, sl->e->tab);
 119:     } else if (Is_trimloc(l)) {
 120:         error("deleting trimmed (@ or |) target");
 121:         return No;
 122:     } else if (Is_compound(l)) {
 123:         intlet k, len= Nfields(l);
 124:         k_Overfields { if (!l_exists(*field(l, k))) return No; }
 125:         return Yes;
 126:     } else if (Is_tbseloc(l)) {
 127:         tbseloc *tl= Tbseloc(l);
 128:         uniquify(tl->R);
 129:         return in_keys(tl->K, *location(tl->R));
 130:     } else {
 131:         error("deleting non-target");
 132:         return No;
 133:     }
 134: }
 135: 
 136: Hidden Procedure l_del(l) loc l; {
 137:     if (Is_simploc(l)) {
 138:         simploc *sl= Simploc(l);
 139:         if (in_keys(sl->i, sl->e->tab)) {
 140:             uniql(&(sl->e->tab)); /*no need?: see delete*/
 141:             e_delete(&(sl->e->tab), sl->i);
 142:         }
 143:     } else if (Is_trimloc(l)) {
 144:         error("deleting trimmed (@ or |) target");
 145:     } else if (Is_compound(l)) {
 146:         intlet k, len= Nfields(l);
 147:         k_Overfields { l_del(*field(l, k)); }
 148:     } else if (Is_tbseloc(l)) {
 149:         tbseloc *tl= Tbseloc(l);
 150:         value *lc;
 151:         uniquify(tl->R);
 152:         lc= location(tl->R);
 153:         if (in_keys(tl->K, *lc)) delete(lc, tl->K);
 154:     } else error("deleting non-target");
 155: }
 156: 
 157: Visible Procedure l_delete(l) loc l; {
 158:     if (l_exists(l)) l_del(l);
 159:     else error("deleting non-existent target");
 160: }
 161: 
 162: Visible Procedure l_insert(v, l) value v; loc l; {
 163:     value *ll;
 164:     uniquify(l);
 165:     ll= location(l);
 166:     insert(v, ll);
 167: }
 168: 
 169: Visible Procedure l_remove(v, l) value v; loc l; {
 170:     uniquify(l);
 171:     remove(v, location(l));
 172: }
 173: 
 174: Visible Procedure choose(l, v) loc l; value v; {
 175:     value w, s, r;
 176:     if (!Is_tlt(v)) error("choosing from non-text, -list or -table");
 177:     s= size(v);
 178:     if (compare(s, zero) == 0)
 179:         error("choosing from empty text, list or table");
 180:     /* PUT (floor(random*#v) + 1) th'of v IN l */
 181:     r= prod(w= random(), s); release(w); release(s);
 182:     w= floorf(r); release(r);
 183:     r= sum(w, one); release(w);
 184:     put(w= th_of(r, v), l); release(w);
 185: }
 186: 
 187: Visible Procedure draw(l) loc l; {
 188:     value r= random();
 189:     put(r, l);
 190:     release(r);
 191: }
 192: 
 193: Visible Procedure bind(l) loc l; {
 194:     if (Is_simploc(l)) {
 195:         simploc *ll= Simploc(l);
 196:         if (!in(ll->i, *bndtgs)) /* kludge */
 197:             insert(ll->i, bndtgs);
 198:     } else if (Is_compound(l)) {
 199:         intlet k, len= Nfields(l);
 200:         k_Overfields { bind(*field(l, k)); }
 201:     } else if (Is_trimloc(l)) {
 202:         pprerr("t@p or t|p not allowed in ranger", "");
 203:     } else if (Is_tbseloc(l)) {
 204:         pprerr("t[e] not allowed in ranger", "");
 205:     } else error("binding non-identifier");
 206: }

Defined functions