xref: /csrg-svn/usr.bin/pascal/src/stat.c (revision 2185)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 static	char sccsid[] = "@(#)stat.c 1.2 01/16/81";
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 	long	soffset;
39 
40 	s = r;
41 	snlp = nlp;
42 	soffset = sizes[ cbn ].om_off;
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 				case T_ASRT:
120 					putline();
121 					asrtop(s);
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 	if ( soffset != sizes[ cbn ].om_off ) {
139 	    sizes[ cbn ].om_off = soffset;
140 #	    ifdef PC
141 		putlbracket( ftnno , -sizes[cbn].om_off );
142 #	    endif PC
143 	}
144 }
145 
146 ungoto()
147 {
148 	register struct nl *p;
149 
150 	for (p = gotos[cbn]; p != NIL; p = p->chain)
151 		if ((p->nl_flags & NFORWD) != 0) {
152 			if (p->value[NL_GOLEV] != NOTYET)
153 				if (p->value[NL_GOLEV] > level)
154 					p->value[NL_GOLEV] = level;
155 		} else
156 			if (p->value[NL_GOLEV] != DEAD)
157 				if (p->value[NL_GOLEV] > level)
158 					p->value[NL_GOLEV] = DEAD;
159 }
160 
161 putcnt()
162 {
163 
164 	if (monflg == 0) {
165 		return;
166 	}
167 	inccnt( getcnt() );
168 }
169 
170 int
171 getcnt()
172     {
173 
174 	return ++cnts;
175     }
176 
177 inccnt( counter )
178     int	counter;
179     {
180 
181 #	ifdef OBJ
182 	    put2(O_COUNT, counter );
183 #	endif OBJ
184 #	ifdef PC
185 	    putRV( PCPCOUNT , 0 , counter * sizeof (long) , P2INT );
186 	    putleaf( P2ICON , 1 , 0 , P2INT , 0 );
187 	    putop( P2ASG P2PLUS , P2INT );
188 	    putdot( filename , line );
189 #	endif PC
190     }
191 
192 putline()
193 {
194 
195 #	ifdef OBJ
196 	    if (opt('p') != 0)
197 		    put2(O_LINO, line);
198 #	endif OBJ
199 #	ifdef PC
200 	    static lastline;
201 
202 	    if ( line != lastline ) {
203 		stabline( line );
204 		lastline = line;
205 	    }
206 	    if ( opt( 'p' ) ) {
207 		if ( opt('t') ) {
208 		    putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR )
209 			    , "_LINO" );
210 		    putop( P2UNARY P2CALL , P2INT );
211 		    putdot( filename , line );
212 		} else {
213 		    putRV( STMTCOUNT , 0 , 0 , P2INT );
214 		    putleaf( P2ICON , 1 , 0 , P2INT , 0 );
215 		    putop( P2ASG P2PLUS , P2INT );
216 		    putdot( filename , line );
217 		}
218 	    }
219 #	endif PC
220 }
221 
222 /*
223  * With varlist do stat
224  *
225  * With statement requires an extra word
226  * in automatic storage for each level of withing.
227  * These indirect pointers are initialized here, and
228  * the scoping effect of the with statement occurs
229  * because lookup examines the field names of the records
230  * associated with the WITHPTRs on the withlist.
231  */
232 withop(s)
233 	int *s;
234 {
235 	register *p;
236 	register struct nl *r;
237 	int i;
238 	int *swl;
239 	long soffset;
240 
241 	putline();
242 	swl = withlist;
243 	soffset = sizes[cbn].om_off;
244 	for (p = s[2]; p != NIL; p = p[2]) {
245 		i = sizes[cbn].om_off -= sizeof ( int * );
246 		if (sizes[cbn].om_off < sizes[cbn].om_max)
247 			sizes[cbn].om_max = sizes[cbn].om_off;
248 #		ifdef OBJ
249 		    put2(O_LV | cbn <<8+INDX, i );
250 #		endif OBJ
251 #		ifdef PC
252 		    putlbracket( ftnno , -sizes[cbn].om_off );
253 		    putRV( 0 , cbn , i , P2PTR|P2STRTY );
254 #		endif PC
255 		r = lvalue(p[1], MOD , LREQ );
256 		if (r == NIL)
257 			continue;
258 		if (r->class != RECORD) {
259 			error("Variable in with statement refers to %s, not to a record", nameof(r));
260 			continue;
261 		}
262 		r = defnl(0, WITHPTR, r, i);
263 		r->nl_next = withlist;
264 		withlist = r;
265 #		ifdef OBJ
266 		    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[3]);
274 	sizes[cbn].om_off = soffset;
275 #	ifdef PC
276 	    putlbracket( ftnno , -sizes[cbn].om_off );
277 #	endif PC
278 	withlist = swl;
279 }
280 
281 extern	flagwas;
282 /*
283  * var := expr
284  */
285 asgnop(r)
286 	int *r;
287 {
288 	register struct nl *p;
289 	register *av;
290 
291 	if (r == NIL)
292 		return (NIL);
293 	/*
294 	 * Asgnop's only function is
295 	 * to handle function variable
296 	 * assignments.  All other assignment
297 	 * stuff is handled by asgnop1.
298 	 * the if below checks for unqualified lefthandside:
299 	 * necessary for fvars.
300 	 */
301 	av = r[2];
302 	if (av != NIL && av[0] == T_VAR && av[3] == NIL) {
303 		p = lookup1(av[2]);
304 		if (p != NIL)
305 			p->nl_flags = flagwas;
306 		if (p != NIL && p->class == FVAR) {
307 			/*
308 			 * Give asgnop1 the func
309 			 * which is the chain of
310 			 * the FVAR.
311 			 */
312 			p->nl_flags |= NUSED|NMOD;
313 			p = p->chain;
314 			if (p == NIL) {
315 				rvalue(r[3], NIL , RREQ );
316 				return;
317 			}
318 #			ifdef OBJ
319 			    put2(O_LV | bn << 8+INDX, p->value[NL_OFFS]);
320 			    if (isa(p->type, "i") && width(p->type) == 1)
321 				    asgnop1(r, nl+T2INT);
322 			    else
323 				    asgnop1(r, p->type);
324 #			endif OBJ
325 #			ifdef PC
326 				/*
327 				 * this should be the lvalue of the fvar,
328 				 * but since the second pass knows to use
329 				 * the address of the left operand of an
330 				 * assignment, what i want here is an rvalue.
331 				 * see note in funchdr about fvar allocation.
332 				 */
333 			    p = p -> ptr[ NL_FVAR ];
334 			    putRV( p -> symbol , bn , p -> value[ NL_OFFS ]
335 					, p2type( p -> type ) );
336 			    asgnop1( r , p -> type );
337 #			endif PC
338 			return;
339 		}
340 	}
341 	asgnop1(r, NIL);
342 }
343 
344 /*
345  * Asgnop1 handles all assignments.
346  * If p is not nil then we are assigning
347  * to a function variable, otherwise
348  * we look the variable up ourselves.
349  */
350 struct nl *
351 asgnop1(r, p)
352 	int *r;
353 	register struct nl *p;
354 {
355 	register struct nl *p1;
356 
357 	if (r == NIL)
358 		return (NIL);
359 	if (p == NIL) {
360 #	    ifdef OBJ
361 		p = lvalue(r[2], MOD|ASGN|NOUSE , LREQ );
362 #	    endif OBJ
363 #	    ifdef PC
364 		    /*
365 		     * since the second pass knows that it should reference
366 		     * the lefthandside of asignments, what i need here is
367 		     * an rvalue.
368 		     */
369 		p = lvalue( r[2] , MOD|ASGN|NOUSE , RREQ );
370 #	    endif PC
371 	    if ( p == NIL ) {
372 		rvalue( r[3] , NIL , RREQ );
373 		return NIL;
374 	    }
375 	}
376 #	ifdef OBJ
377 	    p1 = rvalue(r[3], p , RREQ );
378 #	endif OBJ
379 #	ifdef PC
380 		/*
381 		 *	if this is a scalar assignment,
382 		 *	    then i want to rvalue the righthandside.
383 		 *	if this is a structure assignment,
384 		 *	    then i want an lvalue to the righthandside.
385 		 *  that's what the intermediate form sez.
386 		 */
387 	    switch ( classify( p ) ) {
388 		case TINT:
389 		case TCHAR:
390 		case TBOOL:
391 		case TSCAL:
392 		    precheck( p , "_RANG4" , "_RSNG4" );
393 		case TDOUBLE:
394 		case TPTR:
395 		    p1 = rvalue( r[3] , p , RREQ );
396 		    break;
397 		default:
398 		    p1 = rvalue( r[3] , p , LREQ );
399 		    break;
400 	    }
401 #	endif PC
402 	if (p1 == NIL)
403 		return (NIL);
404 	if (incompat(p1, p, r[3])) {
405 		cerror("Type of expression clashed with type of variable in assignment");
406 		return (NIL);
407 	}
408 	switch (classify(p)) {
409 		case TINT:
410 		case TBOOL:
411 		case TCHAR:
412 		case TSCAL:
413 #			ifdef OBJ
414 			    rangechk(p, p1);
415 #			endif OBJ
416 #			ifdef PC
417 			    postcheck( p );
418 #			endif PC
419 		case TDOUBLE:
420 		case TPTR:
421 #			ifdef OBJ
422 			    gen(O_AS2, O_AS2, width(p), width(p1));
423 #			endif OBJ
424 #			ifdef PC
425 			    putop( P2ASSIGN , p2type( p ) );
426 			    putdot( filename , line );
427 #			endif PC
428 			break;
429 		default:
430 #			ifdef OBJ
431 			    put2(O_AS, width(p));
432 #			endif OBJ
433 #			ifdef PC
434 			    putstrop( P2STASG , p2type( p )
435 					, lwidth( p ) , align( p ) );
436 			    putdot( filename , line );
437 #			endif PC
438 	}
439 	return (p);	/* Used by for statement */
440 }
441 
442 /*
443  * if expr then stat [ else stat ]
444  */
445 ifop(r)
446 	int *r;
447 {
448 	register struct nl *p;
449 	register l1, l2;	/* l1 is start of else, l2 is end of else */
450 	int nr, goc;
451 
452 	goc = gocnt;
453 	if (r == NIL)
454 		return;
455 	putline();
456 	p = rvalue(r[2], NIL , RREQ );
457 	if (p == NIL) {
458 		statement(r[3]);
459 		noreach = 0;
460 		statement(r[4]);
461 		noreach = 0;
462 		return;
463 	}
464 	if (isnta(p, "b")) {
465 		error("Type of expression in if statement must be Boolean, not %s", nameof(p));
466 		statement(r[3]);
467 		noreach = 0;
468 		statement(r[4]);
469 		noreach = 0;
470 		return;
471 	}
472 #	ifdef OBJ
473 	    l1 = put2(O_IF, getlab());
474 #	endif OBJ
475 #	ifdef PC
476 	    l1 = getlab();
477 	    putleaf( P2ICON , l1 , 0 , P2INT , 0 );
478 	    putop( P2CBRANCH , P2INT );
479 	    putdot( filename , line );
480 #	endif PC
481 	putcnt();
482 	statement(r[3]);
483 	nr = noreach;
484 	if (r[4] != NIL) {
485 		/*
486 		 * else stat
487 		 */
488 		--level;
489 		ungoto();
490 		++level;
491 #		ifdef OBJ
492 		    l2 = put2(O_TRA, getlab());
493 #		endif OBJ
494 #		ifdef PC
495 		    l2 = getlab();
496 		    putjbr( l2 );
497 #		endif PC
498 		patch(l1);
499 		noreach = 0;
500 		statement(r[4]);
501 		noreach &= nr;
502 		l1 = l2;
503 	} else
504 		noreach = 0;
505 	patch(l1);
506 	if (goc != gocnt)
507 		putcnt();
508 }
509 
510 /*
511  * while expr do stat
512  */
513 whilop(r)
514 	int *r;
515 {
516 	register struct nl *p;
517 	register l1, l2;
518 	int goc;
519 
520 	goc = gocnt;
521 	if (r == NIL)
522 		return;
523 	putlab(l1 = getlab());
524 	putline();
525 	p = rvalue(r[2], NIL , RREQ );
526 	if (p == NIL) {
527 		statement(r[3]);
528 		noreach = 0;
529 		return;
530 	}
531 	if (isnta(p, "b")) {
532 		error("Type of expression in while statement must be Boolean, not %s", nameof(p));
533 		statement(r[3]);
534 		noreach = 0;
535 		return;
536 	}
537 	l2 = getlab();
538 #	ifdef OBJ
539 	    put2(O_IF, l2);
540 #	endif OBJ
541 #	ifdef PC
542 	    putleaf( P2ICON , l2 , 0 , P2INT , 0 );
543 	    putop( P2CBRANCH , P2INT );
544 	    putdot( filename , line );
545 #	endif PC
546 	putcnt();
547 	statement(r[3]);
548 #	ifdef OBJ
549 	    put2(O_TRA, l1);
550 #	endif OBJ
551 #	ifdef PC
552 	    putjbr( l1 );
553 #	endif PC
554 	patch(l2);
555 	if (goc != gocnt)
556 		putcnt();
557 }
558 
559 /*
560  * repeat stat* until expr
561  */
562 repop(r)
563 	int *r;
564 {
565 	register struct nl *p;
566 	register l;
567 	int goc;
568 
569 	goc = gocnt;
570 	if (r == NIL)
571 		return;
572 	l = putlab(getlab());
573 	putcnt();
574 	statlist(r[2]);
575 	line = r[1];
576 	p = rvalue(r[3], NIL , RREQ );
577 	if (p == NIL)
578 		return;
579 	if (isnta(p,"b")) {
580 		error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
581 		return;
582 	}
583 #	ifdef OBJ
584 	    put2(O_IF, l);
585 #	endif OBJ
586 #	ifdef PC
587 	    putleaf( P2ICON , l , 0 , P2INT , 0 );
588 	    putop( P2CBRANCH , P2INT );
589 	    putdot( filename , line );
590 #	endif PC
591 	if (goc != gocnt)
592 		putcnt();
593 }
594 
595 /*
596  * assert expr
597  */
598 asrtop(r)
599 	register int *r;
600 {
601 	register struct nl *q;
602 
603 	if (opt('s')) {
604 		standard();
605 		error("Assert statement is non-standard");
606 	}
607 	if (!opt('t'))
608 		return;
609 	r = r[2];
610 #	ifdef OBJ
611 	    q = rvalue((int *) r, NLNIL , RREQ );
612 #	endif OBJ
613 #	ifdef PC
614 	    putleaf( P2ICON , 0 , 0
615 		    , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_ASRT" );
616 	    q = stkrval( r , NLNIL , RREQ );
617 #	endif PC
618 	if (q == NIL)
619 		return;
620 	if (isnta(q, "b"))
621 		error("Assert expression must be Boolean, not %ss", nameof(q));
622 #	ifdef OBJ
623 	    put1(O_ASRT);
624 #	endif OBJ
625 #	ifdef PC
626 	    putop( P2CALL , P2INT );
627 	    putdot( filename , line );
628 #	endif PC
629 }
630