Return to b3typ.c CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint

Annotation of 43BSD/contrib/B/src/bint/b3typ.c, revision 1.1.1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.