xref: /csrg-svn/usr.bin/pascal/src/stat.c (revision 22192)
1 /*
2  * Copyright (c) 1980 Regents of the University of California.
3  * All rights reserved.  The Berkeley software License Agreement
4  * specifies the terms and conditions for redistribution.
5  */
6 
7 #ifndef lint
8 static char sccsid[] = "@(#)stat.c	5.1 (Berkeley) 06/05/85";
9 #endif not lint
10 
11 #include "whoami.h"
12 #include "0.h"
13 #include "tree.h"
14 #include "objfmt.h"
15 #ifdef PC
16 #   include <pcc.h>
17 #   include "pc.h"
18 #endif PC
19 #include "tmps.h"
20 
21 int cntstat;
22 short cnts = 3;
23 #include "opcode.h"
24 #include "tree_ty.h"
25 
26 /*
27  * Statement list
28  */
29 statlist(r)
30 	struct tnode *r;
31 {
32 	register struct tnode *sl;
33 
34 	for (sl=r; sl != TR_NIL; sl=sl->list_node.next)
35 		statement(sl->list_node.list);
36 }
37 
38 /*
39  * Statement
40  */
41 statement(r)
42 	struct tnode *r;
43 {
44 	register struct tnode *tree_node;
45 	register struct nl *snlp;
46 	struct tmps soffset;
47 
48 	tree_node = r;
49 	snlp = nlp;
50 	soffset = sizes[cbn].curtmps;
51 top:
52 	if (cntstat) {
53 		cntstat = 0;
54 		putcnt();
55 	}
56 	if (tree_node == TR_NIL)
57 		return;
58 	line = tree_node->lined.line_no;
59 	if (tree_node->tag == T_LABEL) {
60 		labeled(tree_node->label_node.lbl_ptr);
61 		tree_node = tree_node->label_node.stmnt;
62 		noreach = FALSE;
63 		cntstat = 1;
64 		goto top;
65 	}
66 	if (noreach) {
67 		noreach = FALSE;
68 		warning();
69 		error("Unreachable statement");
70 	}
71 	switch (tree_node->tag) {
72 		case T_PCALL:
73 			putline();
74 #			ifdef OBJ
75 			    proc(tree_node);
76 #			endif OBJ
77 #			ifdef PC
78 			    pcproc( tree_node );
79 #			endif PC
80 			break;
81 		case T_ASGN:
82 			putline();
83 			asgnop(&(tree_node->asg_node));
84 			break;
85 		case T_GOTO:
86 			putline();
87 			gotoop(tree_node->goto_node.lbl_ptr);
88 			noreach = TRUE;
89 			cntstat = 1;
90 			break;
91 		default:
92 			level++;
93 			switch (tree_node->tag) {
94 				default:
95 					panic("stat");
96 				case T_IF:
97 				case T_IFEL:
98 					ifop(&(tree_node->if_node));
99 					break;
100 				case T_WHILE:
101 					whilop(&(tree_node->whi_cas));
102 					noreach = FALSE;
103 					break;
104 				case T_REPEAT:
105 					repop(&(tree_node->repeat));
106 					break;
107 				case T_FORU:
108 				case T_FORD:
109 				        forop(tree_node);
110 					noreach = FALSE;
111 					break;
112 				case T_BLOCK:
113 					statlist(tree_node->stmnt_blck.stmnt_list);
114 					break;
115 				case T_CASE:
116 					putline();
117 #					ifdef OBJ
118 					    caseop(&(tree_node->whi_cas));
119 #					endif OBJ
120 #					ifdef PC
121 					    pccaseop(&(tree_node->whi_cas));
122 #					endif PC
123 					break;
124 				case T_WITH:
125 					withop(&(tree_node->with_node));
126 					break;
127 			}
128 			--level;
129 			if (gotos[cbn])
130 				ungoto();
131 			break;
132 	}
133 	/*
134 	 * Free the temporary name list entries defined in
135 	 * expressions, e.g. STRs, and WITHPTRs from withs.
136 	 */
137 	nlfree(snlp);
138 	    /*
139 	     *	free any temporaries allocated for this statement
140 	     *	these come from strings and sets.
141 	     */
142 	tmpfree(&soffset);
143 }
144 
145 ungoto()
146 {
147 	register struct nl *p;
148 
149 	for (p = gotos[cbn]; p != NLNIL; p = p->chain)
150 		if ((p->nl_flags & NFORWD) != 0) {
151 			if (p->value[NL_GOLEV] != NOTYET)
152 				if (p->value[NL_GOLEV] > level)
153 					p->value[NL_GOLEV] = level;
154 		} else
155 			if (p->value[NL_GOLEV] != DEAD)
156 				if (p->value[NL_GOLEV] > level)
157 					p->value[NL_GOLEV] = DEAD;
158 }
159 
160 putcnt()
161 {
162 
163 	if (monflg == FALSE) {
164 		return;
165 	}
166 	inccnt( getcnt() );
167 }
168 
169 int
170 getcnt()
171     {
172 
173 	return ++cnts;
174     }
175 
176 inccnt( counter )
177     int	counter;
178     {
179 
180 #	ifdef OBJ
181 	    (void) put(2, O_COUNT, counter );
182 #	endif OBJ
183 #	ifdef PC
184 	    putRV( PCPCOUNT , 0 , counter * sizeof (long) , NGLOBAL , PCCT_INT );
185 	    putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
186 	    putop( PCCOM_ASG PCC_PLUS , PCCT_INT );
187 	    putdot( filename , line );
188 #	endif PC
189     }
190 
191 putline()
192 {
193 
194 #	ifdef OBJ
195 	    if (opt('p') != 0)
196 		    (void) put(2, O_LINO, line);
197 
198 	    /*
199 	     * put out line number information for pdx
200 	     */
201 	    lineno(line);
202 
203 #	endif OBJ
204 #	ifdef PC
205 	    static lastline;
206 
207 	    if ( line != lastline ) {
208 		stabline( line );
209 		lastline = line;
210 	    }
211 	    if ( opt( 'p' ) ) {
212 		if ( opt('t') ) {
213 		    putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
214 			    , "_LINO" );
215 		    putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
216 		    putdot( filename , line );
217 		} else {
218 		    putRV( STMTCOUNT , 0 , 0 , NGLOBAL , PCCT_INT );
219 		    putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
220 		    putop( PCCOM_ASG PCC_PLUS , PCCT_INT );
221 		    putdot( filename , line );
222 		}
223 	    }
224 #	endif PC
225 }
226 
227 /*
228  * With varlist do stat
229  *
230  * With statement requires an extra word
231  * in automatic storage for each level of withing.
232  * These indirect pointers are initialized here, and
233  * the scoping effect of the with statement occurs
234  * because lookup examines the field names of the records
235  * associated with the WITHPTRs on the withlist.
236  */
237 withop(s)
238 	WITH_NODE *s;
239 {
240 	register struct tnode *p;
241 	register struct nl *r;
242 	struct nl	*tempnlp;
243 	struct nl *swl;
244 
245 	putline();
246 	swl = withlist;
247 	for (p = s->var_list; p != TR_NIL; p = p->list_node.next) {
248 		tempnlp = tmpalloc((long) (sizeof(int *)), nl+TPTR, REGOK);
249 		    /*
250 		     *	no one uses the allocated temporary namelist entry,
251 		     *	since we have to use it before we know its type;
252 		     *	but we use its runtime location for the with pointer.
253 		     */
254 #		ifdef OBJ
255 		    (void) put(2, O_LV | cbn <<8+INDX, tempnlp -> value[ NL_OFFS ] );
256 #		endif OBJ
257 #		ifdef PC
258 		    putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
259 			    tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
260 #		endif PC
261 		r = lvalue(p->list_node.list, MOD , LREQ );
262 		if (r == NLNIL)
263 			continue;
264 		if (r->class != RECORD) {
265 			error("Variable in with statement refers to %s, not to a record", nameof(r));
266 			continue;
267 		}
268 		r = defnl((char *) 0, WITHPTR, r, tempnlp -> value[ NL_OFFS ] );
269 #		ifdef PC
270 		    r -> extra_flags |= tempnlp -> extra_flags;
271 #		endif PC
272 		r->nl_next = withlist;
273 		withlist = r;
274 #		ifdef OBJ
275 		    (void) put(1, PTR_AS);
276 #		endif OBJ
277 #		ifdef PC
278 		    putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
279 		    putdot( filename , line );
280 #		endif PC
281 	}
282 	statement(s->stmnt);
283 	withlist = swl;
284 }
285 
286 extern	flagwas;
287 /*
288  * var := expr
289  */
290 asgnop(r)
291 	ASG_NODE *r;
292 {
293 	register struct nl *p;
294 	register struct tnode *av;
295 
296 	/*
297 	 * Asgnop's only function is
298 	 * to handle function variable
299 	 * assignments.  All other assignment
300 	 * stuff is handled by asgnop1.
301 	 * the if below checks for unqualified lefthandside:
302 	 * necessary for fvars.
303 	 */
304 	av = r->lhs_var;
305 	if (av != TR_NIL && av->tag == T_VAR && av->var_node.qual == TR_NIL) {
306 		p = lookup1(av->var_node.cptr);
307 		if (p != NLNIL)
308 			p->nl_flags = flagwas;
309 		if (p != NLNIL && p->class == FVAR) {
310 			/*
311 			 * Give asgnop1 the func
312 			 * which is the chain of
313 			 * the FVAR.
314 			 */
315 			p->nl_flags |= NUSED|NMOD;
316 			p = p->chain;
317 			if (p == NLNIL) {
318 				p = rvalue(r->rhs_expr, NLNIL , RREQ );
319 				return;
320 			}
321 #			ifdef OBJ
322 			    (void) put(2, O_LV | bn << 8+INDX, (int)p->value[NL_OFFS]);
323 			    if (isa(p->type, "i") && width(p->type) == 1)
324 				    (void) asgnop1(r, nl+T2INT);
325 			    else
326 				    (void) asgnop1(r, p->type);
327 #			endif OBJ
328 #			ifdef PC
329 				/*
330 				 * this should be the lvalue of the fvar,
331 				 * but since the second pass knows to use
332 				 * the address of the left operand of an
333 				 * assignment, what i want here is an rvalue.
334 				 * see note in funchdr about fvar allocation.
335 				 */
336 			    p = p -> ptr[ NL_FVAR ];
337 			    putRV( p -> symbol , bn , p -> value[ NL_OFFS ] ,
338 				    p -> extra_flags , p2type( p -> type ) );
339 			    (void) asgnop1( r , p -> type );
340 #			endif PC
341 			return;
342 		}
343 	}
344 	(void) asgnop1(r, NLNIL);
345 }
346 
347 /*
348  * Asgnop1 handles all assignments.
349  * If p is not nil then we are assigning
350  * to a function variable, otherwise
351  * we look the variable up ourselves.
352  */
353 struct nl *
354 asgnop1(r, p)
355 	ASG_NODE *r;
356 	register struct nl *p;
357 {
358 	register struct nl *p1;
359 	int	clas;
360 #ifdef OBJ
361 	int w;
362 #endif OBJ
363 
364 #ifdef OBJ
365 	if (p == NLNIL) {
366 	    p = lvalue(r->lhs_var, MOD|ASGN|NOUSE , LREQ );
367 	    if ( p == NLNIL ) {
368 		(void) rvalue( r->rhs_expr , NLNIL , RREQ );
369 		return NLNIL;
370 	    }
371 	    w = width(p);
372 	} else {
373 	    /*
374 	     * assigning to the return value, which is at least
375 	     * of width two since it resides on the stack
376 	     */
377 	    w = width(p);
378 	    if (w < 2)
379 		w = 2;
380 	}
381 	clas = classify(p);
382 	if ((clas == TARY || clas == TSTR) && p->chain->class == CRANGE) {
383 	    p1 = lvalue(r->rhs_expr, p , LREQ ); /* SHOULD THIS BE rvalue? */
384 	} else {
385 	    p1 = rvalue(r->rhs_expr, p , RREQ );
386 	}
387 #   endif OBJ
388 #   ifdef PC
389 	if (p == NLNIL) {
390 	    /* check for conformant array type */
391 	    codeoff();
392 	    p = rvalue(r->lhs_var, MOD|ASGN|NOUSE, LREQ);
393 	    codeon();
394 	    if (p == NLNIL) {
395 		(void) rvalue(r->rhs_expr, NLNIL, RREQ);
396 		return NLNIL;
397 	    }
398 	    clas = classify(p);
399 	    if ((clas == TARY || clas == TSTR) && p->chain->class == CRANGE) {
400 		return pcasgconf(r, p);
401 	    } else {
402 		/*
403 		 * since the second pass knows that it should reference
404 		 * the lefthandside of asignments, what i need here is
405 		 * an rvalue.
406 		 */
407 		p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
408 	    }
409 	    if ( p == NLNIL ) {
410 		(void) rvalue( r->rhs_expr , NLNIL , RREQ );
411 		return NLNIL;
412 	    }
413 	}
414 	    /*
415 	     *	if this is a scalar assignment,
416 	     *	    then i want to rvalue the righthandside.
417 	     *	if this is a structure assignment,
418 	     *	    then i want an lvalue to the righthandside.
419 	     *  that's what the intermediate form sez.
420 	     */
421 	switch ( classify( p ) ) {
422 	    case TINT:
423 	    case TCHAR:
424 	    case TBOOL:
425 	    case TSCAL:
426 		precheck( p , "_RANG4" , "_RSNG4" );
427 		/* and fall through */
428 	    case TDOUBLE:
429 	    case TPTR:
430 		p1 = rvalue( r->rhs_expr , p , RREQ );
431 		break;
432 	    default:
433 		p1 = rvalue( r->rhs_expr , p , LREQ );
434 		break;
435 	}
436 #	endif PC
437 	if (p1 == NLNIL)
438 		return (NLNIL);
439 	if (incompat(p1, p, r->rhs_expr)) {
440 		cerror("Type of expression clashed with type of variable in assignment");
441 		return (NLNIL);
442 	}
443 #	ifdef OBJ
444 	    switch (classify(p)) {
445 		    case TINT:
446 		    case TBOOL:
447 		    case TCHAR:
448 		    case TSCAL:
449 			    rangechk(p, p1);
450 			    (void) gen(O_AS2, O_AS2, w, width(p1));
451 			    break;
452 		    case TDOUBLE:
453 		    case TPTR:
454 			    (void) gen(O_AS2, O_AS2, w, width(p1));
455 			    break;
456 		    case TARY:
457 		    case TSTR:
458 			    if (p->chain->class == CRANGE) {
459 				/* conformant array assignment */
460 				p1 = p->chain;
461 				w = width(p1->type);
462 				putcbnds(p1, 1);
463 				putcbnds(p1, 0);
464 				gen(NIL, T_SUB, w, w);
465 				put(2, w > 2? O_CON24: O_CON2, 1);
466 				gen(NIL, T_ADD, w, w);
467 				putcbnds(p1, 2);
468 				gen(NIL, T_MULT, w, w);
469 				put(1, O_VAS);
470 				break;
471 			    }
472 			    /* else fall through */
473 		    default:
474 			    (void) put(2, O_AS, w);
475 			    break;
476 	    }
477 #	endif OBJ
478 #	ifdef PC
479 	    switch (classify(p)) {
480 		    case TINT:
481 		    case TBOOL:
482 		    case TCHAR:
483 		    case TSCAL:
484 			    postcheck(p, p1);
485 			    sconv(p2type(p1), p2type(p));
486 			    putop( PCC_ASSIGN , p2type( p ) );
487 			    putdot( filename , line );
488 			    break;
489 		    case TPTR:
490 			    putop( PCC_ASSIGN , p2type( p ) );
491 			    putdot( filename , line );
492 			    break;
493 		    case TDOUBLE:
494 			    sconv(p2type(p1), p2type(p));
495 			    putop( PCC_ASSIGN , p2type( p ) );
496 			    putdot( filename , line );
497 			    break;
498 		    default:
499 			    putstrop(PCC_STASG, PCCM_ADDTYPE(p2type(p), PCCTM_PTR),
500 					(int) lwidth(p), align(p));
501 			    putdot( filename , line );
502 			    break;
503 	    }
504 #	endif PC
505 	return (p);	/* Used by for statement */
506 }
507 
508 #ifdef PC
509 /*
510  * assignment to conformant arrays.  Since these are variable length,
511  *	we use blkcpy() to perform the assignment.
512  *	blkcpy(rhs, lhs, (upper - lower + 1) * width)
513  */
514 struct nl *
515 pcasgconf(r, p)
516 	register ASG_NODE *r;
517 	struct nl *p;
518 {
519 	struct nl *p1;
520 
521 	if (r == (ASG_NODE *) TR_NIL || p == NLNIL)
522 		return NLNIL;
523 	putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR) , "_blkcpy" );
524 	p1 = rvalue( r->rhs_expr , p , LREQ );
525 	if (p1 == NLNIL)
526 		return NLNIL;
527 	p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , LREQ );
528 	if (p == NLNIL)
529 		return NLNIL;
530 	putop(PCC_CM, PCCT_INT);
531 		/* upper bound */
532 	p1 = p->chain->nptr[1];
533 	putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
534 	    p1->extra_flags, p2type( p1 ) );
535 		/* minus lower bound */
536 	p1 = p->chain->nptr[0];
537 	putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
538 	    p1->extra_flags, p2type( p1 ) );
539 	putop( PCC_MINUS, PCCT_INT );
540 		/* add one */
541 	putleaf(PCC_ICON, 1, 0, PCCT_INT, 0);
542 	putop( PCC_PLUS, PCCT_INT );
543 		/* and multiply by the width */
544 	p1 = p->chain->nptr[2];
545 	putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
546 	    p1->extra_flags, p2type( p1 ) );
547 	putop( PCC_MUL , PCCT_INT );
548 	putop(PCC_CM, PCCT_INT);
549 	putop(PCC_CALL, PCCT_INT);
550 	putdot( filename , line);
551 	return p;
552 }
553 #endif PC
554 
555 /*
556  * if expr then stat [ else stat ]
557  */
558 ifop(if_n)
559 	IF_NODE *if_n;
560 {
561 	register struct nl *p;
562 	register l1, l2;	/* l1 is start of else, l2 is end of else */
563 	int goc;
564 	bool nr;
565 
566 	goc = gocnt;
567 	putline();
568 	p = rvalue(if_n->cond_expr, NLNIL , RREQ );
569 	if (p == NIL) {
570 		statement(if_n->then_stmnt);
571 		noreach = FALSE;
572 		statement(if_n->else_stmnt);
573 		noreach = FALSE;
574 		return;
575 	}
576 	if (isnta(p, "b")) {
577 		error("Type of expression in if statement must be Boolean, not %s", nameof(p));
578 		statement(if_n->then_stmnt);
579 		noreach = FALSE;
580 		statement(if_n->else_stmnt);
581 		noreach = FALSE;
582 		return;
583 	}
584 #	ifdef OBJ
585 	    l1 = put(2, O_IF, getlab());
586 #	endif OBJ
587 #	ifdef PC
588 	    l1 = (int) getlab();
589 	    putleaf( PCC_ICON , l1 , 0 , PCCT_INT , (char *) 0 );
590 	    putop( PCC_CBRANCH , PCCT_INT );
591 	    putdot( filename , line );
592 #	endif PC
593 	putcnt();
594 	statement(if_n->then_stmnt);
595 	nr = noreach;
596 	if (if_n->else_stmnt != TR_NIL) {
597 		/*
598 		 * else stat
599 		 */
600 		--level;
601 		ungoto();
602 		++level;
603 #		ifdef OBJ
604 		    l2 = put(2, O_TRA, getlab());
605 #		endif OBJ
606 #		ifdef PC
607 		    l2 = (int) getlab();
608 		    putjbr( (long) l2 );
609 #		endif PC
610 		patch((PTR_DCL)l1);
611 		noreach = FALSE;
612 		statement(if_n->else_stmnt);
613 		noreach = (noreach && nr)?TRUE:FALSE;
614 		l1 = l2;
615 	} else
616 		noreach = FALSE;
617 	patch((PTR_DCL)l1);
618 	if (goc != gocnt)
619 		putcnt();
620 }
621 
622 /*
623  * while expr do stat
624  */
625 whilop(w_node)
626 	WHI_CAS *w_node;
627 {
628 	register struct nl *p;
629 	register char *l1, *l2;
630 	int goc;
631 
632 	goc = gocnt;
633 	l1 = getlab();
634 	(void) putlab(l1);
635 	putline();
636 	p = rvalue(w_node->expr, NLNIL , RREQ );
637 	if (p == NLNIL) {
638 		statement(w_node->stmnt_list);
639 		noreach = FALSE;
640 		return;
641 	}
642 	if (isnta(p, "b")) {
643 		error("Type of expression in while statement must be Boolean, not %s", nameof(p));
644 		statement(w_node->stmnt_list);
645 		noreach = FALSE;
646 		return;
647 	}
648 	l2 = getlab();
649 #	ifdef OBJ
650 	    (void) put(2, O_IF, l2);
651 #	endif OBJ
652 #	ifdef PC
653 	    putleaf( PCC_ICON , (int) l2 , 0 , PCCT_INT , (char *) 0 );
654 	    putop( PCC_CBRANCH , PCCT_INT );
655 	    putdot( filename , line );
656 #	endif PC
657 	putcnt();
658 	statement(w_node->stmnt_list);
659 #	ifdef OBJ
660 	    (void) put(2, O_TRA, l1);
661 #	endif OBJ
662 #	ifdef PC
663 	    putjbr( (long) l1 );
664 #	endif PC
665 	patch((PTR_DCL) l2);
666 	if (goc != gocnt)
667 		putcnt();
668 }
669 
670 /*
671  * repeat stat* until expr
672  */
673 repop(r)
674 	REPEAT *r;
675 {
676 	register struct nl *p;
677 	register l;
678 	int goc;
679 
680 	goc = gocnt;
681 	l = (int) putlab(getlab());
682 	putcnt();
683 	statlist(r->stmnt_list);
684 	line = r->line_no;
685 	p = rvalue(r->term_expr, NLNIL , RREQ );
686 	if (p == NLNIL)
687 		return;
688 	if (isnta(p,"b")) {
689 		error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
690 		return;
691 	}
692 #	ifdef OBJ
693 	    (void) put(2, O_IF, l);
694 #	endif OBJ
695 #	ifdef PC
696 	    putleaf( PCC_ICON , l , 0 , PCCT_INT , (char *) 0 );
697 	    putop( PCC_CBRANCH , PCCT_INT );
698 	    putdot( filename , line );
699 #	endif PC
700 	if (goc != gocnt)
701 		putcnt();
702 }
703