4.3BSD - /usr/src/new/B/src/bsmall/b2typ.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
   2: /* $Header: b2typ.c,v 1.1 84/06/28 00:49:27 timo Exp $ */
   3: 
   4: /* Type matching */
   5: #include "b.h"
   6: #include "b1obj.h"
   7: #include "b2env.h"
   8: #include "b2sem.h"
   9: #include "b2typ.h"
  10: 
  11: #define Tnil ((btype) Vnil)
  12: 
  13: Forward btype valtype();
  14: 
  15: /* All the routines in this file are temporary */
  16: /* Thus length() and empty() have been put here too */
  17: 
  18: Visible int length(v) value v; {
  19:     value s= size(v);
  20:     int len= intval(s);
  21:     release(s);
  22:     return len;
  23: }
  24: 
  25: Visible bool empty(v) value v; {
  26:     value s= size(v);
  27:     bool b= large(s) || intval(s)!=0;
  28:     release(s);
  29:     return !b;
  30: }
  31: 
  32: Visible btype loctype(l) loc l; {
  33:     value *ll;
  34:     if (Is_simploc(l)) {
  35:         simploc *sl= Simploc(l);
  36:         if (!in_env(sl->e->tab, sl->i, &ll)) return Tnil;
  37:         return valtype(*ll);
  38:     } else if (Is_tbseloc(l)) {
  39:         tbseloc *tl= Tbseloc(l);
  40:         btype tt= loctype(tl->R), associate;
  41:         if (tt == Tnil) return Tnil;
  42:         if (!empty(tt)) associate= th_of(one, tt);
  43:         else associate= Tnil;
  44:         release(tt);
  45:         return associate;
  46:     } else if (Is_trimloc(l)) {
  47:         return mk_text("");
  48:     } else if (Is_compound(l)) {
  49:         btype ct= mk_compound(Nfields(l)); intlet k, len= Nfields(l);
  50:         k_Overfields { put_in_field(loctype(*field(l, k)), &ct, k); }
  51:         return ct;
  52:     } else {
  53:         syserr("loctype asked of non-target");
  54:         return Tnil;
  55:     }
  56: }
  57: 
  58: Visible btype valtype(v) value v; {
  59:     if (Is_number(v)) return mk_integer(0);
  60:     else if (Is_text(v)) return mk_text("");
  61:     else if (Is_compound(v)) {
  62:         btype ct= mk_compound(Nfields(v)); intlet k, len= Nfields(v);
  63:         k_Overfields { put_in_field(valtype(*field(v, k)), &ct, k); }
  64:         return ct;
  65:     } else if (Is_ELT(v)) {
  66:         return mk_elt();
  67:     } else if (Is_list(v)) {
  68:         btype tt= mk_elt(), vt, ve;
  69:         if (!empty(v)) {
  70:             insert(vt= valtype(ve= min1(v)), &tt);
  71:             release(vt); release(ve);
  72:         }
  73:         return tt;
  74:     } else if (Is_table(v)) {
  75:         btype tt= mk_elt(), vk, va;
  76:         if (!empty(v)) {
  77:             vk= valtype(*key(v, 0));
  78:             va= valtype(*assoc(v, 0));
  79:             replace(va, &tt, vk);
  80:             release(vk); release(va);
  81:         }
  82:         return tt;
  83:     } else {
  84:         syserr("valtype called with unknown type");
  85:         return Tnil;
  86:     }
  87: }
  88: 
  89: Visible must_agree(t, u, m) btype t, u; string m; {
  90:     intlet k, len;
  91:     value vt, vu;
  92:     if (t == Tnil || u == Tnil || t == u) return;
  93:     if ((Is_number(t) && Is_number(u))
  94:      || (Is_text(t) && Is_text(u))
  95:      || (Is_ELT(u) && (Is_ELT(t) || Is_list(t) || Is_table(t)))
  96:      || (Is_ELT(t) && (Is_ELT(u) || Is_list(u) || Is_table(u)))) return;
  97:     else if (Is_compound(t) && Is_compound(u)) {
  98:         if ((len= Nfields(t)) != Nfields(u)) error(m);
  99:         else k_Overfields { must_agree(*field(t,k), *field(u,k), m); }
 100:     } else {
 101:         if (Is_list(t) && Is_list(u)) {
 102:             if (!empty(t) && !empty(u)) {
 103:                 must_agree(vt= min1(t), vu= min1(u), m);
 104:                 release(vt); release(vu);
 105:             }
 106:         } else if (Is_table(t) && Is_table(u)) {
 107:             if (!empty(t) && !empty(u)) {
 108:                 must_agree(*key(t, 0), *key(u, 0), m);
 109:                 must_agree(*assoc(t, 0), *assoc(u, 0), m);
 110:             }
 111:         } else error(m);
 112:     }
 113: }

Defined functions

Defined macros