Return to call.c CVS log

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

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

1.1     ! root        1: /* Copyright (c) 1979 Regents of the University of California */
        !             2: 
        !             3: static char sccsid[] = "@(#)call.c 1.24 6/3/83";
        !             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: #   include "pc.h"
        !            12: #   include "pcops.h"
        !            13: #endif PC
        !            14: #include "tmps.h"
        !            15: 
        !            16: /*
        !            17:  * Call generates code for calls to
        !            18:  * user defined procedures and functions
        !            19:  * and is called by proc and funccod.
        !            20:  * P is the result of the lookup
        !            21:  * of the procedure/function symbol,
        !            22:  * and porf is PROC or FUNC.
        !            23:  * Psbn is the block number of p.
        !            24:  *
        !            25:  *     the idea here is that regular scalar functions are just called,
        !            26:  *     while structure functions and formal functions have their results
        !            27:  *     stored in a temporary after the call.
        !            28:  *     structure functions do this because they return pointers
        !            29:  *     to static results, so we copy the static
        !            30:  *     and return a pointer to the copy.
        !            31:  *     formal functions do this because we have to save the result
        !            32:  *     around a call to the runtime routine which restores the display,
        !            33:  *     so we can't just leave the result lying around in registers.
        !            34:  *     formal calls save the address of the descriptor in a local
        !            35:  *     temporary, so it can be addressed for the call which restores
        !            36:  *     the display (FRTN).
        !            37:  *     calls to formal parameters pass the formal as a hidden argument 
        !            38:  *     to a special entry point for the formal call.
        !            39:  *     [this is somewhat dependent on the way arguments are addressed.]
        !            40:  *     so PROCs and scalar FUNCs look like
        !            41:  *             p(...args...)
        !            42:  *     structure FUNCs look like
        !            43:  *             (temp = p(...args...),&temp)
        !            44:  *     formal FPROCs look like
        !            45:  *             ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
        !            46:  *     formal scalar FFUNCs look like
        !            47:  *             ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
        !            48:  *     formal structure FFUNCs look like
        !            49:  *             (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
        !            50:  */
        !            51: struct nl *
        !            52: call(p, argv, porf, psbn)
        !            53:        struct nl *p;
        !            54:        int *argv, porf, psbn;
        !            55: {
        !            56:        register struct nl *p1, *q;
        !            57:        int *r;
        !            58:        struct nl       *p_type_class = classify( p -> type );
        !            59:        bool chk = TRUE;
        !            60:        struct nl       *savedispnp;    /* temporary to hold saved display */
        !            61: #      ifdef PC
        !            62:            long        p_p2type = p2type( p );
        !            63:            long        p_type_p2type = p2type( p -> type );
        !            64:            bool        noarguments;
        !            65:            long        calltype;       /* type of the call */
        !            66:                /*
        !            67:                 *      these get used if temporaries and structures are used
        !            68:                 */
        !            69:            struct nl   *tempnlp;
        !            70:            long        temptype;       /* type of the temporary */
        !            71:            long        p_type_width;
        !            72:            long        p_type_align;
        !            73:            char        extname[ BUFSIZ ];
        !            74:            struct nl   *tempdescrp;
        !            75: #      endif PC
        !            76: 
        !            77:          if (p->class == FFUNC || p->class == FPROC) {
        !            78:            /*
        !            79:             * allocate space to save the display for formal calls
        !            80:             */
        !            81:            savedispnp = tmpalloc( sizeof display , NIL , NOREG );
        !            82:        }
        !            83: #      ifdef OBJ
        !            84:            if (p->class == FFUNC || p->class == FPROC) {
        !            85:                put(2, O_LV | cbn << 8 + INDX ,
        !            86:                        (int) savedispnp -> value[ NL_OFFS ] );
        !            87:                put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
        !            88:            }
        !            89:            if (porf == FUNC) {
        !            90:                    /*
        !            91:                     * Push some space
        !            92:                     * for the function return type
        !            93:                     */
        !            94:                    put(2, O_PUSH, leven(-lwidth(p->type)));
        !            95:            }
        !            96: #      endif OBJ
        !            97: #      ifdef PC
        !            98:                /*
        !            99:                 *      if this is a formal call,
        !           100:                 *      stash the address of the descriptor
        !           101:                 *      in a temporary so we can find it
        !           102:                 *      after the FCALL for the call to FRTN
        !           103:                 */
        !           104:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           105:                tempdescrp = tmpalloc(sizeof( struct formalrtn *) , NIL ,
        !           106:                                        REGOK );
        !           107:                putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           108:                        tempdescrp -> extra_flags , P2PTR|P2STRTY );
        !           109:                putRV( 0 , psbn , p -> value[ NL_OFFS ] ,
        !           110:                        p -> extra_flags , P2PTR|P2STRTY );
        !           111:                putop( P2ASSIGN , P2PTR | P2STRTY );
        !           112:            }
        !           113:                /*
        !           114:                 *      if we have to store a temporary,
        !           115:                 *      temptype will be its type,
        !           116:                 *      otherwise, it's P2UNDEF.
        !           117:                 */
        !           118:            temptype = P2UNDEF;
        !           119:            calltype = P2INT;
        !           120:            if ( porf == FUNC ) {
        !           121:                p_type_width = width( p -> type );
        !           122:                switch( p_type_class ) {
        !           123:                    case TSTR:
        !           124:                    case TSET:
        !           125:                    case TREC:
        !           126:                    case TFILE:
        !           127:                    case TARY:
        !           128:                        calltype = temptype = P2STRTY;
        !           129:                        p_type_align = align( p -> type );
        !           130:                        break;
        !           131:                    default:
        !           132:                        if ( p -> class == FFUNC ) {
        !           133:                            calltype = temptype = p2type( p -> type );
        !           134:                        }
        !           135:                        break;
        !           136:                }
        !           137:                if ( temptype != P2UNDEF ) {
        !           138:                    tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
        !           139:                        /*
        !           140:                         *      temp
        !           141:                         *      for (temp = ...
        !           142:                         */
        !           143:                    putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           144:                            tempnlp -> extra_flags , temptype );
        !           145:                }
        !           146:            }
        !           147:            switch ( p -> class ) {
        !           148:                case FUNC:
        !           149:                case PROC:
        !           150:                        /*
        !           151:                         *      ... p( ...
        !           152:                         */
        !           153:                    sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
        !           154:                    putleaf( P2ICON , 0 , 0 , p2type( p ) , extname );
        !           155:                    break;
        !           156:                case FFUNC:
        !           157:                case FPROC:
        !           158: 
        !           159:                            /*
        !           160:                             *  ... ( t -> entryaddr )( ...
        !           161:                             */
        !           162:                            /*  the descriptor */
        !           163:                        putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           164:                                tempdescrp -> extra_flags , P2PTR | P2STRTY );
        !           165:                            /*  the entry address within the descriptor */
        !           166:                        if ( FENTRYOFFSET != 0 ) {
        !           167:                            putleaf( P2ICON , FENTRYOFFSET , 0 , P2INT , 0 );
        !           168:                            putop( P2PLUS , 
        !           169:                                ADDTYPE(
        !           170:                                    ADDTYPE( ADDTYPE( p2type( p ) , P2FTN ) ,
        !           171:                                            P2PTR ) ,
        !           172:                                        P2PTR ) );
        !           173:                        }
        !           174:                            /*
        !           175:                             *  indirect to fetch the formal entry address
        !           176:                             *  with the result type of the routine.
        !           177:                             */
        !           178:                        if (p -> class == FFUNC) {
        !           179:                            putop( P2UNARY P2MUL ,
        !           180:                                ADDTYPE(ADDTYPE(p2type(p -> type), P2FTN),
        !           181:                                        P2PTR));
        !           182:                        } else {
        !           183:                                /* procedures are int returning functions */
        !           184:                            putop( P2UNARY P2MUL ,
        !           185:                                ADDTYPE(ADDTYPE(P2INT, P2FTN), P2PTR));
        !           186:                        }
        !           187:                        break;
        !           188:                default:
        !           189:                        panic("call class");
        !           190:            }
        !           191:            noarguments = TRUE;
        !           192: #      endif PC
        !           193:        /*
        !           194:         * Loop and process each of
        !           195:         * arguments to the proc/func.
        !           196:         *      ... ( ... args ... ) ...
        !           197:         */
        !           198:        for (p1 = plist(p); p1 != NIL; p1 = p1->chain) {
        !           199:            if (argv == NIL) {
        !           200:                    error("Not enough arguments to %s", p->symbol);
        !           201:                    return (NIL);
        !           202:            }
        !           203:            switch (p1->class) {
        !           204:                case REF:
        !           205:                        /*
        !           206:                         * Var parameter
        !           207:                         */
        !           208:                        r = argv[1];
        !           209:                        if (r != NIL && r[0] != T_VAR) {
        !           210:                                error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
        !           211:                                chk = FALSE;
        !           212:                                break;
        !           213:                        }
        !           214:                        q = lvalue( (int *) argv[1], MOD | ASGN , LREQ );
        !           215:                        if (q == NIL) {
        !           216:                                chk = FALSE;
        !           217:                                break;
        !           218:                        }
        !           219:                        if (q != p1->type) {
        !           220:                                error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
        !           221:                                chk = FALSE;
        !           222:                                break;
        !           223:                        }
        !           224:                        break;
        !           225:                case VAR:
        !           226:                        /*
        !           227:                         * Value parameter
        !           228:                         */
        !           229: #                      ifdef OBJ
        !           230:                            q = rvalue(argv[1], p1->type , RREQ );
        !           231: #                      endif OBJ
        !           232: #                      ifdef PC
        !           233:                                /*
        !           234:                                 * structure arguments require lvalues,
        !           235:                                 * scalars use rvalue.
        !           236:                                 */
        !           237:                            switch( classify( p1 -> type ) ) {
        !           238:                                case TFILE:
        !           239:                                case TARY:
        !           240:                                case TREC:
        !           241:                                case TSET:
        !           242:                                case TSTR:
        !           243:                                    q = stkrval( argv[1] , p1 -> type , LREQ );
        !           244:                                    break;
        !           245:                                case TINT:
        !           246:                                case TSCAL:
        !           247:                                case TBOOL:
        !           248:                                case TCHAR:
        !           249:                                    precheck( p1 -> type , "_RANG4" , "_RSNG4" );
        !           250:                                    q = stkrval( argv[1] , p1 -> type , RREQ );
        !           251:                                    postcheck(p1 -> type, nl+T4INT);
        !           252:                                    break;
        !           253:                                case TDOUBLE:
        !           254:                                    q = stkrval( argv[1] , p1 -> type , RREQ );
        !           255:                                    sconv(p2type(q), P2DOUBLE);
        !           256:                                    break;
        !           257:                                default:
        !           258:                                    q = rvalue( argv[1] , p1 -> type , RREQ );
        !           259:                                    break;
        !           260:                            }
        !           261: #                      endif PC
        !           262:                        if (q == NIL) {
        !           263:                                chk = FALSE;
        !           264:                                break;
        !           265:                        }
        !           266:                        if (incompat(q, p1->type, argv[1])) {
        !           267:                                cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
        !           268:                                chk = FALSE;
        !           269:                                break;
        !           270:                        }
        !           271: #                      ifdef OBJ
        !           272:                            if (isa(p1->type, "bcsi"))
        !           273:                                    rangechk(p1->type, q);
        !           274:                            if (q->class != STR)
        !           275:                                    convert(q, p1->type);
        !           276: #                      endif OBJ
        !           277: #                      ifdef PC
        !           278:                            switch( classify( p1 -> type ) ) {
        !           279:                                case TFILE:
        !           280:                                case TARY:
        !           281:                                case TREC:
        !           282:                                case TSET:
        !           283:                                case TSTR:
        !           284:                                        putstrop( P2STARG
        !           285:                                            , p2type( p1 -> type )
        !           286:                                            , lwidth( p1 -> type )
        !           287:                                            , align( p1 -> type ) );
        !           288:                            }
        !           289: #                      endif PC
        !           290:                        break;
        !           291:                case FFUNC:
        !           292:                        /*
        !           293:                         * function parameter
        !           294:                         */
        !           295:                        q = flvalue( (int *) argv[1] , p1 );
        !           296:                        chk = (chk && fcompat(q, p1));
        !           297:                        break;
        !           298:                case FPROC:
        !           299:                        /*
        !           300:                         * procedure parameter
        !           301:                         */
        !           302:                        q = flvalue( (int *) argv[1] , p1 );
        !           303:                        chk = (chk && fcompat(q, p1));
        !           304:                        break;
        !           305:                default:
        !           306:                        panic("call");
        !           307:            }
        !           308: #          ifdef PC
        !           309:                    /*
        !           310:                     *  if this is the nth (>1) argument,
        !           311:                     *  hang it on the left linear list of arguments
        !           312:                     */
        !           313:                if ( noarguments ) {
        !           314:                        noarguments = FALSE;
        !           315:                } else {
        !           316:                        putop( P2LISTOP , P2INT );
        !           317:                }
        !           318: #          endif PC
        !           319:            argv = argv[2];
        !           320:        }
        !           321:        if (argv != NIL) {
        !           322:                error("Too many arguments to %s", p->symbol);
        !           323:                rvlist(argv);
        !           324:                return (NIL);
        !           325:        }
        !           326:        if (chk == FALSE)
        !           327:                return NIL;
        !           328: #      ifdef OBJ
        !           329:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           330:                put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
        !           331:                put(2, O_LV | cbn << 8 + INDX ,
        !           332:                        (int) savedispnp -> value[ NL_OFFS ] );
        !           333:                put(1, O_FCALL);
        !           334:                put(2, O_FRTN, even(width(p->type)));
        !           335:            } else {
        !           336:                put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
        !           337:            }
        !           338: #      endif OBJ
        !           339: #      ifdef PC
        !           340:                /*
        !           341:                 *      for formal calls: add the hidden argument
        !           342:                 *      which is the formal struct describing the
        !           343:                 *      environment of the routine.
        !           344:                 *      and the argument which is the address of the
        !           345:                 *      space into which to save the display.
        !           346:                 */
        !           347:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           348:                putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           349:                        tempdescrp -> extra_flags , P2PTR|P2STRTY );
        !           350:                if ( !noarguments ) {
        !           351:                    putop( P2LISTOP , P2INT );
        !           352:                }
        !           353:                noarguments = FALSE;
        !           354:                putLV( 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
        !           355:                        savedispnp -> extra_flags , P2PTR | P2STRTY );
        !           356:                putop( P2LISTOP , P2INT );
        !           357:            }
        !           358:                /*
        !           359:                 *      do the actual call:
        !           360:                 *          either      ... p( ... ) ...
        !           361:                 *          or          ... ( t -> entryaddr )( ... ) ...
        !           362:                 *      and maybe an assignment.
        !           363:                 */
        !           364:            if ( porf == FUNC ) {
        !           365:                switch ( p_type_class ) {
        !           366:                    case TBOOL:
        !           367:                    case TCHAR:
        !           368:                    case TINT:
        !           369:                    case TSCAL:
        !           370:                    case TDOUBLE:
        !           371:                    case TPTR:
        !           372:                        putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) ,
        !           373:                                p_type_p2type );
        !           374:                        if ( p -> class == FFUNC ) {
        !           375:                            putop( P2ASSIGN , p_type_p2type );
        !           376:                        }
        !           377:                        break;
        !           378:                    default:
        !           379:                        putstrop( ( noarguments ? P2UNARY P2STCALL : P2STCALL ),
        !           380:                                ADDTYPE( p_type_p2type , P2PTR ) ,
        !           381:                                p_type_width , p_type_align );
        !           382:                        putstrop(P2STASG, ADDTYPE(p_type_p2type, P2PTR),
        !           383:                                lwidth(p -> type), align(p -> type));
        !           384:                        break;
        !           385:                }
        !           386:            } else {
        !           387:                putop( ( noarguments ? P2UNARY P2CALL : P2CALL ) , P2INT );
        !           388:            }
        !           389:                /*
        !           390:                 *      ( t=p , ... , FRTN( t ) ...
        !           391:                 */
        !           392:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           393:                putop( P2COMOP , P2INT );
        !           394:                putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) ,
        !           395:                        "_FRTN" );
        !           396:                putRV( 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           397:                        tempdescrp -> extra_flags , P2PTR | P2STRTY );
        !           398:                putLV( 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
        !           399:                        savedispnp -> extra_flags , P2PTR | P2STRTY );
        !           400:                putop( P2LISTOP , P2INT );
        !           401:                putop( P2CALL , P2INT );
        !           402:                putop( P2COMOP , P2INT );
        !           403:            }
        !           404:                /*
        !           405:                 *      if required:
        !           406:                 *      either  ... , temp )
        !           407:                 *      or      ... , &temp )
        !           408:                 */
        !           409:            if ( porf == FUNC && temptype != P2UNDEF ) {
        !           410:                if ( temptype != P2STRTY ) {
        !           411:                    putRV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           412:                            tempnlp -> extra_flags , p_type_p2type );
        !           413:                } else {
        !           414:                    putLV( 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           415:                            tempnlp -> extra_flags , p_type_p2type );
        !           416:                }
        !           417:                putop( P2COMOP , P2INT );
        !           418:            }
        !           419:            if ( porf == PROC ) {
        !           420:                putdot( filename , line );
        !           421:            }
        !           422: #      endif PC
        !           423:        return (p->type);
        !           424: }
        !           425: 
        !           426: rvlist(al)
        !           427:        register int *al;
        !           428: {
        !           429: 
        !           430:        for (; al != NIL; al = al[2])
        !           431:                rvalue( (int *) al[1], NLNIL , RREQ );
        !           432: }
        !           433: 
        !           434:     /*
        !           435:      * check that two function/procedure namelist entries are compatible
        !           436:      */
        !           437: bool
        !           438: fcompat( formal , actual )
        !           439:     struct nl  *formal;
        !           440:     struct nl  *actual;
        !           441: {
        !           442:     register struct nl *f_chain;
        !           443:     register struct nl *a_chain;
        !           444:     bool compat = TRUE;
        !           445: 
        !           446:     if ( formal == NIL || actual == NIL ) {
        !           447:        return FALSE;
        !           448:     }
        !           449:     for (a_chain = plist(actual), f_chain = plist(formal);
        !           450:          f_chain != NIL;
        !           451:         f_chain = f_chain->chain, a_chain = a_chain->chain) {
        !           452:        if (a_chain == NIL) {
        !           453:            error("%s %s declared on line %d has more arguments than",
        !           454:                parnam(formal->class), formal->symbol,
        !           455:                linenum(formal));
        !           456:            cerror("%s %s declared on line %d",
        !           457:                parnam(actual->class), actual->symbol,
        !           458:                linenum(actual));
        !           459:            return FALSE;
        !           460:        }
        !           461:        if ( a_chain -> class != f_chain -> class ) {
        !           462:            error("%s parameter %s of %s declared on line %d is not identical",
        !           463:                parnam(f_chain->class), f_chain->symbol,
        !           464:                formal->symbol, linenum(formal));
        !           465:            cerror("with %s parameter %s of %s declared on line %d",
        !           466:                parnam(a_chain->class), a_chain->symbol,
        !           467:                actual->symbol, linenum(actual));
        !           468:            compat = FALSE;
        !           469:        } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
        !           470:            compat = (compat && fcompat(f_chain, a_chain));
        !           471:        }
        !           472:        if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
        !           473:            (a_chain->type != f_chain->type)) {
        !           474:            error("Type of %s parameter %s of %s declared on line %d is not identical",
        !           475:                parnam(f_chain->class), f_chain->symbol,
        !           476:                formal->symbol, linenum(formal));
        !           477:            cerror("to type of %s parameter %s of %s declared on line %d",
        !           478:                parnam(a_chain->class), a_chain->symbol,
        !           479:                actual->symbol, linenum(actual));
        !           480:            compat = FALSE;
        !           481:        }
        !           482:     }
        !           483:     if (a_chain != NIL) {
        !           484:        error("%s %s declared on line %d has fewer arguments than",
        !           485:            parnam(formal->class), formal->symbol,
        !           486:            linenum(formal));
        !           487:        cerror("%s %s declared on line %d",
        !           488:            parnam(actual->class), actual->symbol,
        !           489:            linenum(actual));
        !           490:        return FALSE;
        !           491:     }
        !           492:     return compat;
        !           493: }
        !           494: 
        !           495: char *
        !           496: parnam(nltype)
        !           497:     int nltype;
        !           498: {
        !           499:     switch(nltype) {
        !           500:        case REF:
        !           501:            return "var";
        !           502:        case VAR:
        !           503:            return "value";
        !           504:        case FUNC:
        !           505:        case FFUNC:
        !           506:            return "function";
        !           507:        case PROC:
        !           508:        case FPROC:
        !           509:            return "procedure";
        !           510:        default:
        !           511:            return "SNARK";
        !           512:     }
        !           513: }
        !           514: 
        !           515: plist(p)
        !           516:     struct nl *p;
        !           517: {
        !           518:     switch (p->class) {
        !           519:        case FFUNC:
        !           520:        case FPROC:
        !           521:            return p->ptr[ NL_FCHAIN ];
        !           522:        case PROC:
        !           523:        case FUNC:
        !           524:            return p->chain;
        !           525:        default:
        !           526:            panic("plist");
        !           527:     }
        !           528: }
        !           529: 
        !           530: linenum(p)
        !           531:     struct nl *p;
        !           532: {
        !           533:     if (p->class == FUNC)
        !           534:        return p->ptr[NL_FVAR]->value[NL_LINENO];
        !           535:     return p->value[NL_LINENO];
        !           536: }

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