Commit | Line | Data |
---|---|---|
d52551c6 KB |
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[] = "@(#)exec.c 5.2 (Berkeley) 6/7/85"; | |
9 | #endif not lint | |
10 | ||
11 | /* | |
12 | * exec.c | |
13 | * | |
14 | * Routines for handling the semantics of control structures. | |
15 | * F77 compiler, pass 1. | |
16 | * | |
17 | * University of Utah CS Dept modification history: | |
18 | * | |
19 | * Revision 2.3 85/03/18 08:03:31 donn | |
20 | * Hacks for conversions from type address to numeric type -- prevent addresses | |
21 | * from being stored in shorts and prevent warnings about implicit conversions. | |
22 | * | |
23 | * Revision 2.2 84/09/03 23:18:30 donn | |
24 | * When a DO loop had the same variable as its loop variable and its limit, | |
25 | * the limit temporary was assigned to AFTER the original value of the variable | |
26 | * was destroyed by assigning the initial value to the loop variable. I | |
27 | * swapped the operands of a comparison and changed the direction of the | |
28 | * operator... This only affected programs when optimizing. (This may not | |
29 | * be enough if something alters the order of evaluation of side effects | |
30 | * later on... sigh.) | |
31 | * | |
32 | * Revision 2.1 84/07/19 12:02:53 donn | |
33 | * Changed comment headers for UofU. | |
34 | * | |
35 | * Revision 1.3 84/07/12 18:35:12 donn | |
36 | * Added change to enddo() to detect open 'if' blocks at the ends of loops. | |
37 | * | |
38 | * Revision 1.2 84/06/08 11:22:53 donn | |
39 | * Fixed bug in exdo() -- if a loop parameter contained an instance of the loop | |
40 | * variable and the optimizer was off, the loop variable got converted to | |
41 | * register before the parameters were processed and so the loop parameters | |
42 | * were initialized from garbage in the register instead of the memory version | |
43 | * of the loop variable. | |
44 | * | |
45 | */ | |
46 | ||
47 | #include "defs.h" | |
48 | #include "optim.h" | |
49 | ||
50 | ||
51 | /* Logical IF codes | |
52 | */ | |
53 | ||
54 | ||
55 | exif(p) | |
56 | expptr p; | |
57 | { | |
58 | register int k; | |
59 | pushctl(CTLIF); | |
60 | ctlstack->elselabel = newlabel(); | |
61 | ||
62 | if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL) | |
63 | { | |
64 | if(k != TYERROR) | |
65 | err("non-logical expression in IF statement"); | |
66 | frexpr(p); | |
67 | } | |
68 | else if (optimflag) | |
69 | optbuff (SKIFN, p, ctlstack->elselabel, 0); | |
70 | else | |
71 | putif (p, ctlstack->elselabel); | |
72 | } | |
73 | ||
74 | ||
75 | ||
76 | exelif(p) | |
77 | expptr p; | |
78 | { | |
79 | int k,oldelse; | |
80 | ||
81 | if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL) | |
82 | { | |
83 | if(k != TYERROR) | |
84 | err("non-logical expression in IF statement"); | |
85 | frexpr(p); | |
86 | } | |
87 | else { | |
88 | if(ctlstack->ctltype == CTLIF) | |
89 | { | |
90 | if(ctlstack->endlabel == 0) ctlstack->endlabel = newlabel(); | |
91 | oldelse=ctlstack->elselabel; | |
92 | ctlstack->elselabel = newlabel(); | |
93 | if (optimflag) | |
94 | { | |
95 | optbuff (SKGOTO, 0, ctlstack->endlabel, 0); | |
96 | optbuff (SKLABEL, 0, oldelse, 0); | |
97 | optbuff (SKIFN, p, ctlstack->elselabel, 0); | |
98 | } | |
99 | else | |
100 | { | |
101 | putgoto (ctlstack->endlabel); | |
102 | putlabel (oldelse); | |
103 | putif (p, ctlstack->elselabel); | |
104 | } | |
105 | } | |
106 | else execerr("elseif out of place", CNULL); | |
107 | } | |
108 | } | |
109 | ||
110 | ||
111 | ||
112 | ||
113 | ||
114 | exelse() | |
115 | { | |
116 | if(ctlstack->ctltype==CTLIF) | |
117 | { | |
118 | if(ctlstack->endlabel == 0) | |
119 | ctlstack->endlabel = newlabel(); | |
120 | ctlstack->ctltype = CTLELSE; | |
121 | if (optimflag) | |
122 | { | |
123 | optbuff (SKGOTO, 0, ctlstack->endlabel, 0); | |
124 | optbuff (SKLABEL, 0, ctlstack->elselabel, 0); | |
125 | } | |
126 | else | |
127 | { | |
128 | putgoto (ctlstack->endlabel); | |
129 | putlabel (ctlstack->elselabel); | |
130 | } | |
131 | } | |
132 | ||
133 | else execerr("else out of place", CNULL); | |
134 | } | |
135 | ||
136 | ||
137 | exendif() | |
138 | { | |
139 | if (ctlstack->ctltype == CTLIF) | |
140 | { | |
141 | if (optimflag) | |
142 | { | |
143 | optbuff (SKLABEL, 0, ctlstack->elselabel, 0); | |
144 | if (ctlstack->endlabel) | |
145 | optbuff (SKLABEL, 0, ctlstack->endlabel, 0); | |
146 | } | |
147 | else | |
148 | { | |
149 | putlabel (ctlstack->elselabel); | |
150 | if (ctlstack->endlabel) | |
151 | putlabel (ctlstack->endlabel); | |
152 | } | |
153 | popctl (); | |
154 | } | |
155 | else if (ctlstack->ctltype == CTLELSE) | |
156 | { | |
157 | if (optimflag) | |
158 | optbuff (SKLABEL, 0, ctlstack->endlabel, 0); | |
159 | else | |
160 | putlabel (ctlstack->endlabel); | |
161 | popctl (); | |
162 | } | |
163 | else | |
164 | execerr("endif out of place", CNULL); | |
165 | } | |
166 | ||
167 | ||
168 | ||
169 | LOCAL pushctl(code) | |
170 | int code; | |
171 | { | |
172 | register int i; | |
173 | ||
174 | /* fprintf(diagfile,"old blklevel %d \n",blklevel); dmpframe(ctlstack); */ | |
175 | if(++ctlstack >= lastctl) | |
176 | many("loops or if-then-elses", 'c'); | |
177 | ctlstack->ctltype = code; | |
178 | for(i = 0 ; i < 4 ; ++i) | |
179 | ctlstack->ctlabels[i] = 0; | |
180 | ++blklevel; | |
181 | } | |
182 | ||
183 | ||
184 | LOCAL popctl() | |
185 | { | |
186 | if( ctlstack-- < ctls ) | |
187 | fatal("control stack empty"); | |
188 | --blklevel; | |
189 | } | |
190 | ||
191 | ||
192 | ||
193 | LOCAL poplab() | |
194 | { | |
195 | register struct Labelblock *lp; | |
196 | ||
197 | for(lp = labeltab ; lp < highlabtab ; ++lp) | |
198 | if(lp->labdefined) | |
199 | { | |
200 | /* mark all labels in inner blocks unreachable */ | |
201 | if(lp->blklevel > blklevel) | |
202 | lp->labinacc = YES; | |
203 | } | |
204 | else if(lp->blklevel > blklevel) | |
205 | { | |
206 | /* move all labels referred to in inner blocks out a level */ | |
207 | lp->blklevel = blklevel; | |
208 | } | |
209 | } | |
210 | \f | |
211 | ||
212 | ||
213 | /* BRANCHING CODE | |
214 | */ | |
215 | ||
216 | exgoto(lab) | |
217 | struct Labelblock *lab; | |
218 | { | |
219 | if (optimflag) | |
220 | optbuff (SKGOTO, 0, lab->labelno, 0); | |
221 | else | |
222 | putgoto (lab->labelno); | |
223 | } | |
224 | ||
225 | ||
226 | ||
227 | ||
228 | ||
229 | ||
230 | ||
231 | exequals(lp, rp) | |
232 | register struct Primblock *lp; | |
233 | register expptr rp; | |
234 | { | |
235 | register Namep np; | |
236 | ||
237 | if(lp->tag != TPRIM) | |
238 | { | |
239 | err("assignment to a non-variable"); | |
240 | frexpr(lp); | |
241 | frexpr(rp); | |
242 | } | |
243 | else if(lp->namep->vclass!=CLVAR && lp->argsp) | |
244 | { | |
245 | if(parstate >= INEXEC) | |
246 | err("assignment to an undimemsioned array"); | |
247 | else | |
248 | mkstfunct(lp, rp); | |
249 | } | |
250 | else | |
251 | { | |
252 | np = (Namep) lp->namep; | |
253 | if (np->vclass == CLPROC && np->vprocclass == PTHISPROC | |
254 | && proctype == TYSUBR) | |
255 | { | |
256 | err("assignment to a subroutine name"); | |
257 | return; | |
258 | } | |
259 | if(parstate < INDATA) | |
260 | enddcl(); | |
261 | if (optimflag) | |
262 | optbuff (SKEQ, mkexpr(OPASSIGN, mklhs(lp), fixtype(rp)), 0, 0); | |
263 | else | |
264 | puteq (mklhs(lp), fixtype(rp)); | |
265 | } | |
266 | } | |
267 | ||
268 | ||
269 | ||
270 | mkstfunct(lp, rp) | |
271 | struct Primblock *lp; | |
272 | expptr rp; | |
273 | { | |
274 | register struct Primblock *p; | |
275 | register Namep np; | |
276 | chainp args; | |
277 | ||
278 | if(parstate < INDATA) | |
279 | { | |
280 | enddcl(); | |
281 | parstate = INDATA; | |
282 | } | |
283 | ||
284 | np = lp->namep; | |
285 | if(np->vclass == CLUNKNOWN) | |
286 | np->vclass = CLPROC; | |
287 | else | |
288 | { | |
289 | dclerr("redeclaration of statement function", np); | |
290 | return; | |
291 | } | |
292 | np->vprocclass = PSTFUNCT; | |
293 | np->vstg = STGSTFUNCT; | |
294 | impldcl(np); | |
295 | args = (lp->argsp ? lp->argsp->listp : CHNULL); | |
296 | np->varxptr.vstfdesc = mkchain(args , rp ); | |
297 | ||
298 | for( ; args ; args = args->nextp) | |
299 | if( args->datap->tag!=TPRIM || | |
300 | (p = (struct Primblock *) (args->datap) )->argsp || | |
301 | p->fcharp || p->lcharp ) | |
302 | err("non-variable argument in statement function definition"); | |
303 | else | |
304 | { | |
305 | args->datap = (tagptr) (p->namep); | |
306 | vardcl(p->namep); | |
307 | free(p); | |
308 | } | |
309 | } | |
310 | ||
311 | ||
312 | ||
313 | excall(name, args, nstars, labels) | |
314 | Namep name; | |
315 | struct Listblock *args; | |
316 | int nstars; | |
317 | struct Labelblock *labels[ ]; | |
318 | { | |
319 | register expptr p; | |
320 | ||
321 | settype(name, TYSUBR, ENULL); | |
322 | p = mkfunct( mkprim(name, args, CHNULL) ); | |
323 | p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT; | |
324 | if (nstars > 0) | |
325 | if (optimflag) | |
326 | optbuff (SKCMGOTO, p, nstars, labels); | |
327 | else | |
328 | putcmgo (p, nstars, labels); | |
329 | else | |
330 | if (optimflag) | |
331 | optbuff (SKCALL, p, 0, 0); | |
332 | else | |
333 | putexpr (p); | |
334 | } | |
335 | ||
336 | ||
337 | ||
338 | exstop(stop, p) | |
339 | int stop; | |
340 | register expptr p; | |
341 | { | |
342 | char *q; | |
343 | int n; | |
344 | expptr mkstrcon(); | |
345 | ||
346 | if(p) | |
347 | { | |
348 | if( ! ISCONST(p) ) | |
349 | { | |
350 | execerr("pause/stop argument must be constant", CNULL); | |
351 | frexpr(p); | |
352 | p = mkstrcon(0, CNULL); | |
353 | } | |
354 | else if( ISINT(p->constblock.vtype) ) | |
355 | { | |
b2ab2bea | 356 | q = convic(p->constblock.constant.ci); |
d52551c6 KB |
357 | n = strlen(q); |
358 | if(n > 0) | |
359 | { | |
b2ab2bea | 360 | p->constblock.constant.ccp = copyn(n, q); |
d52551c6 KB |
361 | p->constblock.vtype = TYCHAR; |
362 | p->constblock.vleng = (expptr) ICON(n); | |
363 | } | |
364 | else | |
365 | p = (expptr) mkstrcon(0, CNULL); | |
366 | } | |
367 | else if(p->constblock.vtype != TYCHAR) | |
368 | { | |
369 | execerr("pause/stop argument must be integer or string", CNULL); | |
370 | p = (expptr) mkstrcon(0, CNULL); | |
371 | } | |
372 | } | |
373 | else p = (expptr) mkstrcon(0, CNULL); | |
374 | ||
375 | if (optimflag) | |
376 | optbuff ((stop ? SKSTOP : SKPAUSE), p, 0, 0); | |
377 | else | |
378 | putexpr (call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p)); | |
379 | } | |
380 | ||
381 | \f | |
382 | /* UCB DO LOOP CODE */ | |
383 | ||
384 | #define DOINIT par[0] | |
385 | #define DOLIMIT par[1] | |
386 | #define DOINCR par[2] | |
387 | ||
b2ab2bea KB |
388 | #define CONSTINIT constant[0] |
389 | #define CONSTLIMIT constant[1] | |
390 | #define CONSTINCR constant[2] | |
d52551c6 KB |
391 | |
392 | #define VARSTEP 0 | |
393 | #define POSSTEP 1 | |
394 | #define NEGSTEP 2 | |
395 | ||
396 | ||
397 | exdo(range, spec) | |
398 | int range; | |
399 | chainp spec; | |
400 | ||
401 | { | |
402 | register expptr p, q; | |
403 | expptr q1; | |
404 | register Namep np; | |
405 | chainp cp; | |
406 | register int i; | |
407 | int dotype, incsign; | |
408 | Addrp dovarp, dostgp; | |
409 | expptr par[3]; | |
b2ab2bea | 410 | expptr constant[3]; |
d52551c6 KB |
411 | Slotp doslot; |
412 | ||
413 | pushctl(CTLDO); | |
414 | dorange = ctlstack->dolabel = range; | |
415 | np = (Namep) (spec->datap); | |
416 | ctlstack->donamep = NULL; | |
417 | if(np->vdovar) | |
418 | { | |
419 | errstr("nested loops with variable %s", varstr(VL,np->varname)); | |
420 | return; | |
421 | } | |
422 | ||
423 | dovarp = mkplace(np); | |
424 | dotype = dovarp->vtype; | |
425 | ||
426 | if( ! ONEOF(dotype, MSKINT|MSKREAL) ) | |
427 | { | |
428 | err("bad type on DO variable"); | |
429 | return; | |
430 | } | |
431 | ||
432 | ||
433 | for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp) | |
434 | { | |
435 | p = fixtype((expptr) cpexpr((tagptr) q = cp->datap)); | |
436 | if(!ONEOF(p->headblock.vtype, MSKINT|MSKREAL) ) | |
437 | { | |
438 | err("bad type on DO parameter"); | |
439 | return; | |
440 | } | |
441 | ||
442 | ||
443 | if (ISCONST(q)) | |
b2ab2bea | 444 | constant[i] = mkconv(dotype, q); |
d52551c6 KB |
445 | else |
446 | { | |
447 | frexpr(q); | |
b2ab2bea | 448 | constant[i] = NULL; |
d52551c6 KB |
449 | } |
450 | ||
451 | par[i++] = mkconv(dotype, p); | |
452 | } | |
453 | ||
454 | frchain(&spec); | |
455 | switch(i) | |
456 | { | |
457 | case 0: | |
458 | case 1: | |
459 | err("too few DO parameters"); | |
460 | return; | |
461 | ||
462 | case 2: | |
463 | DOINCR = (expptr) ICON(1); | |
464 | CONSTINCR = ICON(1); | |
465 | ||
466 | case 3: | |
467 | break; | |
468 | ||
469 | default: | |
470 | err("too many DO parameters"); | |
471 | return; | |
472 | } | |
473 | ||
474 | ctlstack->donamep = np; | |
475 | ||
476 | np->vdovar = YES; | |
477 | if( !optimflag && enregister(np) ) | |
478 | { | |
479 | /* stgp points to a storage version, varp to a register version */ | |
480 | dostgp = dovarp; | |
481 | dovarp = mkplace(np); | |
482 | } | |
483 | else | |
484 | dostgp = NULL; | |
485 | ||
486 | for (i = 0; i < 4; i++) | |
487 | ctlstack->ctlabels[i] = newlabel(); | |
488 | ||
489 | if( CONSTLIMIT ) | |
490 | ctlstack->domax = DOLIMIT; | |
491 | else | |
492 | ctlstack->domax = (expptr) mktemp(dotype, PNULL); | |
493 | ||
494 | if( CONSTINCR ) | |
495 | { | |
496 | ctlstack->dostep = DOINCR; | |
497 | if( (incsign = conssgn(CONSTINCR)) == 0) | |
498 | err("zero DO increment"); | |
499 | ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP); | |
500 | } | |
501 | else | |
502 | { | |
503 | ctlstack->dostep = (expptr) mktemp(dotype, PNULL); | |
504 | ctlstack->dostepsign = VARSTEP; | |
505 | } | |
506 | ||
507 | if (optimflag) | |
508 | doslot = optbuff (SKDOHEAD,0,0,ctlstack); | |
509 | ||
510 | if( CONSTLIMIT && CONSTINIT && ctlstack->dostepsign!=VARSTEP) | |
511 | { | |
512 | if (optimflag) | |
513 | optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp),cpexpr(DOINIT)), | |
514 | 0,0); | |
515 | else | |
516 | puteq (cpexpr(dovarp), cpexpr(DOINIT)); | |
517 | if( ! onetripflag ) | |
518 | { | |
519 | q = mkexpr(OPMINUS, cpexpr(CONSTLIMIT), cpexpr(CONSTINIT)); | |
520 | if((incsign * conssgn(q)) == -1) | |
521 | { | |
522 | warn("DO range never executed"); | |
523 | if (optimflag) | |
524 | optbuff (SKGOTO,0,ctlstack->endlabel,0); | |
525 | else | |
526 | putgoto (ctlstack->endlabel); | |
527 | } | |
528 | frexpr(q); | |
529 | } | |
530 | } | |
531 | ||
532 | ||
533 | else if (ctlstack->dostepsign != VARSTEP && !onetripflag) | |
534 | { | |
535 | if (CONSTLIMIT) | |
536 | q = (expptr) cpexpr(ctlstack->domax); | |
537 | else | |
538 | q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT); | |
539 | q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT); | |
540 | q = mkexpr( (ctlstack->dostepsign == POSSTEP ? OPGE : OPLE), | |
541 | q, q1); | |
542 | if (optimflag) | |
543 | optbuff (SKIFN,q, ctlstack->endlabel,0); | |
544 | else | |
545 | putif (q, ctlstack->endlabel); | |
546 | } | |
547 | else | |
548 | { | |
549 | if (!CONSTLIMIT) | |
550 | if (optimflag) | |
551 | optbuff (SKEQ, | |
552 | mkexpr(OPASSIGN,cpexpr(ctlstack->domax),DOLIMIT),0,0); | |
553 | else | |
554 | puteq (cpexpr(ctlstack->domax), DOLIMIT); | |
555 | q = DOINIT; | |
556 | if (!onetripflag) | |
557 | q = mkexpr(OPMINUS, q, | |
558 | mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), | |
559 | DOINCR) ); | |
560 | if (optimflag) | |
561 | optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp), q),0,0); | |
562 | else | |
563 | puteq (cpexpr(dovarp), q); | |
564 | if (onetripflag && ctlstack->dostepsign == VARSTEP) | |
565 | if (optimflag) | |
566 | optbuff (SKEQ, | |
567 | mkexpr(OPASSIGN,cpexpr(ctlstack->dostep),DOINCR),0,0); | |
568 | else | |
569 | puteq (cpexpr(ctlstack->dostep), DOINCR); | |
570 | } | |
571 | ||
572 | if (ctlstack->dostepsign == VARSTEP) | |
573 | { | |
574 | expptr incr,test; | |
575 | if (onetripflag) | |
576 | if (optimflag) | |
577 | optbuff (SKGOTO,0,ctlstack->dobodylabel,0); | |
578 | else | |
579 | putgoto (ctlstack->dobodylabel); | |
580 | else | |
581 | if (optimflag) | |
582 | optbuff (SKIFN,mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)), | |
583 | ctlstack->doneglabel,0); | |
584 | else | |
585 | putif (mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)), | |
586 | ctlstack->doneglabel); | |
587 | if (optimflag) | |
588 | optbuff (SKLABEL,0,ctlstack->doposlabel,0); | |
589 | else | |
590 | putlabel (ctlstack->doposlabel); | |
591 | incr = mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)); | |
592 | test = mkexpr(OPLE, incr, cpexpr(ctlstack->domax)); | |
593 | if (optimflag) | |
594 | optbuff (SKIFN,test, ctlstack->endlabel,0); | |
595 | else | |
596 | putif (test, ctlstack->endlabel); | |
597 | } | |
598 | ||
599 | if (optimflag) | |
600 | optbuff (SKLABEL,0,ctlstack->dobodylabel,0); | |
601 | else | |
602 | putlabel (ctlstack->dobodylabel); | |
603 | if (dostgp) | |
604 | { | |
605 | if (optimflag) | |
606 | optbuff (SKEQ,mkexpr(OPASSIGN,dostgp, dovarp),0,0); | |
607 | else | |
608 | puteq (dostgp, dovarp); | |
609 | } | |
610 | else | |
611 | frexpr(dovarp); | |
612 | if (optimflag) | |
613 | doslot->nullslot = optbuff (SKNULL,0,0,0); | |
614 | ||
615 | frexpr(CONSTINIT); | |
616 | frexpr(CONSTLIMIT); | |
617 | frexpr(CONSTINCR); | |
618 | } | |
619 | ||
620 | \f | |
621 | enddo(here) | |
622 | int here; | |
623 | ||
624 | { | |
625 | register struct Ctlframe *q; | |
626 | Namep np; | |
627 | Addrp ap, rv; | |
628 | expptr t; | |
629 | register int i; | |
630 | Slotp doslot; | |
631 | ||
632 | while (here == dorange) | |
633 | { | |
634 | while (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLELSE) | |
635 | { | |
636 | execerr("missing endif", CNULL); | |
637 | exendif(); | |
638 | } | |
639 | ||
640 | if (np = ctlstack->donamep) | |
641 | { | |
642 | rv = mkplace (np); | |
643 | ||
644 | t = mkexpr(OPPLUSEQ, cpexpr(rv), cpexpr(ctlstack->dostep) ); | |
645 | ||
646 | if (optimflag) | |
647 | doslot = optbuff (SKENDDO,0,0,ctlstack); | |
648 | ||
649 | if (ctlstack->dostepsign == VARSTEP) | |
650 | if (optimflag) | |
651 | { | |
652 | optbuff (SKIFN, | |
653 | mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), | |
654 | ctlstack->doposlabel,0); | |
655 | optbuff (SKLABEL,0,ctlstack->doneglabel,0); | |
656 | optbuff (SKIFN,mkexpr(OPLT, t, ctlstack->domax), | |
657 | ctlstack->dobodylabel,0); | |
658 | } | |
659 | else | |
660 | { | |
661 | putif (mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), | |
662 | ctlstack->doposlabel); | |
663 | putlabel (ctlstack->doneglabel); | |
664 | putif (mkexpr(OPLT, t, ctlstack->domax), | |
665 | ctlstack->dobodylabel); | |
666 | } | |
667 | else | |
668 | { | |
669 | int op; | |
670 | op = (ctlstack->dostepsign == POSSTEP ? OPGT : OPLT); | |
671 | if (optimflag) | |
672 | optbuff (SKIFN, mkexpr(op,t,ctlstack->domax), | |
673 | ctlstack->dobodylabel,0); | |
674 | else | |
675 | putif (mkexpr(op, t, ctlstack->domax), | |
676 | ctlstack->dobodylabel); | |
677 | } | |
678 | if (optimflag) | |
679 | optbuff (SKLABEL,0,ctlstack->endlabel,0); | |
680 | else | |
681 | putlabel (ctlstack->endlabel); | |
682 | ||
683 | if (ap = memversion(np)) | |
684 | { | |
685 | if (optimflag) | |
686 | optbuff (SKEQ,mkexpr(OPASSIGN,ap, rv),0,0); | |
687 | else | |
688 | puteq (ap, rv); | |
689 | } | |
690 | else | |
691 | frexpr(rv); | |
692 | for (i = 0; i < 4; i++) | |
693 | ctlstack->ctlabels[i] = 0; | |
694 | if (!optimflag) | |
695 | deregister(ctlstack->donamep); | |
696 | ctlstack->donamep->vdovar = NO; | |
697 | if (optimflag) | |
698 | doslot->nullslot = optbuff (SKNULL,0,0,0); | |
699 | } | |
700 | ||
701 | popctl(); | |
702 | poplab(); | |
703 | ||
704 | dorange = 0; | |
705 | for (q = ctlstack; q >= ctls; --q) | |
706 | if (q->ctltype == CTLDO) | |
707 | { | |
708 | dorange = q->dolabel; | |
709 | break; | |
710 | } | |
711 | } | |
712 | } | |
713 | ||
714 | \f | |
715 | exassign(vname, labelval) | |
716 | Namep vname; | |
717 | struct Labelblock *labelval; | |
718 | { | |
719 | Addrp p; | |
720 | expptr mkaddcon(); | |
721 | ||
722 | p = mkplace(vname); | |
723 | #if SZADDR > SZSHORT | |
724 | if( p->vtype == TYSHORT ) | |
725 | err("insufficient precision in ASSIGN variable"); | |
726 | else | |
727 | #endif | |
728 | if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) | |
729 | err("noninteger assign variable"); | |
730 | else | |
731 | { | |
732 | if (optimflag) | |
733 | optbuff (SKASSIGN, p, labelval->labelno, 0); | |
734 | else | |
735 | puteq (p, intrconv(p->vtype, mkaddcon(labelval->labelno))); | |
736 | } | |
737 | } | |
738 | ||
739 | ||
740 | ||
741 | exarif(expr, neglab, zerlab, poslab) | |
742 | expptr expr; | |
743 | struct Labelblock *neglab, *zerlab, *poslab; | |
744 | { | |
745 | register int lm, lz, lp; | |
746 | struct Labelblock *labels[3]; | |
747 | ||
748 | lm = neglab->labelno; | |
749 | lz = zerlab->labelno; | |
750 | lp = poslab->labelno; | |
751 | expr = fixtype(expr); | |
752 | ||
753 | if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) ) | |
754 | { | |
755 | err("invalid type of arithmetic if expression"); | |
756 | frexpr(expr); | |
757 | } | |
758 | else | |
759 | { | |
760 | if(lm == lz) | |
761 | exar2(OPLE, expr, lm, lp); | |
762 | else if(lm == lp) | |
763 | exar2(OPNE, expr, lm, lz); | |
764 | else if(lz == lp) | |
765 | exar2(OPGE, expr, lz, lm); | |
766 | else | |
767 | if (optimflag) | |
768 | { | |
769 | labels[0] = neglab; | |
770 | labels[1] = zerlab; | |
771 | labels[2] = poslab; | |
772 | optbuff (SKARIF, expr, 0, labels); | |
773 | } | |
774 | else | |
775 | prarif(expr, lm, lz, lp); | |
776 | } | |
777 | } | |
778 | ||
779 | ||
780 | ||
781 | LOCAL exar2 (op, e, l1, l2) | |
782 | int op; | |
783 | expptr e; | |
784 | int l1,l2; | |
785 | { | |
786 | if (optimflag) | |
787 | { | |
788 | optbuff (SKIFN, mkexpr(op, e, ICON(0)), l2, 0); | |
789 | optbuff (SKGOTO, 0, l1, 0); | |
790 | } | |
791 | else | |
792 | { | |
793 | putif (mkexpr(op, e, ICON(0)), l2); | |
794 | putgoto (l1); | |
795 | } | |
796 | } | |
797 | ||
798 | ||
799 | exreturn(p) | |
800 | register expptr p; | |
801 | { | |
802 | if(procclass != CLPROC) | |
803 | warn("RETURN statement in main or block data"); | |
804 | if(p && (proctype!=TYSUBR || procclass!=CLPROC) ) | |
805 | { | |
806 | err("alternate return in nonsubroutine"); | |
807 | p = 0; | |
808 | } | |
809 | ||
810 | if(p) | |
811 | if (optimflag) | |
812 | optbuff (SKRETURN, p, retlabel, 0); | |
813 | else | |
814 | { | |
815 | putforce (TYINT, p); | |
816 | putgoto (retlabel); | |
817 | } | |
818 | else | |
819 | if (optimflag) | |
820 | optbuff (SKRETURN, p, | |
821 | (proctype==TYSUBR ? ret0label : retlabel), 0); | |
822 | else | |
823 | putgoto (proctype==TYSUBR ? ret0label : retlabel); | |
824 | } | |
825 | ||
826 | ||
827 | ||
828 | exasgoto(labvar) | |
829 | struct Hashentry *labvar; | |
830 | { | |
831 | register Addrp p; | |
832 | ||
833 | p = mkplace(labvar); | |
834 | if( ! ISINT(p->vtype) ) | |
835 | err("assigned goto variable must be integer"); | |
836 | else | |
837 | if (optimflag) | |
838 | optbuff (SKASGOTO, p, 0, 0); | |
839 | else | |
840 | putbranch (p); | |
841 | } |