xref: /csrg-svn/usr.bin/pascal/src/stat.c (revision 15951)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 #ifndef lint
4 static char sccsid[] = "@(#)stat.c 1.13 02/06/84";
5 #endif
6 
7 #include "whoami.h"
8 #include "0.h"
9 #include "tree.h"
10 #include "objfmt.h"
11 #ifdef PC
12 #   include "pcops.h"
13 #   include "pc.h"
14 #endif PC
15 #include "tmps.h"
16 
17 int cntstat;
18 short cnts = 3;
19 #include "opcode.h"
20 #include "tree_ty.h"
21 
22 /*
23  * Statement list
24  */
25 statlist(r)
26 	struct tnode *r;
27 {
28 	register struct tnode *sl;
29 
30 	for (sl=r; sl != TR_NIL; sl=sl->list_node.next)
31 		statement(sl->list_node.list);
32 }
33 
34 /*
35  * Statement
36  */
37 statement(r)
38 	struct tnode *r;
39 {
40 	register struct tnode *tree_node;
41 	register struct nl *snlp;
42 	struct tmps soffset;
43 
44 	tree_node = r;
45 	snlp = nlp;
46 	soffset = sizes[cbn].curtmps;
47 top:
48 	if (cntstat) {
49 		cntstat = 0;
50 		putcnt();
51 	}
52 	if (tree_node == TR_NIL)
53 		return;
54 	line = tree_node->lined.line_no;
55 	if (tree_node->tag == T_LABEL) {
56 		labeled(tree_node->label_node.lbl_ptr);
57 		tree_node = tree_node->label_node.stmnt;
58 		noreach = FALSE;
59 		cntstat = 1;
60 		goto top;
61 	}
62 	if (noreach) {
63 		noreach = FALSE;
64 		warning();
65 		error("Unreachable statement");
66 	}
67 	switch (tree_node->tag) {
68 		case T_PCALL:
69 			putline();
70 #			ifdef OBJ
71 			    proc(tree_node);
72 #			endif OBJ
73 #			ifdef PC
74 			    pcproc( tree_node );
75 #			endif PC
76 			break;
77 		case T_ASGN:
78 			putline();
79 			asgnop(&(tree_node->asg_node));
80 			break;
81 		case T_GOTO:
82 			putline();
83 			gotoop(tree_node->goto_node.lbl_ptr);
84 			noreach = TRUE;
85 			cntstat = 1;
86 			break;
87 		default:
88 			level++;
89 			switch (tree_node->tag) {
90 				default:
91 					panic("stat");
92 				case T_IF:
93 				case T_IFEL:
94 					ifop(&(tree_node->if_node));
95 					break;
96 				case T_WHILE:
97 					whilop(&(tree_node->whi_cas));
98 					noreach = FALSE;
99 					break;
100 				case T_REPEAT:
101 					repop(&(tree_node->repeat));
102 					break;
103 				case T_FORU:
104 				case T_FORD:
105 				        forop(tree_node);
106 					noreach = FALSE;
107 					break;
108 				case T_BLOCK:
109 					statlist(tree_node->stmnt_blck.stmnt_list);
110 					break;
111 				case T_CASE:
112 					putline();
113 #					ifdef OBJ
114 					    caseop(&(tree_node->whi_cas));
115 #					endif OBJ
116 #					ifdef PC
117 					    pccaseop(&(tree_node->whi_cas));
118 #					endif PC
119 					break;
120 				case T_WITH:
121 					withop(&(tree_node->with_node));
122 					break;
123 			}
124 			--level;
125 			if (gotos[cbn])
126 				ungoto();
127 			break;
128 	}
129 	/*
130 	 * Free the temporary name list entries defined in
131 	 * expressions, e.g. STRs, and WITHPTRs from withs.
132 	 */
133 	nlfree(snlp);
134 	    /*
135 	     *	free any temporaries allocated for this statement
136 	     *	these come from strings and sets.
137 	     */
138 	tmpfree(&soffset);
139 }
140 
141 ungoto()
142 {
143 	register struct nl *p;
144 
145 	for (p = gotos[cbn]; p != NLNIL; p = p->chain)
146 		if ((p->nl_flags & NFORWD) != 0) {
147 			if (p->value[NL_GOLEV] != NOTYET)
148 				if (p->value[NL_GOLEV] > level)
149 					p->value[NL_GOLEV] = level;
150 		} else
151 			if (p->value[NL_GOLEV] != DEAD)
152 				if (p->value[NL_GOLEV] > level)
153 					p->value[NL_GOLEV] = DEAD;
154 }
155 
156 putcnt()
157 {
158 
159 	if (monflg == FALSE) {
160 		return;
161 	}
162 	inccnt( getcnt() );
163 }
164 
165 int
166 getcnt()
167     {
168 
169 	return ++cnts;
170     }
171 
172 inccnt( counter )
173     int	counter;
174     {
175 
176 #	ifdef OBJ
177 	    (void) put(2, O_COUNT, counter );
178 #	endif OBJ
179 #	ifdef PC
180 	    putRV( PCPCOUNT , 0 , counter * sizeof (long) , NGLOBAL , P2INT );
181 	    putleaf( P2ICON , 1 , 0 , P2INT , (char *) 0 );
182 	    putop( P2ASG P2PLUS , P2INT );
183 	    putdot( filename , line );
184 #	endif PC
185     }
186 
187 putline()
188 {
189 
190 #	ifdef OBJ
191 	    if (opt('p') != 0)
192 		    (void) put(2, O_LINO, line);
193 
194 	    /*
195 	     * put out line number information for pdx
196 	     */
197 	    lineno(line);
198 
199 #	endif OBJ
200 #	ifdef PC
201 	    static lastline;
202 
203 	    if ( line != lastline ) {
204 		stabline( line );
205 		lastline = line;
206 	    }
207 	    if ( opt( 'p' ) ) {
208 		if ( opt('t') ) {
209 		    putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
210 			    , "_LINO" );
211 		    putop( P2UNARY P2CALL , P2INT );
212 		    putdot( filename , line );
213 		} else {
214 		    putRV( STMTCOUNT , 0 , 0 , NGLOBAL , P2INT );
215 		    putleaf( P2ICON , 1 , 0 , P2INT , (char *) 0 );
216 		    putop( P2ASG P2PLUS , P2INT );
217 		    putdot( filename , line );
218 		}
219 	    }
220 #	endif PC
221 }
222 
223 /*
224  * With varlist do stat
225  *
226  * With statement requires an extra word
227  * in automatic storage for each level of withing.
228  * These indirect pointers are initialized here, and
229  * the scoping effect of the with statement occurs
230  * because lookup examines the field names of the records
231  * associated with the WITHPTRs on the withlist.
232  */
233 withop(s)
234 	WITH_NODE *s;
235 {
236 	register struct tnode *p;
237 	register struct nl *r;
238 	struct nl	*tempnlp;
239 	struct nl *swl;
240 
241 	putline();
242 	swl = withlist;
243 	for (p = s->var_list; p != TR_NIL; p = p->list_node.next) {
244 		tempnlp = tmpalloc((long) (sizeof(int *)), nl+TPTR, REGOK);
245 		    /*
246 		     *	no one uses the allocated temporary namelist entry,
247 		     *	since we have to use it before we know its type;
248 		     *	but we use its runtime location for the with pointer.
249 		     */
250 #		ifdef OBJ
251 		    (void) put(2, O_LV | cbn <<8+INDX, tempnlp -> value[ NL_OFFS ] );
252 #		endif OBJ
253 #		ifdef PC
254 		    putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
255 			    tempnlp -> extra_flags , P2PTR|P2STRTY );
256 #		endif PC
257 		r = lvalue(p->list_node.list, MOD , LREQ );
258 		if (r == NLNIL)
259 			continue;
260 		if (r->class != RECORD) {
261 			error("Variable in with statement refers to %s, not to a record", nameof(r));
262 			continue;
263 		}
264 		r = defnl((char *) 0, WITHPTR, r, tempnlp -> value[ NL_OFFS ] );
265 #		ifdef PC
266 		    r -> extra_flags |= tempnlp -> extra_flags;
267 #		endif PC
268 		r->nl_next = withlist;
269 		withlist = r;
270 #		ifdef OBJ
271 		    (void) put(1, PTR_AS);
272 #		endif OBJ
273 #		ifdef PC
274 		    putop( P2ASSIGN , P2PTR|P2STRTY );
275 		    putdot( filename , line );
276 #		endif PC
277 	}
278 	statement(s->stmnt);
279 	withlist = swl;
280 }
281 
282 extern	flagwas;
283 /*
284  * var := expr
285  */
286 asgnop(r)
287 	ASG_NODE *r;
288 {
289 	register struct nl *p;
290 	register struct tnode *av;
291 
292 	/*
293 	 * Asgnop's only function is
294 	 * to handle function variable
295 	 * assignments.  All other assignment
296 	 * stuff is handled by asgnop1.
297 	 * the if below checks for unqualified lefthandside:
298 	 * necessary for fvars.
299 	 */
300 	av = r->lhs_var;
301 	if (av != TR_NIL && av->tag == T_VAR && av->var_node.qual == TR_NIL) {
302 		p = lookup1(av->var_node.cptr);
303 		if (p != NLNIL)
304 			p->nl_flags = flagwas;
305 		if (p != NLNIL && p->class == FVAR) {
306 			/*
307 			 * Give asgnop1 the func
308 			 * which is the chain of
309 			 * the FVAR.
310 			 */
311 			p->nl_flags |= NUSED|NMOD;
312 			p = p->chain;
313 			if (p == NLNIL) {
314 				p = rvalue(r->rhs_expr, NLNIL , RREQ );
315 				return;
316 			}
317 #			ifdef OBJ
318 			    (void) put(2, O_LV | bn << 8+INDX, (int)p->value[NL_OFFS]);
319 			    if (isa(p->type, "i") && width(p->type) == 1)
320 				    (void) asgnop1(r, nl+T2INT);
321 			    else
322 				    (void) asgnop1(r, p->type);
323 #			endif OBJ
324 #			ifdef PC
325 				/*
326 				 * this should be the lvalue of the fvar,
327 				 * but since the second pass knows to use
328 				 * the address of the left operand of an
329 				 * assignment, what i want here is an rvalue.
330 				 * see note in funchdr about fvar allocation.
331 				 */
332 			    p = p -> ptr[ NL_FVAR ];
333 			    putRV( p -> symbol , bn , p -> value[ NL_OFFS ] ,
334 				    p -> extra_flags , p2type( p -> type ) );
335 			    (void) asgnop1( r , p -> type );
336 #			endif PC
337 			return;
338 		}
339 	}
340 	(void) asgnop1(r, NLNIL);
341 }
342 
343 /*
344  * Asgnop1 handles all assignments.
345  * If p is not nil then we are assigning
346  * to a function variable, otherwise
347  * we look the variable up ourselves.
348  */
349 struct nl *
350 asgnop1(r, p)
351 	ASG_NODE *r;
352 	register struct nl *p;
353 {
354 	register struct nl *p1;
355 #ifdef OBJ
356 	int w;
357 #endif
358 
359 	if (p == NLNIL) {
360 #	    ifdef OBJ
361 		p = lvalue(r->lhs_var, MOD|ASGN|NOUSE , LREQ );
362 		w = width(p);
363 #	    endif OBJ
364 #	    ifdef PC
365 		    /*
366 		     * since the second pass knows that it should reference
367 		     * the lefthandside of asignments, what i need here is
368 		     * an rvalue.
369 		     */
370 		p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
371 #	    endif PC
372 	    if ( p == NLNIL ) {
373 		(void) rvalue( r->rhs_expr , NLNIL , RREQ );
374 		return NLNIL;
375 	    }
376 	}
377 #	ifdef OBJ
378 	    /*
379 	     * assigning to the return value, which is at least
380 	     * of width two since it resides on the stack
381 	     */
382 	    else {
383 		w = width(p);
384 		if (w < 2)
385 		    w = 2;
386 	    }
387 	    p1 = rvalue(r->rhs_expr, p , RREQ );
388 #	endif OBJ
389 #	ifdef PC
390 		/*
391 		 *	if this is a scalar assignment,
392 		 *	    then i want to rvalue the righthandside.
393 		 *	if this is a structure assignment,
394 		 *	    then i want an lvalue to the righthandside.
395 		 *  that's what the intermediate form sez.
396 		 */
397 	    switch ( classify( p ) ) {
398 		case TINT:
399 		case TCHAR:
400 		case TBOOL:
401 		case TSCAL:
402 		    precheck( p , "_RANG4" , "_RSNG4" );
403 		case TDOUBLE:
404 		case TPTR:
405 		    p1 = rvalue( r->rhs_expr , p , RREQ );
406 		    break;
407 		default:
408 		    p1 = rvalue( r->rhs_expr , p , LREQ );
409 		    break;
410 	    }
411 #	endif PC
412 	if (p1 == NLNIL)
413 		return (NLNIL);
414 	if (incompat(p1, p, r->rhs_expr)) {
415 		cerror("Type of expression clashed with type of variable in assignment");
416 		return (NLNIL);
417 	}
418 #	ifdef OBJ
419 	    switch (classify(p)) {
420 		    case TINT:
421 		    case TBOOL:
422 		    case TCHAR:
423 		    case TSCAL:
424 			    rangechk(p, p1);
425 			    (void) gen(O_AS2, O_AS2, w, width(p1));
426 			    break;
427 		    case TDOUBLE:
428 		    case TPTR:
429 			    (void) gen(O_AS2, O_AS2, w, width(p1));
430 			    break;
431 		    default:
432 			    (void) put(2, O_AS, w);
433 			    break;
434 	    }
435 #	endif OBJ
436 #	ifdef PC
437 	    switch (classify(p)) {
438 		    case TINT:
439 		    case TBOOL:
440 		    case TCHAR:
441 		    case TSCAL:
442 			    postcheck(p, p1);
443 			    sconv(p2type(p1), p2type(p));
444 			    putop( P2ASSIGN , p2type( p ) );
445 			    putdot( filename , line );
446 			    break;
447 		    case TPTR:
448 			    putop( P2ASSIGN , p2type( p ) );
449 			    putdot( filename , line );
450 			    break;
451 		    case TDOUBLE:
452 			    sconv(p2type(p1), p2type(p));
453 			    putop( P2ASSIGN , p2type( p ) );
454 			    putdot( filename , line );
455 			    break;
456 		    default:
457 			    putstrop(P2STASG, ADDTYPE(p2type(p), P2PTR),
458 					(int) lwidth(p), align(p));
459 			    putdot( filename , line );
460 			    break;
461 	    }
462 #	endif PC
463 	return (p);	/* Used by for statement */
464 }
465 
466 /*
467  * if expr then stat [ else stat ]
468  */
469 ifop(if_n)
470 	IF_NODE *if_n;
471 {
472 	register struct nl *p;
473 	register l1, l2;	/* l1 is start of else, l2 is end of else */
474 	int goc;
475 	bool nr;
476 
477 	goc = gocnt;
478 	putline();
479 	p = rvalue(if_n->cond_expr, NLNIL , RREQ );
480 	if (p == NIL) {
481 		statement(if_n->then_stmnt);
482 		noreach = FALSE;
483 		statement(if_n->else_stmnt);
484 		noreach = FALSE;
485 		return;
486 	}
487 	if (isnta(p, "b")) {
488 		error("Type of expression in if statement must be Boolean, not %s", nameof(p));
489 		statement(if_n->then_stmnt);
490 		noreach = FALSE;
491 		statement(if_n->else_stmnt);
492 		noreach = FALSE;
493 		return;
494 	}
495 #	ifdef OBJ
496 	    l1 = put(2, O_IF, getlab());
497 #	endif OBJ
498 #	ifdef PC
499 	    l1 = (int) getlab();
500 	    putleaf( P2ICON , l1 , 0 , P2INT , (char *) 0 );
501 	    putop( P2CBRANCH , P2INT );
502 	    putdot( filename , line );
503 #	endif PC
504 	putcnt();
505 	statement(if_n->then_stmnt);
506 	nr = noreach;
507 	if (if_n->else_stmnt != TR_NIL) {
508 		/*
509 		 * else stat
510 		 */
511 		--level;
512 		ungoto();
513 		++level;
514 #		ifdef OBJ
515 		    l2 = put(2, O_TRA, getlab());
516 #		endif OBJ
517 #		ifdef PC
518 		    l2 = (int) getlab();
519 		    putjbr( (long) l2 );
520 #		endif PC
521 		patch((PTR_DCL)l1);
522 		noreach = FALSE;
523 		statement(if_n->else_stmnt);
524 		noreach = (noreach && nr)?TRUE:FALSE;
525 		l1 = l2;
526 	} else
527 		noreach = FALSE;
528 	patch((PTR_DCL)l1);
529 	if (goc != gocnt)
530 		putcnt();
531 }
532 
533 /*
534  * while expr do stat
535  */
536 whilop(w_node)
537 	WHI_CAS *w_node;
538 {
539 	register struct nl *p;
540 	register char *l1, *l2;
541 	int goc;
542 
543 	goc = gocnt;
544 	l1 = getlab();
545 	(void) putlab(l1);
546 	putline();
547 	p = rvalue(w_node->expr, NLNIL , RREQ );
548 	if (p == NLNIL) {
549 		statement(w_node->stmnt_list);
550 		noreach = FALSE;
551 		return;
552 	}
553 	if (isnta(p, "b")) {
554 		error("Type of expression in while statement must be Boolean, not %s", nameof(p));
555 		statement(w_node->stmnt_list);
556 		noreach = FALSE;
557 		return;
558 	}
559 	l2 = getlab();
560 #	ifdef OBJ
561 	    (void) put(2, O_IF, l2);
562 #	endif OBJ
563 #	ifdef PC
564 	    putleaf( P2ICON , (int) l2 , 0 , P2INT , (char *) 0 );
565 	    putop( P2CBRANCH , P2INT );
566 	    putdot( filename , line );
567 #	endif PC
568 	putcnt();
569 	statement(w_node->stmnt_list);
570 #	ifdef OBJ
571 	    (void) put(2, O_TRA, l1);
572 #	endif OBJ
573 #	ifdef PC
574 	    putjbr( (long) l1 );
575 #	endif PC
576 	patch((PTR_DCL) l2);
577 	if (goc != gocnt)
578 		putcnt();
579 }
580 
581 /*
582  * repeat stat* until expr
583  */
584 repop(r)
585 	REPEAT *r;
586 {
587 	register struct nl *p;
588 	register l;
589 	int goc;
590 
591 	goc = gocnt;
592 	l = (int) putlab(getlab());
593 	putcnt();
594 	statlist(r->stmnt_list);
595 	line = r->line_no;
596 	p = rvalue(r->term_expr, NLNIL , RREQ );
597 	if (p == NLNIL)
598 		return;
599 	if (isnta(p,"b")) {
600 		error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
601 		return;
602 	}
603 #	ifdef OBJ
604 	    (void) put(2, O_IF, l);
605 #	endif OBJ
606 #	ifdef PC
607 	    putleaf( P2ICON , l , 0 , P2INT , (char *) 0 );
608 	    putop( P2CBRANCH , P2INT );
609 	    putdot( filename , line );
610 #	endif PC
611 	if (goc != gocnt)
612 		putcnt();
613 }
614