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