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