Return to b2typ.c CVS log

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

Annotation of 43BSD/contrib/B/src/bsmall/b2typ.c, revision 1.1

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

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