xref: /csrg-svn/usr.bin/pascal/src/stat.c (revision 3079)
1 /* Copyright (c) 1979 Regents of the University of California */
2 
3 static char sccsid[] = "@(#)stat.c 1.3 03/08/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 	    put(2, 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 		    put(2, 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 		    put(2, 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 			    put(2, O_LV | bn << 8+INDX, (int)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 	int w;
357 
358 	if (r == NIL)
359 		return (NIL);
360 	if (p == NIL) {
361 #	    ifdef OBJ
362 		p = lvalue(r[2], MOD|ASGN|NOUSE , LREQ );
363 		w = width(p);
364 #	    endif OBJ
365 #	    ifdef PC
366 		    /*
367 		     * since the second pass knows that it should reference
368 		     * the lefthandside of asignments, what i need here is
369 		     * an rvalue.
370 		     */
371 		p = lvalue( r[2] , MOD|ASGN|NOUSE , RREQ );
372 #	    endif PC
373 	    if ( p == NIL ) {
374 		rvalue( r[3] , NIL , RREQ );
375 		return NIL;
376 	    }
377 	}
378 #	ifdef OBJ
379 	    /*
380 	     * assigning to the return value, which is at least
381 	     * of width two since it resides on the stack
382 	     */
383 	    else {
384 		w = width(p);
385 		if (w < 2)
386 		    w = 2;
387 	    }
388 	    p1 = rvalue(r[3], p , RREQ );
389 #	endif OBJ
390 #	ifdef PC
391 		/*
392 		 *	if this is a scalar assignment,
393 		 *	    then i want to rvalue the righthandside.
394 		 *	if this is a structure assignment,
395 		 *	    then i want an lvalue to the righthandside.
396 		 *  that's what the intermediate form sez.
397 		 */
398 	    switch ( classify( p ) ) {
399 		case TINT:
400 		case TCHAR:
401 		case TBOOL:
402 		case TSCAL:
403 		    precheck( p , "_RANG4" , "_RSNG4" );
404 		case TDOUBLE:
405 		case TPTR:
406 		    p1 = rvalue( r[3] , p , RREQ );
407 		    break;
408 		default:
409 		    p1 = rvalue( r[3] , p , LREQ );
410 		    break;
411 	    }
412 #	endif PC
413 	if (p1 == NIL)
414 		return (NIL);
415 	if (incompat(p1, p, r[3])) {
416 		cerror("Type of expression clashed with type of variable in assignment");
417 		return (NIL);
418 	}
419 	switch (classify(p)) {
420 		case TINT:
421 		case TBOOL:
422 		case TCHAR:
423 		case TSCAL:
424 #			ifdef OBJ
425 			    rangechk(p, p1);
426 #			endif OBJ
427 #			ifdef PC
428 			    postcheck( p );
429 #			endif PC
430 		case TDOUBLE:
431 		case TPTR:
432 #			ifdef OBJ
433 			    gen(O_AS2, O_AS2, w, width(p1));
434 #			endif OBJ
435 #			ifdef PC
436 			    putop( P2ASSIGN , p2type( p ) );
437 			    putdot( filename , line );
438 #			endif PC
439 			break;
440 		default:
441 #			ifdef OBJ
442 			    put(2, O_AS, w);
443 #			endif OBJ
444 #			ifdef PC
445 			    putstrop( P2STASG , p2type( p )
446 					, lwidth( p ) , align( p ) );
447 			    putdot( filename , line );
448 #			endif PC
449 	}
450 	return (p);	/* Used by for statement */
451 }
452 
453 /*
454  * if expr then stat [ else stat ]
455  */
456 ifop(r)
457 	int *r;
458 {
459 	register struct nl *p;
460 	register l1, l2;	/* l1 is start of else, l2 is end of else */
461 	int goc;
462 	bool nr;
463 
464 	goc = gocnt;
465 	if (r == NIL)
466 		return;
467 	putline();
468 	p = rvalue(r[2], NIL , RREQ );
469 	if (p == NIL) {
470 		statement(r[3]);
471 		noreach = 0;
472 		statement(r[4]);
473 		noreach = 0;
474 		return;
475 	}
476 	if (isnta(p, "b")) {
477 		error("Type of expression in if statement must be Boolean, not %s", nameof(p));
478 		statement(r[3]);
479 		noreach = 0;
480 		statement(r[4]);
481 		noreach = 0;
482 		return;
483 	}
484 #	ifdef OBJ
485 	    l1 = put(2, O_IF, getlab());
486 #	endif OBJ
487 #	ifdef PC
488 	    l1 = getlab();
489 	    putleaf( P2ICON , l1 , 0 , P2INT , 0 );
490 	    putop( P2CBRANCH , P2INT );
491 	    putdot( filename , line );
492 #	endif PC
493 	putcnt();
494 	statement(r[3]);
495 	nr = noreach;
496 	if (r[4] != NIL) {
497 		/*
498 		 * else stat
499 		 */
500 		--level;
501 		ungoto();
502 		++level;
503 #		ifdef OBJ
504 		    l2 = put(2, O_TRA, getlab());
505 #		endif OBJ
506 #		ifdef PC
507 		    l2 = getlab();
508 		    putjbr( l2 );
509 #		endif PC
510 		patch(l1);
511 		noreach = 0;
512 		statement(r[4]);
513 		noreach = (noreach && nr);
514 		l1 = l2;
515 	} else
516 		noreach = 0;
517 	patch(l1);
518 	if (goc != gocnt)
519 		putcnt();
520 }
521 
522 /*
523  * while expr do stat
524  */
525 whilop(r)
526 	int *r;
527 {
528 	register struct nl *p;
529 	register l1, l2;
530 	int goc;
531 
532 	goc = gocnt;
533 	if (r == NIL)
534 		return;
535 	putlab(l1 = getlab());
536 	putline();
537 	p = rvalue(r[2], NIL , RREQ );
538 	if (p == NIL) {
539 		statement(r[3]);
540 		noreach = 0;
541 		return;
542 	}
543 	if (isnta(p, "b")) {
544 		error("Type of expression in while statement must be Boolean, not %s", nameof(p));
545 		statement(r[3]);
546 		noreach = 0;
547 		return;
548 	}
549 	l2 = getlab();
550 #	ifdef OBJ
551 	    put(2, O_IF, l2);
552 #	endif OBJ
553 #	ifdef PC
554 	    putleaf( P2ICON , l2 , 0 , P2INT , 0 );
555 	    putop( P2CBRANCH , P2INT );
556 	    putdot( filename , line );
557 #	endif PC
558 	putcnt();
559 	statement(r[3]);
560 #	ifdef OBJ
561 	    put(2, O_TRA, l1);
562 #	endif OBJ
563 #	ifdef PC
564 	    putjbr( l1 );
565 #	endif PC
566 	patch(l2);
567 	if (goc != gocnt)
568 		putcnt();
569 }
570 
571 /*
572  * repeat stat* until expr
573  */
574 repop(r)
575 	int *r;
576 {
577 	register struct nl *p;
578 	register l;
579 	int goc;
580 
581 	goc = gocnt;
582 	if (r == NIL)
583 		return;
584 	l = putlab(getlab());
585 	putcnt();
586 	statlist(r[2]);
587 	line = r[1];
588 	p = rvalue(r[3], NIL , RREQ );
589 	if (p == NIL)
590 		return;
591 	if (isnta(p,"b")) {
592 		error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
593 		return;
594 	}
595 #	ifdef OBJ
596 	    put(2, O_IF, l);
597 #	endif OBJ
598 #	ifdef PC
599 	    putleaf( P2ICON , l , 0 , P2INT , 0 );
600 	    putop( P2CBRANCH , P2INT );
601 	    putdot( filename , line );
602 #	endif PC
603 	if (goc != gocnt)
604 		putcnt();
605 }
606 
607 /*
608  * assert expr
609  */
610 asrtop(r)
611 	register int *r;
612 {
613 	register struct nl *q;
614 
615 	if (opt('s')) {
616 		standard();
617 		error("Assert statement is non-standard");
618 	}
619 	if (!opt('t'))
620 		return;
621 	r = r[2];
622 #	ifdef OBJ
623 	    q = rvalue((int *) r, NLNIL , RREQ );
624 #	endif OBJ
625 #	ifdef PC
626 	    putleaf( P2ICON , 0 , 0
627 		    , ADDTYPE( P2FTN | P2INT , P2PTR ) , "_ASRT" );
628 	    q = stkrval( r , NLNIL , RREQ );
629 #	endif PC
630 	if (q == NIL)
631 		return;
632 	if (isnta(q, "b"))
633 		error("Assert expression must be Boolean, not %ss", nameof(q));
634 #	ifdef OBJ
635 	    put(1, O_ASRT);
636 #	endif OBJ
637 #	ifdef PC
638 	    putop( P2CALL , P2INT );
639 	    putdot( filename , line );
640 #	endif PC
641 }
642