Return to b3loc.c CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint

Annotation of 43BSD/contrib/B/src/bint/b3loc.c, revision 1.1

1.1     ! root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.