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

##### Functions

    bind              X
    check_location    X
    choose            X
    content           X
    draw              X
    global_loc        X
    l_del             X
    l_delete          X
    l_exists          X
    l_insert          X
    l_remove          X
    local_loc         X
    location          X
    put               X
    put_trim          X
    put_with_check    X
    putck             X
    tbsel_loc         X
    trim_loc          X
    unbind            X
    uniquify          X

       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

bind defined in line 327; used 3 times

- in line 335
- in /usr/src/new/PORT/B/src/bint/b3in2.c line 119, 153

check_location defined in line 79; used 2 times

- in line 49, 70

choose defined in line 307; never used
content defined in line 84; used 2 times

- in line 103
- in /usr/src/new/PORT/B/src/bint/b3sem.h line 15

draw defined in line 321; never used
global_loc defined in line 133; used 3 times

- in /usr/src/new/PORT/B/src/bint/b3in2.c line 90
- in /usr/src/new/PORT/B/src/bint/b3int.c line 356
- in /usr/src/new/PORT/B/src/bint/b3sem.h line 14

l_del defined in line 257; used 4 times

- in line 265, 278, 338, 352

l_delete defined in line 277; never used
l_exists defined in line 231; used 2 times

- in line 240, 278

l_insert defined in line 282; never used
l_remove defined in line 292; never used
local_loc defined in line 131; used 3 times

- in /usr/src/new/PORT/B/src/bint/b3in2.c line 89
- in /usr/src/new/PORT/B/src/bint/b3int.c line 352
- in /usr/src/new/PORT/B/src/bint/b3sem.h line 13

location defined in line 16; used 11 times

- in line 32, 65, 80-85(2), 138, 175, 199, 245, 271, 286, 296

put defined in line 155; used 13 times

- in line 150, 170, 213, 317, 323
- in /usr/src/new/PORT/B/src/bint/b3in2.c line 127, 154, 170
- in /usr/src/new/PORT/B/src/bint/b3int.c line 127-133(3)
- in /usr/src/new/PORT/B/src/bint/b3scr.c line 423, 440

put_trim defined in line 135; used 1 times

- in line 163

put_with_check defined in line 211; never used
putck defined in line 188; used 2 times

- in line 195, 226

tbsel_loc defined in line 125; used 2 times

- in /usr/src/new/PORT/B/src/bint/b3int.c line 223
- in /usr/src/new/PORT/B/src/bint/b3sem.h line 18

trim_loc defined in line 89; used 3 times

- in /usr/src/new/PORT/B/src/bint/b3int.c line 227, 233
- in /usr/src/new/PORT/B/src/bint/b3sem.h line 17

unbind defined in line 341; used 3 times

- in line 349
- in /usr/src/new/PORT/B/src/bint/b3in2.c line 124, 174

uniquify defined in line 44; used 7 times

- in line 64, 92, 173, 244, 269, 284, 294

Last modified: 1985-08-27 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 1442 |