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