sources/f2c/io.c

   1 /****************************************************************
   2 Copyright 1990 by AT&T Bell Laboratories and Bellcore.
   3
   4 Permission to use, copy, modify, and distribute this software
   5 and its documentation for any purpose and without fee is hereby
   6 granted, provided that the above copyright notice appear in all
   7 copies and that both that the copyright notice and this
   8 permission notice and warranty disclaimer appear in supporting
   9 documentation, and that the names of AT&T Bell Laboratories or
  10 Bellcore or any of their entities not be used in advertising or
  11 publicity pertaining to distribution of the software without
  12 specific, written prior permission.
  13
  14 AT&T and Bellcore disclaim all warranties with regard to this
  15 software, including all implied warranties of merchantability
  16 and fitness.  In no event shall AT&T or Bellcore be liable for
  17 any special, indirect or consequential damages or any damages
  18 whatsoever resulting from loss of use, data or profits, whether
  19 in an action of contract, negligence or other tortious action,
  20 arising out of or in connection with the use or performance of
  21 this software.
  22 ****************************************************************/
  23
  24 /* Routines to generate code for I/O statements.
  25    Some corrections and improvements due to David Wasley, U. C. Berkeley
  26 */
  27
  28 /* TEMPORARY */
  29 #define TYIOINT TYLONG
  30 #define SZIOINT SZLONG
  31
  32 #include "defs.h"
  33 #include "names.h"
  34 #include "iob.h"
  35
  36 extern int inqmask;
  37
  38 LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
  39         doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
  40         putio(), putiocall();
  41
  42 iob_data *iob_list;
  43 Addrp io_structs[9];
  44
  45 LOCAL char ioroutine[12];
  46
  47 LOCAL long ioendlab;
  48 LOCAL long ioerrlab;
  49 LOCAL int endbit;
  50 LOCAL int errbit;
  51 LOCAL long jumplab;
  52 LOCAL long skiplab;
  53 LOCAL int ioformatted;
  54 LOCAL int statstruct = NO;
  55 LOCAL struct Labelblock *skiplabel;
  56 Addrp ioblkp;
  57
  58 #define UNFORMATTED 0
  59 #define FORMATTED 1
  60 #define LISTDIRECTED 2
  61 #define NAMEDIRECTED 3
  62
  63 #define V(z)    ioc[z].iocval
  64
  65 #define IOALL 07777
  66
  67 LOCAL struct Ioclist
  68 {
  69         char *iocname;
  70         int iotype;
  71         expptr iocval;
  72 }
  73 ioc[ ] =
  74 {
  75         { "", 0 },
  76         { "unit", IOALL },
  77         { "fmt", M(IOREAD) | M(IOWRITE) },
  78         { "err", IOALL },
  79         { "end", M(IOREAD) },
  80         { "iostat", IOALL },
  81         { "rec", M(IOREAD) | M(IOWRITE) },
  82         { "recl", M(IOOPEN) | M(IOINQUIRE) },
  83         { "file", M(IOOPEN) | M(IOINQUIRE) },
  84         { "status", M(IOOPEN) | M(IOCLOSE) },
  85         { "access", M(IOOPEN) | M(IOINQUIRE) },
  86         { "form", M(IOOPEN) | M(IOINQUIRE) },
  87         { "blank", M(IOOPEN) | M(IOINQUIRE) },
  88         { "exist", M(IOINQUIRE) },
  89         { "opened", M(IOINQUIRE) },
  90         { "number", M(IOINQUIRE) },
  91         { "named", M(IOINQUIRE) },
  92         { "name", M(IOINQUIRE) },
  93         { "sequential", M(IOINQUIRE) },
  94         { "direct", M(IOINQUIRE) },
  95         { "formatted", M(IOINQUIRE) },
  96         { "unformatted", M(IOINQUIRE) },
  97         { "nextrec", M(IOINQUIRE) }
  98 };
  99
 100 #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
 101 #define MAXIO   SZFLAG + 10*SZIOINT + 15*SZADDR
 102
 103 /* #define IOSUNIT 1 */
 104 /* #define IOSFMT 2 */
 105 #define IOSERR 3
 106 #define IOSEND 4
 107 #define IOSIOSTAT 5
 108 #define IOSREC 6
 109 #define IOSRECL 7
 110 #define IOSFILE 8
 111 #define IOSSTATUS 9
 112 #define IOSACCESS 10
 113 #define IOSFORM 11
 114 #define IOSBLANK 12
 115 #define IOSEXISTS 13
 116 #define IOSOPENED 14
 117 #define IOSNUMBER 15
 118 #define IOSNAMED 16
 119 #define IOSNAME 17
 120 #define IOSSEQUENTIAL 18
 121 #define IOSDIRECT 19
 122 #define IOSFORMATTED 20
 123 #define IOSUNFORMATTED 21
 124 #define IOSNEXTREC 22
 125
 126 #define IOSTP V(IOSIOSTAT)
 127
 128
 129 /* offsets in generated structures */
 130
 131 #define SZFLAG SZIOINT
 132
 133 /* offsets for external READ and WRITE statements */
 134
 135 #define XERR 0
 136 #define XUNIT   SZFLAG
 137 #define XEND    SZFLAG + SZIOINT
 138 #define XFMT    2*SZFLAG + SZIOINT
 139 #define XREC    2*SZFLAG + SZIOINT + SZADDR
 140 #define XRLEN   2*SZFLAG + 2*SZADDR
 141 #define XRNUM   2*SZFLAG + 2*SZADDR + SZIOINT
 142
 143 /* offsets for internal READ and WRITE statements */
 144
 145 #define XIERR   0
 146 #define XIUNIT  SZFLAG
 147 #define XIEND   SZFLAG + SZADDR
 148 #define XIFMT   2*SZFLAG + SZADDR
 149 #define XIRLEN  2*SZFLAG + 2*SZADDR
 150 #define XIRNUM  2*SZFLAG + 2*SZADDR + SZIOINT
 151 #define XIREC   2*SZFLAG + 2*SZADDR + 2*SZIOINT
 152
 153 /* offsets for OPEN statements */
 154
 155 #define XFNAME  SZFLAG + SZIOINT
 156 #define XFNAMELEN       SZFLAG + SZIOINT + SZADDR
 157 #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
 158 #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
 159 #define XFORMATTED      SZFLAG + 2*SZIOINT + 3*SZADDR
 160 #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
 161 #define XBLANK  SZFLAG + 3*SZIOINT + 4*SZADDR
 162
 163 /* offset for CLOSE statement */
 164
 165 #define XCLSTATUS       SZFLAG + SZIOINT
 166
 167 /* offsets for INQUIRE statement */
 168
 169 #define XFILE   SZFLAG + SZIOINT
 170 #define XFILELEN        SZFLAG + SZIOINT + SZADDR
 171 #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
 172 #define XOPEN   SZFLAG + 2*SZIOINT + 2*SZADDR
 173 #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
 174 #define XNAMED  SZFLAG + 2*SZIOINT + 4*SZADDR
 175 #define XNAME   SZFLAG + 2*SZIOINT + 5*SZADDR
 176 #define XNAMELEN        SZFLAG + 2*SZIOINT + 6*SZADDR
 177 #define XQACCESS        SZFLAG + 3*SZIOINT + 6*SZADDR
 178 #define XQACCLEN        SZFLAG + 3*SZIOINT + 7*SZADDR
 179 #define XSEQ    SZFLAG + 4*SZIOINT + 7*SZADDR
 180 #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
 181 #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
 182 #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
 183 #define XFORM   SZFLAG + 6*SZIOINT + 9*SZADDR
 184 #define XFORMLEN        SZFLAG + 6*SZIOINT + 10*SZADDR
 185 #define XFMTED  SZFLAG + 7*SZIOINT + 10*SZADDR
 186 #define XFMTEDLEN       SZFLAG + 7*SZIOINT + 11*SZADDR
 187 #define XUNFMT  SZFLAG + 8*SZIOINT + 11*SZADDR
 188 #define XUNFMTLEN       SZFLAG + 8*SZIOINT + 12*SZADDR
 189 #define XQRECL  SZFLAG + 9*SZIOINT + 12*SZADDR
 190 #define XNEXTREC        SZFLAG + 9*SZIOINT + 13*SZADDR
 191 #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
 192 #define XQBLANKLEN      SZFLAG + 9*SZIOINT + 15*SZADDR
 193
 194 LOCAL char *cilist_names[] = {
 195         "cilist",
 196         "cierr",
 197         "ciunit",
 198         "ciend",
 199         "cifmt",
 200         "cirec"
 201         };
 202 LOCAL char *icilist_names[] = {
 203         "icilist",
 204         "icierr",
 205         "iciunit",
 206         "iciend",
 207         "icifmt",
 208         "icirlen",
 209         "icirnum"
 210         };
 211 LOCAL char *olist_names[] = {
 212         "olist",
 213         "oerr",
 214         "ounit",
 215         "ofnm",
 216         "ofnmlen",
 217         "osta",
 218         "oacc",
 219         "ofm",
 220         "orl",
 221         "oblnk"
 222         };
 223 LOCAL char *cllist_names[] = {
 224         "cllist",
 225         "cerr",
 226         "cunit",
 227         "csta"
 228         };
 229 LOCAL char *alist_names[] = {
 230         "alist",
 231         "aerr",
 232         "aunit"
 233         };
 234 LOCAL char *inlist_names[] = {
 235         "inlist",
 236         "inerr",
 237         "inunit",
 238         "infile",
 239         "infilen",
 240         "inex",
 241         "inopen",
 242         "innum",
 243         "innamed",
 244         "inname",
 245         "innamlen",
 246         "inacc",
 247         "inacclen",
 248         "inseq",
 249         "inseqlen",
 250         "indir",
 251         "indirlen",
 252         "infmt",
 253         "infmtlen",
 254         "inform",
 255         "informlen",
 256         "inunf",
 257         "inunflen",
 258         "inrecl",
 259         "innrec",
 260         "inblank",
 261         "inblanklen"
 262         };
 263
 264 LOCAL char **io_fields;
 265
 266 #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
 267
 268 LOCAL io_setup io_stuff[] = {
 269         zork(cilist_names, TYCILIST),   /* external read/write */
 270         zork(inlist_names, TYINLIST),   /* inquire */
 271         zork(olist_names,  TYOLIST),    /* open */
 272         zork(cllist_names, TYCLLIST),   /* close */
 273         zork(alist_names,  TYALIST),    /* rewind */
 274         zork(alist_names,  TYALIST),    /* backspace */
 275         zork(alist_names,  TYALIST),    /* endfile */
 276         zork(icilist_names,TYICILIST),  /* internal read */
 277         zork(icilist_names,TYICILIST)   /* internal write */
 278         };
 279
 280 #undef zork
 281
 282
 283 fmtstmt(lp)
 284 register struct Labelblock *lp;
 285 {
 286         if(lp == NULL)
 287         {
 288                 execerr("unlabeled format statement" , CNULL);
 289                 return(-1);
 290         }
 291         if(lp->labtype == LABUNKNOWN)
 292         {
 293                 lp->labtype = LABFORMAT;
 294                 lp->labelno = newlabel();
 295         }
 296         else if(lp->labtype != LABFORMAT)
 297         {
 298                 execerr("bad format number", CNULL);
 299                 return(-1);
 300         }
 301         return(lp->labelno);
 302 }
 303
 304
 305 setfmt(lp)
 306 struct Labelblock *lp;
 307 {
 308         int n;
 309         char *s0, *lexline();
 310         register char *s, *se, *t;
 311         register k;
 312
 313         s0 = s = lexline(&n);
 314         se = t = s + n;
 315
 316         /* warn of trivial errors, e.g. "  11 CONTINUE" (one too few spaces) */
 317         /* following FORMAT... */
 318
 319         if (n <= 0)
 320                 warn("No (...) after FORMAT");
 321         else if (*s != '(')
 322                 warni("%c rather than ( after FORMAT", *s);
 323         else if (se[-1] != ')') {
 324                 *se = 0;
 325                 while(--t > s && *t != ')') ;
 326                 if (t <= s)
 327                         warn("No ) at end of FORMAT statement");
 328                 else if (se - t > 30)
 329                         warn1("Extraneous text at end of FORMAT: ...%s", se-12);
 330                 else
 331                         warn1("Extraneous text at end of FORMAT: %s", t+1);
 332                 t = se;
 333                 }
 334
 335         /* fix MYQUOTES (\002's) and \\'s */
 336
 337         while(s < se)
 338                 switch(*s++) {
 339                         case 2:
 340                                 t += 3; break;
 341                         case '"':
 342                         case '\\':
 343                                 t++; break;
 344                         }
 345         s = s0;
 346         lp->fmtstring = t = mem(t - s + 1, 0);
 347         while(s < se)
 348                 switch(k = *s++) {
 349                         case 2:
 350                                 t[0] = '\\';
 351                                 t[1] = '0';
 352                                 t[2] = '0';
 353                                 t[3] = '2';
 354                                 t += 4;
 355                                 break;
 356                         case '"':
 357                         case '\\':
 358                                 *t++ = '\\';
 359                                 /* no break */
 360                         default:
 361                                 *t++ = k;
 362                         }
 363         *t = 0;
 364         flline();
 365 }
 366
 367
 368
 369 startioctl()
 370 {
 371         register int i;
 372
 373         inioctl = YES;
 374         nioctl = 0;
 375         ioformatted = UNFORMATTED;
 376         for(i = 1 ; i<=NIOS ; ++i)
 377                 V(i) = NULL;
 378 }
 379
 380  static long
 381 newiolabel() {
 382         long rv;
 383         rv = ++lastiolabno;
 384         skiplabel = mklabel(rv);
 385         skiplabel->labdefined = 1;
 386         return rv;
 387         }
 388
 389
 390 endioctl()
 391 {
 392         int i;
 393         expptr p;
 394         struct io_setup *ios;
 395
 396         inioctl = NO;
 397
 398         /* set up for error recovery */
 399
 400         ioerrlab = ioendlab = skiplab = jumplab = 0;
 401
 402         if(p = V(IOSEND))
 403                 if(ISICON(p))
 404                         execlab(ioendlab = p->constblock.Const.ci);
 405                 else
 406                         err("bad end= clause");
 407
 408         if(p = V(IOSERR))
 409                 if(ISICON(p))
 410                         execlab(ioerrlab = p->constblock.Const.ci);
 411                 else
 412                         err("bad err= clause");
 413
 414         if(IOSTP)
 415                 if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
 416                 {
 417                         err("iostat must be an integer variable");
 418                         frexpr(IOSTP);
 419                         IOSTP = NULL;
 420                 }
 421
 422         if(iostmt == IOREAD)
 423         {
 424                 if(IOSTP)
 425                 {
 426                         if(ioerrlab && ioendlab && ioerrlab==ioendlab)
 427                                 jumplab = ioerrlab;
 428                         else
 429                                 skiplab = jumplab = newiolabel();
 430                 }
 431                 else    {
 432                         if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
 433                         {
 434                                 IOSTP = (expptr) Mktemp(TYINT, ENULL);
 435                                 skiplab = jumplab = newiolabel();
 436                         }
 437                         else
 438                                 jumplab = (ioerrlab ? ioerrlab : ioendlab);
 439                 }
 440         }
 441         else if(iostmt == IOWRITE)
 442         {
 443                 if(IOSTP && !ioerrlab)
 444                         skiplab = jumplab = newiolabel();
 445                 else
 446                         jumplab = ioerrlab;
 447         }
 448         else
 449                 jumplab = ioerrlab;
 450
 451         endbit = IOSTP!=NULL || ioendlab!=0;    /* for use in startrw() */
 452         errbit = IOSTP!=NULL || ioerrlab!=0;
 453         if (jumplab && !IOSTP)
 454                 IOSTP = (expptr) Mktemp(TYINT, ENULL);
 455
 456         if(iostmt!=IOREAD && iostmt!=IOWRITE)
 457         {
 458                 ios = io_stuff + iostmt;
 459                 io_fields = ios->fields;
 460                 ioblkp = io_structs[iostmt];
 461                 if(ioblkp == NULL)
 462                         io_structs[iostmt] = ioblkp =
 463                                 autovar(1, ios->type, ENULL, "");
 464                 ioset(TYIOINT, XERR, ICON(errbit));
 465         }
 466
 467         switch(iostmt)
 468         {
 469         case IOOPEN:
 470                 dofopen();
 471                 break;
 472
 473         case IOCLOSE:
 474                 dofclose();
 475                 break;
 476
 477         case IOINQUIRE:
 478                 dofinquire();
 479                 break;
 480
 481         case IOBACKSPACE:
 482                 dofmove("f_back");
 483                 break;
 484
 485         case IOREWIND:
 486                 dofmove("f_rew");
 487                 break;
 488
 489         case IOENDFILE:
 490                 dofmove("f_end");
 491                 break;
 492
 493         case IOREAD:
 494         case IOWRITE:
 495                 startrw();
 496                 break;
 497
 498         default:
 499                 fatali("impossible iostmt %d", iostmt);
 500         }
 501         for(i = 1 ; i<=NIOS ; ++i)
 502                 if(i!=IOSIOSTAT && V(i)!=NULL)
 503                         frexpr(V(i));
 504 }
 505
 506
 507
 508 iocname()
 509 {
 510         register int i;
 511         int found, mask;
 512
 513         found = 0;
 514         mask = M(iostmt);
 515         for(i = 1 ; i <= NIOS ; ++i)
 516                 if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
 517                         if(ioc[i].iotype & mask)
 518                                 return(i);
 519                         else    found = i;
 520         if(found)
 521                 errstr("invalid control %s for statement", ioc[found].iocname);
 522         else
 523                 errstr("unknown iocontrol %s", token);
 524         return(IOSBAD);
 525 }
 526
 527
 528 ioclause(n, p)
 529 register int n;
 530 register expptr p;
 531 {
 532         struct Ioclist *iocp;
 533
 534         ++nioctl;
 535         if(n == IOSBAD)
 536                 return;
 537         if(n == IOSPOSITIONAL)
 538                 {
 539                 n = nioctl;
 540                 if (nioctl == IOSFMT) {
 541                         if (iostmt == IOOPEN) {
 542                                 n = IOSFILE;
 543                                 NOEXT("file= specifier omitted from open");
 544                                 }
 545                         else if (iostmt < IOREAD)
 546                                 goto illegal;
 547                         }
 548                 else if(nioctl > IOSFMT)
 549                         {
 550  illegal:
 551                         err("illegal positional iocontrol");
 552                         return;
 553                         }
 554                 }
 555
 556         if(p == NULL)
 557         {
 558                 if(n == IOSUNIT)
 559                         p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
 560                 else if(n != IOSFMT)
 561                 {
 562                         err("illegal * iocontrol");
 563                         return;
 564                 }
 565         }
 566         if(n == IOSFMT)
 567                 ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
 568
 569         iocp = & ioc[n];
 570         if(iocp->iocval == NULL)
 571         {
 572                 if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) )
 573                         p = fixtype(p);
 574                 iocp->iocval = p;
 575         }
 576         else
 577                 errstr("iocontrol %s repeated", iocp->iocname);
 578 }
 579
 580 /* io list item */
 581
 582 doio(list)
 583 chainp list;
 584 {
 585         expptr call0();
 586
 587         if(ioformatted == NAMEDIRECTED)
 588         {
 589                 if(list)
 590                         err("no I/O list allowed in NAMELIST read/write");
 591         }
 592         else
 593         {
 594                 doiolist(list);
 595                 ioroutine[0] = 'e';
 596                 jumplab = 0;
 597                 putiocall( call0(TYINT, ioroutine) );
 598         }
 599 }
 600
 601
 602
 603
 604
 605  LOCAL void
 606 doiolist(p0)
 607  chainp p0;
 608 {
 609         chainp p;
 610         register tagptr q;
 611         register expptr qe;
 612         register Namep qn;
 613         Addrp tp, mkscalar();
 614         int range;
 615
 616         for (p = p0 ; p ; p = p->nextp)
 617         {
 618                 q = (tagptr)p->datap;
 619                 if(q->tag == TIMPLDO)
 620                 {
 621                         exdo(range=newlabel(), (Namep)0,
 622                                 q->impldoblock.impdospec);
 623                         doiolist(q->impldoblock.datalist);
 624                         enddo(range);
 625                         free( (charptr) q);
 626                 }
 627                 else    {
 628                         if(q->tag==TPRIM && q->primblock.argsp==NULL
 629                             && q->primblock.namep->vdim!=NULL)
 630                         {
 631                                 vardcl(qn = q->primblock.namep);
 632                                 if(qn->vdim->nelt) {
 633                                         putio( fixtype(cpexpr(qn->vdim->nelt)),
 634                                             (expptr)mkscalar(qn) );
 635                                         qn->vlastdim = 0;
 636                                         }
 637                                 else
 638                                         err("attempt to i/o array of unknown size");
 639                         }
 640                         else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
 641                             (qe = (expptr) memversion(q->primblock.namep)) )
 642                                 putio(ICON(1),qe);
 643                         else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
 644                             (qe->addrblock.uname_tag != UNAM_CONST ||
 645                             !ISCOMPLEX(qe -> addrblock.vtype))) ||
 646                             (qe -> tag == TCONST && !ISCOMPLEX(qe ->
 647                             headblock.vtype))) {
 648                                 if (qe -> tag == TCONST)
 649                                         qe = (expptr) putconst((Constp)qe);
 650                                 putio(ICON(1), qe);
 651                         }
 652                         else if(qe->headblock.vtype != TYERROR)
 653                         {
 654                                 if(iostmt == IOWRITE)
 655                                 {
 656                                         ftnint lencat();
 657                                         expptr qvl;
 658                                         qvl = NULL;
 659                                         if( ISCHAR(qe) )
 660                                         {
 661                                                 qvl = (expptr)
 662                                                     cpexpr(qe->headblock.vleng);
 663                                                 tp = Mktemp(qe->headblock.vtype,
 664                                                     ICON(lencat(qe)));
 665                                         }
 666                                         else
 667                                                 tp = Mktemp(qe->headblock.vtype,
 668                                                     qe->headblock.vleng);
 669                                         puteq( cpexpr((expptr)tp), qe);
 670                                         if(qvl) /* put right length on block */
 671                                         {
 672                                                 frexpr(tp->vleng);
 673                                                 tp->vleng = qvl;
 674                                         }
 675                                         putio(ICON(1), (expptr)tp);
 676                                 }
 677                                 else
 678                                         err("non-left side in READ list");
 679                         }
 680                         frexpr(q);
 681                 }
 682         }
 683         frchain( &p0 );
 684 }
 685
 686  int iocalladdr = TYADDR;       /* for fixing TYADDR in saveargtypes */
 687
 688  LOCAL void
 689 putio(nelt, addr)
 690  expptr nelt;
 691  register expptr addr;
 692 {
 693         int type;
 694         register expptr q;
 695         extern Constp mkconst();
 696         register Addrp c = 0;
 697
 698         type = addr->headblock.vtype;
 699         if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
 700         {
 701                 nelt = mkexpr(OPSTAR, ICON(2), nelt);
 702                 type -= (TYCOMPLEX-TYREAL);
 703         }
 704
 705         /* pass a length with every item.  for noncharacter data, fake one */
 706         if(type != TYCHAR)
 707         {
 708
 709                 if( ISCONST(addr) )
 710                         addr = (expptr) putconst((Constp)addr);
 711                 c = ALLOC(Addrblock);
 712                 c->tag = TADDR;
 713                 c->vtype = TYLENG;
 714                 c->vstg = STGAUTO;
 715                 c->ntempelt = 1;
 716                 c->isarray = 1;
 717                 c->memoffset = ICON(0);
 718                 c->uname_tag = UNAM_IDENT;
 719                 c->charleng = 1;
 720                 sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
 721                 addr = mkexpr(OPCHARCAST, addr, ENULL);
 722         }
 723
 724         nelt = fixtype( mkconv(TYLENG,nelt) );
 725         if(ioformatted == LISTDIRECTED) {
 726                 expptr mc = mkconv(TYLONG, ICON(type));
 727                 q = c   ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
 728                         : call3(TYINT, "do_lio", mc, nelt, addr);
 729                 }
 730         else {
 731                 char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
 732                 q = c   ? call3(TYINT, s, nelt, addr, (expptr)c)
 733                         : call2(TYINT, s, nelt, addr);
 734                 }
 735         iocalladdr = TYCHAR;
 736         putiocall(q);
 737         iocalladdr = TYADDR;
 738 }
 739
 740
 741
 742
 743 endio()
 744 {
 745         extern void p1_label();
 746
 747         if(skiplab)
 748         {
 749                 p1_label((long)(skiplabel - labeltab));
 750                 if(ioendlab) {
 751                         exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
 752                         exgoto(execlab(ioendlab));
 753                         exendif();
 754                         }
 755                 if(ioerrlab) {
 756                         exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
 757                                         ? OPGT : OPNE,
 758                                 cpexpr(IOSTP), ICON(0)));
 759                         exgoto(execlab(ioerrlab));
 760                         exendif();
 761                         }
 762         }
 763
 764         if(IOSTP)
 765                 frexpr(IOSTP);
 766 }
 767
 768
 769
 770  LOCAL void
 771 putiocall(q)
 772  register expptr q;
 773 {
 774         int tyintsave;
 775
 776         tyintsave = tyint;
 777         tyint = tyioint;        /* for -I2 and -i2 */
 778
 779         if(IOSTP)
 780         {
 781                 q->headblock.vtype = TYINT;
 782                 q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
 783         }
 784         putexpr(q);
 785         if(jumplab) {
 786                 exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
 787                 exgoto(execlab(jumplab));
 788                 exendif();
 789                 }
 790         tyint = tyintsave;
 791 }
 792
 793  void
 794 fmtname(np, q)
 795  Namep np;
 796  register Addrp q;
 797 {
 798         register int k;
 799         register char *s, *t;
 800         extern chainp assigned_fmts;
 801
 802         if (!np->vfmt_asg) {
 803                 np->vfmt_asg = 1;
 804                 assigned_fmts = mkchain((char *)np, assigned_fmts);
 805                 }
 806         k = strlen(s = np->fvarname);
 807         if (k < IDENT_LEN - 4) {
 808                 q->uname_tag = UNAM_IDENT;
 809                 t = q->user.ident;
 810                 }
 811         else {
 812                 q->uname_tag = UNAM_CHARP;
 813                 q->user.Charp = t = mem(k + 5,0);
 814                 }
 815         sprintf(t, "%s_fmt", s);
 816         }
 817
 818 LOCAL Addrp asg_addr(p)
 819  union Expression *p;
 820 {
 821         register Addrp q;
 822
 823         if (p->tag != TPRIM)
 824                 badtag("asg_addr", p->tag);
 825         q = ALLOC(Addrblock);
 826         q->tag = TADDR;
 827         q->vtype = TYCHAR;
 828         q->vstg = STGAUTO;
 829         q->ntempelt = 1;
 830         q->isarray = 0;
 831         q->memoffset = ICON(0);
 832         fmtname(p->primblock.namep, q);
 833         return q;
 834         }
 835
 836 startrw()
 837 {
 838         register expptr p;
 839         register Namep np;
 840         register Addrp unitp, fmtp, recp;
 841         register expptr nump;
 842         Addrp mkscalar();
 843         expptr mkaddcon();
 844         int iostmt1;
 845         flag intfile, sequential, ok, varfmt;
 846         struct io_setup *ios;
 847
 848         /* First look at all the parameters and determine what is to be done */
 849
 850         ok = YES;
 851         statstruct = YES;
 852
 853         intfile = NO;
 854         if(p = V(IOSUNIT))
 855         {
 856                 if( ISINT(p->headblock.vtype) )
 857                         unitp = (Addrp) cpexpr(p);
 858                 else if(p->headblock.vtype == TYCHAR)
 859                 {
 860                         intfile = YES;
 861                         if(p->tag==TPRIM && p->primblock.argsp==NULL &&
 862                             (np = p->primblock.namep)->vdim!=NULL)
 863                         {
 864                                 vardcl(np);
 865                                 if(np->vdim->nelt)
 866                                 {
 867                                         nump = (expptr) cpexpr(np->vdim->nelt);
 868                                         if( ! ISCONST(nump) )
 869                                                 statstruct = NO;
 870                                 }
 871                                 else
 872                                 {
 873                                         err("attempt to use internal unit array of unknown size");
 874                                         ok = NO;
 875                                         nump = ICON(1);
 876                                 }
 877                                 unitp = mkscalar(np);
 878                         }
 879                         else    {
 880                                 nump = ICON(1);
 881                                 unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
 882                         }
 883                         if(! isstatic((expptr)unitp) )
 884                                 statstruct = NO;
 885                 }
 886         }
 887         else
 888         {
 889                 err("bad unit specifier");
 890                 ok = NO;
 891         }
 892
 893         sequential = YES;
 894         if(p = V(IOSREC))
 895                 if( ISINT(p->headblock.vtype) )
 896                 {
 897                         recp = (Addrp) cpexpr(p);
 898                         sequential = NO;
 899                 }
 900                 else    {
 901                         err("bad REC= clause");
 902                         ok = NO;
 903                 }
 904         else
 905                 recp = NULL;
 906
 907
 908         varfmt = YES;
 909         fmtp = NULL;
 910         if(p = V(IOSFMT))
 911         {
 912                 if(p->tag==TPRIM && p->primblock.argsp==NULL)
 913                 {
 914                         np = p->primblock.namep;
 915                         if(np->vclass == CLNAMELIST)
 916                         {
 917                                 ioformatted = NAMEDIRECTED;
 918                                 fmtp = (Addrp) fixtype(p);
 919                                 V(IOSFMT) = (expptr)fmtp;
 920                                 goto endfmt;
 921                         }
 922                         vardcl(np);
 923                         if(np->vdim)
 924                         {
 925                                 if( ! ONEOF(np->vstg, MSKSTATIC) )
 926                                         statstruct = NO;
 927                                 fmtp = mkscalar(np);
 928                                 goto endfmt;
 929                         }
 930                         if( ISINT(np->vtype) )  /* ASSIGNed label */
 931                         {
 932                                 statstruct = NO;
 933                                 varfmt = YES;
 934                                 fmtp = asg_addr(p);
 935                                 goto endfmt;
 936                         }
 937                 }
 938                 p = V(IOSFMT) = fixtype(p);
 939                 if(p->headblock.vtype == TYCHAR
 940                         /* Since we allow write(6,n)            */
 941                         /* we may as well allow write(6,n(2))   */
 942                 || p->tag == TADDR && ISINT(p->addrblock.vtype))
 943                 {
 944                         if( ! isstatic(p) )
 945                                 statstruct = NO;
 946                         fmtp = (Addrp) cpexpr(p);
 947                 }
 948                 else if( ISICON(p) )
 949                 {
 950                         struct Labelblock *lp;
 951                         lp = mklabel(p->constblock.Const.ci);
 952                         if (fmtstmt(lp) > 0)
 953                         {
 954                                 fmtp = (Addrp)mkaddcon(lp->stateno);
 955                                 /* lp->stateno for names fmt_nnn */
 956                                 lp->fmtlabused = 1;
 957                                 varfmt = NO;
 958                         }
 959                         else
 960                                 ioformatted = UNFORMATTED;
 961                 }
 962                 else    {
 963                         err("bad format descriptor");
 964                         ioformatted = UNFORMATTED;
 965                         ok = NO;
 966                 }
 967         }
 968         else
 969                 fmtp = NULL;
 970
 971 endfmt:
 972         if(intfile) {
 973                 if (ioformatted==UNFORMATTED) {
 974                         err("unformatted internal I/O not allowed");
 975                         ok = NO;
 976                         }
 977                 if (recp) {
 978                         err("direct internal I/O not allowed");
 979                         ok = NO;
 980                         }
 981                 }
 982         if(!sequential && ioformatted==LISTDIRECTED)
 983         {
 984                 err("direct list-directed I/O not allowed");
 985                 ok = NO;
 986         }
 987         if(!sequential && ioformatted==NAMEDIRECTED)
 988         {
 989                 err("direct namelist I/O not allowed");
 990                 ok = NO;
 991         }
 992
 993         if( ! ok )
 994                 return;
 995
 996         /*
 997    Now put out the I/O structure, statically if all the clauses
 998    are constants, dynamically otherwise
 999 */
1000
1001         if (intfile) {
1002                 ios = io_stuff + iostmt;
1003                 iostmt1 = IOREAD;
1004                 }
1005         else {
1006                 ios = io_stuff;
1007                 iostmt1 = 0;
1008                 }
1009         io_fields = ios->fields;
1010         if(statstruct)
1011         {
1012                 ioblkp = ALLOC(Addrblock);
1013                 ioblkp->tag = TADDR;
1014                 ioblkp->vtype = ios->type;
1015                 ioblkp->vclass = CLVAR;
1016                 ioblkp->vstg = STGINIT;
1017                 ioblkp->memno = ++lastvarno;
1018                 ioblkp->memoffset = ICON(0);
1019                 ioblkp -> uname_tag = UNAM_IDENT;
1020                 new_iob_data(ios,
1021                         temp_name("io_", lastvarno, ioblkp->user.ident));                       }
1022         else if(!(ioblkp = io_structs[iostmt1]))
1023                 io_structs[iostmt1] = ioblkp =
1024                         autovar(1, ios->type, ENULL, "");
1025
1026         ioset(TYIOINT, XERR, ICON(errbit));
1027         if(iostmt == IOREAD)
1028                 ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
1029
1030         if(intfile)
1031         {
1032                 ioset(TYIOINT, XIRNUM, nump);
1033                 ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
1034                 ioseta(XIUNIT, unitp);
1035         }
1036         else
1037                 ioset(TYIOINT, XUNIT, (expptr) unitp);
1038
1039         if(recp)
1040                 ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
1041
1042         if(varfmt)
1043                 ioseta( intfile ? XIFMT : XFMT , fmtp);
1044         else
1045                 ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
1046
1047         ioroutine[0] = 's';
1048         ioroutine[1] = '_';
1049         ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
1050         ioroutine[3] = "ds"[sequential];
1051         ioroutine[4] = "ufln"[ioformatted];
1052         ioroutine[5] = "ei"[intfile];
1053         ioroutine[6] = '\0';
1054
1055         putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
1056
1057         if(statstruct)
1058         {
1059                 frexpr((expptr)ioblkp);
1060                 statstruct = NO;
1061                 ioblkp = 0;     /* unnecessary */
1062         }
1063 }
1064
1065
1066
1067  LOCAL void
1068 dofopen()
1069 {
1070         register expptr p;
1071
1072         if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
1073                 ioset(TYIOINT, XUNIT, cpexpr(p) );
1074         else
1075                 err("bad unit in open");
1076         if( (p = V(IOSFILE)) )
1077                 if(p->headblock.vtype == TYCHAR)
1078                         ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
1079                 else
1080                         err("bad file in open");
1081
1082         iosetc(XFNAME, p);
1083
1084         if(p = V(IOSRECL))
1085                 if( ISINT(p->headblock.vtype) )
1086                         ioset(TYIOINT, XRECLEN, cpexpr(p) );
1087                 else
1088                         err("bad recl");
1089         else
1090                 ioset(TYIOINT, XRECLEN, ICON(0) );
1091
1092         iosetc(XSTATUS, V(IOSSTATUS));
1093         iosetc(XACCESS, V(IOSACCESS));
1094         iosetc(XFORMATTED, V(IOSFORM));
1095         iosetc(XBLANK, V(IOSBLANK));
1096
1097         putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
1098 }
1099
1100
1101  LOCAL void
1102 dofclose()
1103 {
1104         register expptr p;
1105
1106         if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
1107         {
1108                 ioset(TYIOINT, XUNIT, cpexpr(p) );
1109                 iosetc(XCLSTATUS, V(IOSSTATUS));
1110                 putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
1111         }
1112         else
1113                 err("bad unit in close statement");
1114 }
1115
1116
1117  LOCAL void
1118 dofinquire()
1119 {
1120         register expptr p;
1121         if(p = V(IOSUNIT))
1122         {
1123                 if( V(IOSFILE) )
1124                         err("inquire by unit or by file, not both");
1125                 ioset(TYIOINT, XUNIT, cpexpr(p) );
1126         }
1127         else if( ! V(IOSFILE) )
1128                 err("must inquire by unit or by file");
1129         iosetlc(IOSFILE, XFILE, XFILELEN);
1130         iosetip(IOSEXISTS, XEXISTS);
1131         iosetip(IOSOPENED, XOPEN);
1132         iosetip(IOSNUMBER, XNUMBER);
1133         iosetip(IOSNAMED, XNAMED);
1134         iosetlc(IOSNAME, XNAME, XNAMELEN);
1135         iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
1136         iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
1137         iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
1138         iosetlc(IOSFORM, XFORM, XFORMLEN);
1139         iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
1140         iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
1141         iosetip(IOSRECL, XQRECL);
1142         iosetip(IOSNEXTREC, XNEXTREC);
1143         iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
1144
1145         putiocall( call1(TYINT,  "f_inqu", cpexpr((expptr)ioblkp) ));
1146 }
1147
1148
1149
1150  LOCAL void
1151 dofmove(subname)
1152  char *subname;
1153 {
1154         register expptr p;
1155
1156         if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
1157         {
1158                 ioset(TYIOINT, XUNIT, cpexpr(p) );
1159                 putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
1160         }
1161         else
1162                 err("bad unit in I/O motion statement");
1163 }
1164
1165 static int ioset_assign = OPASSIGN;
1166
1167  LOCAL void
1168 ioset(type, offset, p)
1169  int type, offset;
1170  register expptr p;
1171 {
1172         offset /= SZLONG;
1173         if(statstruct && ISCONST(p)) {
1174                 register char *s;
1175                 switch(type) {
1176                         case TYADDR:    /* stmt label */
1177                                 s = "fmt_";
1178                                 break;
1179                         case TYIOINT:
1180                                 s = "";
1181                                 break;
1182                         default:
1183                                 badtype("ioset", type);
1184                         }
1185                 iob_list->fields[offset] =
1186                         string_num(s, p->constblock.Const.ci);
1187                 frexpr(p);
1188                 }
1189         else {
1190                 register Addrp q;
1191
1192                 q = ALLOC(Addrblock);
1193                 q->tag = TADDR;
1194                 q->vtype = type;
1195                 q->vstg = STGAUTO;
1196                 q->ntempelt = 1;
1197                 q->isarray = 0;
1198                 q->memoffset = ICON(0);
1199                 q->uname_tag = UNAM_IDENT;
1200                 sprintf(q->user.ident, "%s.%s",
1201                         statstruct ? iob_list->name : ioblkp->user.ident,
1202                         io_fields[offset + 1]);
1203                 if (type == TYADDR && p->tag == TCONST
1204                                    && p->constblock.vtype == TYADDR) {
1205                         /* kludge */
1206                         register Addrp p1;
1207                         p1 = ALLOC(Addrblock);
1208                         p1->tag = TADDR;
1209                         p1->vtype = type;
1210                         p1->vstg = STGAUTO;     /* wrong, but who cares? */
1211                         p1->ntempelt = 1;
1212                         p1->isarray = 0;
1213                         p1->memoffset = ICON(0);
1214                         p1->uname_tag = UNAM_IDENT;
1215                         sprintf(p1->user.ident, "fmt_%ld",
1216                                 p->constblock.Const.ci);
1217                         frexpr(p);
1218                         p = (expptr)p1;
1219                         }
1220                 if (type == TYADDR && p->headblock.vtype == TYCHAR)
1221                         q->vtype = TYCHAR;
1222                 putexpr(mkexpr(ioset_assign, (expptr)q, p));
1223                 }
1224 }
1225
1226
1227
1228
1229  LOCAL void
1230 iosetc(offset, p)
1231  int offset;
1232  register expptr p;
1233 {
1234         if(p == NULL)
1235                 ioset(TYADDR, offset, ICON(0) );
1236         else if(p->headblock.vtype == TYCHAR)
1237                 ioset(TYADDR, offset, addrof(cpexpr(p) ));
1238         else
1239                 err("non-character control clause");
1240 }
1241
1242
1243
1244  LOCAL void
1245 ioseta(offset, p)
1246  int offset;
1247  register Addrp p;
1248 {
1249         char *s, *s1;
1250         static char who[] = "ioseta";
1251         expptr e, mo;
1252         Namep np;
1253         ftnint ci;
1254         int k;
1255         char buf[24], buf1[24];
1256         Extsym *comm;
1257
1258         if(statstruct)
1259         {
1260                 if (!p)
1261                         return;
1262                 if (p->tag != TADDR)
1263                         badtag(who, p->tag);
1264                 offset /= SZLONG;
1265                 switch(p->uname_tag) {
1266                     case UNAM_NAME:
1267                         mo = p->memoffset;
1268                         if (mo->tag != TCONST)
1269                                 badtag("ioseta/memoffset", mo->tag);
1270                         np = p->user.name;
1271                         np->visused = 1;
1272                         ci = mo->constblock.Const.ci - np->voffset;
1273                         if (np->vstg == STGCOMMON && !np->vcommequiv) {
1274                                 comm = &extsymtab[np->vardesc.varno];
1275                                 sprintf(buf, "%d.", comm->curno);
1276                                 k = strlen(buf) + strlen(comm->cextname)
1277                                         + strlen(np->cvarname);
1278                                 if (ci) {
1279                                         sprintf(buf1, "+%ld", ci);
1280                                         k += strlen(buf1);
1281                                         }
1282                                 else
1283                                         buf1[0] = 0;
1284                                 s = mem(k + 1, 0);
1285                                 sprintf(s, "%s%s%s%s", comm->cextname, buf,
1286                                         np->cvarname, buf1);
1287                                 }
1288                         else if (ci) {
1289                                 sprintf(buf,"%ld", ci);
1290                                 s1 = p->user.name->cvarname;
1291                                 k = strlen(buf) + strlen(s1);
1292                                 sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
1293                                 }
1294                         else
1295                                 s = cpstring(p->user.name->cvarname);
1296                         break;
1297                     case UNAM_CONST:
1298                         s = tostring(p->user.Const.ccp1.ccp0,
1299                                 (int)p->vleng->constblock.Const.ci);
1300                         break;
1301                     default:
1302                         badthing("uname_tag", who, p->uname_tag);
1303                     }
1304                 /* kludge for Hollerith */
1305                 if (p->vtype != TYCHAR) {
1306                         s1 = mem(strlen(s)+10,0);
1307                         sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
1308                         s = s1;
1309                         }
1310                 iob_list->fields[offset] = s;
1311         }
1312         else {
1313                 if (!p)
1314                         e = ICON(0);
1315                 else if (p->vtype != TYCHAR) {
1316                         NOEXT("non-character variable as format or internal unit");
1317                         e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
1318                         }
1319                 else
1320                         e = addrof((expptr)p);
1321                 ioset(TYADDR, offset, e);
1322                 }
1323 }
1324
1325
1326
1327
1328  LOCAL void
1329 iosetip(i, offset)
1330  int i, offset;
1331 {
1332         register expptr p;
1333
1334         if(p = V(i))
1335                 if(p->tag==TADDR &&
1336                     ONEOF(p->addrblock.vtype, inqmask) ) {
1337                         ioset_assign = OPASSIGNI;
1338                         ioset(TYADDR, offset, addrof(cpexpr(p)) );
1339                         ioset_assign = OPASSIGN;
1340                         }
1341                 else
1342                         errstr("impossible inquire parameter %s", ioc[i].iocname);
1343         else
1344                 ioset(TYADDR, offset, ICON(0) );
1345 }
1346
1347
1348
1349  LOCAL void
1350 iosetlc(i, offp, offl)
1351  int i, offp, offl;
1352 {
1353         register expptr p;
1354         if( (p = V(i)) && p->headblock.vtype==TYCHAR)
1355                 ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
1356         iosetc(offp, p);
1357 }