xref: /csrg-svn/usr.bin/pascal/src/stat.c (revision 15941)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 #ifndef lint
4 static char sccsid[] = "@(#)stat.c 1.11.1.1 02/04/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 *)), INT_TYP, REGOK);
245 #		ifdef OBJ
246 		    (void) put(2, O_LV | cbn <<8+INDX, tempnlp -> value[ NL_OFFS ] );
247 #		endif OBJ
248 #		ifdef PC
249 		    putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
250 			    tempnlp -> extra_flags , P2PTR|P2STRTY );
251 #		endif PC
252 		r = lvalue(p->list_node.list, MOD , LREQ );
253 		if (r == NLNIL)
254 			continue;
255 		if (r->class != RECORD) {
256 			error("Variable in with statement refers to %s, not to a record", nameof(r));
257 			continue;
258 		}
259 		r = defnl((char *) 0, WITHPTR, r, tempnlp -> value[ NL_OFFS ] );
260 #		ifdef PC
261 		    r -> extra_flags |= tempnlp -> extra_flags;
262 #		endif PC
263 		r->nl_next = withlist;
264 		withlist = r;
265 #		ifdef OBJ
266 		    (void) put(1, PTR_AS);
267 #		endif OBJ
268 #		ifdef PC
269 		    putop( P2ASSIGN , P2PTR|P2STRTY );
270 		    putdot( filename , line );
271 #		endif PC
272 	}
273 	statement(s->stmnt);
274 	withlist = swl;
275 }
276 
277 extern	flagwas;
278 /*
279  * var := expr
280  */
281 asgnop(r)
282 	ASG_NODE *r;
283 {
284 	register struct nl *p;
285 	register struct tnode *av;
286 
287 	/*
288 	 * Asgnop's only function is
289 	 * to handle function variable
290 	 * assignments.  All other assignment
291 	 * stuff is handled by asgnop1.
292 	 * the if below checks for unqualified lefthandside:
293 	 * necessary for fvars.
294 	 */
295 	av = r->lhs_var;
296 	if (av != TR_NIL && av->tag == T_VAR && av->var_node.qual == TR_NIL) {
297 		p = lookup1(av->var_node.cptr);
298 		if (p != NLNIL)
299 			p->nl_flags = flagwas;
300 		if (p != NLNIL && p->class == FVAR) {
301 			/*
302 			 * Give asgnop1 the func
303 			 * which is the chain of
304 			 * the FVAR.
305 			 */
306 			p->nl_flags |= NUSED|NMOD;
307 			p = p->chain;
308 			if (p == NLNIL) {
309 				p = rvalue(r->rhs_expr, NLNIL , RREQ );
310 				return;
311 			}
312 #			ifdef OBJ
313 			    (void) put(2, O_LV | bn << 8+INDX, (int)p->value[NL_OFFS]);
314 			    if (isa(p->type, "i") && width(p->type) == 1)
315 				    (void) asgnop1(r, nl+T2INT);
316 			    else
317 				    (void) asgnop1(r, p->type);
318 #			endif OBJ
319 #			ifdef PC
320 				/*
321 				 * this should be the lvalue of the fvar,
322 				 * but since the second pass knows to use
323 				 * the address of the left operand of an
324 				 * assignment, what i want here is an rvalue.
325 				 * see note in funchdr about fvar allocation.
326 				 */
327 			    p = p -> ptr[ NL_FVAR ];
328 			    putRV( p -> symbol , bn , p -> value[ NL_OFFS ] ,
329 				    p -> extra_flags , p2type( p -> type ) );
330 			    (void) asgnop1( r , p -> type );
331 #			endif PC
332 			return;
333 		}
334 	}
335 	(void) asgnop1(r, NLNIL);
336 }
337 
338 /*
339  * Asgnop1 handles all assignments.
340  * If p is not nil then we are assigning
341  * to a function variable, otherwise
342  * we look the variable up ourselves.
343  */
344 struct nl *
345 asgnop1(r, p)
346 	ASG_NODE *r;
347 	register struct nl *p;
348 {
349 	register struct nl *p1;
350 #ifdef OBJ
351 	int w;
352 #endif
353 
354 	if (p == NLNIL) {
355 #	    ifdef OBJ
356 		p = lvalue(r->lhs_var, MOD|ASGN|NOUSE , LREQ );
357 		w = width(p);
358 #	    endif OBJ
359 #	    ifdef PC
360 		    /*
361 		     * since the second pass knows that it should reference
362 		     * the lefthandside of asignments, what i need here is
363 		     * an rvalue.
364 		     */
365 		p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
366 #	    endif PC
367 	    if ( p == NLNIL ) {
368 		(void) rvalue( r->rhs_expr , NLNIL , RREQ );
369 		return NLNIL;
370 	    }
371 	}
372 #	ifdef OBJ
373 	    /*
374 	     * assigning to the return value, which is at least
375 	     * of width two since it resides on the stack
376 	     */
377 	    else {
378 		w = width(p);
379 		if (w < 2)
380 		    w = 2;
381 	    }
382 	    p1 = rvalue(r->rhs_expr, p , RREQ );
383 #	endif OBJ
384 #	ifdef PC
385 		/*
386 		 *	if this is a scalar assignment,
387 		 *	    then i want to rvalue the righthandside.
388 		 *	if this is a structure assignment,
389 		 *	    then i want an lvalue to the righthandside.
390 		 *  that's what the intermediate form sez.
391 		 */
392 	    switch ( classify( p ) ) {
393 		case TINT:
394 		case TCHAR:
395 		case TBOOL:
396 		case TSCAL:
397 		    precheck( p , "_RANG4" , "_RSNG4" );
398 		case TDOUBLE:
399 		case TPTR:
400 		    p1 = rvalue( r->rhs_expr , p , RREQ );
401 		    break;
402 		default:
403 		    p1 = rvalue( r->rhs_expr , p , LREQ );
404 		    break;
405 	    }
406 #	endif PC
407 	if (p1 == NLNIL)
408 		return (NLNIL);
409 	if (incompat(p1, p, r->rhs_expr)) {
410 		cerror("Type of expression clashed with type of variable in assignment");
411 		return (NLNIL);
412 	}
413 #	ifdef OBJ
414 	    switch (classify(p)) {
415 		    case TINT:
416 		    case TBOOL:
417 		    case TCHAR:
418 		    case TSCAL:
419 			    rangechk(p, p1);
420 			    (void) gen(O_AS2, O_AS2, w, width(p1));
421 			    break;
422 		    case TDOUBLE:
423 		    case TPTR:
424 			    (void) gen(O_AS2, O_AS2, w, width(p1));
425 			    break;
426 		    default:
427 			    (void) put(2, O_AS, w);
428 			    break;
429 	    }
430 #	endif OBJ
431 #	ifdef PC
432 	    switch (classify(p)) {
433 		    case TINT:
434 		    case TBOOL:
435 		    case TCHAR:
436 		    case TSCAL:
437 			    postcheck(p, p1);
438 			    sconv(p2type(p1), p2type(p));
439 			    putop( P2ASSIGN , p2type( p ) );
440 			    putdot( filename , line );
441 			    break;
442 		    case TPTR:
443 			    putop( P2ASSIGN , p2type( p ) );
444 			    putdot( filename , line );
445 			    break;
446 		    case TDOUBLE:
447 			    sconv(p2type(p1), p2type(p));
448 			    putop( P2ASSIGN , p2type( p ) );
449 			    putdot( filename , line );
450 			    break;
451 		    default:
452 			    putstrop(P2STASG, ADDTYPE(p2type(p), P2PTR),
453 					(int) lwidth(p), align(p));
454 			    putdot( filename , line );
455 			    break;
456 	    }
457 #	endif PC
458 	return (p);	/* Used by for statement */
459 }
460 
461 /*
462  * if expr then stat [ else stat ]
463  */
464 ifop(if_n)
465 	IF_NODE *if_n;
466 {
467 	register struct nl *p;
468 	register l1, l2;	/* l1 is start of else, l2 is end of else */
469 	int goc;
470 	bool nr;
471 
472 	goc = gocnt;
473 	putline();
474 	p = rvalue(if_n->cond_expr, NLNIL , RREQ );
475 	if (p == NIL) {
476 		statement(if_n->then_stmnt);
477 		noreach = FALSE;
478 		statement(if_n->else_stmnt);
479 		noreach = FALSE;
480 		return;
481 	}
482 	if (isnta(p, "b")) {
483 		error("Type of expression in if statement must be Boolean, not %s", nameof(p));
484 		statement(if_n->then_stmnt);
485 		noreach = FALSE;
486 		statement(if_n->else_stmnt);
487 		noreach = FALSE;
488 		return;
489 	}
490 #	ifdef OBJ
491 	    l1 = put(2, O_IF, getlab());
492 #	endif OBJ
493 #	ifdef PC
494 	    l1 = (int) getlab();
495 	    putleaf( P2ICON , l1 , 0 , P2INT , (char *) 0 );
496 	    putop( P2CBRANCH , P2INT );
497 	    putdot( filename , line );
498 #	endif PC
499 	putcnt();
500 	statement(if_n->then_stmnt);
501 	nr = noreach;
502 	if (if_n->else_stmnt != TR_NIL) {
503 		/*
504 		 * else stat
505 		 */
506 		--level;
507 		ungoto();
508 		++level;
509 #		ifdef OBJ
510 		    l2 = put(2, O_TRA, getlab());
511 #		endif OBJ
512 #		ifdef PC
513 		    l2 = (int) getlab();
514 		    putjbr( (long) l2 );
515 #		endif PC
516 		patch((PTR_DCL)l1);
517 		noreach = FALSE;
518 		statement(if_n->else_stmnt);
519 		noreach = (noreach && nr)?TRUE:FALSE;
520 		l1 = l2;
521 	} else
522 		noreach = FALSE;
523 	patch((PTR_DCL)l1);
524 	if (goc != gocnt)
525 		putcnt();
526 }
527 
528 /*
529  * while expr do stat
530  */
531 whilop(w_node)
532 	WHI_CAS *w_node;
533 {
534 	register struct nl *p;
535 	register char *l1, *l2;
536 	int goc;
537 
538 	goc = gocnt;
539 	l1 = getlab();
540 	(void) putlab(l1);
541 	putline();
542 	p = rvalue(w_node->expr, NLNIL , RREQ );
543 	if (p == NLNIL) {
544 		statement(w_node->stmnt_list);
545 		noreach = FALSE;
546 		return;
547 	}
548 	if (isnta(p, "b")) {
549 		error("Type of expression in while statement must be Boolean, not %s", nameof(p));
550 		statement(w_node->stmnt_list);
551 		noreach = FALSE;
552 		return;
553 	}
554 	l2 = getlab();
555 #	ifdef OBJ
556 	    (void) put(2, O_IF, l2);
557 #	endif OBJ
558 #	ifdef PC
559 	    putleaf( P2ICON , (int) l2 , 0 , P2INT , (char *) 0 );
560 	    putop( P2CBRANCH , P2INT );
561 	    putdot( filename , line );
562 #	endif PC
563 	putcnt();
564 	statement(w_node->stmnt_list);
565 #	ifdef OBJ
566 	    (void) put(2, O_TRA, l1);
567 #	endif OBJ
568 #	ifdef PC
569 	    putjbr( (long) l1 );
570 #	endif PC
571 	patch((PTR_DCL) l2);
572 	if (goc != gocnt)
573 		putcnt();
574 }
575 
576 /*
577  * repeat stat* until expr
578  */
579 repop(r)
580 	REPEAT *r;
581 {
582 	register struct nl *p;
583 	register l;
584 	int goc;
585 
586 	goc = gocnt;
587 	l = (int) putlab(getlab());
588 	putcnt();
589 	statlist(r->stmnt_list);
590 	line = r->line_no;
591 	p = rvalue(r->term_expr, NLNIL , RREQ );
592 	if (p == NLNIL)
593 		return;
594 	if (isnta(p,"b")) {
595 		error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
596 		return;
597 	}
598 #	ifdef OBJ
599 	    (void) put(2, O_IF, l);
600 #	endif OBJ
601 #	ifdef PC
602 	    putleaf( P2ICON , l , 0 , P2INT , (char *) 0 );
603 	    putop( P2CBRANCH , P2INT );
604 	    putdot( filename , line );
605 #	endif PC
606 	if (goc != gocnt)
607 		putcnt();
608 }
609