Return to call.c CVS log

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

Annotation of 43BSD/ucb/pascal/src/call.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[] = "@(#)call.c     5.2 (Berkeley) 7/26/85";
        !             9: #endif not lint
        !            10: 
        !            11: #include "whoami.h"
        !            12: #include "0.h"
        !            13: #include "tree.h"
        !            14: #include "opcode.h"
        !            15: #include "objfmt.h"
        !            16: #ifdef PC
        !            17: #   include "pc.h"
        !            18: #   include <pcc.h>
        !            19: #endif PC
        !            20: #include "tmps.h"
        !            21: #include "tree_ty.h"
        !            22: 
        !            23: /*
        !            24:  * Call generates code for calls to
        !            25:  * user defined procedures and functions
        !            26:  * and is called by proc and funccod.
        !            27:  * P is the result of the lookup
        !            28:  * of the procedure/function symbol,
        !            29:  * and porf is PROC or FUNC.
        !            30:  * Psbn is the block number of p.
        !            31:  *
        !            32:  *     the idea here is that regular scalar functions are just called,
        !            33:  *     while structure functions and formal functions have their results
        !            34:  *     stored in a temporary after the call.
        !            35:  *     structure functions do this because they return pointers
        !            36:  *     to static results, so we copy the static
        !            37:  *     and return a pointer to the copy.
        !            38:  *     formal functions do this because we have to save the result
        !            39:  *     around a call to the runtime routine which restores the display,
        !            40:  *     so we can't just leave the result lying around in registers.
        !            41:  *     formal calls save the address of the descriptor in a local
        !            42:  *     temporary, so it can be addressed for the call which restores
        !            43:  *     the display (FRTN).
        !            44:  *     calls to formal parameters pass the formal as a hidden argument 
        !            45:  *     to a special entry point for the formal call.
        !            46:  *     [this is somewhat dependent on the way arguments are addressed.]
        !            47:  *     so PROCs and scalar FUNCs look like
        !            48:  *             p(...args...)
        !            49:  *     structure FUNCs look like
        !            50:  *             (temp = p(...args...),&temp)
        !            51:  *     formal FPROCs look like
        !            52:  *             ( t=p,( t -> entryaddr )(...args...,t,s),FRTN(t,s))
        !            53:  *     formal scalar FFUNCs look like
        !            54:  *             ( t=p,temp=( t -> entryaddr )(...args...,t,s),FRTN(t,s),temp)
        !            55:  *     formal structure FFUNCs look like
        !            56:  *             (t=p,temp = ( t -> entryaddr )(...args...,t,s),FRTN(t,s),&temp)
        !            57:  */
        !            58: struct nl *
        !            59: call(p, argv_node, porf, psbn)
        !            60:        struct nl *p;
        !            61:        struct tnode    *argv_node;     /* list node */
        !            62:        int porf, psbn;
        !            63: {
        !            64:        register struct nl *p1, *q, *p2;
        !            65:        register struct nl *ptype, *ctype;
        !            66:        struct tnode *rnode;
        !            67:        int i, j, d;
        !            68:        bool chk = TRUE;
        !            69:        struct nl       *savedispnp;    /* temporary to hold saved display */
        !            70: #      ifdef PC
        !            71:            int         p_type_class = classify( p -> type );
        !            72:            long        p_type_p2type = p2type( p -> type );
        !            73:            bool        noarguments;
        !            74:                /*
        !            75:                 *      these get used if temporaries and structures are used
        !            76:                 */
        !            77:            struct nl   *tempnlp;
        !            78:            long        temptype;       /* type of the temporary */
        !            79:            long        p_type_width;
        !            80:            long        p_type_align;
        !            81:            char        extname[ BUFSIZ ];
        !            82:            struct nl   *tempdescrp;
        !            83: #      endif PC
        !            84: 
        !            85:          if (p->class == FFUNC || p->class == FPROC) {
        !            86:            /*
        !            87:             * allocate space to save the display for formal calls
        !            88:             */
        !            89:            savedispnp = tmpalloc( (long) sizeof display , NLNIL , NOREG );
        !            90:        }
        !            91: #      ifdef OBJ
        !            92:            if (p->class == FFUNC || p->class == FPROC) {
        !            93:                (void) put(2, O_LV | cbn << 8 + INDX ,
        !            94:                        (int) savedispnp -> value[ NL_OFFS ] );
        !            95:                (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
        !            96:            }
        !            97:            if (porf == FUNC) {
        !            98:                    /*
        !            99:                     * Push some space
        !           100:                     * for the function return type
        !           101:                     */
        !           102:                    (void) put(2, O_PUSH, leven(-lwidth(p->type)));
        !           103:            }
        !           104: #      endif OBJ
        !           105: #      ifdef PC
        !           106:                /*
        !           107:                 *      if this is a formal call,
        !           108:                 *      stash the address of the descriptor
        !           109:                 *      in a temporary so we can find it
        !           110:                 *      after the FCALL for the call to FRTN
        !           111:                 */
        !           112:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           113:                tempdescrp = tmpalloc((long) (sizeof( struct formalrtn *)),
        !           114:                                        NLNIL, REGOK );
        !           115:                putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           116:                        tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
        !           117:                putRV((char *) 0 , psbn , p -> value[ NL_OFFS ] ,
        !           118:                        p -> extra_flags , PCCTM_PTR|PCCT_STRTY );
        !           119:                putop( PCC_ASSIGN , PCCTM_PTR | PCCT_STRTY );
        !           120:            }
        !           121:                /*
        !           122:                 *      if we have to store a temporary,
        !           123:                 *      temptype will be its type,
        !           124:                 *      otherwise, it's PCCT_UNDEF.
        !           125:                 */
        !           126:            temptype = PCCT_UNDEF;
        !           127:            if ( porf == FUNC ) {
        !           128:                p_type_width = width( p -> type );
        !           129:                switch( p_type_class ) {
        !           130:                    case TSTR:
        !           131:                    case TSET:
        !           132:                    case TREC:
        !           133:                    case TFILE:
        !           134:                    case TARY:
        !           135:                        temptype = PCCT_STRTY;
        !           136:                        p_type_align = align( p -> type );
        !           137:                        break;
        !           138:                    default:
        !           139:                        if ( p -> class == FFUNC ) {
        !           140:                            temptype = p2type( p -> type );
        !           141:                        }
        !           142:                        break;
        !           143:                }
        !           144:                if ( temptype != PCCT_UNDEF ) {
        !           145:                    tempnlp = tmpalloc(p_type_width, p -> type, NOREG);
        !           146:                        /*
        !           147:                         *      temp
        !           148:                         *      for (temp = ...
        !           149:                         */
        !           150:                    putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           151:                            tempnlp -> extra_flags , (int) temptype );
        !           152:                }
        !           153:            }
        !           154:            switch ( p -> class ) {
        !           155:                case FUNC:
        !           156:                case PROC:
        !           157:                        /*
        !           158:                         *      ... p( ...
        !           159:                         */
        !           160:                    sextname( extname , p -> symbol , BLOCKNO(p -> nl_block) );
        !           161:                    putleaf( PCC_ICON , 0 , 0 , p2type( p ) , extname );
        !           162:                    break;
        !           163:                case FFUNC:
        !           164:                case FPROC:
        !           165: 
        !           166:                            /*
        !           167:                             *  ... ( t -> entryaddr )( ...
        !           168:                             */
        !           169:                            /*  the descriptor */
        !           170:                        putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           171:                                tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
        !           172:                            /*  the entry address within the descriptor */
        !           173:                        if ( FENTRYOFFSET != 0 ) {
        !           174:                            putleaf( PCC_ICON , FENTRYOFFSET , 0 , PCCT_INT , 
        !           175:                                                (char *) 0 );
        !           176:                            putop( PCC_PLUS , 
        !           177:                                PCCM_ADDTYPE(
        !           178:                                    PCCM_ADDTYPE( PCCM_ADDTYPE( p2type( p ) , PCCTM_FTN ) ,
        !           179:                                            PCCTM_PTR ) ,
        !           180:                                        PCCTM_PTR ) );
        !           181:                        }
        !           182:                            /*
        !           183:                             *  indirect to fetch the formal entry address
        !           184:                             *  with the result type of the routine.
        !           185:                             */
        !           186:                        if (p -> class == FFUNC) {
        !           187:                            putop( PCCOM_UNARY PCC_MUL ,
        !           188:                                PCCM_ADDTYPE(PCCM_ADDTYPE(p2type(p -> type), PCCTM_FTN),
        !           189:                                        PCCTM_PTR));
        !           190:                        } else {
        !           191:                                /* procedures are int returning functions */
        !           192:                            putop( PCCOM_UNARY PCC_MUL ,
        !           193:                                PCCM_ADDTYPE(PCCM_ADDTYPE(PCCT_INT, PCCTM_FTN), PCCTM_PTR));
        !           194:                        }
        !           195:                        break;
        !           196:                default:
        !           197:                        panic("call class");
        !           198:            }
        !           199:            noarguments = TRUE;
        !           200: #      endif PC
        !           201:        /*
        !           202:         * Loop and process each of
        !           203:         * arguments to the proc/func.
        !           204:         *      ... ( ... args ... ) ...
        !           205:         */
        !           206:        ptype = NIL;
        !           207:        for (p1 = plist(p); p1 != NLNIL; p1 = p1->chain) {
        !           208:            if (argv_node == TR_NIL) {
        !           209:                    error("Not enough arguments to %s", p->symbol);
        !           210:                    return (NLNIL);
        !           211:            }
        !           212:            switch (p1->class) {
        !           213:                case REF:
        !           214:                        /*
        !           215:                         * Var parameter
        !           216:                         */
        !           217:                        rnode = argv_node->list_node.list;
        !           218:                        if (rnode != TR_NIL && rnode->tag != T_VAR) {
        !           219:                                error("Expression given (variable required) for var parameter %s of %s", p1->symbol, p->symbol);
        !           220:                                chk = FALSE;
        !           221:                                break;
        !           222:                        }
        !           223:                        q = lvalue( argv_node->list_node.list,
        !           224:                                        MOD | ASGN , LREQ );
        !           225:                        if (q == NIL) {
        !           226:                                chk = FALSE;
        !           227:                                break;
        !           228:                        }
        !           229:                        p2 = p1->type;
        !           230:                        if (p2 == NLNIL || p2->chain == NLNIL || p2->chain->class != CRANGE) {
        !           231:                            if (q != p2) {
        !           232:                                error("Parameter type not identical to type of var parameter %s of %s", p1->symbol, p->symbol);
        !           233:                                chk = FALSE;
        !           234:                            }
        !           235:                            break;
        !           236:                        } else {
        !           237:                            /* conformant array */
        !           238:                            if (p1 == ptype) {
        !           239:                                if (q != ctype) {
        !           240:                                    error("Conformant array parameters in the same specification must be the same type.");
        !           241:                                    goto conf_err;
        !           242:                                }
        !           243:                            } else {
        !           244:                                if (classify(q) != TARY && classify(q) != TSTR) {
        !           245:                                    error("Array type required for var parameter %s of %s",p1->symbol,p->symbol);
        !           246:                                    goto conf_err;
        !           247:                                }
        !           248:                                /* check base type of array */
        !           249:                                if (p2->type != q->type) {
        !           250:                                    error("Base type of array not identical to that of conformant array parameter %s of %s", p1->symbol, p->symbol);
        !           251:                                    goto conf_err;
        !           252:                                }
        !           253:                                if (p2->value[0] != q->value[0]) {
        !           254:                                    error("Subscript number mismatch on conformant array parameter %s of %s", p1->symbol, p->symbol);
        !           255:                                    /* Don't process array bounds & width */
        !           256: conf_err:                          if (p1->chain->type->class == CRANGE) {
        !           257:                                        d = p1->value[0];
        !           258:                                        for (i = 1; i <= d; i++) {
        !           259:                                            /* for each subscript, pass by
        !           260:                                             * bounds and width
        !           261:                                             */
        !           262:                                            p1 = p1->chain->chain->chain;
        !           263:                                        }
        !           264:                                    }
        !           265:                                    ptype = ctype = NLNIL;
        !           266:                                    chk = FALSE;
        !           267:                                    break;
        !           268:                                }
        !           269:                                /*
        !           270:                                 * Save array type for all parameters with same
        !           271:                                 * specification.
        !           272:                                 */
        !           273:                                ctype = q;
        !           274:                                ptype = p2;
        !           275:                                /*
        !           276:                                 * If at end of conformant array list,
        !           277:                                 * get bounds.
        !           278:                                 */
        !           279:                                if (p1->chain->type->class == CRANGE) {
        !           280:                                    /* check each subscript, put on stack */
        !           281:                                    d = ptype->value[0];
        !           282:                                    q = ctype;
        !           283:                                    for (i = 1; i <= d; i++) {
        !           284:                                        p1 = p1->chain;
        !           285:                                        q = q->chain;
        !           286:                                        if (incompat(q, p1->type, TR_NIL)){
        !           287:                                            error("Subscript type not conformable with parameter %s of %s", p1->symbol, p->symbol);
        !           288:                                            chk = FALSE;
        !           289:                                            break;
        !           290:                                        }
        !           291:                                        /* Put lower and upper bound & width */
        !           292: #                                      ifdef OBJ
        !           293:                                        if (q->type->class == CRANGE) {
        !           294:                                            putcbnds(q->type);
        !           295:                                        } else {
        !           296:                                            put(2, width(p1->type) <= 2 ? O_CON2
        !           297:                                                : O_CON4, q->range[0]);
        !           298:                                            put(2, width(p1->type) <= 2 ? O_CON2
        !           299:                                                : O_CON4, q->range[1]);
        !           300:                                            put(2, width(p1->type) <= 2 ? O_CON2
        !           301:                                                : O_CON4, aryconst(ctype,i));
        !           302:                                        }
        !           303: #                                      endif OBJ
        !           304: #                                      ifdef PC
        !           305:                                        if (q->type->class == CRANGE) {
        !           306:                                            for (j = 1; j <= 3; j++) {
        !           307:                                                p2 = p->nptr[j];
        !           308:                                                putRV(p2->symbol, (p2->nl_block
        !           309:                                                    & 037), p2->value[0],
        !           310:                                                    p2->extra_flags,p2type(p2));
        !           311:                                                putop(PCC_CM, PCCT_INT);
        !           312:                                            }
        !           313:                                        } else {
        !           314:                                            putleaf(PCC_ICON, q->range[0], 0,PCCT_INT,0);
        !           315:                                            putop( PCC_CM , PCCT_INT );
        !           316:                                            putleaf(PCC_ICON, q->range[1], 0,PCCT_INT,0);
        !           317:                                            putop( PCC_CM , PCCT_INT );
        !           318:                                            putleaf(PCC_ICON,aryconst(ctype,i),0,PCCT_INT,0);
        !           319:                                            putop( PCC_CM , PCCT_INT );
        !           320:                                        }
        !           321: #                                      endif PC
        !           322:                                        p1 = p1->chain->chain;
        !           323:                                    }
        !           324:                                }
        !           325:                            }
        !           326:                        }
        !           327:                        break;
        !           328:                case VAR:
        !           329:                        /*
        !           330:                         * Value parameter
        !           331:                         */
        !           332: #                      ifdef OBJ
        !           333:                            q = rvalue(argv_node->list_node.list,
        !           334:                                        p1->type , RREQ );
        !           335: #                      endif OBJ
        !           336: #                      ifdef PC
        !           337:                                /*
        !           338:                                 * structure arguments require lvalues,
        !           339:                                 * scalars use rvalue.
        !           340:                                 */
        !           341:                            switch( classify( p1 -> type ) ) {
        !           342:                                case TFILE:
        !           343:                                case TARY:
        !           344:                                case TREC:
        !           345:                                case TSET:
        !           346:                                case TSTR:
        !           347:                                q = stkrval(argv_node->list_node.list,
        !           348:                                                p1 -> type , (long) LREQ );
        !           349:                                    break;
        !           350:                                case TINT:
        !           351:                                case TSCAL:
        !           352:                                case TBOOL:
        !           353:                                case TCHAR:
        !           354:                                    precheck( p1 -> type , "_RANG4" , "_RSNG4" );
        !           355:                                q = stkrval(argv_node->list_node.list,
        !           356:                                                p1 -> type , (long) RREQ );
        !           357:                                    postcheck(p1 -> type, nl+T4INT);
        !           358:                                    break;
        !           359:                                case TDOUBLE:
        !           360:                                q = stkrval(argv_node->list_node.list,
        !           361:                                                p1 -> type , (long) RREQ );
        !           362:                                    sconv(p2type(q), PCCT_DOUBLE);
        !           363:                                    break;
        !           364:                                default:
        !           365:                                    q = rvalue(argv_node->list_node.list,
        !           366:                                                p1 -> type , RREQ );
        !           367:                                    break;
        !           368:                            }
        !           369: #                      endif PC
        !           370:                        if (q == NIL) {
        !           371:                                chk = FALSE;
        !           372:                                break;
        !           373:                        }
        !           374:                        if (incompat(q, p1->type,
        !           375:                                argv_node->list_node.list)) {
        !           376:                                cerror("Expression type clashed with type of value parameter %s of %s", p1->symbol, p->symbol);
        !           377:                                chk = FALSE;
        !           378:                                break;
        !           379:                        }
        !           380: #                      ifdef OBJ
        !           381:                            if (isa(p1->type, "bcsi"))
        !           382:                                    rangechk(p1->type, q);
        !           383:                            if (q->class != STR)
        !           384:                                    convert(q, p1->type);
        !           385: #                      endif OBJ
        !           386: #                      ifdef PC
        !           387:                            switch( classify( p1 -> type ) ) {
        !           388:                                case TFILE:
        !           389:                                case TARY:
        !           390:                                case TREC:
        !           391:                                case TSET:
        !           392:                                case TSTR:
        !           393:                                        putstrop( PCC_STARG
        !           394:                                            , p2type( p1 -> type )
        !           395:                                            , (int) lwidth( p1 -> type )
        !           396:                                            , align( p1 -> type ) );
        !           397:                            }
        !           398: #                      endif PC
        !           399:                        break;
        !           400:                case FFUNC:
        !           401:                        /*
        !           402:                         * function parameter
        !           403:                         */
        !           404:                        q = flvalue(argv_node->list_node.list, p1 );
        !           405:                        /*chk = (chk && fcompat(q, p1));*/
        !           406:                        if ((chk) && (fcompat(q, p1)))
        !           407:                            chk = TRUE;
        !           408:                        else
        !           409:                            chk = FALSE;
        !           410:                        break;
        !           411:                case FPROC:
        !           412:                        /*
        !           413:                         * procedure parameter
        !           414:                         */
        !           415:                        q = flvalue(argv_node->list_node.list, p1 );
        !           416:                        /* chk = (chk && fcompat(q, p1)); */
        !           417:                        if ((chk) && (fcompat(q, p1)))
        !           418:                            chk = TRUE;
        !           419:                        else chk = FALSE;
        !           420:                        break;
        !           421:                default:
        !           422:                        panic("call");
        !           423:            }
        !           424: #          ifdef PC
        !           425:                    /*
        !           426:                     *  if this is the nth (>1) argument,
        !           427:                     *  hang it on the left linear list of arguments
        !           428:                     */
        !           429:                if ( noarguments ) {
        !           430:                        noarguments = FALSE;
        !           431:                } else {
        !           432:                        putop( PCC_CM , PCCT_INT );
        !           433:                }
        !           434: #          endif PC
        !           435:            argv_node = argv_node->list_node.next;
        !           436:        }
        !           437:        if (argv_node != TR_NIL) {
        !           438:                error("Too many arguments to %s", p->symbol);
        !           439:                rvlist(argv_node);
        !           440:                return (NLNIL);
        !           441:        }
        !           442:        if (chk == FALSE)
        !           443:                return NLNIL;
        !           444: #      ifdef OBJ
        !           445:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           446:                (void) put(2, PTR_RV | psbn << 8+INDX, (int)p->value[NL_OFFS]);
        !           447:                (void) put(2, O_LV | cbn << 8 + INDX ,
        !           448:                        (int) savedispnp -> value[ NL_OFFS ] );
        !           449:                (void) put(1, O_FCALL);
        !           450:                (void) put(2, O_FRTN, even(width(p->type)));
        !           451:            } else {
        !           452:                (void) put(2, O_CALL | psbn << 8, (long)p->value[NL_ENTLOC]);
        !           453:            }
        !           454: #      endif OBJ
        !           455: #      ifdef PC
        !           456:                /*
        !           457:                 *      for formal calls: add the hidden argument
        !           458:                 *      which is the formal struct describing the
        !           459:                 *      environment of the routine.
        !           460:                 *      and the argument which is the address of the
        !           461:                 *      space into which to save the display.
        !           462:                 */
        !           463:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           464:                putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           465:                        tempdescrp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
        !           466:                if ( !noarguments ) {
        !           467:                    putop( PCC_CM , PCCT_INT );
        !           468:                }
        !           469:                noarguments = FALSE;
        !           470:                putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
        !           471:                        savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
        !           472:                putop( PCC_CM , PCCT_INT );
        !           473:            }
        !           474:                /*
        !           475:                 *      do the actual call:
        !           476:                 *          either      ... p( ... ) ...
        !           477:                 *          or          ... ( t -> entryaddr )( ... ) ...
        !           478:                 *      and maybe an assignment.
        !           479:                 */
        !           480:            if ( porf == FUNC ) {
        !           481:                switch ( p_type_class ) {
        !           482:                    case TBOOL:
        !           483:                    case TCHAR:
        !           484:                    case TINT:
        !           485:                    case TSCAL:
        !           486:                    case TDOUBLE:
        !           487:                    case TPTR:
        !           488:                        putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) ,
        !           489:                                (int) p_type_p2type );
        !           490:                        if ( p -> class == FFUNC ) {
        !           491:                            putop( PCC_ASSIGN , (int) p_type_p2type );
        !           492:                        }
        !           493:                        break;
        !           494:                    default:
        !           495:                        putstrop( ( noarguments ? PCCOM_UNARY PCC_STCALL : PCC_STCALL ),
        !           496:                                (int) PCCM_ADDTYPE( p_type_p2type , PCCTM_PTR ) ,
        !           497:                                (int) p_type_width ,(int) p_type_align );
        !           498:                        putstrop(PCC_STASG, (int) PCCM_ADDTYPE(p_type_p2type, PCCTM_PTR),
        !           499:                                (int) lwidth(p -> type), align(p -> type));
        !           500:                        break;
        !           501:                }
        !           502:            } else {
        !           503:                putop( ( noarguments ? PCCOM_UNARY PCC_CALL : PCC_CALL ) , PCCT_INT );
        !           504:            }
        !           505:                /*
        !           506:                 *      ( t=p , ... , FRTN( t ) ...
        !           507:                 */
        !           508:            if ( p -> class == FFUNC || p -> class == FPROC ) {
        !           509:                putop( PCC_COMOP , PCCT_INT );
        !           510:                putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR ) ,
        !           511:                        "_FRTN" );
        !           512:                putRV((char *) 0 , cbn , tempdescrp -> value[ NL_OFFS ] ,
        !           513:                        tempdescrp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
        !           514:                putLV((char *) 0 , cbn , savedispnp -> value[ NL_OFFS ] ,
        !           515:                        savedispnp -> extra_flags , PCCTM_PTR | PCCT_STRTY );
        !           516:                putop( PCC_CM , PCCT_INT );
        !           517:                putop( PCC_CALL , PCCT_INT );
        !           518:                putop( PCC_COMOP , PCCT_INT );
        !           519:            }
        !           520:                /*
        !           521:                 *      if required:
        !           522:                 *      either  ... , temp )
        !           523:                 *      or      ... , &temp )
        !           524:                 */
        !           525:            if ( porf == FUNC && temptype != PCCT_UNDEF ) {
        !           526:                if ( temptype != PCCT_STRTY ) {
        !           527:                    putRV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           528:                            tempnlp -> extra_flags , (int) p_type_p2type );
        !           529:                } else {
        !           530:                    putLV((char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
        !           531:                            tempnlp -> extra_flags , (int) p_type_p2type );
        !           532:                }
        !           533:                putop( PCC_COMOP , PCCT_INT );
        !           534:            }
        !           535:            if ( porf == PROC ) {
        !           536:                putdot( filename , line );
        !           537:            }
        !           538: #      endif PC
        !           539:        return (p->type);
        !           540: }
        !           541: 
        !           542: rvlist(al)
        !           543:        register struct tnode *al;
        !           544: {
        !           545: 
        !           546:        for (; al != TR_NIL; al = al->list_node.next)
        !           547:                (void) rvalue( al->list_node.list, NLNIL , RREQ );
        !           548: }
        !           549: 
        !           550:     /*
        !           551:      * check that two function/procedure namelist entries are compatible
        !           552:      */
        !           553: bool
        !           554: fcompat( formal , actual )
        !           555:     struct nl  *formal;
        !           556:     struct nl  *actual;
        !           557: {
        !           558:     register struct nl *f_chain;
        !           559:     register struct nl *a_chain;
        !           560:     extern struct nl   *plist();
        !           561:     bool compat = TRUE;
        !           562: 
        !           563:     if ( formal == NLNIL || actual == NLNIL ) {
        !           564:        return FALSE;
        !           565:     }
        !           566:     for (a_chain = plist(actual), f_chain = plist(formal);
        !           567:          f_chain != NLNIL;
        !           568:         f_chain = f_chain->chain, a_chain = a_chain->chain) {
        !           569:        if (a_chain == NIL) {
        !           570:            error("%s %s declared on line %d has more arguments than",
        !           571:                parnam(formal->class), formal->symbol,
        !           572:                (char *) linenum(formal));
        !           573:            cerror("%s %s declared on line %d",
        !           574:                parnam(actual->class), actual->symbol,
        !           575:                (char *) linenum(actual));
        !           576:            return FALSE;
        !           577:        }
        !           578:        if ( a_chain -> class != f_chain -> class ) {
        !           579:            error("%s parameter %s of %s declared on line %d is not identical",
        !           580:                parnam(f_chain->class), f_chain->symbol,
        !           581:                formal->symbol, (char *) linenum(formal));
        !           582:            cerror("with %s parameter %s of %s declared on line %d",
        !           583:                parnam(a_chain->class), a_chain->symbol,
        !           584:                actual->symbol, (char *) linenum(actual));
        !           585:            compat = FALSE;
        !           586:        } else if (a_chain->class == FFUNC || a_chain->class == FPROC) {
        !           587:            /*compat = (compat && fcompat(f_chain, a_chain));*/
        !           588:            if ((compat) && (fcompat(f_chain, a_chain)))
        !           589:                compat = TRUE;
        !           590:            else compat = FALSE;
        !           591:        }
        !           592:        if ((a_chain->class != FPROC && f_chain->class != FPROC) &&
        !           593:            (a_chain->type != f_chain->type)) {
        !           594:            error("Type of %s parameter %s of %s declared on line %d is not identical",
        !           595:                parnam(f_chain->class), f_chain->symbol,
        !           596:                formal->symbol, (char *) linenum(formal));
        !           597:            cerror("to type of %s parameter %s of %s declared on line %d",
        !           598:                parnam(a_chain->class), a_chain->symbol,
        !           599:                actual->symbol, (char *) linenum(actual));
        !           600:            compat = FALSE;
        !           601:        }
        !           602:     }
        !           603:     if (a_chain != NIL) {
        !           604:        error("%s %s declared on line %d has fewer arguments than",
        !           605:            parnam(formal->class), formal->symbol,
        !           606:            (char *) linenum(formal));
        !           607:        cerror("%s %s declared on line %d",
        !           608:            parnam(actual->class), actual->symbol,
        !           609:            (char *) linenum(actual));
        !           610:        return FALSE;
        !           611:     }
        !           612:     return compat;
        !           613: }
        !           614: 
        !           615: char *
        !           616: parnam(nltype)
        !           617:     int nltype;
        !           618: {
        !           619:     switch(nltype) {
        !           620:        case REF:
        !           621:            return "var";
        !           622:        case VAR:
        !           623:            return "value";
        !           624:        case FUNC:
        !           625:        case FFUNC:
        !           626:            return "function";
        !           627:        case PROC:
        !           628:        case FPROC:
        !           629:            return "procedure";
        !           630:        default:
        !           631:            return "SNARK";
        !           632:     }
        !           633: }
        !           634: 
        !           635: struct nl *plist(p)
        !           636:     struct nl *p;
        !           637: {
        !           638:     switch (p->class) {
        !           639:        case FFUNC:
        !           640:        case FPROC:
        !           641:            return p->ptr[ NL_FCHAIN ];
        !           642:        case PROC:
        !           643:        case FUNC:
        !           644:            return p->chain;
        !           645:        default:
        !           646:            {
        !           647:                panic("plist");
        !           648:                return(NLNIL); /* this is here only so lint won't complain
        !           649:                                  panic actually aborts */
        !           650:            }
        !           651: 
        !           652:     }
        !           653: }
        !           654: 
        !           655: linenum(p)
        !           656:     struct nl *p;
        !           657: {
        !           658:     if (p->class == FUNC)
        !           659:        return p->ptr[NL_FVAR]->value[NL_LINENO];
        !           660:     return p->value[NL_LINENO];
        !           661: }

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