4.4BSD/usr/src/usr.bin/pascal/src/fhdr.c.new
/*-
* Copyright (c) 1980 The Regents of the University of California.
* All rights reserved.
*
* %sccs.include.redist.c%
*/
#ifndef lint
static char sccsid[] = "%W% (Berkeley) %G%";
#endif /* not lint */
#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "opcode.h"
#include "objfmt.h"
#include "align.h"
#include "tree_ty.h"
/*
* this array keeps the pxp counters associated with
* functions and procedures, so that they can be output
* when their bodies are encountered
*/
int bodycnts[ DSPLYSZ ];
#ifdef PC
# include "pc.h"
#endif PC
#ifdef OBJ
int cntpatch;
int nfppatch;
#endif OBJ
/*
* Funchdr inserts
* declaration of a the
* prog/proc/func into the
* namelist. It also handles
* the arguments and puts out
* a transfer which defines
* the entry point of a procedure.
*/
struct nl *
funchdr(r)
struct tnode *r;
{
register struct nl *p;
register struct tnode *rl;
struct nl *cp, *dp, *temp;
int o;
if (inpflist(r->p_dec.id_ptr)) {
opush('l');
yyretrieve(); /* kludge */
}
pfcnt++;
parts[ cbn ] |= RPRT;
line = r->p_dec.line_no;
if (r->p_dec.param_list == TR_NIL &&
(p=lookup1(r->p_dec.id_ptr)) != NIL && bn == cbn) {
/*
* Symbol already defined
* in this block. it is either
* a redeclared symbol (error)
* a forward declaration,
* or an external declaration.
* check that forwards are of the right kind:
* if this fails, we are trying to redefine it
* and enter() will complain.
*/
if ( ( ( p->nl_flags & NFORWD ) != 0 )
&& ( ( p->class == FUNC && r->tag == T_FDEC )
|| ( p->class == PROC && r->tag == T_PDEC ) ) ) {
/*
* Grammar doesnt forbid
* types on a resolution
* of a forward function
* declaration.
*/
if (p->class == FUNC && r->p_dec.type)
error("Function type should be given only in forward declaration");
/*
* get another counter for the actual
*/
if ( monflg ) {
bodycnts[ cbn ] = getcnt();
}
# ifdef PC
enclosing[ cbn ] = p -> symbol;
# endif PC
# ifdef PTREE
/*
* mark this proc/func as forward
* in the pTree.
*/
pDEF( p -> inTree ).PorFForward = TRUE;
# endif PTREE
return (p);
}
}
/* if a routine segment is being compiled,
* do level one processing.
*/
if ((r->tag != T_PROG) && (!progseen))
level1();
/*
* Declare the prog/proc/func
*/
switch (r->tag) {
case T_PROG:
progseen = TRUE;
if (opt('z'))
monflg = TRUE;
program = p = defnl(r->p_dec.id_ptr, PROG, NLNIL, 0);
p->value[3] = r->p_dec.line_no;
break;
case T_PDEC:
if (r->p_dec.type != TR_NIL)
error("Procedures do not have types, only functions do");
p = enter(defnl(r->p_dec.id_ptr, PROC, NLNIL, 0));
p->nl_flags |= NMOD;
# ifdef PC
enclosing[ cbn ] = r->p_dec.id_ptr;
p -> extra_flags |= NGLOBAL;
# endif PC
break;
case T_FDEC:
{
register struct tnode *il;
il = r->p_dec.type;
if (il == TR_NIL) {
temp = NLNIL;
error("Function type must be specified");
} else if (il->tag != T_TYID) {
temp = NLNIL;
error("Function type can be specified only by using a type identifier");
} else
temp = gtype(il);
}
p = enter(defnl(r->p_dec.id_ptr, FUNC, temp, NIL));
p->nl_flags |= NMOD;
/*
* An arbitrary restriction
*/
switch (o = classify(p->type)) {
case TFILE:
case TARY:
case TREC:
case TSET:
case TSTR:
warning();
if (opt('s')) {
standard();
}
error("Functions should not return %ss", clnames[o]);
}
# ifdef PC
enclosing[ cbn ] = r->p_dec.id_ptr;
p -> extra_flags |= NGLOBAL;
# endif PC
break;
default:
panic("funchdr");
}
if (r->tag != T_PROG) {
/*
* Mark this proc/func as
* being forward declared
*/
p->nl_flags |= NFORWD;
/*
* Enter the parameters
* in the next block for
* the time being
*/
if (++cbn >= DSPLYSZ) {
error("Procedure/function nesting too deep");
pexit(ERRS);
}
/*
* For functions, the function variable
*/
if (p->class == FUNC) {
# ifdef OBJ
cp = defnl(r->p_dec.id_ptr, FVAR, p->type, 0);
# endif OBJ
# ifdef PC
/*
* fvars used to be allocated and deallocated
* by the caller right before the arguments.
* the offset of the fvar was kept in
* value[NL_OFFS] of function (very wierd,
* but see asgnop).
* now, they are locals to the function
* with the offset kept in the fvar.
*/
cp = defnl(r->p_dec.id_ptr, FVAR, p->type,
(int)-roundup(roundup(
(int)(DPOFF1+lwidth(p->type)),
(long)align(p->type))), (long) A_STACK);
cp -> extra_flags |= NLOCAL;
# endif PC
cp->chain = p;
p->ptr[NL_FVAR] = cp;
}
/*
* Enter the parameters
* and compute total size
*/
p->value[NL_OFFS] = params(p, r->p_dec.param_list);
/*
* because NL_LINENO field in the function
* namelist entry has been used (as have all
* the other fields), the line number is
* stored in the NL_LINENO field of its fvar.
*/
if (p->class == FUNC)
p->ptr[NL_FVAR]->value[NL_LINENO] = r->p_dec.line_no;
else
p->value[NL_LINENO] = r->p_dec.line_no;
cbn--;
} else {
/*
* The wonderful
* program statement!
*/
# ifdef OBJ
if (monflg) {
(void) put(1, O_PXPBUF);
cntpatch = put(2, O_CASE4, (long)0);
nfppatch = put(2, O_CASE4, (long)0);
}
# endif OBJ
cp = p;
for (rl = r->p_dec.param_list; rl; rl = rl->list_node.next) {
if (rl->list_node.list == TR_NIL)
continue;
dp = defnl((char *) rl->list_node.list, VAR, NLNIL, 0);
cp->chain = dp;
cp = dp;
}
}
/*
* Define a branch at
* the "entry point" of
* the prog/proc/func.
*/
p->value[NL_ENTLOC] = (int) getlab();
if (monflg) {
bodycnts[ cbn ] = getcnt();
p->value[ NL_CNTR ] = 0;
}
# ifdef OBJ
(void) put(2, O_TRA4, (long)p->value[NL_ENTLOC]);
# endif OBJ
# ifdef PTREE
{
pPointer PF = tCopy( r );
pSeize( PorFHeader[ nesting ] );
if ( r->tag != T_PROG ) {
pPointer *PFs;
PFs = &( pDEF( PorFHeader[ nesting ] ).PorFPFs );
*PFs = ListAppend( *PFs , PF );
} else {
pDEF( PorFHeader[ nesting ] ).GlobProg = PF;
}
pRelease( PorFHeader[ nesting ] );
}
# endif PTREE
return (p);
}
/*
* deal with the parameter declaration for a routine.
* p is the namelist entry of the routine.
* formalist is the parse tree for the parameter declaration.
* formalist [0] T_LISTPP
* [1] pointer to a formal
* [2] pointer to next formal
* for by-value or by-reference formals, the formal is
* formal [0] T_PVAL or T_PVAR
* [1] pointer to id_list
* [2] pointer to type (error if not typeid)
* for function and procedure formals, the formal is
* formal [0] T_PFUNC or T_PPROC
* [1] pointer to id_list (error if more than one)
* [2] pointer to type (error if not typeid, or proc)
* [3] pointer to formalist for this routine.
*/
fparams(p, formal)
register struct nl *p;
struct tnode *formal; /* T_PFUNC or T_PPROC */
{
(void) params(p, formal->pfunc_node.param_list);
p -> value[ NL_LINENO ] = formal->pfunc_node.line_no;
p -> ptr[ NL_FCHAIN ] = p -> chain;
p -> chain = NIL;
}
params(p, formalist)
register struct nl *p;
struct tnode *formalist; /* T_LISTPP */
{
struct nl *chainp, *savedp;
struct nl *dp;
register struct tnode *formalp; /* an element of the formal list */
register struct tnode *formal; /* a formal */
struct tnode *r, *s, *t, *typ, *idlist;
int w, o;
/*
* Enter the parameters
* and compute total size
*/
chainp = savedp = p;
# ifdef OBJ
o = 0;
# endif OBJ
# ifdef PC
/*
* parameters used to be allocated backwards,
* then fixed. for pc, they are allocated correctly.
* also, they are aligned.
*/
o = DPOFF2;
# endif PC
for (formalp = formalist; formalp != TR_NIL;
formalp = formalp->list_node.next) {
formal = formalp->list_node.list;
if (formal == TR_NIL)
continue;
/*
* Parametric procedures
* don't have types !?!
*/
typ = formal->pfunc_node.type;
p = NLNIL;
if ( typ == TR_NIL ) {
if ( formal->tag != T_PPROC ) {
error("Types must be specified for arguments");
}
} else {
if ( formal->tag == T_PPROC ) {
error("Procedures cannot have types");
} else {
p = gtype(typ);
}
}
for (idlist = formal->param.id_list; idlist != TR_NIL;
idlist = idlist->list_node.next) {
switch (formal->tag) {
default:
panic("funchdr2");
case T_PVAL:
if (p != NLNIL) {
if (p->class == FILET)
error("Files cannot be passed by value");
else if (p->nl_flags & NFILES)
error("Files cannot be a component of %ss passed by value",
nameof(p));
}
# ifdef OBJ
w = lwidth(p);
o -= roundup(w, (long) A_OBJSTACK);
# ifdef DEC11
dp = defnl((char *) idlist->list_node.list,
VAR, p, o);
# else
dp = defnl((char *) idlist->list_node.list,
VAR,p, (w < 2) ? o + 1 : o);
# endif DEC11
# endif OBJ
# ifdef PC
o = roundup(o, (long) A_STACK);
w = lwidth(p);
# ifndef DEC11
if (w <= sizeof(int)) {
o += sizeof(int) - w;
}
# endif not DEC11
dp = defnl((char *) idlist->list_node.list,VAR,
p, o);
o += w;
# endif PC
dp->nl_flags |= NMOD;
break;
case T_PVAR:
# ifdef OBJ
dp = defnl((char *) idlist->list_node.list, REF,
p, o -= sizeof ( int * ) );
# endif OBJ
# ifdef PC
dp = defnl( (char *) idlist->list_node.list, REF,
p ,
o = roundup( o , (long)A_STACK ) );
o += sizeof(char *);
# endif PC
break;
case T_PFUNC:
if (idlist->list_node.next != TR_NIL) {
error("Each function argument must be declared separately");
idlist->list_node.next = TR_NIL;
}
# ifdef OBJ
dp = defnl((char *) idlist->list_node.list,FFUNC,
p, o -= sizeof ( int * ) );
# endif OBJ
# ifdef PC
dp = defnl( (char *) idlist->list_node.list ,
FFUNC , p ,
o = roundup( o , (long)A_STACK ) );
o += sizeof(char *);
# endif PC
dp -> nl_flags |= NMOD;
fparams(dp, formal);
break;
case T_PPROC:
if (idlist->list_node.next != TR_NIL) {
error("Each procedure argument must be declared separately");
idlist->list_node.next = TR_NIL;
}
# ifdef OBJ
dp = defnl((char *) idlist->list_node.list,
FPROC, p, o -= sizeof ( int * ) );
# endif OBJ
# ifdef PC
dp = defnl( (char *) idlist->list_node.list ,
FPROC , p,
o = roundup( o , (long)A_STACK ) );
o += sizeof(char *);
# endif PC
dp -> nl_flags |= NMOD;
fparams(dp, formal);
break;
}
if (dp != NLNIL) {
# ifdef PC
dp -> extra_flags |= NPARAM;
# endif PC
chainp->chain = dp;
chainp = dp;
}
}
if (typ != TR_NIL && typ->tag == T_TYCARY) {
# ifdef OBJ
w = -roundup(lwidth(p->chain), (long) A_STACK);
# ifndef DEC11
w = (w > -2)? w + 1 : w;
# endif
# endif OBJ
# ifdef PC
w = lwidth(p->chain);
o = roundup(o, (long)A_STACK);
# endif PC
/*
* Allocate space for upper and
* lower bounds and width.
*/
for (s=typ; s->tag == T_TYCARY; s = s->ary_ty.type) {
for (r=s->ary_ty.type_list; r != TR_NIL;
r = r->list_node.next) {
t = r->list_node.list;
p = p->chain;
# ifdef OBJ
o += w;
# endif OBJ
chainp->chain = defnl(t->crang_ty.lwb_var,
VAR, p, o);
chainp = chainp->chain;
chainp->nl_flags |= (NMOD | NUSED);
p->nptr[0] = chainp;
o += w;
chainp->chain = defnl(t->crang_ty.upb_var,
VAR, p, o);
chainp = chainp->chain;
chainp->nl_flags |= (NMOD | NUSED);
p->nptr[1] = chainp;
o += w;
chainp->chain = defnl(0, VAR, p, o);
chainp = chainp->chain;
chainp->nl_flags |= (NMOD | NUSED);
p->nptr[2] = chainp;
# ifdef PC
o += w;
# endif PC
}
}
}
}
p = savedp;
# ifdef OBJ
/*
* Correct the naivete (naivety)
* of our above code to
* calculate offsets
*/
for (dp = p->chain; dp != NLNIL; dp = dp->chain)
dp->value[NL_OFFS] += -o + DPOFF2;
return (-o + DPOFF2);
# endif OBJ
# ifdef PC
return roundup( o , (long)A_STACK );
# endif PC
}