00037 {
00038         register int i;
00039         int inequiv;                    /* True if one namep occurs in
00040                                            several EQUIV declarations */
00041         int comno;              /* Index into Extsym table of the last
00042                                    COMMON block seen (implicitly assuming
00043                                    that only one will be given) */
00044         int ovarno;
00045         ftnint comoffset;       /* Index into the COMMON block */
00046         ftnint offset;          /* Offset from array base */
00047         ftnint leng;
00048         register struct Equivblock *equivdecl;
00049         register struct Eqvchain *q;
00050         struct Primblock *primp;
00051         register Namep np;
00052         int k, k1, ns, pref, t;
00053         chainp cp;
00054         extern int type_pref[];
00055         char *s;
00056 
00057         for(i = 0 ; i < nequiv ; ++i)
00058         {
00059 
00060 /* Handle each equivalence declaration */
00061 
00062                 equivdecl = &eqvclass[i];
00063                 equivdecl->eqvbottom = equivdecl->eqvtop = 0;
00064                 comno = -1;
00065 
00066 
00067 
00068                 for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
00069                 {
00070                         offset = 0;
00071                         if (!(primp = q->eqvitem.eqvlhs))
00072                                 continue;
00073                         vardcl(np = primp->namep);
00074                         if(primp->argsp || primp->fcharp)
00075                         {
00076                                 expptr offp;
00077 
00078 /* Pad ones onto the end of an array declaration when needed */
00079 
00080                                 if(np->vdim!=NULL && np->vdim->ndim>1 &&
00081                                     nsubs(primp->argsp)==1 )
00082                                 {
00083                                         if(! ftn66flag)
00084                                                 warni
00085                         ("1-dim subscript in EQUIVALENCE, %d-dim declared",
00086                                                     np -> vdim -> ndim);
00087                                         cp = NULL;
00088                                         ns = np->vdim->ndim;
00089                                         while(--ns > 0)
00090                                                 cp = mkchain((char *)ICON(1), cp);
00091                                         primp->argsp->listp->nextp = cp;
00092                                 }
00093 
00094                                 offp = suboffset(primp);
00095                                 if(ISICON(offp))
00096                                         offset = offp->constblock.Const.ci;
00097                                 else    {
00098                                         dclerr
00099                         ("nonconstant subscript in equivalence ",
00100                                             np);
00101                                         np = NULL;
00102                                 }
00103                                 frexpr(offp);
00104                         }
00105 
00106 /* Free up the primblock, since we now have a hash table (Namep) entry */
00107 
00108                         frexpr((expptr)primp);
00109 
00110                         if(np && (leng = iarrlen(np))<0)
00111                         {
00112                                 dclerr("adjustable in equivalence", np);
00113                                 np = NULL;
00114                         }
00115 
00116                         if(np) switch(np->vstg)
00117                         {
00118                         case STGUNKNOWN:
00119                         case STGBSS:
00120                         case STGEQUIV:
00121                                 break;
00122 
00123                         case STGCOMMON:
00124 
00125 /* The code assumes that all COMMON references in a given EQUIVALENCE will
00126    be to the same COMMON block, and will all be consistent */
00127 
00128                                 comno = np->vardesc.varno;
00129                                 comoffset = np->voffset + offset;
00130                                 break;
00131 
00132                         default:
00133                                 dclerr("bad storage class in equivalence", np);
00134                                 np = NULL;
00135                                 break;
00136                         }
00137 
00138                         if(np)
00139                         {
00140                                 q->eqvoffset = offset;
00141 
00142 /* eqvbottom   gets the largest difference between the array base address
00143    and the address specified in the EQUIV declaration */
00144 
00145                                 equivdecl->eqvbottom =
00146                                     lmin(equivdecl->eqvbottom, -offset);
00147 
00148 /* eqvtop   gets the largest difference between the end of the array and
00149    the address given in the EQUIVALENCE */
00150 
00151                                 equivdecl->eqvtop =
00152                                     lmax(equivdecl->eqvtop, leng-offset);
00153                         }
00154                         q->eqvitem.eqvname = np;
00155                 }
00156 
00157 /* Now all equivalenced variables are in the hash table with the proper
00158    offset, and   eqvtop and eqvbottom   are set. */
00159 
00160                 if(comno >= 0)
00161 
00162 /* Get rid of all STGEQUIVS, they will be mapped onto STGCOMMON variables
00163    */
00164 
00165                         eqvcommon(equivdecl, comno, comoffset);
00166                 else for(q = equivdecl->equivs ; q ; q = q->eqvnextp)
00167                 {
00168                         if(np = q->eqvitem.eqvname)
00169                         {
00170                                 inequiv = NO;
00171                                 if(np->vstg==STGEQUIV)
00172                                         if( (ovarno = np->vardesc.varno) == i)
00173                                         {
00174 
00175 /* Can't EQUIV different elements of the same array */
00176 
00177                                                 if(np->voffset + q->eqvoffset != 0)
00178                                                         dclerr
00179                         ("inconsistent equivalence", np);
00180                                         }
00181                                         else    {
00182                                                 offset = np->voffset;
00183                                                 inequiv = YES;
00184                                         }
00185 
00186                                 np->vstg = STGEQUIV;
00187                                 np->vardesc.varno = i;
00188                                 np->voffset = - q->eqvoffset;
00189 
00190                                 if(inequiv)
00191 
00192 /* Combine 2 equivalence declarations */
00193 
00194                                         eqveqv(i, ovarno, q->eqvoffset + offset);
00195                         }
00196                 }
00197         }
00198 
00199 /* Now each equivalence declaration is distinct (all connections have been
00200    merged in eqveqv()), and some may be empty. */
00201 
00202         for(i = 0 ; i < nequiv ; ++i)
00203         {
00204                 equivdecl = & eqvclass[i];
00205                 if(equivdecl->eqvbottom!=0 || equivdecl->eqvtop!=0) {
00206 
00207 /* a live chain */
00208 
00209                         k = TYCHAR;
00210                         pref = 1;
00211                         for(q = equivdecl->equivs ; q; q = q->eqvnextp)
00212                             if ((np = q->eqvitem.eqvname)
00213                                         && !np->veqvadjust) {
00214                                 np->veqvadjust = 1;
00215                                 np->voffset -= equivdecl->eqvbottom;
00216                                 t = typealign[k1 = np->vtype];
00217                                 if (pref < type_pref[k1]) {
00218                                         k = k1;
00219                                         pref = type_pref[k1];
00220                                         }
00221                                 if(np->voffset % t != 0) {
00222                                         dclerr("bad alignment forced by equivalence", np);
00223                                         --nerr; /* don't give bad return code for this */
00224                                         }
00225                                 }
00226                         equivdecl->eqvtype = k;
00227                 }
00228                 freqchain(equivdecl);
00229         }
00230 }

00233 {
00234 #ifdef MSDOS
00235         Fatal("Only one Fortran input file allowed under MS-DOS");
00236 #else
00237 #ifndef KR_headers
00238         extern int fork(void), wait(int*);
00239 #endif
00240         int pid, status, w;
00241         extern int retcode;
00242 
00243         if (!(pid = fork()))
00244                 return 1;
00245         if (pid == -1)
00246                 Fatal("bad fork");
00247         while((w = wait(&status)) != pid)
00248                 if (w == -1)
00249                         Fatal("bad wait code");
00250         retcode |= status >> 8;
00251 #endif
00252         return 0;
00253         }

00965 {
00966         register struct Hashentry *p;
00967         register Namep q;
00968 
00969         for(p=hashtab; p<lasthash; ++p)
00970                 if( (q = p->varp) && q->vclass==CLNAMELIST)
00971                         namelist(q);
00972 }

00379 {
00380         register struct Entrypoint *ep;
00381         struct Entrypoint *ep0;
00382         chainp cp;
00383         extern char *err_proc;
00384         static char comblks[] = "common blocks";
00385 
00386         err_proc = comblks;
00387         docommon();
00388 
00389 /* Now the hash table entries for fields of common blocks have STGCOMMON,
00390    vdcldone, voffset, and varno.  And the common blocks themselves have
00391    their full sizes in extleng. */
00392 
00393         err_proc = "equivalences";
00394         doequiv();
00395 
00396         err_proc = comblks;
00397         docomleng();
00398 
00399 /* This implies that entry points in the declarations are buffered in
00400    entries   but not written out */
00401 
00402         err_proc = "entries";
00403         if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
00404                 /* entries could be 0 in case of an error */
00405                 do doentry(ep);
00406                         while(ep = ep->entnextp);
00407                 entries = (struct Entrypoint *)revchain((chainp)ep0);
00408                 }
00409 
00410         err_proc = 0;
00411         parstate = INEXEC;
00412         p1put(P1_PROCODE);
00413         freetemps();
00414         if (earlylabs) {
00415                 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
00416                         p1_label((long)cp->datap);
00417                 frchain(&earlylabs);
00418                 }
00419         p1_line_number(lineno); /* for files that start with a MAIN program */
00420                                 /* that starts with an executable statement */
00421 }

00832 {
00833         if(skiplab)
00834         {
00835                 if (ioformatted != NAMEDIRECTED)
00836                         p1_label((long)(skiplabel - labeltab));
00837                 if(ioendlab) {
00838                         exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
00839                         exgoto(execlab(ioendlab));
00840                         exendif();
00841                         }
00842                 if(ioerrlab) {
00843                         exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
00844                                         ? OPGT : OPNE,
00845                                 cpexpr(IOSTP), ICON(0)));
00846                         exgoto(execlab(ioerrlab));
00847                         exendif();
00848                         }
00849         }
00850 
00851         if(IOSTP)
00852                 frexpr(IOSTP);
00853 }

00425 {
00426         int i;
00427         expptr p;
00428         struct io_setup *ios;
00429 
00430         inioctl = NO;
00431 
00432         /* set up for error recovery */
00433 
00434         ioerrlab = ioendlab = skiplab = jumplab = 0;
00435 
00436         if(p = V(IOSEND))
00437                 if(ISICON(p))
00438                         execlab(ioendlab = p->constblock.Const.ci);
00439                 else
00440                         err("bad end= clause");
00441 
00442         if(p = V(IOSERR))
00443                 if(ISICON(p))
00444                         execlab(ioerrlab = p->constblock.Const.ci);
00445                 else
00446                         err("bad err= clause");
00447 
00448         if(IOSTP)
00449                 if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
00450                 {
00451                         err("iostat must be an integer variable");
00452                         frexpr(IOSTP);
00453                         IOSTP = NULL;
00454                 }
00455 
00456         if(iostmt == IOREAD)
00457         {
00458                 if(IOSTP)
00459                 {
00460                         if(ioerrlab && ioendlab && ioerrlab==ioendlab)
00461                                 jumplab = ioerrlab;
00462                         else
00463                                 skiplab = jumplab = newiolabel();
00464                 }
00465                 else    {
00466                         if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
00467                         {
00468                                 IOSTP = (expptr) mktmp(TYINT, ENULL);
00469                                 skiplab = jumplab = newiolabel();
00470                         }
00471                         else
00472                                 jumplab = (ioerrlab ? ioerrlab : ioendlab);
00473                 }
00474         }
00475         else if(iostmt == IOWRITE)
00476         {
00477                 if(IOSTP && !ioerrlab)
00478                         skiplab = jumplab = newiolabel();
00479                 else
00480                         jumplab = ioerrlab;
00481         }
00482         else
00483                 jumplab = ioerrlab;
00484 
00485         endbit = IOSTP!=NULL || ioendlab!=0;    /* for use in startrw() */
00486         errbit = IOSTP!=NULL || ioerrlab!=0;
00487         if (jumplab && !IOSTP)
00488                 IOSTP = (expptr) mktmp(TYINT, ENULL);
00489 
00490         if(iostmt!=IOREAD && iostmt!=IOWRITE)
00491         {
00492                 ios = io_stuff + iostmt;
00493                 io_fields = ios->fields;
00494                 ioblkp = io_structs[iostmt];
00495                 if(ioblkp == NULL)
00496                         io_structs[iostmt] = ioblkp =
00497                                 autovar(1, ios->type, ENULL, "");
00498                 ioset(TYIOINT, XERR, ICON(errbit));
00499         }
00500 
00501         switch(iostmt)
00502         {
00503         case IOOPEN:
00504                 dofopen();
00505                 break;
00506 
00507         case IOCLOSE:
00508                 dofclose();
00509                 break;
00510 
00511         case IOINQUIRE:
00512                 dofinquire();
00513                 break;
00514 
00515         case IOBACKSPACE:
00516                 dofmove("f_back");
00517                 break;
00518 
00519         case IOREWIND:
00520                 dofmove("f_rew");
00521                 break;
00522 
00523         case IOENDFILE:
00524                 dofmove("f_end");
00525                 break;
00526 
00527         case IOREAD:
00528         case IOWRITE:
00529                 startrw();
00530                 break;
00531 
00532         default:
00533                 fatali("impossible iostmt %d", iostmt);
00534         }
00535         for(i = 1 ; i<=NIOS ; ++i)
00536                 if(i!=IOSIOSTAT && V(i)!=NULL)
00537                         frexpr(V(i));
00538 }

00329 {
00330         struct Labelblock *lp;
00331         Extsym *ext;
00332 
00333         if(parstate < INDATA)
00334                 enddcl();
00335         if(ctlstack >= ctls)
00336                 err("DO loop or BLOCK IF not closed");
00337         for(lp = labeltab ; lp < labtabend ; ++lp)
00338                 if(lp->stateno!=0 && lp->labdefined==NO)
00339                         errstr("missing statement label %s",
00340                                 convic(lp->stateno) );
00341 
00342 /* Save copies of the common variables in extptr -> allextp */
00343 
00344         for (ext = extsymtab; ext < nextext; ext++)
00345                 if (ext -> extstg == STGCOMMON && ext -> extp) {
00346                         extern int usedefsforcommon;
00347 
00348 /* Write out the abbreviations for common block reference */
00349 
00350                         copy_data (ext -> extp);
00351                         if (usedefsforcommon) {
00352                                 wr_abbrevs (c_file, 1, ext -> extp);
00353                                 ext -> used_here = 1;
00354                                 }
00355                         else
00356                                 ext -> extp = CHNULL;
00357 
00358                         }
00359 
00360         if (nentry > 1)
00361                 fix_entry_returns();
00362         epicode();
00363         donmlist();
00364         dobss();
00365         start_formatting ();
00366         if (nentry > 1)
00367                 putentries(c_file);
00368 
00369         zap_changes();
00370         procinit();     /* clean up for next procedure */
00371 }

00067 {
00068         register struct Ctlframe *c;
00069 
00070         for(c = ctlstack; c->ctltype == CTLIFX; --c);
00071         if(c->ctltype == CTLIF) {
00072                 p1_else ();
00073                 c->ctltype = CTLELSE;
00074                 }
00075         else
00076                 execerr("else out of place", CNULL);
00077         }

00295 {
00296         register char *s;
00297         register int i, j;
00298 
00299         lastiolabno = 100000;
00300         lastlabno = 0;
00301         lastvarno = 0;
00302         nliterals = 0;
00303         nerr = 0;
00304 
00305         infile = stdin;
00306 
00307         maxtoklen = 502;
00308         token = (char *)ckalloc(maxtoklen+2);
00309         memset(dflttype, tyreal, 26);
00310         memset(dflttype + 'i' - 'a', tyint, 6);
00311         memset(hextoi_tab, 16, sizeof(hextoi_tab));
00312         for(i = 0, s = "0123456789abcdef"; *s; i++, s++)
00313                 hextoi(*s) = i;
00314         for(i = 10, s = "ABCDEF"; *s; i++, s++)
00315                 hextoi(*s) = i;
00316         for(j = 0, s = "abcdefghijklmnopqrstuvwxyz"; i = *s++; j++)
00317                 Letters[i] = Letters[i+'A'-'a'] = j;
00318 
00319         ctls = ALLOCN(maxctl+1, Ctlframe);
00320         extsymtab = ALLOCN(maxext, Extsym);
00321         eqvclass = ALLOCN(maxequiv, Equivblock);
00322         hashtab = ALLOCN(maxhash, Hashentry);
00323         labeltab = ALLOCN(maxstno, Labelblock);
00324         litpool = ALLOCN(maxliterals, Literal);
00325         labarray = (struct Labelblock **)ckalloc(maxlablist*
00326                                         sizeof(struct Labelblock *));
00327         fmt_init();
00328         mem_init();
00329         np_init();
00330 
00331         ctlstack = ctls++;
00332         lastctl = ctls + maxctl;
00333         nextext = extsymtab;
00334         lastext = extsymtab + maxext;
00335         lasthash = hashtab + maxhash;
00336         labtabend = labeltab + maxstno;
00337         highlabtab = labeltab;
00338         main_alias[0] = '\0';
00339         if (forcedouble)
00340                 dfltproc[TYREAL] = dfltproc[TYDREAL];
00341 
00342 /* Initialize the routines for providing C output */
00343 
00344         out_init ();
00345 }

00276 {
00277         lexstate = RETEOS;
00278 }

00309 {
00310         static char *str1fmt[6] =
00311                 { "\\b", "\\t", "\\n", "\\f", "\\r", "\\%03o" };
00312         register int i, j;
00313         register char *s;
00314 
00315         /* str_fmt */
00316 
00317 #ifdef non_ASCII
00318         i = 0;
00319 #else
00320         i = 127;
00321 #endif
00322         for(; i < Table_size; i++)
00323                 str_fmt[i] = "\\%03o";
00324 #ifdef non_ASCII
00325         for(i = 32; i < 127; i++) {
00326                 s = str0fmt[i];
00327                 str_fmt[*(unsigned char *)s] = s;
00328                 }
00329         str_fmt['"'] = "\\\"";
00330 #else
00331         if (Ansi == 1)
00332                 str_fmt[7] = chr_fmt[7] = "\\a";
00333 #endif
00334 
00335         /* chr_fmt */
00336 
00337 #ifdef non_ASCII
00338         for(i = 0; i < 32; i++)
00339                 chr_fmt[i] = chr0fmt[i];
00340 #else
00341         i = 127;
00342 #endif
00343         for(; i < Table_size; i++)
00344                 chr_fmt[i] = "\\%o";
00345 #ifdef non_ASCII
00346         for(i = 32; i < 127; i++) {
00347                 s = chr0fmt[i];
00348                 j = *(unsigned char *)s;
00349                 if (j == '\\')
00350                         j = *(unsigned char *)(s+1);
00351                 chr_fmt[j] = s;
00352                 }
00353 #endif
00354 
00355         /* escapes (used in lex.c) */
00356 
00357         for(i = 0; i < Table_size; i++)
00358                 escapes[i] = i;
00359         for(s = "btnfr0", i = 0; i < 6; i++)
00360                 escapes[*(unsigned char *)s++] = "\b\t\n\f\r"[i];
00361         /* finish str_fmt and chr_fmt */
00362 
00363         if (Ansi)
00364                 str1fmt[5] = "\\v";
00365         if ('\v' == 'v') { /* ancient C compiler */
00366                 str1fmt[5] = "v";
00367 #ifndef non_ASCII
00368                 escapes['v'] = 11;
00369 #endif
00370                 }
00371         else
00372                 escapes['v'] = '\v';
00373         for(s = "\b\t\n\f\r\v", i = 0; j = *(unsigned char *)s++;)
00374                 str_fmt[j] = chr_fmt[j] = str1fmt[i++];
00375         /* '\v' = 11 for both EBCDIC and ASCII... */
00376         chr_fmt[11] = Ansi ? "\\v" : "\\13";
00377         }

01194 {
01195         register chainp p, p1;
01196         register Addrp q;
01197         register int t;
01198 
01199         p1 = holdtemps;
01200         while(p = p1) {
01201                 q = (Addrp)p->datap;
01202                 t = q->vtype;
01203                 if (t == TYCHAR && q->varleng != 0) {
01204                         /* restore clobbered character string lengths */
01205                         frexpr(q->vleng);
01206                         q->vleng = ICON(q->varleng);
01207                         }
01208                 p1 = p->nextp;
01209                 p->nextp = templist[t];
01210                 templist[t] = p;
01211                 }
01212         holdtemps = 0;
01213         }

00801 {
00802         struct Rplblock *rp;
00803 
00804         while(rpllist)
00805         {
00806                 rp = rpllist->rplnextp;
00807                 free( (charptr) rpllist);
00808                 rpllist = rp;
00809         }
00810 }

00349 {
00350         register struct Hashentry *hp;
00351         register Namep p;
00352         register struct Dimblock *q;
00353         register int i;
00354 
00355         for(hp = hashtab ; hp < lasthash ; ++hp)
00356                 if(p = hp->varp)
00357                 {
00358                         frexpr(p->vleng);
00359                         if(q = p->vdim)
00360                         {
00361                                 for(i = 0 ; i < q->ndim ; ++i)
00362                                 {
00363                                         frexpr(q->dims[i].dimsize);
00364                                         frexpr(q->dims[i].dimexpr);
00365                                 }
00366                                 frexpr(q->nelt);
00367                                 frexpr(q->baseoffset);
00368                                 frexpr(q->basexpr);
00369                                 free( (charptr) q);
00370                         }
00371                         if(p->vclass == CLNAMELIST)
00372                                 frchain( &(p->varxptr.namelist) );
00373                         free( (charptr) p);
00374                         hp->varp = NULL;
00375                 }
00376         }

01275 {
01276         register struct Keylist *p;
01277         register int i,j;
01278         register char *s;
01279 
01280         for(i = 0 ; i<26 ; ++i)
01281                 keystart[i] = NULL;
01282 
01283         for(p = keys ; p->keyname ; ++p) {
01284                 j = letter(p->keyname[0]);
01285                 if(keystart[j] == NULL)
01286                         keystart[j] = p;
01287                 keyend[j] = p;
01288                 }
01289         i = (maxcontin + 2) * 66;
01290         sbuf = (char *)ckalloc(i + 70);
01291         send = sbuf + i;
01292         maxcont = maxcontin + 1;
01293         linestart = (char **)ckalloc(maxcont*sizeof(char*));
01294         comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] =
01295         comstart['#'] = 1;
01296 #ifdef EOF_CHAR
01297         comstart[EOF_CHAR] = 1;
01298 #endif
01299         s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
01300         while(i = *s++)
01301                 anum_buf[i] = 1;
01302         s = "0123456789";
01303         while(i = *s++)
01304                 anum_buf[i] = 2;
01305         }

00543 {
00544         register int i;
00545         int found, mask;
00546 
00547         found = 0;
00548         mask = M(iostmt);
00549         for(i = 1 ; i <= NIOS ; ++i)
00550                 if(!strcmp(ioc[i].iocname, token))
00551                         if(ioc[i].iotype & mask)
00552                                 return(i);
00553                         else {
00554                                 found = i;
00555                                 break;
00556                                 }
00557         if(found) {
00558                 if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
00559                         NOEXT("open with \"name=\" treated as \"file=\"");
00560                         for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
00561                         return i;
00562                         }
00563                 errstr("invalid control %s for statement", ioc[found].iocname);
00564                 }
00565         else
00566                 errstr("unknown iocontrol %s", token);
00567         return(IOSBAD);
00568 }

00077 {
00078         curmemblock = firstmemblock = mem0
00079                 = (memblock *)Alloc(sizeof(memblock));
00080         mem_first = mem0->buf;
00081         mem_next  = mem0->buf;
00082         mem_last  = mem0->buf + MEMBSIZE;
00083         mem0_last = mem0->buf + MEMBSIZE;
00084         mem0->next = 0;
00085         }

00507 {
00508         return ++lastlabno;
00509 }

00296 {
00297         if(parstate != OUTSIDE)
00298         {
00299                 execerr("missing end statement", CNULL);
00300                 endproc();
00301         }
00302 
00303         parstate = INSIDE;
00304         procclass = CLMAIN;     /* default */
00305 }

00159 {
00160         next_slot = output_buf = Alloc(MAX_OUTPUT_SIZE);
00161         memset(output_buf, 0, MAX_OUTPUT_SIZE);
00162         }

01383 {
01384     extern int tab_size;
01385     register char *s;
01386 
01387     s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
01388     while(*s)
01389         tr_tab[*s++] = 3;
01390     tr_tab['>'] = 1;
01391 
01392         opeqable[OPPLUS] = 1;
01393         opeqable[OPMINUS] = 1;
01394         opeqable[OPSTAR] = 1;
01395         opeqable[OPSLASH] = 1;
01396         opeqable[OPMOD] = 1;
01397         opeqable[OPLSHIFT] = 1;
01398         opeqable[OPBITAND] = 1;
01399         opeqable[OPBITXOR] = 1;
01400         opeqable[OPBITOR ] = 1;
01401 
01402 
01403 /* Set the output format for both types of floating point constants */
01404 
01405     if (fl_fmt_string == NULL || *fl_fmt_string == '\0')
01406         fl_fmt_string = Ansi == 1 ? "%sf" : "(float)%s";
01407 
01408     if (db_fmt_string == NULL || *db_fmt_string == '\0')
01409         db_fmt_string = "%.17g";
01410 
01411 /* Set the output format for both types of complex constants.  They will
01412    have string parameters rather than float or double so that the decimal
01413    point may be added to the strings generated by the {db,fl}_fmt_string
01414    formats above */
01415 
01416     if (cm_fmt_string == NULL || *cm_fmt_string == '\0') {
01417         cm_fmt_string = "{%s,%s}";
01418     } /* if cm_fmt_string == NULL */
01419 
01420     if (dcm_fmt_string == NULL || *dcm_fmt_string == '\0') {
01421         dcm_fmt_string = "{%s,%s}";
01422     } /* if dcm_fmt_string == NULL */
01423 
01424     tab_size = 4;
01425 } /* out_init */

00381 {
00382         int n, n1;
00383         char *s;
00384 
00385         n = n1 = strlen(outbuf);
00386         if (*outbuf && outbuf[n-1] != '/')
00387                 n1++;
00388         s = Alloc(n+64);
00389         outbtail = s + n1;
00390         strcpy(s, outbuf);
00391         if (n != n1)
00392                 strcpy(s+n, "/");
00393         outbuf = s;
00394         }

00380 {
00381         register struct Labelblock *lp;
00382         struct Chain *cp;
00383         int i;
00384         struct memblock;
00385         extern struct memblock *curmemblock, *firstmemblock;
00386         extern char *mem_first, *mem_next, *mem_last, *mem0_last;
00387 
00388         curmemblock = firstmemblock;
00389         mem_next = mem_first;
00390         mem_last = mem0_last;
00391         ei_next = ei_first = ei_last = 0;
00392         wh_next = wh_first = wh_last = 0;
00393         iob_list = 0;
00394         for(i = 0; i < 9; i++)
00395                 io_structs[i] = 0;
00396 
00397         parstate = OUTSIDE;
00398         headerdone = NO;
00399         blklevel = 1;
00400         saveall = NO;
00401         substars = NO;
00402         nwarn = 0;
00403         thislabel = NULL;
00404         needkwd = 0;
00405 
00406         proctype = TYUNKNOWN;
00407         procname = "MAIN_";
00408         procclass = CLUNKNOWN;
00409         nentry = 0;
00410         nallargs = nallchargs = 0;
00411         multitype = NO;
00412         retslot = NULL;
00413         for(i = 0; i < NTYPES0; i++) {
00414                 frexpr((expptr)xretslot[i]);
00415                 xretslot[i] = 0;
00416                 }
00417         cxslot = -1;
00418         chslot = -1;
00419         chlgslot = -1;
00420         procleng = 0;
00421         blklevel = 1;
00422         lastargslot = 0;
00423 
00424         for(lp = labeltab ; lp < labtabend ; ++lp)
00425                 lp->stateno = 0;
00426 
00427         hashclear();
00428 
00429 /* Clear the list of newly generated identifiers from the previous
00430    function */
00431 
00432         frexchain(&new_vars);
00433         frexchain(&used_builtins);
00434         frchain(&assigned_fmts);
00435         frchain(&allargs);
00436         frchain(&earlylabs);
00437 
00438         nintnames = 0;
00439         highlabtab = labeltab;
00440 
00441         ctlstack = ctls - 1;
00442         for(i = TYADDR; i < TYVOID; i++) {
00443                 for(cp = templist[i]; cp ; cp = cp->nextp)
00444                         free( (charptr) (cp->datap) );
00445                 frchain(templist + i);
00446                 autonum[i] = 0;
00447                 }
00448         holdtemps = NULL;
00449         dorange = 0;
00450         nregvar = 0;
00451         highregvar = 0;
00452         entries = NULL;
00453         rpllist = NULL;
00454         inioctl = NO;
00455         eqvstart += nequiv;
00456         nequiv = 0;
00457         dcomplex_seen = 0;
00458 
00459         for(i = 0 ; i<NTYPES0 ; ++i)
00460                 rtvlabel[i] = 0;
00461 
00462         if(undeftype)
00463                 setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z');
00464         else
00465         {
00466                 setimpl(tyreal, (ftnint) 0, 'a', 'z');
00467                 setimpl(tyint,  (ftnint) 0, 'i', 'n');
00468         }
00469         setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */
00470 }

00428 {
00429         register struct Intrblock *I;
00430         register struct Specblock *S;
00431 
00432         for(I = intrtab; I->intrfname[0]; I++)
00433                 if (I->intrval.intrgroup != INTRGEN)
00434                     switch(I->intrval.intrstuff) {
00435                         case TYREAL:
00436                                 I->intrval.intrstuff = TYDREAL;
00437                                 I->intrval.intrno = I->intrval.dblintrno;
00438                                 break;
00439                         case TYCOMPLEX:
00440                                 I->intrval.intrstuff = TYDCOMPLEX;
00441                                 I->intrval.intrno = I->intrval.dblintrno;
00442                                 I->intrval.dblcmplx = 1;
00443                         }
00444 
00445         for(S = spectab; S->atype; S++)
00446             switch(S->atype) {
00447                 case TYCOMPLEX:
00448                         S->atype = TYDCOMPLEX;
00449                         if (S->rtype == TYREAL)
00450                                 S->rtype = TYDREAL;
00451                         else if (S->rtype == TYCOMPLEX)
00452                                 S->rtype = TYDCOMPLEX;
00453                         switch(S->spxname[0]) {
00454                                 case 'r':
00455                                         S->spxname[0] = 'd';
00456                                         break;
00457                                 case 'c':
00458                                         S->spxname[0] = 'z';
00459                                         break;
00460                                 default:
00461                                         Fatal("r8fix bug");
00462                                 }
00463                         break;
00464                 case TYREAL:
00465                         S->atype = TYDREAL;
00466                         switch(S->rtype) {
00467                             case TYREAL:
00468                                 S->rtype = TYDREAL;
00469                                 if (S->spxname[0] != 'r')
00470                                         Fatal("r8fix bug");
00471                                 S->spxname[0] = 'd';
00472                             case TYDREAL:       /* d_prod */
00473                                 break;
00474 
00475                             case TYSHORT:
00476                                 if (!strcmp(S->spxname, "hr_expn"))
00477                                         S->spxname[1] = 'd';
00478                                 else if (!strcmp(S->spxname, "h_nint"))
00479                                         strcpy(S->spxname, "h_dnnt");
00480                                 else Fatal("r8fix bug");
00481                                 break;
00482 
00483                             case TYLONG:
00484                                 if (!strcmp(S->spxname, "ir_expn"))
00485                                         S->spxname[1] = 'd';
00486                                 else if (!strcmp(S->spxname, "i_nint"))
00487                                         strcpy(S->spxname, "i_dnnt");
00488                                 else Fatal("r8fix bug");
00489                                 break;
00490 
00491                             default:
00492                                 Fatal("r8fix bug");
00493                             }
00494                 }
00495         }

00221 {
00222     static char *hset[3] = { 0, "integer", "doublereal" };
00223 
00224 /* Adjust the global flags according to the command line parameters */
00225 
00226     if (chars_per_wd > 0) {
00227         typesize[TYADDR] = typesize[TYLONG] = typesize[TYREAL] =
00228                 typesize[TYLOGICAL] = chars_per_wd;
00229         typesize[TYINT1] = typesize[TYLOGICAL1] = 1;
00230         typesize[TYDREAL] = typesize[TYCOMPLEX] = chars_per_wd << 1;
00231         typesize[TYDCOMPLEX] = chars_per_wd << 2;
00232         typesize[TYSHORT] = typesize[TYLOGICAL2] = chars_per_wd >> 1;
00233         typesize[TYCILIST] = 5*chars_per_wd;
00234         typesize[TYICILIST] = 6*chars_per_wd;
00235         typesize[TYOLIST] = 9*chars_per_wd;
00236         typesize[TYCLLIST] = 3*chars_per_wd;
00237         typesize[TYALIST] = 2*chars_per_wd;
00238         typesize[TYINLIST] = 26*chars_per_wd;
00239         }
00240 
00241     if (wordalign)
00242         typealign[TYDREAL] = typealign[TYDCOMPLEX] = typealign[TYREAL];
00243     if (!tyioint) {
00244         tyioint = TYSHORT;
00245         szleng = typesize[TYSHORT];
00246         def_i2 = "#define f2c_i2 1\n";
00247         inqmask = M(TYSHORT)|M(TYLOGICAL2);
00248         goto checklong;
00249         }
00250     else
00251         szleng = typesize[TYLONG];
00252     if (useshortints) {
00253         /* inqmask = M(TYLONG); */
00254         /* used to disallow LOGICAL in INQUIRE under -I2 */
00255  checklong:
00256         protorettypes[TYLOGICAL] = "shortlogical";
00257         casttypes[TYLOGICAL] = "K_fp";
00258         if (uselongints)
00259                 err ("Can't use both long and short ints");
00260         else {
00261                 tyint = tylogical = TYSHORT;
00262                 tylog = TYLOGICAL2;
00263                 }
00264         }
00265     else if (uselongints)
00266         tyint = TYLONG;
00267 
00268     if (h0align) {
00269         if (tyint == TYLONG && wordalign)
00270                 h0align = 1;
00271         ohalign = halign = hset[h0align];
00272         htype = h0align == 1 ? tyint : TYDREAL;
00273         hsize = typesize[htype];
00274         }
00275 
00276     if (no66flag)
00277         noextflag = no66flag;
00278     if (noextflag)
00279         zflag = 0;
00280 
00281     if (r8flag) {
00282         tyreal = TYDREAL;
00283         tycomplex = TYDCOMPLEX;
00284         r8fix();
00285         }
00286     if (forcedouble) {
00287         protorettypes[TYREAL] = "E_f";
00288         casttypes[TYREAL] = "E_fp";
00289         }
00290     else
00291         dneg = 0;
00292 
00293     if (maxregvar > MAXREGVAR) {
00294         warni("-O%d: too many register variables", maxregvar);
00295         maxregvar = MAXREGVAR;
00296     } /* if maxregvar > MAXREGVAR */
00297 
00298 /* Check the list of input files */
00299 
00300     {
00301         int bad, i, cur_max = Max_ftn_files;
00302 
00303         for (i = bad = 0; i < cur_max && ftn_files[i]; i++)
00304             if (ftn_files[i][0] == '-') {
00305                 errstr ("Invalid flag '%s'", ftn_files[i]);
00306                 bad++;
00307                 }
00308         if (bad)
00309                 exit(1);
00310 
00311     } /* block */
00312 } /* set_externs */

00081 {
00082         int k;
00083         if (debugflag == 1)
00084                 return;
00085         k = strlen(tmpdir) + 24;
00086         c_functions = (char *)ckalloc(7*k);
00087         initfname = c_functions + k;
00088         initbname = initfname + k;
00089         blkdfname = initbname + k;
00090         p1_file = blkdfname + k;
00091         p1_bakfile = p1_file + k;
00092         sortfname = p1_bakfile + k;
00093         {
00094 #ifdef MSDOS
00095         char buf[64], *s, *t;
00096         if (!*tmpdir || *tmpdir == '.' && !tmpdir[1])
00097                 t = "";
00098         else {
00099                 /* substitute \ for / to avoid confusion with a
00100                  * switch indicator in the system("sort ...")
00101                  * call in formatdata.c
00102                  */
00103                 for(s = tmpdir, t = buf; *s; s++, t++)
00104                         if ((*t = *s) == '/')
00105                                 *t = '\\';
00106                 if (t[-1] != '\\')
00107                         *t++ = '\\';
00108                 *t = 0;
00109                 t = buf;
00110                 }
00111         sprintf(c_functions, "%sf2c_func", t);
00112         sprintf(initfname, "%sf2c_rd", t);
00113         sprintf(blkdfname, "%sf2c_blkd", t);
00114         sprintf(p1_file, "%sf2c_p1f", t);
00115         sprintf(p1_bakfile, "%sf2c_p1fb", t);
00116         sprintf(sortfname, "%sf2c_sort", t);
00117 #else
00118         long pid = getpid();
00119         sprintf(c_functions, "%s/f2c%ld_func", tmpdir, pid);
00120         sprintf(initfname, "%s/f2c%ld_rd", tmpdir, pid);
00121         sprintf(blkdfname, "%s/f2c%ld_blkd", tmpdir, pid);
00122         sprintf(p1_file, "%s/f2c%ld_p1f", tmpdir, pid);
00123         sprintf(p1_bakfile, "%s/f2c%ld_p1fb", tmpdir, pid);
00124         sprintf(sortfname, "%s/f2c%ld_sort", tmpdir, pid);
00125 #endif
00126         sprintf(initbname, "%s.b", initfname);
00127         }
00128         if (debugflag)
00129                 fprintf(diagfile, "%s %s %s %s %s %s\n", c_functions,
00130                         initfname, blkdfname, p1_file, p1_bakfile, sortfname);
00131         }

00088 {
00089     FILE *infile;
00090     static int wrote_one = 0;
00091     extern int usedefsforcommon;
00092     extern char *p1_file, *p1_bakfile;
00093 
00094     this_proc_name[0] = '\0';
00095     last_was_label = 0;
00096     ei_next = ei_first;
00097     wh_next = wh_first;
00098 
00099     (void) fclose (pass1_file);
00100     if ((infile = fopen (p1_file, binread)) == NULL)
00101         Fatal("start_formatting:  couldn't open the intermediate file\n");
00102 
00103     if (wrote_one)
00104         nice_printf (c_file, "\n");
00105 
00106     while (!feof (infile)) {
00107         expptr this_expr;
00108 
00109         this_expr = do_format (infile, c_file);
00110         if (this_expr) {
00111             out_and_free_statement (c_file, this_expr);
00112         } /* if this_expr */
00113     } /* while !feof infile */
00114 
00115     (void) fclose (infile);
00116 
00117     if (last_was_label)
00118         nice_printf (c_file, ";\n");
00119 
00120     prev_tab (c_file);
00121     gflag1 = sharp_line = 0;
00122     if (this_proc_name[0])
00123         nice_printf (c_file, "} /* %s */\n", this_proc_name);
00124 
00125 
00126 /* Write the #undefs for common variable reference */
00127 
00128     if (usedefsforcommon) {
00129         Extsym *ext;
00130         int did_one = 0;
00131 
00132         for (ext = extsymtab; ext < nextext; ext++)
00133             if (ext -> extstg == STGCOMMON && ext -> used_here) {
00134                 ext -> used_here = 0;
00135                 if (!did_one)
00136                     nice_printf (c_file, "\n");
00137                 wr_abbrevs(c_file, 0, ext->extp);
00138                 did_one = 1;
00139                 ext -> extp = CHNULL;
00140             } /* if */
00141 
00142         if (did_one)
00143             nice_printf (c_file, "\n");
00144     } /* if usedefsforcommon */
00145 
00146     other_undefs(c_file);
00147 
00148     wrote_one = 1;
00149 
00150 /* For debugging only */
00151 
00152     if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
00153         if (infile = fopen (p1_file, binread)) {
00154             ffilecopy (infile, pass1_file);
00155             fclose (infile);
00156             fclose (pass1_file);
00157         } /* if infile */
00158 
00159 /* End of "debugging only" */
00160 
00161     scrub(p1_file);     /* optionally unlink */
00162 
00163     if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
00164         err ("start_formatting:  couldn't reopen the pass1 file");
00165 
00166 } /* start_formatting */

00938 {
00939         register expptr p;
00940         register Namep np;
00941         register Addrp unitp, fmtp, recp;
00942         register expptr nump;
00943         int iostmt1;
00944         flag intfile, sequential, ok, varfmt;
00945         struct io_setup *ios;
00946 
00947         /* First look at all the parameters and determine what is to be done */
00948 
00949         ok = YES;
00950         statstruct = YES;
00951 
00952         intfile = NO;
00953         if(p = V(IOSUNIT))
00954         {
00955                 if( ISINT(p->headblock.vtype) ) {
00956  int_unit:
00957                         unitp = (Addrp) cpexpr(p);
00958                         }
00959                 else if(p->headblock.vtype == TYCHAR)
00960                 {
00961                         if (nioctl == 1 && iostmt == IOREAD) {
00962                                 /* kludge to recognize READ(format expr) */
00963                                 V(IOSFMT) = p;
00964                                 V(IOSUNIT) = p = (expptr) IOSTDIN;
00965                                 ioformatted = FORMATTED;
00966                                 goto int_unit;
00967                                 }
00968                         intfile = YES;
00969                         if(p->tag==TPRIM && p->primblock.argsp==NULL &&
00970                             (np = p->primblock.namep)->vdim!=NULL)
00971                         {
00972                                 vardcl(np);
00973                                 if(nump = np->vdim->nelt)
00974                                 {
00975                                         nump = fixtype(cpexpr(nump));
00976                                         if( ! ISCONST(nump) ) {
00977                                                 statstruct = NO;
00978                                                 np->vlastdim = 0;
00979                                                 }
00980                                 }
00981                                 else
00982                                 {
00983                                         err("attempt to use internal unit array of unknown size");
00984                                         ok = NO;
00985                                         nump = ICON(1);
00986                                 }
00987                                 unitp = mkscalar(np);
00988                         }
00989                         else    {
00990                                 nump = ICON(1);
00991                                 unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
00992                         }
00993                         if(! isstatic((expptr)unitp) )
00994                                 statstruct = NO;
00995                 }
00996                 else {
00997                         err("unit specifier not of type integer or character");
00998                         ok = NO;
00999                         }
01000         }
01001         else
01002         {
01003                 err("bad unit specifier");
01004                 ok = NO;
01005         }
01006 
01007         sequential = YES;
01008         if(p = V(IOSREC))
01009                 if( ISINT(p->headblock.vtype) )
01010                 {
01011                         recp = (Addrp) cpexpr(p);
01012                         sequential = NO;
01013                 }
01014                 else    {
01015                         err("bad REC= clause");
01016                         ok = NO;
01017                 }
01018         else
01019                 recp = NULL;
01020 
01021 
01022         varfmt = YES;
01023         fmtp = NULL;
01024         if(p = V(IOSFMT))
01025         {
01026                 if(p->tag==TPRIM && p->primblock.argsp==NULL)
01027                 {
01028                         np = p->primblock.namep;
01029                         if(np->vclass == CLNAMELIST)
01030                         {
01031                                 ioformatted = NAMEDIRECTED;
01032                                 fmtp = (Addrp) fixtype(p);
01033                                 V(IOSFMT) = (expptr)fmtp;
01034                                 if (skiplab)
01035                                         jumplab = 0;
01036                                 goto endfmt;
01037                         }
01038                         vardcl(np);
01039                         if(np->vdim)
01040                         {
01041                                 if( ! ONEOF(np->vstg, MSKSTATIC) )
01042                                         statstruct = NO;
01043                                 fmtp = mkscalar(np);
01044                                 goto endfmt;
01045                         }
01046                         if( ISINT(np->vtype) )  /* ASSIGNed label */
01047                         {
01048                                 statstruct = NO;
01049                                 varfmt = YES;
01050                                 fmtp = asg_addr(p);
01051                                 goto endfmt;
01052                         }
01053                 }
01054                 p = V(IOSFMT) = fixtype(p);
01055                 if(p->headblock.vtype == TYCHAR
01056                         /* Since we allow write(6,n)            */
01057                         /* we may as well allow write(6,n(2))   */
01058                 || p->tag == TADDR && ISINT(p->addrblock.vtype))
01059                 {
01060                         if( ! isstatic(p) )
01061                                 statstruct = NO;
01062                         fmtp = (Addrp) cpexpr(p);
01063                 }
01064                 else if( ISICON(p) )
01065                 {
01066                         struct Labelblock *lp;
01067                         lp = mklabel(p->constblock.Const.ci);
01068                         if (fmtstmt(lp) > 0)
01069                         {
01070                                 fmtp = (Addrp)mkaddcon(lp->stateno);
01071                                 /* lp->stateno for names fmt_nnn */
01072                                 lp->fmtlabused = 1;
01073                                 varfmt = NO;
01074                         }
01075                         else
01076                                 ioformatted = UNFORMATTED;
01077                 }
01078                 else    {
01079                         err("bad format descriptor");
01080                         ioformatted = UNFORMATTED;
01081                         ok = NO;
01082                 }
01083         }
01084         else
01085                 fmtp = NULL;
01086 
01087 endfmt:
01088         if(intfile) {
01089                 if (ioformatted==UNFORMATTED) {
01090                         err("unformatted internal I/O not allowed");
01091                         ok = NO;
01092                         }
01093                 if (recp) {
01094                         err("direct internal I/O not allowed");
01095                         ok = NO;
01096                         }
01097                 }
01098         if(!sequential && ioformatted==LISTDIRECTED)
01099         {
01100                 err("direct list-directed I/O not allowed");
01101                 ok = NO;
01102         }
01103         if(!sequential && ioformatted==NAMEDIRECTED)
01104         {
01105                 err("direct namelist I/O not allowed");
01106                 ok = NO;
01107         }
01108 
01109         if( ! ok ) {
01110                 statstruct = NO;
01111                 return;
01112                 }
01113 
01114         /*
01115    Now put out the I/O structure, statically if all the clauses
01116    are constants, dynamically otherwise
01117 */
01118 
01119         if (intfile) {
01120                 ios = io_stuff + iostmt;
01121                 iostmt1 = IOREAD;
01122                 }
01123         else {
01124                 ios = io_stuff;
01125                 iostmt1 = 0;
01126                 }
01127         io_fields = ios->fields;
01128         if(statstruct)
01129         {
01130                 ioblkp = ALLOC(Addrblock);
01131                 ioblkp->tag = TADDR;
01132                 ioblkp->vtype = ios->type;
01133                 ioblkp->vclass = CLVAR;
01134                 ioblkp->vstg = STGINIT;
01135                 ioblkp->memno = ++lastvarno;
01136                 ioblkp->memoffset = ICON(0);
01137                 ioblkp -> uname_tag = UNAM_IDENT;
01138                 new_iob_data(ios,
01139                         temp_name("io_", lastvarno, ioblkp->user.ident));                       }
01140         else if(!(ioblkp = io_structs[iostmt1]))
01141                 io_structs[iostmt1] = ioblkp =
01142                         autovar(1, ios->type, ENULL, "");
01143 
01144         ioset(TYIOINT, XERR, ICON(errbit));
01145         if(iostmt == IOREAD)
01146                 ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
01147 
01148         if(intfile)
01149         {
01150                 ioset(TYIOINT, XIRNUM, nump);
01151                 ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
01152                 ioseta(XIUNIT, unitp);
01153         }
01154         else
01155                 ioset(TYIOINT, XUNIT, (expptr) unitp);
01156 
01157         if(recp)
01158                 ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
01159 
01160         if(varfmt)
01161                 ioseta( intfile ? XIFMT : XFMT , fmtp);
01162         else
01163                 ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
01164 
01165         ioroutine[0] = 's';
01166         ioroutine[1] = '_';
01167         ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
01168         ioroutine[3] = "ds"[sequential];
01169         ioroutine[4] = "ufln"[ioformatted];
01170         ioroutine[5] = "ei"[intfile];
01171         ioroutine[6] = '\0';
01172 
01173         putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
01174 
01175         if(statstruct)
01176         {
01177                 frexpr((expptr)ioblkp);
01178                 statstruct = NO;
01179                 ioblkp = 0;     /* unnecessary */
01180         }
01181 }