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