* Copyright (c) 1980 The Regents of the University of California.
* %sccs.include.redist.c%
static char sccsid
[] = "@(#)fhdr.c 5.4 (Berkeley) %G%";
* this array keeps the pxp counters associated with
* functions and procedures, so that they can be output
* when their bodies are encountered
* prog/proc/func into the
* namelist. It also handles
* the arguments and puts out
* a transfer which defines
* the entry point of a procedure.
register struct tnode
*rl
;
struct nl
*cp
, *dp
, *temp
;
if (inpflist(r
->p_dec
.id_ptr
)) {
yyretrieve(); /* kludge */
if (r
->p_dec
.param_list
== TR_NIL
&&
(p
=lookup1(r
->p_dec
.id_ptr
)) != NIL
&& bn
== cbn
) {
* in this block. it is either
* a redeclared symbol (error)
* 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
) ) ) {
if (p
->class == FUNC
&& r
->p_dec
.type
)
error("Function type should be given only in forward declaration");
* get another counter for the actual
bodycnts
[ cbn
] = getcnt();
enclosing
[ cbn
] = p
-> symbol
;
* mark this proc/func as forward
pDEF( p
-> inTree
).PorFForward
= TRUE
;
/* if a routine segment is being compiled,
* do level one processing.
if ((r
->tag
!= T_PROG
) && (!progseen
))
* Declare the prog/proc/func
program
= p
= defnl(r
->p_dec
.id_ptr
, PROG
, NLNIL
, 0);
p
->value
[3] = r
->p_dec
.line_no
;
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));
enclosing
[ cbn
] = r
->p_dec
.id_ptr
;
p
-> extra_flags
|= NGLOBAL
;
register struct tnode
*il
;
error("Function type must be specified");
} else if (il
->tag
!= T_TYID
) {
error("Function type can be specified only by using a type identifier");
p
= enter(defnl(r
->p_dec
.id_ptr
, FUNC
, temp
, NIL
));
* An arbitrary restriction
switch (o
= classify(p
->type
)) {
error("Functions should not return %ss", clnames
[o
]);
enclosing
[ cbn
] = r
->p_dec
.id_ptr
;
p
-> extra_flags
|= NGLOBAL
;
error("Procedure/function nesting too deep");
* For functions, the function variable
cp
= defnl(r
->p_dec
.id_ptr
, FVAR
, p
->type
, 0);
* 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,
* 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)(DPOFF1
+lwidth(p
->type
)),
(long)align(p
->type
))), (long) A_STACK
);
cp
-> extra_flags
|= NLOCAL
;
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.
p
->ptr
[NL_FVAR
]->value
[NL_LINENO
] = r
->p_dec
.line_no
;
p
->value
[NL_LINENO
] = r
->p_dec
.line_no
;
cntpatch
= put(2, O_CASE4
, (long)0);
nfppatch
= put(2, O_CASE4
, (long)0);
for (rl
= r
->p_dec
.param_list
; rl
; rl
= rl
->list_node
.next
) {
if (rl
->list_node
.list
== TR_NIL
)
dp
= defnl((char *) rl
->list_node
.list
, VAR
, NLNIL
, 0);
p
->value
[NL_ENTLOC
] = (int) getlab();
bodycnts
[ cbn
] = getcnt();
(void) put(2, O_TRA4
, (long)p
->value
[NL_ENTLOC
]);
pPointer PF
= tCopy( r
);
pSeize( PorFHeader
[ nesting
] );
if ( r
->tag
!= T_PROG
) {
PFs
= &( pDEF( PorFHeader
[ nesting
] ).PorFPFs
);
*PFs
= ListAppend( *PFs
, PF
);
pDEF( PorFHeader
[ nesting
] ).GlobProg
= PF
;
pRelease( PorFHeader
[ nesting
] );
* 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.
* [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
* [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.
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
;
struct tnode
*formalist
; /* T_LISTPP */
struct nl
*chainp
, *savedp
;
register struct tnode
*formalp
; /* an element of the formal list */
register struct tnode
*formal
; /* a formal */
struct tnode
*r
, *s
, *t
, *typ
, *idlist
;
* parameters used to be allocated backwards,
* then fixed. for pc, they are allocated correctly.
* also, they are aligned.
for (formalp
= formalist
; formalp
!= TR_NIL
;
formalp
= formalp
->list_node
.next
) {
formal
= formalp
->list_node
.list
;
typ
= formal
->pfunc_node
.type
;
if ( formal
->tag
!= T_PPROC
) {
error("Types must be specified for arguments");
if ( formal
->tag
== T_PPROC
) {
error("Procedures cannot have types");
for (idlist
= formal
->param
.id_list
; idlist
!= TR_NIL
;
idlist
= idlist
->list_node
.next
) {
error("Files cannot be passed by value");
else if (p
->nl_flags
& NFILES
)
error("Files cannot be a component of %ss passed by value",
o
-= roundup(w
, (long) A_STACK
);
dp
= defnl((char *) idlist
->list_node
.list
,
dp
= defnl((char *) idlist
->list_node
.list
,
VAR
,p
, (w
< 2) ? o
+ 1 : o
);
o
= roundup(o
, (long) A_STACK
);
dp
= defnl((char *) idlist
->list_node
.list
,VAR
,
dp
= defnl((char *) idlist
->list_node
.list
, REF
,
p
, o
-= sizeof ( int * ) );
dp
= defnl( (char *) idlist
->list_node
.list
, REF
,
o
= roundup( o
, (long)A_STACK
) );
if (idlist
->list_node
.next
!= TR_NIL
) {
error("Each function argument must be declared separately");
idlist
->list_node
.next
= TR_NIL
;
dp
= defnl((char *) idlist
->list_node
.list
,FFUNC
,
p
, o
-= sizeof ( int * ) );
dp
= defnl( (char *) idlist
->list_node
.list
,
o
= roundup( o
, (long)A_STACK
) );
if (idlist
->list_node
.next
!= TR_NIL
) {
error("Each procedure argument must be declared separately");
idlist
->list_node
.next
= TR_NIL
;
dp
= defnl((char *) idlist
->list_node
.list
,
FPROC
, p
, o
-= sizeof ( int * ) );
dp
= defnl( (char *) idlist
->list_node
.list
,
o
= roundup( o
, (long)A_STACK
) );
dp
-> extra_flags
|= NPARAM
;
if (typ
!= TR_NIL
&& typ
->tag
== T_TYCARY
) {
w
= -roundup(lwidth(p
->chain
), (long) A_STACK
);
o
= roundup(o
, (long)A_STACK
);
* 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
;
chainp
->chain
= defnl(t
->crang_ty
.lwb_var
,
chainp
->nl_flags
|= (NMOD
| NUSED
);
chainp
->chain
= defnl(t
->crang_ty
.upb_var
,
chainp
->nl_flags
|= (NMOD
| NUSED
);
chainp
->chain
= defnl(0, VAR
, p
, o
);
chainp
->nl_flags
|= (NMOD
| NUSED
);
* Correct the naivete (naivety)
for (dp
= p
->chain
; dp
!= NLNIL
; dp
= dp
->chain
)
dp
->value
[NL_OFFS
] += -o
+ DPOFF2
;
return roundup( o
, (long)A_STACK
);