xref: /csrg-svn/usr.bin/pascal/src/fhdr.c (revision 3838)
13191Smckusick /* Copyright (c) 1979 Regents of the University of California */
23191Smckusick 
3*3838Speter static char sccsid[] = "@(#)fhdr.c 1.3 06/01/81";
43191Smckusick 
53191Smckusick #include "whoami.h"
63191Smckusick #include "0.h"
73191Smckusick #include "tree.h"
83191Smckusick #include "opcode.h"
93191Smckusick #include "objfmt.h"
103191Smckusick #include "align.h"
113191Smckusick 
123191Smckusick /*
133191Smckusick  * this array keeps the pxp counters associated with
143191Smckusick  * functions and procedures, so that they can be output
153191Smckusick  * when their bodies are encountered
163191Smckusick  */
173191Smckusick int	bodycnts[ DSPLYSZ ];
183191Smckusick 
193191Smckusick #ifdef PC
203191Smckusick #   include "pc.h"
213191Smckusick #   include "pcops.h"
223191Smckusick #endif PC
233191Smckusick 
243191Smckusick #ifdef OBJ
253191Smckusick int	cntpatch;
263191Smckusick int	nfppatch;
273191Smckusick #endif OBJ
283191Smckusick 
293191Smckusick /*
303191Smckusick  * Funchdr inserts
313191Smckusick  * declaration of a the
323191Smckusick  * prog/proc/func into the
333191Smckusick  * namelist. It also handles
343191Smckusick  * the arguments and puts out
353191Smckusick  * a transfer which defines
363191Smckusick  * the entry point of a procedure.
373191Smckusick  */
383191Smckusick 
393191Smckusick struct nl *
403191Smckusick funchdr(r)
413191Smckusick 	int *r;
423191Smckusick {
433191Smckusick 	register struct nl *p;
443191Smckusick 	register *il, **rl;
453302Smckusic 	struct nl *cp, *dp;
463302Smckusic 	int s, o, *pp;
473191Smckusick 
483191Smckusick 	if (inpflist(r[2])) {
493191Smckusick 		opush('l');
503191Smckusick 		yyretrieve();	/* kludge */
513191Smckusick 	}
523191Smckusick 	pfcnt++;
533191Smckusick 	parts[ cbn ] |= RPRT;
543191Smckusick 	line = r[1];
553191Smckusick 	if (r[3] == NIL && (p=lookup1(r[2])) != NIL && bn == cbn) {
563191Smckusick 		/*
573191Smckusick 		 * Symbol already defined
583191Smckusick 		 * in this block. it is either
593191Smckusick 		 * a redeclared symbol (error)
603191Smckusick 		 * a forward declaration,
613191Smckusick 		 * or an external declaration.
623191Smckusick 		 */
633191Smckusick 		if ((p->class == FUNC || p->class == PROC) && (p->nl_flags & NFORWD) != 0) {
643191Smckusick 			/*
653191Smckusick 			 * Grammar doesnt forbid
663191Smckusick 			 * types on a resolution
673191Smckusick 			 * of a forward function
683191Smckusick 			 * declaration.
693191Smckusick 			 */
703191Smckusick 			if (p->class == FUNC && r[4])
713191Smckusick 				error("Function type should be given only in forward declaration");
723191Smckusick 			/*
733191Smckusick 			 * get another counter for the actual
743191Smckusick 			 */
753191Smckusick 			if ( monflg ) {
763191Smckusick 			    bodycnts[ cbn ] = getcnt();
773191Smckusick 			}
783191Smckusick #			ifdef PC
793191Smckusick 			    enclosing[ cbn ] = p -> symbol;
803191Smckusick #			endif PC
813191Smckusick #			ifdef PTREE
823191Smckusick 				/*
833191Smckusick 				 *	mark this proc/func as forward
843191Smckusick 				 *	in the pTree.
853191Smckusick 				 */
863191Smckusick 			    pDEF( p -> inTree ).PorFForward = TRUE;
873191Smckusick #			endif PTREE
883191Smckusick 			return (p);
893191Smckusick 		}
903191Smckusick 	}
913191Smckusick 
923191Smckusick 	/* if a routine segment is being compiled,
933191Smckusick 	 * do level one processing.
943191Smckusick 	 */
953191Smckusick 
963191Smckusick 	 if ((r[0] != T_PROG) && (!progseen))
973191Smckusick 		level1();
983191Smckusick 
993191Smckusick 
1003191Smckusick 	/*
1013191Smckusick 	 * Declare the prog/proc/func
1023191Smckusick 	 */
1033191Smckusick 	switch (r[0]) {
1043191Smckusick 	    case T_PROG:
1053191Smckusick 		    progseen = TRUE;
1063191Smckusick 		    if (opt('z'))
1073191Smckusick 			    monflg = TRUE;
1083191Smckusick 		    program = p = defnl(r[2], PROG, 0, 0);
1093191Smckusick 		    p->value[3] = r[1];
1103191Smckusick 		    break;
1113191Smckusick 	    case T_PDEC:
1123191Smckusick 		    if (r[4] != NIL)
1133191Smckusick 			    error("Procedures do not have types, only functions do");
1143191Smckusick 		    p = enter(defnl(r[2], PROC, 0, 0));
1153191Smckusick 		    p->nl_flags |= NMOD;
1163191Smckusick #		    ifdef PC
1173191Smckusick 			enclosing[ cbn ] = r[2];
118*3838Speter 			p -> extra_flags |= NGLOBAL;
1193191Smckusick #		    endif PC
1203191Smckusick 		    break;
1213191Smckusick 	    case T_FDEC:
1223191Smckusick 		    il = r[4];
1233191Smckusick 		    if (il == NIL)
1243191Smckusick 			    error("Function type must be specified");
1253191Smckusick 		    else if (il[0] != T_TYID) {
1263191Smckusick 			    il = NIL;
1273191Smckusick 			    error("Function type can be specified only by using a type identifier");
1283191Smckusick 		    } else
1293191Smckusick 			    il = gtype(il);
1303191Smckusick 		    p = enter(defnl(r[2], FUNC, il, NIL));
1313191Smckusick 		    p->nl_flags |= NMOD;
1323191Smckusick 		    /*
1333191Smckusick 		     * An arbitrary restriction
1343191Smckusick 		     */
1353191Smckusick 		    switch (o = classify(p->type)) {
1363191Smckusick 			    case TFILE:
1373191Smckusick 			    case TARY:
1383191Smckusick 			    case TREC:
1393191Smckusick 			    case TSET:
1403191Smckusick 			    case TSTR:
1413191Smckusick 				    warning();
1423191Smckusick 				    if (opt('s')) {
1433191Smckusick 					    standard();
1443191Smckusick 				    }
1453191Smckusick 				    error("Functions should not return %ss", clnames[o]);
1463191Smckusick 		    }
1473191Smckusick #		    ifdef PC
1483191Smckusick 			enclosing[ cbn ] = r[2];
149*3838Speter 			p -> extra_flags |= NGLOBAL;
1503191Smckusick #		    endif PC
1513191Smckusick 		    break;
1523191Smckusick 	    default:
1533191Smckusick 		    panic("funchdr");
1543191Smckusick 	}
1553191Smckusick 	if (r[0] != T_PROG) {
1563191Smckusick 		/*
1573191Smckusick 		 * Mark this proc/func as
1583191Smckusick 		 * being forward declared
1593191Smckusick 		 */
1603191Smckusick 		p->nl_flags |= NFORWD;
1613191Smckusick 		/*
1623191Smckusick 		 * Enter the parameters
1633191Smckusick 		 * in the next block for
1643191Smckusick 		 * the time being
1653191Smckusick 		 */
1663191Smckusick 		if (++cbn >= DSPLYSZ) {
1673191Smckusick 			error("Procedure/function nesting too deep");
1683191Smckusick 			pexit(ERRS);
1693191Smckusick 		}
1703191Smckusick 		/*
1713191Smckusick 		 * For functions, the function variable
1723191Smckusick 		 */
1733191Smckusick 		if (p->class == FUNC) {
1743191Smckusick #			ifdef OBJ
1753191Smckusick 			    cp = defnl(r[2], FVAR, p->type, 0);
1763191Smckusick #			endif OBJ
1773191Smckusick #			ifdef PC
1783191Smckusick 				/*
1793191Smckusick 				 * fvars used to be allocated and deallocated
1803191Smckusick 				 * by the caller right before the arguments.
1813191Smckusick 				 * the offset of the fvar was kept in
1823191Smckusick 				 * value[NL_OFFS] of function (very wierd,
1833191Smckusick 				 * but see asgnop).
1843191Smckusick 				 * now, they are locals to the function
1853191Smckusick 				 * with the offset kept in the fvar.
1863191Smckusick 				 */
1873191Smckusick 
1883191Smckusick 			    cp = defnl(r[2], FVAR, p->type,
1893302Smckusic 				(int)-leven(roundup(
1903302Smckusic 			            (int)(DPOFF1+lwidth(p->type)),
1913302Smckusic 				    (long)align(p->type))));
192*3838Speter 			    cp -> extra_flags |= NLOCAL;
1933191Smckusick #			endif PC
1943191Smckusick 			cp->chain = p;
1953191Smckusick 			p->ptr[NL_FVAR] = cp;
1963191Smckusick 		}
1973191Smckusick 		/*
1983191Smckusick 		 * Enter the parameters
1993191Smckusick 		 * and compute total size
2003191Smckusick 		 */
2013302Smckusic 	        p->value[NL_OFFS] = params(p, r[3]);
2023302Smckusic 		/*
2033302Smckusic 		 * because NL_LINENO field in the function
2043302Smckusic 		 * namelist entry has been used (as have all
2053302Smckusic 		 * the other fields), the line number is
2063302Smckusic 		 * stored in the NL_LINENO field of its fvar.
2073302Smckusic 		 */
2083302Smckusic 		if (p->class == FUNC)
2093302Smckusic 		    p->ptr[NL_FVAR]->value[NL_LINENO] = r[1];
2103302Smckusic 		else
2113302Smckusic 		    p->value[NL_LINENO] = r[1];
2123191Smckusick 		cbn--;
2133191Smckusick 	} else {
2143191Smckusick 		/*
2153191Smckusick 		 * The wonderful
2163191Smckusick 		 * program statement!
2173191Smckusick 		 */
2183191Smckusick #		ifdef OBJ
2193191Smckusick 		    if (monflg) {
2203191Smckusick 			    put(1, O_PXPBUF);
2213191Smckusick 			    cntpatch = put(2, O_CASE4, (long)0);
2223191Smckusick 			    nfppatch = put(2, O_CASE4, (long)0);
2233191Smckusick 		    }
2243191Smckusick #		endif OBJ
2253191Smckusick 		cp = p;
2263191Smckusick 		for (rl = r[3]; rl; rl = rl[2]) {
2273191Smckusick 			if (rl[1] == NIL)
2283191Smckusick 				continue;
2293191Smckusick 			dp = defnl(rl[1], VAR, 0, 0);
2303191Smckusick 			cp->chain = dp;
2313191Smckusick 			cp = dp;
2323191Smckusick 		}
2333191Smckusick 	}
2343191Smckusick 	/*
2353191Smckusick 	 * Define a branch at
2363191Smckusick 	 * the "entry point" of
2373191Smckusick 	 * the prog/proc/func.
2383191Smckusick 	 */
2393191Smckusick 	p->entloc = getlab();
2403191Smckusick 	if (monflg) {
2413191Smckusick 		bodycnts[ cbn ] = getcnt();
2423191Smckusick 		p->value[ NL_CNTR ] = 0;
2433191Smckusick 	}
2443191Smckusick #	ifdef OBJ
2453191Smckusick 	    put(2, O_TRA4, (long)p->entloc);
2463191Smckusick #	endif OBJ
2473191Smckusick #	ifdef PTREE
2483191Smckusick 	    {
2493191Smckusick 		pPointer	PF = tCopy( r );
2503191Smckusick 
2513191Smckusick 		pSeize( PorFHeader[ nesting ] );
2523191Smckusick 		if ( r[0] != T_PROG ) {
2533191Smckusick 			pPointer	*PFs;
2543191Smckusick 
2553191Smckusick 			PFs = &( pDEF( PorFHeader[ nesting ] ).PorFPFs );
2563191Smckusick 			*PFs = ListAppend( *PFs , PF );
2573191Smckusick 		} else {
2583191Smckusick 			pDEF( PorFHeader[ nesting ] ).GlobProg = PF;
2593191Smckusick 		}
2603191Smckusick 		pRelease( PorFHeader[ nesting ] );
2613191Smckusick 	    }
2623191Smckusick #	endif PTREE
2633191Smckusick 	return (p);
2643191Smckusick }
2653302Smckusic 
2663302Smckusic 	/*
2673302Smckusic 	 * deal with the parameter declaration for a routine.
2683302Smckusic 	 * p is the namelist entry of the routine.
2693302Smckusic 	 * formalist is the parse tree for the parameter declaration.
2703302Smckusic 	 * formalist	[0]	T_LISTPP
2713302Smckusic 	 *		[1]	pointer to a formal
2723302Smckusic 	 *		[2]	pointer to next formal
2733302Smckusic 	 * for by-value or by-reference formals, the formal is
2743302Smckusic 	 * formal	[0]	T_PVAL or T_PVAR
2753302Smckusic 	 *		[1]	pointer to id_list
2763302Smckusic 	 *		[2]	pointer to type (error if not typeid)
2773302Smckusic 	 * for function and procedure formals, the formal is
2783302Smckusic 	 * formal	[0]	T_PFUNC or T_PPROC
2793302Smckusic 	 *		[1]	pointer to id_list (error if more than one)
2803302Smckusic 	 *		[2]	pointer to type (error if not typeid, or proc)
2813302Smckusic 	 *		[3]	pointer to formalist for this routine.
2823302Smckusic 	 */
2833302Smckusic fparams(p, formal)
2843302Smckusic 	register struct nl *p;
2853302Smckusic 	int *formal;
2863302Smckusic {
2873302Smckusic 	params(p, formal[3]);
2883302Smckusic 	p -> value[ NL_LINENO ] = formal[4];
2893302Smckusic 	p -> ptr[ NL_FCHAIN ] = p -> chain;
2903302Smckusic 	p -> chain = NIL;
2913302Smckusic }
2923302Smckusic 
2933302Smckusic params(p, formalist)
2943302Smckusic 	register struct nl *p;
2953302Smckusic 	int *formalist;
2963302Smckusic {
2973302Smckusic 	struct nl *chainp, *savedp;
2983302Smckusic 	struct nl *dp;
2993302Smckusic 	register int **formalp;		/* an element of the formal list */
3003302Smckusic 	register int *formal;		/* a formal */
3013302Smckusic 	int *typ, *idlist;
3023302Smckusic 	int w, o;
3033302Smckusic 
3043302Smckusic 	/*
3053302Smckusic 	 * Enter the parameters
3063302Smckusic 	 * and compute total size
3073302Smckusic 	 */
3083302Smckusic 	chainp = savedp = p;
3093302Smckusic 
3103302Smckusic #	ifdef OBJ
3113302Smckusic 	    o = 0;
3123302Smckusic #	endif OBJ
3133302Smckusic #	ifdef PC
3143302Smckusic 		/*
3153302Smckusic 		 * parameters used to be allocated backwards,
3163302Smckusic 		 * then fixed.  for pc, they are allocated correctly.
3173302Smckusic 		 * also, they are aligned.
3183302Smckusic 		 */
3193302Smckusic 	    o = DPOFF2;
3203302Smckusic #	endif PC
3213302Smckusic 	for (formalp = formalist; formalp != NIL; formalp = formalp[2]) {
3223302Smckusic 		p = NIL;
3233302Smckusic 		formal = formalp[1];
3243302Smckusic 		if (formal == NIL)
3253302Smckusic 			continue;
3263302Smckusic 		/*
3273302Smckusic 		 * Parametric procedures
3283302Smckusic 		 * don't have types !?!
3293302Smckusic 		 */
3303302Smckusic 		typ = formal[2];
3313302Smckusic 		if ( typ == NIL ) {
3323302Smckusic 		    if ( formal[0] != T_PPROC ) {
3333302Smckusic 			error("Types must be specified for arguments");
3343302Smckusic 			p = NIL;
3353302Smckusic 		    }
3363302Smckusic 		} else {
3373302Smckusic 		    if ( formal[0] == T_PPROC ) {
3383302Smckusic 			error("Procedures cannot have types");
3393302Smckusic 			p = NIL;
3403302Smckusic 		    } else {
3413302Smckusic 			if (typ[0] != T_TYID) {
3423302Smckusic 				error("Types for arguments can be specified only by using type identifiers");
3433302Smckusic 				p = NIL;
3443302Smckusic 			} else {
3453302Smckusic 				p = gtype(typ);
3463302Smckusic 			}
3473302Smckusic 		    }
3483302Smckusic 		}
3493302Smckusic 		for (idlist = formal[1]; idlist != NIL; idlist = idlist[2]) {
3503302Smckusic 			switch (formal[0]) {
3513302Smckusic 			    default:
3523302Smckusic 				    panic("funchdr2");
3533302Smckusic 			    case T_PVAL:
3543302Smckusic 				    if (p != NIL) {
3553302Smckusic 					    if (p->class == FILET)
3563302Smckusic 						    error("Files cannot be passed by value");
3573302Smckusic 					    else if (p->nl_flags & NFILES)
3583302Smckusic 						    error("Files cannot be a component of %ss passed by value",
3593302Smckusic 							    nameof(p));
3603302Smckusic 				    }
3613302Smckusic #				    ifdef OBJ
3623302Smckusic 					w = lwidth(p);
3633302Smckusic 					o -= even(w);
3643302Smckusic #					ifdef DEC11
3653302Smckusic 					    dp = defnl(idlist[1], VAR, p, o);
3663302Smckusic #					else
3673302Smckusic 					    dp = defnl(idlist[1], VAR, p,
3683302Smckusic 						(w < 2) ? o + 1 : o);
3693302Smckusic #					endif DEC11
3703302Smckusic #				    endif OBJ
3713302Smckusic #				    ifdef PC
3723302Smckusic 					dp = defnl( idlist[1] , VAR , p
3733302Smckusic 						, o = roundup( o , (long)A_STACK ) );
3743302Smckusic 					o += lwidth( p );
3753302Smckusic #				    endif PC
3763302Smckusic 				    dp->nl_flags |= NMOD;
3773302Smckusic 				    break;
3783302Smckusic 			    case T_PVAR:
3793302Smckusic #				    ifdef OBJ
3803302Smckusic 					dp = defnl(idlist[1], REF, p, o -= sizeof ( int * ) );
3813302Smckusic #				    endif OBJ
3823302Smckusic #				    ifdef PC
3833302Smckusic 					dp = defnl( idlist[1] , REF , p
3843302Smckusic 						, o = roundup( o , (long)A_STACK ) );
3853302Smckusic 					o += sizeof(char *);
3863302Smckusic #				    endif PC
3873302Smckusic 				    break;
3883302Smckusic 			    case T_PFUNC:
3893302Smckusic 				    if (idlist[2] != NIL) {
3903302Smckusic 					error("Each function argument must be declared separately");
3913302Smckusic 					idlist[2] = NIL;
3923302Smckusic 				    }
3933302Smckusic #				    ifdef OBJ
3943302Smckusic 					dp = defnl(idlist[1], FFUNC, p, o -= sizeof ( int * ) );
3953302Smckusic #				    endif OBJ
3963302Smckusic #				    ifdef PC
3973302Smckusic 					dp = defnl( idlist[1] , FFUNC , p
3983302Smckusic 						, o = roundup( o , (long)A_STACK ) );
3993302Smckusic 					o += sizeof(char *);
4003302Smckusic #				    endif PC
4013302Smckusic 				    dp -> nl_flags |= NMOD;
4023302Smckusic 				    fparams(dp, formal);
4033302Smckusic 				    break;
4043302Smckusic 			    case T_PPROC:
4053302Smckusic 				    if (idlist[2] != NIL) {
4063302Smckusic 					error("Each procedure argument must be declared separately");
4073302Smckusic 					idlist[2] = NIL;
4083302Smckusic 				    }
4093302Smckusic #				    ifdef OBJ
4103302Smckusic 					dp = defnl(idlist[1], FPROC, p, o -= sizeof ( int * ) );
4113302Smckusic #				    endif OBJ
4123302Smckusic #				    ifdef PC
4133302Smckusic 					dp = defnl( idlist[1] , FPROC , p
4143302Smckusic 						, o = roundup( o , (long)A_STACK ) );
4153302Smckusic 					o += sizeof(char *);
4163302Smckusic #				    endif PC
4173302Smckusic 				    dp -> nl_flags |= NMOD;
4183302Smckusic 				    fparams(dp, formal);
4193302Smckusic 				    break;
4203302Smckusic 			    }
4213302Smckusic 			if (dp != NIL) {
422*3838Speter #				ifdef PC
423*3838Speter 				    dp -> extra_flags |= NPARAM;
424*3838Speter #				endif PC
4253302Smckusic 				chainp->chain = dp;
4263302Smckusic 				chainp = dp;
4273302Smckusic 			}
4283302Smckusic 		}
4293302Smckusic 	}
4303302Smckusic 	p = savedp;
4313302Smckusic #	ifdef OBJ
4323302Smckusic 		/*
4333302Smckusic 		 * Correct the naivete (naivety)
4343302Smckusic 		 * of our above code to
4353302Smckusic 		 * calculate offsets
4363302Smckusic 		 */
4373302Smckusic 	    for (dp = p->chain; dp != NIL; dp = dp->chain)
4383302Smckusic 		    dp->value[NL_OFFS] += -o + DPOFF2;
4393302Smckusic 	    return (-o + DPOFF2);
4403302Smckusic #	endif OBJ
4413302Smckusic #	ifdef PC
4423302Smckusic 	    return roundup( o , (long)A_STACK );
4433302Smckusic #	endif PC
4443302Smckusic }
445