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