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

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

Defined functions

Defined macros