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