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

   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: }

Defined functions

Defined variables