+/*
+ * Copyright (c) 1980 Regents of the University of California.
+ * All rights reserved. The Berkeley software License Agreement
+ * specifies the terms and conditions for redistribution.
+ */
+
+#ifndef lint
+static char sccsid[] = "@(#)exec.c 5.1 (Berkeley) %G%";
+#endif not lint
+
+/*
+ * exec.c
+ *
+ * Routines for handling the semantics of control structures.
+ * F77 compiler, pass 1.
+ *
+ * University of Utah CS Dept modification history:
+ *
+ * Revision 2.3 85/03/18 08:03:31 donn
+ * Hacks for conversions from type address to numeric type -- prevent addresses
+ * from being stored in shorts and prevent warnings about implicit conversions.
+ *
+ * Revision 2.2 84/09/03 23:18:30 donn
+ * When a DO loop had the same variable as its loop variable and its limit,
+ * the limit temporary was assigned to AFTER the original value of the variable
+ * was destroyed by assigning the initial value to the loop variable. I
+ * swapped the operands of a comparison and changed the direction of the
+ * operator... This only affected programs when optimizing. (This may not
+ * be enough if something alters the order of evaluation of side effects
+ * later on... sigh.)
+ *
+ * Revision 2.1 84/07/19 12:02:53 donn
+ * Changed comment headers for UofU.
+ *
+ * Revision 1.3 84/07/12 18:35:12 donn
+ * Added change to enddo() to detect open 'if' blocks at the ends of loops.
+ *
+ * Revision 1.2 84/06/08 11:22:53 donn
+ * Fixed bug in exdo() -- if a loop parameter contained an instance of the loop
+ * variable and the optimizer was off, the loop variable got converted to
+ * register before the parameters were processed and so the loop parameters
+ * were initialized from garbage in the register instead of the memory version
+ * of the loop variable.
+ *
+ */
+
+#ifndef lint
+static char *sccsid = "@(#)exec.c 5.1 (Berkeley) 85/06/07";
+#endif
+
+#include "defs.h"
+#include "optim.h"
+
+
+/* Logical IF codes
+*/
+
+
+exif(p)
+expptr p;
+{
+register int k;
+pushctl(CTLIF);
+ctlstack->elselabel = newlabel();
+
+if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
+ {
+ if(k != TYERROR)
+ err("non-logical expression in IF statement");
+ frexpr(p);
+ }
+else if (optimflag)
+ optbuff (SKIFN, p, ctlstack->elselabel, 0);
+else
+ putif (p, ctlstack->elselabel);
+}
+
+
+
+exelif(p)
+expptr p;
+{
+int k,oldelse;
+
+if( ( k = (p = fixtype(p))->headblock.vtype) != TYLOGICAL)
+ {
+ if(k != TYERROR)
+ err("non-logical expression in IF statement");
+ frexpr(p);
+ }
+else {
+ if(ctlstack->ctltype == CTLIF)
+ {
+ if(ctlstack->endlabel == 0) ctlstack->endlabel = newlabel();
+ oldelse=ctlstack->elselabel;
+ ctlstack->elselabel = newlabel();
+ if (optimflag)
+ {
+ optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
+ optbuff (SKLABEL, 0, oldelse, 0);
+ optbuff (SKIFN, p, ctlstack->elselabel, 0);
+ }
+ else
+ {
+ putgoto (ctlstack->endlabel);
+ putlabel (oldelse);
+ putif (p, ctlstack->elselabel);
+ }
+ }
+ else execerr("elseif out of place", CNULL);
+ }
+}
+
+
+
+
+
+exelse()
+{
+if(ctlstack->ctltype==CTLIF)
+ {
+ if(ctlstack->endlabel == 0)
+ ctlstack->endlabel = newlabel();
+ ctlstack->ctltype = CTLELSE;
+ if (optimflag)
+ {
+ optbuff (SKGOTO, 0, ctlstack->endlabel, 0);
+ optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
+ }
+ else
+ {
+ putgoto (ctlstack->endlabel);
+ putlabel (ctlstack->elselabel);
+ }
+ }
+
+else execerr("else out of place", CNULL);
+}
+
+
+exendif()
+{
+if (ctlstack->ctltype == CTLIF)
+ {
+ if (optimflag)
+ {
+ optbuff (SKLABEL, 0, ctlstack->elselabel, 0);
+ if (ctlstack->endlabel)
+ optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
+ }
+ else
+ {
+ putlabel (ctlstack->elselabel);
+ if (ctlstack->endlabel)
+ putlabel (ctlstack->endlabel);
+ }
+ popctl ();
+ }
+else if (ctlstack->ctltype == CTLELSE)
+ {
+ if (optimflag)
+ optbuff (SKLABEL, 0, ctlstack->endlabel, 0);
+ else
+ putlabel (ctlstack->endlabel);
+ popctl ();
+ }
+else
+ execerr("endif out of place", CNULL);
+}
+
+
+
+LOCAL pushctl(code)
+int code;
+{
+register int i;
+
+/* fprintf(diagfile,"old blklevel %d \n",blklevel); dmpframe(ctlstack); */
+if(++ctlstack >= lastctl)
+ many("loops or if-then-elses", 'c');
+ctlstack->ctltype = code;
+for(i = 0 ; i < 4 ; ++i)
+ ctlstack->ctlabels[i] = 0;
+++blklevel;
+}
+
+
+LOCAL popctl()
+{
+if( ctlstack-- < ctls )
+ fatal("control stack empty");
+--blklevel;
+}
+
+
+
+LOCAL poplab()
+{
+register struct Labelblock *lp;
+
+for(lp = labeltab ; lp < highlabtab ; ++lp)
+ if(lp->labdefined)
+ {
+ /* mark all labels in inner blocks unreachable */
+ if(lp->blklevel > blklevel)
+ lp->labinacc = YES;
+ }
+ else if(lp->blklevel > blklevel)
+ {
+ /* move all labels referred to in inner blocks out a level */
+ lp->blklevel = blklevel;
+ }
+}
+\f
+
+
+/* BRANCHING CODE
+*/
+
+exgoto(lab)
+struct Labelblock *lab;
+{
+if (optimflag)
+ optbuff (SKGOTO, 0, lab->labelno, 0);
+else
+ putgoto (lab->labelno);
+}
+
+
+
+
+
+
+
+exequals(lp, rp)
+register struct Primblock *lp;
+register expptr rp;
+{
+register Namep np;
+
+if(lp->tag != TPRIM)
+ {
+ err("assignment to a non-variable");
+ frexpr(lp);
+ frexpr(rp);
+ }
+else if(lp->namep->vclass!=CLVAR && lp->argsp)
+ {
+ if(parstate >= INEXEC)
+ err("assignment to an undimemsioned array");
+ else
+ mkstfunct(lp, rp);
+ }
+else
+ {
+ np = (Namep) lp->namep;
+ if (np->vclass == CLPROC && np->vprocclass == PTHISPROC
+ && proctype == TYSUBR)
+ {
+ err("assignment to a subroutine name");
+ return;
+ }
+ if(parstate < INDATA)
+ enddcl();
+ if (optimflag)
+ optbuff (SKEQ, mkexpr(OPASSIGN, mklhs(lp), fixtype(rp)), 0, 0);
+ else
+ puteq (mklhs(lp), fixtype(rp));
+ }
+}
+
+
+
+mkstfunct(lp, rp)
+struct Primblock *lp;
+expptr rp;
+{
+register struct Primblock *p;
+register Namep np;
+chainp args;
+
+if(parstate < INDATA)
+ {
+ enddcl();
+ parstate = INDATA;
+ }
+
+np = lp->namep;
+if(np->vclass == CLUNKNOWN)
+ np->vclass = CLPROC;
+else
+ {
+ dclerr("redeclaration of statement function", np);
+ return;
+ }
+np->vprocclass = PSTFUNCT;
+np->vstg = STGSTFUNCT;
+impldcl(np);
+args = (lp->argsp ? lp->argsp->listp : CHNULL);
+np->varxptr.vstfdesc = mkchain(args , rp );
+
+for( ; args ; args = args->nextp)
+ if( args->datap->tag!=TPRIM ||
+ (p = (struct Primblock *) (args->datap) )->argsp ||
+ p->fcharp || p->lcharp )
+ err("non-variable argument in statement function definition");
+ else
+ {
+ args->datap = (tagptr) (p->namep);
+ vardcl(p->namep);
+ free(p);
+ }
+}
+
+
+
+excall(name, args, nstars, labels)
+Namep name;
+struct Listblock *args;
+int nstars;
+struct Labelblock *labels[ ];
+{
+register expptr p;
+
+settype(name, TYSUBR, ENULL);
+p = mkfunct( mkprim(name, args, CHNULL) );
+p->exprblock.vtype = p->exprblock.leftp->headblock.vtype = TYINT;
+if (nstars > 0)
+ if (optimflag)
+ optbuff (SKCMGOTO, p, nstars, labels);
+ else
+ putcmgo (p, nstars, labels);
+else
+ if (optimflag)
+ optbuff (SKCALL, p, 0, 0);
+ else
+ putexpr (p);
+}
+
+
+
+exstop(stop, p)
+int stop;
+register expptr p;
+{
+char *q;
+int n;
+expptr mkstrcon();
+
+if(p)
+ {
+ if( ! ISCONST(p) )
+ {
+ execerr("pause/stop argument must be constant", CNULL);
+ frexpr(p);
+ p = mkstrcon(0, CNULL);
+ }
+ else if( ISINT(p->constblock.vtype) )
+ {
+ q = convic(p->constblock.const.ci);
+ n = strlen(q);
+ if(n > 0)
+ {
+ p->constblock.const.ccp = copyn(n, q);
+ p->constblock.vtype = TYCHAR;
+ p->constblock.vleng = (expptr) ICON(n);
+ }
+ else
+ p = (expptr) mkstrcon(0, CNULL);
+ }
+ else if(p->constblock.vtype != TYCHAR)
+ {
+ execerr("pause/stop argument must be integer or string", CNULL);
+ p = (expptr) mkstrcon(0, CNULL);
+ }
+ }
+else p = (expptr) mkstrcon(0, CNULL);
+
+if (optimflag)
+ optbuff ((stop ? SKSTOP : SKPAUSE), p, 0, 0);
+else
+ putexpr (call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p));
+}
+
+\f
+/* UCB DO LOOP CODE */
+
+#define DOINIT par[0]
+#define DOLIMIT par[1]
+#define DOINCR par[2]
+
+#define CONSTINIT const[0]
+#define CONSTLIMIT const[1]
+#define CONSTINCR const[2]
+
+#define VARSTEP 0
+#define POSSTEP 1
+#define NEGSTEP 2
+
+
+exdo(range, spec)
+int range;
+chainp spec;
+
+{
+ register expptr p, q;
+ expptr q1;
+ register Namep np;
+ chainp cp;
+ register int i;
+ int dotype, incsign;
+ Addrp dovarp, dostgp;
+ expptr par[3];
+ expptr const[3];
+ Slotp doslot;
+
+ pushctl(CTLDO);
+ dorange = ctlstack->dolabel = range;
+ np = (Namep) (spec->datap);
+ ctlstack->donamep = NULL;
+ if(np->vdovar)
+ {
+ errstr("nested loops with variable %s", varstr(VL,np->varname));
+ return;
+ }
+
+ dovarp = mkplace(np);
+ dotype = dovarp->vtype;
+
+ if( ! ONEOF(dotype, MSKINT|MSKREAL) )
+ {
+ err("bad type on DO variable");
+ return;
+ }
+
+
+ for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
+ {
+ p = fixtype((expptr) cpexpr((tagptr) q = cp->datap));
+ if(!ONEOF(p->headblock.vtype, MSKINT|MSKREAL) )
+ {
+ err("bad type on DO parameter");
+ return;
+ }
+
+
+ if (ISCONST(q))
+ const[i] = mkconv(dotype, q);
+ else
+ {
+ frexpr(q);
+ const[i] = NULL;
+ }
+
+ par[i++] = mkconv(dotype, p);
+ }
+
+ frchain(&spec);
+ switch(i)
+ {
+ case 0:
+ case 1:
+ err("too few DO parameters");
+ return;
+
+ case 2:
+ DOINCR = (expptr) ICON(1);
+ CONSTINCR = ICON(1);
+
+ case 3:
+ break;
+
+ default:
+ err("too many DO parameters");
+ return;
+ }
+
+ ctlstack->donamep = np;
+
+ np->vdovar = YES;
+ if( !optimflag && enregister(np) )
+ {
+ /* stgp points to a storage version, varp to a register version */
+ dostgp = dovarp;
+ dovarp = mkplace(np);
+ }
+ else
+ dostgp = NULL;
+
+ for (i = 0; i < 4; i++)
+ ctlstack->ctlabels[i] = newlabel();
+
+ if( CONSTLIMIT )
+ ctlstack->domax = DOLIMIT;
+ else
+ ctlstack->domax = (expptr) mktemp(dotype, PNULL);
+
+ if( CONSTINCR )
+ {
+ ctlstack->dostep = DOINCR;
+ if( (incsign = conssgn(CONSTINCR)) == 0)
+ err("zero DO increment");
+ ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
+ }
+ else
+ {
+ ctlstack->dostep = (expptr) mktemp(dotype, PNULL);
+ ctlstack->dostepsign = VARSTEP;
+ }
+
+if (optimflag)
+ doslot = optbuff (SKDOHEAD,0,0,ctlstack);
+
+if( CONSTLIMIT && CONSTINIT && ctlstack->dostepsign!=VARSTEP)
+ {
+ if (optimflag)
+ optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp),cpexpr(DOINIT)),
+ 0,0);
+ else
+ puteq (cpexpr(dovarp), cpexpr(DOINIT));
+ if( ! onetripflag )
+ {
+ q = mkexpr(OPMINUS, cpexpr(CONSTLIMIT), cpexpr(CONSTINIT));
+ if((incsign * conssgn(q)) == -1)
+ {
+ warn("DO range never executed");
+ if (optimflag)
+ optbuff (SKGOTO,0,ctlstack->endlabel,0);
+ else
+ putgoto (ctlstack->endlabel);
+ }
+ frexpr(q);
+ }
+ }
+
+
+else if (ctlstack->dostepsign != VARSTEP && !onetripflag)
+ {
+ if (CONSTLIMIT)
+ q = (expptr) cpexpr(ctlstack->domax);
+ else
+ q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
+ q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
+ q = mkexpr( (ctlstack->dostepsign == POSSTEP ? OPGE : OPLE),
+ q, q1);
+ if (optimflag)
+ optbuff (SKIFN,q, ctlstack->endlabel,0);
+ else
+ putif (q, ctlstack->endlabel);
+ }
+else
+ {
+ if (!CONSTLIMIT)
+ if (optimflag)
+ optbuff (SKEQ,
+ mkexpr(OPASSIGN,cpexpr(ctlstack->domax),DOLIMIT),0,0);
+ else
+ puteq (cpexpr(ctlstack->domax), DOLIMIT);
+ q = DOINIT;
+ if (!onetripflag)
+ q = mkexpr(OPMINUS, q,
+ mkexpr(OPASSIGN, cpexpr(ctlstack->dostep),
+ DOINCR) );
+ if (optimflag)
+ optbuff (SKEQ,mkexpr(OPASSIGN,cpexpr(dovarp), q),0,0);
+ else
+ puteq (cpexpr(dovarp), q);
+ if (onetripflag && ctlstack->dostepsign == VARSTEP)
+ if (optimflag)
+ optbuff (SKEQ,
+ mkexpr(OPASSIGN,cpexpr(ctlstack->dostep),DOINCR),0,0);
+ else
+ puteq (cpexpr(ctlstack->dostep), DOINCR);
+ }
+
+if (ctlstack->dostepsign == VARSTEP)
+ {
+ expptr incr,test;
+ if (onetripflag)
+ if (optimflag)
+ optbuff (SKGOTO,0,ctlstack->dobodylabel,0);
+ else
+ putgoto (ctlstack->dobodylabel);
+ else
+ if (optimflag)
+ optbuff (SKIFN,mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
+ ctlstack->doneglabel,0);
+ else
+ putif (mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
+ ctlstack->doneglabel);
+ if (optimflag)
+ optbuff (SKLABEL,0,ctlstack->doposlabel,0);
+ else
+ putlabel (ctlstack->doposlabel);
+ incr = mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep));
+ test = mkexpr(OPLE, incr, cpexpr(ctlstack->domax));
+ if (optimflag)
+ optbuff (SKIFN,test, ctlstack->endlabel,0);
+ else
+ putif (test, ctlstack->endlabel);
+ }
+
+if (optimflag)
+ optbuff (SKLABEL,0,ctlstack->dobodylabel,0);
+else
+ putlabel (ctlstack->dobodylabel);
+if (dostgp)
+ {
+ if (optimflag)
+ optbuff (SKEQ,mkexpr(OPASSIGN,dostgp, dovarp),0,0);
+ else
+ puteq (dostgp, dovarp);
+ }
+else
+ frexpr(dovarp);
+if (optimflag)
+ doslot->nullslot = optbuff (SKNULL,0,0,0);
+
+frexpr(CONSTINIT);
+frexpr(CONSTLIMIT);
+frexpr(CONSTINCR);
+}
+
+\f
+enddo(here)
+int here;
+
+{
+ register struct Ctlframe *q;
+ Namep np;
+ Addrp ap, rv;
+ expptr t;
+ register int i;
+ Slotp doslot;
+
+ while (here == dorange)
+ {
+ while (ctlstack->ctltype == CTLIF || ctlstack->ctltype == CTLELSE)
+ {
+ execerr("missing endif", CNULL);
+ exendif();
+ }
+
+ if (np = ctlstack->donamep)
+ {
+ rv = mkplace (np);
+
+ t = mkexpr(OPPLUSEQ, cpexpr(rv), cpexpr(ctlstack->dostep) );
+
+ if (optimflag)
+ doslot = optbuff (SKENDDO,0,0,ctlstack);
+
+ if (ctlstack->dostepsign == VARSTEP)
+ if (optimflag)
+ {
+ optbuff (SKIFN,
+ mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
+ ctlstack->doposlabel,0);
+ optbuff (SKLABEL,0,ctlstack->doneglabel,0);
+ optbuff (SKIFN,mkexpr(OPLT, t, ctlstack->domax),
+ ctlstack->dobodylabel,0);
+ }
+ else
+ {
+ putif (mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)),
+ ctlstack->doposlabel);
+ putlabel (ctlstack->doneglabel);
+ putif (mkexpr(OPLT, t, ctlstack->domax),
+ ctlstack->dobodylabel);
+ }
+ else
+ {
+ int op;
+ op = (ctlstack->dostepsign == POSSTEP ? OPGT : OPLT);
+ if (optimflag)
+ optbuff (SKIFN, mkexpr(op,t,ctlstack->domax),
+ ctlstack->dobodylabel,0);
+ else
+ putif (mkexpr(op, t, ctlstack->domax),
+ ctlstack->dobodylabel);
+ }
+ if (optimflag)
+ optbuff (SKLABEL,0,ctlstack->endlabel,0);
+ else
+ putlabel (ctlstack->endlabel);
+
+ if (ap = memversion(np))
+ {
+ if (optimflag)
+ optbuff (SKEQ,mkexpr(OPASSIGN,ap, rv),0,0);
+ else
+ puteq (ap, rv);
+ }
+ else
+ frexpr(rv);
+ for (i = 0; i < 4; i++)
+ ctlstack->ctlabels[i] = 0;
+ if (!optimflag)
+ deregister(ctlstack->donamep);
+ ctlstack->donamep->vdovar = NO;
+ if (optimflag)
+ doslot->nullslot = optbuff (SKNULL,0,0,0);
+ }
+
+ popctl();
+ poplab();
+
+ dorange = 0;
+ for (q = ctlstack; q >= ctls; --q)
+ if (q->ctltype == CTLDO)
+ {
+ dorange = q->dolabel;
+ break;
+ }
+ }
+}
+
+\f
+exassign(vname, labelval)
+Namep vname;
+struct Labelblock *labelval;
+{
+Addrp p;
+expptr mkaddcon();
+
+p = mkplace(vname);
+#if SZADDR > SZSHORT
+if( p->vtype == TYSHORT )
+ err("insufficient precision in ASSIGN variable");
+else
+#endif
+if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
+ err("noninteger assign variable");
+else
+ {
+ if (optimflag)
+ optbuff (SKASSIGN, p, labelval->labelno, 0);
+ else
+ puteq (p, intrconv(p->vtype, mkaddcon(labelval->labelno)));
+ }
+}
+
+
+
+exarif(expr, neglab, zerlab, poslab)
+expptr expr;
+struct Labelblock *neglab, *zerlab, *poslab;
+{
+register int lm, lz, lp;
+struct Labelblock *labels[3];
+
+lm = neglab->labelno;
+lz = zerlab->labelno;
+lp = poslab->labelno;
+expr = fixtype(expr);
+
+if( ! ONEOF(expr->headblock.vtype, MSKINT|MSKREAL) )
+ {
+ err("invalid type of arithmetic if expression");
+ frexpr(expr);
+ }
+else
+ {
+ if(lm == lz)
+ exar2(OPLE, expr, lm, lp);
+ else if(lm == lp)
+ exar2(OPNE, expr, lm, lz);
+ else if(lz == lp)
+ exar2(OPGE, expr, lz, lm);
+ else
+ if (optimflag)
+ {
+ labels[0] = neglab;
+ labels[1] = zerlab;
+ labels[2] = poslab;
+ optbuff (SKARIF, expr, 0, labels);
+ }
+ else
+ prarif(expr, lm, lz, lp);
+ }
+}
+
+
+
+LOCAL exar2 (op, e, l1, l2)
+int op;
+expptr e;
+int l1,l2;
+{
+if (optimflag)
+ {
+ optbuff (SKIFN, mkexpr(op, e, ICON(0)), l2, 0);
+ optbuff (SKGOTO, 0, l1, 0);
+ }
+else
+ {
+ putif (mkexpr(op, e, ICON(0)), l2);
+ putgoto (l1);
+ }
+}
+
+
+exreturn(p)
+register expptr p;
+{
+if(procclass != CLPROC)
+ warn("RETURN statement in main or block data");
+if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
+ {
+ err("alternate return in nonsubroutine");
+ p = 0;
+ }
+
+if(p)
+ if (optimflag)
+ optbuff (SKRETURN, p, retlabel, 0);
+ else
+ {
+ putforce (TYINT, p);
+ putgoto (retlabel);
+ }
+else
+ if (optimflag)
+ optbuff (SKRETURN, p,
+ (proctype==TYSUBR ? ret0label : retlabel), 0);
+ else
+ putgoto (proctype==TYSUBR ? ret0label : retlabel);
+}
+
+
+
+exasgoto(labvar)
+struct Hashentry *labvar;
+{
+register Addrp p;
+
+p = mkplace(labvar);
+if( ! ISINT(p->vtype) )
+ err("assigned goto variable must be integer");
+else
+ if (optimflag)
+ optbuff (SKASGOTO, p, 0, 0);
+ else
+ putbranch (p);
+}
projects / unix-history / commitdiff