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     ! 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.