Return to b2tcP.c CVS log

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

Annotation of 43BSD/contrib/B/src/bint/b2tcP.c, revision 1.1

1.1     ! root        1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
        !             2: 
        !             3: /*
        !             4:   $Header: b2tcP.c,v 1.4 85/08/22 16:57:02 timo Exp $
        !             5: */
        !             6: 
        !             7: /* polytype representation */
        !             8: 
        !             9: #include "b.h"
        !            10: #include "b1obj.h"
        !            11: #include "b2tcP.h"
        !            12: 
        !            13: /* A polytype is a compound with two fields.
        !            14:  * The first field is a B text, and holds the typekind.
        !            15:  * If the typekind is 'Variable', the second field is 
        !            16:  *   a B text, holding the identifier of the variable;
        !            17:  * otherwise, the second field is a compound of sub(poly)types,
        !            18:  *   indexed from 0 to one less then the number of subtypes.
        !            19:  */
        !            20: 
        !            21: #define Kin    0
        !            22: #define Sub    1
        !            23: #define Id     Sub
        !            24: #define Asc    0
        !            25: #define Key    1
        !            26: 
        !            27: #define Kind(u)                ((typekind) *Field((value) (u), Kin))
        !            28: #define Psubtypes(u)   (Field((value) (u), Sub))
        !            29: #define Ident(u)       (*Field((value) (u), Id))
        !            30: 
        !            31: typekind var_kind;
        !            32: typekind num_kind;
        !            33: typekind tex_kind;
        !            34: typekind lis_kind;
        !            35: typekind tab_kind;
        !            36: typekind com_kind;
        !            37: typekind t_n_kind;
        !            38: typekind l_t_kind;
        !            39: typekind tlt_kind;
        !            40: typekind err_kind;
        !            41: 
        !            42: polytype num_type;
        !            43: polytype tex_type;
        !            44: polytype err_type;
        !            45: polytype t_n_type;
        !            46: 
        !            47: /* Making, setting and accessing (the fields of) polytypes */
        !            48: 
        !            49: Visible polytype mkt_polytype(k, nsub) typekind k; intlet nsub; {
        !            50:        value u;
        !            51:        
        !            52:        u = mk_compound(2);
        !            53:        *Field(u, Kin)= copy((value) k);
        !            54:        *Field(u, Sub)= mk_compound(nsub);
        !            55:        return ((polytype) u);
        !            56: }
        !            57: 
        !            58: Procedure putsubtype(sub, u, isub) polytype sub, u; intlet isub; {
        !            59:        *Field(*Psubtypes(u), isub)= (value) sub;
        !            60: }
        !            61: 
        !            62: typekind kind(u) polytype u; {
        !            63:        return (Kind(u));
        !            64: }
        !            65: 
        !            66: intlet nsubtypes(u) polytype u; {
        !            67:        return (Nfields(*Psubtypes(u)));
        !            68: }
        !            69: 
        !            70: polytype subtype(u, i) polytype u; intlet i; {
        !            71:        return ((polytype) *Field(*Psubtypes(u), i));
        !            72: }
        !            73: 
        !            74: polytype asctype(u) polytype u; {
        !            75:        return (subtype(u, Asc));
        !            76: }
        !            77: 
        !            78: polytype keytype(u) polytype u; {
        !            79:        return (subtype(u, Key));
        !            80: }
        !            81: 
        !            82: value ident(u) polytype u; {
        !            83:        return (Ident(u));
        !            84: }
        !            85: 
        !            86: /* making new polytypes */
        !            87: 
        !            88: polytype mkt_number() {
        !            89:        return(p_copy(num_type));
        !            90: }
        !            91: 
        !            92: polytype mkt_text() {
        !            93:        return(p_copy(tex_type));
        !            94: }
        !            95: 
        !            96: polytype mkt_tn() {
        !            97:        return(p_copy(t_n_type));
        !            98: }
        !            99: 
        !           100: polytype mkt_error() {
        !           101:        return(p_copy(err_type));
        !           102: }
        !           103: 
        !           104: polytype mkt_list(s) polytype s; {
        !           105:        polytype u;
        !           106:        
        !           107:        u = mkt_polytype(lis_kind, 1);
        !           108:        putsubtype(s, u, Asc);
        !           109:        return (u);
        !           110: }
        !           111: 
        !           112: polytype mkt_table(k, a) polytype k, a; {
        !           113:        polytype u;
        !           114:        
        !           115:        u = mkt_polytype(tab_kind, 2);
        !           116:        putsubtype(a, u, Asc);
        !           117:        putsubtype(k, u, Key);
        !           118:        return (u);
        !           119: }
        !           120: 
        !           121: polytype mkt_lt(s) polytype s; {
        !           122:        polytype u;
        !           123:        
        !           124:        u = mkt_polytype(l_t_kind, 1);
        !           125:        putsubtype(s, u, Asc);
        !           126:        return (u);
        !           127: }
        !           128: 
        !           129: polytype mkt_tlt(s) polytype s; {
        !           130:        polytype u;
        !           131:        
        !           132:        u = mkt_polytype(tlt_kind, 1);
        !           133:        putsubtype(s, u, Asc);
        !           134:        return (u);
        !           135: }
        !           136: 
        !           137: polytype mkt_compound(nsub) intlet nsub; {
        !           138:        return mkt_polytype(com_kind, nsub);
        !           139: }
        !           140: 
        !           141: polytype mkt_var(id) value id; {
        !           142:        polytype u;
        !           143:        
        !           144:        u = mk_compound(2);
        !           145:        *Field(u, Kin)= copy((value) var_kind);
        !           146:        *Field(u, Id)= id;
        !           147:        return (u);
        !           148: }
        !           149: 
        !           150: Hidden value nnewvar;
        !           151: 
        !           152: polytype mkt_newvar() {
        !           153:        value v;
        !           154:        v = sum(nnewvar, one);
        !           155:        release(nnewvar);
        !           156:        nnewvar = v;
        !           157:        return mkt_var(convert(nnewvar, No, No));
        !           158: }
        !           159: 
        !           160: polytype p_copy(u) polytype u; {
        !           161:        return((polytype) copy((polytype) u));
        !           162: }
        !           163: 
        !           164: Procedure p_release(u) polytype u; {
        !           165:        release((polytype) u);
        !           166: }
        !           167: 
        !           168: /* predicates */
        !           169: 
        !           170: bool are_same_types(u, v) polytype u, v; {
        !           171:        if (compare((value) Kind(u), (value) Kind(v)) NE 0)
        !           172:                return (No);
        !           173:        else if (t_is_var(Kind(u)))
        !           174:                return (compare(Ident(u), Ident(v)) EQ 0);
        !           175:        else
        !           176:                return (
        !           177:                        (nsubtypes(u) EQ nsubtypes(v))
        !           178:                        &&
        !           179:                        (compare(*Psubtypes(u), *Psubtypes(v)) EQ 0)
        !           180:                );
        !           181: }
        !           182: 
        !           183: bool have_same_structure(u, v) polytype u, v; {
        !           184:        return(
        !           185:                (compare((value) Kind(u), (value) Kind(v)) EQ 0)
        !           186:                &&
        !           187:                nsubtypes(u) EQ nsubtypes(v)
        !           188:        );
        !           189: }
        !           190: 
        !           191: bool t_is_number(kind) typekind kind; {
        !           192:        return (compare((value) kind, (value) num_kind) EQ 0 ? Yes : No);
        !           193: }
        !           194: 
        !           195: bool t_is_text(kind) typekind kind; {
        !           196:        return (compare((value) kind, (value) tex_kind) EQ 0 ? Yes : No);
        !           197: }
        !           198: 
        !           199: bool t_is_tn(kind) typekind kind; {
        !           200:        return (compare((value) kind, (value) t_n_kind) EQ 0 ? Yes : No);
        !           201: }
        !           202: 
        !           203: bool t_is_error(kind) typekind kind; {
        !           204:        return (compare((value) kind, (value) err_kind) EQ 0 ? Yes : No);
        !           205: }
        !           206: 
        !           207: bool t_is_list(kind) typekind kind; {
        !           208:        return (compare((value) kind, (value) lis_kind) EQ 0 ? Yes : No);
        !           209: }
        !           210: 
        !           211: bool t_is_table(kind) typekind kind; {
        !           212:        return (compare((value) kind, (value) tab_kind) EQ 0 ? Yes : No);
        !           213: }
        !           214: 
        !           215: bool t_is_lt(kind) typekind kind; {
        !           216:        return (compare((value) kind, (value) l_t_kind) EQ 0 ? Yes : No);
        !           217: }
        !           218: 
        !           219: bool t_is_tlt(kind) typekind kind; {
        !           220:        return (compare((value) kind, (value) tlt_kind) EQ 0 ? Yes : No);
        !           221: }
        !           222: 
        !           223: bool t_is_compound(kind) typekind kind; {
        !           224:        return (compare((value) kind, (value) com_kind) EQ 0 ? Yes : No);
        !           225: }
        !           226: 
        !           227: bool t_is_var(kind) typekind kind; {
        !           228:        return (compare((value) kind, (value) var_kind) EQ 0 ? Yes : No);
        !           229: }
        !           230: 
        !           231: bool has_number(kind) typekind kind; {
        !           232:        if (compare(kind, num_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
        !           233:                return (Yes);
        !           234:        else
        !           235:                return (No);
        !           236: }
        !           237: 
        !           238: bool has_text(kind) typekind kind; {
        !           239:        if (compare(kind, tex_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
        !           240:                return (Yes);
        !           241:        else
        !           242:                return (No);
        !           243: }
        !           244: 
        !           245: bool has_lt(kind) typekind kind; {
        !           246:        if (compare(kind, l_t_kind) EQ 0 || compare(kind, tlt_kind) EQ 0)
        !           247:                return (Yes);
        !           248:        else
        !           249:                return (No);
        !           250: }
        !           251: 
        !           252: /* The table "typeof" maps the identifiers of the variables (B texts)
        !           253:  * to polytypes.
        !           254:  */
        !           255:  
        !           256: value typeof;
        !           257: 
        !           258: Procedure repl_type_of(u, p) polytype u, p; {
        !           259:        replace((value) p, &typeof, Ident(u));
        !           260: }
        !           261: 
        !           262: bool table_has_type_of(u) polytype u; {
        !           263:        return(in_keys(Ident(u), typeof));
        !           264: }
        !           265: 
        !           266: polytype type_of(u) polytype u; {
        !           267:        return((polytype) *adrassoc(typeof, Ident(u)));
        !           268: }
        !           269: 
        !           270: polytype bottom_var(u) polytype u; {
        !           271:        polytype b;
        !           272: 
        !           273:        if (!t_is_var(Kind(u)))
        !           274:                return (u);
        !           275:        /* Kind(u) == Variable */
        !           276:        while (table_has_type_of(u)) {
        !           277:                b = type_of(u);
        !           278:                if (t_is_var(Kind(b)))
        !           279:                        u = b;
        !           280:                else
        !           281:                        break;
        !           282:        }
        !           283:        /* Kind(u) == Variable && !table_has_type_of(u)*/
        !           284:        return (u);
        !           285: }
        !           286: 
        !           287: Visible Procedure usetypetable(t) value t; {
        !           288:        typeof = t;
        !           289: }
        !           290: 
        !           291: Visible Procedure deltypetable() {
        !           292:        release(typeof);
        !           293: }
        !           294: 
        !           295: /* init */
        !           296: 
        !           297: Visible Procedure initpol() {
        !           298:        num_kind = mk_text("Number");
        !           299:        num_type = mkt_polytype(num_kind, 0);
        !           300:        tex_kind = mk_text("Text");
        !           301:        tex_type = mkt_polytype(tex_kind, 0);
        !           302:        t_n_kind = mk_text("TN");
        !           303:        t_n_type = mkt_polytype(t_n_kind, 0);
        !           304:        err_kind = mk_text("Error");
        !           305:        err_type = mkt_polytype(err_kind, 0);
        !           306:        
        !           307:        lis_kind = mk_text("List");
        !           308:        tab_kind = mk_text("Table");
        !           309:        com_kind = mk_text("Compound");
        !           310:        l_t_kind = mk_text("LT");
        !           311:        tlt_kind = mk_text("TLT");
        !           312:        var_kind = mk_text("Variable");
        !           313:        
        !           314:        nnewvar = zero;
        !           315: }

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