Return to b3env.c CVS log

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

Annotation of 43BSDTahoe/new/B/src/bint/b3env.c, revision 1.1

1.1     ! root        1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
        !             2: 
        !             3: /*
        !             4:   $Header: b3env.c,v 1.4 85/08/22 16:57:42 timo Exp $
        !             5: */
        !             6: 
        !             7: /* Environments */
        !             8: 
        !             9: #include "b.h"
        !            10: #include "b1obj.h"
        !            11: #include "b3err.h" /*for curline, curlino*/
        !            12: 
        !            13: Visible envtab prmnvtab;
        !            14: Visible envchain prmnvchain;
        !            15: Visible env prmnv;
        !            16: 
        !            17: /* context: */
        !            18: /* The bound tags for the current environment are stored in *bndtgs */
        !            19: /* A new bound tag list is created on evaluating a refined test or expression */
        !            20: 
        !            21: Visible env curnv;
        !            22: Visible value *bndtgs;
        !            23: Hidden value bndtglist;
        !            24: Visible literal cntxt, resexp;
        !            25: Visible value uname= Vnil;
        !            26: Visible intlet lino;
        !            27: Visible intlet f_lino;
        !            28: 
        !            29: Visible context read_context;
        !            30: 
        !            31: Visible Procedure sv_context(sc) context *sc; {
        !            32:        sc->curnv= curnv;
        !            33:        sc->bndtgs= bndtgs;
        !            34:        sc->cntxt= cntxt;
        !            35:        sc->resexp= resexp;
        !            36:        sc->uname= copy(uname);
        !            37:        sc->cur_line= curline;
        !            38:        sc->cur_lino= curlino;
        !            39: }
        !            40: 
        !            41: Visible Procedure set_context(sc) context *sc; {
        !            42:        curnv= sc->curnv;
        !            43:        bndtgs= sc->bndtgs;
        !            44:        cntxt= sc->cntxt;
        !            45:        resexp= sc->resexp;
        !            46:        release(uname); uname= sc->uname;
        !            47:        curline= sc->cur_line;
        !            48:        curlino= sc->cur_lino;
        !            49: }
        !            50: 
        !            51: Visible Procedure initenv() {
        !            52:        /* The following invariant must be maintained:
        !            53:           EITHER:
        !            54:              the original permanent-environment table resides in prmnv->tab
        !            55:              and prmnvtab == Vnil
        !            56:           OR:
        !            57:              the original permanent-environment table resides in prmnvtab
        !            58:              and prmnv->tab contains a scratch-pad copy.
        !            59:        */
        !            60:        prmnv= &prmnvchain;
        !            61:        prmnv->tab= mk_elt(); prmnvtab= Vnil;
        !            62:        prmnv->inv_env= Enil;
        !            63:        bndtglist= mk_elt();
        !            64: }
        !            65: 
        !            66: Visible Procedure endenv() {
        !            67:        release(prmnv->tab); prmnv->tab= Vnil;
        !            68:        release(bndtglist); bndtglist= Vnil;
        !            69:        release(uname); uname= Vnil;
        !            70:        release(erruname); erruname= Vnil;
        !            71: }
        !            72: 
        !            73: Visible Procedure re_env() {
        !            74:        setprmnv(); bndtgs= &bndtglist;
        !            75: }
        !            76: 
        !            77: Visible Procedure setprmnv() {
        !            78:        /* the current and permanent environment are reset
        !            79:           to the original permanent environment */
        !            80:        if (prmnvtab != Vnil) {
        !            81:                prmnv->tab= prmnvtab;
        !            82:                prmnvtab= Vnil;
        !            83:        }
        !            84:        curnv= prmnv;
        !            85: }
        !            86: 
        !            87: Visible Procedure e_replace(v, t, k) value v, *t, k; {
        !            88:        if (Is_compound(*t)) {
        !            89:                int n= SmallIntVal(k);
        !            90:                uniql(t);
        !            91:                if (*Field(*t, n) != Vnil) release(*Field(*t, n));
        !            92:                *Field(*t, n)= copy(v);
        !            93:        }
        !            94:        else if (!Is_table(*t)) syserr(MESS(2900, "replacing in non-environment"));
        !            95:        else replace(v, t, k);
        !            96: }
        !            97: 
        !            98: Visible Procedure e_delete(t, k) value *t, k; {
        !            99:        if (Is_compound(*t) && IsSmallInt(k)) {
        !           100:                int n= SmallIntVal(k);
        !           101:                if (*Field(*t, n) != Vnil) {
        !           102:                        uniql(t); release(*Field(*t, n));
        !           103:                        *Field(*t, n)= Vnil;
        !           104:                }
        !           105:        }
        !           106:        else if (!Is_table(*t)) syserr(MESS(2901, "deleting from non-environment"));
        !           107:        else if (in_keys(k, *t)) delete(t, k);
        !           108: }
        !           109: 
        !           110: Visible value* envassoc(t, ke) value t, ke; {
        !           111:        if (Is_compound(t) && IsSmallInt(ke)) {
        !           112:                int n= SmallIntVal(ke);
        !           113:                if (*Field(t, n) == Vnil) return Pnil;
        !           114:                return Field(t, n);
        !           115:        }
        !           116:        if (!Is_table(t)) syserr(MESS(2902, "selection on non-environment"));
        !           117:        return adrassoc(t, ke);
        !           118: }
        !           119: 
        !           120: Visible bool in_env(tab, ke, aa) value tab, ke, **aa; {
        !           121:        /* IF ke in keys tab:
        !           122:                PUT tab[ke] IN aa
        !           123:                SUCCEED
        !           124:           FAIL
        !           125:        */
        !           126:        *aa= envassoc(tab, ke);
        !           127:        return (*aa != Pnil);
        !           128: }
        !           129: 
        !           130: Visible Procedure extbnd_tags(btl, et) value btl; envtab et; {
        !           131:        /* Copy bound targets to the invoking environment */
        !           132:        /* FOR tag IN btl: \ btl is the bound tag list
        !           133:               IF tag in keys et: \ et is the environment we're just leaving
        !           134:                   PUT et[tag] IN curnv[tag] \ curnv is the invoking environment
        !           135:        */
        !           136:        value *aa, tag;
        !           137:        int len= length(btl), k;
        !           138:        for (k= 1; k <= len; k++) {
        !           139:                tag= thof(k, btl);
        !           140:                if (in_env(et, tag, &aa)) {
        !           141:                        e_replace(*aa, &(curnv->tab), tag);
        !           142:                        if (*bndtgs != Vnil) insert(tag, bndtgs);
        !           143:                }
        !           144:                release(tag);
        !           145:        }
        !           146: }
        !           147: 
        !           148: Visible Procedure lst_ttgs() {
        !           149:        int k, len;
        !           150:        len= length(prmnv->tab);
        !           151:        k_Over_len {
        !           152:                writ(*key(prmnv->tab, k));
        !           153:                wri_space();
        !           154:        }
        !           155:        newline();
        !           156: }

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