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