Return to b2tcU.c CVS log

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

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

1.1     ! root        1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
        !             2: 
        !             3: /*
        !             4:   $Header: b2tcU.c,v 1.4 85/08/22 16:57:11 timo Exp $
        !             5: */
        !             6: 
        !             7: /* unification of polytypes */
        !             8: 
        !             9: #include "b.h"
        !            10: #include "b1obj.h"
        !            11: #include "b2tcP.h"
        !            12: #include "b2tcU.h"
        !            13: #include "b2tcE.h"
        !            14: 
        !            15: Hidden bool bad;
        !            16: Hidden bool cycling;
        !            17: Hidden bool badcycle;
        !            18: 
        !            19: Visible Procedure unify(a, b, pu)
        !            20: polytype a, b, *pu;
        !            21: {
        !            22:        bad = No;
        !            23:        cycling = No;
        !            24:        setreprtable();
        !            25:        u_unify(a, b, pu);
        !            26:        if (bad) badtyperr(a, b);
        !            27:        delreprtable();
        !            28: }
        !            29: 
        !            30: Hidden Procedure u_unify(a, b, pu)
        !            31: polytype a, b, *pu;
        !            32: {
        !            33:        typekind a_kind, b_kind;
        !            34:        polytype res;
        !            35:        
        !            36:        a_kind = kind(a);
        !            37:        b_kind = kind(b);
        !            38:        
        !            39:        if (are_same_types(a, b)) {
        !            40:                *pu = p_copy(a);
        !            41:        }
        !            42:        else if (t_is_var(a_kind) || t_is_var(b_kind)) {
        !            43:                substitute_for(a, b, pu);
        !            44:        }
        !            45:        else if (have_same_structure(a, b)) {
        !            46:                unify_subtypes(a, b, pu);
        !            47:        }
        !            48:        else if (has_number(a_kind) && has_number(b_kind)) {
        !            49:                *pu = mkt_number();
        !            50:        }
        !            51:        else if (has_text(a_kind) && has_text(b_kind)) {
        !            52:                *pu = mkt_text();
        !            53:        }
        !            54:        else if (has_text(a_kind) && t_is_tlt(b_kind)) {
        !            55:                u_unify(asctype(b), (res = mkt_text()), pu);
        !            56:                p_release(res);
        !            57:        }
        !            58:        else if (has_text(b_kind) && t_is_tlt(a_kind)) {
        !            59:                u_unify(asctype(a), (res = mkt_text()), pu);
        !            60:                p_release(res);
        !            61:        }
        !            62:        else if ((t_is_list(a_kind) && has_lt(b_kind))
        !            63:                 ||
        !            64:                 (t_is_list(b_kind) && has_lt(a_kind))
        !            65:        )
        !            66:        {
        !            67:                u_unify(asctype(a), asctype(b), &res);
        !            68:                *pu = mkt_list(res);
        !            69:        }
        !            70:        else if (t_is_table(a_kind) && has_lt(b_kind)) {
        !            71:                u_unify(asctype(a), asctype(b), &res);
        !            72:                *pu = mkt_table(p_copy(keytype(a)), res);
        !            73:        }
        !            74:        else if (t_is_table(b_kind) && has_lt(a_kind)) {
        !            75:                u_unify(asctype(a), asctype(b), &res);
        !            76:                *pu = mkt_table(p_copy(keytype(b)), res);
        !            77:        }
        !            78:        else if ((t_is_tlt(a_kind) && t_is_lt(b_kind))
        !            79:                 || 
        !            80:                 (t_is_lt(a_kind) && t_is_tlt(b_kind)))
        !            81:        {
        !            82:                u_unify(asctype(a), asctype(b), &res);
        !            83:                *pu = mkt_lt(res);
        !            84:        }
        !            85:        else if (t_is_error(a_kind) || t_is_error(b_kind)) {
        !            86:                *pu = mkt_error();
        !            87:        }
        !            88:        else {
        !            89:                *pu = mkt_error();
        !            90:                if (cycling)
        !            91:                        badcycle = Yes;
        !            92:                else
        !            93:                        bad = Yes;
        !            94:        }
        !            95: }
        !            96: 
        !            97: Hidden Procedure unify_subtypes(a, b, pu)
        !            98: polytype a, b, *pu;
        !            99: {
        !           100:        polytype sa, sb, s;
        !           101:        intlet nsub, is;
        !           102:        
        !           103:        nsub = nsubtypes(a);
        !           104:        *pu = mkt_polytype(kind(a), nsub);
        !           105:        for (is = 0; is < nsub; is++) {
        !           106:                sa = subtype(a, is);
        !           107:                sb = subtype(b, is);
        !           108:                u_unify(sa, sb, &s);
        !           109:                putsubtype(s, *pu, is);
        !           110:        }
        !           111: }
        !           112: 
        !           113: Forward bool contains();
        !           114: Forward bool equal_vars();
        !           115: 
        !           116: Hidden Procedure substitute_for(a, b, pu)
        !           117: polytype a, b, *pu;
        !           118: {
        !           119:        typekind a_kind, b_kind;
        !           120:        polytype ta, tb;
        !           121:        bool ta_is_a, tb_is_b;
        !           122:        
        !           123:        a_kind = kind(a);
        !           124:        b_kind = kind(b);
        !           125:        
        !           126:        if (t_is_var(a_kind) && table_has_type_of(a)) {
        !           127:                ta = type_of(a);
        !           128:                ta_is_a = No;
        !           129:        }
        !           130:        else {
        !           131:                ta = a;
        !           132:                ta_is_a = Yes;
        !           133:        }
        !           134:        if (t_is_var(b_kind) && table_has_type_of(b)) {
        !           135:                tb = type_of(b);
        !           136:                tb_is_b = No;
        !           137:        }
        !           138:        else {
        !           139:                tb = b;
        !           140:                tb_is_b = Yes;
        !           141:        }
        !           142:        
        !           143:        if (!(ta_is_a && tb_is_b))
        !           144:                u_unify(ta, tb, pu);
        !           145:        else if (!t_is_var(a_kind))
        !           146:                *pu = p_copy(a);
        !           147:        else
        !           148:                *pu = p_copy(b);
        !           149:        
        !           150:        if (t_is_var(a_kind)) {
        !           151:                if (contains(*pu, bottom_var(a)))
        !           152:                        textify(a, pu);
        !           153:        }
        !           154:        if (t_is_var(b_kind)) {
        !           155:                if (contains(*pu, bottom_var(b)))
        !           156:                        textify(b, pu);
        !           157:        }
        !           158:        
        !           159:        if (t_is_var(a_kind) && !are_same_types(*pu, a))
        !           160:                repl_type_of(a, *pu);
        !           161:        if (t_is_var(b_kind) && !are_same_types(*pu, b))
        !           162:                repl_type_of(b, *pu);
        !           163: }
        !           164: 
        !           165: Hidden Procedure textify(a, pu)
        !           166: polytype a, *pu;
        !           167: {
        !           168:        polytype ttext, text_hopefully;
        !           169:        
        !           170:        ttext = mkt_text();
        !           171:        cycling = Yes;
        !           172:        badcycle = No;
        !           173:        u_unify(*pu, ttext, &text_hopefully);
        !           174:        if (badcycle EQ No) {
        !           175:                p_release(text_hopefully);
        !           176:                u_unify(a, ttext, &text_hopefully);
        !           177:        }
        !           178:        if (badcycle EQ No) {
        !           179:                *pu = ttext;
        !           180:        }
        !           181:        else {
        !           182:                *pu = mkt_error();
        !           183:                cyctyperr(a);
        !           184:                p_release(ttext);
        !           185:        }
        !           186:        p_release(text_hopefully);
        !           187:        cycling = No;
        !           188: }
        !           189: 
        !           190: Visible bool contains(u, a) polytype u, a; {
        !           191:        bool result;
        !           192:        
        !           193:        result = No;
        !           194:        if (t_is_var(kind(u))) {
        !           195:                if (table_has_type_of(u)) {
        !           196:                        result = contains(type_of(u), a);
        !           197:                }
        !           198:        }
        !           199:        else {
        !           200:                polytype s;
        !           201:                intlet is, nsub;
        !           202:                nsub = nsubtypes(u);
        !           203:                for (is = 0; is < nsub; is++) {
        !           204:                        s = subtype(u, is);
        !           205:                        if (equal_vars(s, a) || contains(s, a)) {
        !           206:                                result = Yes;
        !           207:                                break;
        !           208:                        }
        !           209:                }
        !           210:        }
        !           211:        return (result);
        !           212: }
        !           213: 
        !           214: Visible bool equal_vars(s, a) polytype s, a; {
        !           215:        return (are_same_types(bottom_var(s), a));
        !           216: }

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