Return to call.c CVS log

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

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

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