Return to fhdr.c CVS log

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

Annotation of 43BSD/ucb/pascal/src/fhdr.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[] = "@(#)fhdr.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: #include "align.h"
        !            17: #include "tree_ty.h"
        !            18: 
        !            19: /*
        !            20:  * this array keeps the pxp counters associated with
        !            21:  * functions and procedures, so that they can be output
        !            22:  * when their bodies are encountered
        !            23:  */
        !            24: int    bodycnts[ DSPLYSZ ];
        !            25: 
        !            26: #ifdef PC
        !            27: #   include "pc.h"
        !            28: #endif PC
        !            29: 
        !            30: #ifdef OBJ
        !            31: int    cntpatch;
        !            32: int    nfppatch;
        !            33: #endif OBJ
        !            34: 
        !            35: /*
        !            36:  * Funchdr inserts
        !            37:  * declaration of a the
        !            38:  * prog/proc/func into the
        !            39:  * namelist. It also handles
        !            40:  * the arguments and puts out
        !            41:  * a transfer which defines
        !            42:  * the entry point of a procedure.
        !            43:  */
        !            44: 
        !            45: struct nl *
        !            46: funchdr(r)
        !            47:        struct tnode *r;
        !            48: {
        !            49:        register struct nl *p;
        !            50:        register struct tnode *rl;
        !            51:        struct nl *cp, *dp, *temp;
        !            52:        int o;
        !            53: 
        !            54:        if (inpflist(r->p_dec.id_ptr)) {
        !            55:                opush('l');
        !            56:                yyretrieve();   /* kludge */
        !            57:        }
        !            58:        pfcnt++;
        !            59:        parts[ cbn ] |= RPRT;
        !            60:        line = r->p_dec.line_no;
        !            61:        if (r->p_dec.param_list == TR_NIL &&
        !            62:                (p=lookup1(r->p_dec.id_ptr)) != NIL && bn == cbn) {
        !            63:                /*
        !            64:                 * Symbol already defined
        !            65:                 * in this block. it is either
        !            66:                 * a redeclared symbol (error)
        !            67:                 * a forward declaration,
        !            68:                 * or an external declaration.
        !            69:                 * check that forwards are of the right kind:
        !            70:                 *     if this fails, we are trying to redefine it
        !            71:                 *     and enter() will complain.
        !            72:                 */
        !            73:                if (  ( ( p->nl_flags & NFORWD ) != 0 )
        !            74:                   && (  ( p->class == FUNC && r->tag == T_FDEC )
        !            75:                      || ( p->class == PROC && r->tag == T_PDEC ) ) ) {
        !            76:                        /*
        !            77:                         * Grammar doesnt forbid
        !            78:                         * types on a resolution
        !            79:                         * of a forward function
        !            80:                         * declaration.
        !            81:                         */
        !            82:                        if (p->class == FUNC && r->p_dec.type)
        !            83:                                error("Function type should be given only in forward declaration");
        !            84:                        /*
        !            85:                         * get another counter for the actual
        !            86:                         */
        !            87:                        if ( monflg ) {
        !            88:                            bodycnts[ cbn ] = getcnt();
        !            89:                        }
        !            90: #                      ifdef PC
        !            91:                            enclosing[ cbn ] = p -> symbol;
        !            92: #                      endif PC
        !            93: #                      ifdef PTREE
        !            94:                                /*
        !            95:                                 *      mark this proc/func as forward
        !            96:                                 *      in the pTree.
        !            97:                                 */
        !            98:                            pDEF( p -> inTree ).PorFForward = TRUE;
        !            99: #                      endif PTREE
        !           100:                        return (p);
        !           101:                }
        !           102:        }
        !           103: 
        !           104:        /* if a routine segment is being compiled,
        !           105:         * do level one processing.
        !           106:         */
        !           107: 
        !           108:         if ((r->tag != T_PROG) && (!progseen))
        !           109:                level1();
        !           110: 
        !           111: 
        !           112:        /*
        !           113:         * Declare the prog/proc/func
        !           114:         */
        !           115:        switch (r->tag) {
        !           116:            case T_PROG:
        !           117:                    progseen = TRUE;
        !           118:                    if (opt('z'))
        !           119:                            monflg = TRUE;
        !           120:                    program = p = defnl(r->p_dec.id_ptr, PROG, NLNIL, 0);
        !           121:                    p->value[3] = r->p_dec.line_no;
        !           122:                    break;
        !           123:            case T_PDEC:
        !           124:                    if (r->p_dec.type != TR_NIL)
        !           125:                            error("Procedures do not have types, only functions do");
        !           126:                    p = enter(defnl(r->p_dec.id_ptr, PROC, NLNIL, 0));
        !           127:                    p->nl_flags |= NMOD;
        !           128: #                  ifdef PC
        !           129:                        enclosing[ cbn ] = r->p_dec.id_ptr;
        !           130:                        p -> extra_flags |= NGLOBAL;
        !           131: #                  endif PC
        !           132:                    break;
        !           133:            case T_FDEC:
        !           134:                    {
        !           135:                        register struct tnode *il;
        !           136:                    il = r->p_dec.type;
        !           137:                    if (il == TR_NIL) {
        !           138:                            temp = NLNIL;
        !           139:                            error("Function type must be specified");
        !           140:                    } else if (il->tag != T_TYID) {
        !           141:                            temp = NLNIL;
        !           142:                            error("Function type can be specified only by using a type identifier");
        !           143:                    } else
        !           144:                            temp = gtype(il);
        !           145:                    }
        !           146:                    p = enter(defnl(r->p_dec.id_ptr, FUNC, temp, NIL));
        !           147:                    p->nl_flags |= NMOD;
        !           148:                    /*
        !           149:                     * An arbitrary restriction
        !           150:                     */
        !           151:                    switch (o = classify(p->type)) {
        !           152:                            case TFILE:
        !           153:                            case TARY:
        !           154:                            case TREC:
        !           155:                            case TSET:
        !           156:                            case TSTR:
        !           157:                                    warning();
        !           158:                                    if (opt('s')) {
        !           159:                                            standard();
        !           160:                                    }
        !           161:                                    error("Functions should not return %ss", clnames[o]);
        !           162:                    }
        !           163: #                  ifdef PC
        !           164:                        enclosing[ cbn ] = r->p_dec.id_ptr;
        !           165:                        p -> extra_flags |= NGLOBAL;
        !           166: #                  endif PC
        !           167:                    break;
        !           168:            default:
        !           169:                    panic("funchdr");
        !           170:        }
        !           171:        if (r->tag != T_PROG) {
        !           172:                /*
        !           173:                 * Mark this proc/func as
        !           174:                 * being forward declared
        !           175:                 */
        !           176:                p->nl_flags |= NFORWD;
        !           177:                /*
        !           178:                 * Enter the parameters
        !           179:                 * in the next block for
        !           180:                 * the time being
        !           181:                 */
        !           182:                if (++cbn >= DSPLYSZ) {
        !           183:                        error("Procedure/function nesting too deep");
        !           184:                        pexit(ERRS);
        !           185:                }
        !           186:                /*
        !           187:                 * For functions, the function variable
        !           188:                 */
        !           189:                if (p->class == FUNC) {
        !           190: #                      ifdef OBJ
        !           191:                            cp = defnl(r->p_dec.id_ptr, FVAR, p->type, 0);
        !           192: #                      endif OBJ
        !           193: #                      ifdef PC
        !           194:                                /*
        !           195:                                 * fvars used to be allocated and deallocated
        !           196:                                 * by the caller right before the arguments.
        !           197:                                 * the offset of the fvar was kept in
        !           198:                                 * value[NL_OFFS] of function (very wierd,
        !           199:                                 * but see asgnop).
        !           200:                                 * now, they are locals to the function
        !           201:                                 * with the offset kept in the fvar.
        !           202:                                 */
        !           203: 
        !           204:                            cp = defnl(r->p_dec.id_ptr, FVAR, p->type,
        !           205:                                (int)-leven(roundup(
        !           206:                                    (int)(DPOFF1+lwidth(p->type)),
        !           207:                                    (long)align(p->type))));
        !           208:                            cp -> extra_flags |= NLOCAL;
        !           209: #                      endif PC
        !           210:                        cp->chain = p;
        !           211:                        p->ptr[NL_FVAR] = cp;
        !           212:                }
        !           213:                /*
        !           214:                 * Enter the parameters
        !           215:                 * and compute total size
        !           216:                 */
        !           217:                p->value[NL_OFFS] = params(p, r->p_dec.param_list);
        !           218:                /*
        !           219:                 * because NL_LINENO field in the function 
        !           220:                 * namelist entry has been used (as have all
        !           221:                 * the other fields), the line number is
        !           222:                 * stored in the NL_LINENO field of its fvar.
        !           223:                 */
        !           224:                if (p->class == FUNC)
        !           225:                    p->ptr[NL_FVAR]->value[NL_LINENO] = r->p_dec.line_no;
        !           226:                else
        !           227:                    p->value[NL_LINENO] = r->p_dec.line_no;
        !           228:                cbn--;
        !           229:        } else { 
        !           230:                /*
        !           231:                 * The wonderful
        !           232:                 * program statement!
        !           233:                 */
        !           234: #              ifdef OBJ
        !           235:                    if (monflg) {
        !           236:                            (void) put(1, O_PXPBUF);
        !           237:                            cntpatch = put(2, O_CASE4, (long)0);
        !           238:                            nfppatch = put(2, O_CASE4, (long)0);
        !           239:                    }
        !           240: #              endif OBJ
        !           241:                cp = p;
        !           242:                for (rl = r->p_dec.param_list; rl; rl = rl->list_node.next) {
        !           243:                        if (rl->list_node.list == TR_NIL)
        !           244:                                continue;
        !           245:                        dp = defnl((char *) rl->list_node.list, VAR, NLNIL, 0);
        !           246:                        cp->chain = dp;
        !           247:                        cp = dp;
        !           248:                }
        !           249:        }
        !           250:        /*
        !           251:         * Define a branch at
        !           252:         * the "entry point" of
        !           253:         * the prog/proc/func.
        !           254:         */
        !           255:        p->value[NL_ENTLOC] = (int) getlab();
        !           256:        if (monflg) {
        !           257:                bodycnts[ cbn ] = getcnt();
        !           258:                p->value[ NL_CNTR ] = 0;
        !           259:        }
        !           260: #      ifdef OBJ
        !           261:            (void) put(2, O_TRA4, (long)p->value[NL_ENTLOC]);
        !           262: #      endif OBJ
        !           263: #      ifdef PTREE
        !           264:            {
        !           265:                pPointer        PF = tCopy( r );
        !           266: 
        !           267:                pSeize( PorFHeader[ nesting ] );
        !           268:                if ( r->tag != T_PROG ) {
        !           269:                        pPointer        *PFs;
        !           270: 
        !           271:                        PFs = &( pDEF( PorFHeader[ nesting ] ).PorFPFs );
        !           272:                        *PFs = ListAppend( *PFs , PF );
        !           273:                } else {
        !           274:                        pDEF( PorFHeader[ nesting ] ).GlobProg = PF;
        !           275:                }
        !           276:                pRelease( PorFHeader[ nesting ] );
        !           277:            }
        !           278: #      endif PTREE
        !           279:        return (p);
        !           280: }
        !           281: 
        !           282:        /*
        !           283:         * deal with the parameter declaration for a routine.
        !           284:         * p is the namelist entry of the routine.
        !           285:         * formalist is the parse tree for the parameter declaration.
        !           286:         * formalist    [0]     T_LISTPP
        !           287:         *              [1]     pointer to a formal
        !           288:         *              [2]     pointer to next formal
        !           289:         * for by-value or by-reference formals, the formal is
        !           290:         * formal       [0]     T_PVAL or T_PVAR
        !           291:         *              [1]     pointer to id_list
        !           292:         *              [2]     pointer to type (error if not typeid)
        !           293:         * for function and procedure formals, the formal is
        !           294:         * formal       [0]     T_PFUNC or T_PPROC
        !           295:         *              [1]     pointer to id_list (error if more than one)
        !           296:         *              [2]     pointer to type (error if not typeid, or proc)
        !           297:         *              [3]     pointer to formalist for this routine.
        !           298:         */
        !           299: fparams(p, formal)
        !           300:        register struct nl *p;
        !           301:        struct tnode *formal;           /* T_PFUNC or T_PPROC */
        !           302: {
        !           303:        (void) params(p, formal->pfunc_node.param_list);
        !           304:        p -> value[ NL_LINENO ] = formal->pfunc_node.line_no;
        !           305:        p -> ptr[ NL_FCHAIN ] = p -> chain;
        !           306:        p -> chain = NIL;
        !           307: }
        !           308: 
        !           309: params(p, formalist)
        !           310:        register struct nl *p;
        !           311:        struct tnode *formalist;        /* T_LISTPP */
        !           312: {
        !           313:        struct nl *chainp, *savedp;
        !           314:        struct nl *dp;
        !           315:        register struct tnode *formalp; /* an element of the formal list */
        !           316:        register struct tnode *formal;  /* a formal */
        !           317:        struct tnode *r, *s, *t, *typ, *idlist;
        !           318:        int w, o;
        !           319: 
        !           320:        /*
        !           321:         * Enter the parameters
        !           322:         * and compute total size
        !           323:         */
        !           324:        chainp = savedp = p;
        !           325: 
        !           326: #      ifdef OBJ
        !           327:            o = 0;
        !           328: #      endif OBJ
        !           329: #      ifdef PC
        !           330:                /*
        !           331:                 * parameters used to be allocated backwards,
        !           332:                 * then fixed.  for pc, they are allocated correctly.
        !           333:                 * also, they are aligned.
        !           334:                 */
        !           335:            o = DPOFF2;
        !           336: #      endif PC
        !           337:        for (formalp = formalist; formalp != TR_NIL;
        !           338:                        formalp = formalp->list_node.next) {
        !           339:                formal = formalp->list_node.list;
        !           340:                if (formal == TR_NIL)
        !           341:                        continue;
        !           342:                /*
        !           343:                 * Parametric procedures
        !           344:                 * don't have types !?!
        !           345:                 */
        !           346:                typ = formal->pfunc_node.type;
        !           347:                p = NLNIL;
        !           348:                if ( typ == TR_NIL ) {
        !           349:                    if ( formal->tag != T_PPROC ) {
        !           350:                        error("Types must be specified for arguments");
        !           351:                    }
        !           352:                } else {
        !           353:                    if ( formal->tag == T_PPROC ) {
        !           354:                        error("Procedures cannot have types");
        !           355:                    } else {
        !           356:                        p = gtype(typ);
        !           357:                    }
        !           358:                }
        !           359:                for (idlist = formal->param.id_list; idlist != TR_NIL;
        !           360:                                idlist = idlist->list_node.next) {
        !           361:                        switch (formal->tag) {
        !           362:                            default:
        !           363:                                    panic("funchdr2");
        !           364:                            case T_PVAL:
        !           365:                                    if (p != NLNIL) {
        !           366:                                            if (p->class == FILET)
        !           367:                                                    error("Files cannot be passed by value");
        !           368:                                            else if (p->nl_flags & NFILES)
        !           369:                                                    error("Files cannot be a component of %ss passed by value",
        !           370:                                                            nameof(p));
        !           371:                                    }
        !           372: #                                  ifdef OBJ
        !           373:                                        w = lwidth(p);
        !           374:                                        o -= even(w);
        !           375: #                                      ifdef DEC11
        !           376:                                            dp = defnl((char *) idlist->list_node.list,
        !           377:                                                                VAR, p, o);
        !           378: #                                      else
        !           379:                                            dp = defnl((char *) idlist->list_node.list,
        !           380:                                                    VAR,p, (w < 2) ? o + 1 : o);
        !           381: #                                      endif DEC11
        !           382: #                                  endif OBJ
        !           383: #                                  ifdef PC
        !           384:                                        o = roundup(o, (long) A_STACK);
        !           385:                                        w = lwidth(p);
        !           386: #                                      ifndef DEC11
        !           387:                                            if (w <= sizeof(int)) {
        !           388:                                                o += sizeof(int) - w;
        !           389:                                            }
        !           390: #                                      endif not DEC11
        !           391:                                        dp = defnl((char *) idlist->list_node.list,VAR,
        !           392:                                                        p, o);
        !           393:                                        o += w;
        !           394: #                                  endif PC
        !           395:                                    dp->nl_flags |= NMOD;
        !           396:                                    break;
        !           397:                            case T_PVAR:
        !           398: #                                  ifdef OBJ
        !           399:                                        dp = defnl((char *) idlist->list_node.list, REF,
        !           400:                                                    p, o -= sizeof ( int * ) );
        !           401: #                                  endif OBJ
        !           402: #                                  ifdef PC
        !           403:                                        dp = defnl( (char *) idlist->list_node.list, REF,
        !           404:                                                    p , 
        !           405:                                            o = roundup( o , (long)A_STACK ) );
        !           406:                                        o += sizeof(char *);
        !           407: #                                  endif PC
        !           408:                                    break;
        !           409:                            case T_PFUNC:
        !           410:                                    if (idlist->list_node.next != TR_NIL) {
        !           411:                                        error("Each function argument must be declared separately");
        !           412:                                        idlist->list_node.next = TR_NIL;
        !           413:                                    }
        !           414: #                                  ifdef OBJ
        !           415:                                        dp = defnl((char *) idlist->list_node.list,FFUNC,
        !           416:                                                p, o -= sizeof ( int * ) );
        !           417: #                                  endif OBJ
        !           418: #                                  ifdef PC
        !           419:                                        dp = defnl( (char *) idlist->list_node.list , 
        !           420:                                                FFUNC , p ,
        !           421:                                                o = roundup( o , (long)A_STACK ) );
        !           422:                                        o += sizeof(char *);
        !           423: #                                  endif PC
        !           424:                                    dp -> nl_flags |= NMOD;
        !           425:                                    fparams(dp, formal);
        !           426:                                    break;
        !           427:                            case T_PPROC:
        !           428:                                    if (idlist->list_node.next != TR_NIL) {
        !           429:                                        error("Each procedure argument must be declared separately");
        !           430:                                        idlist->list_node.next = TR_NIL;
        !           431:                                    }
        !           432: #                                  ifdef OBJ
        !           433:                                        dp = defnl((char *) idlist->list_node.list,
        !           434:                                            FPROC, p, o -= sizeof ( int * ) );
        !           435: #                                  endif OBJ
        !           436: #                                  ifdef PC
        !           437:                                        dp = defnl( (char *) idlist->list_node.list ,
        !           438:                                                FPROC , p,
        !           439:                                                o = roundup( o , (long)A_STACK ) );
        !           440:                                        o += sizeof(char *);
        !           441: #                                  endif PC
        !           442:                                    dp -> nl_flags |= NMOD;
        !           443:                                    fparams(dp, formal);
        !           444:                                    break;
        !           445:                            }
        !           446:                        if (dp != NLNIL) {
        !           447: #                              ifdef PC
        !           448:                                    dp -> extra_flags |= NPARAM;
        !           449: #                              endif PC
        !           450:                                chainp->chain = dp;
        !           451:                                chainp = dp;
        !           452:                        }
        !           453:                }
        !           454:                if (typ != TR_NIL && typ->tag == T_TYCARY) {
        !           455: #                  ifdef OBJ
        !           456:                        w = -even(lwidth(p->chain));
        !           457: #                      ifndef DEC11
        !           458:                            w = (w > -2)? w + 1 : w;
        !           459: #                      endif
        !           460: #                  endif OBJ
        !           461: #                  ifdef PC
        !           462:                        w = lwidth(p->chain);
        !           463:                        o = roundup(o, (long)A_STACK);
        !           464: #                  endif PC
        !           465:                    /*
        !           466:                     * Allocate space for upper and
        !           467:                     * lower bounds and width.
        !           468:                     */
        !           469:                    for (s=typ; s->tag == T_TYCARY; s = s->ary_ty.type) {
        !           470:                        for (r=s->ary_ty.type_list; r != TR_NIL;
        !           471:                                                r = r->list_node.next) {
        !           472:                            t = r->list_node.list;
        !           473:                            p = p->chain;
        !           474: #                          ifdef OBJ
        !           475:                                o += w;
        !           476: #                          endif OBJ
        !           477:                            chainp->chain = defnl(t->crang_ty.lwb_var,
        !           478:                                                                VAR, p, o);
        !           479:                            chainp = chainp->chain;
        !           480:                            chainp->nl_flags |= (NMOD | NUSED);
        !           481:                            p->nptr[0] = chainp;
        !           482:                            o += w;
        !           483:                            chainp->chain = defnl(t->crang_ty.upb_var,
        !           484:                                                                VAR, p, o);
        !           485:                            chainp = chainp->chain;
        !           486:                            chainp->nl_flags |= (NMOD | NUSED);
        !           487:                            p->nptr[1] = chainp;
        !           488:                            o += w;
        !           489:                            chainp->chain  = defnl(0, VAR, p, o);
        !           490:                            chainp = chainp->chain;
        !           491:                            chainp->nl_flags |= (NMOD | NUSED);
        !           492:                            p->nptr[2] = chainp;
        !           493: #                          ifdef PC
        !           494:                                o += w;
        !           495: #                          endif PC
        !           496:                        }
        !           497:                    }
        !           498:                }
        !           499:        }
        !           500:        p = savedp;
        !           501: #      ifdef OBJ
        !           502:                /*
        !           503:                 * Correct the naivete (naivety)
        !           504:                 * of our above code to
        !           505:                 * calculate offsets
        !           506:                 */
        !           507:            for (dp = p->chain; dp != NLNIL; dp = dp->chain)
        !           508:                    dp->value[NL_OFFS] += -o + DPOFF2;
        !           509:            return (-o + DPOFF2);
        !           510: #      endif OBJ
        !           511: #      ifdef PC
        !           512:            return roundup( o , (long)A_STACK );
        !           513: #      endif PC
        !           514: }

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