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