Return to pclval.c CVS log

Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / pascal / src

Annotation of 43BSDTahoe/ucb/pascal/src/pclval.c, revision 1.1

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

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