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