Return to cset.c CVS log

Up to [CSRG BSD Unix] / 3BSD / cmd / pi

Annotation of 3BSD/cmd/pi/cset.c, revision 1.1

1.1     ! root        1: /* Copyright (c) 1979 Regents of the University of California */
        !             2: #
        !             3: /*
        !             4:  * pi - Pascal interpreter code translator
        !             5:  *
        !             6:  * Charles Haley, Bill Joy UCB
        !             7:  * Version 1.2 November 1978
        !             8:  */
        !             9: 
        !            10: #include "whoami"
        !            11: #include "0.h"
        !            12: #include "tree.h"
        !            13: #include "opcode.h"
        !            14: 
        !            15: /*
        !            16:  * Constant set constructor.
        !            17:  * settype is the type of the
        !            18:  * set if we think that we know it
        !            19:  * if not we try our damndest to figure
        !            20:  * out what the type should be.
        !            21:  */
        !            22: struct nl *
        !            23: cset(r, settype, x)
        !            24:        int *r;
        !            25:        struct nl *settype;
        !            26:        int x;
        !            27: {
        !            28:        register *e;
        !            29:        register struct nl *t, *exptype;
        !            30:        int n, *el;
        !            31: 
        !            32:        if (settype == NIL) {
        !            33:                /*
        !            34:                 * So far we have no indication
        !            35:                 * of what the set type should be.
        !            36:                 * We "look ahead" and try to infer
        !            37:                 * The type of the constant set
        !            38:                 * by evaluating one of its members.
        !            39:                 */
        !            40:                e = r[2];
        !            41:                if (e == NIL)
        !            42:                        return (nl+TSET);       /* tenative for [] */
        !            43:                e = e[1];
        !            44:                if (e == NIL)
        !            45:                        return (NIL);
        !            46:                if (e[0] == T_RANG)
        !            47:                        e = e[1];
        !            48:                codeoff();
        !            49:                t = rvalue(e, NIL);
        !            50:                codeon();
        !            51:                if (t == NIL)
        !            52:                        return (NIL);
        !            53:                /*
        !            54:                 * The type of the set, settype, is
        !            55:                 * deemed to be a set of the base type
        !            56:                 * of t, which we call exptype.  If,
        !            57:                 * however, this would involve a
        !            58:                 * "set of integer", we cop out
        !            59:                 * and use "intset"'s current scoped
        !            60:                 * type instead.
        !            61:                 */
        !            62:                if (isa(t, "r")) {
        !            63:                        error("Sets may not have 'real' elements");
        !            64:                        return (NIL);
        !            65:                }
        !            66:                if (isnta(t, "bcsi")) {
        !            67:                        error("Set elements must be scalars, not %ss", nameof(t));
        !            68:                        return (NIL);
        !            69:                }
        !            70:                if (isa(t, "i")) {
        !            71:                        settype = lookup(intset);
        !            72:                        if (settype == NIL)
        !            73:                                panic("intset");
        !            74:                        settype = settype->type;
        !            75:                        if (settype == NIL)
        !            76:                                return (NIL);
        !            77:                        if (isnta(settype, "t")) {
        !            78:                                error("Set default type \"intset\" is not a set");
        !            79:                                return (NIL);
        !            80:                        }
        !            81:                        exptype = settype->type;
        !            82:                } else {
        !            83:                        exptype = t->type;
        !            84:                        if (exptype == NIL)
        !            85:                                return (NIL);
        !            86:                        if (exptype->class != RANGE)
        !            87:                                exptype = exptype->type;
        !            88:                        settype = defnl(0, SET, exptype, 0);
        !            89:                }
        !            90:        } else {
        !            91:                if (settype->class != SET) {
        !            92:                        /*
        !            93:                         * e.g string context [1,2] = 'abc'
        !            94:                         */
        !            95:                        error("Constant set involved in non set context");
        !            96:                        return (NIL);
        !            97:                }
        !            98:                exptype = settype->type;
        !            99:        }
        !           100:        if (x == NIL)
        !           101:                put2(O_PUSH, -width(settype));
        !           102:        n = 0;
        !           103:        for (el=r[2]; el; el=el[2]) {
        !           104:                n++;
        !           105:                e = el[1];
        !           106:                if (e == NIL)
        !           107:                        return (NIL);
        !           108:                if (e[0] == T_RANG) {
        !           109:                        t = rvalue(e[2], NIL);
        !           110:                        if (t == NIL) {
        !           111:                                rvalue(e[1], NIL);
        !           112:                                continue;
        !           113:                        }
        !           114:                        if (incompat(t, exptype, e[2]))
        !           115:                                cerror("Upper bound of element type clashed with set type in constant set");
        !           116:                        else
        !           117:                                convert(t, nl+T2INT);
        !           118:                        t = rvalue(e[1], NIL);
        !           119:                        if (t == NIL)
        !           120:                                continue;
        !           121:                        if (incompat(t, exptype, e[1]))
        !           122:                                cerror("Lower bound of element type clashed with set type in constant set");
        !           123:                        else
        !           124:                                convert(t, nl+T2INT);
        !           125:                } else {
        !           126:                        t = rvalue((int *) e, NLNIL);
        !           127:                        if (t == NIL)
        !           128:                                continue;
        !           129:                        if (incompat(t, exptype, e))
        !           130:                                cerror("Element type clashed with set type in constant set");
        !           131:                        else
        !           132:                                convert(t, nl+T2INT);
        !           133:                        put1(O_SDUP);
        !           134:                }
        !           135:        }
        !           136:        if (x == NIL) {
        !           137:                setran(exptype);
        !           138:                put(4, O_CTTOT, n, set.lwrb, set.uprbp);
        !           139:        } else
        !           140:                put2(O_CON2, n);
        !           141:        return (settype);
        !           142: }

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