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

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b2tcP.c,v 1.4 85/08/22 16:57:02 timo Exp $
   5: */
   6: 
   7: /* polytype representation */
   8: 
   9: #include "b.h"
  10: #include "b1obj.h"
  11: #include "b2tcP.h"
  12: 
  13: /* A polytype is a compound with two fields.
  14:  * The first field is a B text, and holds the typekind.
  15:  * If the typekind is 'Variable', the second field is
  16:  *   a B text, holding the identifier of the variable;
  17:  * otherwise, the second field is a compound of sub(poly)types,
  18:  *   indexed from 0 to one less then the number of subtypes.
  19:  */
  20: 
  21: #define Kin 0
  22: #define Sub 1
  23: #define Id  Sub
  24: #define Asc 0
  25: #define Key 1
  26: 
  27: #define Kind(u)     ((typekind) *Field((value) (u), Kin))
  28: #define Psubtypes(u)    (Field((value) (u), Sub))
  29: #define Ident(u)    (*Field((value) (u), Id))
  30: 
  31: typekind var_kind;
  32: typekind num_kind;
  33: typekind tex_kind;
  34: typekind lis_kind;
  35: typekind tab_kind;
  36: typekind com_kind;
  37: typekind t_n_kind;
  38: typekind l_t_kind;
  39: typekind tlt_kind;
  40: typekind err_kind;
  41: 
  42: polytype num_type;
  43: polytype tex_type;
  44: polytype err_type;
  45: polytype t_n_type;
  46: 
  47: /* Making, setting and accessing (the fields of) polytypes */
  48: 
  49: Visible polytype mkt_polytype(k, nsub) typekind k; intlet nsub; {
  50:     value u;
  51: 
  52:     u = mk_compound(2);
  53:     *Field(u, Kin)= copy((value) k);
  54:     *Field(u, Sub)= mk_compound(nsub);
  55:     return ((polytype) u);
  56: }
  57: 
  58: Procedure putsubtype(sub, u, isub) polytype sub, u; intlet isub; {
  59:     *Field(*Psubtypes(u), isub)= (value) sub;
  60: }
  61: 
  62: typekind kind(u) polytype u; {
  63:     return (Kind(u));
  64: }
  65: 
  66: intlet nsubtypes(u) polytype u; {
  67:     return (Nfields(*Psubtypes(u)));
  68: }
  69: 
  70: polytype subtype(u, i) polytype u; intlet i; {
  71:     return ((polytype) *Field(*Psubtypes(u), i));
  72: }
  73: 
  74: polytype asctype(u) polytype u; {
  75:     return (subtype(u, Asc));
  76: }
  77: 
  78: polytype keytype(u) polytype u; {
  79:     return (subtype(u, Key));
  80: }
  81: 
  82: value ident(u) polytype u; {
  83:     return (Ident(u));
  84: }
  85: 
  86: /* making new polytypes */
  87: 
  88: polytype mkt_number() {
  89:     return(p_copy(num_type));
  90: }
  91: 
  92: polytype mkt_text() {
  93:     return(p_copy(tex_type));
  94: }
  95: 
  96: polytype mkt_tn() {
  97:     return(p_copy(t_n_type));
  98: }
  99: 
 100: polytype mkt_error() {
 101:     return(p_copy(err_type));
 102: }
 103: 
 104: polytype mkt_list(s) polytype s; {
 105:     polytype u;
 106: 
 107:     u = mkt_polytype(lis_kind, 1);
 108:     putsubtype(s, u, Asc);
 109:     return (u);
 110: }
 111: 
 112: polytype mkt_table(k, a) polytype k, a; {
 113:     polytype u;
 114: 
 115:     u = mkt_polytype(tab_kind, 2);
 116:     putsubtype(a, u, Asc);
 117:     putsubtype(k, u, Key);
 118:     return (u);
 119: }
 120: 
 121: polytype mkt_lt(s) polytype s; {
 122:     polytype u;
 123: 
 124:     u = mkt_polytype(l_t_kind, 1);
 125:     putsubtype(s, u, Asc);
 126:     return (u);
 127: }
 128: 
 129: polytype mkt_tlt(s) polytype s; {
 130:     polytype u;
 131: 
 132:     u = mkt_polytype(tlt_kind, 1);
 133:     putsubtype(s, u, Asc);
 134:     return (u);
 135: }
 136: 
 137: polytype mkt_compound(nsub) intlet nsub; {
 138:     return mkt_polytype(com_kind, nsub);
 139: }
 140: 
 141: polytype mkt_var(id) value id; {
 142:     polytype u;
 143: 
 144:     u = mk_compound(2);
 145:     *Field(u, Kin)= copy((value) var_kind);
 146:     *Field(u, Id)= id;
 147:     return (u);
 148: }
 149: 
 150: Hidden value nnewvar;
 151: 
 152: polytype mkt_newvar() {
 153:     value v;
 154:     v = sum(nnewvar, one);
 155:     release(nnewvar);
 156:     nnewvar = v;
 157:     return mkt_var(convert(nnewvar, No, No));
 158: }
 159: 
 160: polytype p_copy(u) polytype u; {
 161:     return((polytype) copy((polytype) u));
 162: }
 163: 
 164: Procedure p_release(u) polytype u; {
 165:     release((polytype) u);
 166: }
 167: 
 168: /* predicates */
 169: 
 170: bool are_same_types(u, v) polytype u, v; {
 171:     if (compare((value) Kind(u), (value) Kind(v)) NE 0)
 172:         return (No);
 173:     else if (t_is_var(Kind(u)))
 174:         return (compare(Ident(u), Ident(v)) EQ 0);
 175:     else
 176:         return (
 177:             (nsubtypes(u) EQ nsubtypes(v))
 178:             &&
 179:             (compare(*Psubtypes(u), *Psubtypes(v)) EQ 0)
 180:         );
 181: }
 182: 
 183: bool have_same_structure(u, v) polytype u, v; {
 184:     return(
 185:         (compare((value) Kind(u), (value) Kind(v)) EQ 0)
 186:         &&
 187:         nsubtypes(u) EQ nsubtypes(v)
 188:     );
 189: }
 190: 
 191: bool t_is_number(kind) typekind kind; {
 192:     return (compare((value) kind, (value) num_kind) EQ 0 ? Yes : No);
 193: }
 194: 
 195: bool t_is_text(kind) typekind kind; {
 196:     return (compare((value) kind, (value) tex_kind) EQ 0 ? Yes : No);
 197: }
 198: 
 199: bool t_is_tn(kind) typekind kind; {
 200:     return (compare((value) kind, (value) t_n_kind) EQ 0 ? Yes : No);
 201: }
 202: 
 203: bool t_is_error(kind) typekind kind; {
 204:     return (compare((value) kind, (value) err_kind) EQ 0 ? Yes : No);
 205: }
 206: 
 207: bool t_is_list(kind) typekind kind; {
 208:     return (compare((value) kind, (value) lis_kind) EQ 0 ? Yes : No);
 209: }
 210: 
 211: bool t_is_table(kind) typekind kind; {
 212:     return (compare((value) kind, (value) tab_kind) EQ 0 ? Yes : No);
 213: }
 214: 
 215: bool t_is_lt(kind) typekind kind; {
 216:     return (compare((value) kind, (value) l_t_kind) EQ 0 ? Yes : No);
 217: }
 218: 
 219: bool t_is_tlt(kind) typekind kind; {
 220:     return (compare((value) kind, (value) tlt_kind) EQ 0 ? Yes : No);
 221: }
 222: 
 223: bool t_is_compound(kind) typekind kind; {
 224:     return (compare((value) kind, (value) com_kind) EQ 0 ? Yes : No);
 225: }
 226: 
 227: bool t_is_var(kind) typekind kind; {
 228:     return (compare((value) kind, (value) var_kind) EQ 0 ? Yes : No);
 229: }
 230: 
 231: bool has_number(kind) typekind kind; {
 232:     if (compare(kind, num_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
 233:         return (Yes);
 234:     else
 235:         return (No);
 236: }
 237: 
 238: bool has_text(kind) typekind kind; {
 239:     if (compare(kind, tex_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
 240:         return (Yes);
 241:     else
 242:         return (No);
 243: }
 244: 
 245: bool has_lt(kind) typekind kind; {
 246:     if (compare(kind, l_t_kind) EQ 0 || compare(kind, tlt_kind) EQ 0)
 247:         return (Yes);
 248:     else
 249:         return (No);
 250: }
 251: 
 252: /* The table "typeof" maps the identifiers of the variables (B texts)
 253:  * to polytypes.
 254:  */
 255: 
 256: value typeof;
 257: 
 258: Procedure repl_type_of(u, p) polytype u, p; {
 259:     replace((value) p, &typeof, Ident(u));
 260: }
 261: 
 262: bool table_has_type_of(u) polytype u; {
 263:     return(in_keys(Ident(u), typeof));
 264: }
 265: 
 266: polytype type_of(u) polytype u; {
 267:     return((polytype) *adrassoc(typeof, Ident(u)));
 268: }
 269: 
 270: polytype bottom_var(u) polytype u; {
 271:     polytype b;
 272: 
 273:     if (!t_is_var(Kind(u)))
 274:         return (u);
 275:     /* Kind(u) == Variable */
 276:     while (table_has_type_of(u)) {
 277:         b = type_of(u);
 278:         if (t_is_var(Kind(b)))
 279:             u = b;
 280:         else
 281:             break;
 282:     }
 283:     /* Kind(u) == Variable && !table_has_type_of(u)*/
 284:     return (u);
 285: }
 286: 
 287: Visible Procedure usetypetable(t) value t; {
 288:     typeof = t;
 289: }
 290: 
 291: Visible Procedure deltypetable() {
 292:     release(typeof);
 293: }
 294: 
 295: /* init */
 296: 
 297: Visible Procedure initpol() {
 298:     num_kind = mk_text("Number");
 299:     num_type = mkt_polytype(num_kind, 0);
 300:     tex_kind = mk_text("Text");
 301:     tex_type = mkt_polytype(tex_kind, 0);
 302:     t_n_kind = mk_text("TN");
 303:     t_n_type = mkt_polytype(t_n_kind, 0);
 304:     err_kind = mk_text("Error");
 305:     err_type = mkt_polytype(err_kind, 0);
 306: 
 307:     lis_kind = mk_text("List");
 308:     tab_kind = mk_text("Table");
 309:     com_kind = mk_text("Compound");
 310:     l_t_kind = mk_text("LT");
 311:     tlt_kind = mk_text("TLT");
 312:     var_kind = mk_text("Variable");
 313: 
 314:     nnewvar = zero;
 315: }

Defined functions

Defined variables

Defined macros