![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b3env.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint|
Return to b3env.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint |
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.