00920 {
00921         register Addrp q;
00922 
00923         if (p->tag != TPRIM)
00924                 badtag("asg_addr", p->tag);
00925         q = ALLOC(Addrblock);
00926         q->tag = TADDR;
00927         q->vtype = TYCHAR;
00928         q->vstg = STGAUTO;
00929         q->ntempelt = 1;
00930         q->isarray = 0;
00931         q->memoffset = ICON(0);
00932         fmtname(p->primblock.namep, q);
00933         return q;
00934         }

01221 {
01222         register expptr p;
01223 
01224         if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
01225         {
01226                 ioset(TYIOINT, XUNIT, cpexpr(p) );
01227                 iosetc(XCLSTATUS, V(IOSSTATUS));
01228                 putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
01229         }
01230         else
01231                 err("bad unit in close statement");
01232 }

01237 {
01238         register expptr p;
01239         if(p = V(IOSUNIT))
01240         {
01241                 if( V(IOSFILE) )
01242                         err("inquire by unit or by file, not both");
01243                 ioset(TYIOINT, XUNIT, cpexpr(p) );
01244         }
01245         else if( ! V(IOSFILE) )
01246                 err("must inquire by unit or by file");
01247         iosetlc(IOSFILE, XFILE, XFILELEN);
01248         iosetip(IOSEXISTS, XEXISTS);
01249         iosetip(IOSOPENED, XOPEN);
01250         iosetip(IOSNUMBER, XNUMBER);
01251         iosetip(IOSNAMED, XNAMED);
01252         iosetlc(IOSNAME, XNAME, XNAMELEN);
01253         iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
01254         iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
01255         iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
01256         iosetlc(IOSFORM, XFORM, XFORMLEN);
01257         iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
01258         iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
01259         iosetip(IOSRECL, XQRECL);
01260         iosetip(IOSNEXTREC, XNEXTREC);
01261         iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
01262 
01263         putiocall( call1(TYINT,  "f_inqu", cpexpr((expptr)ioblkp) ));
01264 }

01275 {
01276         register expptr p;
01277 
01278         if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
01279         {
01280                 ioset(TYIOINT, XUNIT, cpexpr(p) );
01281                 putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
01282         }
01283         else
01284                 err("bad unit in I/O motion statement");
01285 }

01187 {
01188         register expptr p;
01189 
01190         if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
01191                 ioset(TYIOINT, XUNIT, cpexpr(p) );
01192         else
01193                 err("bad unit in open");
01194         if( (p = V(IOSFILE)) )
01195                 if(p->headblock.vtype == TYCHAR)
01196                         ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
01197                 else
01198                         err("bad file in open");
01199 
01200         iosetc(XFNAME, p);
01201 
01202         if(p = V(IOSRECL))
01203                 if( ISINT(p->headblock.vtype) )
01204                         ioset(TYIOINT, XRECLEN, cpexpr(p) );
01205                 else
01206                         err("bad recl");
01207         else
01208                 ioset(TYIOINT, XRECLEN, ICON(0) );
01209 
01210         iosetc(XSTATUS, V(IOSSTATUS));
01211         iosetc(XACCESS, V(IOSACCESS));
01212         iosetc(XFORMATTED, V(IOSFORM));
01213         iosetc(XBLANK, V(IOSBLANK));
01214 
01215         putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
01216 }

00651 {
00652         if(ioformatted == NAMEDIRECTED)
00653         {
00654                 if(list)
00655                         err("no I/O list allowed in NAMELIST read/write");
00656         }
00657         else
00658         {
00659                 doiolist(list);
00660                 ioroutine[0] = 'e';
00661                 if (skiplab)
00662                         jumplab = 0;
00663                 putiocall( call0(TYINT, ioroutine) );
00664         }
00665 }

00678 {
00679         chainp p;
00680         register tagptr q;
00681         register expptr qe;
00682         register Namep qn;
00683         Addrp tp;
00684         int range;
00685         extern char *ohalign;
00686 
00687         for (p = p0 ; p ; p = p->nextp)
00688         {
00689                 q = (tagptr)p->datap;
00690                 if(q->tag == TIMPLDO)
00691                 {
00692                         exdo(range = (int)newlabel(), (Namep)0,
00693                                 q->impldoblock.impdospec);
00694                         doiolist(q->impldoblock.datalist);
00695                         enddo(range);
00696                         free( (charptr) q);
00697                 }
00698                 else    {
00699                         if(q->tag==TPRIM && q->primblock.argsp==NULL
00700                             && q->primblock.namep->vdim!=NULL)
00701                         {
00702                                 vardcl(qn = q->primblock.namep);
00703                                 if(qn->vdim->nelt) {
00704                                         putio( fixtype(cpexpr(qn->vdim->nelt)),
00705                                             (expptr)mkscalar(qn) );
00706                                         qn->vlastdim = 0;
00707                                         }
00708                                 else
00709                                         err("attempt to i/o array of unknown size");
00710                         }
00711                         else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
00712                             (qe = (expptr) memversion(q->primblock.namep)) )
00713                                 putio(ICON(1),qe);
00714                         else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
00715                                 halign = 0;
00716                                 putio(ICON(1), qe = fixtype(cpexpr(q)));
00717                                 halign = ohalign;
00718                                 }
00719                         else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
00720                             (qe->addrblock.uname_tag != UNAM_CONST ||
00721                             !ISCOMPLEX(qe -> addrblock.vtype))) ||
00722                             (qe -> tag == TCONST && !ISCOMPLEX(qe ->
00723                             headblock.vtype))) {
00724                                 if (qe -> tag == TCONST)
00725                                         qe = (expptr) putconst((Constp)qe);
00726                                 putio(ICON(1), qe);
00727                         }
00728                         else if(qe->headblock.vtype != TYERROR)
00729                         {
00730                                 if(iostmt == IOWRITE)
00731                                 {
00732                                         expptr qvl;
00733                                         qvl = NULL;
00734                                         if( ISCHAR(qe) )
00735                                         {
00736                                                 qvl = (expptr)
00737                                                     cpexpr(qe->headblock.vleng);
00738                                                 tp = mktmp(qe->headblock.vtype,
00739                                                     ICON(lencat(qe)));
00740                                         }
00741                                         else
00742                                                 tp = mktmp(qe->headblock.vtype,
00743                                                     qe->headblock.vleng);
00744                                         puteq( cpexpr((expptr)tp), qe);
00745                                         if(qvl) /* put right length on block */
00746                                         {
00747                                                 frexpr(tp->vleng);
00748                                                 tp->vleng = qvl;
00749                                         }
00750                                         putio(ICON(1), (expptr)tp);
00751                                 }
00752                                 else
00753                                         err("non-left side in READ list");
00754                         }
00755                         frexpr(q);
00756                 }
00757         }
00758         frchain( &p0 );
00759 }

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 }

00892 {
00893         register int k;
00894         register char *s, *t;
00895         extern chainp assigned_fmts;
00896 
00897         if (!np->vfmt_asg) {
00898                 np->vfmt_asg = 1;
00899                 assigned_fmts = mkchain((char *)np, assigned_fmts);
00900                 }
00901         k = strlen(s = np->fvarname);
00902         if (k < IDENT_LEN - 4) {
00903                 q->uname_tag = UNAM_IDENT;
00904                 t = q->user.ident;
00905                 }
00906         else {
00907                 q->uname_tag = UNAM_CHARP;
00908                 q->user.Charp = t = mem(k + 5,0);
00909                 }
00910         sprintf(t, "%s_fmt", s);
00911         }

00296 {
00297         if(lp == NULL)
00298         {
00299                 execerr("unlabeled format statement" , CNULL);
00300                 return(-1);
00301         }
00302         if(lp->labtype == LABUNKNOWN)
00303         {
00304                 lp->labtype = LABFORMAT;
00305                 lp->labelno = (int)newlabel();
00306         }
00307         else if(lp->labtype != LABFORMAT)
00308         {
00309                 execerr("bad format number", CNULL);
00310                 return(-1);
00311         }
00312         return(lp->labelno);
00313 }

00579 {
00580         struct Ioclist *iocp;
00581 
00582         ++nioctl;
00583         if(n == IOSBAD)
00584                 return;
00585         if(n == IOSPOSITIONAL)
00586                 {
00587                 n = nioctl;
00588                 if (n == IOSFMT) {
00589                         if (iostmt == IOOPEN) {
00590                                 n = IOSFILE;
00591                                 NOEXT("file= specifier omitted from open");
00592                                 }
00593                         else if (iostmt < IOREAD)
00594                                 goto illegal;
00595                         }
00596                 else if(n > IOSFMT)
00597                         {
00598  illegal:
00599                         err("illegal positional iocontrol");
00600                         return;
00601                         }
00602                 }
00603         else if (n == IOSNML)
00604                 n = IOSFMT;
00605 
00606         if(p == NULL)
00607         {
00608                 if(n == IOSUNIT)
00609                         p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
00610                 else if(n != IOSFMT)
00611                 {
00612                         err("illegal * iocontrol");
00613                         return;
00614                 }
00615         }
00616         if(n == IOSFMT)
00617                 ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
00618 
00619         iocp = & ioc[n];
00620         if(iocp->iocval == NULL)
00621         {
00622                 if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
00623                         p = fixtype(p);
00624                 else if (p && p->tag == TPRIM
00625                            && p->primblock.namep->vclass == CLUNKNOWN) {
00626                         /* kludge made necessary by attempt to infer types
00627                          * for untyped external parameters: given an error
00628                          * in calling sequences, an integer argument might
00629                          * tentatively be assumed TYCHAR; this would otherwise
00630                          * be corrected too late in startrw after startrw
00631                          * had decided this to be an internal file.
00632                          */
00633                         vardcl(p->primblock.namep);
00634                         p->primblock.vtype = p->primblock.namep->vtype;
00635                         }
00636                 iocp->iocval = p;
00637         }
00638         else
00639                 errstr("iocontrol %s repeated", iocp->iocname);
00640 }

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 }

01298 {
01299         offset /= SZLONG;
01300         if(statstruct && ISCONST(p)) {
01301                 register char *s;
01302                 switch(type) {
01303                         case TYADDR:    /* stmt label */
01304                                 s = "fmt_";
01305                                 break;
01306                         case TYIOINT:
01307                                 s = "";
01308                                 break;
01309                         default:
01310                                 badtype("ioset", type);
01311                         }
01312                 iob_list->fields[offset] =
01313                         string_num(s, p->constblock.Const.ci);
01314                 frexpr(p);
01315                 }
01316         else {
01317                 register Addrp q;
01318 
01319                 q = ALLOC(Addrblock);
01320                 q->tag = TADDR;
01321                 q->vtype = type;
01322                 q->vstg = STGAUTO;
01323                 q->ntempelt = 1;
01324                 q->isarray = 0;
01325                 q->memoffset = ICON(0);
01326                 q->uname_tag = UNAM_IDENT;
01327                 sprintf(q->user.ident, "%s.%s",
01328                         statstruct ? iob_list->name : ioblkp->user.ident,
01329                         io_fields[offset + 1]);
01330                 if (type == TYADDR && p->tag == TCONST
01331                                    && p->constblock.vtype == TYADDR) {
01332                         /* kludge */
01333                         register Addrp p1;
01334                         p1 = ALLOC(Addrblock);
01335                         p1->tag = TADDR;
01336                         p1->vtype = type;
01337                         p1->vstg = STGAUTO;     /* wrong, but who cares? */
01338                         p1->ntempelt = 1;
01339                         p1->isarray = 0;
01340                         p1->memoffset = ICON(0);
01341                         p1->uname_tag = UNAM_IDENT;
01342                         sprintf(p1->user.ident, "fmt_%ld",
01343                                 p->constblock.Const.ci);
01344                         frexpr(p);
01345                         p = (expptr)p1;
01346                         }
01347                 if (type == TYADDR && p->headblock.vtype == TYCHAR)
01348                         q->vtype = TYCHAR;
01349                 putexpr(mkexpr(ioset_assign, (expptr)q, p));
01350                 }
01351 }

01385 {
01386         char *s, *s1;
01387         static char who[] = "ioseta";
01388         expptr e, mo;
01389         Namep np;
01390         ftnint ci;
01391         int k;
01392         char buf[24], buf1[24];
01393         Extsym *comm;
01394         extern int usedefsforcommon;
01395 
01396         if(statstruct)
01397         {
01398                 if (!p)
01399                         return;
01400                 if (p->tag != TADDR)
01401                         badtag(who, p->tag);
01402                 offset /= SZLONG;
01403                 switch(p->uname_tag) {
01404                     case UNAM_NAME:
01405                         mo = p->memoffset;
01406                         if (mo->tag != TCONST)
01407                                 badtag("ioseta/memoffset", mo->tag);
01408                         np = p->user.name;
01409                         np->visused = 1;
01410                         ci = mo->constblock.Const.ci - np->voffset;
01411                         if (np->vstg == STGCOMMON
01412                         && !np->vcommequiv
01413                         && !usedefsforcommon) {
01414                                 comm = &extsymtab[np->vardesc.varno];
01415                                 sprintf(buf, "%d.", comm->curno);
01416                                 k = strlen(buf) + strlen(comm->cextname)
01417                                         + strlen(np->cvarname);
01418                                 if (ci) {
01419                                         sprintf(buf1, "+%ld", ci);
01420                                         k += strlen(buf1);
01421                                         }
01422                                 else
01423                                         buf1[0] = 0;
01424                                 s = mem(k + 1, 0);
01425                                 sprintf(s, "%s%s%s%s", comm->cextname, buf,
01426                                         np->cvarname, buf1);
01427                                 }
01428                         else if (ci) {
01429                                 sprintf(buf,"%ld", ci);
01430                                 s1 = p->user.name->cvarname;
01431                                 k = strlen(buf) + strlen(s1);
01432                                 sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
01433                                 }
01434                         else
01435                                 s = cpstring(np->cvarname);
01436                         break;
01437                     case UNAM_CONST:
01438                         s = tostring(p->user.Const.ccp1.ccp0,
01439                                 (int)p->vleng->constblock.Const.ci);
01440                         break;
01441                     default:
01442                         badthing("uname_tag", who, p->uname_tag);
01443                     }
01444                 /* kludge for Hollerith */
01445                 if (p->vtype != TYCHAR) {
01446                         s1 = mem(strlen(s)+10,0);
01447                         sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
01448                         s = s1;
01449                         }
01450                 iob_list->fields[offset] = s;
01451         }
01452         else {
01453                 if (!p)
01454                         e = ICON(0);
01455                 else if (p->vtype != TYCHAR) {
01456                         NOEXT("non-character variable as format or internal unit");
01457                         e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
01458                         }
01459                 else
01460                         e = addrof((expptr)p);
01461                 ioset(TYADDR, offset, e);
01462                 }
01463 }

01364 {
01365         if(p == NULL)
01366                 ioset(TYADDR, offset, ICON(0) );
01367         else if(p->headblock.vtype == TYCHAR) {
01368                 p = putx(fixtype((expptr)putchop(cpexpr(p))));
01369                 ioset(TYADDR, offset, addrof(p));
01370                 }
01371         else
01372                 err("non-character control clause");
01373 }

01476 {
01477         register expptr p;
01478 
01479         if(p = V(i))
01480                 if(p->tag==TADDR &&
01481                     ONEOF(p->addrblock.vtype, inqmask) ) {
01482                         ioset_assign = OPASSIGNI;
01483                         ioset(TYADDR, offset, addrof(cpexpr(p)) );
01484                         ioset_assign = OPASSIGN;
01485                         }
01486                 else
01487                         errstr("impossible inquire parameter %s", ioc[i].iocname);
01488         else
01489                 ioset(TYADDR, offset, ICON(0) );
01490 }

01503 {
01504         register expptr p;
01505         if( (p = V(i)) && p->headblock.vtype==TYCHAR)
01506                 ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
01507         iosetc(offp, p);
01508 }

00415                  {
00416         long rv;
00417         rv = ++lastiolabno;
00418         skiplabel = mklabel(rv);
00419         skiplabel->labdefined = 1;
00420         return rv;
00421         }

00778 {
00779         int type;
00780         register expptr q;
00781         register Addrp c = 0;
00782 
00783         type = addr->headblock.vtype;
00784         if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
00785         {
00786                 nelt = mkexpr(OPSTAR, ICON(2), nelt);
00787                 type -= (TYCOMPLEX-TYREAL);
00788         }
00789 
00790         /* pass a length with every item.  for noncharacter data, fake one */
00791         if(type != TYCHAR)
00792         {
00793 
00794                 if( ISCONST(addr) )
00795                         addr = (expptr) putconst((Constp)addr);
00796                 c = ALLOC(Addrblock);
00797                 c->tag = TADDR;
00798                 c->vtype = TYLENG;
00799                 c->vstg = STGAUTO;
00800                 c->ntempelt = 1;
00801                 c->isarray = 1;
00802                 c->memoffset = ICON(0);
00803                 c->uname_tag = UNAM_IDENT;
00804                 c->charleng = 1;
00805                 sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
00806                 addr = mkexpr(OPCHARCAST, addr, ENULL);
00807                 }
00808 
00809         nelt = fixtype( mkconv(tyioint,nelt) );
00810         if(ioformatted == LISTDIRECTED) {
00811                 expptr mc = mkconv(tyioint, ICON(typeconv[type]));
00812                 q = c   ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
00813                         : call3(TYINT, "do_lio", mc, nelt, addr);
00814                 }
00815         else {
00816                 char *s = ioformatted==FORMATTED ? "do_fio"
00817                         : !byterev ? "do_uio"
00818                         : ONEOF(type, M(TYCHAR)|M(TYINT1)|M(TYLOGICAL1))
00819                         ? "do_ucio" : "do_unio";
00820                 q = c   ? call3(TYINT, s, nelt, addr, (expptr)c)
00821                         : call2(TYINT, s, nelt, addr);
00822                 }
00823         iocalladdr = TYCHAR;
00824         putiocall(q);
00825         iocalladdr = TYADDR;
00826 }

00864 {
00865         int tyintsave;
00866 
00867         tyintsave = tyint;
00868         tyint = tyioint;        /* for -I2 and -i2 */
00869 
00870         if(IOSTP)
00871         {
00872                 q->headblock.vtype = TYINT;
00873                 q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
00874         }
00875         putexpr(q);
00876         if(jumplab) {
00877                 exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
00878                 exgoto(execlab(jumplab));
00879                 exendif();
00880                 }
00881         tyint = tyintsave;
00882 }

00323 {
00324         int n, parity;
00325         char *s0;
00326         register char *s, *se, *t;
00327         register k;
00328 
00329         s0 = s = lexline(&n);
00330         se = t = s + n;
00331 
00332         /* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
00333         /* following FORMAT... */
00334 
00335         if (n <= 0)
00336                 warn("No (...) after FORMAT");
00337         else if (*s != '(')
00338                 warni("%c rather than ( after FORMAT", *s);
00339         else if (se[-1] != ')') {
00340                 *se = 0;
00341                 while(--t > s && *t != ')') ;
00342                 if (t <= s)
00343                         warn("No ) at end of FORMAT statement");
00344                 else if (se - t > 30)
00345                         warn1("Extraneous text at end of FORMAT: ...%s", se-12);
00346                 else
00347                         warn1("Extraneous text at end of FORMAT: %s", t+1);
00348                 t = se;
00349                 }
00350 
00351         /* fix MYQUOTES (\002's) and \\'s */
00352 
00353         parity = 1;
00354         while(s < se)
00355                 switch(*s++) {
00356                         case 2:
00357                                 if ((parity ^= 1) && *s == 2) {
00358                                         t -= 2;
00359                                         ++s;
00360                                         }
00361                                 else
00362                                         t += 3;
00363                                 break;
00364                         case '"':
00365                         case '\\':
00366                                 t++; break;
00367                         }
00368         s = s0;
00369         parity = 1;
00370         if (lp) {
00371                 lp->fmtstring = t = mem((int)(t - s + 1), 0);
00372                 while(s < se)
00373                         switch(k = *s++) {
00374                                 case 2:
00375                                         if ((parity ^= 1) && *s == 2)
00376                                                 s++;
00377                                         else {
00378                                                 t[0] = '\\';
00379                                                 t[1] = '0';
00380                                                 t[2] = '0';
00381                                                 t[3] = '2';
00382                                                 t += 4;
00383                                                 }
00384                                         break;
00385                                 case '"':
00386                                 case '\\':
00387                                         *t++ = '\\';
00388                                         /* no break */
00389                                 default:
00390                                         *t++ = k;
00391                                 }
00392                 *t = 0;
00393                 }
00394         flline();
00395 }

00404 {
00405         register int i;
00406 
00407         inioctl = YES;
00408         nioctl = 0;
00409         ioformatted = UNFORMATTED;
00410         for(i = 1 ; i<=NIOS ; ++i)
00411                 V(i) = NULL;
00412 }

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 }

 {
        "alist",
        "aerr",
        "aunit"
        }

 {
        "cilist",
        "cierr",
        "ciunit",
        "ciend",
        "cifmt",
        "cirec"
        }

 {
        "cllist",
        "cerr",
        "cunit",
        "csta"
        }

 {
        "icilist",
        "icierr",
        "iciunit",
        "iciend",
        "icifmt",
        "icirlen",
        "icirnum"
        }

 {
        "inlist",
        "inerr",
        "inunit",
        "infile",
        "infilen",
        "inex",
        "inopen",
        "innum",
        "innamed",
        "inname",
        "innamlen",
        "inacc",
        "inacclen",
        "inseq",
        "inseqlen",
        "indir",
        "indirlen",
        "infmt",
        "infmtlen",
        "inform",
        "informlen",
        "inunf",
        "inunflen",
        "inrecl",
        "innrec",
        "inblank",
        "inblanklen"
        }

 {
        zork(cilist_names, TYCILIST),   
        zork(inlist_names, TYINLIST),   
        zork(olist_names,  TYOLIST),    
        zork(cllist_names, TYCLLIST),   
        zork(alist_names,  TYALIST),    
        zork(alist_names,  TYALIST),    
        zork(alist_names,  TYALIST),    
        zork(icilist_names,TYICILIST),  
        zork(icilist_names,TYICILIST)   
        }

 {
        "olist",
        "oerr",
        "ounit",
        "ofnm",
        "ofnmlen",
        "osta",
        "oacc",
        "ofm",
        "orl",
        "oblnk"
        }

 {

                0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15



                }