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

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b3loc.c,v 1.4 85/08/27 10:56:45 timo Exp $
   5: */
   6: 
   7: /* B locations and environments */
   8: #include "b.h"
   9: #include "b0con.h"
  10: #include "b1obj.h"
  11: #include "b3env.h" /* for bndtgs */
  12: #include "b3sem.h"
  13: #include "b3sou.h" /* for tarvalue() */
  14: #include "b3err.h" /* for still_ok */
  15: 
  16: Hidden value* location(l) loc l; {
  17:     value *ll;
  18:     if (Is_locloc(l)) {
  19:         if (!in_env(curnv->tab, l, &ll))
  20:             error(MESS(3600, "target not initialised"));
  21:         return ll;
  22:     } else if (Is_simploc(l)) {
  23:         simploc *sl= Simploc(l);
  24:         if (!in_env(sl->e->tab, sl->i, &ll))
  25:             if (Is_locloc(sl->i))
  26:                 error(MESS(3601, "target not initialised"));
  27:             else error3(0, sl->i,
  28:                 MESS(3602, " hasn't been initialised"));
  29:         return ll;
  30:     } else if (Is_tbseloc(l)) {
  31:         tbseloc *tl= Tbseloc(l);
  32:         ll= location(tl->R);
  33:         if (still_ok) {
  34:             ll= adrassoc(*ll, tl->K);
  35:             if (ll == Pnil && still_ok) error(MESS(3603, "key not in table"));
  36:         }
  37:         return ll;
  38:     } else {
  39:         syserr(MESS(3604, "call of location with improper type"));
  40:         return (value *) Dummy;
  41:     }
  42: }
  43: 
  44: Hidden Procedure uniquify(l) loc l; {
  45:     if (Is_simploc(l)) {
  46:         simploc *sl= Simploc(l);
  47:         value *ta= &(sl->e->tab), ke= sl->i;
  48:         uniql(ta);
  49:         check_location(l);
  50:         if (still_ok) {
  51:             if (Is_compound(*ta)) uniql(Field(*ta, intval(ke)));
  52:             else {  value *aa, v;
  53:                 VOID uniq_assoc(*ta, ke);
  54:                 aa= adrassoc(*ta, ke);
  55:                 v= copy(tarvalue(ke, *aa));
  56:                 release(*aa);
  57:                 *aa= v;
  58:                 uniql(aa);
  59:             }
  60:         }
  61:     } else if (Is_tbseloc(l)) {
  62:         tbseloc *tl= Tbseloc(l);
  63:         value t, ke;
  64:         uniquify(tl->R);
  65:         if (still_ok) { t= *location(tl->R); ke= tl->K; }
  66:         if (still_ok) {
  67:             if (!Is_table(t)) error(MESS(3605, "selection on non-table"));
  68:             else if (empty(t)) error(MESS(3606, "selection on empty table"));
  69:             else {
  70:                 check_location(l);
  71:                 if (still_ok) VOID uniq_assoc(t, ke);
  72:             }
  73:         }
  74:     } else if (Is_trimloc(l)) { syserr(MESS(3607, "uniquifying trimloc"));
  75:     } else if (Is_compound(l)) { syserr(MESS(3608, "uniquifying comploc"));
  76:     } else syserr(MESS(3609, "uniquifying non-location"));
  77: }
  78: 
  79: Visible Procedure check_location(l) loc l; {
  80:     VOID location(l);
  81:     /* location may produce an error message */
  82: }
  83: 
  84: Visible value content(l) loc l; {
  85:     value *ll= location(l);
  86:     return still_ok ? copy(*ll) : Vnil;
  87: }
  88: 
  89: Visible loc trim_loc(l, v, sign) loc l; value v; char sign; {
  90:     loc root, res; value text, B, C;
  91:     if (Is_simploc(l) || Is_tbseloc(l)) {
  92:         uniquify(l); /* Call tarvalue at proper time */
  93:         root= l;
  94:         B= zero; C= zero;
  95:     } else if (Is_trimloc(l)) {
  96:         trimloc *rr= Trimloc(l);
  97:         root= rr->R;
  98:         B= rr->B; C= rr->C;
  99:     } else {
 100:         error(MESS(3610, "trim (@ or |) on target of improper type"));
 101:         return Lnil;
 102:     }
 103:     text= content(root);
 104:     if (!still_ok);
 105:     else if (!Is_text(text)) {
 106:         error(MESS(3611, "in the target t@p or t|p, t does not contain a text"));
 107:     } else {
 108:         value s= size(text), w, x, b_plus_c;
 109:         if (sign == '@') B= sum(B, w=diff(v, one));
 110:         else {  C= sum(C, w=diff(x= diff(s, B), v)); release(x); }
 111:         release(w);
 112:         b_plus_c= sum(B, C);
 113:         if (still_ok && (compare(B,zero)<0 || compare(C,zero)<0
 114:                   || compare(b_plus_c,s)>0))
 115:             error(MESS(3612, "in the target t@p or t|p, p is out of bounds"));
 116:         else res= mk_trimloc(root, B, C);
 117:         if (sign == '@') release(B);
 118:         else release(C);
 119:         release(s); release(b_plus_c);
 120:     }
 121:     release(text);
 122:     if (still_ok) return res; else return Lnil;
 123: }
 124: 
 125: Visible loc tbsel_loc(R, K) loc R; value K; {
 126:     if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
 127:     else error(MESS(3613, "selection on target of improper type"));
 128:     return Lnil;
 129: }
 130: 
 131: Visible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }
 132: 
 133: Visible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }
 134: 
 135: Hidden Procedure put_trim(v, tl) value v; trimloc *tl; {
 136:     value rr, nn, head, tail, part;
 137:     value B= tl->B, C= tl->C, len, len_minus_c, tail_start;
 138:     rr= *location(tl->R);
 139:     len= size(rr);
 140:     len_minus_c= diff(len, C); release(len);
 141:     tail_start= sum(len_minus_c, one); release(len_minus_c);
 142:     if (compare(B, zero)<0 || compare(C, zero)<0
 143:      || compare(B, tail_start)>=0)
 144:         error(MESS(3614, "trim (@ or |) on text location out of bounds"));
 145:     else {
 146:         head= curtail(rr, B); /* rr|B */
 147:         tail= behead(rr, tail_start); /* rr@(#rr-C+1) */
 148:         part= concat(head, v); release(head);
 149:         nn= concat(part, tail); release(part); release(tail);
 150:         put(nn, tl->R); release(nn);
 151:     }
 152:     release(tail_start);
 153: }
 154: 
 155: Visible Procedure put(v, l) value v; loc l; {
 156:     if (Is_locloc(l)) {
 157:         e_replace(v, &curnv->tab, l);
 158:     } else if (Is_simploc(l)) {
 159:         simploc *sl= Simploc(l);
 160:         e_replace(v, &(sl->e->tab), sl->i);
 161:     } else if (Is_trimloc(l)) {
 162:         if (!Is_text(v)) error(MESS(3615, "putting non-text in trim (@ or |)"));
 163:         else put_trim(v, Trimloc(l));
 164:     } else if (Is_compound(l)) {
 165:         intlet k, len= Nfields(l);
 166:         if (!Is_compound(v))
 167:             error(MESS(3616, "putting non-compound in compound location"));
 168:         else if (Nfields(v) != Nfields(l))
 169:             error(MESS(3617, "putting compound in compound location of different length"));
 170:         else k_Overfields { put(*Field(v, k), *Field(l, k)); }
 171:     } else if (Is_tbseloc(l)) {
 172:         tbseloc *tl= Tbseloc(l); value *rootloc;
 173:         uniquify(tl->R);
 174:         if (still_ok) {
 175:             rootloc= location(tl->R);
 176:             if (still_ok && !Is_table(*rootloc))
 177:                 error(MESS(3621, "selection on non-table"));
 178:             if (still_ok) replace(v, rootloc, tl->K);
 179:         }
 180:     } else error(MESS(3618, "putting in non-target"));
 181: }
 182: 
 183: /* Check for correct effect of multiple put-command: catches PUT 1, 2 IN x, x.
 184:    The assignment cannot be undone, but this is not considered a problem.
 185:    For trimmed-texts, no checks are made because the language definition
 186:    itself causes problem (try PUT "abc", "" IN x@2|1, x@3|1). */
 187: 
 188: Hidden bool putck(v, l) value v; loc l; {
 189:     intlet k, len; value w;
 190:     if (!still_ok) return No;
 191:     if (Is_compound(l)) {
 192:         if (!Is_compound(v) || Nfields(v) != (len= Nfields(l)))
 193:             return No; /* Severe type error */
 194:         k_Overfields
 195:             { if (!putck(*Field(v, k), *Field(l, k))) return No; }
 196:         return Yes;
 197:     }
 198:     if (Is_trimloc(l)) return Yes; /* Don't check trim locations */
 199:     w= *location(l);
 200:     /* Unfortunately, this may already cause an error, e.g. after
 201: 	   PUT 1, {} IN t[1], t.  This can't be helped unless we introduce
 202: 	   a flag so that location will shut up. */
 203:     return still_ok && compare(v, w) == 0;
 204: }
 205: 
 206: /* The check can't be called from within put because put is recursive,
 207:    and so is the check: then, for the inner levels the check would be done
 208:    twice.  Moreover, we don't want to clutter up put, which is called
 209:    internally in, many places. */
 210: 
 211: Visible Procedure put_with_check(v, l) value v; loc l; {
 212:     intlet i, k, len; bool ok;
 213:     put(v, l);
 214:     if (!still_ok || !Is_compound(l))
 215:         return; /* Single target can't be wrong */
 216:     len= Nfields(l); ok= Yes;
 217:     /* Quick check for putting in all different local targets: */
 218:     k_Overfields {
 219:         if (!IsSmallInt(*Field(l, k))) { ok= No; break; }
 220:         for (i= k-1; i >= 0; --i) {
 221:             if (*Field(l, i) == *Field(l, k)) { ok= No; break; }
 222:         }
 223:         if (!ok) break;
 224:     }
 225:     if (ok) return; /* All different local basic-targets */
 226:     if (!putck(v, l))
 227:         error(MESS(3619, "putting different values in same location"));
 228: }
 229: 
 230: 
 231: Hidden bool l_exists(l) loc l; {
 232:     if (Is_simploc(l)) {
 233:         simploc *sl= Simploc(l);
 234:         return envassoc(sl->e->tab, sl->i) != Pnil;
 235:     } else if (Is_trimloc(l)) {
 236:         error(MESS(3620, "deleting trimmed (@ or |) target"));
 237:         return No;
 238:     } else if (Is_compound(l)) {
 239:         intlet k, len= Nfields(l);
 240:         k_Overfields { if (!l_exists(*Field(l, k))) return No; }
 241:         return Yes;
 242:     } else if (Is_tbseloc(l)) {
 243:         tbseloc *tl= Tbseloc(l); value *ll;
 244:         uniquify(tl->R); /* call tarvalue() at proper place */
 245:         if (still_ok) ll= location(tl->R);
 246:         if (still_ok && !Is_table(*ll))
 247:             error(MESS(3621, "selection on non-table"));
 248:         return still_ok && in_keys(tl->K, *ll);
 249:     } else {
 250:         error(MESS(3622, "deleting non-target"));
 251:         return No;
 252:     }
 253: }
 254: 
 255: /* Delete a location if it exists */
 256: 
 257: Hidden Procedure l_del(l) loc l; {
 258:     if (Is_simploc(l)) {
 259:         simploc *sl= Simploc(l);
 260:         e_delete(&(sl->e->tab), sl->i);
 261:     } else if (Is_trimloc(l)) {
 262:         error(MESS(3623, "deleting trimmed (@ or |) target"));
 263:     } else if (Is_compound(l)) {
 264:         intlet k, len= Nfields(l);
 265:         k_Overfields { l_del(*Field(l, k)); }
 266:     } else if (Is_tbseloc(l)) {
 267:         tbseloc *tl= Tbseloc(l);
 268:         value *lc;
 269:         uniquify(tl->R);
 270:         if (still_ok) {
 271:             lc= location(tl->R);
 272:             if (in_keys(tl->K, *lc)) delete(lc, tl->K);
 273:         }
 274:     } else error(MESS(3624, "deleting non-target"));
 275: }
 276: 
 277: Visible Procedure l_delete(l) loc l; {
 278:     if (l_exists(l)) l_del(l);
 279:     else if (still_ok) error(MESS(3625, "deleting non-existent target"));
 280: }
 281: 
 282: Visible Procedure l_insert(v, l) value v; loc l; {
 283:     value *ll;
 284:     uniquify(l);
 285:     if (still_ok) {
 286:         ll= location(l);
 287:         if (!Is_list(*ll)) error(MESS(3626, "inserting in non-list"));
 288:         else insert(v, ll);
 289:     }
 290: }
 291: 
 292: Visible Procedure l_remove(v, l) value v; loc l; {
 293:     value *ll;
 294:     uniquify(l);
 295:     if (still_ok) {
 296:         ll= location(l);
 297:         if (!Is_list(*ll)) error(MESS(3627, "removing from non-list"));
 298:         else if (empty(*ll)) error(MESS(3628, "removing from empty list"));
 299:         else remove(v, ll);
 300:     }
 301: }
 302: 
 303: /* Warning: choose is only as good as the accuracy of the random-number */
 304: /* generator. In particular, for very large values of v, elements will  */
 305: /* be chosen unfairly. Choose should be rewritten to cope with this     */
 306: 
 307: Visible Procedure choose(l, v) loc l; value v; {
 308:     value w, s, r;
 309:     if (!Is_tlt(v)) error(MESS(3629, "choosing from non-text, -list or -table"));
 310:     else if (empty(v)) error(MESS(3630, "choosing from empty text, list or table"));
 311:     else {
 312:         /* PUT (floor(random*#v) + 1) th'of v IN l */
 313:         s= size(v);
 314:         r= prod(w= random(), s); release(w); release(s);
 315:         w= floorf(r); release(r);
 316:         r= sum(w, one); release(w);
 317:         put(w= th_of(r, v), l); release(w); release(r);
 318:     }
 319: }
 320: 
 321: Visible Procedure draw(l) loc l; {
 322:     value r= random();
 323:     put(r, l);
 324:     release(r);
 325: }
 326: 
 327: Visible Procedure bind(l) loc l; {
 328:     if (*bndtgs != Vnil) {
 329:         if (Is_simploc(l)) {
 330:             simploc *ll= Simploc(l);
 331:             if (!in(ll->i, *bndtgs)) /* kludge */ /* what for? */
 332:                 insert(ll->i, bndtgs);
 333:         } else if (Is_compound(l)) {
 334:             intlet k, len= Nfields(l);
 335:             k_Overfields { bind(*Field(l, k)); }
 336:         } else error(MESS(3631, "binding non-identifier"));
 337:     }
 338:     l_del(l);
 339: }
 340: 
 341: Visible Procedure unbind(l) loc l; {
 342:     if (*bndtgs != Vnil) {
 343:         if (Is_simploc(l)) {
 344:             simploc *ll= Simploc(l);
 345:             if (in(ll->i, *bndtgs))
 346:                 remove(ll->i, bndtgs);
 347:         } else if (Is_compound(l)) {
 348:             intlet k, len= Nfields(l);
 349:             k_Overfields { unbind(*Field(l, k)); }
 350:         } else error(MESS(3632, "unbinding non-identifier"));
 351:     }
 352:     l_del(l);
 353: }

Defined functions