lang/fortran/comp/io.c

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