BSD 4_1_snap development

author CSRG <csrg@ucbvax.Berkeley.EDU>

Fri, 5 Sep 1980 00:28:42 +0000 (16:28 -0800)

committer CSRG <csrg@ucbvax.Berkeley.EDU>

Fri, 5 Sep 1980 00:28:42 +0000 (16:28 -0800)
author CSRG <csrg@ucbvax.Berkeley.EDU>
Fri, 5 Sep 1980 00:28:42 +0000 (16:28 -0800)
committer CSRG <csrg@ucbvax.Berkeley.EDU>
Fri, 5 Sep 1980 00:28:42 +0000 (16:28 -0800)
diff --git a/usr/src/cmd/efl/addr.c b/usr/src/cmd/efl/addr.c

new file mode 100644 (file)

index 0000000..ead6d32
--- /dev/null
+++ b/usr/src/cmd/efl/addr.c
@@ -0,0 +1,178 @@
+#include "defs"
+
+struct varblock *subscript(v,s)
+register ptr v,s;
+{
+ptr p;
+register ptr q;
+ptr bounds, subs;
+int size, align, mask;
+
+if(v->tag == TERROR)
+       goto ret;
+if(v->tag!=TNAME && v->tag!=TTEMP)
+       badtag("subscript", v->tag);
+if(s->tag == TERROR)
+       {
+       v->vsubs = 0;
+       goto ret;
+       }
+
+if(s->tag != TLIST)
+       badtag("subscript", s->tag);
+sizalign(v, &size, &align, &mask);
+if(bounds = v->vdim)
+       bounds = bounds->datap;
+subs = s->leftp;
+
+while ( bounds && subs)
+       {
+       if(bounds->lowerb)
+               {
+               p = mknode(TAROP,OPMINUS,mkint(1),cpexpr(bounds->lowerb));
+               subs->datap = mknode(TAROP,OPPLUS, subs->datap, p);
+               }
+       bounds = bounds->nextp;
+       subs = subs->nextp;
+       }
+v->vdim = 0;
+if(bounds || subs)
+       {
+       exprerr("subscript and bounds of different length", CNULL);
+       v->vsubs = 0;
+       goto ret;
+       }
+
+if(v->vsubs)
+       { /* special case of subscripted type element */
+       if(s->leftp==0 || s->leftp->nextp!=0)
+               {
+               exprerr("not exactly one subscript on type member", CNULL);
+               v->vsubs = 0;
+               goto ret;
+               }
+       q = mknode(TAROP,OPMINUS,s->leftp->datap, mkint(1) );
+       q = mknode(TAROP,OPSTAR, mkint(size), q);
+       if(v->voffset)
+               v->voffset = mknode(TAROP,OPPLUS,v->voffset, q);
+       else    v->voffset = q;
+       goto ret;
+       }
+
+v->vsubs = s;
+
+if(v->vtype==TYCHAR || v->vtype==TYSTRUCT ||
+       (v->vtype==TYLCOMPLEX && tailor.lngcxtype==NULL) )
+       { /* add an initial unit subscript */
+       s->leftp = mkchain(mkint(1), s->leftp);
+       }
+
+else   {   /* add to offset, set first subscript to 1 */
+       q = mknode(TAROP,OPMINUS,s->leftp->datap, mkint(1) );
+       q = mknode(TAROP,OPSTAR, mkint(size), q);
+       if(v->voffset)
+               v->voffset = mknode(TAROP,OPPLUS,v->voffset, q);
+       else    v->voffset = q;
+
+       s->leftp->datap = mkint(1);
+       }
+ret:
+       return(v);
+}
+
+
+
+
+
+ptr strucelt(var, subelt)
+register ptr var;
+ptr subelt;
+{
+register ptr p, q;
+
+if(var->tag == TERROR)
+       return(var);
+if(var->vtype!=TYSTRUCT || var->vtypep==0 || var->vdim!=0)
+       {
+       exprerr("attempt to find a member in an array or non-structure", CNULL);
+       return(errnode());
+       }
+for(p = var->vtypep->strdesc ; p ; p = p->nextp)
+       if(subelt == p->datap->sthead) break;
+if(p == 0)
+       {
+       exprerr("%s is not in structure\n", subelt->namep);
+       return(errnode());
+       }
+q = p->datap;
+var->vdim = q->vdim;
+var->vtypep = q->vtypep;
+if(q->voffset)
+       if(var->voffset)
+               var->voffset = mknode(TAROP,OPPLUS,var->voffset,cpexpr(q->voffset));
+       else    {
+               var->voffset = cpexpr(q->voffset);
+               }
+if( (var->vtype = q->vtype) != TYSTRUCT)
+       convtype(var);
+return(var);
+}
+
+
+
+convtype(p)
+register ptr p;
+{
+register int i, k;
+ptr mksub1();
+
+switch(p->vtype)
+       {
+       case TYFIELD:
+       case TYINT:
+       case TYCHAR:
+       case TYREAL:
+       case TYLREAL:
+       case TYCOMPLEX:
+       case TYLOG:
+               k = eflftn[p->vtype];
+               break;
+
+       default:
+               fatal("convtype: impossible type");
+       }
+
+for(i=0; i<NFTNTYPES; ++i)
+       if(i != k) p->vbase[i] = 0;
+       else if(p->vbase[i]==0)
+               {
+               exprerr("illegal combination of array and dot",CNULL);
+               mvexpr(errnode(), p);
+               return;
+               }
+
+if(p->vsubs == 0)
+       p->vsubs = mksub1();
+
+}
+
+
+
+fixsubs(p)
+register ptr p;
+{
+ptr q, *firstsub;
+int size,align,mask;
+
+if(p->voffset)
+       {
+       firstsub = &(p->vsubs->leftp->datap);
+       sizalign(p, &size,&align,&mask);
+       if(p->vtype == TYCHAR)
+               size = tailor.ftnsize[FTNINT];
+
+       q = mknode(TAROP,OPSLASH,p->voffset,mkint(size));
+       *firstsub = mknode(TAROP,OPPLUS, q, *firstsub);
+       p->voffset = 0;
+       }
+}
diff --git a/usr/src/cmd/efl/alloc.c b/usr/src/cmd/efl/alloc.c

new file mode 100644 (file)

index 0000000..a2c6afb
--- /dev/null
+++ b/usr/src/cmd/efl/alloc.c
@@ -0,0 +1,320 @@
+#include "defs"
+
+#define NHISTO 50
+int histo[NHISTO];
+
+int mem[MEMSIZE];
+unsigned int nmemused  = 0;
+unsigned int nmemavail = 0;
+long int totalloc      = 0;
+long int totfreed      = 0;
+
+int nexpblocks = 0;
+ptr expblocks  = 0;
+int nexcblocks = 0;
+ptr excblocks  = 0;
+ptr chains     = 0;
+
+ptr alloc(), calloc(), malloc();
+
+ptr intalloc(n)
+int n;
+{
+int *p;
+
+/*debug*/ if(n>sizeof(struct genblock)) fatal1("intalloc(%d)", n);
+if( (p = calloc(1,n)) == NULL)
+       {
+       if(memdump)
+               prmem();
+       fatal1("Line %d:  Cannot allocate memory", yylineno);
+       }
+
+return(p);
+}
+
+
+
+
+ptr calloc(m,n)
+int m, n;
+{
+return(alloc(m*n));
+}
+
+
+
+ptr malloc(m)
+int m;
+{
+return(alloc(m));
+}
+
+
+
+/* Very stupid memory allocator.  Stores a count word before
+   each block; negative if idle, positive if busy.
+   Looks for a block big enough for current request, and splits it
+   if necessary.  Does not coalesce, always starts at bottom of memory.
+   Checks validity of all count words it encounters.
+*/
+
+
+ptr alloc(k)
+register int k;
+{
+int *p;
+register int i, j;
+
+k = (k + sizeof(int)-1) / sizeof(int);
+if(k <=0) fprintf(diagfile, "alloc(%d words)\n", k);
+else if(k >= NHISTO) ++histo[0];
+else ++histo[k];
+totalloc += k;
+if(k > 256) fprintf(diagfile, "calloc(%d words)\n", k);
+
+/* look for a large enough slot */
+if(nmemavail > k)
+    for(i=0 ; i<nmemused ; )
+       {
+       j = mem[i];
+       if(j>256)
+               {
+               fprintf(diagfile, "Bad count word %d\n", j);
+               goto die;
+               }
+       if(j>=0 ||  (j = -j)<k)
+               i += (j+1);
+       else    {
+               if(j > 256)
+                       {
+                       fprintf(diagfile, "Bad count word %d\n", j);
+                       goto die;
+                       }
+               mem[i] = k;
+               if(j > k)
+                       mem[i+k+1] = -(j-k-1);
+               for(j = i+k ; j>i ; --j)
+                       mem[j] = 0;
+               nmemavail -= (k+1);
+               return(mem + i+1);
+               }
+       }
+
+/* otherwise try to advance the fence */
+mem[nmemused] = k;
+p = mem + nmemused + 1;
+nmemused += (k+1);
+if(nmemused >= MEMSIZE)
+       {
+       die:
+/*debug*/      fprintf(diagfile, "Highwater mark %d words. ", nmemused);
+/*debug*/      fprintf(diagfile, "%ld words left over\n", totalloc-totfreed);
+/*     prmem();        */
+       fatal1("Line %d:  out of memory", yylineno);
+       }
+return(p);
+}
+
+
+
+cfree(p)
+ptr p;
+{
+if(p==0)
+       fatal("cfree(0)");
+free(p);
+}
+
+
+
+
+free(p)
+register unsigned int *p;
+{
+if(p<=mem || p>mem+nmemused)
+       {
+       fprintf(diagfile, "attempt to free an unallocated block,  ");
+       goto bad;
+       }
+if(p[-1]>256 || p[-1]<0)
+       {
+       fprintf(diagfile, "attempted to free a block of length %u\n",p[-1]);
+  bad: fprintf(diagfile, "location %o    ", p);
+       fprintf(diagfile, "mem=%o   lastused=%o\n", mem, mem+nmemused);
+/*     if(p[-1]>256 || p[-1]<0)        */
+               fatal("");
+       }
+totfreed += p[-1];
+nmemavail += p[-1]+1;
+p[-1] = - p[-1];
+;
+}
+
+
+prhisto()
+{
+int i;
+fprintf(diagfile, "allocation histogram:\n%4d big blocks\n",histo[0]);
+for(i=1;i<NHISTO;++i)
+       if(histo[i]>0) fprintf(diagfile, "%4d %2d-word blocks\n", histo[i],i);
+}
+
+
+
+
+
+ptr allexpblock()
+{
+ptr p;
+
+if(expblocks)
+       {
+       p = expblocks;
+       expblocks = expblocks->leftp;
+       zeroout(p, sizeof(struct exprblock));
+       --nexpblocks;
+       return(p);
+       }
+else   return( ALLOC(exprblock) );
+}
+
+
+
+
+frexpblock(p)
+register ptr p;
+{
+if ( p[-1] != sizeof(struct exprblock)/sizeof(int) )
+       badtag("frexpblock", p->tag);
+if(nexpblocks < EXPRPOOL)
+       {
+       p->leftp = expblocks;
+       p->tag = 0;
+       expblocks = p;
+       ++nexpblocks;
+       }
+else   cfree(p);
+}
+
+
+
+
+ptr allexcblock()
+{
+ptr p;
+
+if(excblocks)
+       {
+       p = excblocks;
+       excblocks = excblocks->leftp;
+       zeroout(p, sizeof(struct execblock));
+       --nexcblocks;
+       return(p);
+       }
+else   return( ALLOC(execblock) );
+}
+
+
+
+
+frexcblock(p)
+register ptr p;
+{
+if( p[-1] != sizeof(struct execblock)/sizeof(int) )
+       fatal1("invalid frexcblock block of size %d", p[-1]);
+if(nexcblocks < EXECPOOL)
+       {
+       p->leftp = excblocks;
+       p->tag = 0;
+       excblocks = p;
+       ++nexcblocks;
+       }
+else   cfree(p);
+}
+
+
+
+zeroout(p,n)
+register int *p;
+int n;
+{
+register int *pn;
+
+pn = p + (n + sizeof(int)-1)/sizeof(int);
+
+while(p < pn)
+       *p++ = 0;
+}
+
+
+
+
+frchain(p0)
+register chainp *p0;
+{
+register ptr p;
+
+if(p0==0 || *p0==0) return;
+
+for(p = *p0 ; p->nextp ; p = p->nextp)
+       p->datap = 0;
+
+p->datap = 0;
+p->nextp = chains;
+chains = *p0;
+*p0 = 0;
+}
+
+
+chainp mkchain(p,q)
+ptr p, q;
+{
+register chainp r;
+
+if(chains)
+       {
+       r = chains;
+       chains = chains->nextp;
+       }
+else   r = ALLOC(chain);
+r->datap = p;
+r->nextp = q;
+return(r);
+}
+
+
+
+
+prmem()
+{
+register int i,j;
+
+fprintf(diagfile, "Memory dump:\n");
+
+for(i=0 ; i<nmemused ; )
+       {
+       j = mem[i];
+       fprintf(diagfile, "Loc %6o = Word %5d   ", mem+i, i);
+       if(j<0)
+               fprintf(diagfile, "Idle block length %4d   ", j = -j);
+       else    fprintf(diagfile, "Busy block length %4d   ", j);
+       fprintf(diagfile, "tag %3d", mem[i+1].tag);
+       if(mem[i+1].tag==TNAME && mem[i+1].sthead!=0)
+               fprintf(diagfile, "   varname %s", mem[i+1].sthead->namep);
+       else if(j==2)
+               fprintf(diagfile, "  chain %o %o", mem[i+1], mem[i+2]);
+       else if (mem[i+1].tag > TIOSTAT)
+               {
+               char *s, *sn;
+               s = & mem[i+1];
+               sn = s + 12;
+               fprintf(diagfile, "  \"");
+               while(*s!= '\0' && s<sn)
+                       putc(*s++, diagfile);
+               }
+       fprintf(diagfile, "\n");
+
+       i += j+1;
+       }
+}
diff --git a/usr/src/cmd/efl/blklab.c b/usr/src/cmd/efl/blklab.c

new file mode 100644 (file)

index 0000000..ea2f890
--- /dev/null
+++ b/usr/src/cmd/efl/blklab.c
@@ -0,0 +1,354 @@
+#include "defs"
+
+
+hide(p)
+ptr p;
+{
+warn1("Name %s hidden by a new declaration", p->namep);
+hidlist = mkchain(p->varp, hidlist);
+p->varp = 0;
+++nhid[blklevel];
+}
+
+
+
+/*  remove all symbol table entries in terminated block,
+    revive old hidden names
+*/
+unhide()
+{
+chainp p;
+register ptr q;
+register ptr v;
+register struct stentry *s;
+struct stentry **hp;
+
+for(hp = hashtab ; hp<hashend ; ++hp)
+       if(s = *hp)
+               {
+               if( (v = s->varp) && v->blklevel == blklevel)
+                       {
+                       if(v->tag==TLABEL)
+                               if(blklevel <= 1)
+                                       {
+                                       if(v->labdefined==0)
+                                               laberr("%s never defined",
+                                                       v->sthead->namep);
+                                       s->varp = 0;
+                                       }
+                               else    { /* move label out a level */
+                                       if(v->labdefined)
+                                               v->labinacc = 1;
+                                       v->blklevel--;
+                                       ++ndecl[blklevel-1];
+                                       }
+                       else    {
+                               if(v->tag == TNAME)
+                                       {
+                                       TEST fprintf(diagfile,"gone(%s) level %d\n",
+                                               s->namep, blklevel);
+                                       gonelist = mkchain(s->varp, gonelist);
+                                       }
+
+                               else if(v->tag!=TSTRUCT)
+                                       {
+                                       ++ndecl[blklevel];
+                                       if(v->tag==TDEFINE)
+                                               frdef(v);
+                                       }
+                               s->varp = 0;
+                               }
+                       --ndecl[blklevel];
+                       }
+               }
+
+for( p=hidlist  ;  p && ((v = (q=p->datap)->sthead)->varp==NULL) ; p=hidlist )
+       {
+       v->varp = q;
+       v->tag = q->tag;
+       v->subtype = q->subtype;
+       if(v->blklevel > q->blklevel)
+               v->blklevel = q->blklevel;
+       hidlist = p->nextp;
+       p->nextp = CHNULL;
+       frchain(&p);
+       --nhid[blklevel];
+TEST fprintf(diagfile, "unhide(%s), blklevel %d\n", v->namep, v->blklevel);
+       }
+if(ndecl[blklevel] != 0)
+       {
+       sprintf(msg, "%d declarations leftover at block level %d",
+               ndecl[blklevel], blklevel);
+       fatal(msg);
+       }
+if(nhid[blklevel] != 0)
+       fatal("leftover hidden variables");
+}
+
+
+
+
+ptr bgnexec()
+{
+register ptr p;
+
+p = allexcblock();
+p->tag = TEXEC;
+p->prevexec = thisexec;
+if(thisexec && thisexec->copylab)
+       {
+       p->labelno = thisexec->labelno;
+       p->labused = thisexec->labused;
+       thisexec->labelno = 0;
+       }
+thisexec = p;
+return(p);
+}
+
+
+ptr addexec()
+{
+register ptr p;
+register ptr q;
+
+q = thisexec;
+p = q->prevexec;
+
+if(q->temps)
+       tempvarlist = hookup(q->temps, tempvarlist);
+
+p->brnchend = q->brnchend;
+p->nftnst += q->nftnst;
+p->labeled |= q->labeled;
+p->uniffable |= q->uniffable;
+
+if(q->labelno && !(q->labused))
+       {
+       if(q->nxtlabno)
+               exnull();
+       else q->nxtlabno = q->labelno;
+       }
+
+thisexec = p;
+
+if(q->nxtlabno)
+       {
+       if(p->labelno && !(p->labused))
+               exnull();
+       p->labelno = q->nxtlabno;
+       p->labused = 0;
+       }
+
+frexcblock(q);
+return(p);
+}
+
+
+
+pushctl(t,vp)
+int t;
+register ptr vp;
+{
+register ptr q;
+ptr p;
+int junk;
+
+q = allexcblock();
+q->tag = TCONTROL;
+q->subtype = t;
+q->loopvar = vp;
+q->prevctl = thisctl;
+thisctl = q;
+
+switch(t)
+       {
+       case STSWITCH:
+               q->xlab = nextlab();
+               q->nextlab = 0;
+               exgoto(q->xlab);
+               ncases = -1;
+               break;
+
+       case STFOR:
+               exlab(0);
+               q->nextlab = nextlab();
+               q->xlab = nextlab();
+               break;
+
+       case STWHILE:
+               q->nextlab = thislab();
+               if(vp)
+                       exifgo( mknode(TNOTOP,OPNOT,vp,PNULL),
+                               q->breaklab = nextlab() );
+               else    thisexec->copylab = 1;
+               break;
+
+       case STREPEAT:
+               exnull();
+               q->xlab = thislab();
+               thisexec->copylab = 1;
+               junk = nextindif();
+               indifs[junk] = 0;
+               q->indifn = junk;
+               indifs[q->indifn] = q->xlab;
+               break;
+
+       case STDO:
+               q->nextlab = nextlab();
+               exlab(0);
+               putic(ICKEYWORD,FDO);
+               putic(ICLABEL, q->nextlab);
+               putic(ICBLANK, 1);
+               p = mknode(TASGNOP,OPASGN,vp->dovar,vp->dopar[0]);
+               prexpr(p);
+               frexpr(p);
+               putic(ICOP, OPCOMMA);
+               prexpr(vp->dopar[1]);
+               frexpr(vp->dopar[1]);
+               if(vp->dopar[2])
+                       {
+                       putic(ICOP, OPCOMMA);
+                       prexpr(vp->dopar[2]);
+                       frexpr(vp->dopar[2]);
+                       }
+               cfree(vp);
+               break;
+
+       case STIF:
+               exif(vp);
+               thisexec->nftnst = 0;
+               break;
+
+       default:
+               fatal1("pushctl: invalid control block type %d", t);
+       }
+
+++ctllevel;
+}
+
+
+
+popctl()
+{
+register ptr p;
+ptr newp;
+chainp q;
+int first, deflabno, blab, cmin, cmax, range, caseval, optcase;
+int labp[MAXSWITCH];
+
+if(thisctl == 0)
+       fatal("empty control stack popped");
+
+switch(thisctl->subtype)
+       {
+       case STSWITCH:
+/*             if(thisexec->brnchend == 0)     */
+                       {
+                       if(thisctl->breaklab == 0)
+                               thisctl->breaklab = nextlab();
+                       exgoto(thisctl->breaklab);
+                       }
+               exlab(thisctl->xlab);
+               deflabno = 0;
+               first = YES;
+               optcase = (thisctl->loopvar->vtype == TYINT);
+
+               for(p=thisctl->loopctl ; p!=0 ; p = p->nextcase)
+                       if(p->labdefined == 0)
+                               {
+                               laberr("undefined case label", CNULL);
+                               optcase = NO;
+                               }
+                       else if(p->casexpr == 0)
+                               deflabno = p->labelno;
+                       else if( isicon(p->casexpr, &caseval))
+                               {
+                               if(first)
+                                       {
+                                       first = NO;
+                                       cmin = cmax = caseval;
+                                       }
+                               else    {
+                                       if(caseval < cmin)
+                                               cmin = caseval;
+                                       if(caseval > cmax)
+                                               cmax = caseval;
+                                       }
+                               ++ncases;
+                               }
+                       else    optcase = NO;
+
+               range = cmax - cmin + 1;
+               if(optcase && ncases>2 && range<2*ncases && range<MAXSWITCH)
+                       {
+                       register int i;
+                       for(i=0; i<range ; ++i)
+                               labp[i] = 0;
+                       for(p=thisctl->loopctl ; p!=0 ; p = p->nextcase)
+                               if(p->labdefined && p->casexpr)
+                                       {
+                                       isicon(p->casexpr, &caseval);
+                                       frexpr(p->casexpr);
+                                       labp[caseval-cmin] = p->labelno;
+                                       }
+                       
+                       q = CHNULL;
+                       blab = (deflabno ? deflabno : thisctl->breaklab);
+                       for(i=range-1 ; i>=0 ; --i)
+                               q = mkchain(labp[i] ? labp[i] : blab, q);
+                       excompgoto(q, mknode(TAROP,OPPLUS, mkint(1-cmin),
+                                    cpexpr(thisctl->loopvar) ));
+                       }
+               else    {
+                       for(p=thisctl->loopctl ; p!=0 ; p = p->nextcase)
+                               if(p->labdefined && p->casexpr)
+                                       exifgo( mknode(TRELOP,OPEQ,
+                                          cpexpr(thisctl->loopvar),p->casexpr),
+                                          p->labelno);
+                       }
+               if(deflabno)
+                       exgoto(deflabno);
+
+               for(p = thisctl->loopctl ; p; p = newp)
+                       {
+                       newp = p->nextcase;
+                       cfree(p);
+                       }
+               thisctl->loopctl = NULL;
+               break;
+
+       case STFOR:
+               exgoto(thisctl->nextlab);
+               break;
+
+       case STWHILE:
+               exgoto(thisctl->nextlab);
+               break;
+
+       case STREPEAT:
+               break;
+
+       case STDO:
+               exnull();
+               exlab(thisctl->nextlab);
+               putic(ICKEYWORD,FCONTINUE);
+               break;
+
+       case STIF:
+               break;
+
+       case STPROC:
+               break;
+
+       default:
+               fatal1("popctl: invalid control block type %d",
+                       thisctl->subtype);
+       }
+
+if(thisctl->breaklab != 0)
+       thisexec->nxtlabno = thisctl->breaklab;
+p = thisctl->prevctl;
+frexcblock(thisctl);
+thisctl = p;
+--ctllevel;
+}
diff --git a/usr/src/cmd/efl/dcl.c b/usr/src/cmd/efl/dcl.c

new file mode 100644 (file)

index 0000000..af640c1
--- /dev/null
+++ b/usr/src/cmd/efl/dcl.c
@@ -0,0 +1,473 @@
+#include "defs"
+
+
+static char mess[ ] = "inconsistent attributes";
+
+attatt(a1 , a2)
+register struct atblock *a1, *a2;
+{
+#define MERGE1(x) {if(a1->x==0) a1->x = a2->x; else if(a2->x!=0 && a1->x!=a2->x) dclerr(mess,"x"+2); }
+
+MERGE1(attype);
+MERGE1(attypep);
+MERGE1(atprec);
+MERGE1(atclass);
+MERGE1(atext);
+MERGE1(atcommon);
+MERGE1(atdim);
+
+if(a1->atprec!=0 && (a1->attype==TYREAL || a1->attype==TYCOMPLEX) )
+       a1->attype += (TYLREAL-TYREAL);
+
+cfree(a2);
+}
+
+
+
+attvars(a , v)
+register struct atblock * a;
+register chainp v;
+{
+register chainp p;
+
+for(p=v; p!=0 ; p = p->nextp)
+       attvr1(a, p->datap);
+
+if(a->attype == TYFIELD)
+       cfree(a->attypep);
+else if(a->attype == TYCHAR)
+       frexpr(a->attypep);
+
+cfree(a);
+}
+
+#define MERGE(x,y) {if(v->y==0) v->y = a->x; else if(a->x!=0 && a->x!=v->y) dclerr(mess,"x"+2); }
+
+
+
+
+
+attvr1(a, v)
+register struct atblock * a;
+register struct varblock * v;
+{
+register chainp p;
+
+if(v->vdcldone)
+       {
+       dclerr("attempt to declare variable after use", v->sthead->namep);
+       return;
+       }
+v->vdclstart = 1;
+if(v->vclass == CLMOS)
+       dclerr("attempt to redefine structure member", v->sthead->namep);
+if (v->vdim == 0)
+       v->vdim = a->atdim;
+else if(!eqdim(a->atdim, v->vdim))
+       dclerr("inconsistent dimensions", v->sthead->namep);
+if(v->vprec == 0)
+       v->vprec = a->atprec;
+
+MERGE(attype,vtype);
+
+if(v->vtypep == 0)
+       {
+       if(a->attypep != 0)
+               if(a->attype == TYFIELD)
+                       {
+                       v->vtypep = ALLOC(fieldspec);
+                       cpblock(a->attypep, v->vtypep, sizeof(struct fieldspec));
+                       }
+               else if(a->attype == TYCHAR)
+                       v->vtypep = cpexpr(a->attypep);
+               else    v->vtypep = a->attypep;
+       else if(a->attypep!=0 && a->attypep!=v->vtypep)
+               dclerr("inconsistent attributes", "typep");
+       }
+
+if(v->vprec!=0 && (v->vtype==TYREAL || v->vtype==TYCOMPLEX) )
+       v->vtype += (TYLREAL-TYREAL);
+
+if(a->atcommon)
+       if(v->vclass !=  0)
+               dclerr("common variable already in common, argument list, or external",
+                       v->sthead->namep);
+       else    {
+               if(blklevel != a->atcommon->blklevel)
+                       dclerr("inconsistent common block usage", "");
+               for(p = &(a->atcommon->comchain) ; p->nextp!=0 ; p = p->nextp) ;
+               p->nextp = mkchain(v, PNULL);
+       }
+
+if(a->atext!=0 && v->vext==0)
+       {
+       v->vext = 1;
+       extname(v);
+       }
+else if(a->atclass == CLVALUE)
+       if(v->vclass==CLARG || v->vclass==CLVALUE)
+               v->vclass = CLVALUE;
+       else dclerr("cannot value a non-argument variable",v->sthead->namep);
+else  MERGE(atclass,vclass);
+if(v->vclass==CLCOMMON || v->vclass==CLVALUE || v->vclass==CLAUTO)
+       setvproc(v, PROCNO);
+}
+
+
+
+
+
+eqdim(a,b)
+register ptr a, b;
+{
+if(a==0 || b==0 || a==b)  return(1);
+
+a = a->datap;
+b = b->datap;
+
+while(a!=0 && b!=0)
+       {
+       if(!eqexpr(a->lowerb,b->lowerb) || !eqexpr(a->upperb,b->upperb))
+               return(0);
+
+       a = a->nextp;
+       b = b->nextp;
+       }
+
+return( a == b );
+}
+
+
+eqexpr(a,b)
+register ptr a, b;
+{
+if(a==b) return(1);
+if(a==0 || b==0) return(0);
+if(a->tag!=b->tag || a->subtype!=b->subtype)
+       return(0);
+
+switch(a->tag)
+       {
+case TCONST:
+       return( equals(a->leftp, b->leftp) );
+
+case TNAME:
+       return( a->sthead ==  b->sthead );
+
+case TLIST:
+       a = a->leftp;
+       b = b->leftp;
+
+       while(a!=0 && b!=0)
+               {
+               if(!eqexpr(a->datap,b->datap))
+                       return(0);
+               a = a->nextp;
+               b = b->nextp;
+               }
+       return( a == b );
+
+case TAROP:
+case TASGNOP:
+case TLOGOP:
+case TRELOP:
+case TCALL:
+case TREPOP:
+       return(eqexpr(a->leftp,b->leftp) && eqexpr(a->rightp,b->rightp));
+
+case TNOTOP:
+case TNEGOP:
+       return(eqexpr(a->leftp,b->leftp));
+
+default:
+       badtag("eqexpr", a->tag);
+       }
+/* NOTREACHED */
+}
+
+
+
+setimpl(type, c1, c2)
+int type;
+register int c1, c2;
+{
+register int i;
+
+if(c1<'a' || c2<c1 || c2>'z')
+       dclerr("bad implicit range", CNULL);
+else if(type==TYUNDEFINED || type>TYLCOMPLEX)
+       dclerr("bad type in implicit statement", CNULL);
+else
+       for(i = c1 ; i<=c2 ; ++i)
+               impltype[i-'a'] = type;
+}
+\f
+doinits(p)
+register ptr p;
+{
+register ptr q;
+
+for( ; p ; p = p->nextp)
+       if( (q = p->datap)->vinit)
+               {
+               mkinit(q, q->vinit);
+               q->vinit = 0;
+               }
+}
+
+
+
+
+mkinit(v, e)
+register ptr v;
+register ptr e;
+{
+if(v->vdcldone == 0)
+       dclit(v);
+
+swii(idfile);
+
+if(v->vtype!=TYCHAR && v->vtypep)
+       dclerr("structure initialization", v->sthead->namep);
+else if(v->vdim==NULL || v->vsubs!=NULL)
+       {
+       if(e->tag==TLIST && (v->vtype==TYCOMPLEX || v->vtype==TYLCOMPLEX) )
+               e = compconst(e);
+       valinit(v, e);
+       }
+else
+       arrinit(v,e);
+
+swii(icfile);
+
+frexpr(e);
+}
+
+
+
+
+
+valinit(v, e)
+register ptr v;
+register ptr e;
+{
+static char buf[4] = "1hX";
+int vt;
+
+vt = v->vtype;
+/*check for special case of one-character initialization of
+  non-character datum
+*/
+if(vt==TYCHAR || e->vtype!=TYCHAR || !isconst(e) || strlen(e->leftp)!=1)
+       {
+       e = simple(RVAL, coerce(vt,e) );
+       if(e->tag == TERROR)
+               return;
+       if( ! isconst(e) )
+               {
+               dclerr("nonconstant initializer", v->sthead->namep);
+               return;
+               }
+       }
+if(vt == TYCHAR)
+       {
+       charinit(v, e->leftp);
+       return;
+       }
+prexpr( simple(LVAL,v) );
+putic(ICOP,OPSLASH);
+if(e->vtype != TYCHAR)
+       prexpr(e);
+else if(strlen(e->leftp) == 1)
+       {
+       buf[2] = e->leftp[0];
+       putsii(ICCONST, buf);
+       }
+else   dclerr("character initialization of nonchar", v->sthead->namep);
+putic(ICOP,OPSLASH);
+putic(ICMARK,0);
+}
+
+
+
+arrinit(v, e)
+register ptr v;
+register ptr e;
+{
+struct exprblock *listinit(), *firstelt(), *nextelt();
+ptr arrsize();
+
+if(e->tag!=TLIST && e->tag!=TREPOP)
+       e = mknode(TREPOP, 0, arrsize(v), e);
+if( listinit(v, firstelt(v), e) )
+       warn("too few initializers");
+if(v->vsubs)
+       {
+       frexpr(v->vsubs);
+       v->vsubs = NULL;
+       }
+}
+
+
+
+struct exprblock *listinit(v, subs, e)
+register struct varblock *v;
+struct exprblock *subs;
+register ptr e;
+{
+struct varblock *vt;
+register chainp p;
+int n;
+struct varblock *subscript();
+struct exprblock *nextelt();
+
+switch(e->tag)
+       {
+       case TLIST:
+               for(p = e->leftp; p; p = p->nextp)
+                       {
+                       if(subs == NULL)
+                               goto toomany;
+                       subs = listinit(v, subs, p->datap);
+                       }
+               return(subs);
+
+       case TREPOP:
+               if( ! isicon(e->leftp, &n) )
+                       {
+                       dclerr("nonconstant repetition factor");
+                       return(subs);
+                       }
+               while(--n >= 0)
+                       {
+                       if(subs == NULL)
+                               goto toomany;
+                       subs = listinit(v, subs, e->rightp);
+                       }
+               return(subs);
+
+       default:
+               if(subs == NULL)
+                       goto toomany;
+               vt = subscript(cpexpr(v), cpexpr(subs));
+               valinit(vt, e);
+               frexpr(vt);
+               return( nextelt(v,subs) );
+
+       }
+
+toomany:
+       dclerr("too many initializers", NULL);
+       return(NULL);
+}
+
+
+
+
+charinit(v,e)
+ptr v;
+char *e;
+{
+register char *bp;
+char buf[50];
+register int i, j;
+int nwd, nch;
+
+v = cpexpr(v);
+if(v->vsubs == 0)
+       v->vsubs = mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL);
+
+nwd = ceil( nch = conval(v->vtypep) , tailor.ftnchwd);
+sprintf(buf,"%dh", tailor.ftnchwd);
+for(bp = buf ; *bp ; ++bp )
+       ;
+
+
+for(i = 0; i<nwd ; ++i)
+       {
+       if(i > 0) v->vsubs->leftp->datap = 
+               mknode(TAROP,OPPLUS, v->vsubs->leftp->datap, mkint(1));
+       prexpr( v = simple(LVAL,v) );
+
+       for(j = 0 ; j<tailor.ftnchwd && *e!='\0' && nch-->0 ; )
+               bp[j++] = *e++;
+       while(j < tailor.ftnchwd)
+               {
+               bp[j++] = ' ';
+               nch--;
+               }
+       bp[j] = '\0';
+
+       putic(ICOP,OPSLASH);
+       putsii(ICCONST, buf);
+       putic(ICOP,OPSLASH);
+       putic(ICMARK,0);
+       }
+
+frexpr(v);
+}
+
+
+
+
+
+
+
+struct exprblock *firstelt(v)
+register struct varblock *v;
+{
+register struct dimblock *b;
+register chainp s;
+ptr t;
+int junk;
+
+if(v->vdim==NULL || v->vsubs!=NULL)
+       fatal("firstelt: bad argument");
+s = NULL;
+for(b = v->vdim->datap ; b; b = b->nextp)
+       {
+       t = (b->lowerb ? cpexpr(b->lowerb) : mkint(1) );
+       s = hookup(s, mkchain(t,CHNULL) );
+       if(!isicon(b->upperb,&junk) || (b->lowerb && !isicon(b->lowerb,&junk)) )
+               dclerr("attempt to initialize adjustable array",
+                       v->sthead->namep);
+       }
+return( mknode(TLIST, 0, s, PNULL) );
+}
+
+
+
+
+struct exprblock *nextelt(v,subs)
+struct varblock *v;
+struct exprblock *subs;
+{
+register struct dimblock *b;
+register chainp *s;
+int sv;
+
+if(v == NULL)
+       return(NULL);
+
+b = v->vdim->datap;
+s = subs->leftp;
+
+while(b && s)
+       {
+       sv = conval(s->datap);
+       frexpr(s->datap);
+       if( sv < conval(b->upperb) )
+               {
+               s->datap =mkint(sv+1);
+               return(subs);
+               }
+       s->datap = (b->lowerb ? cpexpr(b->lowerb) : mkint(1) );
+
+       b = b->nextp;
+       s = s->nextp;
+       }
+
+if(b || s)
+       fatal("nextelt: bad subscript count");
+return(NULL);
+}
diff --git a/usr/src/cmd/efl/dclgen.c b/usr/src/cmd/efl/dclgen.c

new file mode 100644 (file)

index 0000000..8509506
--- /dev/null
+++ b/usr/src/cmd/efl/dclgen.c
@@ -0,0 +1,345 @@
+#include "defs"
+
+#define DOCOMMON 1
+#define NOCOMMON 0
+
+dclgen()
+{
+register ptr p, q;
+ptr q1;
+chainp *y, z;
+register struct stentry *s;
+struct stentry **hp;
+int first;
+int i, j;
+extern char *types[];
+char *sp;
+
+/*   print procedure statement and argument list */
+
+for(p = prevcomments ; p ; p = p->nextp)
+       {
+       sp = p->datap;
+       fprintf(codefile, "%s\n", sp+1);
+       cfree(sp);
+       }
+frchain(&prevcomments);
+
+if(tailor.procheader)
+       fprintf(codefile, "%s\n", tailor.procheader);
+
+if(procname)
+       {
+       p2str("      ");
+       if(procname->vtype==TYSUBR || procname->vtype==TYUNDEFINED)
+               p2key(FSUBROUTINE);
+       else    {
+               p2str(types[procname->vtype]);
+               p2key(FFUNCTION);
+               }
+
+       p2str(procname->sthead->namep);
+       }
+else if(procclass == PRBLOCK)
+       {
+       p2stmt(0);
+       p2key(FBLOCKDATA);
+       }
+else   {
+       p2str("c  main program");
+       if(tailor.ftnsys == CRAY)
+               {
+               p2stmt(0);
+               p2key(FPROGRAM);
+               }
+       }
+
+if(thisargs)
+       {
+       p2str( "(" );
+       first = 1;
+
+       for(p = thisargs ; p ; p = p->nextp)
+               if( (q=p->datap)->vextbase)
+                       {
+                       if(first) first = 0;
+                       else p2str(", ");
+                       p2str(ftnames[q->vextbase]);
+                       }
+               else    for(i=0 ; i<NFTNTYPES ; ++i)
+                               if(j = q->vbase[i])
+                                       {
+                                       if(first) first = 0;
+                                       else p2str( ", " );
+                                       p2str(ftnames[j]);
+                                       }
+       p2str( ")" );
+       }
+
+/* first put out declarations of variables that are used as
+   adjustable dimensions
+*/
+
+y = 0;
+z = & y;
+for(hp = hashtab ; hp<hashend; ++hp)
+       if( *hp && (q = (*hp)->varp) )
+               if(q->tag==TNAME && q->vadjdim && q!=procname)
+                       z = z->nextp = mkchain(q,CHNULL);
+
+dclchain(y, NOCOMMON);
+frchain(&y);
+
+/* then declare the rest of the arguments */
+z = & y;
+for(p = thisargs ; p ; p = p->nextp)
+       if(p->datap->vadjdim == 0)
+               z = z->nextp = mkchain(p->datap,CHNULL);
+dclchain(y, NOCOMMON);
+frchain(&y);
+frchain(&thisargs);
+
+
+/* now put out declarations for common blocks */
+for(p = commonlist ; p ; p = p->nextp)
+       prcomm(p->datap);
+
+TEST fprintf(diagfile, "\nend of common declarations");
+z = &y;
+
+/* next the other variables that are in the symbol table */
+
+for(hp = hashtab ; hp<hashend ; ++hp)
+       if( *hp && (q = (*hp)->varp) )
+               if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON &&
+                   q->vclass!=CLARG && q!=procname &&
+                   (tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) )
+                       z = z->nextp = mkchain(q,CHNULL);
+
+dclchain(y, NOCOMMON);
+frchain(&y);
+
+TEST fprintf(diagfile, "\nend of symbol table, start of gonelist");
+
+/* now declare variables that are no longer in the symbol table */
+
+dclchain(gonelist, NOCOMMON);
+
+TEST fprintf(diagfile, "\nbeginning of hidlist");
+dclchain(hidlist, NOCOMMON);
+
+dclchain(tempvarlist, NOCOMMON);
+
+
+/* finally put out equivalence statements that are generated 
+   because of structure and character variables
+*/
+for(p = genequivs; p ; p = p->nextp)
+       {
+       q = p->datap;
+       p2stmt(0);
+       first = 1;
+       p2key(FEQUIVALENCE);
+       p2str( "(" );
+       for(i=0; i<NFTNTYPES; ++i)
+               if(q->vbase[i])
+                       {
+                       if(first) first = 0;
+                       else p2str( ", " );
+                       p2str(ftnames[ q->vbase[i] ]);
+                       p2str( "(1" );
+                       if(q1 = q->vdim)
+                               for(q1 = q1->datap; q1 ; q1 = q1->nextp)
+                                       p2str( ",1" );
+                       p2str( ")" );
+                       }
+       p2str( ")" );
+       }
+frchain(&genequivs);
+}
+
+
+
+
+prcomm(p)
+register ptr p;
+{
+register int first;
+register ptr q;
+
+p2stmt(0);
+p2key(FCOMMON);
+p2str( "/" );
+p2str(p->comname);
+p2str("/ ");
+first = 1;
+for(q = p->comchain ; q; q = q->nextp)
+       {
+       if(first) first=0;
+       else p2str(", ");
+       prname(q->datap);
+       }
+dclchain(p->comchain, DOCOMMON);
+}
+
+
+
+prname(p)
+register ptr p;
+{
+register int i;
+
+switch(p->tag)
+       {
+       case TCONST:
+               p2str(p->leftp);
+               return;
+
+       case TNAME:
+               if( ! p->vdcldone )
+                       if(p->blklevel == 1)
+                               dclit(p);
+                       else    mkftnp(p);
+               for(i=0; i<NFTNTYPES ; ++i)
+                       if(p->vbase[i])
+                               {
+                               p2str(ftnames[p->vbase[i]]);
+                               return;
+                               }
+               fatal1("prname: no fortran types for name %s",
+                       p->sthead->namep);
+
+       case TFTNBLOCK:
+               for(i=0; i<NFTNTYPES ; ++i)
+                       if(p->vbase[i])
+                               {
+                               p2str(ftnames[p->vbase[i]]);
+                               return;
+                               }
+               return;
+
+       default:
+               badtag("prname", p->tag);
+       }
+}
+
+
+
+
+dclchain(chp, okcom)
+ptr chp;
+int okcom;
+{
+extern char *ftntypes[];
+register ptr pn, p;
+register int i;
+int first, nline;
+ptr q,v;
+int ntypes;
+int size,align,mask;
+int subval;
+
+nline = 0;
+for(pn = chp ; pn ; pn = pn->nextp)
+       {
+       p = pn->datap;
+       if( (p->tag==TNAME || p->tag==TTEMP) && p->vext!=0)
+               {
+               if(nline%NAMESPERLINE == 0)
+                       {
+                       p2stmt(0);
+                       p2key(FEXTERNAL);
+                       }
+               else    p2str(", ");
+               ++nline;
+               p2str(ftnames[p->vextbase]);
+               }
+       }
+
+
+for(pn = chp ; pn ; pn = pn->nextp)
+       {
+       p = pn->datap;
+       if( (p->tag==TNAME || p->tag==TTEMP) &&
+           p->vtype==TYSTRUCT && p->vclass!=CLARG)
+               {
+               ntypes = 0;
+               for(i=0; i<NFTNTYPES; ++i)
+                       if(p->vbase[i])
+                               ++ntypes;
+               if(ntypes > 1)
+                       genequivs = mkchain(p, genequivs);
+               }
+       }
+
+for(i=0; i<NFTNTYPES; ++i)
+       {
+       nline = 0;
+       for(pn = chp; pn ; pn = pn->nextp)
+               {
+               p = pn->datap;
+               if( (p->tag==TNAME || p->tag==TTEMP) &&
+                   p->vtype!=TYSUBR && p->vbase[i]!=0 &&
+                   (okcom || p->vclass!=CLCOMMON) )
+                       {
+                       if(nline%NAMESPERLINE == 0)
+                               {
+                               p2stmt(0);
+                               p2str(ftntypes[i]);
+                               }
+                       else    p2str( ", " );
+                       ++nline;
+                       p2str(ftnames[p->vbase[i]]);
+                       first = -1;
+               
+                       if(p->vtype==TYCHAR || p->vtype==TYSTRUCT ||
+                          (p->vtype==TYLCOMPLEX && tailor.lngcxtype==NULL))
+                               {
+                               p2str( "(" );
+                               sizalign(p, &size,&align,&mask);
+                               p2int( size/tailor.ftnsize[i] );
+                               first = 0;
+                               }
+                       else if(p->vdim)
+                               {
+                               p2str( "(" );
+                               first = 1;
+                               }
+                       if(first >=0)
+                               {
+                               if(q = p->vdim)
+                                   for(q = q->datap ; q ; q = q->nextp)
+                                       {
+                                       if(q->upperb == 0)
+                                               {
+                                               q->upperb = mkint(1);
+                                               if(q->lowerb)
+                                                       {
+                                                       frexpr(q->lowerb);
+                                                       q->lowerb = 0;
+                                                       }
+                                               }
+                                       else if(q->lowerb)
+                                               {
+                                               v = fold( mknode(TAROP,OPMINUS,
+                                                       mkint(1),cpexpr(q->lowerb)) );
+                                               v = fold( mknode(TAROP,OPPLUS,
+                                                       cpexpr(q->upperb),v) );
+                                               q->lowerb = 0;
+                                               q->upperb = v;
+                                               }
+                                       if(first) first = 0;
+                                       else p2str( ", " );
+                                       v = q->upperb = simple(RVAL,q->upperb);
+                                       if( (v->tag==TNAME && v->vclass==CLARG) ||
+                                           (isicon(v,&subval) && subval>0) )
+                                               prname(v);
+                                       else    dclerr("invalid array bound",
+                                               p->sthead->namep);
+                                       }
+                               p2str( ")" );
+                               }
+                       }
+               }
+       }
+}
diff --git a/usr/src/cmd/efl/defs b/usr/src/cmd/efl/defs

new file mode 100644 (file)

index 0000000..219277e
--- /dev/null
+++ b/usr/src/cmd/efl/defs
@@ -0,0 +1,671 @@
+#include "stdio.h"
+
+#define NO  0
+#define YES 1
+
+#define CNULL (char *) 0
+#define PNULL (ptr) 0
+#define CHNULL (chainp) 0
+
+#define HASHEDTABLE 1
+
+#define XL     6
+
+#define NFTNTYPES 7
+#define NEFLTYPES 13
+
+#define MEMSIZE 12240
+#define YYMAXDEPTH 250
+
+#define MAXSTNO 200
+#define MAXINCLUDEDEPTH 10
+#define MAXBLOCKDEPTH 30
+#define MAXINDIFS 150
+#define MAXFTNAMES 250
+#define MAXEFLNAMES 300
+#define MAXSWITCH 100
+
+#define EXECPOOL 20
+#define EXPRPOOL 40
+
+#define NAMESPERLINE 6
+
+#define LINESPACES 66
+#define INDENTSPACES 3
+
+typedef int *ptr;
+
+extern struct chain
+       {
+       ptr nextp;
+       ptr datap;
+       } ;
+
+typedef struct chain *chainp;
+
+extern int yylineno;
+extern int dumpic;
+extern int memdump;
+extern int dbgflag;
+extern int nowarnflag;
+extern int nocommentflag;
+extern int verbose;
+extern int dumpcore;
+#define TEST if(dbgflag)
+#define efgetc (efmacp?*efmacp++:getc(yyin))
+extern char msg[];
+
+#define UNIX 1
+#define GCOS 2
+#define GCOSBCD 3
+#define CRAY   4
+#define IBM    5
+
+#define FIELDMAX 32768.
+
+#define ALLOC(x) (struct x *) intalloc(sizeof(struct x))
+
+extern FILE *diagfile;
+extern FILE *codefile;
+extern FILE *yyin;
+extern FILE *fileptrs[];
+extern char *filenames[];
+extern char *basefile;
+extern int  filelines[];
+extern int filedepth;
+extern char *efmacp;
+extern char *filemacs[];
+extern int pushchars[];
+
+extern struct fileblock *iifilep;
+
+extern int mem[];
+extern unsigned int nmemused;
+extern long int totfreed;
+extern long int totalloc;
+
+extern int nhid[];
+extern int ndecl[];
+
+extern int indifs[];
+extern int nxtindif;
+extern int afterif;
+
+extern neflnames;
+
+extern int nftnch;
+extern int nftncont;
+
+extern char ftnames[MAXFTNAMES][7];
+extern int nftnames;
+extern int nftnm0;
+extern int impltype[];
+extern int ftnmask[];
+
+extern double fieldmax;
+extern int ftnefl[];
+extern int eflftn[];
+
+extern ptr thisexec;
+extern ptr thisctl;
+extern int pushlex;
+extern int igeol;
+extern int ateof;
+extern int eofneed;
+extern int forcerr;
+extern int comneed;
+extern int optneed;
+extern int defneed;
+extern int lettneed;
+extern int iobrlevel;
+
+extern int prevbg;
+
+extern chainp hidlist;
+extern chainp commonlist;
+extern chainp tempvarlist;
+extern chainp temptypelist;
+extern chainp gonelist;
+extern int blklevel;
+extern int ctllevel;
+extern int dclsect;
+extern int instruct;
+extern int inbound;
+extern int inproc;
+
+extern int ncases;
+extern ptr comments;
+extern ptr prevcomments;
+extern ptr genequivs;
+extern ptr arrays;
+extern ptr generlist;
+extern ptr knownlist;
+
+extern int graal;
+extern ptr procname;
+extern int procclass;
+extern ptr thisargs;
+
+extern int langopt;
+extern int dotsopt;
+extern int dbgopt;
+extern int dbglevel;
+
+extern int stnos[];
+extern int nxtstno;
+extern int constno;
+extern int labno;
+extern int nerrs;
+extern int nbad;
+extern int nwarns;
+
+struct headbits
+       {
+       unsigned int tag:8;
+       unsigned int subtype:8;
+       unsigned int blklevel:8;
+       };
+
+extern struct fileblock
+       {
+       FILE *fileptr;
+       char filename[20];
+       };
+
+extern struct fileblock *ibfile;
+extern struct fileblock *icfile;
+extern struct fileblock *idfile;
+extern struct fileblock *iefile;
+
+
+extern struct comentry
+       {
+       struct headbits header;
+       char comname[7];
+       long int comleng;
+       unsigned int cominit:2;
+       chainp comchain;
+       } ;
+
+extern struct stentry
+       {
+       struct headbits header;
+       char *namep;
+       ptr varp;
+       int hashval;
+       };
+
+extern struct stentry *hashtab[];
+extern struct stentry **hashend;
+
+extern struct typeblock
+       {
+       struct headbits header;
+       ptr sthead;
+       ptr strdesc;
+       int stralign;
+       int strsize;
+       int basetypes;
+       } ;
+
+extern struct keyblock
+       {
+       struct headbits header;
+       ptr sthead;
+       } ;
+
+
+extern struct varblock
+       {
+       struct headbits header;
+       ptr sthead;
+       ptr vinit;
+               unsigned int vadjdim:1;
+               unsigned int vdcldone:1;
+               unsigned int vdclstart:1;
+               unsigned int vnamedone:1;
+               unsigned int vprec:1;
+               unsigned int vext:1;
+               unsigned int vproc:2;
+               unsigned int needpar:1;
+               unsigned int vtype:4;
+               unsigned int vclass:3;
+       ptr vtypep;
+       ptr vdim;
+       ptr vsubs;
+       ptr voffset;
+       int vextbase;
+       int vbase[NFTNTYPES];
+       } ;
+
+extern struct atblock
+       {
+       int atprec;
+       int attype;
+       int atext;
+       int atclass;
+       ptr attypep;
+       ptr atcommon;
+       ptr atdim;
+       } ;
+
+extern struct dimblock
+       {
+       ptr nextp;
+       ptr lowerb;
+       ptr upperb;
+       } ;
+
+extern struct exprblock        /* must be same size as varblock */
+       {
+       struct headbits header;
+       ptr leftp;
+       ptr rightp;
+               unsigned int vadjdim:1;
+               unsigned int vdcldone:1;
+               unsigned int vdclstart:1;
+               unsigned int vnamedone:1;
+               unsigned int vprec:1;
+               unsigned int vext:1;
+               unsigned int vproc:2;
+               unsigned int needpar:1;
+               unsigned int vtype:4;
+               unsigned int vclass:3;
+       ptr vtypep;
+       ptr vdim;
+       ptr vsubs;
+       ptr voffset;
+       int vextbase;
+       int vbase[NFTNTYPES];
+       } ;
+
+
+extern struct execblock
+       {
+       struct headbits header;
+       ptr temps;
+       int labelno;
+               unsigned int uniffable:1;
+               unsigned int brnchend:1;
+               unsigned int labeled:1;
+               unsigned int copylab:1;
+               unsigned int labdefined:1;
+               unsigned int labused:1;
+               unsigned int labinacc:1;
+       ptr execdesc;
+       ptr prevexec;
+       int nxtlabno;
+       int nftnst;
+       } ;
+
+
+extern struct ctlblock /* must be same size as execblock */
+       {
+       struct headbits header;
+       ptr loopvar;
+       ptr loopctl;
+       ptr prevctl;
+       int nextlab;
+       int breaklab;
+       int xlab;
+       int indifn;
+       } ;
+
+extern struct caseblock
+       {
+       struct headbits header;
+       ptr nextcase;
+       int labelno;
+               unsigned int uniffable:1;
+               unsigned int brnchend:1;
+               unsigned int labeled:1;
+               unsigned int copylab:1;
+               unsigned int labdefined:1;
+               unsigned int labused:1;
+               unsigned int labinacc:1;
+       ptr casexpr;
+       } ;
+
+extern struct labelblock
+       {
+       struct headbits header;
+       ptr sthead;
+       int labelno;
+               unsigned int uniffable:1;
+               unsigned int brnchend:1;
+               unsigned int labeled:1;
+               unsigned int copylab:1;
+               unsigned int labdefined:1;
+               unsigned int labused:1;
+               unsigned int labinacc:1;
+       } ;
+
+extern struct defblock
+       {
+       struct headbits header;
+       ptr sthead;
+       char *valp;
+       } ;
+
+extern struct doblock
+       {
+       struct headbits header;
+       ptr dovar;
+       ptr dopar[3];
+       } ;
+
+extern struct fieldspec
+       {
+       struct headbits header;
+       ptr flbound;
+       ptr frange;
+       ptr frshift;
+       int fanymore;
+       } ;
+
+
+extern struct genblock
+       {
+       struct headbits header;
+       ptr nextgenf;
+       char *genname;
+       char *genfname[NEFLTYPES];
+       int genftype[NEFLTYPES];
+       } ;
+
+
+extern struct knownname
+       {
+       struct headbits header;
+       ptr nextfunct;
+       char *funcname;
+       int functype;
+       } ;
+
+extern struct iostblock
+       {
+       struct headbits header;
+       ptr leftp;      /* padding */
+       ptr right;      /* padding */
+               unsigned int vadjdim:1;
+               unsigned int vdcldone:1;
+               unsigned int vdclstart:1;
+               unsigned int vnamedone:1;
+               unsigned int vprec:1;
+               unsigned int vext:1;
+               unsigned int vproc:2;
+               unsigned int needpar:1;
+               unsigned int vtype:4;
+               unsigned int vclass:3;
+       int iokwd;
+       ptr iounit;
+       ptr iolist;
+       int iojunk[7];  /* padding */
+       } ;
+
+extern struct ioitem
+       {
+       struct headbits header;
+       ptr ioexpr;
+       char *iofmt;
+       int nrep;
+       } ;
+
+
+struct iogroup
+       {
+       struct headbits header;
+       struct doblock *doptr;
+       char *iofmt;
+       int nrep;
+       ptr ioitems;
+       };
+
+
+extern struct tailoring
+       {
+       int ftnsys;
+       int errmode;
+       int charcomp;
+       int ftnin;
+       int ftnout;
+       int ftncontnu;
+       char *procheader;
+       char *lngcxtype;
+       char *lngcxprefix;
+       int ftnchwd;
+       int ftnsize[NFTNTYPES];
+       int ftnalign[NFTNTYPES];
+       char *dfltfmt[NEFLTYPES];
+       int hollincall;
+       int deltastno;
+       int dclintrinsics;
+       int ftn77;
+       }  tailor;
+
+
+struct system
+       {
+       char *sysname;
+       short sysno;
+       short chperwd;
+       short idig;
+       short rdig;
+       short ddig;
+       } systab[];
+
+
+
+
+
+/* Declarations of popular functions */
+
+char *copys(), *convic(), *procnm();
+ptr cpexpr(), compconst(), simple(), mknode(), mkint(), mkconst();
+ptr intalloc(), calloc(), allexcblock(), allexpblock();
+ptr mkcall(), coerce(), fold(), builtin(), gent(), errnode();
+ptr arg1(), arg2(), arg4();
+struct stentry *name();
+chainp mkchain(), hookup();
+\f
+/*Block tags */
+
+#define TAROP 1
+#define TASGNOP 2
+#define TLOGOP 3
+#define TRELOP 4
+#define TCALL 5
+#define TREPOP 6
+#define TLIST 7
+#define TCONST 8
+#define TNAME 9
+#define TERROR 10
+#define TCOMMON 11
+#define TSTRUCT 12
+#define TSTFUNCT 13
+#define TEXEC 14
+#define TTEMP 15
+#define TDEFINE 16
+#define TKEYWORD 17
+#define TLABEL 18
+#define TCASE 19
+#define TNOTOP 20
+#define TNEGOP 21
+#define TDOBLOCK 22
+#define TCONTROL 23
+#define TKNOWNFUNCT 24
+#define TFIELD 25
+#define TGENERIC 26
+#define TIOSTAT 27
+#define TIOGROUP 28
+#define TIOITEM 29
+#define TFTNBLOCK 30
+
+/* Operator subtypes */
+
+#define OPPLUS 1
+#define OPMINUS 2
+#define OPSTAR 3
+#define OPSLASH 4
+#define OPPOWER 5
+
+#define OPNOT 6
+#define OPAND 7
+#define OP2AND 8
+#define OP2OR 9
+#define OPOR 10
+
+#define OPEQ 11
+#define OPLT 12
+#define OPGT 13
+#define OPLE 14
+#define OPGE 15
+#define OPNE 16
+
+#define OPLPAR 17
+#define OPRPAR 18
+#define OPEQUALS 19
+#define OPCOMMA 20
+
+#define OPASGN 0
+#define OPREL 0
+
+
+/* Simplification types */
+
+#define LVAL 1
+#define RVAL 2
+#define SUBVAL 3
+#define IFVAL 4
+
+
+/* Parser return values */
+
+#define PARSERR 1
+#define PARSEOF 2
+#define PARSOPT 3
+#define PARSDCL 4
+#define PARSDEF 5
+#define PARSPROC 6
+\f
+
+/* Symbol table types */
+
+#define TYUNDEFINED 0
+#define TYINT 1
+#define TYREAL 2
+#define TYLREAL 3
+#define TYLOG 4
+#define TYCOMPLEX 5
+#define TYLCOMPLEX 6
+#define TYCHAR 7
+#define TYSTRUCT 8
+#define TYLABEL 9
+#define TYSUBR 10
+#define TYFIELD 11
+#define TYHOLLERITH 12
+
+
+
+/* Fortran types */
+
+#define FTNINT 0
+#define FTNREAL 1
+#define FTNLOG 2
+#define FTNCOMPLEX 3
+#define FTNDOUBLE 4
+#define FTNCHAR 5
+#define FTNDCOMPLEX 6
+
+
+
+/* symbol table classes */
+
+#define CLUNDEFINED 0
+#define CLARG 1
+#define CLVALUE 2
+#define CLSTAT 3
+#define CLAUTO 4
+#define CLCOMMON 5
+#define CLMOS 6
+#define CLEXT 7
+
+
+/* values of vproc */
+
+#define PROCUNKNOWN 0
+#define PROCNO 1
+#define PROCYES 2
+#define PROCINTRINSIC 3
+
+/* values of procclass */
+
+#define PRBLOCK        1
+#define PRMAIN 2
+#define PRSUBR 3
+#define PRFUNCT        4
+
+
+
+/* ctlblock subtypes */
+
+#define STNULL 1
+#define STIF 2
+#define STIFELSE 3
+#define STREPEAT 4
+#define STWHILE 5
+#define STFOR 6
+#define STDO 7
+#define STSWITCH 8
+#define STRETURN 9
+#define STGOTO 10
+#define STCALL 11
+#define STPROC 12
+
+
+
+/* intermediate code definitions */
+
+#define ICEOF 0
+#define ICBEGIN 1
+#define ICKEYWORD 2
+#define ICOP 3
+#define ICNAME 4
+#define ICCONST 5
+#define ICLABEL 6
+#define ICMARK 7
+#define ICINDENT 8
+#define ICCOMMENT 9
+#define ICINDPTR 10
+#define ICBLANK 11
+
+#define FCONTINUE 2
+#define FCALL 3
+#define FDO 4
+#define FIF1 5
+#define FIF2 6
+#define FGOTO 7
+#define FRETURN 8
+#define FREAD 9
+#define FWRITE 10
+#define FFORMAT 11
+#define FSTOP 12
+#define FDATA 13
+#define FEQUIVALENCE 14
+#define FCOMMON 15
+#define FEXTERNAL 16
+#define FREWIND 17
+#define FBACKSPACE 18
+#define FENDFILE 19
+#define FSUBROUTINE 20
+#define FFUNCTION 21
+#define FPROGRAM 22
+#define FBLOCKDATA 23
+#define FEND 24
+
+
+/* I/O error handling options */
+
+#define IOERRNONE      0
+#define IOERRIBM       1
+#define IOERRFORT77    2
diff --git a/usr/src/cmd/efl/efltest/Band.e b/usr/src/cmd/efl/efltest/Band.e

new file mode 100644 (file)

index 0000000..ab436c5
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Band.e
@@ -0,0 +1,235 @@
+  procedure bnds(n,ml,m,g,nb,b)
+ 
+# to solve a*x = b, where a is a banded matrix, using gaussian
+# elimination with partial pivoting.
+ 
+# mnemonic - double precision band solution of a system of
+#            linear algebraic equations.
+ 
+# input -
+ 
+#   n  - the order of the system.
+#   ml - the number of nonzero elements of a on and below the diagonal.
+#   m  - the total number of nonzero elements in each row of a.
+#   g  - the matrix a, with g(i,j) = a(i,i+j-ml).
+#   nb - the number of right-hand-sides b.
+#   b  - the right-hand-sides.
+ 
+# output -
+ 
+#   g - has been clobbered.
+#   b - the solution vectors, x.
+ 
+# scratch space allocated - n*( (ml-1)*mu + 1 ) words.
+ 
+# error states -
+ 
+#   1 - n.lt.1.
+#   2 - ml.lt.1.
+#   3 - ml.gt.m.
+#   4 - nb.lt.1.
+#   5 - singular matrix. (recoverable)
+  
+  real g(n,m),b(n,nb)
+  integer n,ml,m,nb
+  
+  include rstack
+  
+  integer il,iint,istkgt,nerror,nerr
+  
+# check the input for errors.
+ 
+  if ( n < 1 ) { seterr(" bnds - n.lt.1",14,1,2) }
+  if ( ml < 1 ) { seterr(" bnds - ml.lt.1",16,2,2) }
+  if ( ml > m ) { seterr(" bnds - ml.gt.m",15,3,2) }
+  if ( nb < 1 ) { seterr(" bnds - nb.lt.1",15,4,2) }
+ 
+  enter(1)
+  
+  il = istkgt(max0(n*(ml-1),1),3) ; iint = istkgt(n,2)
+  
+  bndlu(n,ml,m,g,ws(il),is(iint))
+  
+  if ( nerror(nerr) == 0 ) { bndfb(n,ml,m,ws(il),g,is(iint),nb,b) }
+ 
+  else { erroff() ; seterr(" bnds - singular matrix",23,5,1) }
+  
+  leave()
+  
+  return
+  
+  end
+  procedure bndlu(n,ml,m,g,l,int)
+ 
+# to obtain the lu decomposition of a banded matrix,
+# using gaussian elimination with partial pivoting.
+ 
+# mnemonic - double precision band lu decomposition.
+ 
+# input -
+ 
+#   n   - the order of the matrix.
+#   ml  - the number of nonzero elements of a on and below the diagonal.
+#   m   - the number of nonzero elements in each row of a.
+#   g   - the matrix a, with g(i,j) = a(i,i+j-ml).
+ 
+# output -
+ 
+#   l   - the lower triangular banded factor of a.
+#   g   - the upper triangular banded factor of a.
+#   int - the row pivoting used.
+ 
+# scratch storage allocated - none.
+ 
+# error states -
+ 
+#   1 - n.lt.1.
+#   2 - ml.lt.1.
+#   3 - m.lt.ml.
+#   4 - singular matrix. (recoverable)
+  
+  real g(n,m),l(n,ml)    # l(n,ml-1).
+  integer n,ml,m,int(n)
+  
+  real x,norm,eps,r1mach
+  integer i,j,k,ll,m1,m2
+  logical sing
+  
+# check the input for errors.
+ 
+  if ( n < 1 ) { seterr(" bndlu - n.lt.1",15,1,2) }
+  if ( ml < 1 ) { seterr(" bndlu - ml.lt.1",16,2,2) }
+  if ( m < ml ) { seterr(" bndlu - m.lt.ml",16,3,2) }
+ 
+  entsrc(i,0)    # protect against an existing error state.
+ 
+  sing = .false. ; eps = r1mach(4)
+  m1 = ml-1 ; m2 = m-ml
+  
+  ll = m1
+  for ( i = 1 , i <= min0(m1,n) , i += 1 )    # set to 0 those elements
+    {                                         # of g which are undefined.
+    do j = ml+1-i , m 
+                { g(i,j-ll) = g(i,j) }
+    ll = ll-1
+    do j = m-ll , m 
+                { g(i,j) = 0.0e0 }
+    }
+  
+  for ( i = 1 , i <= min0(m2,n) , i += 1 )    # zero out lower rhs wart.
+    {
+    do j = ml+i , m 
+                { g(n+1-i,j) = 0.0e0 }
+    }
+ 
+  norm = 0.0e0    # get || a || sub infinity.
+  do i = 1 , n 
+               
+    {
+    int(i) = i
+    x = 0.0e0 ; do j = 1 , m 
+                { x += abs(g(i,j)) }
+    norm = amax1(norm,x)
+    }
+  
+  do k = 1 , n 
+               
+    {
+    x = g(k,1) ; i = k
+    
+    ll = min0(m1+k,n)
+    
+    if ( k < ll )
+      {
+      do j = k+1 , ll 
+                   # get the pivot row.
+        { if ( abs(g(j,1)) > abs(x) ) { x = g(j,1) ; i = j } }
+      }
+    
+    int(k) = i
+    
+    if ( x == 0.0e0 ) { sing = .true. ; g(k,1) = norm*eps }
+ 
+    if ( ml == 1 | k == n ) { next }
+    
+    if ( i ~= k )    # need to interchange the rows.
+      {
+      do j = 1 , m 
+                { x = g(k,j) ; g(k,j) = g(i,j) ; g(i,j) = x }
+      }
+    
+    if ( k >= ll ) { next }
+    do i = k+1 , ll 
+               
+      {
+      x = g(i,1)/g(k,1)
+      l(k,i-k) = x
+      
+      do j = 2 , m 
+                { g(i,j-1) = g(i,j)-x*g(k,j) }
+ 
+      g(i,m) = 0.0e0
+      }
+    }
+  
+  if ( sing ) { seterr(" bndlu - singular matrix",24,4,1) }
+  
+  return
+  
+  end
+  procedure bndfb(n,ml,m,l,u,int,nb,b)
+ 
+# to solve l*u*x = b, where l and u result from a call to bnds.
+ 
+# mnemonic - double precision band forward elimination and
+#            back-solve.
+ 
+# input -
+ 
+#   n   - the order of the system.
+#   ml  - the number of nonzero entries of l on and below
+#         the diagonal.
+#   m   - the number of nonzero elements of u on and above
+#         the diagonal.
+#   l   - the lower triangular banded factor.
+#   u   - the upper triangular banded factor.
+#   int - the ordering of the rows of the system, due to pivoting.
+#   nb  - the number of right-hand-sides.
+#   b   - the right-hand-sides.
+ 
+# output -
+ 
+#   b - the solution vectors.
+ 
+# scratch space allocated - none.
+ 
+# error states -
+ 
+#   1 - n.lt.1.
+#   2 - ml.lt.1.
+#   3 - m.lt.ml.
+#   4 - nb.lt.1.
+ 
+  real l(n,ml),u(n,m),b(n,nb)    # l(n,ml-1).
+  integer n,ml,m,int(n),nb
+ 
+  integer nerror,nerr
+ 
+# check the input for errors.
+ 
+  if ( n < 1 ) { seterr(" bndfb - n.lt.1",15,1,2) }
+  if ( ml < 1 ) { seterr(" bndfb - ml.lt.1",16,2,2) }
+  if ( m < ml ) { seterr(" bndfb - m.lt.ml",16,3,2) }
+  if ( nb < 1 ) { seterr(" bndfb - nb.lt.1",16,4,2) }
+  
+  entsrc(nerr,0)    # protect against an existing error state.
+  
+  bndfe(n,ml,l,int,nb,b)
+                   # do the forward-elimination.
+ 
+  bndbs(n,m,u,nb,b)
+                   # do the back-substitution.
+  
+  return
+  
+  end
diff --git a/usr/src/cmd/efl/efltest/Band.out b/usr/src/cmd/efl/efltest/Band.out

new file mode 100644 (file)

index 0000000..4ec0ce6
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Band.out
@@ -0,0 +1,208 @@
+      subroutine bnds(n, ml, m, g, nb, b)
+      integer m, n, nb
+      integer ml
+      real g(n, m), b(n, nb)
+      common /cstak/ ds
+      double precision ds(500)
+      integer istkgt, nerror, max0, iint, nerr, il
+      integer is(1000)
+      real rs(1000), ws(500)
+      logical ls(1000)
+      complex cs(500)
+      equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
+c to solve a*x = b, where a is a banded matrix, using gaussian
+c elimination with partial pivoting.
+c mnemonic - double precision band solution of a system of
+c            linear algebraic equations.
+c input -
+c   n  - the order of the system.
+c   ml - the number of nonzero elements of a on and below the diagonal.
+c   m  - the total number of nonzero elements in each row of a.
+c   g  - the matrix a, with g(i,j) = a(i,i+j-ml).
+c   nb - the number of right-hand-sides b.
+c   b  - the right-hand-sides.
+c output -
+c   g - has been clobbered.
+c   b - the solution vectors, x.
+c scratch space allocated - n*( (ml-1)*mu + 1 ) words.
+c error states -
+c   1 - n.lt.1.
+c   2 - ml.lt.1.
+c   3 - ml.gt.m.
+c   4 - nb.lt.1.
+c   5 - singular matrix. (recoverable)
+c check the input for errors.
+      if (n .lt. 1) call seterr(14h bnds - n.lt.1, 14, 1, 2)
+      if (ml .lt. 1) call seterr(15h bnds - ml.lt.1, 16, 2, 2)
+      if (ml .gt. m) call seterr(15h bnds - ml.gt.m, 15, 3, 2)
+      if (nb .lt. 1) call seterr(15h bnds - nb.lt.1, 15, 4, 2)
+      call enter(1)
+      il = istkgt(max0(n*(ml-1), 1), 3)
+      iint = istkgt(n, 2)
+      call bndlu(n, ml, m, g, ws(il), is(iint))
+      if (nerror(nerr) .ne. 0) goto 1
+         call bndfb(n, ml, m, ws(il), g, is(iint), nb, b)
+         goto  2
+   1     call erroff
+         call seterr(23h bnds - singular matrix, 23, 5, 1)
+   2  call leave
+      return
+      end
+      subroutine bndlu(n, ml, m, g, l, int)
+      integer m, n, ml
+      integer int(n)
+      real g(n, m), l(n, ml)
+      integer min0, i, j, k, m1, m2
+      integer ll
+      real abs, eps, x, norm, amax1, r1mach
+      logical sing
+      integer temp, temp1
+c to obtain the lu decomposition of a banded matrix,
+c using gaussian elimination with partial pivoting.
+c mnemonic - double precision band lu decomposition.
+c input -
+c   n   - the order of the matrix.
+c   ml  - the number of nonzero elements of a on and below the diagonal.
+c   m   - the number of nonzero elements in each row of a.
+c   g   - the matrix a, with g(i,j) = a(i,i+j-ml).
+c output -
+c   l   - the lower triangular banded factor of a.
+c   g   - the upper triangular banded factor of a.
+c   int - the row pivoting used.
+c scratch storage allocated - none.
+c error states -
+c   1 - n.lt.1.
+c   2 - ml.lt.1.
+c   3 - m.lt.ml.
+c   4 - singular matrix. (recoverable)
+c l(n,ml-1).
+c check the input for errors.
+      if (n .lt. 1) call seterr(15h bndlu - n.lt.1, 15, 1, 2)
+      if (ml .lt. 1) call seterr(16h bndlu - ml.lt.1, 16, 2, 2)
+      if (m .lt. ml) call seterr(16h bndlu - m.lt.ml, 16, 3, 2)
+c protect against an existing error state.
+      call entsrc(i, 0)
+      sing = .false.
+      eps = r1mach(4)
+      m1 = ml-1
+      m2 = m-ml
+      ll = m1
+      i = 1
+         goto  2
+   1     i = i+1
+   2     if (i .gt. min0(m1, n)) goto  5
+c set to 0 those elements
+c of g which are undefined.
+         temp = ml+1-i
+         do  3 j = temp, m
+            temp1 = j-ll
+            g(i, temp1) = g(i, j)
+   3        continue
+         ll = ll-1
+         temp = m-ll
+         do  4 j = temp, m
+            g(i, j) = 0.0e0
+   4        continue
+         goto  1
+   5  i = 1
+         goto  7
+   6     i = i+1
+   7     if (i .gt. min0(m2, n)) goto  9
+c zero out lower rhs wart.
+         temp = ml+i
+         do  8 j = temp, m
+            temp1 = n+1-i
+            g(temp1, j) = 0.0e0
+   8        continue
+         goto  6
+c get || a || sub infinity.
+   9  norm = 0.0e0
+      do  11 i = 1, n
+         int(i) = i
+         x = 0.0e0
+         do  10 j = 1, m
+            x = x+abs(g(i, j))
+  10        continue
+         norm = amax1(norm, x)
+  11     continue
+      do  20 k = 1, n
+         x = g(k, 1)
+         i = k
+         ll = min0(m1+k, n)
+         if (k .ge. ll) goto 14
+            temp = k+1
+            do  13 j = temp, ll
+c get the pivot row.
+               if (abs(g(j, 1)) .le. abs(x)) goto 12
+                  x = g(j, 1)
+                  i = j
+  12           continue
+  13           continue
+  14     int(k) = i
+         if (x .ne. 0.0e0) goto 15
+            sing = .true.
+            g(k, 1) = norm*eps
+  15     if (ml .eq. 1 .or. k .eq. n) goto  20
+         if (i .eq. k) goto 17
+            do  16 j = 1, m
+c need to interchange the rows.
+               x = g(k, j)
+               g(k, j) = g(i, j)
+               g(i, j) = x
+  16           continue
+  17     if (k .ge. ll) goto  20
+         temp = k+1
+         do  19 i = temp, ll
+            x = g(i, 1)/g(k, 1)
+            temp1 = i-k
+            l(k, temp1) = x
+            do  18 j = 2, m
+               g(i, j-1) = g(i, j)-x*g(k, j)
+  18           continue
+            g(i, m) = 0.0e0
+  19        continue
+  20     continue
+      if (sing) call seterr(24h bndlu - singular matrix, 24, 4, 1)
+      return
+      end
+      subroutine bndfb(n, ml, m, l, u, int, nb, b)
+      integer m, n, nb, ml
+      integer int(n)
+      real l(n, ml), u(n, m), b(n, nb)
+      integer nerror, nerr
+c to solve l*u*x = b, where l and u result from a call to bnds.
+c mnemonic - double precision band forward elimination and
+c            back-solve.
+c input -
+c   n   - the order of the system.
+c   ml  - the number of nonzero entries of l on and below
+c         the diagonal.
+c   m   - the number of nonzero elements of u on and above
+c         the diagonal.
+c   l   - the lower triangular banded factor.
+c   u   - the upper triangular banded factor.
+c   int - the ordering of the rows of the system, due to pivoting.
+c   nb  - the number of right-hand-sides.
+c   b   - the right-hand-sides.
+c output -
+c   b - the solution vectors.
+c scratch space allocated - none.
+c error states -
+c   1 - n.lt.1.
+c   2 - ml.lt.1.
+c   3 - m.lt.ml.
+c   4 - nb.lt.1.
+c l(n,ml-1).
+c check the input for errors.
+      if (n .lt. 1) call seterr(15h bndfb - n.lt.1, 15, 1, 2)
+      if (ml .lt. 1) call seterr(16h bndfb - ml.lt.1, 16, 2, 2)
+      if (m .lt. ml) call seterr(16h bndfb - m.lt.ml, 16, 3, 2)
+      if (nb .lt. 1) call seterr(16h bndfb - nb.lt.1, 16, 4, 2)
+c protect against an existing error state.
+      call entsrc(nerr, 0)
+      call bndfe(n, ml, l, int, nb, b)
+c do the forward-elimination.
+      call bndbs(n, m, u, nb, b)
+c do the back-substitution.
+      return
+      end
diff --git a/usr/src/cmd/efl/efltest/Buram.e b/usr/src/cmd/efl/efltest/Buram.e

new file mode 100644 (file)

index 0000000..94477a7
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Buram.e
@@ -0,0 +1,470 @@
+subroutine  Buram(npts,mesh,fn,m,n,p,q,delk)
+integer           npts,m,n;
+real  mesh(npts),fn(npts),p(1),q(1),delk;
+ 
+#    Buram is a double precision subroutine which finds a
+#   a rational function which is the best approximation,
+#   in the uniform or minimax sense, to a given discrete
+#   function.  The rational function is represented as
+#   the quotient of two polynomials each expanded in terms
+#   of Tchebychev polynomials.  This routine is a shell
+#   which in turn calls the routine  Burm1 with certain
+#   default values for the initial approximation and  for
+#   the stopping criteria.
+ 
+#   Input:
+#   npts   - the number of mesh points.
+#   mesh   - the array of mesh points.
+#   fn     - the array of function values.
+#   m      - the degree of the desired numerator polynomial.
+#   n      - the degree of the desired denominator polynomial.
+ 
+#   Output:
+#   p      - the array of coefficients for the numerator polynomial.
+#   q      - the array of coefficients for the denominator polynomial.
+#   delk   - the maximum error in the approximation.
+ 
+#   Error States (asterisk indicates recoverable):
+#   1  - invalid degree
+#   2  - too few mesh points
+#   3  - mesh is not strictly monotone
+#   4* - approximation equals function
+#   5* - no improvement in approximation
+#   6* - reached 50 iterations
+ 
+integer           nitr,maxitr,itol,Nerror,ier;
+real  fnmax,fnmin;
+logical           Smonor;
+common  /dfccom/   nitr;
+ 
+call Enter(1);
+if (m<0  |  n<0)
+    call Seterr(" Buram - invalid degree",23,1,2);
+if (npts < m+n+2)
+    call Seterr(" Buram - too few mesh points",28,2,2);
+if (!(Smonor(mesh,npts,1)))
+    call Seterr(" Buram - mesh is not strictly monotone",38,3,2);
+ 
+#   Initialize the numerator and demoninator polynomials.
+fnmax = fn(1);                    fnmin = fn(1);
+do i=2,npts
+    {
+    if (fnmax < fn(i))
+       fnmax = fn(i);
+    else if (fn(i) < fnmin)
+       fnmin = fn(i);
+    }
+call Setr(m+1,0.0e0,p);           p(1) = 0.5e0*(fnmax + fnmin);
+call Setr(n+1,0.0e0,q);           q(1) = 1.0e0
+delk = fnmax - p(1);              nitr = 0;
+ 
+if (! (m==0 & n==0))
+    {
+    maxitr = 50;                  itol = 2;
+    call  Burm1(npts,mesh,fn,maxitr,itol,m,n,p,q,delk);
+    if (nerror(ier)!=0)
+       {
+       if (ier == 7)
+           call Newerr(" Buram - approximation equals function",39,4,1);
+       else if (ier == 8)
+           call Newerr(" Buram - no improvement in approximation",40,5,1);
+       else if (ier == 9)
+           call Newerr(" Buram - reached 50 iterations",30,6,1);
+       else
+           call Eprint;
+       }
+    }
+call Leave;
+return
+end
+subroutine   Burm1(npts,mesh,fn,maxitr,itol,m,n,p,q,delk)
+integer           npts,maxitr,itol,m,n;
+real  mesh(npts),fn(npts),p(1),q(1),delk;
+ 
+#    Burm1 is a double precision subroutine which finds a
+#   a rational function which is the best approximation,
+#   in the uniform or minimax sense, to a given discrete
+#   function.  The rational function is represented as
+#   the quotient of two polynomials each expanded in terms
+#   of Tchebychev polynomials.  This routine starts from an
+#   initial approximation and terminates for one of four
+#   reasons: (1) the error curve equioscillates and the
+#   alternating extrema match to ITOL digits, (2) the number
+#   of iterations exceeds MAXITR, (3) the approximation
+#   cannot be improved, or (4) the approximation is essentially
+#   equal to the given discrete function.
+ 
+#   Input:
+#   npts   - the number of mesh points.
+#   mesh   - the array of mesh points.
+#   fn     - the array of function values.
+#   maxitr - the maximum number of iterations.
+#   itol   - the number of digits to which the extrema should match.
+#   m      - the degree of the desired numerator polynomial.
+#   n      - the degree of the desired denominator polynomial.
+#   p      - the array of coefficients for the initial numerator.
+#   q      - the array of coefficients for the initial denominator.
+ 
+#   Output:
+#   p      - the array of coefficients for the numerator polynomial.
+#   q      - the array of coefficients for the denominator polynomial.
+#   delk   - the maximum error in the approximation.
+ 
+#   Error States (asterisk indicates recoverable):
+#   1  - invalid degree
+#   2  - too few mesh points
+#   3  - mesh is not strictly monotone
+#   4  - maxitr .lt. 0
+#   5  - invalid accuracy request
+#   6  - denominator is nonpositive
+#   7* - approximation equals function
+#   8* - no improvement in approximation
+#   9* - reached maximum no. of iterations
+ 
+integer           idig,Iflr,I1mach,Istkgt,npptr,nqptr,enptr,qkptr,iexptr;
+real  R1mach,Float,qlrg;
+logical           Smonor;
+ 
+common  /cstak/   dstak(500)
+long real  dstak
+integer           istak(1000)
+real              ws(1000)
+ 
+equivalence dstak,istak
+equivalence dstak,ws
+call Enter(1);
+if (m<0  |  n<0)
+    call Seterr(" Burm1 - invalid degree",23,1,2);
+if (npts < m+n+2)
+    call Seterr(" Burm1 - too few mesh points",28,2,2);
+if (!(Smonor(mesh,npts,1)))
+    call Seterr(" Burm1 - mesh is not strictly monotone",38,3,2);
+if (maxitr < 0)
+    call Seterr(" Burm1 - maxitr .lt. 0",22,4,2);
+idig = Iflr(R1mach(5)*Float(I1mach(11)));
+if (itol < 1  |  idig < itol)
+    call Seterr(" Burm1 - invalid accuracy request",36,5,2);
+qlrg = Abs(q(1));
+for (j=2, j<=n+1, j=j+1)
+    if (qlrg < abs(q(j)))
+        qlrg = abs(q(j));
+if (qlrg == 0.e0)
+    call Seterr(" Burm1 - denominator is nonpositive",35,6,2)
+else
+    {
+    for (j=1, j<=n+1, j=j+1)
+        q(j) = q(j)/qlrg;
+    for (j=1, j<=m+1, j=j+1)
+        p(j) = p(j)/qlrg;
+    }
+ 
+npptr  = Istkgt(m+1,3);
+nqptr  = Istkgt(n+1,3);
+enptr  = Istkgt(npts,3);
+qkptr  = Istkgt(npts,3);
+iexptr = Istkgt(npts,2);
+ 
+call  B1rm1(npts,mesh,fn,maxitr,itol,m,n,p,q,delk,ws(npptr),ws(nqptr),
+            ws(enptr),ws(qkptr),istak(iexptr));
+ 
+call Leave;
+return;
+end
+subroutine  B1rm1(npts,x,fn,maxitr,itol,m,n,p,q,delk,newp,newq,en,qk,iext)
+integer           npts,maxitr,itol,m,n,iext(npts);
+real  x(npts),fn(npts),p(1),q(1),delk,newp(1),newq(1),
+                  en(npts),qk(npts);
+ 
+integer           nitr,nex,imax,imin,ilrg,Lrgex ,Nerror,ier;
+real  eps,bnd,R1mach,delnew;
+common  /dfccom/  nitr;
+ 
+eps = R1mach(4)*10.0e0**itol;
+call Extrmr(npts,fn,nex,iext,imax,imin,ilrg);
+bnd = Abs(fn(ilrg))*eps;
+ 
+call  Enqk(npts,x,fn,m,n,p,q,qk,en);
+do i=1,npts
+    if (qk(i) <= 0.0e0)
+        call Seterr(" Burm1 - denominator is nonpositive",35,6,2);
+ 
+call Extrmr(npts,en,nex,iext,imax,imin,ilrg);
+delk = Abs(en(ilrg));            delnew = delk;
+call Movefr(m+1,p,newp);          call Movefr(n+1,q,newq);
+ 
+for (nitr=0, nitr<maxitr, nitr=nitr+1)
+    {
+#   call Outpt3 (x,npts,p,q,delk,m,n,en,iext,nex)
+    if (delk <= bnd)
+        {
+        call Seterr(" Burm1 - approximation equals function",39,7,1);
+        return;
+        }
+    #   Test for optimal solution.
+    if (Lrgex (npts,en,nex,iext,ilrg,itol) >= m+n+2)
+        return;
+ 
+    call  Lpstp(npts,x,fn,qk,delnew,m,n,newp,newq)
+    if (Nerror(ier) != 0)
+        call Erroff;
+ 
+    call  Enqk(npts,x,fn,m,n,newp,newq,qk,en);
+    call Extrmr(npts,en,nex,iext,imax,imin,ilrg);
+    delnew = Abs(en(ilrg));
+    if (delk <= delnew)
+        {
+        call Seterr(" Burm1 - no improvement in approximation",40,8,1);
+        return;
+        }
+    call Movefr(m+1,newp,p);      call Movefr(n+1,newq,q);
+    delk = delnew;
+    }
+call Seterr(" Burm1 - reached maximum no. of iterations",42,9,1);
+ 
+return;
+end
+subroutine   Enqk( npts,X,fn,m,n,p,q,Qk,en)
+integer           npts,m,n;
+real  X(npts),fn(npts),p(1),q(1),Qk(npts),en(npts);
+#
+#   Subroutine  Enqk computes en & Qk.
+#   en=error values at mesh points.
+#   Qk=value of denominator polynomial at mesh points.
+#
+real  Tchbp,Pk;
+  if (npts<=0 | m<0 | n<0)
+    call seterr ("enQk-invalid dimension",22,1,2)
+  do i=1,npts
+   {
+    Qk(i)=Tchbp(n,q,X(i),X(1),X(npts))
+    if (Qk(i)==0.e0)
+      call seterr ("enQk-divisor .eq. 0.",20,2,2)
+    Pk=Tchbp(m,p,X(i),X(1),X(npts))
+    en(i)=(fn(i)*Qk(i)-Pk)/Qk(i)
+   }
+  return
+  end
+integer function Lrgex (npts,en,nex,iext,ilrg,tol)
+#
+#    Function Lrgex  finds the no. of error extrema with magnitudes
+#    within tolerance of magnitude of largest error.
+#
+  integer npts,nex,iext(nex),ilrg,j,k,L,tol
+  real en(npts),hold
+  if (npts<=0)
+    call Seterr ("Lrgex -invalid dimension",24,1,2)
+  if (nex<=0 | ilrg<=0)
+    call Seterr ("Lrgex -invalid index",20,2,2)
+  k=0
+  do j=1,nex
+   {
+    L=iext(j)
+    hold=Abs(en(ilrg))-Abs(en(L))
+    if (hold<=10.**(-tol)*Abs(en(ilrg)))
+      k=k+1
+   }
+  Lrgex =k
+  return
+  end
+subroutine  Lpstp(npts,mesh,fn,Qk,delk,m,n,p,q)
+integer           npts,m,n;
+real  mesh(npts),fn(npts),Qk(npts),delk,p(1),q(1);
+ 
+#    Lpstp defines the linear programming subproblem of the
+#   Differential Correction algorithm.  It also provides
+#   the interface to the general purpose linear programming
+#   package.
+ 
+#   Input:
+#   npts   - the number of mesh points.
+#   mesh   - the array of mesh points.
+#   fn     - the array of function values.
+#   Qk     - the array of current denominator values.
+#   delk   - the current minimax error.
+#   m      - the degree of the numerator polynomial.
+#   n      - the degree of the denominator polynomial.
+#   p      - the current numerator polynomial.
+#   q      - the current denominator polynomial.
+ 
+#   Output:
+#   p      - the array of coefficients for the numerator polynomial.
+#   q      - the array of coefficients for the denominator polynomial.
+ 
+#   Error States (asterisk indicates fatal):
+#   1* - invalid degree
+#   2* - too few mesh points
+#   3* - nonpositive delk
+#   4  - no improvement in the lp subproblem
+ 
+integer           aptr,bptr,cptr,xptr;
+ 
+common  /cstak/   dstak(500)
+long real  dstak
+integer           istak(1000)
+real              ws(1000)
+ 
+equivalence dstak,istak
+equivalence dstak,ws
+ 
+call Enter(1);
+if (m<0  |  n<0)
+    call Seterr(" Lpstp - invalid degree",23,1,2);
+if (npts < m+n+2)
+    call Seterr(" Lpstp - too few mesh points",28,2,2);
+ 
+aptr   = Istkgt((3*npts+1),3);
+bptr   = Istkgt((2*(npts+n+1)),3);
+cptr   = Istkgt((m+n+3),3);
+xptr   = Istkgt((m+n+3),3);
+ 
+call  L9stp(npts,mesh,fn,Qk,delk,m,n,p,q,ws(aptr),ws(bptr),
+           ws(cptr),ws(xptr));
+ 
+call Leave;
+return;
+end
+subroutine  L9stp(npts,mesh,fn,Qk,delk,m,n,p,q,A,B,C,X)
+integer           npts,m,n;
+real  mesh(npts),fn(npts),Qk(npts),delk,p(1),q(1),
+                  A(1),B(1),C(1),X(1);
+ 
+integer           nptsc,mc,nc,i1,i2,i3,i4,mm,nn,Nerror,ierr;
+real  ctx,ctxnew,qlrg,Float,R1mach;
+external           Difmt;
+common  /difcom/  nptsc,mc,nc,i1,i2,i3,i4;
+ 
+ 
+nptsc = npts;                             mc = m;
+nc = n;
+i1 = npts;                                i2 = i1 + npts;
+i3 = i2 + n + 1;                          i4 = i3 + n + 1;
+mm = i4;                                  nn = m+n+3;
+ 
+call Movefr(n+1,q,X);                     call Movefr(m+1,p,X(n+2));
+X(nn) = 0.e0;
+call Setr(i2,0.0e0,B);                    call Setr((i4-i2),-1.0e0,B(i2+1));
+call Setr(nn,0.0e0,C);                    C(nn) = -1.0e0;
+call Movefr(npts,mesh,A);                 call Movefr(npts,fn,A(npts+1));
+call Movefr(npts,Qk,A(2*npts+1));
+if (delk <= 0.0e0)
+    call Seterr(" Lpstp - nonpositive delk",25,3,2)
+A(3*npts+1) = delk;                       ctx = 0.0e0;
+ 
+#   Solve the LP problem: max C(T)X subject to AX >= B.
+#   The subroutine  Difmt derives the matrix A from
+#   the data stored in the array A.
+ 
+call Lpph2(A,mm,nn, Difmt,B,C,X,4*mm,ctxnew)
+if (Nerror(ier) != 0)
+    call Erroff;
+if (ctx < ctxnew)
+    {
+    qlrg = 0.0e0;
+    for (j=1, j<=n+1, j=j+1)
+        if (qlrg < abs(X(j)))            qlrg = abs(X(j));
+    for (j=1, j<=n+1, j=j+1)
+        q(j) = X(j)/qlrg;
+    i = 0;
+    for (j=n+2, j<=m+n+2, j=j+1)
+        {
+        i = i+1;                          p(i) = X(j)/qlrg;
+        }
+    }
+else
+    call Seterr(" Lpstp - no improvement in the lp subproblem",44,4,1);
+ 
+return;
+end
+subroutine  Difmt(inprod,A,mm,nn,irow,X,dinprd)
+integer           mm,nn,irow;
+real  A(1),X(nn),dinprd;
+logical           inprod;
+ 
+#    Difmt handles references by the LP routine to
+#   the matrix for the linear programming subproblem.
+ 
+integer           npts,m,n,i1,i2,i3,i4,irm1,irm2,irm3,zptr,
+                  fnptr,qzptr,jp,maxmn;
+real  fct,fdelk,delk,z,fn,qz,Tchbp;
+common  /difcom/  npts,m,n,i1,i2,i3,i4;
+ 
+call Enter(1);
+if (mm != i4  |  nn ~= m+n+3)
+    call Seterr(" Difmt - invalid dimension",26,1,2)
+if (irow<0  | mm<irow)
+    call Seterr(" Difmt - invalid index",22,2,2)
+ 
+irm1 = irow - i1;
+irm2 = irow - i2;
+irm3 = irow - i3;
+if (inprod  &  i2 < irow)
+    {
+    if (i3 < irow)
+       dinprd = -X(irm3);
+    else
+       dinprd =  X(irm2);
+    }
+else if (i2 < irow)
+   {
+    call Setr(nn,0.0e0,X);
+    if (i3 < irow)
+       X(irm3) = -1.0e0;
+    else
+       X(irm2) =  1.0e0;
+    }
+else
+    {
+    if (i1 < irow)
+       {
+       fct = -1.0e0;           zptr = irm1;
+       }
+    else
+       {
+       fct =  1.0e0;           zptr = irow;
+       }
+    z     = A(zptr);
+    fnptr = zptr+npts;         fn = A(fnptr);
+    qzptr = fnptr+npts;                qz = A(qzptr);
+    delk  = A(3*npts+1);       fdelk = fct*fn + delk;
+    if ( inprod )
+       dinprd = fdelk*Tchbp(n,X,z,A(1),A(npts)) -
+               fct*Tchbp(m,X(n+2),z,A(1),A(npts)) + qz*X(nn);
+    else
+       {
+       maxmn = Max0(m,n);
+       call  Tchcf(z,A(1),A(npts),maxmn,X);
+       for (j=m+1, 1<=j, j=j-1)
+           {
+           jp = j+n+1;         X(jp) = -fct*X(j);
+           }
+       for (j=1, j<=n+1, j=j+1)
+           X(j) = fdelk*X(j);
+       X(nn) = qz;
+       }
+    }
+call Leave;
+return;
+end
+subroutine  Tchcf (x,a,b,deg,XX)
+#
+#    Subroutine  Tchcf computes the deg+1 Tchebycheff
+#    coefficients of the point x.
+#
+  integer deg,i
+  real a,b,twoxx,x,XX(1)
+  call enter(1)
+  if (deg<0)
+    call seterr (" Tchcf-invalid degree",21,1,2)
+  XX(1)=1.e0
+  if (deg>0)
+    if (b<=a)
+      call seterr (" Tchcf-invalid interval",23,2,2)
+    else        #scale x to the interval (-1.e0,1.e0)
+      XX(2)=2.e0*(x-(a+b)/2.e0)/(b-a)
+  if (deg>1)
+    twoxx=2.e0*XX(2)
+    for (i=3,i<=deg+1,i=i+1)
+      XX(i)=twoxx*XX(i-1)-XX(i-2)
+  call leave
+  return
+  end
diff --git a/usr/src/cmd/efl/efltest/Buram.out b/usr/src/cmd/efl/efltest/Buram.out

new file mode 100644 (file)

index 0000000..2399383
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Buram.out
@@ -0,0 +1,494 @@
+      subroutine buram(npts, mesh, fn, m, n, p, q, delk)
+      integer npts
+      integer m, n
+      real mesh(npts), fn(npts), p(1), q(1), delk
+      common /dfccom/ nitr
+      integer nitr
+      integer ier, maxitr, nerror, i, itol
+      real fnmin, fnmax
+      logical smonor
+c    Buram is a double precision subroutine which finds a
+c   a rational function which is the best approximation,
+c   in the uniform or minimax sense, to a given discrete
+c   function.  The rational function is represented as
+c   the quotient of two polynomials each expanded in terms
+c   of Tchebychev polynomials.  This routine is a shell
+c   which in turn calls the routine  Burm1 with certain
+c   default values for the initial approximation and  for
+c   the stopping criteria.
+c   Input:
+c   npts   - the number of mesh points.
+c   mesh   - the array of mesh points.
+c   fn     - the array of function values.
+c   m      - the degree of the desired numerator polynomial.
+c   n      - the degree of the desired denominator polynomial.
+c   Output:
+c   p      - the array of coefficients for the numerator polynomial.
+c   q      - the array of coefficients for the denominator polynomial.
+c   delk   - the maximum error in the approximation.
+c   Error States (asterisk indicates recoverable):
+c   1  - invalid degree
+c   2  - too few mesh points
+c   3  - mesh is not strictly monotone
+c   4* - approximation equals function
+c   5* - no improvement in approximation
+c   6* - reached 50 iterations
+      call enter(1)
+      if (m .lt. 0 .or. n .lt. 0) call seterr(
+     1   23h Buram - invalid degree, 23, 1, 2)
+      if (npts .lt. m+n+2) call seterr(28h Buram - too few mesh points
+     1   , 28, 2, 2)
+      if (.not. smonor(mesh, npts, 1)) call seterr(
+     1   38h Buram - mesh is not strictly monotone, 38, 3, 2)
+c   Initialize the numerator and demoninator polynomials.
+      fnmax = fn(1)
+      fnmin = fn(1)
+      do  3 i = 2, npts
+         if (fnmax .ge. fn(i)) goto 1
+            fnmax = fn(i)
+            goto  2
+   1        if (fn(i) .lt. fnmin) fnmin = fn(i)
+   2     continue
+   3     continue
+      call setr(m+1, 0.0e0, p)
+      p(1) = 0.5e0*(fnmax+fnmin)
+      call setr(n+1, 0.0e0, q)
+      q(1) = 1.0e0
+      delk = fnmax-p(1)
+      nitr = 0
+      if (m .eq. 0 .and. n .eq. 0) goto 11
+         maxitr = 50
+         itol = 2
+         call burm1(npts, mesh, fn, maxitr, itol, m, n, p, q, delk)
+         if (nerror(ier) .eq. 0) goto 10
+            if (ier .ne. 7) goto 4
+               call newerr(38h Buram - approximation equals function, 
+     1            39, 4, 1)
+               goto  9
+   4           if (ier .ne. 8) goto 5
+                  call newerr(
+     1               40h Buram - no improvement in approximation, 40, 5,
+     2               1)
+                  goto  8
+   5              if (ier .ne. 9) goto 6
+                     call newerr(30h Buram - reached 50 iterations, 30
+     1                  , 6, 1)
+                     goto  7
+   6                 call eprint
+   7           continue
+   8        continue
+   9        continue
+  10     continue
+  11  call leave
+      return
+      end
+      subroutine burm1(npts, mesh, fn, maxitr, itol, m, n, p, q, 
+     1   delk)
+      integer npts
+      integer maxitr, itol, m, n
+      real mesh(npts), fn(npts), p(1), q(1), delk
+      common /cstak/ dstak
+      double precision dstak(500)
+      integer istkgt, iexptr, j, idig, iflr, istak(1000)
+      integer enptr, qkptr, i1mach, npptr, nqptr
+      real abs, qlrg, float, ws(1000), r1mach
+      logical smonor
+      equivalence (dstak, istak)
+      equivalence (dstak, ws)
+c    Burm1 is a double precision subroutine which finds a
+c   a rational function which is the best approximation,
+c   in the uniform or minimax sense, to a given discrete
+c   function.  The rational function is represented as
+c   the quotient of two polynomials each expanded in terms
+c   of Tchebychev polynomials.  This routine starts from an
+c   initial approximation and terminates for one of four
+c   reasons: (1) the error curve equioscillates and the
+c   alternating extrema match to ITOL digits, (2) the number
+c   of iterations exceeds MAXITR, (3) the approximation
+c   cannot be improved, or (4) the approximation is essentially
+c   equal to the given discrete function.
+c   Input:
+c   npts   - the number of mesh points.
+c   mesh   - the array of mesh points.
+c   fn     - the array of function values.
+c   maxitr - the maximum number of iterations.
+c   itol   - the number of digits to which the extrema should match.
+c   m      - the degree of the desired numerator polynomial.
+c   n      - the degree of the desired denominator polynomial.
+c   p      - the array of coefficients for the initial numerator.
+c   q      - the array of coefficients for the initial denominator.
+c   Output:
+c   p      - the array of coefficients for the numerator polynomial.
+c   q      - the array of coefficients for the denominator polynomial.
+c   delk   - the maximum error in the approximation.
+c   Error States (asterisk indicates recoverable):
+c   1  - invalid degree
+c   2  - too few mesh points
+c   3  - mesh is not strictly monotone
+c   4  - maxitr .lt. 0
+c   5  - invalid accuracy request
+c   6  - denominator is nonpositive
+c   7* - approximation equals function
+c   8* - no improvement in approximation
+c   9* - reached maximum no. of iterations
+      call enter(1)
+      if (m .lt. 0 .or. n .lt. 0) call seterr(
+     1   23h Burm1 - invalid degree, 23, 1, 2)
+      if (npts .lt. m+n+2) call seterr(28h Burm1 - too few mesh points
+     1   , 28, 2, 2)
+      if (.not. smonor(mesh, npts, 1)) call seterr(
+     1   38h Burm1 - mesh is not strictly monotone, 38, 3, 2)
+      if (maxitr .lt. 0) call seterr(22h Burm1 - maxitr .lt. 0, 22, 4, 2
+     1   )
+      idig = iflr(r1mach(5)*float(i1mach(11)))
+      if (itol .lt. 1 .or. idig .lt. itol) call seterr(
+     1   33h Burm1 - invalid accuracy request, 36, 5, 2)
+      qlrg = abs(q(1))
+      j = 2
+         goto  2
+   1     j = j+1
+   2     if (j .gt. n+1) goto  3
+         if (qlrg .lt. abs(q(j))) qlrg = abs(q(j))
+         goto  1
+   3  if (qlrg .ne. 0.e0) goto 4
+         call seterr(35h Burm1 - denominator is nonpositive, 35, 6, 2)
+         goto  11
+   4     j = 1
+            goto  6
+   5        j = j+1
+   6        if (j .gt. n+1) goto  7
+            q(j) = q(j)/qlrg
+            goto  5
+   7     j = 1
+            goto  9
+   8        j = j+1
+   9        if (j .gt. m+1) goto  10
+            p(j) = p(j)/qlrg
+            goto  8
+  10     continue
+  11  npptr = istkgt(m+1, 3)
+      nqptr = istkgt(n+1, 3)
+      enptr = istkgt(npts, 3)
+      qkptr = istkgt(npts, 3)
+      iexptr = istkgt(npts, 2)
+      call b1rm1(npts, mesh, fn, maxitr, itol, m, n, p, q, delk, ws(
+     1   npptr), ws(nqptr), ws(enptr), ws(qkptr), istak(iexptr))
+      call leave
+      return
+      end
+      subroutine b1rm1(npts, x, fn, maxitr, itol, m, n, p, q, 
+     1   delk, newp, newq, en, qk, iext)
+      integer npts
+      integer maxitr, itol, m, n, iext(npts)
+      real x(npts), fn(npts), p(1), q(1), delk, newp(1)
+      real newq(1), en(npts), qk(npts)
+      common /dfccom/ nitr
+      integer nitr
+      integer ier, nex, nerror, i, imin, imax
+      integer ilrg, lrgex
+      real bnd, abs, eps, delnew, r1mach
+      eps = r1mach(4)*10.0e0**itol
+      call extrmr(npts, fn, nex, iext, imax, imin, ilrg)
+      bnd = abs(fn(ilrg))*eps
+      call enqk(npts, x, fn, m, n, p, q, qk, en)
+      do  1 i = 1, npts
+         if (qk(i) .le. 0.0e0) call seterr(
+     1      35h Burm1 - denominator is nonpositive, 35, 6, 2)
+   1     continue
+      call extrmr(npts, en, nex, iext, imax, imin, ilrg)
+      delk = abs(en(ilrg))
+      delnew = delk
+      call movefr(m+1, p, newp)
+      call movefr(n+1, q, newq)
+      nitr = 0
+         goto  3
+   2     nitr = nitr+1
+   3     if (nitr .ge. maxitr) goto  6
+c   call Outpt3 (x,npts,p,q,delk,m,n,en,iext,nex)
+         if (delk .gt. bnd) goto 4
+            call seterr(38h Burm1 - approximation equals function, 39, 7
+     1         , 1)
+            return
+c   Test for optimal solution.
+   4     if (lrgex(npts, en, nex, iext, ilrg, itol) .ge. m+n+2) return
+         call lpstp(npts, x, fn, qk, delnew, m, n, newp, newq)
+         if (nerror(ier) .ne. 0) call erroff
+         call enqk(npts, x, fn, m, n, newp, newq, qk, en)
+         call extrmr(npts, en, nex, iext, imax, imin, ilrg)
+         delnew = abs(en(ilrg))
+         if (delk .gt. delnew) goto 5
+            call seterr(40h Burm1 - no improvement in approximation, 40,
+     1         8, 1)
+            return
+   5     call movefr(m+1, newp, p)
+         call movefr(n+1, newq, q)
+         delk = delnew
+         goto  2
+   6  call seterr(42h Burm1 - reached maximum no. of iterations, 42, 9
+     1   , 1)
+      return
+      end
+      subroutine enqk(npts, x, fn, m, n, p, q, qk, en)
+      integer npts
+      integer m, n
+      real x(npts), fn(npts), p(1), q(1), qk(npts), en(npts)
+      integer i
+      real pk, tchbp
+c
+c   Subroutine  Enqk computes en & Qk.
+c   en=error values at mesh points.
+c   Qk=value of denominator polynomial at mesh points.
+c
+      if (npts .le. 0 .or. m .lt. 0 .or. n .lt. 0) call seterr(
+     1   22henQk-invalid dimension, 22, 1, 2)
+      do  1 i = 1, npts
+         qk(i) = tchbp(n, q, x(i), x(1), x(npts))
+         if (qk(i) .eq. 0.e0) call seterr(20henQk-divisor .eq. 0., 20, 2
+     1      , 2)
+         pk = tchbp(m, p, x(i), x(1), x(npts))
+         en(i) = (fn(i)*qk(i)-pk)/qk(i)
+   1     continue
+      return
+      end
+      integer function lrgex(npts, en, nex, iext, ilrg, tol)
+      integer nex, npts
+      integer iext(nex), ilrg, tol
+      real en(npts)
+      integer j, k, l
+      real abs, hold
+c
+c    Function Lrgex  finds the no. of error extrema with magnitudes
+c    within tolerance of magnitude of largest error.
+c
+      if (npts .le. 0) call seterr(24hLrgex -invalid dimension, 24, 1, 2
+     1   )
+      if (nex .le. 0 .or. ilrg .le. 0) call seterr(
+     1   20hLrgex -invalid index, 20, 2, 2)
+      k = 0
+      do  1 j = 1, nex
+         l = iext(j)
+         hold = abs(en(ilrg))-abs(en(l))
+         if (hold .le. 10.**(-tol)*abs(en(ilrg))) k = k+1
+   1     continue
+      lrgex = k
+      return
+      end
+      subroutine lpstp(npts, mesh, fn, qk, delk, m, n, p, q)
+      integer npts
+      integer m, n
+      real mesh(npts), fn(npts), qk(npts), delk, p(1), q(1)
+      common /cstak/ dstak
+      double precision dstak(500)
+      integer istkgt, aptr, bptr, cptr, xptr, istak(1000)
+      real ws(1000)
+      equivalence (dstak, istak)
+      equivalence (dstak, ws)
+c    Lpstp defines the linear programming subproblem of the
+c   Differential Correction algorithm.  It also provides
+c   the interface to the general purpose linear programming
+c   package.
+c   Input:
+c   npts   - the number of mesh points.
+c   mesh   - the array of mesh points.
+c   fn     - the array of function values.
+c   Qk     - the array of current denominator values.
+c   delk   - the current minimax error.
+c   m      - the degree of the numerator polynomial.
+c   n      - the degree of the denominator polynomial.
+c   p      - the current numerator polynomial.
+c   q      - the current denominator polynomial.
+c   Output:
+c   p      - the array of coefficients for the numerator polynomial.
+c   q      - the array of coefficients for the denominator polynomial.
+c   Error States (asterisk indicates fatal):
+c   1* - invalid degree
+c   2* - too few mesh points
+c   3* - nonpositive delk
+c   4  - no improvement in the lp subproblem
+      call enter(1)
+      if (m .lt. 0 .or. n .lt. 0) call seterr(
+     1   23h Lpstp - invalid degree, 23, 1, 2)
+      if (npts .lt. m+n+2) call seterr(28h Lpstp - too few mesh points
+     1   , 28, 2, 2)
+      aptr = istkgt(3*npts+1, 3)
+      bptr = istkgt(2*(npts+n+1), 3)
+      cptr = istkgt(m+n+3, 3)
+      xptr = istkgt(m+n+3, 3)
+      call l9stp(npts, mesh, fn, qk, delk, m, n, p, q, ws(aptr), ws(
+     1   bptr), ws(cptr), ws(xptr))
+      call leave
+      return
+      end
+      subroutine l9stp(npts, mesh, fn, qk, delk, m, n, p, q, a, b,
+     1   c, x)
+      integer npts
+      integer m, n
+      real mesh(npts), fn(npts), qk(npts), delk, p(1), q(1)
+      real a(1), b(1), c(1), x(1)
+      common /difcom/ nptsc, mc, nc, i1, i2, i3, i4
+      integer nptsc, mc, nc, i1, i2, i3
+      integer i4
+      external difmt
+      integer ier, nerror, i, j, ierr, mm
+      integer nn
+      real abs, ctx, ctxnew, qlrg, float, r1mach
+      nptsc = npts
+      mc = m
+      nc = n
+      i1 = npts
+      i2 = i1+npts
+      i3 = i2+n+1
+      i4 = i3+n+1
+      mm = i4
+      nn = m+n+3
+      call movefr(n+1, q, x)
+      call movefr(m+1, p, x(n+2))
+      x(nn) = 0.e0
+      call setr(i2, 0.0e0, b)
+      call setr(i4-i2, -1.0e0, b(i2+1))
+      call setr(nn, 0.0e0, c)
+      c(nn) = -1.0e0
+      call movefr(npts, mesh, a)
+      call movefr(npts, fn, a(npts+1))
+      call movefr(npts, qk, a(2*npts+1))
+      if (delk .le. 0.0e0) call seterr(25h Lpstp - nonpositive delk, 25,
+     1   3, 2)
+      a(3*npts+1) = delk
+      ctx = 0.0e0
+c   Solve the LP problem: max C(T)X subject to AX >= B.
+c   The subroutine  Difmt derives the matrix A from
+c   the data stored in the array A.
+      call lpph2(a, mm, nn, difmt, b, c, x, 4*mm, ctxnew)
+      if (nerror(ier) .ne. 0) call erroff
+      if (ctx .ge. ctxnew) goto 10
+         qlrg = 0.0e0
+         j = 1
+            goto  2
+   1        j = j+1
+   2        if (j .gt. n+1) goto  3
+            if (qlrg .lt. abs(x(j))) qlrg = abs(x(j))
+            goto  1
+   3     j = 1
+            goto  5
+   4        j = j+1
+   5        if (j .gt. n+1) goto  6
+            q(j) = x(j)/qlrg
+            goto  4
+   6     i = 0
+         j = n+2
+            goto  8
+   7        j = j+1
+   8        if (j .gt. m+n+2) goto  9
+            i = i+1
+            p(i) = x(j)/qlrg
+            goto  7
+   9     continue
+         goto  11
+  10     call seterr(44h Lpstp - no improvement in the lp subproblem, 
+     1      44, 4, 1)
+  11  return
+      end
+      subroutine difmt(inprod, a, mm, nn, irow, x, dinprd)
+      integer nn
+      integer mm, irow
+      real a(1), x(nn), dinprd
+      logical inprod
+      common /difcom/ npts, m, n, i1, i2, i3, i4
+      integer npts, m, n, i1, i2, i3
+      integer i4
+      integer max0, irm1, irm2, irm3, j, zptr
+      integer jp, maxmn, fnptr, qzptr
+      real fct, delk, z, fn, fdelk, tchbp
+      real qz
+c    Difmt handles references by the LP routine to
+c   the matrix for the linear programming subproblem.
+      call enter(1)
+      if (mm .ne. i4 .or. nn .ne. m+n+3) call seterr(
+     1   26h Difmt - invalid dimension, 26, 1, 2)
+      if (irow .lt. 0 .or. mm .lt. irow) call seterr(
+     1   22h Difmt - invalid index, 22, 2, 2)
+      irm1 = irow-i1
+      irm2 = irow-i2
+      irm3 = irow-i3
+      if ((.not. inprod) .or. i2 .ge. irow) goto 3
+         if (i3 .ge. irow) goto 1
+            dinprd = -x(irm3)
+            goto  2
+   1        dinprd = x(irm2)
+   2     continue
+         goto  18
+   3     if (i2 .ge. irow) goto 6
+            call setr(nn, 0.0e0, x)
+            if (i3 .ge. irow) goto 4
+               x(irm3) = -1.0e0
+               goto  5
+   4           x(irm2) = 1.0e0
+   5        continue
+            goto  17
+   6        if (i1 .ge. irow) goto 7
+               fct = -1.0e0
+               zptr = irm1
+               goto  8
+   7           fct = 1.0e0
+               zptr = irow
+   8        z = a(zptr)
+            fnptr = zptr+npts
+            fn = a(fnptr)
+            qzptr = fnptr+npts
+            qz = a(qzptr)
+            delk = a(3*npts+1)
+            fdelk = fct*fn+delk
+            if (.not. inprod) goto 9
+               dinprd = fdelk*tchbp(n, x, z, a(1), a(npts))-fct*tchbp(m,
+     1            x(n+2), z, a(1), a(npts))+qz*x(nn)
+               goto  16
+   9           maxmn = max0(m, n)
+               call tchcf(z, a(1), a(npts), maxmn, x)
+               j = m+1
+                  goto  11
+  10              j = j-1
+  11              if (1 .gt. j) goto  12
+                  jp = j+n+1
+                  x(jp) = (-fct)*x(j)
+                  goto  10
+  12           j = 1
+                  goto  14
+  13              j = j+1
+  14              if (j .gt. n+1) goto  15
+                  x(j) = fdelk*x(j)
+                  goto  13
+  15           x(nn) = qz
+  16        continue
+  17  continue
+  18  call leave
+      return
+      end
+      subroutine tchcf(x, a, b, deg, xx)
+      integer deg
+      real x, a, b, xx(1)
+      integer i
+      real twoxx
+c
+c    Subroutine  Tchcf computes the deg+1 Tchebycheff
+c    coefficients of the point x.
+c
+      call enter(1)
+      if (deg .lt. 0) call seterr(21h Tchcf-invalid degree, 21, 1, 2)
+      xx(1) = 1.e0
+      if (deg .le. 0) goto 3
+         if (b .gt. a) goto 1
+            call seterr(23h Tchcf-invalid interval, 23, 2, 2)
+            goto  2
+   1        xx(2) = 2.e0*(x-(a+b)/2.e0)/(b-a)
+cscale x to the interval (-1.e0,1.e0)
+   2  continue
+   3  if (deg .gt. 1) twoxx = 2.e0*xx(2)
+      i = 3
+         goto  5
+   4     i = i+1
+   5     if (i .gt. deg+1) goto  6
+         xx(i) = twoxx*xx(i-1)-xx(i-2)
+         goto  4
+   6  call leave
+      return
+      end
diff --git a/usr/src/cmd/efl/efltest/Dgl.e b/usr/src/cmd/efl/efltest/Dgl.e

new file mode 100644 (file)

index 0000000..64ce61a
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Dgl.e
@@ -0,0 +1,182 @@
+  Procedure DglsBP(Nu,Order,BC,E)
+  
+# To determine which ODE should use which boundary condition.
+  
+# Mnemonic - Double precision Galerkin's method for Linear Systems,
+#            Boundary condition Placement.
+
+# Scratch Space Allocated -
+
+#       S(DglsBP) <= Nu*(4*Nu+15)
+
+# Integer words.
+  
+  Integer Nu,Order(Nu,Nu,2),BC(Nu,2,2),E(Nu,2,2)
+  
+  Integer inow,inowold,i,j,l,iMaxord,iCE,Istkgt,iPPS
+  Logical AllZero
+  
+  Struct Nodei { Integer bp,N,j,R(1) }
+  
+  Define Push  +1
+  Define Search  0
+  Define Pop  -1
+
+# Define Node = Is(inow) -> Nodei
+  
+  Include dstack
+
+# Check the input for errors.
+
+  If ( Nu < 1 ) { Seterr("DglsBP - Nu.lt.1",16,1,2) }
+
+  Do l = 1 , 2 
+    {
+
+    Do i = 1 , Nu 
+      {
+      AllZero = .True.    # Is Order(i,.,l) = (-1,...,-1)?
+      Do j = 1 , Nu 
+        {
+        AllZero &= Order(i,j,l) == (-1)
+        If ( Order(i,j,l) < (-1) | Order(i,j,l) > 2 )
+          { Seterr("DglsBP - Order(i,j,l) not one of -1,0,1,2",41,2,2) }
+        }
+      If ( ( BC(i,1,l) ~= (-2) & BC(i,1,l) ~= 0 ) |
+           ( BC(i,2,l) ~= (-2) & BC(i,2,l) ~= 1 ) )
+        { Seterr("DglsBP - BC(i,.,l) not one of -2,0,1",36,3,2) }
+      If ( AllZero )
+        { Seterr("DglsBP - Order(i,.,l)=(-1,...,-1)",33,4,2) }
+      }
+    }
+  
+  Enter(1)
+  
+  iCE = Istkgt(Nu,2)    # Complement of E.
+
+# Maxord(i,l) = Max over j=1,...,Nu Order(i,j,l).
+
+  iMaxord = Istkgt(2*Nu,2)
+  Seti(2*Nu,-1,Is(iMaxord))
+
+  Do l = 1 , 2 
+    {
+    Do i = 1 , Nu 
+      {
+      Do j = 1 , Nu 
+        {
+        Is(iMaxord+i-1+(l-1)*Nu) = Max0(Is(iMaxord+i-1+(l-1)*Nu),
+                                        Order(i,j,l))
+        }
+      }
+    }
+  
+  i = 0 ; iPPS = Push
+
+  While ( i < 4*Nu | iPPS ~= Push )
+    {
+    
+    Switch ( iPPS )
+      {
+
+      Case Push:    # Make a node.
+
+        inowold = inow
+        i += 1 ; inow = Istkgt(Nu+3,2)
+        Is(inow) -> Nodei.bp = inowold
+      
+#       Get the candidates for E(i).
+      
+        D6lsBP(i,Nu,Order,BC,E,
+               Is(iMaxord),Is(iCE),Is(inow) -> Nodei.R,Is(inow) -> Nodei.N)
+      
+        Is(inow) -> Nodei.j = 0
+        iPPS = Search ; Break
+
+      Case Search:    # Searching a node.
+
+        Is(inow) -> Nodei.j += 1
+      
+        If ( Is(inow) -> Nodei.j > Is(inow) -> Nodei.N )    # Back-up.
+          { iPPS = Pop ; Next }
+      
+        E(i,1,1) = Is(inow) -> Nodei.R(Is(inow) -> Nodei.j)
+        iPPS = Push ; Break
+
+      Case Pop:    # Backing up a Node.
+
+        inow = Is(inow) -> Nodei.bp ; Istkrl(1) ; i -= 1
+        iPPS = Search ; Break
+
+      }    # End Switch.
+
+    If ( i == 0 )
+      { Seterr("DglsBP - Improper Boundary Conditions",37,5,1) ; Break }
+
+    }    # End While.
+
+  Leave()
+  
+  Return
+  
+  End
+  Procedure D6lsBP(i,Nu,Order,BC,E,
+                   Maxord,CE,R,N)
+  
+  Integer i,Nu,Order(Nu,Nu,2),BC(1),E(1),    # BC(Nu,2,2),E(Nu,2,2),
+          Maxord(Nu,2),CE(Nu),R(Nu),N    # E(i-1),R(N).
+  
+  Integer j,LR,DM,NBCs,l,ii
+
+  If ( BC(i) < 0 ) { N = 1 ; R(N) = 0 ; Return }
+
+# LR = 1 for left, LR = 2 for right.
+
+  LR = 1+(i-1)/(2*Nu)
+
+# DM = 1 for Dirichlet, DM = 2 for Mixed boundary conditions.
+
+  DM = 1+Mod((i-1)/Nu,2)
+
+  ii = Mod(i,Nu) ; If ( ii == 0 ) { ii = Nu }    # B(i) = B(ii,DM,LR).
+  
+  N = 0
+  
+  Do j = 1 , Nu  { CE(j) = j }    # CE = Complement of E.
+  If ( i <= 2*Nu )
+    {
+    For ( j = 1 , j < i , j += 1 )
+      {
+      If ( BC(j) >= 0 ) { CE(E(j)) = 0 }
+      }
+    }
+  Else
+    {
+    For ( j = 2*Nu+1 , j < i , j += 1 )
+      {
+      If ( BC(j) >= 0 ) { CE(E(j)) = 0 }
+      }
+    }
+  
+  Do j = 1 , Nu 
+    {
+    If ( CE(j) == 0 ) { Next }
+
+    NBCs = 0
+    
+    For ( l = 1 , l < i , l += 1 )
+      {
+      If ( E(l) == j & BC(l) >= 0 ) { NBCs += 1 }
+      }
+    
+    If ( ( DM == 1 & Maxord(j,LR) > BC(i) ) |
+         ( DM == 2 & Order(j,ii,LR) > BC(i) ) )
+      {
+      If ( NBCs < Max0(Maxord(j,1),Maxord(j,2)) )
+        { N += 1 ; R(N) = j }
+      }
+    }
+  
+  Return
+  
+  End
diff --git a/usr/src/cmd/efl/efltest/Dgl.out b/usr/src/cmd/efl/efltest/Dgl.out

new file mode 100644 (file)

index 0000000..e6adc3a
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Dgl.out
@@ -0,0 +1,168 @@
+      subroutine dglsbp(nu, order, bc, e)
+      integer nu
+      integer order(nu, nu, 2), bc(nu, 2, 2), e(nu, 2, 2)
+      common /cstak/ ds
+      double precision ds(500)
+      integer ice, istkgt, max0, i, j, l
+      integer ipps, inow, imaord, inoold, is(1000)
+      real rs(1000)
+      logical allero, ls(1000)
+      complex cs(500)
+      double precision ws(500)
+      integer temp, temp1
+      equivalence (ds(1), cs(1), ws(1), rs(1), is(1), ls(1))
+c To determine which ODE should use which boundary condition.
+c Mnemonic - Double precision Galerkin's method for Linear Systems,
+c            Boundary condition Placement.
+c Scratch Space Allocated -
+c       S(DglsBP) <= Nu*(4*Nu+15)
+c Integer words.
+c Define Node = Is(inow) -> Nodei
+c Check the input for errors.
+      if (nu .lt. 1) call seterr(16hDglsBP - Nu.lt.1, 16, 1, 2)
+      do  3 l = 1, 2
+         do  2 i = 1, nu
+c Is Order(i,.,l) = (-1,...,-1)?
+            allero = .true.
+            do  1 j = 1, nu
+               allero = allero .and. order(i, j, l) .eq. (-1)
+               if (order(i, j, l) .lt. (-1) .or. order(i, j, l) .gt. 2) 
+     1            call seterr(
+     2            41hDglsBP - Order(i,j,l) not one of -1,0,1,2, 41, 2, 2
+     3            )
+   1           continue
+            if (bc(i, 1, l) .ne. (-2) .and. bc(i, 1, l) .ne. 0 .or. bc(i
+     1         , 2, l) .ne. (-2) .and. bc(i, 2, l) .ne. 1) call seterr(
+     2         36hDglsBP - BC(i,.,l) not one of -2,0,1, 36, 3, 2)
+            if (allero) call seterr(
+     1         33hDglsBP - Order(i,.,l)=(-1,...,-1), 33, 4, 2)
+   2        continue
+   3     continue
+      call enter(1)
+c Complement of E.
+      ice = istkgt(nu, 2)
+c Maxord(i,l) = Max over j=1,...,Nu Order(i,j,l).
+      imaord = istkgt(2*nu, 2)
+      call seti(2*nu, -1, is(imaord))
+      do  6 l = 1, 2
+         do  5 i = 1, nu
+            do  4 j = 1, nu
+               temp1 = imaord+i-1+(l-1)*nu
+               temp = imaord+i-1+(l-1)*nu
+               is(temp1) = max0(is(temp), order(i, j, l))
+   4           continue
+   5        continue
+   6     continue
+      i = 0
+      ipps = 1
+   7  if (i .ge. 4*nu .and. ipps .eq. 1) goto  15
+         goto  12
+c Make a node.
+   8        inoold = inow
+            i = i+1
+            inow = istkgt(nu+3, 2)
+            is(inow) = inoold
+c       Get the candidates for E(i).
+            call d6lsbp(i, nu, order, bc, e, is(imaord), is(ice), is(
+     1         inow+3), is(inow+1))
+            is(inow+2) = 0
+            ipps = 0
+            goto  13
+            goto  13
+c Searching a node.
+   9        is(inow+2) = is(inow+2)+1
+            if (is(inow+2) .le. is(inow+1)) goto 10
+               ipps = -1
+c Back-up.
+               goto  7
+  10        temp = inow+2+is(inow+2)-1
+            e(i, 1, 1) = is(temp+1)
+            ipps = 1
+            goto  13
+            goto  13
+c Backing up a Node.
+  11        inow = is(inow)
+            call istkrl(1)
+            i = i-1
+            ipps = 0
+            goto  13
+            goto  13
+  12        temp = ipps+2
+            if (temp .gt. 0 .and. temp .le. 3) goto ( 11,  9,  8), temp
+c End Switch.
+  13     if (i .ne. 0) goto 14
+            call seterr(37hDglsBP - Improper Boundary Conditions, 37, 5,
+     1         1)
+            goto  15
+  14     continue
+         goto  7
+c End While.
+  15  call leave
+      return
+      end
+      subroutine d6lsbp(i, nu, order, bc, e, maxord, ce, r, n)
+      integer nu
+      integer i, order(nu, nu, 2), bc(1), e(1), maxord(nu, 2), ce(nu)
+      integer r(nu), n
+      integer mod, max0, j, l, nbcs, dm
+      integer ii, lr
+      integer temp
+c BC(Nu,2,2),E(Nu,2,2),
+c E(i-1),R(N).
+      if (bc(i) .ge. 0) goto 1
+         n = 1
+         r(n) = 0
+         return
+c LR = 1 for left, LR = 2 for right.
+   1  lr = (i-1)/(2*nu)+1
+c DM = 1 for Dirichlet, DM = 2 for Mixed boundary conditions.
+      dm = mod((i-1)/nu, 2)+1
+      ii = mod(i, nu)
+      if (ii .eq. 0) ii = nu
+c B(i) = B(ii,DM,LR).
+      n = 0
+      do  2 j = 1, nu
+         ce(j) = j
+   2     continue
+c CE = Complement of E.
+      if (i .gt. 2*nu) goto 7
+         j = 1
+            goto  4
+   3        j = j+1
+   4        if (j .ge. i) goto  6
+            if (bc(j) .lt. 0) goto 5
+               temp = e(j)
+               ce(temp) = 0
+   5        continue
+            goto  3
+   6     continue
+         goto  12
+   7     j = 2*nu+1
+            goto  9
+   8        j = j+1
+   9        if (j .ge. i) goto  11
+            if (bc(j) .lt. 0) goto 10
+               temp = e(j)
+               ce(temp) = 0
+  10        continue
+            goto  8
+  11     continue
+  12  do  18 j = 1, nu
+         if (ce(j) .eq. 0) goto  18
+         nbcs = 0
+         l = 1
+            goto  14
+  13        l = l+1
+  14        if (l .ge. i) goto  15
+            if (e(l) .eq. j .and. bc(l) .ge. 0) nbcs = nbcs+1
+            goto  13
+  15     if ((dm .ne. 1 .or. maxord(j, lr) .le. bc(i)) .and. (dm .ne. 2
+     1       .or. order(j, ii, lr) .le. bc(i))) goto 17
+            if (nbcs .ge. max0(maxord(j, 1), maxord(j, 2))) goto 16
+               n = n+1
+               r(n) = j
+  16        continue
+  17     continue
+  18     continue
+      return
+      end
diff --git a/usr/src/cmd/efl/efltest/Hard.e b/usr/src/cmd/efl/efltest/Hard.e

new file mode 100644 (file)

index 0000000..7e79bab
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Hard.e
@@ -0,0 +1,105 @@
+struct t { struct s { character(6) a(2),b;integer c} a(3); integer b(6) }
+procedure sam(x)
+t x(4),y
+integer z(5,7)
+x(2).a(2).a(2) = "abc"
+y.b(3) = 4
+z(2,4)->s.c = 2
+z->s.a(2) = "xyz"
+end
+procedure
+struct { field(3) a,b,c,d; field(10000) e; field(3) f} x
+integer m
+x.a = 2
+x.b = 2
+x.c = 2
+x.d = 2
+x.e = 2
+x.f = 2
+x.a-=2
+x.b-=2
+x.c-=2
+x.d-=2
+x.a*=2
+x.b*=2
+x.c*=2
+x.d*=2
+x.c+=2
+x.c *= x.d += x.b = (x.a=1)+2
+end
+
+
+procedure
+struct t { field(0:3) a; field(20) b; field(60) c}
+t x
+integer k
+k = x.a+x.b+x.c
+end
+procedure
+struct t { field(50) a,b,c,d,e }
+integer i
+t x(5)
+x(2).a = i
+x(2).b = i
+x(2).c = i
+x(2).d = i
+x(2).e = i
+
+do i = x(1).a, x(3).b,x(5).e
+       x(i**2).b *= x(i**2+1).e
+end
+procedure
+struct t {real a} x
+x.a = 1.
+       {
+       struct t {integer b, c} y
+       y.b=1
+       }
+x.a = 2.
+end
+common(cc) complex a
+integer b
+
+procedure
+integer a
+{logical a;a = .true.}
+a = 1
+{logical a;a=.false.}
+a=2
+end
+procedure
+a = 1
+end
+procedure a(b)
+end
+
+procedure alltyp(y)
+struct {
+       real a(3)
+       long real b(3)
+       integer c(3)
+       complex d(3)
+       logical e(3)
+       character(8) f(3)
+       character(9) g(3)
+       } x, y
+
+x.a(3) = x.b(3) = x.c(3) = x.d(3) = 1
+x.e(3) = false
+x.f(3) = x.g(3) = "abcdefg"
+end
+procedure
+integer i,j
+logical l
+switch(i)
+       {
+       case 1: if(l) goto case 2
+               else switch(j)
+                       {
+                       case 1: goto case 2
+                       case 2: goto case 1
+                       }
+       case 3: j=2
+       case 2: while(i!=j) ++j
+       }
+end
diff --git a/usr/src/cmd/efl/efltest/Hard.out b/usr/src/cmd/efl/efltest/Hard.out

new file mode 100644 (file)

index 0000000..e5979c1
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/Hard.out
@@ -0,0 +1,131 @@
+      subroutine sam(x)
+      integer x(27, 4)
+      integer y(27), z(5, 7)
+      call ef1asc(x(10, 2), 6, 3habc, 3)
+      y(24) = 4
+      z(8, 4) = 2
+      call ef1asc(z(3, 1), 6, 3hxyz, 3)
+      end
+c  main program
+      integer mod, m, x(2)
+      x(1) = 3*(x(1)/3)+1
+      x(1) = x(1)-3*(mod(x(1)/3, 3)-1)
+      x(1) = x(1)-9*(mod(x(1)/9, 3)-1)
+      x(1) = mod(x(1), 27)+27
+      x(2) = 10000*(x(2)/10000)+1
+      x(2) = mod(x(2), 10000)+10000
+      x(1) = x(1)-2
+      x(1) = x(1)-6
+      x(1) = x(1)-18
+      x(1) = x(1)-54
+      x(1) = 3*(x(1)/3)+2*(mod(x(1), 3)+1)-1
+      x(1) = x(1)-3*(mod(x(1)/3, 3)-(2*(mod(x(1)/3, 3)+1)-1))
+      x(1) = x(1)-9*(mod(x(1)/9, 3)-(2*(mod(x(1)/9, 3)+1)-1))
+      x(1) = mod(x(1), 27)+27*(2*(x(1)/27+1)-1)
+      x(1) = x(1)+18
+      x(1) = 3*(x(1)/3)
+      x(1) = x(1)-3*(mod(x(1)/3, 3)-(mod(x(1), 3)+2))
+      x(1) = x(1)+27*(mod(x(1)/3, 3)+1)
+      x(1) = x(1)-9*(mod(x(1)/9, 3)-((mod(x(1)/9, 3)+1)*(x(1)/27+1)-1))
+      end
+c  main program
+      integer mod, k, x(1)
+      k = mod(x(1), 4)+mod(x(1)/4, 20)+1+x(1)/80+1
+      end
+c  main program
+      integer mod, i, x(3, 5)
+      integer temp, temp1, temp2, temp3, temp4
+      x(1, 2) = 50*(x(1, 2)/50)+i-1
+      x(1, 2) = mod(x(1, 2), 50)+50*(i-1)
+      x(2, 2) = 50*(x(2, 2)/50)+i-1
+      x(2, 2) = mod(x(2, 2), 50)+50*(i-1)
+      x(3, 2) = i-1
+      temp2 = mod(x(1, 1), 50)+1
+      temp1 = x(1, 3)/50+1
+      temp = x(3, 5)+1
+      do  1 i = temp2, temp1, temp
+         temp4 = i**2
+         temp3 = i**2
+         x(1, temp4) = mod(x(1, temp4), 50)+50*((x(1, temp4)/50+1)*(x(3,
+     1      temp3+1)+1)-1)
+   1     continue
+      end
+c  main program
+      real x(1)
+      integer y(2)
+      x(1) = 1.
+      y(1) = 1
+      x(1) = 2.
+      end
+c  main program
+      common /cc/ a3
+      complex a3
+      integer a, b
+      logical a1, a2
+      a2 = .true.
+      a = 1
+      a1 = .false.
+      a = 2
+      end
+c  main program
+      common /cc/ a
+      complex a
+      integer b
+      a = 1
+      end
+      subroutine a(b)
+      real b
+      common /cc/ a1
+      complex a1
+      integer b1
+      end
+      subroutine alltyp(y, y1, y2, y3, y4)
+      integer y(38)
+      real y1(38)
+      logical y2(38)
+      complex y3(19)
+      double precision y4(19)
+      common /cc/ a
+      complex a
+      integer b, x(38)
+      real x1(38)
+      logical x2(38)
+      complex x3(19)
+      double precision x4(19)
+      equivalence (x(1), x1(1), x2(1), x3(1), x4(1))
+      x3(10) = 1
+      x(13) = x3(10)
+      x4(5) = x(13)
+      x1(3) = x4(5)
+      x2(23) = .false.
+      call ef1asc(x(36), 9, 7habcdefg, 7)
+      call ef1asc(x(28), 8, x(36), 9)
+      end
+c  main program
+      common /cc/ a
+      complex a
+      integer b, i, j
+      logical l
+      goto  11
+   1     if (.not. l) goto 2
+            goto  9
+            goto  7
+   2        goto  5
+   3           goto  4
+               goto  6
+   4           goto  3
+               goto  6
+   5           if (j .eq. 2) goto  4
+               if (j .eq. 1) goto  3
+   6     continue
+   7     goto  12
+   8     j = 2
+         goto  12
+   9     if (i .eq. j) goto  10
+            j = j+1
+            goto  9
+  10     continue
+         goto  12
+  11     if (i .gt. 0 .and. i .le. 3) goto ( 1,  9,  8), i
+  12  continue
+      end
diff --git a/usr/src/cmd/efl/efltest/dstack b/usr/src/cmd/efl/efltest/dstack

new file mode 100644 (file)

index 0000000..371b12e
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/dstack
@@ -0,0 +1,4 @@
+  Common (Cstak) Ds ; Long Real Ds(500)
+  Long Real Ws(500)
+  Real Rs(1000) ; Integer Is(1000) ; Complex Cs(500) ; Logical Ls(1000)
+  Equivalence ( Ds(1),Cs(1),Ws(1),Rs(1),Is(1),Ls(1))
diff --git a/usr/src/cmd/efl/efltest/rstack b/usr/src/cmd/efl/efltest/rstack

new file mode 100644 (file)

index 0000000..93d9903
--- /dev/null
+++ b/usr/src/cmd/efl/efltest/rstack
@@ -0,0 +1,4 @@
+  common (cstak) ds ; long real ds(500)
+  real ws(500)
+  real rs(1000) ; integer is(1000) ; complex cs(500) ; logical ls(1000)
+  equivalence  ds(1),cs(1),ws(1),rs(1),is(1),ls(1)
diff --git a/usr/src/cmd/efl/error.c b/usr/src/cmd/efl/error.c

new file mode 100644 (file)

index 0000000..16a1ac3
--- /dev/null
+++ b/usr/src/cmd/efl/error.c
@@ -0,0 +1,137 @@
+#include "defs"
+
+char *linerr()
+{
+static char buff[50];
+register int i;
+
+for(i = filedepth; i>0 && filenames[i]==NULL ; --i)
+       ;
+if(i > 0)
+       sprintf(buff, "on line %d of file %s", yylineno, filenames[i]);
+else
+       sprintf(buff, "on line %d", yylineno);
+return(buff);
+}
+
+
+
+laberr(s,t)
+char *s;
+char *t;
+{
+errmess("Label error", s, t);
+}
+
+
+
+
+
+exprerr(s,t)
+char *s;
+ptr t;
+{
+errmess("Expression error", s, t);
+}
+
+
+
+
+execerr(s,t)
+char *s, *t;
+{
+errmess("Error", s, t);
+}
+
+
+errmess(m,s,t)
+char *m, *s, *t;
+{
+fprintf(diagfile, "**%s %s:  ", m, linerr());
+if(s)
+       fprintf(diagfile, s, t);
+fprintf(diagfile, "\n");
+++nerrs;
+}
+
+
+
+dclerr(s, n)
+char *s, *n;
+{
+extern int nerrs;
+
+fprintf(diagfile, "**Error %s: Declaration for %s: %s\n",
+               linerr(), n, s);
+++nerrs;
+}
+
+
+
+
+badtag(routine, tag)
+char *routine;
+int tag;
+{
+char buff[100];
+sprintf(buff, "impossible tag %d in routine %s", tag, routine);
+fatal(buff);
+}
+
+
+
+fatal1(s,t)
+char *s;
+int t;
+{
+
+sprintf(msg, s, t);
+fatal(msg);
+}
+
+
+
+fatal(s)
+char *s;
+{
+fprintf(diagfile, "\n***Compiler error %s.", linerr());
+if(s) fprintf(diagfile, "   %s.", s);
+fprintf(diagfile, "\n");
+fflush(stdout);
+
+if(dumpcore)
+       abort(0);
+else   {
+       rmiis();
+       exit(-1);
+       }
+}
+
+
+
+warn1(s,t)
+char *s;
+int t;
+{
+sprintf(msg, s, t);
+warn(msg);
+}
+
+
+
+
+warn(s)
+char *s;
+{
+++nwarns;
+if( !nowarnflag)
+       fprintf(diagfile, "*Warning: %s\n", s);
+}
+
+
+
+yyerror(s)
+char *s;
+{
+errmess(s, CNULL, CNULL);
+}
diff --git a/usr/src/cmd/efl/exec.c b/usr/src/cmd/efl/exec.c

new file mode 100644 (file)

index 0000000..ea8584b
--- /dev/null
+++ b/usr/src/cmd/efl/exec.c
@@ -0,0 +1,441 @@
+#include "defs"
+
+exlab(n)
+register int n;
+{
+if(n==0 && thisexec->labelno && !(thisexec->labused))
+       {
+       thisexec->labused = 1;
+       n = thisexec->labelno;
+       }
+
+if(!prevbg || n!=0)  /* avoid empty statement */
+       {
+       if(comments && !afterif) putcomment();
+       putic(ICBEGIN, n);
+       putic(ICINDENT, ctllevel);
+       if(n != 0)
+               if(stnos[n] != 0)
+                       fatal("statement number changed");
+               else    stnos[n] = ( nxtstno += tailor.deltastno) ;
+       TEST fprintf(diagfile, "LABEL %d\n", n);
+       thisexec->nftnst++;
+       afterif = 0;
+       }
+}
+
+
+exgoto(n)
+int n;
+{
+exlab(0);
+exgo1(n);
+}
+
+exgoind(n)
+int n;
+{
+exlab(0);
+putic(ICKEYWORD,FGOTO);
+putic(ICINDPTR,n);
+TEST fprintf(diagfile, "goto indirect %o\n", n);
+}
+
+
+
+exgo1(n)
+int n;
+{
+putic(ICKEYWORD,FGOTO);
+putic(ICLABEL,n);
+TEST fprintf(diagfile, "goto %d\n", n);
+}
+
+
+excompgoto(labs,index)
+ptr labs;
+register ptr index;
+{
+register int first;
+register ptr p;
+
+index = simple(LVAL,index);
+if(tailor.ftn77)
+       exlab(0);
+else
+       {
+       int ncases = 0;
+       for(p = labs ; p ; p = p->nextp)
+               ++ncases;
+       exif1( mknode(TLOGOP, OPAND,
+               mknode(TRELOP,OPGT, cpexpr(index), mkint(0)),
+               mknode(TRELOP,OPLE, cpexpr(index), mkint(ncases)) ));
+       }
+
+putic(ICKEYWORD, FGOTO);
+putic(ICOP,OPLPAR);
+
+first = 1;
+for(p = labs ; p ; p = p->nextp)
+       {
+       if(first)   first = 0;
+       else   putic(ICOP,OPCOMMA);
+       putic(ICLABEL,p->datap);
+       }
+putic(ICOP,OPRPAR);
+frchain(&labs);
+
+putic(ICOP,OPCOMMA);
+prexpr(index);
+frexpr(index);
+TEST fprintf(diagfile, "computed goto\n");
+}
+
+
+
+
+excall(p)
+register ptr p;
+{
+register ptr q1, q2, q3;
+ptr mkholl(), exioop();
+
+if(p->tag==TNAME || p->tag==TFTNBLOCK)
+       p = mkcall(p, PNULL);
+
+if(p->tag == TERROR)
+       {
+       frexpr(p);
+       return;
+       }
+if(p->tag != TCALL)
+       badtag("excall", p->tag);
+
+q1 = p->leftp;
+q2 = (q1->tag==TFTNBLOCK ? q1 : q1->sthead->varp);
+if(q2->vtype!=TYUNDEFINED && q2->vtype!=TYSUBR)
+       {
+       dclerr("attempt to use a variable as a subroutine", p->sthead->namep);
+       frexpr(p);
+       return;
+       }
+q1->vtype = q2->vtype = TYSUBR;
+if(q1->vdcldone==0)
+       dclit(q1);
+
+if(q1->tag == TNAME)
+       {
+       if( equals(q2->sthead->namep, "stop") )
+               {
+               exlab(0);
+               putic(ICKEYWORD, FSTOP);
+               TEST fprintf(diagfile,"stop ");
+               if( (q1 = p->rightp) && (q1 = q1->leftp) )
+                       prexpr( simple(RVAL, q1->datap) );
+               goto done;
+               }
+       if( ioop(q2->sthead->namep) )
+               {
+               exioop(p,NO);
+               goto done;
+               }
+       }
+
+p = simple(RVAL,p);
+exlab(0);
+putic(ICKEYWORD,FCALL);
+TEST fprintf(diagfile, "call ");
+/* replace character constant arguments with holleriths */
+if( (q1=p->rightp) && tailor.hollincall)
+       for(q1 = q1->leftp ; q1 ; q1 = q1->nextp)
+               if( (q2 = q1->datap)->tag==TCONST
+                   && q2->vtype==TYCHAR)
+                       {
+                       q2->vtype = TYHOLLERITH;
+                       frexpr(q2->vtypep);
+                       q2->vtypep = 0;
+                       q2->leftp = mkholl(q3 = q2->leftp);
+                       cfree(q3);
+                       }
+prexpr( p );
+
+done:  frexpr(p);
+}
+
+
+
+
+ptr mkholl(p)
+register char *p;
+{
+register char *q, *t, *s;
+int n;
+
+n = strlen(p);
+q = convic(n);
+s = t = calloc(n + 2 + strlen(q) , 1);
+while(*q)
+       *t++ = *q++;
+*t++ = 'h';
+while(*t++ = *p++ )
+       ;
+return(s);
+}
+
+
+ptr ifthen()
+{
+ptr p;
+ptr addexec();
+
+p = addexec();
+thisexec->brnchend = 0;
+if(thisexec->nftnst == 0)
+       {
+       exlab(0);
+       putic(ICKEYWORD,FCONTINUE);
+       thisexec->nftnst = 1;
+       }
+if(thisexec->nftnst>1 || thisexec->labeled || thisexec->uniffable )
+       {
+       if(thisctl->breaklab == 0)
+               thisctl->breaklab = nextlab();
+       indifs[thisctl->indifn] = thisctl->breaklab;
+       }
+else   thisctl->breaklab = 0;
+return(p);
+}
+
+
+
+exasgn(l,o,r)
+ptr l;
+int o;
+ptr r;
+{
+exlab(0);
+if(l->vdcldone == 0)
+       dclit(l);
+frexpr( simple(LVAL , mknode(TASGNOP,o,l,r)) );
+}
+
+exretn(p)
+ptr p;
+{
+if(p)
+       {
+       if(procname && procname->vtype && procname->vtype!=TYCHAR &&
+         (procname->vtype!=TYLCOMPLEX || tailor.lngcxtype!=NULL) )
+               {
+               if(p->tag!=TNAME || p->sthead!=procname->sthead)
+                       exasgn( cpexpr(procname) , OPASGN, p);
+               }
+       else execerr("can only return values in a function", PNULL);
+       }
+else if(procname && procname->vtype)
+        warn("function return without data value");
+exlab(0);
+putic(ICKEYWORD, FRETURN);
+
+TEST {fprintf(diagfile, "exec: return( " );  prexpr(p);  fprintf(diagfile, ")\n" );  }
+}
+
+
+exnull()
+{
+if(thisexec->labelno && !(thisexec->labused) )
+       {
+       exlab(0);
+       putic(ICKEYWORD,FCONTINUE);
+       }
+}
+
+
+
+
+exbrk(opnext,levskip,btype)
+int opnext;
+ptr levskip;
+int btype;
+{
+
+if(opnext && (btype==STSWITCH || btype==STPROC))
+       execerr("illegal next", PNULL);
+else if(!opnext && btype==STPROC)
+       exretn(PNULL);
+else  brknxtlab(opnext,levskip,btype);
+TEST fprintf(diagfile, "exec: %s\n", (opnext ? "next" : "exit"));
+
+}
+
+
+
+exif(e)
+register ptr e;
+{
+int tag;
+
+if( (tag = e->tag)==TERROR || e->vtype!=TYLOG)
+       {
+       frexpr(e);
+       e = mkconst(TYLOG, ".true.");
+       if(tag != TERROR)
+               execerr("non-logical conditional expression in if", PNULL);
+       }
+TEST fprintf(diagfile, "exif called\n");
+e = simple(RVAL,e);
+exlab(0);
+putic(ICKEYWORD,FIF2);
+indifs[thisctl->indifn = nextindif()] = 0;
+putic(ICINDPTR, thisctl->indifn);
+putic(ICOP,OPLPAR);
+prexpr(e);
+putic(ICOP,OPRPAR);
+putic(ICMARK,0);
+putic(ICOP,OPLPAR);
+prexpr(e = simple(RVAL, mknode(TNOTOP,OPNOT,e,PNULL)));
+putic(ICOP,OPRPAR);
+putic(ICMARK,0);
+afterif = 1;
+frexpr(e);
+}
+
+
+exifgo(e,l)
+ptr e;
+int l;
+{
+exlab(0);
+exif1(e);
+exgo1(l);
+}
+
+
+exif1(e)
+register ptr e;
+{
+e = simple(RVAL,e);
+exlab(0);
+putic(ICKEYWORD,FIF1);
+putic(ICOP,OPLPAR);
+TEST fprintf(diagfile, "if1 ");
+prexpr( e );
+frexpr(e);
+putic(ICOP,OPRPAR);
+putic(ICBLANK, 1);
+}
+
+
+
+
+
+
+
+brkcase()
+{
+ptr bgnexec();
+
+if(ncases==0 /* && thisexec->prevexec->brnchend==0 */ )
+       {
+       exbrk(0, PNULL, 0);
+       addexec();
+       bgnexec();
+       }
+ncases = 1;
+}
+
+
+brknxtlab(opnext, levp, btype)
+int opnext;
+ptr levp;
+int btype;
+{
+register ptr p;
+int levskip;
+
+levskip = ( levp ? convci(levp->leftp) : 1);
+if(levskip <= 0)
+       {
+       execerr("illegal break count %d", levskip);
+       return;
+       }
+
+for(p = thisctl ; p!=0 ; p = p->prevctl)
+       if( (btype==0 || p->subtype==btype) &&
+           p->subtype!=STIF && p->subtype!=STPROC &&
+           (!opnext || p->subtype!=STSWITCH) )
+               if(--levskip == 0) break;
+
+if(p == 0)
+       {
+       execerr("invalid break/next", PNULL);
+       return;
+       }
+
+if(p->subtype==STREPEAT && opnext)
+       exgoind(p->indifn);
+else if(opnext)
+       exgoto(p->nextlab);
+else   {
+       if(p->breaklab == 0)
+               p->breaklab = nextlab();
+       exgoto(p->breaklab);
+       }
+}
+
+
+
+ptr doloop(p1,p2,p3)
+ptr p1;
+ptr p2;
+ptr p3;
+{
+register ptr p, q;
+register int i;
+int val[3];
+
+p = ALLOC(doblock);
+p->tag = TDOBLOCK;
+
+if(p1->tag!=TASGNOP || p1->subtype!=OPASGN || p1->leftp->tag!=TNAME)
+       {
+       p->dovar = gent(TYINT, PNULL);
+       p->dopar[0] = p1;
+       }
+else   {
+       p->dovar = p1->leftp;
+       p->dopar[0] = p1->rightp;
+       frexpblock(p1);
+       }
+if(p2 == 0)
+       {
+       p->dopar[1] = p->dopar[0];
+       p->dopar[0] = mkint(1);
+       }
+else   p->dopar[1] = p2;
+p->dopar[2] = p3;
+
+for(i = 0; i<3 ; ++i)
+       {
+       if(q = p->dopar[i])
+               {
+               if( (q->tag==TNAME || q->tag==TTEMP) &&
+                  (q->vsubs || q->voffset) )
+                       p->dopar[i] = simple(RVAL,mknode(TASGNOP,0,
+                               gent(TYINT,PNULL), q));
+               else
+                       p->dopar[i] = simple(LVAL, coerce(TYINT, q) );
+
+               if(isicon(p->dopar[i], &val[i]))
+                       {
+                       if(val[i] <= 0)
+                               execerr("do parameter out of range", PNULL);
+                       }
+               else    val[i] = -1;
+               }
+       }
+
+if(val[0]>0 && val[1]>0 && val[0]>val[1])
+       execerr("do parameters out of order", PNULL);
+return(p);
+}
diff --git a/usr/src/cmd/efl/field.c b/usr/src/cmd/efl/field.c

new file mode 100644 (file)

index 0000000..a4fbfde
--- /dev/null
+++ b/usr/src/cmd/efl/field.c
@@ -0,0 +1,127 @@
+#include "defs"
+
+
+
+ptr mkfield(q)
+register ptr q;
+{
+register ptr p;
+
+if(!instruct)
+       goto err;
+else if(q->upperb == 0)
+       dclerr("must have upper bound in field spcification", "");
+else
+       {
+       p = ALLOC(fieldspec);
+       p->tag = TFIELD;
+       if(q->lowerb)
+               {
+               p->flbound = q->lowerb;
+               p->frange = mknode(TAROP,OPPLUS,mknode(TAROP,OPMINUS,
+                               q->upperb, cpexpr(q->lowerb)),
+                               mkconst(TYINT,"1") );
+               }
+       else    {
+               p->flbound = mkconst(TYINT,"1");
+               p->frange = q->upperb;
+               }
+       p->frange = simple(RVAL,p->frange);
+       if(p->frange->tag != TCONST)
+               {
+               dclerr("field range must be constant", "");
+               cfree(p);
+               goto err;
+               }
+       cfree(q);
+       return(p);
+       }
+
+err:
+       cfree(q);
+       return( errnode() );
+}
+
+
+
+
+
+ptr extrfield(p)
+register ptr p;
+{
+register ptr t;
+
+t = p->vtypep;
+p->vtype = TYINT;
+p->vtypep = 0;
+
+if(t->frshift)
+       p = mknode(TAROP,OPSLASH, p, cpexpr(t->frshift));
+if(t->fanymore)
+       p = mkcall(builtin(TYINT, "mod"), arg2(p, cpexpr(t->frange)) );
+p = mknode(TAROP,OPPLUS, p, cpexpr(t->flbound));
+return(p);
+}
+
+
+
+
+ptr setfield(e)
+ptr e;
+{
+ptr lp, rp;
+register ptr f, p;
+int subt;
+
+lp = cpexpr(e->leftp);
+rp = e->rightp;
+subt = e->subtype;
+f = lp->vtypep;
+lp->vtype = TYINT;
+lp->vtypep = 0;
+
+if(subt==OPPLUS || subt==OPMINUS)
+       {
+       if(f->frshift)
+               rp = mknode(TAROP,OPSTAR,rp,cpexpr(f->frshift));
+       }
+else   {
+       if(subt != OPASGN)
+               {
+               rp = mknode(TAROP,subt, extrfield(cpexpr(e->leftp)), rp);
+               subt = OPASGN;
+               }
+       rp = coerce(TYINT,rp);
+       if(f->flbound)
+               rp = simple(RVAL, mknode(TAROP,OPMINUS,rp,cpexpr(f->flbound)) );
+       
+       if(f->frshift==0)
+               {
+               if(f->fanymore)
+                       {
+                       p = mknode(TAROP,OPSLASH,cpexpr(lp),cpexpr(f->frange));
+                       p->needpar = YES;
+                       p = mknode(TAROP,OPSTAR,cpexpr(f->frange),p);
+                       rp = mknode(TAROP,OPPLUS,p,rp);
+                       }
+               }
+       else if(f->fanymore==0)
+               {
+               rp = mknode(TAROP,OPSTAR,cpexpr(f->frshift),rp);
+               p = mkcall(builtin(TYINT,"mod"),
+                       arg2(cpexpr(lp),cpexpr(f->frshift)) );
+               rp = mknode(TAROP,OPPLUS, p,rp);
+               }
+       else    {
+               p = mknode(TAROP,OPSLASH,cpexpr(lp),cpexpr(f->frshift));
+               p = mkcall(builtin(TYINT,"mod"), 
+                       arg2(p, cpexpr(f->frange)) );
+               if( rp->tag!=TCONST || !equals(rp->leftp, "0") )
+                       p = mknode(TAROP,OPMINUS, p, rp);
+               rp = mknode(TAROP,OPSTAR, cpexpr(f->frshift), p);
+               rp = mknode(TAROP,OPMINUS, cpexpr(lp), rp);
+               }
+       }
+frexpr( simple(LVAL, mknode(TASGNOP,subt,lp,rp) ));
+return(extrfield(e->leftp));
+}
diff --git a/usr/src/cmd/efl/fixuplex b/usr/src/cmd/efl/fixuplex

new file mode 100755 (executable)

index 0000000..a000e2e
--- /dev/null
+++ b/usr/src/cmd/efl/fixuplex
@@ -0,0 +1,34 @@
+ed - lex.yy.c <<!
+/input/s/getc(yyin)/efgetc/
+/yylex/+1a
+if(pushlex)
+       if(pushlex==1)
+               {
+               pushlex = 2;
+               yylval.ival = 0;
+               return(EOS);
+               }
+       else    {
+               pushlex = 0;
+               if(rket == 2)
+                       rket = 1;
+               else    RETL(prevv,prevl);
+               }
+if(rket > 0)
+       {
+       if(rket==1)
+               {
+               rket = 2;
+               RET(RBRACK);
+               }
+       else    {
+               rket = 0;
+               RET(EOS);
+               }
+       }
+if(eofneed) return(0);
+if(forcerr) return(-1);
+.
+w
+q
+!
diff --git a/usr/src/cmd/efl/free.c b/usr/src/cmd/efl/free.c

new file mode 100644 (file)

index 0000000..eadf552
--- /dev/null
+++ b/usr/src/cmd/efl/free.c
@@ -0,0 +1,234 @@
+#include "defs"
+
+
+cleanst()
+{
+register ptr p, q;
+ptr pjunk;
+int i;
+register struct stentry *s;
+struct stentry **hp;
+
+TEST fprintf(diagfile, "\n");
+
+clcomm();
+
+for(hp = hashtab ; hp<hashend ; ++hp)
+    while( s = *hp )
+       {
+       if( q = s->varp )
+               {
+               if( q->blklevel > 0 )
+                       {
+                       TEST fprintf(diagfile, "remove %s from st\n", s->namep);
+                       switch(q->tag)
+                               {
+                               case TNAME:
+                                       frvar(q);
+                                       break;
+
+                               case TSTRUCT:
+                                       frtype(q);
+                                       break;
+
+                               case TDEFINE:
+                                       frdef(q);
+                                       break;
+
+                               case TLABEL:
+                                       cfree(q);
+                                       break;
+
+                               default:
+                                       sprintf(msg, "cleanst: illegal entry tag %d, ptr %o, name %s.",
+                                               q->tag, q, s->namep);
+                                       fatal(msg);
+                               }
+                       }
+               else if( q->tag == TNAME )
+                       {
+                       q->vdcldone = 0;
+                       q->vnamedone = 0;
+                       q->vextbase = 0;
+                       for(i = 0 ; i<NFTNTYPES ; ++i)
+                               q->vbase[i] = 0;
+                       }
+               }
+       if(s->blklevel > 0)
+               name(s->namep,-1);
+       else    break;
+       }
+
+for(p = gonelist ; p ; p = p->nextp)
+       frvar(p->datap);
+frchain(&gonelist);
+
+if(hidlist) fatal("cleanst: hidlist not empty");
+for(p = hidlist ; p ; p = p->nextp)
+       frvar(p->datap);
+frchain(&hidlist);
+
+for(p = tempvarlist ; p ; p = p->nextp)
+       frvar(p->datap);
+frchain(&tempvarlist);
+
+for(p = temptypelist ; p ; p = p->nextp)
+       if(p->datap->blklevel > 0)
+               frtype(p->datap);
+frchain(&temptypelist);
+
+q = &arrays;
+for(p = arrays ; p ; p = q->nextp)
+       if(p->datap == 0)
+               {
+               q->nextp = p->nextp;
+               p->nextp = 0;
+               pjunk = p;
+               frchain(&pjunk);
+               }
+       else    q = p;
+}
+
+
+
+frvar(p)
+register ptr p;
+{
+register ptr q, qn;
+
+if(p==0) return;
+
+switch(p->tag)
+       {
+       case TSTRUCT:
+               frtype(p);
+               return;
+
+       case TDEFINE:
+               frdef(p);
+               return;
+
+       case TNAME:
+       case TTEMP:
+               if(q = p->vdim)
+                   for(q = q->datap ; q ; q = qn)
+                       {
+                       if(q->lowerb) frexpr(q->lowerb);
+                       frexpr(q->upperb);
+                       qn = q->nextp;
+                       cfree(q);
+                       }
+               
+               if(p->vdim)
+                       p->vdim->datap = 0;
+               if(p->vtype == TYCHAR)
+                       frexpr(p->vtypep);
+               frexpblock(p);
+               return;
+
+       default:
+               badtag("frvar",p->tag);
+       }
+}
+
+
+frtype(p)
+register ptr p;
+{
+register ptr q;
+
+if(p==0 || p->tag!=TSTRUCT)
+       fatal("frtype: bad argument");
+for(q = p->strdesc ; q; q = q->nextp)
+       frvar(q->datap);
+frchain( &(p->strdesc) );
+cfree(p);
+}
+
+
+
+frdef(p)
+ptr p;
+{
+cfree(p->valp);
+cfree(p);
+}
+
+
+
+frexpr(p)
+register ptr p;
+{
+register ptr q;
+
+if(p == 0) return;
+
+switch(p->tag)
+       {
+       case TAROP:
+       case TRELOP:
+       case TLOGOP:
+       case TASGNOP:
+       case TREPOP:
+       case TCALL:
+               frexpr(p->rightp);
+
+
+       case TNOTOP:
+       case TNEGOP:
+               frexpr(p->leftp);
+               break;
+
+       case TCONST:
+               cfree(p->leftp);
+               if(p->vtype == TYCHAR)
+                       frexpr(p->vtypep);
+               if(p->rightp)
+                       cfree(p->rightp);
+               break;
+
+       case TLIST:
+               for(q = p->leftp ; q ; q = q->nextp)
+                       frexpr(q->datap);
+               frchain( &(p->leftp) );
+               break;
+
+       case TTEMP:
+       case TNAME:
+       case TFTNBLOCK:
+               if(p->vsubs)
+                       frexpr(p->vsubs);
+               if(p->voffset)
+                       frexpr(p->voffset);
+
+       case TERROR:
+/*debug*/ case TIOSTAT:
+               break;
+
+       default:
+               badtag("frexpr", p->tag);
+       }
+frexpblock(p);
+}
+
+
+
+
+clcomm()       /* clean up common lists */
+{
+ptr p, oldp, q;
+
+for(oldp = &commonlist ; p = oldp->nextp ;  )
+       {
+       q = p->datap;
+
+       if(q->blklevel > 0)
+               {
+               frchain( &(q->comchain) );
+               cfree(q);
+               oldp->nextp = p->nextp;
+               cfree(p);
+               }
+       else   oldp = p;
+       }
+}
diff --git a/usr/src/cmd/efl/gram.dcl b/usr/src/cmd/efl/gram.dcl

new file mode 100644 (file)

index 0000000..18aaa61
--- /dev/null
+++ b/usr/src/cmd/efl/gram.dcl
@@ -0,0 +1,252 @@
+dcls1:   dcl1
+       | dcls1 EOS
+       | dcls1 EOS dcl1
+               { $$ = hookup($1,$3); }
+       ;
+
+dcl1:    dcl
+       | varlist
+       ;
+
+dcl:     attrs vars
+               { attvars($1,$2); $$ = $2; }
+       | attrs LBRACK dcls1 RBRACK
+               { attvars($1,$3); $$ = $3; }
+       | INITIAL initlist
+               { $$ = 0; }
+       | IMPLICIT letton implist lettoff
+               { $$ = 0; }
+       | EQUIVALENCE equivsets
+               { $$ = 0; }
+       | EQUIVALENCE equivlist
+               { mkequiv($2); $$ = 0; }
+       ;
+
+dcls:    dcl
+       | dcls EOS
+       | dcls EOS dcl
+               { $$ = hookup($1,$3); }
+       ;
+
+initlist:      init
+       | initlist COMMA init
+       ;
+
+init:    lhs ASGNOP  {ininit = YES; }   expr
+               = { ininit = NO;  mkinit($1,$4);  frexpr($1); }
+       ;
+
+implist:  impgroup
+       | implist COMMA impgroup;
+       ;
+
+impgroup:  impspec
+               { setimpl(imptype, 'a', 'z'); }
+       | impspec LPAR impsets RPAR
+       ;
+
+impspec:  specs
+               { imptype = $1->attype; cfree($1); }
+       ;
+
+impsets:  impset
+       | impsets COMMA impset
+       ;
+
+impset:          LETTER
+               { setimpl(imptype, $1, $1); }
+       | LETTER ADDOP LETTER
+               { setimpl(imptype, $1, $3); }
+       ;
+
+equivsets:     equivset
+       | equivsets COMMA equivset
+       ;
+
+equivset:  LPAR equivlist RPAR
+               { mkequiv($2); }
+       ;
+
+equivlist:  lhs COMMA lhs
+               { $$ = mkchain($1, mkchain($3,CHNULL)); }
+       | equivlist COMMA lhs
+               { $$ = hookup($1, mkchain($3,CHNULL)); }
+       ;
+
+attrs:   attr
+       | attrs attr    { attatt($1,$2); }
+       ;
+
+attr:    spec dim      { $1->atdim = $2; }
+       | array dim     { $$ = ALLOC(atblock); $$->atdim = $2; }
+       ;
+
+dim:           { $$ = 0; }
+       | dimbound
+       ;
+
+dimbound:  LPAR { inbound = 1; }  bounds RPAR
+                       { inbound = 0;  $$ = arrays = mkchain($3,arrays); }
+       ;
+
+bounds:          bound
+       | bounds COMMA bound    { hookup($1,$3); }
+       ;
+
+bound:   ubound
+               {
+               $$ = ALLOC(dimblock);
+               $$->lowerb = 0;
+               $$->upperb = $1;
+               }
+       | expr COLON ubound
+               {
+               $$ = ALLOC(dimblock);
+               $$->lowerb = $1;
+               $$->upperb = $3;
+               }
+       ;
+
+ubound:          expr
+       | MULTOP  { $$ = 0; }
+       ;
+
+vars:          { $$ = 0; }
+       | varlist
+       ;
+
+varlist:  var
+       | varlist COMMA var     { hookup($1,$3); }
+       ;
+
+var:     varname dim
+               {
+               if($2!=0)
+                       if($1->vdim==0)
+                               $1->vdim = $2;
+                       else if(!eqdim($2,$1->vdim))
+                               dclerr("multiple dimension", $1->namep);
+               $$ = mkchain($1,CHNULL);
+               }
+       | varname dim ASGNOP  { ininit = YES; }   expr
+               {
+               ininit = NO;
+               if($3!=OPASGN)
+                       dclerr("illegal initialization operator", $1->sthead->namep);
+               if($2!=0)
+                       if($1->vdim==0)
+                               $1->vdim = $2;
+                       else if(!eqdim($2,$1->vdim))
+                               dclerr("multiple dimension", $1->sthead->namep);
+               if($5!=0 && $1->vinit!=0)
+                       dclerr("multiple initialization", $1->sthead->namep);
+               $1->vinit = $5;
+               $$ = mkchain($1,CHNULL);
+               }
+       ;
+
+varname:  NAME
+               { $$ = mkvar($1); }
+       ;
+
+
+specs:   specarray
+       | specs specarray       { attatt($1,$2); }
+       ;
+
+specarray:  spec
+       | array dimbound
+               { $$ = ALLOC(atblock); $$->atdim = $2; }
+       ;
+
+spec:    sclass 
+               {
+               $$ = ALLOC(atblock);
+               if($1 == CLEXT)
+                       $$->atext = 1;
+               $$->atclass = $1;
+               }
+       | comclass contnu
+               {
+               $$ = ALLOC(atblock);
+               $$->atclass = CLCOMMON;
+               $$->atcommon = $1;
+               }
+       | stype
+               { $$ = ALLOC(atblock); $$->attype = $1; }
+       | CHARACTER LPAR expr RPAR
+               { $$ = ALLOC(atblock); $$->attype = TYCHAR; $$->attypep = $3; }
+       | FIELD LPAR bound RPAR
+               { $$ = ALLOC(atblock); $$->attype = TYFIELD;
+                 $$->attypep = mkfield($3); }
+       | deftype
+               { $$ = ALLOC(atblock); $$->attype = TYSTRUCT;
+                 $$->attypep = $1; }
+       | prec
+               { $$ = ALLOC(atblock); $$->atprec = $1; }
+       ;
+
+sclass:          AUTOMATIC     { $$ = CLAUTO;
+                         fprintf(diagfile,"AUTOMATIC not yet implemented\n"); }
+       | STATIC        { $$ = CLSTAT; }
+       | INTERNAL      { $$ = CLSTAT; }
+       | VALUE         { $$ = CLVALUE;
+                         fprintf(diagfile, "VALUE not yet implemented\n");  }
+       | EXTERNAL      { $$ = CLEXT; }
+       ;
+
+comclass:  COMMON LPAR comneed comname RPAR
+                       { $$ = $4; }
+       | COMMON MULTOP comneed comname MULTOP
+                       { $$ = $4; }
+       ;
+
+comneed:       { comneed = 1; }
+       ;
+
+comname:               { $$ = mkcomm(""); }
+       | COMNAME
+       ;
+
+stype:   INTEGER       { $$ = TYINT; }
+       | REAL          { $$ = TYREAL; }
+       | COMPLEX       { $$ = TYCOMPLEX; }
+       | LOGICAL       { $$ = TYLOG; }
+       | DOUBLE PRECISION
+                       { $$ = TYLREAL; /* holdover from Fortran */ }
+       | DOUBLEPRECISION
+                       { $$ = TYLREAL; /* holdover from Fortran */ }
+       ;
+
+deftype:  STRUCTNAME
+               { $$ = $1->varp; }
+       | STRUCT structname contnu struct
+                 { $$ = mkstruct($2,$4); }
+       | STRUCT struct
+               { $$ = mkstruct(PNULL,$2); }
+       ;
+
+structname:  NAME
+               { if($1->varp && $1->varp->blklevel<blklevel)
+                       hide($1);
+                 $1->tag = TSTRUCT;
+               }
+       | STRUCTNAME
+               { if($1->varp)
+                       if($1->varp->blklevel<blklevel)
+                               hide($1);
+                       else dclerr("multiple declaration for type %s", $1->namep);
+               }
+       ;
+
+struct:          LBRACK  { ++instruct; }   dcls  { --instruct; }   RBRACK EOS
+                       { $$ = $3; prevv = -1; }
+       ;
+
+array:   ARRAY
+       | DIMENSION
+       ;
+
+prec:    LONG  { $$ = 1; }
+       | SHORT { $$ = 0; }
+       ;
diff --git a/usr/src/cmd/efl/gram.expr b/usr/src/cmd/efl/gram.expr

new file mode 100644 (file)

index 0000000..839f803
--- /dev/null
+++ b/usr/src/cmd/efl/gram.expr
@@ -0,0 +1,142 @@
+expr:    lhs
+               { if($1->tag == TCALL)
+                       $1 = funcinv($1);
+                 if($1->vtype==TYUNDEFINED && $1->vext==0)
+                       impldecl($1);
+                 else if($1->tag==TNAME && $1->vdcldone==0
+                         && $1->vext==0 && !inbound)
+                               dclit($1);
+                 if($1->vtype==TYFIELD)
+                       $$ = extrfield($1);
+               }
+       | CONST
+       | logcon
+               { $$ = mkconst(TYLOG, ($1 == TRUE ? ".true." : ".false.") ); }
+       | specs parexprs
+               { $$ = typexpr($1,$2); }
+       | sizeof
+       | lengthof
+       | parexprs
+               { if( !ininit && $1->tag== TLIST)
+                       $$ = compconst($1); 
+                 else $1->needpar = 1; }
+       | expr ADDOP expr
+               { $$ = mknode(TAROP,$2,$1,$3); }
+       | expr MULTOP expr
+               { $$ = mknode(TAROP,$2,$1,$3); }
+       | expr POWER expr
+               { $$ = mknode(TAROP,$2,$1,$3); }
+       | ADDOP expr  %prec MULTOP
+               { if($1==OPMINUS)
+                       $$ = mknode(TNEGOP,OPMINUS, $2, PNULL);
+                 else  $$ = $2;  }
+       | DOUBLEADDOP lhs  %prec MULTOP
+               { $$ =  mknode(TASGNOP,$1,$2,mkint(1)); }
+       | expr RELOP expr
+               { $$ = mknode(TRELOP,$2,$1,$3); }
+       | expr OR expr
+               { $$ = mknode(TLOGOP,$2,$1,$3); }
+       | expr AND expr
+               { $$ = mknode(TLOGOP,$2,$1,$3); }
+       | NOT expr
+               { $$ = mknode(TNOTOP,$1,$2,PNULL); }
+       | lhs ASGNOP expr
+               { if($1->tag == TCALL)
+                       {
+                       exprerr("may not assign to a function", CNULL);
+                       $$ = errnode();
+                       }
+                 else
+                       $$ = mknode(TASGNOP,$2,$1,$3);
+               }
+       | expr REPOP expr
+               { $$ = mknode(TREPOP,0,$1,$3); }
+       | iostat
+       | error
+               { $$ = errnode(); }
+       ;
+
+lhs:   lhs1
+               { if($1->tag==TNAME && $1->vdcldone==0 &&
+                       $1->vsubs==0 && $1->vext==0 && !inbound)
+                               dclit($1);
+               }
+       ;
+
+lhs1:    lhsname
+       | lhsname parexprs
+               {
+               if($2->tag!=TLIST)
+                       $2 = mknode(TLIST,0, mkchain($2,CHNULL), PNULL);
+               if($1->vdim)
+                       {
+                       if($1->vdcldone==0 && $1->vext==0)
+                               dclit($1);
+                       $$ = subscript($1,$2);
+                       }
+               else    $$ = mkcall($1,$2);
+               }
+       | lhs QUALOP NAME
+               { $$ = strucelt($1,$3); }
+       | lhs QUALOP NAME parexprs
+               { if($4->tag != TLIST)
+                       $4 = mknode(TLIST,0, mkchain($4,CHNULL), PNULL);
+                 $$ = subscript(strucelt($1,$3), $4);
+               }
+       | lhs ARROW STRUCTNAME
+               { $$ = mkarrow($1,$3); }
+       ;
+
+lhsname:  NAME
+               { if($1->varp == 0) mkvar($1);
+                 if(inbound)
+                         $1->varp->vadjdim = 1;
+                 $$ = cpexpr($1->varp); }
+       ;
+
+parexprs: LPAR RPAR
+               { $$ = mknode(TLIST, 0, PNULL, PNULL); }
+       | LPAR expr RPAR
+               { $$ = $2; }
+       | LPAR exprlist RPAR
+               { $$ = mknode(TLIST,0,$2,PNULL); }
+       ;
+
+exprlist: expr COMMA expr
+               { $$ = mkchain($1, mkchain($3, CHNULL) ); }
+       | exprlist COMMA expr
+               { hookup($1, mkchain($3,CHNULL) ); }
+       ;
+
+sizeof:          SIZEOF LPAR expr RPAR
+               { $$ = esizeof($3->vtype, $3->vtypep, $3->vdim);
+                 frexpr($3); }
+       | SIZEOF LPAR specs RPAR
+               { if($3->attype==TYREAL && $3->atprec)
+                       $3->attype = TYLREAL;
+                 $$ = esizeof($3->attype, $3->attypep, $3->atdim);
+                 cfree($3);
+               }
+       | SIZEOF LPAR CHARACTER RPAR
+               { $$ = mkint(tailor.ftnsize[FTNINT]/tailor.ftnchwd); }
+       ;
+
+lengthof:        LENGTHOF LPAR expr RPAR
+               { $$ = elenof($3->vtype, $3->vtypep, $3->vdim);
+                 frexpr($3); }
+       | LENGTHOF LPAR specs RPAR
+               { $$ = elenof($3->attype, $3->attypep, $3->atdim);
+                 cfree($3);
+               }
+       | LENGTHOF LPAR CHARACTER RPAR
+               { $$ = mkint(1); }
+       ;
+
+logcon:   logval
+       | QUALOP logval QUALOP
+               { $$ = $2; }
+       ;
+
+logval:   TRUE
+       | FALSE
+       ;
diff --git a/usr/src/cmd/efl/gram.head b/usr/src/cmd/efl/gram.head

new file mode 100644 (file)

index 0000000..7ab99c5
--- /dev/null
+++ b/usr/src/cmd/efl/gram.head
@@ -0,0 +1,198 @@
+%{
+#include "defs"
+ptr bgnexec(), addexec(), bgnproc(), mkvar(), mkcomm(), mkstruct(), mkarrow();
+ptr mkiost(), mkioitem(), mkiogroup(), mkformat();
+ptr funcinv(), extrfield(), typexpr(), strucelt(), mkfield();
+ptr esizeof(), elenof(), mkilab();
+ptr ifthen(), doloop();
+struct varblock *subscript();
+%}
+
+%start graal
+%union { int ival; ptr pval; char *cval; }
+
+%left COLON
+%left COMMA
+%right ASGNOP  /* = +- -= ...  */
+%right REPOP   /*  $  */
+%left OR       /*  |  ||  */
+%left AND      /*  &  &&  */
+%left NOT
+%nonassoc RELOP        /*  LT GT LE GE EQ NE  */
+%left ADDOP    /* +  -  */
+%left MULTOP   /* *  /  */
+%right POWER   /*   **  ^  */
+%left ARROW QUALOP     /*  ->  .  */
+
+%type <pval> dcl stat exec stats proc args arg varname comname structname
+%type <pval> dcl1 dcls1 dcl dcls specs equivlist attrs attr comclass
+%type <pval> dim dimbound bounds bound ubound vars varlist var
+%type <pval> specarray spec deftype struct
+%type <pval> expr lhs parexprs iostat sizeof lengthof lhs1 lhsname exprlist
+%type <pval> beginexec control until lablist parlablist compgotoindex
+%type <pval> do exprnull fortest iostat iounit iolist ioitem iobrace
+%type <pval> format
+%type <ival> stype sclass prec logcon logval brk blocktype letter iokwd label
+%token <pval> CONST OPTNAME COMNAME STRUCTNAME NAME ESCAPE
+%token <ival> RELOP ASGNOP OR AND NOT ADDOP MULTOP POWER DOUBLEADDOP
+%token <ival> LETTER TRUE FALSE
+
+%{
+extern int prevv;
+extern YYSTYPE prevl;
+ptr p;
+ptr procattrs;
+int i,n;
+static int imptype;
+static int ininit =NO;
+
+%}
+
+%%
+
+
+graal:
+               { graal = PARSEOF; }
+       | option endchunk
+               { graal = PARSOPT; }
+       | dcl endchunk
+               { graal = PARSDCL; doinits($1);  frchain( & $1); }
+       | procst EOS stats end
+               { endproc(); graal = PARSPROC; }
+       | define endchunk
+               { graal = PARSDEF; }
+       | exec endchunk
+               { graal = PARSERR; }
+       | error
+               { graal = PARSERR;
+                 errmess("Syntax error", "", "");
+               }
+       ;
+
+endchunk:  EOS { eofneed = 1; }
+
+stat:    dcl EOS
+               { if(!dclsect)
+                       warn("declaration amid executables");
+                   $$ = bgnexec();
+                  TEST fprintf(diagfile,"stat: dcl\n");
+                 doinits($1); frchain( & $1); }
+       | exec EOS 
+               { if(dclsect && $1->tag!=TSTFUNCT)
+                       dclsect = 0;
+                   TEST fprintf(diagfile, "stat: exec\n"); }
+       | define EOS
+               { $$ = bgnexec(); }
+       | error EOS
+               { yyerrok;
+                 errmess("Syntax error", "", "");
+                 $$ = bgnexec();
+               }
+       ;
+
+stats:
+               { $$ = bgnexec(); }
+       | stats   { thisexec->copylab = 1; }   stat
+               { $$ = addexec(); thisexec->copylab = 0; }
+       ;
+
+procst:          oproc
+               { procname = 0; thisargs = 0;
+                 if(procclass == 0) procclass = PRMAIN;
+                 goto proctype;
+               }
+       | oproc procname
+               { thisargs = 0; goto proctype; }
+       | oproc procname LPAR RPAR
+               { thisargs = 0; goto proctype; }
+       | oproc procname LPAR args RPAR
+               { thisargs = $4;
+       proctype:
+               if(procattrs)
+                       if(procname == 0)
+                               dclerr("attributes on unnamed procedure", "");
+                       else    {
+                               attvars(procattrs, mkchain(procname,CHNULL));
+                               procclass = PRFUNCT;
+                               }
+               fprintf(diagfile, "Procedure %s:\n", procnm() );
+               if(verbose)
+                       fprintf(diagfile, "    Pass 1\n");
+               }
+       ;
+
+procname:  NAME
+               { procname = mkvar($1);
+                 extname(procname);
+               }
+       ;
+
+oproc:   proc
+               { procattrs = 0; }
+       | attrs proc
+               { procattrs = $1;
+                 if(procclass == 0) procclass = PRFUNCT;
+               }
+       ;
+
+proc:    PROCEDURE
+               { $$ = bgnproc(); procclass = 0; }
+       | BLOCKDATA
+               { $$ = bgnproc(); procclass = PRBLOCK; }
+       ;
+
+args:    arg
+               { $$ = mkchain($1,CHNULL); }
+       | args COMMA arg
+               { hookup($1, mkchain($3,CHNULL) ); }
+       ;
+
+arg:     varname
+               { if($1->vclass == CLUNDEFINED)
+                       $1->vclass = CLARG;
+                 else dclerr("argument already used", $1->sthead->namep);
+               }
+       ;
+
+option:          optson optionnames   { optneed = 0; }
+       ;
+
+optson:          OPTION
+               { if(blklevel > 0)
+                       {
+                       execerr("Option statement inside procedure", "");
+                       execerr("procedure %s terminated prematurely", procnm());
+                       endproc();
+                       }
+                 optneed = 1;
+                 }
+       ;
+
+optionnames:
+       | optionnames optelt
+       | optionnames optelt COMMA
+       ;
+
+optelt:          OPTNAME
+               { setopt($1,CNULL); cfree($1); }
+       | OPTNAME ASGNOP OPTNAME
+               { setopt($1,$3); cfree($1); cfree($3); }
+       | OPTNAME ASGNOP CONST
+               { setopt($1,$3->leftp); cfree($1); cfree($3); }
+       ;
+
+
+define:          DEFINE   { defneed = 1; }
+       ;
+
+end:     END
+               { if(thisctl->subtype != STPROC)
+                       execerr("control stack not empty upon END", "");
+                 exnull();
+                 popctl();
+               }
+       ;
+
+contnu:
+               { igeol=1; /* continue past newlines  */ }
+       ;
diff --git a/usr/src/cmd/efl/icfile.c b/usr/src/cmd/efl/icfile.c

new file mode 100644 (file)

index 0000000..e09d61b
--- /dev/null
+++ b/usr/src/cmd/efl/icfile.c
@@ -0,0 +1,221 @@
+#include "defs"
+
+struct { char chars[ 10 ]; };
+
+
+crii() /* create names for intermediate files */
+{
+
+#ifdef unix
+sprintf(icfile->filename, "eflc.%d", getpid());
+sprintf(idfile->filename, "efld.%d", getpid());
+sprintf(iefile->filename, "efle.%d", getpid());
+#endif
+
+#ifdef gcos
+sprintf(icfile->filename, "code.efl");
+sprintf(idfile->filename, "data.efl");
+sprintf(iefile->filename, "equv.efl");
+#endif
+}
+
+
+
+rmiis()
+{
+rmii(icfile);
+rmii(idfile);
+rmii(iefile);
+}
+
+
+
+
+rmii(p)                /* discard the intermediate file */
+struct fileblock *p;
+{
+#ifdef unix
+if(p)
+       {
+       fclose(p->fileptr);
+       unlink(p->filename);
+       }
+#endif
+
+#ifdef gcos
+if(p)
+       fclose(p->fileptr, "d");
+#endif
+}
+
+
+opiis()
+{
+opii(icfile);
+opii(idfile);
+opii(iefile);
+}
+
+
+
+
+opii(p)        /* open the intermediate file for writing */
+struct fileblock *p;
+{
+
+#ifdef unix
+if( (p->fileptr = fopen(p->filename, "w")) == NULL)
+       fatal("cannot open intermediate file");
+#endif
+
+#ifdef gcos
+if( (p->fileptr = fopen(p->filename, "wi")) == NULL)
+       fatal("cannot open intermediate file");
+#endif
+
+}
+
+
+
+swii(p)
+struct fileblock *p;
+{
+iifilep = p;
+}
+
+
+
+putii(w,n)
+int *w, n;
+{
+if( fwrite(w,sizeof(int),n, iifilep->fileptr) != n)
+       fatal("write error");
+}
+
+
+
+getii(w, n)
+int *w, n;
+{
+if( fread(w,sizeof(int), n, iifilep->fileptr) != n)
+       fatal("read error");
+}
+
+
+
+
+cliis()
+{
+clii(icfile);
+clii(idfile);
+clii(iefile);
+}
+
+
+
+
+clii(p)        /* close the intermediate file */
+struct fileblock *p;
+{
+#ifdef unix
+fclose(p->fileptr);
+#endif
+
+#ifdef gcos
+fclose(p->fileptr, "rl");
+#endif
+}
+
+
+
+rewii(p)       /* close and rewind the intermediate file for reading */
+struct fileblock *p;
+{
+swii(p);
+putic(ICEOF,0);
+clii(p);
+
+#ifdef unix
+if( (p->fileptr = fopen(p->filename, "r")) == NULL)
+       fatal("cannot open intermediate file");
+#endif
+
+#ifdef gcos
+if( (p->fileptr = fopen(p->filename, "ri")) == NULL)
+       fatal("cannot open intermediate file");
+#endif
+}
+
+
+
+putic(c,p)
+int c;
+int p;
+{
+int w[2];
+prevbg = (c==ICINDENT);
+w[0] = c;
+w[1] = p;
+putii(w,2);
+}
+
+
+getic(p)
+int *p;
+{
+int w[2];
+
+getii(w,2);
+*p = w[1];
+return( w[0] );
+}
+
+
+
+putsii(l, p)
+int l;
+char *p;
+{
+int word;
+register int i, m, n;
+
+n = strlen(p);
+putic(l, n);
+m = (n/sizeof(int)) ;
+while(m-- > 0)
+       {
+       for(i=0 ; i<sizeof(int); ++i)
+               word.chars[i] = *p++;
+       putii(&word, 1);
+       }
+n -= (n/sizeof(int))*sizeof(int);
+if(n > 0)
+       {
+       for(i=0 ; i<n ; ++i)
+               word.chars[i] = *p++;
+       putii(&word,1);
+       }
+}
+
+
+
+
+ptr getsii(n)
+int n;
+{
+static int incomm[100];
+int m;
+register int *q, *qm;
+char *p;
+
+m = (n + sizeof(int)-1 ) / sizeof(int);
+q = incomm;
+qm = q + m;
+
+while(q < qm)
+       getii(q++, 1);
+p = incomm;
+p[n] = '\0';
+
+return(incomm);
+}
diff --git a/usr/src/cmd/efl/init.c b/usr/src/cmd/efl/init.c

new file mode 100644 (file)

index 0000000..50eb469
--- /dev/null
+++ b/usr/src/cmd/efl/init.c
@@ -0,0 +1,200 @@
+#include "defs"
+#include "tokdefs"
+
+kwinit()
+{
+struct key { char *keyn; int keyval; } *p;
+static struct key keys[] = {
+       "common", COMMON,
+       "internal", INTERNAL,
+       "external", EXTERNAL,
+       "automatic", AUTOMATIC,
+       "static", STATIC,
+       "value", VALUE,
+       "procedure", PROCEDURE,
+       "blockdata", BLOCKDATA,
+       "subroutine", PROCEDURE /* NB */,
+       "function", PROCEDURE           /* NB */,
+       "option", OPTION,
+       "include", INCLUDE,
+       "define", DEFINE,
+       "end", END,
+       "integer", INTEGER,
+       "real", REAL,
+       "complex", COMPLEX,
+       "logical", LOGICAL,
+       "character", CHARACTER,
+       "struct", STRUCT,
+       "field", FIELD,
+       "array", ARRAY,
+       "dimension", DIMENSION,
+       "long", LONG,
+       "short", SHORT,
+       "initial", INITIAL,
+       "equivalence", EQUIVALENCE,
+       "implicit", IMPLICIT,
+       "debug", DEBUG,
+       "if", IF,
+       "else", ELSE,
+       "while", WHILE,
+       "until", UNTIL,
+       "repeat", REPEAT,
+       "do", DO,
+       "for", FOR,
+       "switch", SWITCH,
+       "select", SWITCH,
+       "case", CASE,
+       "default", DEFAULT,
+       "go", GO,
+       "goto", GOTO,
+       "break", BREAK,
+       "exit", EXIT,
+       "next", NEXT,
+       "return", RETURN,
+       "continue", CONTINUE,
+       "call", CALL,
+       "double", DOUBLE,
+       "precision", PRECISION,
+       "doubleprecision", DOUBLEPRECISION,
+       "sizeof", SIZEOF,
+       "lengthof", LENGTHOF,
+       "read", READ,
+       "write", WRITE,
+       "readbin", READBIN,
+       "writebin", WRITEBIN,
+       "true", TRUE,
+       "false", FALSE,
+       0, 0 } ;
+
+for(p = keys ; p->keyn ; ++p)
+       mkkeywd(p->keyn, p->keyval);
+}
+\f
+
+
+geninit()
+{
+struct gen { char *genn; int restype; char *specn; int argtype; } *p;
+static struct gen gens[] = {
+       "abs", TYINT, "iabs", TYINT,
+       "abs", TYREAL, "abs", TYREAL,
+       "abs", TYLREAL, "dabs", TYLREAL,
+       "abs", TYCOMPLEX, "cabs", TYREAL,
+
+       "sin", TYREAL, "sin", TYREAL,
+       "sin", TYLREAL, "dsin", TYLREAL,
+       "sin", TYCOMPLEX, "csin", TYCOMPLEX,
+
+       "cos", TYREAL, "cos", TYREAL,
+       "cos", TYLREAL, "dcos", TYLREAL,
+       "cos", TYCOMPLEX, "ccos", TYCOMPLEX,
+
+       "atan", TYREAL, "atan", TYREAL,
+       "atan", TYLREAL, "datan", TYLREAL,
+
+       "atan2", TYREAL, "atan2", TYREAL,
+       "atan2", TYLREAL, "datan2", TYLREAL,
+
+       "sqrt", TYREAL, "sqrt", TYREAL,
+       "sqrt", TYLREAL, "dsqrt", TYLREAL,
+       "sqrt", TYCOMPLEX, "csqrt", TYCOMPLEX,
+
+       "log", TYREAL, "alog", TYREAL,
+       "log", TYLREAL, "dlog", TYLREAL,
+       "log", TYCOMPLEX, "clog", TYCOMPLEX,
+
+       "log10", TYREAL, "alog10", TYREAL,
+       "log10", TYLREAL, "dlog10", TYLREAL,
+
+       "exp", TYREAL, "exp", TYREAL,
+       "exp", TYLREAL, "dexp", TYLREAL,
+       "exp", TYCOMPLEX, "cexp", TYCOMPLEX,
+
+       "int", TYREAL, "int", TYINT,
+       "int", TYLREAL, "idint", TYINT,
+
+       "mod", TYINT, "mod", TYINT,
+       "mod", TYREAL, "amod", TYREAL,
+       "mod", TYLREAL, "dmod", TYLREAL,
+
+       "min", TYINT, "min0", TYINT,
+       "min", TYREAL, "amin1", TYREAL,
+       "min", TYLREAL, "dmin1", TYLREAL,
+
+       "max", TYINT, "max0", TYINT,
+       "max", TYREAL, "amax1", TYREAL,
+       "max", TYLREAL, "dmax1", TYLREAL,
+
+       "sign", TYREAL, "sign", TYREAL,
+       "sign", TYINT, "isign", TYINT,
+       "sign", TYLREAL, "dsign", TYLREAL,
+       0, 0, 0, 0 } ;
+
+for(p = gens ; p->genn ; ++p)
+       mkgeneric(p->genn, p->restype, p->specn, p->argtype);
+}
+\f
+knowninit()
+{
+struct known { char *knownn; int knowntype; } *p;
+static struct known knowns[ ] = {
+       "abs", TYREAL,
+       "iabs", TYINT,
+       "dabs", TYLREAL,
+       "aint", TYREAL,
+       "int", TYINT,
+       "idint", TYINT,
+       "amod", TYREAL,
+       "mod", TYINT,
+       "amax0", TYREAL,
+       "amax1", TYREAL,
+       "max0", TYINT,
+       "max1", TYINT,
+       "dmax1", TYLREAL,
+       "amin0", TYREAL,
+       "amin1", TYREAL,
+       "min0", TYINT,
+       "min1", TYINT,
+       "dmin1", TYLREAL,
+       "float", TYREAL,
+       "ifix", TYINT,
+       "sign", TYREAL,
+       "isign", TYINT,
+       "dsign", TYLREAL,
+       "dim", TYREAL,
+       "idim", TYINT,
+       "sngl", TYREAL,
+       "real", TYREAL,
+       "aimag", TYREAL,
+       "dble", TYLREAL,
+       "cmplx", TYCOMPLEX,
+       "conjg", TYCOMPLEX,
+       "exp", TYREAL,
+       "dexp", TYLREAL,
+       "cexp", TYCOMPLEX,
+       "alog", TYREAL,
+       "dlog", TYLREAL,
+       "clog", TYCOMPLEX,
+       "alog10", TYREAL,
+       "dlog10", TYLREAL,
+       "sin", TYREAL,
+       "dsin", TYLREAL,
+       "csin", TYCOMPLEX,
+       "cos", TYREAL,
+       "dcos", TYLREAL,
+       "ccos", TYCOMPLEX,
+       "tanh", TYREAL,
+       "sqrt", TYREAL,
+       "dsqrt", TYLREAL,
+       "csqrt", TYCOMPLEX,
+       "atan", TYREAL,
+       "datan", TYLREAL,
+       "atan2", TYREAL,
+       "datan2", TYLREAL,
+       "dmod", TYLREAL,
+       "cabs", TYREAL,
+       0, 0 };
+
+for(p = knowns ; p->knownn ; ++p)
+       mkknown(p->knownn, p->knowntype);
+}
diff --git a/usr/src/cmd/efl/io.c b/usr/src/cmd/efl/io.c

new file mode 100644 (file)

index 0000000..afd30dd
--- /dev/null
+++ b/usr/src/cmd/efl/io.c
@@ -0,0 +1,708 @@
+#include <ctype.h>
+
+#include "defs"
+
+static int lastfmtchar;
+static int writeop;
+static int needcomma;
+
+
+ptr mkiost(kwd,unit,list)
+int kwd;
+ptr unit;
+ptr list;
+{
+register ptr p;
+
+if(unit!=NULL && unit->vtype!=TYINT)
+       {
+       execerr("I/O unit must be an integer", "");
+       return(NULL);
+       }
+p = allexpblock();
+p->tag = TIOSTAT;
+p->vtype = TYINT;
+p->iokwd = kwd;
+p->iounit = unit;
+p->iolist = list;
+
+return(p);
+}
+
+
+
+
+struct iogroup *mkiogroup(list, format, dop)
+ptr list;
+char *format;
+ptr dop;
+{
+register struct iogroup *p;
+
+p = ALLOC(iogroup);
+p->tag = TIOGROUP;
+p->doptr = dop;
+p->iofmt = format;
+p->ioitems = list;
+return(p);
+}
+\f
+ptr exio(iostp, errhandle)
+struct iostblock *iostp;
+int errhandle;
+{
+ptr unit, list;
+int fmtlabel, errlabel, endlabel, jumplabel;
+ptr errval;
+int fmtio;
+
+if(iostp == NULL)
+       return( errnode() );
+unit = iostp->iounit;
+list = iostp->iolist;
+
+/* kwd=        0  binary input         2  formatted input
+       1  binary output        3  formatted output
+*/
+
+writeop = iostp->iokwd & 01;
+if( fmtio = (iostp->iokwd & 02) )
+       fmtlabel = nextlab() ;
+frexpblock(iostp);
+
+errval = 0;
+endlabel = 0;
+if(errhandle)
+       {
+       switch(tailor.errmode)
+               {
+               default:
+                       execerr("no error handling ", "");
+                       return( errnode() );
+
+               case IOERRIBM:  /* ibm: err=, end= */
+                       jumplabel = nextlab();
+                       break;
+
+               case IOERRFORT77:       /* New Fortran Standard: iostat= */
+                       break;
+
+               }
+       errval = gent(TYINT, PNULL);
+       }
+if(unit)
+       unit = simple(RVAL, unit);
+else   unit = mkint(writeop ? tailor.ftnout : tailor.ftnin);
+
+if(unit->tag!=TCONST && (unit->tag!=TNAME || unit->vsubs!=0))
+       unit = simple(LVAL, mknode(TASGNOP,OPASGN,gent(TYINT,PNULL),unit));
+
+simlist(list);
+
+exlab(0);
+putic(ICKEYWORD, (writeop ? FWRITE : FREAD) );
+putic(ICOP, OPLPAR);
+prexpr(unit);
+frexpr(unit);
+
+if( fmtio )
+       {
+       putic(ICOP, OPCOMMA);
+       putic(ICLABEL, fmtlabel);
+       }
+
+if(errhandle) switch(tailor.errmode)
+       {
+       case IOERRIBM:
+               putic(ICOP,OPCOMMA);
+               putsii(ICCONST, "err =");
+               putic(ICLABEL, errlabel = nextlab() );
+               if(!writeop)
+                       {
+                       putic(ICOP,OPCOMMA);
+                       putsii(ICCONST, "end =");
+                       putic(ICLABEL, endlabel = nextlab() );
+                       }
+               break;
+
+       case IOERRFORT77:
+               putic(ICOP,OPCOMMA);
+               putsii(ICCONST, "iostat =");
+               putname(errval);
+               break;
+       }
+
+putic(ICOP,OPRPAR);
+putic(ICBLANK, 1);
+
+needcomma = NO;
+doiolist(list);
+if(fmtio)
+       {
+       exlab(fmtlabel);
+       putic(ICKEYWORD, FFORMAT);
+       putic(ICOP, OPLPAR);
+       lastfmtchar = '(';
+       doformat(1, list);
+       putic(ICOP, OPRPAR);
+       }
+friolist(list);
+
+if(errhandle && tailor.errmode==IOERRIBM)
+       {
+       exasgn(cpexpr(errval), OPASGN, mkint(0) );
+       exgoto(jumplabel);
+       exlab(errlabel);
+       exasgn(cpexpr(errval), OPASGN, mkint(1) );
+       if(endlabel)
+               {
+               exgoto(jumplabel);
+               exlab(endlabel);
+               exasgn(cpexpr(errval), OPASGN,
+                       mknode(TNEGOP,OPMINUS,mkint(1),PNULL) );
+               }
+       exlab(jumplabel);
+       }
+
+return( errval );
+}
+\f
+doiolist(list)
+ptr list;
+{
+register ptr p, q;
+register struct doblock *dop;
+for(p = list ; p ; p = p->nextp)
+       {
+       switch( (q = p->datap) ->tag)
+               {
+               case TIOGROUP:
+                       if(dop = q->doptr)
+                               {
+                               if(needcomma)
+                                       putic(ICOP, OPCOMMA);
+                               putic(ICOP, OPLPAR);
+                               needcomma = NO;
+                               }
+                       doiolist(q->ioitems);
+                       if(dop)
+                               {
+                               putic(ICOP,OPCOMMA);
+                               prexpr(dop->dovar);
+                               putic(ICOP, OPEQUALS);
+                               prexpr(dop->dopar[0]);
+                               putic(ICOP, OPCOMMA);
+                               prexpr(dop->dopar[1]);
+                               if(dop->dopar[2])
+                                       {
+                                       putic(ICOP, OPCOMMA);
+                                       prexpr(dop->dopar[2]);
+                                       }
+                               putic(ICOP, OPRPAR);
+                               needcomma = YES;
+                               }
+                       break;
+
+               case TIOITEM:
+                       if(q->ioexpr)
+                               {
+                               if(needcomma)
+                                       putic(ICOP, OPCOMMA);
+                               prexpr(q->ioexpr);
+                               needcomma = YES;
+                               }
+                       break;
+
+               default:
+                       badtag("doiolist", q->tag);
+               }
+       }
+}
+\f
+doformat(nrep, list)
+int nrep;
+ptr list;
+{
+register ptr p, q;
+int k;
+ptr arrsize();
+
+if(nrep > 1)
+       {
+       fmtnum(nrep);
+       fmtop(OPLPAR);
+       }
+
+for(p = list ; p ; p = p->nextp)
+       switch( (q = p->datap) ->tag)
+               {
+               case TIOGROUP:
+                       if(q->iofmt)
+                               prfmt(q->nrep, q->iofmt);
+                       else    {
+                               doformat(q->nrep>0 ? q->nrep :
+                                       (q->doptr ? repfac(q->doptr) : 1),
+                                       q->ioitems);
+                               }
+                       break;
+
+               case TIOITEM:
+                       if(q->iofmt == NULL)
+                               break;
+
+                       if(q->nrep==0 && q->ioexpr && q->ioexpr->vdim)
+                               {
+                               if( ! isicon(arrsize(q->ioexpr), &k) )
+                                       execerr("io of adjustable array", "");
+                               else
+                                       prfmt(k, q->iofmt);
+                               }
+                       else
+                               prfmt(q->nrep, q->iofmt);
+               }
+if(nrep > 1)
+       fmtop(OPRPAR);
+}
+\f
+fmtop(op)
+register int op;
+{
+register c;
+
+c = (op==OPLPAR ? '(' : (op==OPRPAR ? ')' : 'x') );
+fmtcom(c);
+putic(ICOP, op);
+lastfmtchar = c;
+}
+
+
+
+
+fmtnum(k)
+int k;
+{
+fmtcom('1');
+prexpr( mkint(k) );
+lastfmtchar = ',';     /* prevent further comma after factor*/
+}
+
+
+
+
+
+
+
+
+/* separate formats with comma unless already a slash*/
+fmtcom(c)
+int c;
+{
+if( c!='/' && c!=')' && lastfmtchar!='/' && lastfmtchar!='(' && lastfmtchar!=',' )
+       {
+       putic(ICOP, OPCOMMA);
+       lastfmtchar = ',';
+       }
+}
+\f
+prfmt(nrep, str)
+int nrep;
+char *str;
+{
+char fmt[20];
+register int k, k0, k1, k2;
+register char *t;
+
+fmtcom(nrep>1 ? '1' : str[0]);
+
+if(nrep > 1)
+       {
+       fmtnum(nrep);
+       fmtop(OPLPAR);
+       }
+
+switch(str[0])
+       {
+       case 'd':
+       case 'e':
+       case 'g':
+               if(writeop)
+                       {
+                       putsii(ICCONST, "1p");
+                       break;
+                       }
+       
+       case 'f':
+               putsii(ICCONST, "0p");
+               break;
+               
+       case 'c':
+               k = convci(str+1);
+               k0 = tailor.ftnchwd;
+               k1 = k / k0;
+               k2 = k % k0;
+               if(k1>0 && k2>0)
+                       sprintf(fmt, "(%da%d,a%d)",k1,k0,k2);
+               else if(k1>1)
+                       sprintf(fmt, "(%da%d)", k1, k0);
+               else    sprintf(fmt, "a%d", k);
+               putsii(ICCONST, fmt);
+               lastfmtchar = 'f';      /* last char isnt operator */
+               goto close;
+
+       default:
+               break;
+       }
+putsii(ICCONST,str);
+/* if the format is an nH, act as if it ended with a non-operator character */
+if( isdigit(str[0]) )
+       {
+       for(t = str+1 ; isdigit(*t) ; ++t);
+               ;
+       if(*t=='h' || *t=='H')
+               {
+               lastfmtchar = 'f';
+               goto close;
+               }
+       }
+lastfmtchar = str[ strlen(str)-1 ];
+
+close:
+       if(nrep > 1)
+               fmtop(OPRPAR);
+}
+\f
+friolist(list)
+ptr list;
+{
+register ptr p, q;
+register struct doblock *dop;
+
+for(p = list; p; p = p->nextp)
+       {
+       switch ( (q = p->datap) ->tag)
+               {
+               case TIOGROUP:
+                       if(dop = q->doptr)
+                               {
+                               frexpr(dop->dovar);
+                               frexpr(dop->dopar[0]);
+                               frexpr(dop->dopar[1]);
+                               if(dop->dopar[2])
+                                       frexpr(dop->dopar[2]);
+                               cfree(dop);
+                               }
+                       friolist(q->ioitems);
+                       break;
+
+               case TIOITEM:
+                       if(q->ioexpr)
+                               frexpr(q->ioexpr);
+                       break;
+
+               default:
+                       badtag("friolist", q->tag);
+               }
+       if(q->iofmt)
+               cfree(q->iofmt);
+       cfree(q);
+       }
+frchain( &list );
+}
+\f
+simlist(p)
+register ptr p;
+{
+register ptr q, ep;
+struct iogroup *enloop();
+
+for( ; p ; p = p->nextp)
+       switch( (q = p->datap) ->tag )
+               {
+               case TIOGROUP:
+                       simlist(q->ioitems);
+                       break;
+
+               case TIOITEM:
+                       if(ep = q->ioexpr)
+                               {
+                               /* if element is a subaggregate, need
+                                  an implied do loop */
+                               if( (ep->voffset || ep->vsubs) &&
+                                   (ep->vdim || ep->vtypep) )
+                                       p->datap = enloop(q);
+                               else
+                                       q->ioexpr = simple(LVAL,ep);
+                               }
+                       break;
+
+               default:
+                       badtag("ioblock", q->tag);
+               }
+}
+
+
+
+
+/* replace an aggregate by an implied do loop of elements */
+
+struct iogroup *enloop(p)
+struct ioitem *p;
+{
+register struct doblock *dop;
+struct iogroup *gp;
+ptr np, q, v, arrsize(), mkioitem();
+int nrep, k, nwd;
+
+q = p->ioexpr;
+np = arrsize(q);
+if( ! isicon(np, &nrep) )
+       nrep = 0;
+
+if(q->vtype == TYCHAR)
+       {
+       nwd = ceil(conval(q->vtypep), tailor.ftnchwd);
+       if(nwd != 1)
+               np = simple(LVAL, mknode(TAROP,OPSTAR,np,mkint(nwd)));
+       }
+else
+       nwd = 0;
+
+if( isicon(np, &k) && k==1)
+       return(p);
+
+dop = ALLOC(doblock);
+dop->tag = TDOBLOCK;
+
+dop->dovar = v = gent(TYINT, PNULL);
+dop->dopar[0] = mkint(1);
+dop->dopar[1] = simple(SUBVAL, np);
+dop->dopar[2] = NULL;
+
+q = simple(LVAL, q);
+if(q->vsubs == NULL)
+       q->vsubs = mknode(TLIST,0, mkchain(cpexpr(v),CHNULL), PNULL);
+else
+       q->vsubs->leftp->datap = simple(SUBVAL, mknode(TAROP,OPPLUS, cpexpr(v),
+                    mknode(TAROP,OPMINUS,q->vsubs->leftp->datap,mkint(1))));
+q->vdim = NULL;
+gp = mkiogroup( mkchain(mkioitem(q,CNULL), CHNULL), p->iofmt, dop);
+gp->nrep = nrep;
+cfree(p);
+return(gp);
+}
+\f
+ptr mkformat(letter, n1, n2)
+char letter;
+register ptr n1, n2;
+{
+char f[20], *fp, *s;
+int k;
+
+if(letter == 's')
+       {
+       if(n1)
+               {
+               k = conval(n1);
+               frexpr(n1);
+               }
+       else    k = 1;
+
+       for(fp = f; k-->0 ; )
+               *fp++ = '/';
+       *fp = '\0';
+       return( copys(f) );
+       }
+
+f[0] = letter;
+fp = f+1;
+
+if(n1) {
+       n1 = simple(RVAL,n1);
+       if(n1->tag==TCONST && n1->vtype==TYINT)
+               {
+               for(s = n1->leftp ; *s; )
+                       *fp++ = *s++;
+               }
+       else    execerr("bad format component %s", n1->leftp);
+       frexpr(n1);
+       }
+
+if(n2) {
+       if(n2->tag==TCONST && n2->vtype==TYINT)
+               {
+               *fp++ = '.';
+               for(s = n2->leftp ; *s; )
+                       *fp++ = *s++;
+               }
+       else    execerr("bad format component %s", n2->leftp);
+       frexpr(n2);
+       }
+
+if( letter == 'x' )
+       {
+       if(n1 == 0)
+               *fp++ = '1';
+       fp[0] = 'x';
+       fp[1] = '\0';
+       return( copys(f+1) );
+       }
+else   {
+       *fp = '\0';
+       return( copys(f) );
+       }
+}
+\f
+ptr mkioitem(e,f)
+register ptr e;
+char *f;
+{
+register ptr p;
+char fmt[10];
+ptr gentemp();
+
+p = ALLOC(ioitem);
+p->tag = TIOITEM;
+if(e!=NULL && e->tag==TCONST)
+       if(e->vtype==TYCHAR && (f==0 || (f[0]=='c' && f[1]=='\0') ))
+               {
+               p->ioexpr = 0;
+               sprintf(msg, "%dh%s", strlen(e->leftp), e->leftp);
+               p->iofmt = copys(msg);
+               frexpr(e);
+               return(p);
+               }
+       else    e = mknode(TASGNOP,OPASGN,gentemp(e),e);
+
+if(e && e->vtype==TYCHAR && f && f[0]=='c' && f[1]=='\0')
+       f = NULL;
+if(f == NULL)
+       {
+       switch(e->vtype)
+               {
+               case TYINT:
+               case TYREAL:
+               case TYLREAL:
+               case TYCOMPLEX:
+               case TYLOG:
+                       f = copys( tailor.dfltfmt[e->vtype] );
+                       break;
+
+               case TYCHAR:
+                       if(e->vtypep->tag != TCONST)
+                               {
+                               execerr("no adjustable character formats", "");
+                               f = 0;
+                               }
+                       else    {
+                               sprintf(fmt, "c%s", e->vtypep->leftp);
+                               f = copys(fmt);
+                               }
+                       break;
+
+               default:
+                       execerr("cannot do I/O on structures", "");
+                       f = 0;
+                       break;
+               }
+       }
+
+p->ioexpr = e;
+p->iofmt = f;
+return(p);
+}
+
+
+
+ptr arrsize(p)
+ptr p;
+{
+register ptr b;
+ptr f, q;
+
+q = mkint(1);
+
+if(b = p->vdim)
+    for(b = b->datap ; b ; b = b->nextp)
+       {
+       if(b->upperb == 0) continue;
+       f = cpexpr(b->upperb);
+       if(b->lowerb)
+               f = mknode(TAROP,OPPLUS,f,
+                       mknode(TAROP,OPMINUS,mkint(1),cpexpr(b->lowerb)));
+       q = simple(RVAL, mknode(TAROP,OPSTAR,q,f));
+       }
+return(q);
+}
+
+
+
+
+repfac(dop)
+register struct doblock *dop;
+{
+int m1, m2, m3;
+
+m3 = 1;
+if( isicon(dop->dopar[0],&m1) &&  isicon(dop->dopar[1],&m2) &&
+  (dop->dopar[2]==NULL || isicon(dop->dopar[2],&m3)) )
+       {
+       if(m3 > 0)
+               return(1 + (m2-m1)/m3);
+       }
+else   execerr("nonconstant implied do", "");
+return(1);
+}
+
+
+
+ioop(s)
+char *s;
+{
+if( equals(s, "backspace") )
+       return(FBACKSPACE);
+if( equals(s, "rewind") )
+       return(FREWIND);
+if( equals(s, "endfile") )
+       return(FENDFILE);
+return(0);
+}
+
+
+
+
+ptr exioop(p, errcheck)
+register struct exprblock *p;
+int errcheck;
+{
+register ptr q, t;
+
+if( (q = p->rightp)==NULL || (q = q->leftp)==NULL  )
+       {
+       execerr("bad I/O operation", "");
+       return(NULL);
+       }
+q = simple(LVAL, cpexpr(q->datap) );
+
+exlab(0);
+putic(ICKEYWORD, ioop(p->leftp->sthead->namep));
+
+if(errcheck)
+       {
+       if(tailor.errmode != IOERRFORT77)
+               {
+               execerr("cannot test value of IOOP without ftn77", "");
+               return( errnode() );
+               }
+       putic(ICOP, OPLPAR);
+       prexpr(q);
+       putic(ICOP, OPCOMMA);
+       putsii(ICCONST, "iostat =");
+       prexpr(cpexpr( t = gent(TYINT,PNULL)));
+       putic(ICOP, OPRPAR);
+       return( t );
+       }
+else   {
+       putic(ICBLANK, 1);
+       prexpr(q);
+       }
+}
diff --git a/usr/src/cmd/efl/lex.l b/usr/src/cmd/efl/lex.l

new file mode 100644 (file)

index 0000000..4d8e59c
--- /dev/null
+++ b/usr/src/cmd/efl/lex.l
@@ -0,0 +1,378 @@
+%Start DOTSON
+%{
+#include <ctype.h>
+#include "defs"
+#include "tokdefs"
+
+typedef union { int ival; ptr pval; } YYSTYPE;
+extern YYSTYPE yylval;
+YYSTYPE prevl;
+int prevv;
+char *copys();
+static ptr p;
+static ptr q;
+static FILE *fd;
+static int quoted, k;
+static int rket        = 0;
+FILE *opincl();
+ptr mkdef(), mkcomm(), mkname(), mkimcon();
+
+#define RET(x) { RETI(x,x);  }
+
+#define RETL(yv,yl) {yylval=prevl=yl;igeol=comneed=0;return(prevv=yv); }
+#define RETP(yv,yl) {yylval.pval=prevl.pval=yl;igeol=comneed=0;return(prevv=yv); }
+#define RETI(yv,yl) {yylval.ival=prevl.ival=yl;igeol=comneed=0;return(prevv=yv); }
+#define REL(n)  {  RETI(RELOP, OPREL+n);}
+#define AS(n)  {  RETI(ASGNOP, OPASGN+n); }
+#define RETC(x) { RETP(CONST, mkconst(x,yytext) );  }
+#define RETZ(x) { yytext[yyleng-1] = '\0'; RETP(CONST, mkimcon(x,yytext) ); }
+
+%}
+
+D      [0-9]
+d      [dD][+-]?[0-9]+
+e      [eE][+-]?[0-9]+
+i      [iI]
+
+%%
+
+[a-zA-Z][a-zA-Z0-9_]*  {
+                  lower(yytext);
+                  if(lettneed && yyleng==1)
+                       { RETI(LETTER, yytext[0]); }
+                  else if(defneed)
+                       {
+                       register char *q1, *q2;
+                       for(q2=q1=yytext+yyleng+1 ; (*q1 = efgetc)!='\n' ; ++q1)
+                               ;
+                       *q1 = '\0';
+                       p = mkdef(yytext, q2);
+                       defneed = 0;
+                       ++yylineno;
+                       unput('\n');
+                       }
+                  else if(optneed)
+                       { RETP(OPTNAME, copys(yytext)); }
+                  else if(comneed && ( (q=name(yytext,1))==NULL || q->tag!=TDEFINE) )
+                       { RETP(COMNAME, mkcomm(yytext) ); }
+                  else if(q = name(yytext,1)) switch(q->tag)
+                       {
+                       case TDEFINE:
+                               filelines[filedepth] = yylineno;
+                               filemacs[filedepth] = efmacp;
+                               pushchars[filedepth] = (yysptr>yysbuf?
+                                               *--yysptr : -1);
+                               if(++filedepth >= MAXINCLUDEDEPTH)
+                                       fatal("macro or include too deep");
+                               filelines[filedepth] = yylineno = 1;
+                               efmacp = q->varp->valp;
+                               filenames[filedepth] = NULL;
+                               break;  /*now process new input */
+
+                       case TSTRUCT:
+                               RETP(STRUCTNAME, q);
+
+                       case TNAME:
+                               RETP(NAME, q);
+
+                       case TKEYWORD:
+                               if(q->subtype == END)
+                                       {
+                                       register int c;
+                                       eofneed = YES;
+                                       while((c=input())!=';'&&c!='\n'&&c!=EOF)
+                                               ;
+                                       NLSTATE;
+                                       }
+                               RET(q->subtype);
+
+                       default:
+                               fatal1("lex: impossible type code %d", q->tag);
+                       }
+                  else  RETP(NAME, mkname(yytext) );
+               }
+
+","    RET(COMMA);
+";"    RET(EOS);
+
+"("    RET(LPAR);
+")"    RET(RPAR);
+
+
+"["    |
+"{"    RET(LBRACK);
+
+"]"    |
+"}"    { if(iobrlevel>0) RET(RBRACK); rket = 1;  RET(EOS); }
+
+","    RET(COMMA);
+":"    RET(COLON);
+
+"$"    RET(REPOP);
+
+<DOTSON>"."[oO][rR]"." |
+"|"    RETI(OR,OPOR);
+<DOTSON>"."[cC][oO][rR]"."     |
+"||"   RETI(OR,OP2OR);
+<DOTSON>"."[aA][nN][dD]"."     |
+"&"    RETI(AND,OPAND);
+<DOTSON>"."[cC][aA][nN][dD]"." |
+"&&"   RETI(AND,OP2AND);
+<DOTSON>"."[nN][oO][tT]"."     |
+"~"    RETI(NOT,OPNOT);
+"!"    RETI(NOT,OPNOT);
+
+<DOTSON>"."[lL][tT]"." |
+"<"    REL(OPLT);
+<DOTSON>"."[lL][eE]"." |
+"<="   REL(OPLE);
+<DOTSON>"."[gG][tT]"." |
+">"    REL(OPGT);
+<DOTSON>"."[gG][eE]"." |
+">="   REL(OPGE);
+<DOTSON>"."[eE][qQ]"." |
+"=="   REL(OPEQ);
+<DOTSON>"."[nN][eE]"." |
+"~="   |
+"!="   REL(OPNE);
+
+"->"   RET(ARROW);
+"."    RET(QUALOP);
+
+"+"    RETI(ADDOP, OPPLUS);
+"-"    RETI(ADDOP, OPMINUS);
+"*"    RETI(MULTOP, OPSTAR);
+"/"    RETI(MULTOP, OPSLASH);
+
+"**"   |
+"^"    RETI(POWER, OPPOWER);
+
+"++"   RETI(DOUBLEADDOP, OPPLUS);
+"--"   RETI(DOUBLEADDOP, OPMINUS);
+
+"="    AS(OPASGN);
+"+="   AS(OPPLUS);
+"-="   AS(OPMINUS);
+"*="   AS(OPSTAR);
+"/="   AS(OPSLASH);
+"**="  |
+"^="   AS(OPPOWER);
+
+"&="   AS(OPAND);
+"&&="  AS(OP2AND);
+"|="   AS(OPOR);
+"||="  AS(OP2OR);
+
+\'[^\n']*\'    |
+\"[^\n"]*\"    { yytext[yyleng-1] = '\0'; p = mkconst(TYCHAR,yytext+1);
+                 RETP(CONST,p); }
+
+{D}+[hH]       { /* nh construct */
+               int i, n;  char c;
+               yytext[yyleng-1] = '\0';  n = convci(yytext);
+               for(i = 0; i<n ; ++i)
+                       if( (c=yytext[i]=input()) == '\n' || c=='\0') break;
+               yytext[i] = '\0';
+               p = mkconst(TYCHAR,yytext);
+               p->vtypep = mkint(i);
+               RETP(CONST, p);
+               }
+
+{D}+           RETC(TYINT);
+
+{D}+"."{D}*    |
+{D}*"."{D}+    RETC(TYREAL);
+
+{D}+"."?{D}*{e}        |
+{D}*"."{D}+{e} RETC(TYREAL);
+
+{D}+"."?{D}*{d}        |
+{D}*"."{D}+{d} RETC(TYLREAL);
+
+{D}+{i}                { yytext[yyleng-1] = '.';
+                 RETP(CONST,mkimcon(TYCOMPLEX,yytext)); }
+
+{D}+"."{D}*{i} |
+{D}*"."{D}+{i} RETZ(TYCOMPLEX);
+
+{D}+"."?{D}*{e}{i}     |
+{D}*"."{D}+{e}{i}      RETZ(TYCOMPLEX);
+
+{D}+"."?{D}*{d}{i}     |
+{D}*"."{D}+{d}{i}      RETZ(TYLCOMPLEX);
+
+"#".*  { if(! nocommentflag) goto litline; }
+
+^"%".* { if(thisexec) thisexec->nftnst += 2;
+         if(inproc)
+               {
+               unput('\n');
+               RETP(ESCAPE, copys(yytext));
+               }
+
+       litline:        p = mkchain( copys(yytext), CHNULL);
+                       if(inproc==0 && yytext[0]=='%')
+                               prevcomments = hookup(prevcomments, p);
+                       else
+                               comments =  hookup(comments,p);
+       }
+
+" "    ;
+\t     ;
+\f     ;
+
+"_"[ \t]*\n    ;
+
+\n     { if(igeol) { igeol=0; prevv = NEWLINE; }
+         else if(prevv>=NAME || prevv==RPAR || prevv==RBRACK
+                       || prevv== -1 || prevv==QUALOP)
+               RET(EOS); }
+
+.      { char * linerr();
+         fprintf(diagfile, "Bad input character %c %s\n", yytext[0], linerr());
+         ++nerrs;
+       }
+
+^[ \t]*[iI][nN][cC][lL][uU][dD][eE].*\n        { /* Include statement */
+       char *q1;
+       register char *q2;
+       for(q1=yytext ; *q1==' ' || *q1=='\t' ; ++q1) ;
+       quoted = NO;
+       for(q1 += 7 ; *q1==' ' || *q1=='\t' ||
+               *q1=='\'' || *q1=='"' || *q1=='(' ; ++q1 )
+                       if(*q1=='"' || *q1=='\'')
+                               quoted = YES;
+       for(q2=q1 ; *q2!='\0' &&  *q2!=' ' && *q2!='\n' &&
+               *q2!='\'' && *q2!='"' && *q2!=')' ; ++q2 )
+                       ;
+       *q2 = '\0';
+       if( ! quoted)
+               for(k=0; (q = name(q1,1)) && q->tag==TDEFINE ; ++k)
+                       {
+                       if(k > MAXINCLUDEDEPTH)
+                               fatal1("Macros too deep for %s", yytext);
+                       q1 = q->varp->valp;
+                       }
+       if( (fd = opincl(&q1)) == NULL)
+               {
+               fprintf(diagfile, "Cannot open file %s.  Stop.\n", q1);
+               exit(2);
+               }
+       filelines[filedepth] = yylineno;
+       pushchars[filedepth] = '\n';
+       if(++filedepth >= MAXINCLUDEDEPTH)
+               fatal("macro or include too deep");
+       fileptrs[filedepth] = yyin = fd;
+       filenames[filedepth] = copys(q1);
+       filelines[filedepth] = yylineno = 1;
+       filemacs[filedepth] = NULL;
+       }
+
+%%
+
+yywrap()
+{
+if(filedepth == 0)
+       {
+       ateof = 1;
+       return(1);
+       }
+
+if(efmacp == 0)
+       {
+       fclose(yyin);
+       cfree(filenames[filedepth]);
+       }
+
+--filedepth;
+if( filemacs[filedepth] )
+       efmacp = filemacs[filedepth];
+else   {
+       yyin = fileptrs[filedepth];
+       efmacp = 0;
+       }
+yylineno = filelines[filedepth];
+if(pushchars[filedepth] != -1)
+       unput( pushchars[filedepth] );
+return(0);
+}
+
+
+
+lower(s)       /* replace upper with lower case letters */
+register char *s;
+{
+register char *t;
+for(t=s ; *t ; ++t)
+       if( isupper(*t) )
+               *s++ = tolower(*t);
+       else if(*t != '_')
+               *s++ = *t;
+}
+
+
+
+
+setdot(k)
+int k;
+{
+if(k)
+       BEGIN DOTSON;
+else   BEGIN 0;
+}
+
+
+
+
+FILE *opincl(namep)
+char **namep;
+{
+#ifndef unix
+       return( fopen(*namep, "r") );
+#else
+
+       /* On Unix, follow the C include conventions */
+       
+       register char *s, *lastslash;
+       char *dir, *name, temp[100];
+       int i;
+       FILE *fp;
+       
+       name = *namep;
+       if(name[0] == '/')
+               return( fopen(name, "r") );
+       
+       dir = basefile;
+       for(i = filedepth ; i>=0 ; --i)
+               if( filemacs[i] == NULL)
+                       {
+                       dir = filenames[i];
+                       break;
+                       }
+
+       lastslash = NULL;
+       for(s = dir ; *s ; ++s)
+               if(*s == '/')
+                       lastslash = s;
+       if(lastslash)
+               {
+               *lastslash = '\0';
+               sprintf(temp, "%s/%s", dir, name);
+               *lastslash = '/';
+               if( fp = fopen(temp, "r") )
+                       *namep = temp;
+               }
+       else
+               fp = fopen(name, "r");
+       
+       if(fp == NULL)
+               {
+               sprintf(temp, "/usr/include/%s", name);
+               fp = fopen(temp, "r");
+               *namep = temp;
+               }
+       return(fp);
+
+#endif
+}
+
diff --git a/usr/src/cmd/efl/misc.c b/usr/src/cmd/efl/misc.c

new file mode 100644 (file)

index 0000000..6219e08
--- /dev/null
+++ b/usr/src/cmd/efl/misc.c
@@ -0,0 +1,421 @@
+#include <ctype.h>
+#include "defs"
+
+char * copys(s)
+register char *s;
+{
+register char *t;
+char *k;
+ptr calloc();
+
+for(t=s; *t++ ; );
+if( (k = calloc( t-s , sizeof(char))) == NULL)
+       fatal("Cannot allocate memory");
+
+for(t=k ; *t++ = *s++ ; );
+return(k);
+}
+
+
+
+equals(a,b)
+register char *a,*b;
+{
+if(a==b) return(YES);
+
+while(*a == *b)
+       if(*a == '\0') return(YES);
+       else {++a; ++b;}
+
+return(NO);
+}
+
+
+char *concat(a,b,c)   /* c = concatenation of a and b */
+register char *a,*b;
+char *c;
+{
+register char *t;
+t = c;
+
+while(*t = *a++) t++;
+while(*t++ = *b++);
+return(c);
+}
+
+
+
+
+
+ptr conrep(a,b)
+char *a, *b;
+{
+char *s;
+
+s = intalloc( strlen(a)+strlen(b)+1 );
+concat(a,b,s);
+cfree(a);
+return(s);
+}
+
+
+eqcon(p,q)
+register ptr p, q;
+{
+int pt, qt;
+
+if(p==q) return(YES);
+if(p==NULL || q==NULL) return(NO);
+pt = p->tag;
+qt = q->tag;
+if(pt==TNEGOP && qt==TNEGOP)
+       return( eqcon(p->leftp, q->leftp) );
+if(pt==TCONST && qt==TNEGOP)
+       return(NO);
+if(pt==TNEGOP && qt==TCONST)
+       return(NO);
+if(p->tag==TCONST && q->tag==TCONST)
+       return( equals(p->leftp,q->leftp) );
+
+fatal("eqcon: nonconstant argument");
+/* NOTREACHED */
+}
+
+
+
+char *convic(n)
+register int n;
+{
+static char s[20];
+register char *t;
+
+s[19] = '\0';
+t = s+19;
+
+do     {
+       *--t = '0' + n%10;
+       n /= 10;
+       } while(n > 0);
+
+return(t);
+}
+
+
+
+conval(p)
+register ptr p;
+{
+int val;
+if(isicon(p, &val))
+       return(val);
+fatal("bad conval");
+}
+
+
+
+isicon(p, valp)
+ptr p;
+int *valp;
+{
+int val1;
+
+if(p)
+    switch(p->tag)
+       {
+       case TNEGOP:
+               if(isicon(p->leftp, &val1))
+                       {
+                       *valp = - val1;
+                       return(1);
+                       }
+               break;
+
+       case TCONST:
+               if(p->vtype == TYINT)
+                       {
+                       *valp = convci(p->leftp);
+                       return(YES);
+                       }
+       default:
+               break;
+       }
+return(NO);
+}
+
+
+
+isconst(p)
+ptr p;
+{
+return(p->tag==TCONST  ||  (p->tag==TNEGOP && isconst(p->leftp)) );
+}
+
+
+
+iszero(s)
+register char *s;
+{
+if(s == NULL)
+       return(YES);
+while( *s=='+' || *s=='-' || *s==' ' )
+       ++s;
+while( *s=='0' || *s=='.' )
+       ++s;
+switch( *s )
+       {
+       case 'd':
+       case 'e':
+       case 'D':
+       case 'E':
+       case ' ':
+       case '\0':
+               return(YES);
+       default:
+               return(NO);
+       }
+}
+
+
+
+
+convci(p)
+register char *p;
+{
+register int n;
+register int sgn;
+
+n = 0;
+sgn = 1;
+for( ; *p ; ++p)
+       if(*p == '-')
+               sgn = -1;
+       else if( isdigit(*p) )
+               n = 10*n + (*p - '0');
+
+return(sgn * n);
+}
+
+
+
+chainp hookup(x,y)
+register chainp x, y;
+{
+register chainp p;
+
+if(x == NULL)
+       return(y);
+for(p=x ; p->nextp ; p = p->nextp)
+       ;
+
+p->nextp = y;
+return(x);
+}
+
+
+ptr cpexpr(p)
+register ptr p;
+{
+register ptr e;
+ptr q, q1;
+
+if(p == NULL)
+       return(NULL);
+
+e = allexpblock();
+cpblock(p, e, sizeof(struct exprblock));
+
+switch(p->tag)
+       {
+       case TAROP:
+       case TRELOP:
+       case TLOGOP:
+       case TASGNOP:
+       case TCALL:
+               e->rightp = cpexpr(p->rightp);
+
+       case TNOTOP:
+       case TNEGOP:
+               e->leftp = cpexpr(p->leftp);
+               break;
+
+       case TCONST:
+               e->leftp = copys(p->leftp);
+               if(p->rightp)
+                       e->rightp = copys(p->rightp);
+               if(p->vtype == TYCHAR)
+                       e->vtypep = cpexpr(p->vtypep);
+               break;
+
+       case TLIST:
+               q1 = &(e->leftp);
+               for(q = p->leftp ; q ; q = q->nextp)
+                       q1 = q1->nextp = mkchain( cpexpr(q->datap), CHNULL);
+               break;
+
+       case TTEMP:
+       case TNAME:
+       case TFTNBLOCK:
+               if(p->vsubs)
+                       e->vsubs = cpexpr(p->vsubs);
+               if(p->voffset)
+                       e->voffset = cpexpr(p->voffset);
+               break;
+
+       case TERROR:
+               break;
+
+       default:
+               badtag("cpexpr", p->tag);
+       }
+return(e);
+}
+
+
+mvexpr(p,q)
+char *p, *q;
+{
+cpblock(p,q, sizeof(struct exprblock) );
+frexpblock(p);
+}
+
+
+cpblock(p,q,n)
+register char *p, *q;
+int n;
+{
+register int i;
+
+for(i=0; i<n; ++i)
+       *q++ = *p++;
+}
+
+
+
+strlen(s)
+register char *s;
+{
+register char *t;
+for(t=s ; *t ; t++ ) ;
+return(t-s);
+}
+
+
+char *procnm() /* name of the current procedure */
+{
+return( procname ? procname->sthead->namep : "" );
+}
+
+
+
+
+
+ptr arg1(a)            /* make an argument list of one value */
+ptr a;
+{
+return( mknode(TLIST,0, mkchain(a,CHNULL), PNULL) );
+}
+
+
+
+ptr arg2(a,b)  /* make an argumentlist (a,b) */
+ptr a,b;
+{
+register ptr p;
+
+p = mkchain(a, mkchain(b,CHNULL) );
+return( mknode(TLIST,0, p,0) );
+}
+
+
+
+
+ptr arg4(a,b)  /* make an argument list of  (a,len(a), b,len(b)) */
+ptr a,b;
+{
+register ptr p;
+p = mkchain(b, mkchain(cpexpr(b->vtypep), CHNULL));
+p = mkchain(a, mkchain(cpexpr(a->vtypep), p));
+return( mknode(TLIST,0,p,PNULL));
+}
+
+
+
+ptr builtin(type,s)
+int type;
+char *s;
+{
+register ptr p, q;
+ptr mkvar(), mkname();
+
+if(p = name(s,1))
+       {
+       if(p->blklevel>1 || (p->tag!=TNAME && p->tag!=TKEYWORD) 
+           || (q=p->varp)==0 || q->vext
+           || (q->vtype!=type && q->vtype!=TYUNDEFINED) )
+               {
+               exprerr("error involving builtin %s", s);
+               return(errnode());
+               }
+       if(q->vtype!= TYUNDEFINED)
+               return( cpexpr(q) );
+       }
+else   {
+       q = mkvar( mkname(s) );
+       if(blklevel > 1)
+               {
+               q->blklevel = 1;
+               q->sthead->blklevel = 1;
+               --ndecl[blklevel];
+               ++ndecl[1];
+               }
+       }
+
+q->vtype = type;
+q->vdclstart = 1;
+mkftnp(q);
+return( cpexpr(q) );
+}
+
+
+
+ptr errnode()
+{
+register struct exprblock * p;
+
+p = allexpblock();
+p->tag = TERROR;
+p->vtype = TYINT;
+return(p);
+}
+
+
+
+min(a,b)
+int a,b;
+{
+return( a<b ? a : b);
+}
+
+
+
+setvproc(p, v)
+register ptr p;
+register int v;
+{
+ptr q;
+register int k;
+
+q = p->sthead->varp;
+k = q->vproc;
+/*debug printf("setvproc(%s ,%d)\n", q->sthead->namep, v); */
+if(p != q)
+       p->vproc = k;
+if(k == v)
+       return;
+
+if(k==PROCUNKNOWN || (k==PROCYES && v==PROCINTRINSIC) )
+       p->vproc = q->vproc = v;
+else if( !(k==PROCINTRINSIC && v==PROCYES)  && p->sthead->varp!=procname)
+       execerr("attempt to use %s as variable and procedure",
+               p->sthead->namep);
+}
diff --git a/usr/src/cmd/efl/mk.c b/usr/src/cmd/efl/mk.c

new file mode 100644 (file)

index 0000000..b05f66c
--- /dev/null
+++ b/usr/src/cmd/efl/mk.c
@@ -0,0 +1,990 @@
+#include "defs"
+
+
+ptr mkcomm(s)
+register char *s;
+{
+register ptr p;
+register char *t;
+
+for(p = commonlist ; p ; p = p->nextp)
+       if(equals(s, p->datap->comname))
+               return(p->datap);
+
+p = ALLOC(comentry);
+for(t = p->comname ; *t++ = *s++ ; ) ;
+p->tag = TCOMMON;
+p->blklevel = (blklevel>0? 1 : 0);
+commonlist = mkchain(p, commonlist);
+return(commonlist->datap);
+}
+
+
+
+
+ptr mkname(s)
+char *s;
+{
+char *copys();
+register ptr p;
+
+if( (p = name(s,1)) == 0)
+       {
+       p = name(s,0);
+       p->tag = TNAME;
+       p->blklevel = blklevel;
+       }
+return(p);
+}
+\f
+ptr mknode(t, o, l, r)
+int t,o;
+register ptr l;
+register ptr r;
+{
+register struct exprblock *p;
+ptr q;
+int lt, rt;
+int ll, rl;
+ptr mksub1(), mkchcon();
+
+p = allexpblock();
+TEST fprintf(diagfile, "mknode(%d,%d,%o,%o) = %o\n", t, o, l, r, p);
+
+top:
+       if(t!=TLIST && t!=TCONST && l!=0 && l->tag==TERROR)
+               {
+               frexpr(r);
+               frexpblock(p);
+               return(l);
+               }
+
+       if(r!=0 && r->tag==TERROR)
+               {
+               frexpr(l);
+               frexpblock(p);
+               return(r);
+               }
+       p->tag = t;
+       p->subtype = o;
+       p->leftp = l;
+       p->rightp = r;
+
+switch(t)
+       {
+       case TAROP:
+               ckdcl(l);
+               ckdcl(r);
+               switch(lt = l->vtype)
+                       {
+                       case TYCHAR:
+                       case TYSTRUCT:
+                       case TYLOG:
+                               exprerr("non-arithmetic operand of arith op","");
+                               goto err;
+                       }
+
+               switch(rt = r->vtype)
+                       {
+                       case TYCHAR:
+                       case TYSTRUCT:
+                       case TYLOG:
+                               exprerr("non-arithmetic operand of arith op","");
+                               goto err;
+                       }
+               if(lt==rt || (o==OPPOWER && rt==TYINT) )
+                       p->vtype = lt;
+               else if( (lt==TYREAL && rt==TYLREAL) ||
+                       (lt==TYLREAL && rt==TYREAL) )
+                               p->vtype = TYLREAL;
+               else if(lt==TYINT)
+                       {
+                       l = coerce(rt,l);
+                       goto top;
+                       }
+               else if(rt==TYINT)
+                       {
+                       r = coerce(lt,r);
+                       goto top;
+                       }
+               else if( (lt==TYREAL && rt==TYCOMPLEX) ||
+                        (lt==TYCOMPLEX && rt==TYREAL) )
+                       p->vtype = TYCOMPLEX;
+               else if( (lt==TYLREAL && rt==TYCOMPLEX) ||
+                        (lt==TYCOMPLEX && rt==TYLREAL) )
+                       p->vtype = TYLCOMPLEX;
+               else    {
+                       exprerr("mixed mode", CNULL);
+                       goto err;
+                       }
+
+               if( (o==OPPLUS||o==OPSTAR) && l->tag==TCONST && r->tag!=TCONST )
+                       {
+                       p->leftp = r;
+                       p->rightp = l;
+                       }
+
+               if(o==OPPLUS && l->tag==TNEGOP &&
+                 (r->tag!=TCONST || l->leftp->tag==TCONST) )
+                       {
+                       p->subtype = OPMINUS;
+                       p->leftp = r;
+                       p->rightp = l->leftp;
+                       }
+
+               break;
+
+       case TRELOP:
+               ckdcl(l);
+               ckdcl(r);
+               p->vtype = TYLOG;
+               lt = l->vtype;
+               rt = r->vtype;
+               if(lt==TYCHAR || rt==TYCHAR)
+                       {
+                       if(l->vtype != r->vtype)
+                               {
+                               exprerr("comparison of character and noncharacter data",CNULL);
+                               goto err;
+                               }
+                       ll = conval(l->vtypep);
+                       rl = conval(r->vtypep);
+                       if( (o==OPEQ || o==OPNE) &&
+                               ( (ll==1 && rl==1 && tailor.charcomp==1)
+                               || (ll<=tailor.ftnchwd && rl<=tailor.ftnchwd
+                               && tailor.charcomp==2) ))
+                               {
+                               if(l->tag == TCONST)
+                                       {
+                                       q = cpexpr( mkchcon(l->leftp) );
+                                       frexpr(l);
+                                       l = q;
+                                       }
+                               if(r->tag == TCONST)
+                                       {
+                                       q = cpexpr( mkchcon(r->leftp) );
+                                       frexpr(r);
+                                       r = q;
+                                       }
+                               if(l->vsubs == 0)
+                                       l->vsubs = mksub1();
+                               if(r->vsubs == 0)
+                                       r->vsubs = mksub1();
+                               p->leftp = l;
+                               p->rightp = r;
+                               }
+                       else    {
+                               p->leftp = mkcall(builtin(TYINT,"ef1cmc"), arg4(l,r));
+                               p->rightp = mkint(0);
+                               }
+                       }
+
+               else if(lt==TYLOG || rt==TYLOG)
+                       exprerr("relational involving logicals", CNULL);
+               else if( (lt==TYCOMPLEX || rt==TYCOMPLEX) &&
+                       o!=OPEQ && o!=OPNE)
+                               exprerr("order comparison of complex numbers", CNULL);
+               else if(lt != rt)
+                       {
+                       if(lt==TYINT)
+                               p->leftp = coerce(rt, l);
+                       else if(rt == TYINT)
+                               p->rightp = coerce(lt, r);
+                       }
+               break;
+
+       case TLOGOP:
+               ckdcl(l);
+               ckdcl(r);
+               if(r->vtype != TYLOG)
+                       {
+                       exprerr("non-logical operand of logical operator",CNULL);
+                       goto err;
+                       }
+       case TNOTOP:
+               ckdcl(l);
+               if(l->vtype != TYLOG)
+                       {
+                       exprerr("non-logical operand of logical operator",CNULL);
+                       }
+               p->vtype = TYLOG;
+               break;
+
+       case TNEGOP:
+               ckdcl(l);
+               lt = l->vtype;
+               if(lt!=TYINT && lt!=TYREAL && lt!=TYLREAL && lt!=TYCOMPLEX)
+                       {
+                       exprerr("impossible unary + or - operation",CNULL);
+                       goto err;
+                       }
+               p->vtype = lt;
+               break;
+
+       case TCALL:
+               p->vtype = l->vtype;
+               p->vtypep = l->vtypep;
+               break;
+
+       case TASGNOP:
+               ckdcl(l);
+               ckdcl(r);
+               lt = l->vtype;
+               if(lt==TYFIELD)
+                       lt = TYINT;
+               rt = r->vtype;
+               if(lt==TYCHAR || rt==TYCHAR || lt==TYLOG || rt==TYLOG)
+                       {
+                       if(lt != rt)
+                               {
+                               exprerr("illegal assignment",CNULL);
+                               goto err;
+                               }
+                       }
+               else if(lt==TYSTRUCT || rt==TYSTRUCT)
+                       {
+                       if(lt!=rt || l->vtypep->strsize!=r->vtypep->strsize
+                               || l->vtypep->stralign!=r->vtypep->stralign)
+                               {
+                               exprerr("illegal structure assignment",CNULL);
+                               goto err;
+                               }
+                       }
+               else if ( (lt==TYCOMPLEX || rt==TYCOMPLEX) && lt!=rt)
+/*                     p->rightp = r = coerce(lt, r) */ ;
+
+               p->vtype = lt;
+               p->vtypep = l->vtypep;
+               break;
+
+       case TCONST:
+       case TLIST:
+       case TREPOP:
+               break;
+
+       default:
+               badtag("mknode", t);
+       }
+
+return(p);
+
+err:   frexpr(p);
+       return( errnode() );
+}
+
+
+
+ckdcl(p)
+ptr p;
+{
+if(p->vtype==TYUNDEFINED || (p->tag==TNAME&&p->vdcldone==0&&p->vadjdim==0))
+       {
+/*debug*/ printf("tag=%d, typed=%d\n", p->tag, p->vtype);
+       fatal("untyped subexpression");
+       }
+if(p->tag==TNAME) setvproc(p,PROCNO);
+}
+\f
+ptr mkvar(p)
+register ptr p;
+{
+register ptr q;
+
+TEST fprintf(diagfile, "mkvar(%s), blk %d\n", p->namep, blklevel);
+
+if(p->blklevel > blklevel)
+       p->blklevel = blklevel;
+
+if(instruct || p->varp==0 || p->varp->blklevel<blklevel)
+       {
+       q = allexpblock();
+       q->tag = TNAME;
+       q->sthead = p;
+       q->blklevel = blklevel;
+       if(! instruct)
+               ++ndecl[blklevel];
+       }
+else q = p->varp;
+
+if(!instruct)
+       {
+       if(p->varp && p->varp->blklevel<blklevel)
+               hide(p);
+       if(p->varp == 0)
+               p->varp = q;
+       }
+
+p->tag = TNAME;
+return(q);
+}
+
+
+ptr mkstruct(v,s)
+register ptr v;
+ptr s;
+{
+register ptr p;
+
+p = ALLOC(typeblock);
+p->sthead = v;
+p->tag = TSTRUCT;
+p->blklevel = blklevel;
+p->strdesc = s;
+offsets(p);
+if(v)  {
+       v->blklevel = blklevel;
+       ++ndecl[blklevel];
+       v->varp = p;
+       }
+else   temptypelist = mkchain(p, temptypelist);
+return(p);
+}
+
+
+ptr mkcall(fn1, args)
+ptr fn1, args;
+{
+int i, j, first;
+register ptr funct, p, q;
+ptr r;
+
+if(fn1->tag == TERROR)
+       return( errnode() );
+else if(fn1->tag == TNAME)
+       {
+       funct = fn1->sthead->varp;
+       frexpblock(fn1);
+       }
+else
+       funct = fn1;
+if(funct->vclass!=0 && funct->vclass!=CLARG)
+       {
+       exprerr("invalid invocation of %s",funct->sthead->namep);
+       frexpr(args);
+       return( errnode() );
+       }
+else   extname(funct);
+
+if(args)  for(p = args->leftp; p ; p = p->nextp)
+       {
+       q = p->datap;
+       if( (q->tag==TCALL&&q->vtype==TYUNDEFINED) ||
+           (q->tag==TNAME&&q->vdcldone==0) )
+               dclit(q);
+       if(q->tag==TNAME && q->vproc==PROCUNKNOWN)
+               setvproc(q, PROCNO);
+       if( q->vtype == TYSTRUCT)
+               {
+               first = 1;
+               for(i = 0; i<NFTNTYPES ; ++i)
+                       if(q->vbase[i] != 0)
+                               {
+                               r = cpexpr(q);
+                               if(first)
+                                       {
+                                       p->datap = r;
+                                       first = 0;
+                                       }
+                               else    p = p->nextp = mkchain(r, p->nextp);
+                               r->vtype = ftnefl[i];
+                               for(j=0; j<NFTNTYPES; ++j)
+                                       if(i != j) r->vbase[j] = 0;
+                               }
+               frexpblock(q);
+               }
+       }
+
+return( mknode(TCALL,0,cpexpr(funct), args) );
+}
+
+
+
+mkcase(p,here)
+ptr p;
+int here;
+{
+register ptr q, s;
+
+for(s = thisctl ; s!=0 && s->subtype!=STSWITCH ; s = s->prevctl)
+       ;
+if(s==0 || (here && s!=thisctl) )
+       {
+       laberr("invalid case label location",CNULL);
+       return(0);
+       }
+for(q = s->loopctl ; q!=0 && !eqcon(p,q->casexpr) ; q = q->nextcase)
+       ;
+if(q == 0)
+       {
+       q = ALLOC(caseblock);
+       q->tag = TCASE;
+       q->casexpr = p;
+       q->labelno = ( here ? thislab() : nextlab() );
+       q->nextcase = s->loopctl;
+       s->loopctl = q;
+       }
+else if(here)
+       if(thisexec->labelno == 0)
+               thisexec->labelno = q->labelno;
+       else if(thisexec->labelno != q->labelno)
+               {
+               exnull();
+               thisexec->labelno = q->labelno;
+               thisexec->labused = 0;
+               }
+if(here)
+       if(q->labdefined)
+               laberr("multiply defined case",CNULL);
+       else
+               q->labdefined = 1;
+return(q->labelno);
+}
+
+
+ptr mkilab(p)
+ptr p;
+{
+char *s, l[30];
+
+if(p->tag!=TCONST || p->vtype!=TYINT)
+       {
+       execerr("invalid label","");
+       s = "";
+       }
+else   s = p->leftp;
+
+while(*s == '0')
+       ++s;
+sprintf(l,"#%s", s);
+
+
+TEST fprintf(diagfile,"numeric label = %s\n", l);
+return( mkname(l) );
+}
+
+
+
+
+mklabel(p,here)
+ptr p;
+int here;
+{
+register ptr q;
+
+if(q = p->varp)
+       {
+       if(q->tag != TLABEL)
+               laberr("%s is already a nonlabel\n", p->namep);
+       else if(q->labinacc)
+               warn1("label %s is inaccessible", p->namep);
+       else if(here)
+               if(q->labdefined)
+                       laberr("%s is already defined\n", p->namep);
+               else if(blklevel > q->blklevel)
+                       laberr("%s is illegally placed\n",p->namep);
+               else    {
+                       q->labdefined = 1;
+                       if(thisexec->labelno == 0)
+                               thisexec->labelno = q->labelno;
+                       else if(thisexec->labelno != q->labelno)
+                               {
+                               exnull();
+                               thisexec->labelno = q->labelno;
+                               thisexec->labused = 0;
+                               }
+                       }
+       }
+else   {
+       q = ALLOC(labelblock);
+       p->varp = q;
+       q->tag = TLABEL;
+       q->subtype = 0;
+       q->blklevel = blklevel;
+       ++ndecl[blklevel];
+       q->labdefined = here;
+       q->labelno = ( here ? thislab() : nextlab() );
+       q->sthead = p;
+       }
+
+return(q->labelno);
+}
+
+
+thislab()
+{
+if(thisexec->labelno == 0)
+       thisexec->labelno = nextlab();
+return(thisexec->labelno);
+}
+
+
+nextlab()
+{
+stnos[++labno] = 0;
+return( labno );
+}
+
+
+nextindif()
+{
+if(++nxtindif < MAXINDIFS)
+       return(nxtindif);
+fatal("too many indifs");
+}
+
+
+
+
+mkkeywd(s, n)
+char *s;
+int n;
+{
+register ptr p;
+register ptr q;
+
+p = name(s, 2);
+q = ALLOC(keyblock);
+p->tag = TKEYWORD;
+q->tag = TKEYWORD;
+p->subtype = n;
+q->subtype = n;
+p->blklevel = 0;
+p->varp = q;
+q->sthead = p;
+}
+
+
+ptr mkdef(s, v)
+char *s, *v;
+{
+register ptr p;
+register ptr q;
+
+if(p = name(s,1))
+       if(p->blklevel == 0)
+               {
+               if(blklevel > 0)
+                       hide(p);
+               else if(p->tag != TDEFINE)
+                       dclerr("attempt to DEFINE a variable name", s);
+               else    {
+                       if( strcmp(v, (q=p->varp) ->valp) )
+                               {
+                               warn("macro value replaced");
+                               cfree(q->valp);
+                               q->valp = copys(v);
+                               }
+                       return(p);
+                       }
+               }
+       else    {
+               dclerr("type already defined", s);
+               return( errnode() );
+               }
+else   p = name(s,0);
+
+q = ALLOC(defblock);
+p->tag = TDEFINE;
+q->tag = TDEFINE;
+p->blklevel = q->blklevel = (blklevel==0 ? 0 : 1);
+q->sthead = p;
+p->varp = q;
+p->varp->valp = copys(v);
+return(p);
+}
+
+
+
+mkknown(s,t)
+char *s;
+int t;
+{
+register ptr p;
+
+p = ALLOC(knownname);
+p->nextfunct = knownlist;
+p->tag = TKNOWNFUNCT;
+knownlist = p;
+p->funcname = s;
+p->functype = t;
+}
+
+
+
+
+
+
+
+ptr mkint(k)
+int k;
+{
+return( mkconst(TYINT, convic(k) ) );
+}
+
+
+ptr mkconst(t,p)
+int t;
+ptr p;
+{
+ptr q;
+
+q = mknode(TCONST, 0, copys(p), PNULL);
+q->vtype = t;
+if(t == TYCHAR)
+       q->vtypep = mkint( strlen(p) );
+return(q);
+}
+
+
+
+ptr mkimcon(t,p)
+int t;
+char *p;
+{
+ptr q;
+char *zero, buff[100];
+
+zero = (t==TYCOMPLEX ? "0." : "0d0");
+sprintf(buff, "(%s,%s)", zero, p);
+q = mknode(TCONST, 0, copys(buff), PNULL);
+q->vtype = t;
+return(q);
+}
+
+
+
+ptr mkarrow(p,t)
+register ptr p;
+ptr t;
+{
+register ptr q, s;
+
+if(p->vsubs == 0)
+       if(p->vdim==0 && p->vtype!=TYCHAR && p->vtype!=TYSTRUCT)
+               {
+               exprerr("need an aggregate to the left of arrow",CNULL);
+               frexpr(p);
+               return( errnode() );
+               }
+       else    {
+               if(p->vdim)
+                       {
+                       s = 0;
+                       for(q = p->vdim->datap ; q ; q = q->nextp)
+                               s = mkchain( mkint(1), s);
+                       subscript(p, mknode(TLIST,0,s,PNULL) );
+                       }
+               }
+
+p->vtype = TYSTRUCT;
+p->vtypep = t->varp;
+return(p);
+}
+
+
+
+
+
+mkequiv(p)
+ptr p;
+{
+ptr q, t;
+int first;
+
+swii(iefile);
+putic(ICBEGIN, 0);
+putic(ICINDENT, 0);
+putic(ICKEYWORD, FEQUIVALENCE);
+putic(ICOP, OPLPAR);
+first = 1;
+
+for(q = p ; q ; q = q->nextp)
+       {
+       if(first)  first = 0;
+       else putic(ICOP, OPCOMMA);
+       prexpr( t =  simple(LVAL,q->datap) );
+       frexpr(t);
+       }
+
+putic(ICOP, OPRPAR);
+swii(icfile);
+frchain( &p );
+}
+
+
+
+
+mkgeneric(gname,atype,fname,ftype)
+char *gname, *fname;
+int atype, ftype;
+{
+register ptr p;
+ptr generic();
+
+if(p = generic(gname))
+       {
+       if(p->genfname[atype])
+               fatal1("generic name already defined", gname);
+       }
+else   {
+       p = ALLOC(genblock);
+       p->tag = TGENERIC;
+       p->nextgenf = generlist;
+       generlist = p;
+       p->genname = gname;
+       }
+
+p->genfname[atype] = fname;
+p->genftype[atype] = ftype;
+}
+
+
+ptr generic(s)
+char *s;
+{
+register ptr p;
+
+for(p= generlist; p ; p = p->nextgenf)
+       if(equals(s, p->genname))
+               return(p);
+return(0);
+}
+
+
+knownfunct(s)
+char *s;
+{
+register ptr p;
+
+for(p = knownlist ; p ; p = p->nextfunct)
+       if(equals(s, p->funcname))
+               return(p->functype);
+return(0);
+}
+
+
+
+
+
+ptr funcinv(p)
+register ptr p;
+{
+ptr fp, fp1;
+register ptr g;
+char *s;
+register int t;
+int vt;
+
+if(g = generic(s = p->leftp->sthead->namep))
+       {
+       if(p->rightp->tag==TLIST && p->rightp->leftp
+               && ( (vt = typearg(p->rightp->leftp)) >=0)
+               && (t = g->genftype[vt]) )
+               {
+               p->leftp = builtin(t, g->genfname[vt]);
+               }
+       else    {
+               dclerr("improper use of generic function", s);
+               frexpr(p);
+               return( errnode() );
+               }
+       }
+
+fp = p->leftp;
+setvproc(fp, PROCYES);
+fp1 = fp->sthead->varp;
+s = fp->sthead->namep;
+
+if(p->vtype==TYUNDEFINED && fp->vclass!=CLARG)
+       if(t = knownfunct(s))
+               {
+               p->vtype = t;
+               setvproc(fp, PROCINTRINSIC);
+               setvproc(fp1, PROCINTRINSIC);
+               fp1->vtype = t;
+               builtin(t,fp1->sthead->namep);
+               cpblock(fp1, fp, sizeof(struct exprblock));
+               }
+
+dclit(p);
+return(p);
+}
+
+
+
+
+typearg(p0)
+register chainp p0;
+{
+register chainp p;
+register int vt, maxt;
+
+if(p0 == NULL)
+       return(-1);
+maxt = p0->datap->vtype;
+
+for(p = p0->nextp ; p ; p = p->nextp)
+       if( (vt = p->datap->vtype) > maxt)
+               maxt = vt;
+
+for(p = p0 ; p ; p = p->nextp)
+       p->datap = coerce(maxt, p->datap);
+
+return(maxt);
+}
+
+
+
+
+ptr typexpr(t,e)
+register ptr t, e;
+{
+ptr e1;
+int etag;
+
+if(t->atdim!=0 || (e->tag==TLIST && t->attype!=TYCOMPLEX) )
+       goto typerr;
+
+switch(t->attype)
+       {
+       case TYCOMPLEX:
+               if(e->tag==TLIST)
+                       if(e->leftp==0 || e->leftp->nextp==0
+                           || e->leftp->nextp->nextp!=0)
+                               {
+                               exprerr("bad conversion to complex", "");
+                               return( errnode() );
+                               }
+                       else    {
+                               e->leftp->datap = simple(RVAL,
+                                               e->leftp->datap);
+                               e->leftp->nextp->datap = simple(RVAL,
+                                               e->leftp->nextp->datap);
+                               if(isconst(e->leftp->datap) &&
+                                  isconst(e->leftp->nextp->datap) )
+                                       return( compconst(e) );
+                               e1 = mkcall(builtin(TYCOMPLEX,"cmplx"),
+                                       arg2( coerce(TYREAL,e->leftp->datap),
+                                       coerce(TYREAL,e->leftp->nextp->datap)));
+                               frchain( &(e->leftp) );
+                               frexpblock(e);
+                               return(e1);
+                               }
+
+       case TYINT:
+       case TYREAL:
+       case TYLREAL:
+       case TYLOG:
+       case TYFIELD:
+               e = coerce(t->attype, simple(RVAL, e) );
+               etag = e->tag;
+               if(etag==TAROP || etag==TLOGOP || etag==TRELOP)
+                       e->needpar = YES;
+               return(e);
+
+       case TYCHAR:
+       case TYSTRUCT:
+               goto typerr;
+       }
+
+typerr:
+       exprerr("typexpr not fully implemented", "");
+       frexpr(e);
+       return( errnode() );
+}
+
+
+
+
+ptr compconst(p)
+register ptr p;
+{
+register ptr a, b;
+int as, bs;
+int prec;
+
+prec = TYREAL;
+p = p->leftp;
+if(p == 0)
+       goto err;
+if(p->datap->vtype == TYLREAL)
+       prec = TYLREAL;
+a = coerce(TYLREAL, p->datap);
+p = p->nextp;
+if(p->nextp)
+       goto err;
+if(p->datap->vtype == TYLREAL)
+       a = coerce(prec = TYLREAL,a);
+b = coerce(TYLREAL, p->datap);
+
+if(a->tag==TNEGOP)
+       {
+       as = '-';
+       a = a->leftp;
+       }
+else   as = ' ';
+
+if(b->tag==TNEGOP)
+       {
+       bs = '-';
+       b = b->leftp;
+       }
+else   bs = ' ';
+
+if(a->tag!=TCONST || a->vtype!=prec ||
+   b->tag!=TCONST || b->vtype!=prec )
+               goto err;
+
+if(prec==TYLREAL && tailor.lngcxtype==NULL)
+       {
+       ptr q, e1, e2;
+       struct dimblock *dp;
+       sprintf(msg, "_const%d", ++constno);
+       q = mkvar(mkname(msg));
+       q->vtype = TYLREAL;
+       dclit(q);
+       dp = ALLOC(dimblock);
+       dp->upperb = mkint(2);
+       q->vdim = mkchain(dp,CHNULL);
+       sprintf(msg, "%c%s", as, a->leftp);
+       e1 = mkconst(TYLREAL, msg);
+       sprintf(msg, "%c%s", bs, b->leftp);
+       e2 = mkconst(TYLREAL, msg);
+       mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) );
+       cfree(q->vdim);
+       q->vtype = TYLCOMPLEX;
+       return(q);
+       }
+else
+       {
+       sprintf(msg, "(%c%s, %c%s)", as, a->leftp, bs, b->leftp);
+       return( mkconst(TYCOMPLEX, msg) );
+       }
+
+err:   exprerr("invalid complex constant", "");
+       return( errnode() );
+}
+
+
+
+
+ptr mkchcon(p)
+char *p;
+{
+register ptr q;
+char buf[10];
+
+sprintf(buf, "_const%d", ++constno);
+q = mkvar(mkname(buf));
+q->vtype = TYCHAR;
+q->vtypep = mkint(strlen(p));
+mkinit(q, mkconst(TYCHAR, p));
+return(q);
+}
+
+
+
+ptr mksub1()
+{
+return( mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL) );
+}
diff --git a/usr/src/cmd/efl/namgen.c b/usr/src/cmd/efl/namgen.c

new file mode 100644 (file)

index 0000000..2366277
--- /dev/null
+++ b/usr/src/cmd/efl/namgen.c
@@ -0,0 +1,334 @@
+#include "defs"
+
+impldecl(p)
+register ptr p;
+{
+extern char *types[];
+register ptr q;
+int n;
+
+if(p->vtype==TYSUBR) return;
+if(p->tag == TCALL)
+       {
+       impldecl(p->leftp);
+       p->vtype = p->leftp->vtype;
+       p->vtypep = p->leftp->vtypep;
+       return;
+       }
+
+if(inbound)
+       n = TYINT;
+else   {
+       n = impltype[p->sthead->namep[0] - 'a' ];
+       if(n==TYREAL && p->vprec!=0)
+               n = TYLREAL;
+       sprintf(msg,  "%s implicitly typed %s",p->sthead->namep, types[n]);
+       warn(msg);
+       }
+q = p->sthead->varp;
+p->vtype = q->vtype = n;
+if(p->blklevel>1 && p->vdclstart==0)
+       {
+       p->blklevel = q->blklevel = p->sthead->blklevel = 1;
+       p->vdclstart = q->vdclstart = 1;
+       --ndecl[blklevel];
+       ++ndecl[1];
+       }
+}
+
+
+
+extname(p)
+register ptr p;
+{
+register int i;
+register char *q, *s;
+
+/*     if(p->vclass == CLARG) return;  */
+if(p->vextbase) return;
+q = p->sthead->namep;
+setvproc(p, PROCYES);
+
+/* external names are automatically at block level 1 */
+
+if( (i =p->blklevel) >1)
+       {
+       p->sthead->blklevel = 1;
+       p->blklevel = 1;
+       p->sthead->varp->blklevel = 1;
+       ++ndecl[1];
+       --ndecl[i];
+       }
+
+if(p->vclass!=CLUNDEFINED && p->vclass!=CLARG)
+       {
+       dclerr("illegal class for procedure", q);
+       return;
+       }
+if(p->vclass!=CLARG && strlen(q)>XL)
+       {
+       if(! ioop(q) )
+               dclerr("procedure name too long", q);
+       return;
+       }
+if(lookftn(q) > 0)
+       dclerr("procedure name already used", q);
+else   {
+       for(i=0 ; i<NFTNTYPES ; ++i)
+               if(p->vbase[i]) break;
+       if(i < NFTNTYPES)
+               p->vextbase = p->vbase[i];
+       else    p->vextbase = nxtftn();
+
+       if(p->vext==0 || p->vclass!=CLARG)
+               for(s = ftnames[ p->vextbase ]; *s++ = *q++ ; ) ; 
+       return;
+       }
+}
+
+
+
+dclit(p)
+register ptr p;
+{
+register ptr q;
+
+if(p->tag == TERROR)
+       return;
+
+q = p->sthead->varp;
+
+if(p->tag == TCALL)
+       {
+       dclit(p->leftp);
+       if( ioop(p->leftp->sthead->namep) )
+               p->leftp->vtype = TYLOG;
+       p->vtype = p->leftp->vtype;
+       p->vtypep = p->leftp->vtypep;
+       return;
+       }
+
+if(q->vdcldone == 0)
+       mkftnp(q);
+if(p != q)
+       cpblock(q,p, sizeof(struct exprblock));
+}
+
+
+mkftnp(p)
+register ptr p;
+{
+int i,k;
+if(inbound || p->vdcldone) return;
+if(p == 0)
+       fatal("mkftnp: zero argument");
+if(p->tag!=TNAME && p->tag!=TTEMP)
+       badtag("mkftnp", p->tag);
+
+if(p->vtype == TYUNDEFINED)
+       if(p->vextbase)
+               return;
+       else    impldecl(p);
+p->vdcldone = 1;
+
+switch(p->vtype)
+       {
+       case TYCHAR:
+       case TYINT:
+       case TYREAL:
+       case TYLREAL:
+       case TYLOG:
+       case TYCOMPLEX:
+       case TYLCOMPLEX:
+               p->vbase[ eflftn[p->vtype] ] = nxtftn();
+               break;
+
+       case TYSTRUCT:
+               k = p->vtypep->basetypes;
+               for(i=0; i<NFTNTYPES ; ++i)
+                       if(k & ftnmask[i])
+                               p->vbase[i] = nxtftn();
+               break;
+
+       case TYSUBR:
+               break;
+
+       default:
+               fatal1("invalid type for %s", p->sthead->namep);
+               break;
+       }
+}
+
+
+namegen()
+{
+register ptr p;
+register struct stentry **hp;
+register int i;
+
+for(hp = hashtab ; hp<hashend ; ++hp)
+       if(*hp && (p = (*hp)->varp) )
+               if(p->tag == TNAME)
+                       mkft(p);
+
+for(p = gonelist ; p ; p = p->nextp)
+       mkft(p->datap);
+
+for(p = hidlist ; p ; p = p->nextp)
+       if(p->datap->tag == TNAME)  mkft(p->datap);
+
+for(p = tempvarlist ; p ; p = p->nextp)
+       mkft(p->datap);
+
+TEST fprintf(diagfile, "Fortran names:\n");
+TEST for(i=1; i<=nftnames ; ++i)  fprintf(diagfile, "%s\n", ftnames[i]);
+}
+
+
+mkft(p)
+register ptr p;
+{
+int i;
+register char *s, *t;
+
+if(p->vnamedone)
+       return;
+
+if(p->vdcldone==0 && p!=procname)
+       {
+       if(p->vext && p->vtype==TYUNDEFINED)
+               p->vtype = TYSUBR;
+       else if(p->vextbase==0 && p->vadjdim==0 && p->vclass!=CLCOMMON)
+               warn1("%s never used", p->sthead->namep);
+       mkftnp(p);
+       }
+
+if(p->vextbase)
+       mkftname(p->vextbase, p->sthead->namep);
+
+for(i=0; i<NFTNTYPES ; ++i)
+       if(p->vbase[i] != 0)
+       if(p!=procname && p->vextbase!=0)
+               {
+               s = ftnames[p->vextbase];
+               t = ftnames[p->vbase[i]];
+               while(*t++ = *s++ )
+                       ;
+               }
+       else if(p->sthead)
+               mkftname(p->vbase[i], p->sthead->namep);
+       else
+               mkftname(p->vbase[i], CHNULL);
+p->vnamedone = 1;
+}
+
+
+
+
+
+mkftname(n,s)
+int n;
+char *s;
+{
+int i, j;
+register int k;
+char fn[7];
+register char *c1, *c2;
+
+if(ftnames[n][0] != '\0')  return;
+
+if(s==0 || *s=='\0')
+       s = "temp";
+else if(*s == '_')
+       ++s;
+k = strlen(s);
+
+for(i=0; i<k && i<(XL/2) ; ++i)
+       fn[i] = s[i];
+if(k > XL)
+       {
+       s += (k-XL);
+       k = XL;
+       }
+
+for( ; i<k ; ++i)
+       fn[i] = s[i];
+fn[i] = '\0';
+
+if( lookftn(fn) )
+       {
+       if(k < XL)
+               ++k;
+       fn[k] = '\0';
+       c1 = fn + k-1;
+       for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
+               if(lookftn(fn) == 0)
+                       goto nameok;
+
+       if(k < XL)
+               ++k;
+       fn[k] = '\0';
+       c1 = fn + k-2;
+       c2 = c1 + 1;
+
+       for(*c1 = '1' ; *c1 <= '9' ; *c1 += 1)
+               for(*c2 = '0' ; *c2 <= '9' ; *c2 += 1)
+                       if(lookftn(fn) == 0)
+                               goto nameok;
+       fatal1("mkftname: cannot generate fortran name for %s", s);
+       }
+
+nameok:
+for(j=0; j<=k ; ++j)
+       ftnames[n][j] = fn[j];
+}
+
+
+
+nxtftn()
+{
+if( ++nftnames < MAXFTNAMES)
+       {
+       ftnames[nftnames][0] = '\0';
+       return(nftnames);
+       }
+
+fatal("too many Fortran names generated");
+/* NOTREACHED */
+}
+
+
+
+lookftn(s)
+char *s;
+{
+register int i;
+
+for(i=1 ; i<=nftnames ; ++i)
+       if(equals(ftnames[i],s))  return(i);
+return(0);
+}
+
+
+
+ptr mkftnblock(type, name)
+int type;
+char *name;
+{
+register struct varblock *p;
+register int k;
+
+p = allexpblock();
+p->tag = TFTNBLOCK;
+p->vtype = type;
+p->vdcldone = 1;
+
+if( (k = lookftn(name)) == 0)
+       {
+       k = nxtftn();
+       strcpy(ftnames[k], name);
+       }
+p->vbase[ eflftn[type] ] = k;
+p->vextbase = k;
+return(p);
+}
diff --git a/usr/src/cmd/efl/pass2.c b/usr/src/cmd/efl/pass2.c

new file mode 100644 (file)

index 0000000..ba47506
--- /dev/null
+++ b/usr/src/cmd/efl/pass2.c
@@ -0,0 +1,412 @@
+#include "defs"
+#include <ctype.h>
+
+static int indent;
+
+char *verb[] = { " ", " ", "continue", "call ", "do ", "if ", "if ",
+       "goto ", "return", "read ", "write ", "format ", "stop ",
+       "data ", "equivalence ", "common ", "external ",
+       "rewind", "backspace", "endfile",
+       "subroutine ", "function ", "program", "blockdata", "end", CNULL };
+
+extern char *ops[];
+ptr getsii();
+
+/* generate code */
+
+pass2()
+{
+exnull();
+if(comments) putcomment();
+if(verbose)
+       fprintf(diagfile, "    Pass 2\n");
+
+dclsect = 0;
+indent = 0;
+
+namegen();
+dclgen();
+body(iefile);
+datas();
+body(icfile);
+
+p2stmt(0);
+p2key(FEND);
+p2flush();
+if(verbose)
+       fprintf(diagfile, "    Pass 2 done\n");
+}
+\f
+datas()
+{
+register int c, n;
+int n1;
+
+rewii(idfile);
+swii(idfile);
+
+for( ; ; )
+       {
+       c = getic(&n1);
+       n = n1;
+       switch(c)
+               {
+               case ICEOF:
+                       return;
+       
+               case ICMARK:
+                       break;
+       
+               case ICBLANK:
+                       putblank(n);
+                       break;
+       
+               case ICNAME:
+                       if(*ftnames[n] == '\0')
+                               fatal1("no name for n=%d", n);
+                       p2stmt(0);
+                       p2key(FDATA);
+                       p2str( ftnames[n] );
+                       break;
+       
+               case ICOP:
+                       p2str( ops[n] );
+                       break;
+       
+               case ICCONST:
+                       p2str( getsii(n) );
+                       break;
+       
+               default:
+                       fatal1("datas: invalid intermediate tag %d", c);
+               }
+       }
+}
+\f
+body(fileadd)
+struct fileblock **fileadd;
+{
+int n1;
+register int n;
+register int c;
+int prevc;
+int ifn;
+
+rewii(fileadd);
+swii(fileadd);
+
+prevc = 0;
+ifn = 0;
+
+for(;;)
+       {
+       c = getic(&n1);
+       n = n1;
+       switch(c)
+               {
+               case ICEOF:
+                       return;
+
+               case ICBEGIN:
+                       if(n != 0)
+                               {
+                               if(prevc)
+                                       p2key(FCONTINUE);
+                               else    prevc = 1;
+                               p2stmt( stnos[n] );
+                               }
+                       else if(!prevc)  p2stmt(0);
+                       break;
+
+               case ICKEYWORD:
+                       p2key(n);
+                       if(n != FIF2)
+                               break;
+                       getic(&ifn);
+                       if( indifs[ifn] )
+                               skipuntil(ICMARK) ;
+                       break;
+
+               case ICOP:
+                       p2str( ops[n] );
+                       break;
+
+               case ICNAME:
+                       if(*ftnames[n]=='\0')
+                               fatal1("no name for n=%d", n);
+                       p2str( ftnames[n] );
+                       break;
+
+               case ICCOMMENT:
+                       if(prevc)
+                               p2key(FCONTINUE);
+                       p2com(n);
+                       break;
+
+               case ICBLANK:
+                       putblank(n);
+                       break;
+
+               case ICCONST:
+                       p2str( getsii(n) );
+                       break;
+
+               case ICINDPTR:
+                       n = indifs[n];
+
+               case ICLABEL:
+                       p2str(" ");
+                       p2int( stnos[n] );
+                       break;
+
+               case ICMARK:
+                       if( indifs[ifn] )
+                               {
+                               p2str(" ");
+                               p2key(FGOTO);
+                               p2int( stnos[ indifs[ifn] ] );
+                               }
+                       else
+                               {
+                               skipuntil(ICINDENT);
+                               p2str(" ");
+                               }
+                       break;
+
+               case ICINDENT:
+                       indent = n * INDENTSPACES;
+                       p2indent(indent);
+                       break;
+
+               default:
+                       sprintf(msg, "Bad pass2 value %o,%o", c,n);
+                       fatal(msg);
+                       break;
+               }
+       if(c!=ICBEGIN && c!=ICINDENT)
+               prevc = 0;
+       }
+}
+\f
+putname(p)
+register ptr p;
+{
+register int i;
+
+if(p->vextbase)
+       {
+       putic(ICNAME, p->vextbase);
+       return;
+       }
+
+for(i=0 ; i<NFTNTYPES ; ++i)
+       if(p->vbase[i])
+               {
+               putic(ICNAME, p->vbase[i]);
+               return;
+               }
+if(strlen(p->sthead->namep) <= XL)
+       fatal1("no fortran slot for name %s", p->sthead->namep);
+}
+
+
+
+putconst(ty, p)
+int ty;
+char *p;
+{
+ptr mkchcon();
+
+if(ty != TYCHAR)
+       putsii(ICCONST,p);
+else   /* change character constant to a variable */
+       putname( mkchcon(p) );
+}
+
+
+putzcon(p)
+register ptr p;
+{
+char buff[100];
+sprintf(buff, "(%s,%s)", p->leftp, p->rightp);
+putsii(ICCONST,buff);
+}
+
+
+
+
+
+
+putcomment()
+{
+register ptr p;
+
+for(p = comments ; p ; p = p->nextp)
+       {
+       putsii(ICCOMMENT, p->datap);
+       cfree(p->datap);
+       }
+frchain(&comments);
+}
+
+
+putblank(n)
+int n;
+{
+while(n-- > 0)
+       p2putc(' ');
+}
+
+
+
+skipuntil(k)
+int k;
+{
+register int i;
+int n;
+
+while( (i = getic(&n))!=k && i!=ICEOF)
+       if(i==ICCOMMENT || i==ICCONST)
+               getsii(n);
+}
+\f
+
+p2int(n)       /* put an integer constant in the output */
+int n;
+{
+p2str( convic(n) );
+}
+
+
+
+
+p2key(n)       /* print a keyword */
+int n;
+{
+p2str( verb[n] );
+}
+
+
+
+p2str(s)       /* write a character string on the output */
+char *s;
+{
+int n;
+
+n = strlen(s);
+if(nftnch==LINESPACES-1 && (n==1 || (n==2 && s[1]==' ')) )
+       p2putc(s[0]);
+
+else   {
+       if( n<=LINESPACES && nftnch+n>LINESPACES-1 )
+               p2line( min(LINESPACES-n , indent+INDENTSPACES) );
+
+       while(*s)
+               p2putc(*s++);
+       }
+}
+
+
+
+p2stmt(n)      /* start a statement with label n */
+int n;
+{
+if(n > 0)
+       fprintf(codefile,"\n%4d  ", n);
+else   fprintf(codefile,"\n      ");
+
+nftnch = 0;
+nftncont = 0;
+}
+
+
+p2com(n)               /* copy a comment */
+int n;
+{
+register int k;
+register char *q;
+
+q = getsii(n);
+if(q[0] == '%')        /* a literal escape line */
+       {
+       putc('\n', codefile);
+       while(--n > 0)
+               putc(*++q, codefile);
+       }
+else    /* actually a comment line */
+       {
+       ++q;
+       --n;
+
+       do      {
+               k = (n>71 ? 71 : n);
+               fprintf(codefile, "\n");
+               putc( tailor.ftnsys==CRAY ? 'C' : 'c' , codefile);
+               while(k-- > 0)
+                       putc(*q++, codefile);
+               n -= 71;
+               }
+                  while(n > 0);
+       }
+}
+
+
+
+
+p2flush()
+{
+if(nftnch > 0)
+       {
+       fprintf(codefile, "\n");
+       nftnch = 0;
+       }
+}
+
+
+
+
+p2putc(c)
+char c;
+{
+if(nftnch >= LINESPACES)       /* end of line */
+       p2line(0);
+if(tailor.ftnsys == CRAY)
+       putc( islower(c) ? toupper(c) : c , codefile);
+else
+       putc(c, codefile);
+++nftnch;
+}
+
+
+
+p2line(in)
+int in;
+{
+register char contchar;
+
+if(++nftncont > 19)
+       {
+       execerr("too many continuation lines", CNULL);
+       contchar = 'X';
+       }
+if(tailor.ftncontnu == 1)
+       fprintf(codefile, "\n&");
+else   {       /* standard column-6 continuation */
+       if(nftncont < 20)
+               contchar = "0123456789ABCDEFGHIJ" [nftncont];
+       fprintf(codefile, "\n     %c", contchar);
+       }
+
+nftnch = 0;
+if(in > 0)
+       p2indent(in);
+}
+
+
+
+p2indent(n)
+register int n;
+{
+while(n-- > 0)
+       p2putc(' ');
+}
diff --git a/usr/src/cmd/efl/print.c b/usr/src/cmd/efl/print.c

new file mode 100644 (file)

index 0000000..fe82fc8
--- /dev/null
+++ b/usr/src/cmd/efl/print.c
@@ -0,0 +1,214 @@
+#include "defs"
+
+char *ops[ ] =         { "", "+", "-", "*", "/", "**",
+       ".not. ", " .and. ", ".andand.", ".oror.", " .or. ",
+       " .eq. ", " .lt. ", " .gt. ", " .le. ", " .ge. ", " .ne. ",
+       "(", ")", " = ", ", " };
+
+int opprecs[ ] = { 0, 7, 7, 8, 8, 9, 5, 4, 4, 3, 3,
+               6, 6, 6, 6, 6, 6, 10, 10, 1, 0 };
+
+char *qualops[ ]       = { "", "->", ".", " of ", " sub " };
+
+
+char *classes[ ]       = { "", "arg ", "valarg ", "static ", "auto ",
+                       "common ", "mos ", "external ", "statement function " };
+
+char *precs[ ] = { "", "long " };
+
+char *types[ ] = { "", "integer ", "real ", "double precision ", "logical ",
+                       "complex ", "char ", "type " };
+
+char *ftntypes[]       = { "integer ", "real ", "logical ", "complex ",
+                       "double precision ", 0, 0 };
+
+
+char *langs[]  = { "pfort", "ratfor", "efl"};
+
+
+propts()
+{
+fprintf(diagfile, "Options: ");
+fprintf(diagfile, "%s ", langs[langopt]);
+fprintf(diagfile, "%s ", (dbgopt ? "debug" : "ndebug") );
+fprintf(diagfile, "%s ", (dotsopt? "dotson" : "dotsoff") );
+fprintf(diagfile, "\n");
+}
+
+
+
+
+prexpr(e)
+ptr e;
+{
+if(e)  prexp1(e, 0,0,0);
+}
+
+
+
+\f
+
+prexp1(e, prec, subt, leftside)
+register ptr e;
+int prec, subt, leftside;
+{
+ptr p, q;
+int prec1, needpar;
+
+needpar = 0;
+
+switch(e->tag)
+       {
+case TERROR:
+       break;
+
+case TCONST:
+       TEST fprintf(diagfile, "%s", e->leftp);
+       if(e->rightp)
+               putzcon(e);
+       else
+               putconst(e->vtype, e->leftp);
+       break;
+
+case TFTNBLOCK:
+       putname(e);
+       break;
+
+case TNAME:
+       if(e->sthead == 0) fatal("name without entry");
+       TEST fprintf(diagfile, "%s", e->sthead->namep);
+       putname(e);
+       if(e->vsubs)
+               prexp1(e->vsubs, 0,0,0);
+       break;
+
+case TTEMP:
+       TEST fprintf(diagfile, "(fakename %o)", e);
+       putname(e);
+       break;
+
+case TLIST:
+       if(e->leftp == 0) break;
+       TEST fprintf(diagfile, "( ");
+       putic(ICOP, OPLPAR);
+       for(p=e->leftp ; p!=0 ; p = p->nextp)
+               {
+               prexp1(p->datap, 0,0,0);
+               if(p->nextp)
+                       {
+                       TEST fprintf(diagfile, " , ");
+                       putic(ICOP, OPCOMMA);
+                       }
+               }
+       TEST fprintf(diagfile, " )");
+       putic(ICOP, OPRPAR);
+       break;
+
+case TSTFUNCT:
+       fprintf(diagfile, "statement function ");
+       prexp1(e->leftp, 0,0,0);
+       TEST fprintf(diagfile, " = ");
+       putic(ICOP, OPEQUALS);
+       prexp1(e->rightp, 0,0,0);
+       break;
+
+case TAROP:
+       if(e->subtype==OPSTAR && e->leftp->tag!=TCONST && e->rightp->tag==TCONST)
+               {
+               q = e->leftp;
+               e->leftp = e->rightp;
+               e->rightp = q;
+               }
+case TLOGOP:
+       prec1 = opprecs[e->subtype];
+       goto print;
+case TNOTOP:
+       prec1 = 5;
+       if(prec > 1)    /* force parens */
+               needpar = 1;
+       goto print;
+case TNEGOP:
+       if(prec > 1)    /* force parens */
+               needpar = 1;
+       prec1 = 8;
+       goto print;
+case TASGNOP:
+       prec1 = 1;
+       goto print;
+case TRELOP:
+       prec1 = 6;
+       goto print;
+case TCALL:
+       prec1 = 10;
+       goto print;
+case TREPOP:
+       prec1 = 2;
+       goto print;
+
+print:
+       if(prec1 < prec )
+               needpar = 1;
+       else if(prec1 == prec)
+               if(e->needpar)
+                       needpar = 1;
+               else if(subt == e->subtype)
+                       needpar |= ! (e->tag==TLOGOP || leftside || subt==0
+                                       || subt==OPPLUS || subt==OPSTAR);
+               else    needpar |=  ! (leftside || subt==OPPLUS || subt==OPSTAR);
+
+       if(needpar)
+               {
+               putic(ICOP,OPLPAR);
+               TEST fprintf(diagfile, "(");
+               }
+
+       if(e->rightp != 0)
+               {
+               prexp1(e->leftp, prec1, e->subtype, 1);
+               switch(e->tag) {
+               case TASGNOP:
+                       TEST fprintf(diagfile, "=");
+                       putic(ICOP, OPEQUALS);
+                       if(e->subtype != 0)
+                               prexp1(e->leftp, prec1, 0, 1);
+       
+               case TAROP:
+               case TNEGOP:
+               case TLOGOP:
+               case TNOTOP:
+               case TRELOP:
+                       if(e->subtype)
+                               {
+                               TEST fprintf(diagfile, " %s ", ops[e->subtype]);
+                               putic(ICOP, e->subtype);
+                               }
+                       break;
+       
+               case TCALL:
+                       TEST fprintf(diagfile, " %s ", qualops[e->subtype]);
+                       break;
+       
+               case TREPOP:
+                       TEST fprintf(diagfile, "$");
+                       break;
+                       }
+
+               prexp1(e->rightp, prec1,e->subtype, 0);
+               }
+       else    { /* e->rightp == 0 */
+               TEST fprintf(diagfile, " %s  ", ops[e->subtype]);
+               putic(ICOP, e->subtype);
+               prexp1(e->leftp, prec1,e->subtype, 0);
+               }
+       if(needpar)
+               {
+               putic(ICOP, OPRPAR);
+               TEST fprintf(diagfile, ")");
+               }
+       break;
+
+default:
+       badtag("prexp1", e->tag);
+       break;
+       }
+}
diff --git a/usr/src/cmd/efl/simple.c b/usr/src/cmd/efl/simple.c

new file mode 100644 (file)

index 0000000..ba77a60
--- /dev/null
+++ b/usr/src/cmd/efl/simple.c
@@ -0,0 +1,690 @@
+#include <ctype.h>
+#include "defs"
+
+
+/* basic simplifying procedure */
+
+ptr simple(t,e)
+int t; /* take on the values LVAL, RVAL, and SUBVAL */
+register ptr e;        /* points to an expression */
+{
+int tag, subtype;
+ptr lp, rp;
+int ltag;
+int lsubt;
+ptr p, e1;
+ptr exio(), exioop(), dblop(), setfield(), gentemp();
+int a,b,c;
+
+top:
+
+if(e == 0) return(0);
+
+tag = e->tag;
+subtype = e->subtype;
+if(lp = e->leftp)
+       {
+       ltag = lp->tag;
+       lsubt = lp->subtype;
+       }
+rp = e->rightp;
+
+TEST fprintf(diagfile, "simple(%d; tag %d,%d)\n", t,tag,subtype);
+
+switch(tag){
+
+case TNOTOP:
+       switch(ltag) {
+
+       case TNOTOP:    /* not not = yes */
+               frexpblock(e);
+               e = lp->leftp;
+               frexpblock(lp);
+               goto top;
+
+       case TLOGOP:    /* de Morgan's Law */
+               lp->subtype = (OPOR+OPAND) - lp->subtype;
+               lp->leftp = mknode(TNOTOP,OPNOT,lp->leftp, PNULL);
+               lp->rightp=mknode(TNOTOP,OPNOT,lp->rightp, PNULL);
+               frexpblock(e);
+               e = lp;
+               goto top;
+
+       case TRELOP:    /* reverse the condition */
+               lp->subtype = (OPEQ+OPNE) - lp->subtype;
+               frexpblock(e);
+               e = lp;
+               goto top;
+
+       case TCALL:
+       case TASGNOP:
+               e->leftp = simple(RVAL,lp);
+
+       case TNAME:
+       case TFTNBLOCK:
+               lp = simple(RVAL,lp);
+
+       case TTEMP:
+               if(t == LVAL)
+                       e = simple(LVAL,
+                             mknode(TASGNOP,0, gentemp(e->leftp), e));
+               break;
+
+       case TCONST:
+               if(equals(lp->leftp, ".false."))
+                       e->leftp = copys(".true.");
+               else if(equals(lp->leftp, ".true."))
+                       e->leftp = copys(".false.");
+               else goto typerr;
+
+               e->tag = TCONST;
+               e->subtype = 0;
+               cfree(lp->leftp);
+               frexpblock(lp);
+               break;
+
+       default:  goto typerr;
+               }
+       break;
+
+
+
+
+case TLOGOP: switch(subtype) {
+               case OPOR:
+               case OPAND:
+                       goto binop;
+
+               case OP2OR:
+               case OP2AND:
+                       lp = e->leftp = simple(RVAL, lp);
+                       if(lp->tag != TTEMP)
+                               lp = simple(RVAL,
+                                       mknode(TASGNOP,0, gent(TYLOG,0),lp));
+                       return( simple(LVAL, mknode(TASGNOP,subtype,lp,rp)) );
+               default:
+                       fatal("impossible logical operator");
+               }
+
+case TNEGOP:
+       lp = e->leftp = simple(RVAL,lp);
+       ltag = lp->tag;
+       lsubt = lp->subtype;
+
+       if(ltag==TNEGOP)
+               {
+               frexpblock(e);
+               e = lp->leftp;
+               frexpblock(lp);
+               goto top;
+               }
+       else    goto lvcheck;
+
+case TAROP:
+case TRELOP:
+
+binop:
+
+       e->leftp = simple(RVAL,lp);
+       lp = e->leftp;
+       ltag = lp->tag;
+       lsubt = lp->subtype;
+
+       e->rightp= simple(RVAL,rp);
+       rp = e->rightp;
+
+       if(tag==TAROP && isicon(rp,&b) )
+               {  /* simplify a*1, a/1 , a+0, a-0  */
+               if( ((subtype==OPSTAR||subtype==OPSLASH) && b==1) ||
+                   ((subtype==OPPLUS||subtype==OPMINUS) && b==0) )
+                       {
+                       frexpr(rp);
+                       mvexpr(lp,e);
+                       goto top;
+                       }
+
+               if(isicon(lp, &a))       /* try folding const op const */
+                       {
+                       e1 = fold(e);
+                       if(e1!=e || e1->tag!=TAROP)
+                               {
+                               e = e1;
+                               goto top;
+                               }
+                       }
+               if(ltag==TAROP && lp->needpar==0 && isicon(lp->rightp,&a) )
+                       { /* look for cases of (e op const ) op' const */
+
+                       if( (subtype==OPPLUS||subtype==OPMINUS) &&
+                           (lsubt==OPPLUS||lsubt==OPMINUS) )
+                               { /*  (e +- const) +- const */
+                               c = (subtype==OPPLUS ? 1 : -1) * b +
+                                   (lsubt==OPPLUS? 1 : -1) * a;
+                               if(c > 0)
+                                       subtype = OPPLUS;
+                               else    {
+                                       subtype = OPMINUS;
+                                       c = -c;
+                                       }
+                       fixexpr:
+                               frexpr(rp);
+                               frexpr(lp->rightp);
+                               frexpblock(e);
+                               e = lp;
+                               e->subtype = subtype;
+                               e->rightp = mkint(c);
+                               goto top;
+                               }
+
+                       else if(lsubt==OPSTAR &&
+                               ( (subtype==OPSTAR) ||
+                                   (subtype==OPSLASH && a%b==0)) )
+                                       { /* (e * const ) (* or /) const */
+                                       c = (subtype==OPSTAR ? a*b : a/b );
+                                       subtype = OPSTAR;
+                                       goto fixexpr;
+                                       }
+                       }
+               if(ltag==TAROP && (lsubt==OPPLUS || lsubt==OPMINUS) &&
+                       subtype==OPSLASH && divides(lp,conval(rp)) )
+                       {
+                       e->leftp = mknode(TAROP,OPSLASH,lp->leftp, cpexpr(rp));
+                       e->rightp = mknode(TAROP,OPSLASH,lp->rightp, rp);
+                       e->subtype = lsubt;
+                       goto top;
+                       }
+               }
+
+       else if( tag==TRELOP && isicon(lp,&a) && isicon(rp,&b) )
+               {
+               e1 = fold(e);
+               if(e1!=e || e1->tag!=TRELOP)
+                       {
+                       e = e1;
+                       goto top;
+                       }
+               }
+
+lvcheck:
+       if(t == LVAL)
+               e = simple(LVAL, mknode(TASGNOP,0, gentemp(e),e));
+       else if(t == SUBVAL)
+               {  /* test for legal Fortran c*v +-c  form */
+               if(tag==TAROP && (subtype==OPPLUS || subtype==OPMINUS))
+                       if(rp->tag==TCONST && rp->vtype==TYINT)
+                               {
+                               if(!cvform(lp))
+                                       e->leftp = simple(SUBVAL, lp);
+                               }
+                       else goto makesub;
+               else if( !cvform(e) ) goto makesub;
+               }
+       break;
+
+case TCALL:
+       if( lp->tag!=TFTNBLOCK && ioop(lp->sthead->namep) )
+               {
+               e = exioop(e, YES);
+               exlab(0);
+               break;
+               }
+       e->rightp = simple(RVAL, rp);
+       if(t == SUBVAL)
+               goto makesub;
+       if(t == LVAL)
+               e = simple(RVAL, mknode(TASGNOP,0, gentemp(e),e));
+       break;
+
+
+case TNAME:
+       if(e->voffset)
+               fixsubs(e);
+       if(e->vsubs)
+               e->vsubs = simple(SUBVAL, e->vsubs);
+       if(t==SUBVAL && !vform(e))
+               goto makesub;
+
+case TTEMP:
+case TFTNBLOCK:
+case TCONST:
+       if(t==SUBVAL && e->vtype!=TYINT)
+               goto makesub;
+       break;
+
+case TASGNOP:
+       lp = e->leftp = simple(LVAL,lp);
+       if(subtype==OP2OR || subtype==OP2AND)
+               e = dblop(e);
+
+       else    {
+               rp = e->rightp = simple(RVAL,rp);
+               if(e->vtype == TYCHAR)
+                       excall(mkcall(mkftnblock(TYSUBR,"ef1asc"), arg4(cpexpr(lp),rp)));
+               else if(e->vtype == TYSTRUCT)
+                       {
+                       if(lp->vtypep->strsize != rp->vtypep->strsize)
+                               fatal("simple: attempt to assign incompatible structures");
+                       e1 = mkchain(cpexpr(lp),mkchain(rp,
+                               mkchain(mkint(lp->vtypep->strsize),CHNULL)));
+                       excall(mkcall(mkftnblock(TYSUBR,"ef1ass"),
+                               mknode(TLIST, 0, e1, PNULL) ));
+                       }
+               else if(lp->vtype == TYFIELD)
+                       lp = setfield(e);
+               else    {
+                       if(subtype != OPASGN)   /* but is one of += etc */
+                               {
+                               rp = e->rightp = simple(RVAL, mknode(
+                                       (subtype<=OPPOWER?TAROP:TLOGOP),subtype,
+                                       cpexpr(e->leftp),e->rightp));
+                               e->subtype = OPASGN;
+                               }
+                       exlab(0);
+                       prexpr(e);
+                       frexpr(rp);
+                       }
+               frexpblock(e);
+               e = lp;
+               if(t == SUBVAL) goto top;
+               }
+
+       break;
+
+case TLIST:
+       for(p=lp ; p ; p = p->nextp)
+               p->datap = simple(t, p->datap);
+       break;
+
+case TIOSTAT:
+       e = exio(e, 1);
+       break;
+
+default:
+       break;
+       }
+
+return(e);
+
+
+typerr:
+       exprerr("type match error", CNULL);
+       return(e);
+
+makesub:
+       if(t==SUBVAL && e->vtype!=TYINT)
+               warn1("Line %d. Non-integer subscript", yylineno);
+       return( simple(RVAL, mknode(TASGNOP,0,gent(TYINT,PNULL),e)) );
+}
+\f
+ptr fold(e)
+register ptr e;
+{
+int a, b, c;
+register ptr lp, rp;
+
+lp = e->leftp;
+rp = e->rightp;
+
+if(lp->tag!=TCONST && lp->tag!=TNEGOP)
+       return(e);
+
+if(rp->tag!=TCONST && rp->tag!=TNEGOP)
+       return(e);
+
+
+switch(e->tag)
+       {
+       case TAROP:
+               if( !isicon(lp,&a) || !isicon(rp,&b) )
+                       return(e);
+
+               switch(e->subtype)
+                       {
+                       case OPPLUS:
+                               c = a + b;break;
+                       case OPMINUS:
+                               c = a - b; break;
+                       case OPSTAR:
+                               c = a * b; break;
+                       case OPSLASH:
+                               if(a%b!=0 && (a<0 || b<0) )
+                                       return(e);
+                               c = a / b; break;
+                       case OPPOWER:
+                               return(e);
+                       default:
+                               fatal("fold: illegal binary operator");
+                       }
+               frexpr(e);
+
+               if(c >= 0)
+                       return( mkint(c) );
+               else    return(mknode(TNEGOP,OPMINUS, mkint(-c), PNULL) );
+
+       case TRELOP:
+               if( !isicon(lp,&a) || !isicon(rp,&b) )
+                       return(e);
+               frexpr(e);
+
+               switch(e->subtype)
+                       {
+                       case OPEQ:
+                               c =  a == b; break;
+                       case OPLT:
+                               c = a < b ; break;
+                       case OPGT:
+                               c = a > b; break;
+                       case OPLE:
+                               c = a <= b; break;
+                       case OPGE:
+                               c = a >= b; break;
+                       case OPNE:
+                               c = a != b; break;
+                       default:
+                               fatal("fold: invalid relational operator");
+                       }
+               return( mkconst(TYLOG, (c ? ".true." : ".false.")) );
+
+
+       case TLOGOP:
+               if(lp->vtype!=TYLOG || rp->vtype!=TYLOG)
+                       return(e);
+               a = equals(lp->leftp, ".true.");
+               b = equals(rp->leftp, ".true.");
+               frexpr(e);
+
+               switch(e->subtype)
+                       {
+                       case OPAND:
+                       case OP2AND:
+                               c = a & b; break;
+                       case OPOR:
+                       case OP2OR:
+                               c = a | b; break;
+                       default:
+                               fatal("fold: invalid logical operator");
+                       }
+               return( mkconst(TYLOG, (c? ".true." : ".false")) );
+
+       default:
+               return(e);
+       }
+}
+\f
+#define TO   + 100*
+
+
+ptr coerce(t,e)        /* coerce expression  e  to type  t */
+int t;
+register ptr e;
+{
+register int et;
+int econst;
+char buff[100];
+char *s, *s1;
+ptr conrep(), xfixf();
+
+if(e->tag == TNEGOP)
+       {
+       e->leftp = coerce(t, e->leftp);
+       goto settype;
+       }
+
+et = e->vtype;
+econst = (e->tag == TCONST);
+TEST fprintf(diagfile, "coerce type %d to type %d\n", et, t);
+if(t == et)
+       return(e);
+
+switch( et TO t )
+       {
+       case TYCOMPLEX TO TYINT:
+       case TYLREAL TO TYINT:
+               e = coerce(TYREAL,e);
+       case TYREAL TO TYINT:
+               if(econst)
+                       e = xfixf(e);
+               if(e->vtype != TYINT)
+                       e = mkcall(builtin(TYINT,"ifix"), arg1(e));
+               break;
+
+       case TYINT TO TYREAL:
+               if(econst)
+                       {
+                       e->leftp = conrep(e->leftp, ".");
+                       goto settype;
+                       }
+               e = mkcall(builtin(TYREAL,"float"), arg1(e));
+               break;
+
+       case TYLREAL TO TYREAL:
+               if(econst)
+                       {
+                       for(s=e->leftp ; *s && *s!='d';++s)
+                               ;
+                       *s = 'e';
+                       goto settype;
+                       }
+               e = mkcall(builtin(TYREAL,"sngl"), arg1(e));
+               break;
+
+       case TYCOMPLEX TO TYREAL:
+               if(econst)
+                       {
+                       s1 = (char *)(e->leftp) + 1;
+                       s = buff;
+                       while(*s1!=',' && *s1!='\0')
+                               *s1++ = *s++;
+                       *s = '\0';
+                       cfree(e->leftp);
+                       e->leftp = copys(buff);
+                       goto settype;
+                       }
+               else
+                       e = mkcall(mkftnblock(TYREAL,"real"), arg1(e));
+               break;
+
+       case TYINT TO TYLREAL:
+               if(econst)
+                       {
+                       e->leftp = conrep(e->leftp,"d0");
+                       goto settype;
+                       }
+       case TYCOMPLEX TO TYLREAL:
+               e = coerce(TYREAL,e);
+       case TYREAL TO TYLREAL:
+               if(econst)
+                       {
+                       for(s=e->leftp ; *s && *s!='e'; ++s)
+                               ;
+                       if(*s == 'e')
+                               *s = 'd';
+                       else    e->leftp = conrep(e->leftp,"d0");
+                       goto settype;
+                       }
+               e = mkcall(builtin(TYLREAL,"dble"), arg1(e));
+               break;
+
+       case TYINT TO TYCOMPLEX:
+       case TYLREAL TO TYCOMPLEX:
+               e = coerce(TYREAL, e);
+       case TYREAL TO TYCOMPLEX:
+               if(e->tag == TCONST)
+                       {
+                       sprintf(buff, "(%s,0.)", e->leftp);
+                       cfree(e->leftp);
+                       e->leftp = copys(buff);
+                       goto settype;
+                       }
+               else
+                       e = mkcall(builtin(TYCOMPLEX,"cmplx"),
+                               arg2(e, mkconst(TYREAL,"0.")));
+               break;
+
+
+       default:
+               goto mismatch;
+       }
+
+return(e);
+
+
+mismatch:
+       exprerr("impossible conversion", "");
+       frexpr(e);
+       return( errnode() );
+
+
+settype:
+       e->vtype = t;
+       return(e);
+}
+
+
+
+/* check whether expression is in form c, v, or v*c */
+cvform(p)
+register ptr p;
+{
+switch(p->tag)
+       {
+       case TCONST:
+               return(p->vtype == TYINT);
+
+       case TNAME:
+               return(vform(p));
+
+       case TAROP:
+               if(p->subtype==OPSTAR && p->rightp->tag==TCONST
+                   && p->rightp->vtype==TYINT && vform(p->leftp))
+                       return(1);
+
+       default:
+               return(0);
+       }
+}
+
+
+
+
+/* is p a simple integer variable */
+vform(p)
+register ptr p;
+{
+return( p->tag==TNAME && p->vtype==TYINT && p->vdim==0
+     && p->voffset==0 && p->vsubs==0) ;
+}
+
+
+
+ptr dblop(p)
+ptr p;
+{
+ptr q;
+
+bgnexec();
+if(p->subtype == OP2OR)
+       q = mknode(TNOTOP,OPNOT, cpexpr(p->leftp), PNULL);
+else   q = cpexpr(p->leftp);
+
+pushctl(STIF, q);
+bgnexec();
+exasgn(cpexpr(p->leftp), OPASGN,  p->rightp);
+ifthen();
+popctl();
+addexec();
+return(p->leftp);
+}
+
+
+
+
+divides(a,b)
+ptr a;
+int b;
+{
+if(a->vtype!=TYINT)
+       return(0);
+
+switch(a->tag)
+       {
+       case TNEGOP:
+               return( divides(a->leftp,b) );
+
+       case TCONST:
+               return( conval(a) % b == 0);
+
+       case TAROP:
+               switch(a->subtype)
+                       {
+                       case OPPLUS:
+                       case OPMINUS:
+                               return(divides(a->leftp,b)&&
+                                          divides(a->rightp,b) );
+
+                       case OPSTAR:
+                               return(divides(a->rightp,b));
+
+                       default:
+                               return(0);
+                       }
+       default:
+               return(0);
+       }
+/* NOTREACHED */
+}
+\f
+/* truncate floating point constant to integer */
+
+#define MAXD 100
+
+ptr xfixf(e)
+struct exprblock *e;
+{
+char digit[MAXD+1];    /* buffer into which digits are placed */
+char *first;   /* points to first nonzero digit */
+register char *end;    /* points at position past last digit */
+register char *dot;    /* decimal point is immediately to left of this digit */
+register char *s;
+int expon;
+
+dot = NULL;
+end = digit;
+expon = 0;
+
+for(s = e->leftp ; *s; ++s)
+       if( isdigit(*s) )
+               {
+               if(end-digit > MAXD)
+                       return(e);
+               *end++ = *s;
+               }
+       else if(*s == '.')
+               dot = end;
+       else if(*s=='d' || *s=='e')
+               {
+               expon = convci(s+1);
+               break;
+               }
+       else fatal1("impossible character %d in floating constant", *s);
+
+if(dot == NULL)
+       dot = end;
+dot += expon;
+if(dot-digit > MAXD)
+       return(e);
+for(first = digit; first<end && *first=='0' ; ++first)
+       ;
+if(dot<=first)
+       {
+       dot = first+1;
+       *first = '0';
+       }
+else   while(end < dot)
+               *end++ = '0';
+*dot = '\0';
+cfree(e->leftp);
+e->leftp = copys(first);
+e->vtype = TYINT;
+return(e);
+}
diff --git a/usr/src/cmd/efl/struct.c b/usr/src/cmd/efl/struct.c

new file mode 100644 (file)

index 0000000..6c31340
--- /dev/null
+++ b/usr/src/cmd/efl/struct.c
@@ -0,0 +1,217 @@
+#include "defs"
+
+offsets(s)
+register ptr s;
+{
+register ptr p, q;
+ptr t;
+ptr prevp;
+int n;
+int size, align, mask, nelt;
+double rshift;
+
+s->stralign = 1;
+s->strsize = 0;
+s->basetypes = 0;
+prevp = 0;
+rshift = 0;
+
+for(p = s->strdesc ; p ; p = p->nextp)
+       {
+       q = p->datap;
+       if(q->vclass != 0)
+               dclerr("attempt to give storage class to mos",
+                       q->namep);
+       else  q->vclass = CLMOS;
+       if(q->vtype == TYUNDEFINED)
+               impldecl(q);
+
+       sizalign(q, &size, &align, &mask);
+       s->strsize = evenoff(s->strsize, align);
+       q->voffset = mkint(s->strsize);
+       /* sloppy formula */
+       nelt = 1;
+       if(t = q->vdim)
+           for(t = t->datap ; t ; t = t->nextp)
+               {
+               if(t->upperb == 0) continue;
+               n = conval(t->upperb);
+               if(t->lowerb)
+                       n -= conval(t->lowerb)-1;
+               nelt *= n;
+               }
+       if(q->vtype==TYFIELD && q->vdim==0 &&
+            (n=conval(q->vtypep->frange))*rshift<=fieldmax && rshift>0)
+               {
+               prevp->vtypep->fanymore = 1;
+               q->vtypep->frshift = mkint( (int) rshift );
+               rshift *= n;
+               cfree(q->voffset);
+               q->voffset = mkint(s->strsize - tailor.ftnsize[FTNINT]);
+               }
+       else    {
+               if(q->vdim!=0 && q->vtype==TYFIELD)
+                       q->vtype = TYINT;
+               rshift = (q->vtype==TYFIELD ? n : 0);
+               s->strsize +=  nelt * evenoff(size,align);
+               s->stralign = lcm(s->stralign, align);
+               s->basetypes |= mask;
+               }
+       prevp = q;
+       }
+}
+
+
+lcm(a,b)
+int a,b;
+{
+int ab, c;
+
+if( (ab = a*b) == 0) return(0);
+
+while(b)
+       {
+       c = a%b;
+       a = b;
+       b = c;
+       }
+
+return(ab/a);
+}
+
+
+
+
+
+sizalign(p, s, a, m)
+register ptr p;
+int *s;
+int *a;
+int *m;
+{
+register int k, t;
+
+if(p->tag == TERROR)
+       return;
+if(p->tag!=TNAME && p->tag!=TTEMP && p->tag!=TFTNBLOCK)
+       badtag("sizalign", p->tag);
+switch(t = p->vtype)
+       {
+       case TYFIELD:
+       case TYINT:
+       case TYREAL:
+       case TYLREAL:
+       case TYCOMPLEX:
+       case TYLOG:
+               k = eflftn[t];
+               *s = tailor.ftnsize[k];
+               *a = tailor.ftnalign[k];
+               *m = ftnmask[k];
+               return;
+
+       case TYLCOMPLEX:
+               if(tailor.lngcxtype)
+                       {
+                       k = FTNDCOMPLEX;
+                       *s = tailor.ftnsize[FTNDCOMPLEX];
+                       }
+               else
+                       {
+                       k = FTNDOUBLE;
+                       *s = 2*tailor.ftnsize[k];
+                       }
+               *a = tailor.ftnalign[k];
+               *m = ftnmask[k];
+               return;
+
+       case TYSTRUCT:
+               *s = p->vtypep->strsize;
+               *a = p->vtypep->stralign;
+               *m = p->vtypep->basetypes;
+               return;
+
+       case TYCHAR:
+               *s = tailor.ftnsize[FTNINT] *
+                       ceil(conval(p->vtypep), tailor.ftnchwd);
+               *a = tailor.ftnalign[FTNINT];
+               *m = ftnmask[FTNINT];
+               return;
+
+       case TYSUBR:
+               *s = 1;
+               *a = 1;
+               *m = 1;
+               dclerr("subroutine name as variable", p->sthead->namep);
+               return;
+
+       default:
+               fatal1("sizalign: invalid type %d", t);
+       }
+}
+
+
+
+evenoff(a,b)   /* round a up to a multiple of b */
+int a,b;
+{
+return(b * ceil(a,b));
+}
+
+
+ceil(a,b)
+int a,b;
+{
+return( (a+b-1)/b );
+}
+
+
+
+
+ptr esizeof(type, typep, dim)
+register int type;
+register ptr typep;
+ptr dim;
+{
+register int k;
+
+switch(type)
+       {
+       case TYFIELD:
+       case TYINT:
+       case TYREAL:
+       case TYLREAL:
+       case TYCOMPLEX:
+       case TYLCOMPLEX:
+       case TYLOG:
+               k = tailor.ftnsize[ eflftn[type] ];
+               break;
+
+       case TYSTRUCT:
+               k = typep->strsize;
+               break;
+
+       case TYCHAR:
+               k = tailor.ftnsize[FTNINT] * ceil(conval(typep), tailor.ftnchwd);
+               break;
+
+       default:
+               exprerr("invalid sizeof", "");
+               k = 0;
+       }
+/* debug version.  should multiply by dimension */
+return( mkint(k) );
+}
+
+
+
+ptr elenof(type, typep, dim)
+register int type;
+register ptr typep;
+ptr dim;
+{
+if(type == TYCHAR)
+       return( mkint( conval(typep) ) );
+exprerr("invalid lengthof", "");
+return( mkint(0) );
+/* debug version.  should multiply by dimension */
+}
diff --git a/usr/src/cmd/efl/symtab.c b/usr/src/cmd/efl/symtab.c

new file mode 100644 (file)

index 0000000..666cd00
--- /dev/null
+++ b/usr/src/cmd/efl/symtab.c
@@ -0,0 +1,189 @@
+#include "defs"
+
+#ifdef HASHEDTABLE
+/* Basic symbol table maintainer.  Action depends on t:
+t = -1 Remove name from table
+t =  0 Put name in table if not there.  Copy name string
+t =  1 Find name in table if there, otherwise return 0.
+t =  2 Put name in table if not there.  Do not copy name
+*/
+
+struct stentry *hashtab[MAXEFLNAMES+1];
+struct stentry **hashend       = hashtab+MAXEFLNAMES+1;
+
+#define NEXT(x) (++x<hashend ? x : hashtab )
+
+struct stentry *name(s,t)
+char *s;
+int t;
+{
+int hash;
+register struct stentry *p, **hp;
+char *copys();
+
+hash = hashfunct(s);
+
+for(hp = hashtab + hash; (p = *hp) ; hp = NEXT(hp) )
+       if(hash==p->hashval && equals(s,p->namep))
+               switch(t)
+               {
+               case -1:
+                       cfree(p->namep);
+                       cfree(p);
+                       delhash(hp);
+                       --neflnames;
+                       return(0);
+
+               case 0:
+               case 1:
+               case 2:
+                       return(p);
+
+               default:
+                       fatal("name: illegal argument");
+               }
+
+/* not in table */
+switch(t)
+       {
+       case -1:
+               fatal1("cannot delete nonexistent name %s from symbol table", s);
+
+       case 1:
+               return(0);
+
+       case 0:
+       case 2:
+               if(++neflnames >= MAXEFLNAMES)
+                       fatal("hash table full");
+
+               *hp = p = ALLOC(stentry);
+               p->namep = (t==0 ? copys(s) : s);
+               p->hashval = hash;
+               return(p);
+
+       default:
+               fatal("illegal call to name");
+       }
+}
+
+
+
+hashfunct(s)
+register char *s;
+{
+register int h;
+
+h = 0;
+while(*s)
+       h += *s++;
+
+return( h % (MAXEFLNAMES+1) );
+}
+
+
+delhash(hp)
+struct stentry **hp;
+{
+struct stentry **hq, **hvp;
+
+for ( ; ; )
+       {
+       *hp = 0;
+       hq = hp;
+       for(hp = NEXT(hp) ; *hp &&
+               ( (hq < (hvp = hashtab + (*hp)->hashval) && hvp<=hp)
+               || (hp<hq && hq<hvp) || (hvp<=hp && hp<hq) ) ;
+               hp = NEXT(hp) )
+                       ;
+       if(*hp == 0)
+               return;
+       *hq = *hp;
+       }
+}
+#endif
+\f
+#ifndef HASHEDTABLE
+/* Basic symbol table maintainer.  Action depends on t:
+t = -1 Remove name from table
+t =  0 Put name in table if not there.  Copy name string
+t =  1 Find name in table if there, otherwise return 0.
+t =  2 Put name in table if not there.  Do not copy name
+*/
+
+struct stentry *hashtab[MAXEFLNAMES];
+struct stentry **hashend hashtab;
+
+name(s,t)
+char *s;
+int t;
+{
+int hash;
+register struct stentry *p, **hp;
+char *copys();
+
+hash = hashfunct(s);
+
+for(hp = hashtab ; hp<hashend ; ++hp)
+       if( (p = *hp) && hash==p->hashval &&  equals(s,p->namep))
+               switch(t)
+               {
+               case -1:
+                       cfree(p->namep);
+                       cfree(p);
+                       *hp = 0;
+                       return(0);
+
+               case 0:
+               case 1:
+               case 2:
+                       return(p);
+
+               default:
+                       fatal("name: illegal argument");
+               }
+
+/* not in table */
+switch(t)
+       {
+       case -1:
+               fatal1("cannot delete nonexistent name %s from symbol table", s);
+
+       case 1:
+               return(0);
+
+       case 0:
+       case 2:
+               /* look for an empty slot */
+               for(hp = hashtab ; hp<hashend && *hp!=0 ; ++hp)
+                       ;
+
+               if(hp == hashend)
+                       if(++neflnames >= MAXEFLNAMES)
+                               fatal("hash table full");
+                       else ++hashend;
+
+               *hp = p = ALLOC(stentry);
+               p->namep = (t==0 ? copys(s) : s);
+               p->hashval = hash;
+               return(p);
+
+       default:
+               fatal("illegal call to name");
+       }
+}
+
+
+
+hashfunct(s)
+register char *s;
+{
+register int h;
+
+h = 0;
+while(*s)
+       h = *s++;
+
+return(h);
+}
+#endif
diff --git a/usr/src/cmd/efl/tailor.c b/usr/src/cmd/efl/tailor.c

new file mode 100644 (file)

index 0000000..a6a7f4f
--- /dev/null
+++ b/usr/src/cmd/efl/tailor.c
@@ -0,0 +1,196 @@
+#include "defs"
+
+
+setopt(p,q)
+char *p;
+char *q;
+{
+int qval;
+qval = (q!=NULL) && ( equals(q, "yes") || equals(q, "on") );
+
+if(equals(p,"debug")) dbgopt = 1;
+else if(equals(p,"ndebug")) dbgopt = 0;
+else if(equals(p,"pfort")) langopt = 0;
+else if(equals(p,"ratfor")) langopt = 1;
+else if(equals(p,"efl")) langopt = 2;
+else if(equals(p,"dots"))
+       dotsopt = qval;
+else if(equals(p,"ioerror"))
+       {
+       if(equals(q,"none"))
+               tailor.errmode = IOERRNONE;
+       else if(equals(q,"ibm"))
+               tailor.errmode = IOERRIBM;
+       else if(equals(q,"fortran77"))
+               tailor.errmode = IOERRFORT77;
+       else execerr("unknown ioerror option %s", q);
+       }
+else if(equals(p, "system"))
+       {
+       register struct system *sysp;
+       for(sysp = systab ; sysp->sysname ; ++sysp)
+               if( equals(q, sysp->sysname) )
+                       break;
+
+       if(sysp->sysname)
+               tailinit(sysp);
+       else
+               execerr("unknown system %s", q);
+       }
+else if(equals(p, "continue"))
+               tailor.ftncontnu = equals(q, "column1");
+else if(equals(p, "procheader"))
+       tailor.procheader = (q ? copys(q) : 0);
+else if(equals(p, "hollincall"))
+       tailor.hollincall = qval;
+else if(equals(p, "longcomplextype"))
+       {
+       tailor.lngcxtype = (q ? copys(q) : CNULL);
+       if(qval)
+               eflftn[TYLCOMPLEX] = FTNDCOMPLEX;
+       }
+else if(equals(p, "longcomplexprefix"))
+       tailor.lngcxprefix = (q ? copys(q) : CNULL);
+else if(equals(p, "fortran77"))
+       {
+       if(tailor.ftn77 = (q==NULL || qval) )
+               tailor.errmode = IOERRFORT77;
+       else if(tailor.errmode == IOERRFORT77)
+               tailor.errmode = IOERRNONE;
+       }
+
+else if( !tailop(p,q) )
+       execerr("unknown option %s", p);
+
+if(langopt==2)
+       setdot(dotsopt);
+else if(langopt==1)
+       setdot(1);
+}
+
+
+
+
+tailinit(sysp)
+register struct system *sysp;
+{
+register int sysf = sysp->sysno;
+tailor.ftncontnu = (sysf==UNIX);
+tailor.ftnsys = sysf;
+tailor.ftnin = 5;
+tailor.ftnout = 6;
+tailor.errmode = (sysf==UNIX ? IOERRFORT77 : IOERRIBM);
+tailor.charcomp = 2;
+tailor.hollincall = YES;
+tailor.deltastno = 1;
+tailor.dclintrinsics = YES;
+
+tailsize(sysp->chperwd);
+tailfmt(sysp->idig, sysp->rdig, sysp->ddig);
+}
+
+
+
+
+
+tailsize(wordsize)
+int wordsize;
+{
+int i;
+
+tailor.ftnchwd = wordsize;
+tailor.ftnsize[FTNINT] = wordsize;
+tailor.ftnsize[FTNREAL] = wordsize;
+tailor.ftnsize[FTNLOG] = wordsize;
+tailor.ftnsize[FTNCOMPLEX] = 2*wordsize;
+tailor.ftnsize[FTNDOUBLE] = 2*wordsize;
+tailor.ftnsize[FTNDCOMPLEX] = 2*wordsize;
+
+for(i = 0 ; i<NFTNTYPES ; ++i)
+       tailor.ftnalign[i] = tailor.ftnsize[i];
+}
+
+
+
+
+tailfmt(idig, rdig, ddig)
+int idig, rdig, ddig;
+{
+sprintf(msg, "i%d", idig);
+tailor.dfltfmt[TYINT] = copys(msg);
+
+sprintf(msg, "e%d.%d", rdig+8, rdig);
+tailor.dfltfmt[TYREAL] = copys(msg);
+
+sprintf(msg, "d%d.%d", ddig+8, ddig);
+tailor.dfltfmt[TYLREAL] = copys(msg);
+
+sprintf(msg, "1h(,1p%s,2h, ,%s,1h)",
+       tailor.dfltfmt[TYREAL], tailor.dfltfmt[TYREAL]);
+tailor.dfltfmt[TYCOMPLEX] = copys(msg);
+
+sprintf(msg, "1h(,1p%s,2h, ,%s,1h)",
+       tailor.dfltfmt[TYLREAL], tailor.dfltfmt[TYLREAL]);
+tailor.dfltfmt[TYLCOMPLEX] = copys(msg);
+
+tailor.dfltfmt[TYLOG] = "l2";
+}
+
+
+
+
+tailop(n,v)
+char *n, *v;
+{
+int val;
+struct itable { char *optn; int *ioptloc; } *ip;
+struct ctable { char *optn; char **coptloc; } *cp;
+static struct ctable formats[ ] =  {
+       "iformat",      &tailor.dfltfmt[TYINT],
+       "rformat",      &tailor.dfltfmt[TYREAL],
+       "dformat",      &tailor.dfltfmt[TYLREAL],
+       "zformat",      &tailor.dfltfmt[TYCOMPLEX],
+       "zdformat",     &tailor.dfltfmt[TYLCOMPLEX],
+       "lformat",      &tailor.dfltfmt[TYLOG],
+       0, 0  };
+
+static struct itable ints[ ] = {
+       "ftnin",        &tailor.ftnin,
+       "ftnout",       &tailor.ftnout,
+       "charperint",  &tailor.ftnchwd,
+       "charcomp",     &tailor.charcomp,
+       "deltastno",    &tailor.deltastno,
+       "dclintrinsics",        &tailor.dclintrinsics,
+       "isize",        &tailor.ftnsize[FTNINT],
+       "rsize",        &tailor.ftnsize[FTNREAL],
+       "dsize",        &tailor.ftnsize[FTNDOUBLE],
+       "lsize",        &tailor.ftnsize[FTNLOG],
+       "zsize",        &tailor.ftnsize[FTNCOMPLEX],
+       "ialign",       &tailor.ftnalign[FTNINT],
+       "ralign",       &tailor.ftnalign[FTNREAL],
+       "dalign",       &tailor.ftnalign[FTNDOUBLE],
+       "lalign",       &tailor.ftnalign[FTNLOG],
+       "zalign",       &tailor.ftnalign[FTNCOMPLEX],
+       0, 0 };
+
+for(cp = formats; cp->optn ; ++cp)
+       if(equals(n, cp->optn))
+               {
+               *(cp->coptloc) = copys(v);
+               return(1);
+               }
+
+for(ip = ints ; ip->optn ; ++ip)
+       if(equals(n, ip->optn))
+               {
+               if( equals(v, "yes") || equals(v, "on") )
+                       val = 1;
+               else if( equals(v, "no") || equals(v, "off") )
+                       val = 0;
+               else    val = convci(v);
+               *(ip->ioptloc) = val;
+               return(1);
+               }
+
+return(0);
+}
diff --git a/usr/src/cmd/efl/temp.c b/usr/src/cmd/efl/temp.c

new file mode 100644 (file)

index 0000000..c03d048
--- /dev/null
+++ b/usr/src/cmd/efl/temp.c
@@ -0,0 +1,59 @@
+#include "defs"
+
+ptr gentemp(t)
+ptr t;
+{
+register ptr oldp;
+register ptr p;
+register ptr q;
+int ttype;
+ptr ttypep, tdim;
+
+/* search the temporary list for a matching type */
+
+ttype = t->vtype;
+ttypep = t->vtypep;
+tdim = t->vdim;
+
+for(oldp = &tempvarlist ; p = oldp->nextp ; oldp = p)
+       if( (q = p->datap) && (q->vtype == ttype) &&
+         (q->vtypep == ttypep) && eqdim(q->vdim,tdim) )
+               {
+               oldp->nextp = p->nextp;
+               break;
+               }
+
+if(p == PNULL)
+       {
+       q = allexpblock();
+       q->tag = TTEMP;
+       q->subtype = t->subtype;
+       q->vtype = ttype;
+       q->vclass = t->vclass;
+       q->vtypep = ( ttypep ? cpexpr(ttypep) : PNULL);
+       q->vdim = tdim;
+       mkftnp(q);      /* assign fortran types */
+
+       p = mkchain(q, CHNULL);
+       p->datap = q;
+       }
+
+p->nextp = thisexec->temps;
+thisexec->temps = p;
+
+return( cpexpr(q) );
+/* need a copy of the block for the temporary list and another for use */
+}
+
+
+ptr gent(t,tp)  /* make a temporary of type t, typepointer tp */
+int t;
+ptr tp;
+{
+static struct varblock model;
+
+model.vtype = t;
+model.vtypep = tp;
+
+return( gentemp(&model) );
+}
author	CSRG <csrg@ucbvax.Berkeley.EDU>
	Fri, 5 Sep 1980 00:28:42 +0000 (16:28 -0800)
committer	CSRG <csrg@ucbvax.Berkeley.EDU>
	Fri, 5 Sep 1980 00:28:42 +0000 (16:28 -0800)
usr/src/cmd/efl/addr.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/alloc.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/blklab.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/dcl.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/dclgen.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/defs	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Band.e	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Band.out	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Buram.e	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Buram.out	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Dgl.e	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Dgl.out	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Hard.e	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/Hard.out	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/dstack	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/efltest/rstack	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/error.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/exec.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/field.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/fixuplex	[new file with mode: 0755]	patch \| blob
usr/src/cmd/efl/free.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/gram.dcl	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/gram.expr	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/gram.head	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/icfile.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/init.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/io.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/lex.l	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/misc.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/mk.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/namgen.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/pass2.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/print.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/simple.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/struct.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/symtab.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/tailor.c	[new file with mode: 0644]	patch \| blob
usr/src/cmd/efl/temp.c	[new file with mode: 0644]	patch \| blob