xref: /csrg-svn/usr.bin/pascal/src/fend.c (revision 3428)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 static char sccsid[] = "@(#)fend.c 1.6 04/01/81";
4 
5 #include "whoami.h"
6 #include "0.h"
7 #include "tree.h"
8 #include "opcode.h"
9 #include "objfmt.h"
10 #include "align.h"
11 
12 /*
13  * this array keeps the pxp counters associated with
14  * functions and procedures, so that they can be output
15  * when their bodies are encountered
16  */
17 int	bodycnts[ DSPLYSZ ];
18 
19 #ifdef PC
20 #   include "pc.h"
21 #   include "pcops.h"
22 #endif PC
23 
24 #ifdef OBJ
25 int	cntpatch;
26 int	nfppatch;
27 #endif OBJ
28 
29 struct	nl *Fp;
30 int	pnumcnt;
31 /*
32  * Funcend is called to
33  * finish a block by generating
34  * the code for the statements.
35  * It then looks for unresolved declarations
36  * of labels, procedures and functions,
37  * and cleans up the name list.
38  * For the program, it checks the
39  * semantics of the program
40  * statement (yuchh).
41  */
42 funcend(fp, bundle, endline)
43 	struct nl *fp;
44 	int *bundle;
45 	int endline;
46 {
47 	register struct nl *p;
48 	register int i, b;
49 	int var, inp, out, *blk;
50 	bool chkref;
51 	struct nl *iop;
52 	char *cp;
53 	extern int cntstat;
54 #	ifdef PC
55 	    int		savlabel = getlab();
56 	    int		toplabel = getlab();
57 	    int		botlabel = getlab();
58 	    char	extname[ BUFSIZ ];
59 #	endif PC
60 
61 	cntstat = 0;
62 /*
63  *	yyoutline();
64  */
65 	if (program != NIL)
66 		line = program->value[3];
67 	blk = bundle[2];
68 	if (fp == NIL) {
69 		cbn--;
70 #		ifdef PTREE
71 		    nesting--;
72 #		endif PTREE
73 		return;
74 	}
75 #ifdef OBJ
76 	/*
77 	 * Patch the branch to the
78 	 * entry point of the function
79 	 */
80 	patch4(fp->entloc);
81 	/*
82 	 * Put out the block entrance code and the block name.
83 	 * HDRSZE is the number of bytes of info in the static
84 	 * BEG data area exclusive of the proc name. It is
85 	 * currently defined as:
86 	/*	struct hdr {
87 	/*		long framesze;	/* number of bytes of local vars */
88 	/*		long nargs;	/* number of bytes of arguments */
89 	/*		bool tests;	/* TRUE => perform runtime tests */
90 	/*		short offset;	/* offset of procedure in source file */
91 	/*		char name[1];	/* name of active procedure */
92 	/*	};
93 	 */
94 #	define HDRSZE (2 * sizeof(long) + sizeof(short) + sizeof(bool))
95 	var = put(2, ((lenstr(fp->symbol,0) + HDRSZE) << 8)
96 		| (cbn == 1 && opt('p') == 0 ? O_NODUMP: O_BEG), (long)0);
97 	    /*
98 	     *  output the number of bytes of arguments
99 	     *  this is only checked on formal calls.
100 	     */
101 	put(2, O_CASE4, cbn == 1 ? (long)0 : (long)(fp->value[NL_OFFS]-DPOFF2));
102 	    /*
103 	     *	Output the runtime test mode for the routine
104 	     */
105 	put(2, sizeof(bool) == 2 ? O_CASE2 : O_CASE4, opt('t') ? TRUE : FALSE);
106 	    /*
107 	     *	Output line number and routine name
108 	     */
109 	put(2, O_CASE2, bundle[1]);
110 	putstr(fp->symbol, 0);
111 #endif OBJ
112 #ifdef PC
113 	/*
114 	 * put out the procedure entry code
115 	 */
116 	if ( fp -> class == PROG ) {
117 	    putprintf( "	.text" , 0 );
118 	    putprintf( "	.align	1" , 0 );
119 	    putprintf( "	.globl	_main" , 0 );
120 	    putprintf( "_main:" , 0 );
121 	    putprintf( "	.word	0" , 0 );
122 	    putprintf( "	calls	$0,_PCSTART" , 0 );
123 	    putprintf( "	movl	4(ap),__argc" , 0 );
124 	    putprintf( "	movl	8(ap),__argv" , 0 );
125 	    putprintf( "	calls	$0,_program" , 0 );
126 	    putprintf( "	calls	$0,_PCEXIT" , 0 );
127 	    ftnno = fp -> entloc;
128 	    putprintf( "	.text" , 0 );
129 	    putprintf( "	.align	1" , 0 );
130 	    putprintf( "	.globl	_program" , 0 );
131 	    putprintf( "_program:" , 0 );
132 	    stabfunc( "program" , fp -> class , bundle[1] , 0 );
133 	} else {
134 	    ftnno = fp -> entloc;
135 	    putprintf( "	.text" , 0 );
136 	    putprintf( "	.align	1" , 0 );
137 	    sextname( extname , fp -> symbol , cbn - 1 );
138 	    putprintf( "	.globl	%s%s" , 0 , FORMALPREFIX , extname );
139 	    putprintf( "	.globl	%s" , 0 , extname );
140 	    putprintf( "%s:" , 0 , extname );
141 	    stabfunc( fp -> symbol , fp -> class , bundle[1] , cbn - 1 );
142 	    for ( p = fp -> chain ; p != NIL ; p = p -> chain ) {
143 		stabparam( p -> symbol , p2type( p -> type )
144 			    , p -> value[ NL_OFFS ] , lwidth( p -> type ) );
145 	    }
146 	    if ( fp -> class == FUNC ) {
147 		    /*
148 		     *	stab the function variable
149 		     */
150 		p = fp -> ptr[ NL_FVAR ];
151 		stablvar( p -> symbol , p2type( p -> type ) , cbn
152 			, p -> value[ NL_OFFS ] , lwidth( p -> type ) );
153 	    }
154 		/*
155 		 *	stab local variables
156 		 *	rummage down hash chain links.
157 		 */
158 	    for ( i = 0 ; i <= 077 ; i++ ) {
159 		for ( p = disptab[ i ] ; p != NIL ; p = p->nl_next) {
160 		    if ( ( p -> nl_block & 037 ) != cbn ) {
161 			break;
162 		    }
163 		    /*
164 		     *	stab local variables
165 		     *	that's named variables, but not params
166 		     */
167 		    if (   ( p -> symbol != NIL )
168 			&& ( p -> class == VAR )
169 			&& ( p -> value[ NL_OFFS ] < 0 ) ) {
170 			stablvar( p -> symbol , p2type( p -> type ) , cbn
171 			    , p -> value[ NL_OFFS ] , lwidth( p -> type ) );
172 		    }
173 		}
174 	    }
175 	}
176 	stablbrac( cbn );
177 	    /*
178 	     *	register save mask
179 	     */
180 	putprintf( "	.word	" , 1 );
181         putprintf( PREFIXFORMAT , 0 , LABELPREFIX , savlabel );
182 	putjbr( botlabel );
183 	putlab( toplabel );
184 	if ( profflag ) {
185 		/*
186 		 *	call mcount for profiling
187 		 */
188 	    putprintf( "	moval	1f,r0" , 0 );
189 	    putprintf( "	jsb	mcount" , 0 );
190 	    putprintf( "	.data" , 0 );
191 	    putprintf( "	.align	2" , 0 );
192 	    putprintf( "1:" , 0 );
193 	    putprintf( "	.long	0" , 0 );
194 	    putprintf( "	.text" , 0 );
195 	}
196 	    /*
197 	     *	set up unwind exception vector.
198 	     */
199 	putprintf( "	moval	%s,%d(%s)" , 0
200 		, UNWINDNAME , UNWINDOFFSET , P2FPNAME );
201 	    /*
202 	     *	save address of display entry, for unwind.
203 	     */
204 	putprintf( "	moval	%s+%d,%d(%s)" , 0
205 		, DISPLAYNAME , cbn * sizeof(struct dispsave)
206 		, DPTROFFSET , P2FPNAME );
207 	    /*
208 	     *	save old display
209 	     */
210 	putprintf( "	movq	%s+%d,%d(%s)" , 0
211 		, DISPLAYNAME , cbn * sizeof(struct dispsave)
212 		, DSAVEOFFSET , P2FPNAME );
213 	    /*
214 	     *	set up new display by saving AP and FP in appropriate
215 	     *	slot in display structure.
216 	     */
217 	putprintf( "	movq	%s,%s+%d" , 0
218 		, P2APNAME , DISPLAYNAME , cbn * sizeof(struct dispsave) );
219 	    /*
220 	     *	ask second pass to allocate known locals
221 	     */
222 	putlbracket( ftnno , -sizes[ cbn ].om_max );
223 	    /*
224 	     *	and zero them if checking is on
225 	     *	by calling blkclr( bytes of locals , starting local address );
226 	     */
227 	if ( opt( 't' ) && ( -sizes[ cbn ].om_max ) > DPOFF1 ) {
228 	    putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
229 		    , "_blkclr" );
230 	    putleaf( P2ICON ,  ( -sizes[ cbn ].om_max ) - DPOFF1
231 		    , 0 , P2INT , 0 );
232 	    putLV( 0 , cbn , sizes[ cbn ].om_max , P2CHAR );
233 	    putop( P2LISTOP , P2INT );
234 	    putop( P2CALL , P2INT );
235 	    putdot( filename , line );
236 	}
237 #endif PC
238 	if ( monflg ) {
239 		if ( fp -> value[ NL_CNTR ] != 0 ) {
240 			inccnt( fp -> value [ NL_CNTR ] );
241 		}
242 		inccnt( bodycnts[ fp -> nl_block & 037 ] );
243 	}
244 	if (fp->class == PROG) {
245 		/*
246 		 * The glorious buffers option.
247 		 *          0 = don't buffer output
248 		 *          1 = line buffer output
249 		 *          2 = 512 byte buffer output
250 		 */
251 #		ifdef OBJ
252 		    if (opt('b') != 1)
253 			    put(1, O_BUFF | opt('b') << 8);
254 #		endif OBJ
255 #		ifdef PC
256 		    if ( opt( 'b' ) != 1 ) {
257 			putleaf( P2ICON , 0 , 0
258 				, ADDTYPE( P2FTN | P2INT , P2PTR ) , "_BUFF" );
259 			putleaf( P2ICON , opt( 'b' ) , 0 , P2INT , 0 );
260 			putop( P2CALL , P2INT );
261 			putdot( filename , line );
262 		    }
263 #		endif PC
264 		out = 0;
265 		for (p = fp->chain; p != NIL; p = p->chain) {
266 			if (strcmp(p->symbol, "input") == 0) {
267 				inp++;
268 				continue;
269 			}
270 			if (strcmp(p->symbol, "output") == 0) {
271 				out++;
272 				continue;
273 			}
274 			iop = lookup1(p->symbol);
275 			if (iop == NIL || bn != cbn) {
276 				error("File %s listed in program statement but not declared", p->symbol);
277 				continue;
278 			}
279 			if (iop->class != VAR) {
280 				error("File %s listed in program statement but declared as a %s", p->symbol, classes[iop->class]);
281 				continue;
282 			}
283 			if (iop->type == NIL)
284 				continue;
285 			if (iop->type->class != FILET) {
286 				error("File %s listed in program statement but defined as %s",
287 					p->symbol, nameof(iop->type));
288 				continue;
289 			}
290 #			ifdef OBJ
291 			    put(2, O_CON24, text(iop->type) ? 0 : width(iop->type->type));
292 			    i = lenstr(p->symbol,0);
293 			    put(2, O_CON24, i);
294 			    put(2, O_LVCON, i);
295 			    putstr(p->symbol, 0);
296 			    put(2, O_LV | bn<<8+INDX, (int)iop->value[NL_OFFS]);
297 			    put(1, O_DEFNAME);
298 #			endif OBJ
299 #			ifdef PC
300 			    putleaf( P2ICON , 0 , 0
301 				    , ADDTYPE( P2FTN | P2INT , P2PTR )
302 				    , "_DEFNAME" );
303 			    putLV( p -> symbol , bn , iop -> value[NL_OFFS]
304 				    , p2type( iop ) );
305 			    putCONG( p -> symbol , strlen( p -> symbol )
306 				    , LREQ );
307 			    putop( P2LISTOP , P2INT );
308 			    putleaf( P2ICON , strlen( p -> symbol )
309 				    , 0 , P2INT , 0 );
310 			    putop( P2LISTOP , P2INT );
311 			    putleaf( P2ICON
312 				, text(iop->type) ? 0 : width(iop->type->type)
313 				, 0 , P2INT , 0 );
314 			    putop( P2LISTOP , P2INT );
315 			    putop( P2CALL , P2INT );
316 			    putdot( filename , line );
317 #			endif PC
318 		}
319 		if (out == 0 && fp->chain != NIL) {
320 			recovered();
321 			error("The file output must appear in the program statement file list");
322 		}
323 	}
324 	/*
325 	 * Process the prog/proc/func body
326 	 */
327 	noreach = 0;
328 	line = bundle[1];
329 	statlist(blk);
330 #	ifdef PTREE
331 	    {
332 		pPointer Body = tCopy( blk );
333 
334 		pDEF( PorFHeader[ nesting -- ] ).PorFBody = Body;
335 	    }
336 #	endif PTREE
337 #	ifdef OBJ
338 	    if (cbn== 1 && monflg != 0) {
339 		    patchfil(cntpatch - 2, (long)cnts, 2);
340 		    patchfil(nfppatch - 2, (long)pfcnt, 2);
341 	    }
342 #	endif OBJ
343 #	ifdef PC
344 	    if ( fp -> class == PROG && monflg ) {
345 		putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
346 			, "_PMFLUSH" );
347 		putleaf( P2ICON , cnts , 0 , P2INT , 0 );
348 		putleaf( P2ICON , pfcnt , 0 , P2INT , 0 );
349 		putop( P2LISTOP , P2INT );
350 		putLV( PCPCOUNT , 0 , 0 , P2INT );
351 		putop( P2LISTOP , P2INT );
352 		putop( P2CALL , P2INT );
353 		putdot( filename , line );
354 	    }
355 #	endif PC
356 	if (fp->class == PROG && inp == 0 && (input->nl_flags & (NUSED|NMOD)) != 0) {
357 		recovered();
358 		error("Input is used but not defined in the program statement");
359 	}
360 	/*
361 	 * Clean up the symbol table displays and check for unresolves
362 	 */
363 	line = endline;
364 	b = cbn;
365 	Fp = fp;
366 	chkref = syneflg == errcnt[cbn] && opt('w') == 0;
367 	for (i = 0; i <= 077; i++) {
368 		for (p = disptab[i]; p != NIL && (p->nl_block & 037) == b; p = p->nl_next) {
369 			/*
370 			 * Check for variables defined
371 			 * but not referenced
372 			 */
373 			if (chkref && p->symbol != NIL)
374 			switch (p->class) {
375 				case FIELD:
376 					/*
377 					 * If the corresponding record is
378 					 * unused, we shouldn't complain about
379 					 * the fields.
380 					 */
381 				default:
382 					if ((p->nl_flags & (NUSED|NMOD)) == 0) {
383 						warning();
384 						nerror("%s %s is neither used nor set", classes[p->class], p->symbol);
385 						break;
386 					}
387 					/*
388 					 * If a var parameter is either
389 					 * modified or used that is enough.
390 					 */
391 					if (p->class == REF)
392 						continue;
393 #					ifdef OBJ
394 					    if ((p->nl_flags & NUSED) == 0) {
395 						warning();
396 						nerror("%s %s is never used", classes[p->class], p->symbol);
397 						break;
398 					    }
399 #					endif OBJ
400 #					ifdef PC
401 					    if (((p->nl_flags & NUSED) == 0) && ((p->ext_flags & NEXTERN) == 0)) {
402 						warning();
403 						nerror("%s %s is never used", classes[p->class], p->symbol);
404 						break;
405 					    }
406 #					endif PC
407 					if ((p->nl_flags & NMOD) == 0) {
408 						warning();
409 						nerror("%s %s is used but never set", classes[p->class], p->symbol);
410 						break;
411 					}
412 				case LABEL:
413 				case FVAR:
414 				case BADUSE:
415 					break;
416 			}
417 			switch (p->class) {
418 				case BADUSE:
419 					cp = "s";
420 					if (p->chain->ud_next == NIL)
421 						cp++;
422 					eholdnl();
423 					if (p->value[NL_KINDS] & ISUNDEF)
424 						nerror("%s undefined on line%s", p->symbol, cp);
425 					else
426 						nerror("%s improperly used on line%s", p->symbol, cp);
427 					pnumcnt = 10;
428 					pnums(p->chain);
429 					pchr('\n');
430 					break;
431 
432 				case FUNC:
433 				case PROC:
434 #					ifdef OBJ
435 					    if ((p->nl_flags & NFORWD))
436 						nerror("Unresolved forward declaration of %s %s", classes[p->class], p->symbol);
437 #					endif OBJ
438 #					ifdef PC
439 					    if ((p->nl_flags & NFORWD) && ((p->ext_flags & NEXTERN) == 0))
440 						nerror("Unresolved forward declaration of %s %s", classes[p->class], p->symbol);
441 #					endif PC
442 					break;
443 
444 				case LABEL:
445 					if (p->nl_flags & NFORWD)
446 						nerror("label %s was declared but not defined", p->symbol);
447 					break;
448 				case FVAR:
449 					if ((p->nl_flags & NMOD) == 0)
450 						nerror("No assignment to the function variable");
451 					break;
452 			}
453 		}
454 		/*
455 		 * Pop this symbol
456 		 * table slot
457 		 */
458 		disptab[i] = p;
459 	}
460 
461 #	ifdef OBJ
462 	    put(1, O_END);
463 #	endif OBJ
464 #	ifdef PC
465 		/*
466 		 *	if there were file variables declared at this level
467 		 *	call pclose( &__disply[ cbn ] ) to clean them up.
468 		 */
469 	    if ( dfiles[ cbn ] ) {
470 		putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
471 			, "_PCLOSE" );
472 		putRV( DISPLAYNAME , 0 , cbn * sizeof( struct dispsave )
473 			, P2PTR | P2CHAR );
474 		putop( P2CALL , P2INT );
475 		putdot( filename , line );
476 	    }
477 		/*
478 		 *	if this is a function,
479 		 *	the function variable is the return value.
480 		 *	if it's a scalar valued function, return scalar,
481 		 *	else, return a pointer to the structure value.
482 		 */
483 	    if ( fp -> class == FUNC ) {
484 		struct nl	*fvar = fp -> ptr[ NL_FVAR ];
485 		long		fvartype = p2type( fvar -> type );
486 		long		label;
487 		char		labelname[ BUFSIZ ];
488 
489 		switch ( classify( fvar -> type ) ) {
490 		    case TBOOL:
491 		    case TCHAR:
492 		    case TINT:
493 		    case TSCAL:
494 		    case TDOUBLE:
495 		    case TPTR:
496 			putRV( fvar -> symbol , ( fvar -> nl_block ) & 037
497 				, fvar -> value[ NL_OFFS ] , fvartype );
498 			break;
499 		    default:
500 			label = getlab();
501 			sprintf( labelname , PREFIXFORMAT ,
502 				LABELPREFIX , label );
503 			putprintf( "	.data" , 0 );
504 			putprintf( "	.lcomm	%s,%d" , 0 ,
505 				    labelname , lwidth( fvar -> type ) );
506 			putprintf( "	.text" , 0 );
507 			putleaf( P2NAME , 0 , 0 , fvartype , labelname );
508 			putLV( fvar -> symbol , ( fvar -> nl_block ) & 037
509 				, fvar -> value[ NL_OFFS ] , fvartype );
510 			putstrop( P2STASG , fvartype , lwidth( fvar -> type ) ,
511 				align( fvar -> type ) );
512 			putdot( filename , line );
513 			putleaf( P2ICON , 0 , 0 , fvartype , labelname );
514 			break;
515 		}
516 		putop( P2FORCE , fvartype );
517 		putdot( filename , line );
518 	    }
519 		/*
520 		 *	restore old display entry from save area
521 		 */
522 
523 	    putprintf( "	movq	%d(%s),%s+%d" , 0
524 		, DSAVEOFFSET , P2FPNAME
525 		, DISPLAYNAME , cbn * sizeof(struct dispsave) );
526 	    stabrbrac( cbn );
527 	    putprintf( "	ret" , 0 );
528 		/*
529 		 *	let the second pass allocate locals
530 		 * 	and registers
531 		 */
532 	    putprintf( "	.set	" , 1 );
533 	    putprintf( PREFIXFORMAT , 1 , LABELPREFIX , savlabel );
534 	    putprintf( ", 0x%x" , 0 , savmask() );
535 	    putlab( botlabel );
536 	    putprintf( "	subl2	$LF%d,sp" , 0 , ftnno );
537 	    putrbracket( ftnno );
538 	    putjbr( toplabel );
539 		/*
540 		 *  put down the entry point for formal calls
541 		 *  the arguments for FCALL have been passed to us
542 		 *  as hidden parameters after the regular arguments.
543 		 */
544 	    if ( fp -> class != PROG ) {
545 		putprintf( "%s%s:" , 0 , FORMALPREFIX , extname );
546 		putprintf( "	.word	" , 1 );
547 		putprintf( PREFIXFORMAT , 0 , LABELPREFIX , savlabel );
548 		putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) ,
549 			"_FCALL" );
550 		putRV( 0 , cbn ,
551 		    fp -> value[ NL_OFFS ] + sizeof( struct formalrtn * ) ,
552 		    P2PTR | P2STRTY );
553 		putRV( 0 , cbn , fp -> value[ NL_OFFS ] , P2PTR|P2STRTY );
554 		putop( P2LISTOP , P2INT );
555 		putop( P2CALL , P2INT );
556 		putdot( filename , line );
557 		putjbr( botlabel );
558 	    }
559 		/*
560 		 *	declare pcp counters, if any
561 		 */
562 	    if ( monflg && fp -> class == PROG ) {
563 		putprintf( "	.data" , 0 );
564 		putprintf( "	.comm	" , 1 );
565 		putprintf( PCPCOUNT , 1 );
566 		putprintf( ",%d" , 0 , ( cnts + 1 ) * sizeof (long) );
567 		putprintf( "	.text" , 0 );
568 	    }
569 #	endif PC
570 #ifdef DEBUG
571 	dumpnl(fp->ptr[2], fp->symbol);
572 #endif
573 	/*
574 	 * Restore the
575 	 * (virtual) name list
576 	 * position
577 	 */
578 	nlfree(fp->ptr[2]);
579 	/*
580 	 * Proc/func has been
581 	 * resolved
582 	 */
583 	fp->nl_flags &= ~NFORWD;
584 	/*
585 	 * Patch the beg
586 	 * of the proc/func to
587 	 * the proper variable size
588 	 */
589 	if (Fp == NIL)
590 		elineon();
591 #	ifdef OBJ
592 	    patchfil(var, (long)(-sizes[cbn].om_max), 2);
593 #	endif OBJ
594 	cbn--;
595 	if (inpflist(fp->symbol)) {
596 		opop('l');
597 	}
598 }
599 
600 #ifdef PC
601     /*
602      *	construct the long name of a function based on it's static nesting.
603      *	into a caller-supplied buffer (that should be about BUFSIZ big).
604      */
605 sextname( buffer , name , level )
606     char	buffer[];
607     char	*name;
608     int		level;
609 {
610     char	*starthere;
611     int	i;
612 
613     starthere = &buffer[0];
614     for ( i = 1 ; i < level ; i++ ) {
615 	sprintf( starthere , EXTFORMAT , enclosing[ i ] );
616 	starthere += strlen( enclosing[ i ] ) + 1;
617     }
618     sprintf( starthere , EXTFORMAT , name );
619     starthere += strlen( name ) + 1;
620     if ( starthere >= &buffer[ BUFSIZ ] ) {
621 	panic( "sextname" );
622     }
623 }
624 #endif PC
625