Return to pclval.c CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / pascal / src

Annotation of 42BSD/ucb/pascal/src/pclval.c, revision 1.1

1.1     ! root        1: /* Copyright (c) 1979 Regents of the University of California */
        !             2: 
        !             3: static char sccsid[] = "@(#)pclval.c 1.4 6/1/81";
        !             4: 
        !             5: #include "whoami.h"
        !             6: #include "0.h"
        !             7: #include "tree.h"
        !             8: #include "opcode.h"
        !             9: #include "objfmt.h"
        !            10: #ifdef PC
        !            11:        /*
        !            12:         *      and the rest of the file
        !            13:         */
        !            14: #   include    "pc.h"
        !            15: #   include    "pcops.h"
        !            16: 
        !            17: extern int flagwas;
        !            18: /*
        !            19:  * pclvalue computes the address
        !            20:  * of a qualified name and
        !            21:  * leaves it on the stack.
        !            22:  * for pc, it can be asked for either an lvalue or an rvalue.
        !            23:  * the semantics are the same, only the code is different.
        !            24:  * for putting out calls to check for nil and fnil,
        !            25:  * we have to traverse the list of qualifications twice:
        !            26:  * once to put out the calls and once to put out the address to be checked.
        !            27:  */
        !            28: struct nl *
        !            29: pclvalue( r , modflag , required )
        !            30:        int     *r;
        !            31:        int     modflag;
        !            32:        int     required;
        !            33: {
        !            34:        register struct nl      *p;
        !            35:        register                *c, *co;
        !            36:        int                     f, o;
        !            37:        int                     tr[2], trp[3];
        !            38:        struct nl               *firstp;
        !            39:        struct nl               *lastp;
        !            40:        char                    *firstsymbol;
        !            41:        char                    firstextra_flags;
        !            42:        int                     firstbn;
        !            43: 
        !            44:        if ( r == NIL ) {
        !            45:                return NIL;
        !            46:        }
        !            47:        if ( nowexp( r ) ) {
        !            48:                return NIL;
        !            49:        }
        !            50:        if ( r[0] != T_VAR ) {
        !            51:                error("Variable required");     /* Pass mesgs down from pt of call ? */
        !            52:                return NIL;
        !            53:        }
        !            54:        firstp = p = lookup( r[2] );
        !            55:        if ( p == NIL ) {
        !            56:                return NIL;
        !            57:        }
        !            58:        firstsymbol = p -> symbol;
        !            59:        firstbn = bn;
        !            60:        firstextra_flags = p -> extra_flags;
        !            61:        c = r[3];
        !            62:        if ( ( modflag & NOUSE ) && ! lptr( c ) ) {
        !            63:                p -> nl_flags = flagwas;
        !            64:        }
        !            65:        if ( modflag & MOD ) {
        !            66:                p -> nl_flags |= NMOD;
        !            67:        }
        !            68:        /*
        !            69:         * Only possibilities for p -> class here
        !            70:         * are the named classes, i.e. CONST, TYPE
        !            71:         * VAR, PROC, FUNC, REF, or a WITHPTR.
        !            72:         */
        !            73:        if ( p -> class == WITHPTR ) {
        !            74:                /*
        !            75:                 * Construct the tree implied by
        !            76:                 * the with statement
        !            77:                 */
        !            78:            trp[0] = T_LISTPP;
        !            79:            trp[1] = tr;
        !            80:            trp[2] = r[3];
        !            81:            tr[0] = T_FIELD;
        !            82:            tr[1] = r[2];
        !            83:            c = trp;
        !            84:        }
        !            85:            /*
        !            86:             *  this not only puts out the names of functions to call
        !            87:             *  but also does all the semantic checking of the qualifications.
        !            88:             */
        !            89:        if ( ! nilfnil( p , c , modflag , firstp , r[2] ) ) {
        !            90:            return NIL;
        !            91:        }
        !            92:        switch (p -> class) {
        !            93:                case WITHPTR:
        !            94:                case REF:
        !            95:                        /*
        !            96:                         * Obtain the indirect word
        !            97:                         * of the WITHPTR or REF
        !            98:                         * as the base of our lvalue
        !            99:                         */
        !           100:                        putRV( firstsymbol , firstbn , p -> value[ 0 ] ,
        !           101:                                firstextra_flags , p2type( p ) );
        !           102:                        firstsymbol = 0;
        !           103:                        f = 0;          /* have an lv on stack */
        !           104:                        o = 0;
        !           105:                        break;
        !           106:                case VAR:
        !           107:                        f = 1;          /* no lv on stack yet */
        !           108:                        o = p -> value[0];
        !           109:                        break;
        !           110:                default:
        !           111:                        error("%s %s found where variable required", classes[p -> class], p -> symbol);
        !           112:                        return (NIL);
        !           113:        }
        !           114:        /*
        !           115:         * Loop and handle each
        !           116:         * qualification on the name
        !           117:         */
        !           118:        if ( c == NIL &&
        !           119:            ( modflag & ASGN ) &&
        !           120:            ( p -> value[ NL_FORV ] & FORVAR ) ) {
        !           121:                error("Can't modify the for variable %s in the range of the loop", p -> symbol);
        !           122:                return (NIL);
        !           123:        }
        !           124:        for ( ; c != NIL ; c = c[2] ) {
        !           125:                co = c[1];
        !           126:                if ( co == NIL ) {
        !           127:                        return NIL;
        !           128:                }
        !           129:                lastp = p;
        !           130:                p = p -> type;
        !           131:                if ( p == NIL ) {
        !           132:                        return NIL;
        !           133:                }
        !           134:                switch ( co[0] ) {
        !           135:                        case T_PTR:
        !           136:                                /*
        !           137:                                 * Pointer qualification.
        !           138:                                 */
        !           139:                                if ( f ) {
        !           140:                                        putLV( firstsymbol , firstbn , o ,
        !           141:                                            firstextra_flags , p2type( p ) );
        !           142:                                        firstsymbol = 0;
        !           143:                                } else {
        !           144:                                        if (o) {
        !           145:                                            putleaf( P2ICON , o , 0 , P2INT
        !           146:                                                    , 0 );
        !           147:                                            putop( P2PLUS , P2PTR | P2CHAR );
        !           148:                                        }
        !           149:                                }
        !           150:                                    /*
        !           151:                                     * Pointer cannot be
        !           152:                                     * nil and file cannot
        !           153:                                     * be at end-of-file.
        !           154:                                     * the appropriate function name is 
        !           155:                                     * already out there from nilfnil.
        !           156:                                     */
        !           157:                                if ( p -> class == PTR ) {
        !           158:                                        /*
        !           159:                                         * this is the indirection from
        !           160:                                         * the address of the pointer 
        !           161:                                         * to the pointer itself.
        !           162:                                         * kirk sez:
        !           163:                                         * fnil doesn't want this.
        !           164:                                         * and does it itself for files
        !           165:                                         * since only it knows where the
        !           166:                                         * actual window is.
        !           167:                                         * but i have to do this for
        !           168:                                         * regular pointers.
        !           169:                                         */
        !           170:                                    putop( P2UNARY P2MUL , p2type( p ) );
        !           171:                                    if ( opt( 't' ) ) {
        !           172:                                        putop( P2CALL , P2INT );
        !           173:                                    }
        !           174:                                } else {
        !           175:                                    putop( P2CALL , P2INT );
        !           176:                                }
        !           177:                                f = o = 0;
        !           178:                                continue;
        !           179:                        case T_ARGL:
        !           180:                        case T_ARY:
        !           181:                                if ( f ) {
        !           182:                                        putLV( firstsymbol , firstbn , o ,
        !           183:                                            firstextra_flags , p2type( p ) );
        !           184:                                        firstsymbol = 0;
        !           185:                                } else {
        !           186:                                        if (o) {
        !           187:                                            putleaf( P2ICON , o , 0 , P2INT
        !           188:                                                    , 0 );
        !           189:                                            putop( P2PLUS , P2INT );
        !           190:                                        }
        !           191:                                }
        !           192:                                arycod( p , co[1] );
        !           193:                                f = o = 0;
        !           194:                                continue;
        !           195:                        case T_FIELD:
        !           196:                                /*
        !           197:                                 * Field names are just
        !           198:                                 * an offset with some 
        !           199:                                 * semantic checking.
        !           200:                                 */
        !           201:                                p = reclook(p, co[1]);
        !           202:                                o += p -> value[0];
        !           203:                                continue;
        !           204:                        default:
        !           205:                                panic("lval2");
        !           206:                }
        !           207:        }
        !           208:        if (f) {
        !           209:                if ( required == LREQ ) {
        !           210:                    putLV( firstsymbol , firstbn , o ,
        !           211:                            firstextra_flags , p2type( p -> type ) );
        !           212:                } else {
        !           213:                    putRV( firstsymbol , firstbn , o ,
        !           214:                            firstextra_flags , p2type( p -> type ) );
        !           215:                }
        !           216:        } else {
        !           217:                if (o) {
        !           218:                    putleaf( P2ICON , o , 0 , P2INT , 0 );
        !           219:                    putop( P2PLUS , P2INT );
        !           220:                }
        !           221:                if ( required == RREQ ) {
        !           222:                    putop( P2UNARY P2MUL , p2type( p -> type ) );
        !           223:                }
        !           224:        }
        !           225:        return ( p -> type );
        !           226: }
        !           227: 
        !           228:     /*
        !           229:      * this recursively follows done a list of qualifications
        !           230:      * and puts out the beginnings of calls to fnil for files
        !           231:      * or nil for pointers (if checking is on) on the way back.
        !           232:      * this returns true or false.
        !           233:      */
        !           234: nilfnil( p , c , modflag , firstp , r2 )
        !           235:     struct nl  *p;
        !           236:     int                *c;
        !           237:     int                modflag;
        !           238:     struct nl  *firstp;
        !           239:     char       *r2;            /* no, not r2-d2 */
        !           240:     {
        !           241:        int             *co;
        !           242:        struct nl       *lastp;
        !           243:        int             t;
        !           244: 
        !           245:        if ( c == NIL ) {
        !           246:            return TRUE;
        !           247:        }
        !           248:        co = (int *) ( c[1] );
        !           249:        if ( co == NIL ) {
        !           250:                return FALSE;
        !           251:        }
        !           252:        lastp = p;
        !           253:        p = p -> type;
        !           254:        if ( p == NIL ) {
        !           255:                return FALSE;
        !           256:        }
        !           257:        switch ( co[0] ) {
        !           258:            case T_PTR:
        !           259:                    /*
        !           260:                     * Pointer qualification.
        !           261:                     */
        !           262:                    lastp -> nl_flags |= NUSED;
        !           263:                    if ( p -> class != PTR && p -> class != FILET) {
        !           264:                            error("^ allowed only on files and pointers, not on %ss", nameof(p));
        !           265:                            goto bad;
        !           266:                    }
        !           267:                    break;
        !           268:            case T_ARGL:
        !           269:                    if ( p -> class != ARRAY ) {
        !           270:                            if ( lastp == firstp ) {
        !           271:                                    error("%s is a %s, not a function", r2, classes[firstp -> class]);
        !           272:                            } else {
        !           273:                                    error("Illegal function qualificiation");
        !           274:                            }
        !           275:                            return FALSE;
        !           276:                    }
        !           277:                    recovered();
        !           278:                    error("Pascal uses [] for subscripting, not ()");
        !           279:                    /* and fall through */
        !           280:            case T_ARY:
        !           281:                    if ( p -> class != ARRAY ) {
        !           282:                            error("Subscripting allowed only on arrays, not on %ss", nameof(p));
        !           283:                            goto bad;
        !           284:                    }
        !           285:                    codeoff();
        !           286:                    t = arycod( p , co[1] );
        !           287:                    codeon();
        !           288:                    switch ( t ) {
        !           289:                            case 0:
        !           290:                                    return FALSE;
        !           291:                            case -1:
        !           292:                                    goto bad;
        !           293:                    }
        !           294:                    break;
        !           295:            case T_FIELD:
        !           296:                    /*
        !           297:                     * Field names are just
        !           298:                     * an offset with some 
        !           299:                     * semantic checking.
        !           300:                     */
        !           301:                    if ( p -> class != RECORD ) {
        !           302:                            error(". allowed only on records, not on %ss", nameof(p));
        !           303:                            goto bad;
        !           304:                    }
        !           305:                    if ( co[1] == NIL ) {
        !           306:                            return FALSE;
        !           307:                    }
        !           308:                    p = reclook( p , co[1] );
        !           309:                    if ( p == NIL ) {
        !           310:                            error("%s is not a field in this record", co[1]);
        !           311:                            goto bad;
        !           312:                    }
        !           313:                    if ( modflag & MOD ) {
        !           314:                            p -> nl_flags |= NMOD;
        !           315:                    }
        !           316:                    if ( ( modflag & NOUSE ) == 0 || lptr( c[2] ) ) {
        !           317:                            p -> nl_flags |= NUSED;
        !           318:                    }
        !           319:                    break;
        !           320:            default:
        !           321:                    panic("nilfnil");
        !           322:        }
        !           323:            /*
        !           324:             *  recursive call, check the rest of the qualifications.
        !           325:             */
        !           326:        if ( ! nilfnil( p , c[2] , modflag , firstp , r2 ) ) {
        !           327:            return FALSE;
        !           328:        }
        !           329:            /*
        !           330:             *  the point of all this.
        !           331:             */
        !           332:        if ( co[0] == T_PTR ) {
        !           333:            if ( p -> class == PTR ) {
        !           334:                    if ( opt( 't' ) ) {
        !           335:                        putleaf( P2ICON , 0 , 0
        !           336:                            , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           337:                            , "_NIL" );
        !           338:                    }
        !           339:            } else {
        !           340:                    putleaf( P2ICON , 0 , 0
        !           341:                        , ADDTYPE( P2FTN | P2INT , P2PTR )
        !           342:                        , "_FNIL" );
        !           343:            }
        !           344:        }
        !           345:        return TRUE;
        !           346: bad:
        !           347:        cerror("Error occurred on qualification of %s", r2);
        !           348:        return FALSE;
        !           349:     }
        !           350: #endif PC

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