Return to b2loc.c CVS log

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

Annotation of 43BSD/contrib/B/src/bsmall/b2loc.c, revision 1.1

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

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