00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029 #define TYIOINT TYLONG
00030 #define SZIOINT SZLONG
00031
00032 #include "defs.h"
00033 #include "names.h"
00034 #include "iob.h"
00035
00036 extern int byterev, inqmask;
00037
00038 static void dofclose Argdcl((void));
00039 static void dofinquire Argdcl((void));
00040 static void dofmove Argdcl((char*));
00041 static void dofopen Argdcl((void));
00042 static void doiolist Argdcl((chainp));
00043 static void ioset Argdcl((int, int, expptr));
00044 static void ioseta Argdcl((int, Addrp));
00045 static void iosetc Argdcl((int, expptr));
00046 static void iosetip Argdcl((int, int));
00047 static void iosetlc Argdcl((int, int, int));
00048 static void putio Argdcl((expptr, expptr));
00049 static void putiocall Argdcl((expptr));
00050
00051 iob_data *iob_list;
00052 Addrp io_structs[9];
00053
00054 LOCAL char ioroutine[12];
00055
00056 LOCAL long ioendlab;
00057 LOCAL long ioerrlab;
00058 LOCAL int endbit;
00059 LOCAL int errbit;
00060 LOCAL long jumplab;
00061 LOCAL long skiplab;
00062 LOCAL int ioformatted;
00063 LOCAL int statstruct = NO;
00064 LOCAL struct Labelblock *skiplabel;
00065 Addrp ioblkp;
00066
00067 #define UNFORMATTED 0
00068 #define FORMATTED 1
00069 #define LISTDIRECTED 2
00070 #define NAMEDIRECTED 3
00071
00072 #define V(z) ioc[z].iocval
00073
00074 #define IOALL 07777
00075
00076 LOCAL struct Ioclist
00077 {
00078 char *iocname;
00079 int iotype;
00080 expptr iocval;
00081 }
00082 ioc[ ] =
00083 {
00084 { "", 0 },
00085 { "unit", IOALL },
00086 { "fmt", M(IOREAD) | M(IOWRITE) },
00087 { "err", IOALL },
00088 { "end", M(IOREAD) },
00089 { "iostat", IOALL },
00090 { "rec", M(IOREAD) | M(IOWRITE) },
00091 { "recl", M(IOOPEN) | M(IOINQUIRE) },
00092 { "file", M(IOOPEN) | M(IOINQUIRE) },
00093 { "status", M(IOOPEN) | M(IOCLOSE) },
00094 { "access", M(IOOPEN) | M(IOINQUIRE) },
00095 { "form", M(IOOPEN) | M(IOINQUIRE) },
00096 { "blank", M(IOOPEN) | M(IOINQUIRE) },
00097 { "exist", M(IOINQUIRE) },
00098 { "opened", M(IOINQUIRE) },
00099 { "number", M(IOINQUIRE) },
00100 { "named", M(IOINQUIRE) },
00101 { "name", M(IOINQUIRE) },
00102 { "sequential", M(IOINQUIRE) },
00103 { "direct", M(IOINQUIRE) },
00104 { "formatted", M(IOINQUIRE) },
00105 { "unformatted", M(IOINQUIRE) },
00106 { "nextrec", M(IOINQUIRE) },
00107 { "nml", M(IOREAD) | M(IOWRITE) }
00108 };
00109
00110 #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
00111
00112
00113
00114 #define IOSERR 3
00115 #define IOSEND 4
00116 #define IOSIOSTAT 5
00117 #define IOSREC 6
00118 #define IOSRECL 7
00119 #define IOSFILE 8
00120 #define IOSSTATUS 9
00121 #define IOSACCESS 10
00122 #define IOSFORM 11
00123 #define IOSBLANK 12
00124 #define IOSEXISTS 13
00125 #define IOSOPENED 14
00126 #define IOSNUMBER 15
00127 #define IOSNAMED 16
00128 #define IOSNAME 17
00129 #define IOSSEQUENTIAL 18
00130 #define IOSDIRECT 19
00131 #define IOSFORMATTED 20
00132 #define IOSUNFORMATTED 21
00133 #define IOSNEXTREC 22
00134 #define IOSNML 23
00135
00136 #define IOSTP V(IOSIOSTAT)
00137
00138
00139
00140
00141 #define SZFLAG SZIOINT
00142
00143
00144
00145 #define XERR 0
00146 #define XUNIT SZFLAG
00147 #define XEND SZFLAG + SZIOINT
00148 #define XFMT 2*SZFLAG + SZIOINT
00149 #define XREC 2*SZFLAG + SZIOINT + SZADDR
00150
00151
00152
00153 #define XIUNIT SZFLAG
00154 #define XIEND SZFLAG + SZADDR
00155 #define XIFMT 2*SZFLAG + SZADDR
00156 #define XIRLEN 2*SZFLAG + 2*SZADDR
00157 #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
00158 #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT
00159
00160
00161
00162 #define XFNAME SZFLAG + SZIOINT
00163 #define XFNAMELEN SZFLAG + SZIOINT + SZADDR
00164 #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
00165 #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
00166 #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR
00167 #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
00168 #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
00169
00170
00171
00172 #define XCLSTATUS SZFLAG + SZIOINT
00173
00174
00175
00176 #define XFILE SZFLAG + SZIOINT
00177 #define XFILELEN SZFLAG + SZIOINT + SZADDR
00178 #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
00179 #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR
00180 #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
00181 #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
00182 #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR
00183 #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR
00184 #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR
00185 #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR
00186 #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR
00187 #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
00188 #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
00189 #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
00190 #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR
00191 #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR
00192 #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
00193 #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR
00194 #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
00195 #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR
00196 #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
00197 #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR
00198 #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
00199 #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR
00200
00201 LOCAL char *cilist_names[] = {
00202 "cilist",
00203 "cierr",
00204 "ciunit",
00205 "ciend",
00206 "cifmt",
00207 "cirec"
00208 };
00209 LOCAL char *icilist_names[] = {
00210 "icilist",
00211 "icierr",
00212 "iciunit",
00213 "iciend",
00214 "icifmt",
00215 "icirlen",
00216 "icirnum"
00217 };
00218 LOCAL char *olist_names[] = {
00219 "olist",
00220 "oerr",
00221 "ounit",
00222 "ofnm",
00223 "ofnmlen",
00224 "osta",
00225 "oacc",
00226 "ofm",
00227 "orl",
00228 "oblnk"
00229 };
00230 LOCAL char *cllist_names[] = {
00231 "cllist",
00232 "cerr",
00233 "cunit",
00234 "csta"
00235 };
00236 LOCAL char *alist_names[] = {
00237 "alist",
00238 "aerr",
00239 "aunit"
00240 };
00241 LOCAL char *inlist_names[] = {
00242 "inlist",
00243 "inerr",
00244 "inunit",
00245 "infile",
00246 "infilen",
00247 "inex",
00248 "inopen",
00249 "innum",
00250 "innamed",
00251 "inname",
00252 "innamlen",
00253 "inacc",
00254 "inacclen",
00255 "inseq",
00256 "inseqlen",
00257 "indir",
00258 "indirlen",
00259 "infmt",
00260 "infmtlen",
00261 "inform",
00262 "informlen",
00263 "inunf",
00264 "inunflen",
00265 "inrecl",
00266 "innrec",
00267 "inblank",
00268 "inblanklen"
00269 };
00270
00271 LOCAL char **io_fields;
00272
00273 #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
00274
00275 LOCAL io_setup io_stuff[] = {
00276 zork(cilist_names, TYCILIST),
00277 zork(inlist_names, TYINLIST),
00278 zork(olist_names, TYOLIST),
00279 zork(cllist_names, TYCLLIST),
00280 zork(alist_names, TYALIST),
00281 zork(alist_names, TYALIST),
00282 zork(alist_names, TYALIST),
00283 zork(icilist_names,TYICILIST),
00284 zork(icilist_names,TYICILIST)
00285 };
00286
00287 #undef zork
00288
00289 int
00290 #ifdef KR_headers
00291 fmtstmt(lp)
00292 register struct Labelblock *lp;
00293 #else
00294 fmtstmt(register struct Labelblock *lp)
00295 #endif
00296 {
00297 if(lp == NULL)
00298 {
00299 execerr("unlabeled format statement" , CNULL);
00300 return(-1);
00301 }
00302 if(lp->labtype == LABUNKNOWN)
00303 {
00304 lp->labtype = LABFORMAT;
00305 lp->labelno = (int)newlabel();
00306 }
00307 else if(lp->labtype != LABFORMAT)
00308 {
00309 execerr("bad format number", CNULL);
00310 return(-1);
00311 }
00312 return(lp->labelno);
00313 }
00314
00315
00316 void
00317 #ifdef KR_headers
00318 setfmt(lp)
00319 struct Labelblock *lp;
00320 #else
00321 setfmt(struct Labelblock *lp)
00322 #endif
00323 {
00324 int n, parity;
00325 char *s0;
00326 register char *s, *se, *t;
00327 register k;
00328
00329 s0 = s = lexline(&n);
00330 se = t = s + n;
00331
00332
00333
00334
00335 if (n <= 0)
00336 warn("No (...) after FORMAT");
00337 else if (*s != '(')
00338 warni("%c rather than ( after FORMAT", *s);
00339 else if (se[-1] != ')') {
00340 *se = 0;
00341 while(--t > s && *t != ')') ;
00342 if (t <= s)
00343 warn("No ) at end of FORMAT statement");
00344 else if (se - t > 30)
00345 warn1("Extraneous text at end of FORMAT: ...%s", se-12);
00346 else
00347 warn1("Extraneous text at end of FORMAT: %s", t+1);
00348 t = se;
00349 }
00350
00351
00352
00353 parity = 1;
00354 while(s < se)
00355 switch(*s++) {
00356 case 2:
00357 if ((parity ^= 1) && *s == 2) {
00358 t -= 2;
00359 ++s;
00360 }
00361 else
00362 t += 3;
00363 break;
00364 case '"':
00365 case '\\':
00366 t++; break;
00367 }
00368 s = s0;
00369 parity = 1;
00370 if (lp) {
00371 lp->fmtstring = t = mem((int)(t - s + 1), 0);
00372 while(s < se)
00373 switch(k = *s++) {
00374 case 2:
00375 if ((parity ^= 1) && *s == 2)
00376 s++;
00377 else {
00378 t[0] = '\\';
00379 t[1] = '0';
00380 t[2] = '0';
00381 t[3] = '2';
00382 t += 4;
00383 }
00384 break;
00385 case '"':
00386 case '\\':
00387 *t++ = '\\';
00388
00389 default:
00390 *t++ = k;
00391 }
00392 *t = 0;
00393 }
00394 flline();
00395 }
00396
00397
00398 void
00399 #ifdef KR_headers
00400 startioctl()
00401 #else
00402 startioctl()
00403 #endif
00404 {
00405 register int i;
00406
00407 inioctl = YES;
00408 nioctl = 0;
00409 ioformatted = UNFORMATTED;
00410 for(i = 1 ; i<=NIOS ; ++i)
00411 V(i) = NULL;
00412 }
00413
00414 static long
00415 newiolabel(Void) {
00416 long rv;
00417 rv = ++lastiolabno;
00418 skiplabel = mklabel(rv);
00419 skiplabel->labdefined = 1;
00420 return rv;
00421 }
00422
00423 void
00424 endioctl(Void)
00425 {
00426 int i;
00427 expptr p;
00428 struct io_setup *ios;
00429
00430 inioctl = NO;
00431
00432
00433
00434 ioerrlab = ioendlab = skiplab = jumplab = 0;
00435
00436 if(p = V(IOSEND))
00437 if(ISICON(p))
00438 execlab(ioendlab = p->constblock.Const.ci);
00439 else
00440 err("bad end= clause");
00441
00442 if(p = V(IOSERR))
00443 if(ISICON(p))
00444 execlab(ioerrlab = p->constblock.Const.ci);
00445 else
00446 err("bad err= clause");
00447
00448 if(IOSTP)
00449 if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
00450 {
00451 err("iostat must be an integer variable");
00452 frexpr(IOSTP);
00453 IOSTP = NULL;
00454 }
00455
00456 if(iostmt == IOREAD)
00457 {
00458 if(IOSTP)
00459 {
00460 if(ioerrlab && ioendlab && ioerrlab==ioendlab)
00461 jumplab = ioerrlab;
00462 else
00463 skiplab = jumplab = newiolabel();
00464 }
00465 else {
00466 if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
00467 {
00468 IOSTP = (expptr) mktmp(TYINT, ENULL);
00469 skiplab = jumplab = newiolabel();
00470 }
00471 else
00472 jumplab = (ioerrlab ? ioerrlab : ioendlab);
00473 }
00474 }
00475 else if(iostmt == IOWRITE)
00476 {
00477 if(IOSTP && !ioerrlab)
00478 skiplab = jumplab = newiolabel();
00479 else
00480 jumplab = ioerrlab;
00481 }
00482 else
00483 jumplab = ioerrlab;
00484
00485 endbit = IOSTP!=NULL || ioendlab!=0;
00486 errbit = IOSTP!=NULL || ioerrlab!=0;
00487 if (jumplab && !IOSTP)
00488 IOSTP = (expptr) mktmp(TYINT, ENULL);
00489
00490 if(iostmt!=IOREAD && iostmt!=IOWRITE)
00491 {
00492 ios = io_stuff + iostmt;
00493 io_fields = ios->fields;
00494 ioblkp = io_structs[iostmt];
00495 if(ioblkp == NULL)
00496 io_structs[iostmt] = ioblkp =
00497 autovar(1, ios->type, ENULL, "");
00498 ioset(TYIOINT, XERR, ICON(errbit));
00499 }
00500
00501 switch(iostmt)
00502 {
00503 case IOOPEN:
00504 dofopen();
00505 break;
00506
00507 case IOCLOSE:
00508 dofclose();
00509 break;
00510
00511 case IOINQUIRE:
00512 dofinquire();
00513 break;
00514
00515 case IOBACKSPACE:
00516 dofmove("f_back");
00517 break;
00518
00519 case IOREWIND:
00520 dofmove("f_rew");
00521 break;
00522
00523 case IOENDFILE:
00524 dofmove("f_end");
00525 break;
00526
00527 case IOREAD:
00528 case IOWRITE:
00529 startrw();
00530 break;
00531
00532 default:
00533 fatali("impossible iostmt %d", iostmt);
00534 }
00535 for(i = 1 ; i<=NIOS ; ++i)
00536 if(i!=IOSIOSTAT && V(i)!=NULL)
00537 frexpr(V(i));
00538 }
00539
00540
00541 int
00542 iocname(Void)
00543 {
00544 register int i;
00545 int found, mask;
00546
00547 found = 0;
00548 mask = M(iostmt);
00549 for(i = 1 ; i <= NIOS ; ++i)
00550 if(!strcmp(ioc[i].iocname, token))
00551 if(ioc[i].iotype & mask)
00552 return(i);
00553 else {
00554 found = i;
00555 break;
00556 }
00557 if(found) {
00558 if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
00559 NOEXT("open with \"name=\" treated as \"file=\"");
00560 for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
00561 return i;
00562 }
00563 errstr("invalid control %s for statement", ioc[found].iocname);
00564 }
00565 else
00566 errstr("unknown iocontrol %s", token);
00567 return(IOSBAD);
00568 }
00569
00570
00571 void
00572 #ifdef KR_headers
00573 ioclause(n, p)
00574 register int n;
00575 register expptr p;
00576 #else
00577 ioclause(register int n, register expptr p)
00578 #endif
00579 {
00580 struct Ioclist *iocp;
00581
00582 ++nioctl;
00583 if(n == IOSBAD)
00584 return;
00585 if(n == IOSPOSITIONAL)
00586 {
00587 n = nioctl;
00588 if (n == IOSFMT) {
00589 if (iostmt == IOOPEN) {
00590 n = IOSFILE;
00591 NOEXT("file= specifier omitted from open");
00592 }
00593 else if (iostmt < IOREAD)
00594 goto illegal;
00595 }
00596 else if(n > IOSFMT)
00597 {
00598 illegal:
00599 err("illegal positional iocontrol");
00600 return;
00601 }
00602 }
00603 else if (n == IOSNML)
00604 n = IOSFMT;
00605
00606 if(p == NULL)
00607 {
00608 if(n == IOSUNIT)
00609 p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
00610 else if(n != IOSFMT)
00611 {
00612 err("illegal * iocontrol");
00613 return;
00614 }
00615 }
00616 if(n == IOSFMT)
00617 ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
00618
00619 iocp = & ioc[n];
00620 if(iocp->iocval == NULL)
00621 {
00622 if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
00623 p = fixtype(p);
00624 else if (p && p->tag == TPRIM
00625 && p->primblock.namep->vclass == CLUNKNOWN) {
00626
00627
00628
00629
00630
00631
00632
00633 vardcl(p->primblock.namep);
00634 p->primblock.vtype = p->primblock.namep->vtype;
00635 }
00636 iocp->iocval = p;
00637 }
00638 else
00639 errstr("iocontrol %s repeated", iocp->iocname);
00640 }
00641
00642
00643
00644 void
00645 #ifdef KR_headers
00646 doio(list)
00647 chainp list;
00648 #else
00649 doio(chainp list)
00650 #endif
00651 {
00652 if(ioformatted == NAMEDIRECTED)
00653 {
00654 if(list)
00655 err("no I/O list allowed in NAMELIST read/write");
00656 }
00657 else
00658 {
00659 doiolist(list);
00660 ioroutine[0] = 'e';
00661 if (skiplab)
00662 jumplab = 0;
00663 putiocall( call0(TYINT, ioroutine) );
00664 }
00665 }
00666
00667
00668
00669
00670
00671 LOCAL void
00672 #ifdef KR_headers
00673 doiolist(p0)
00674 chainp p0;
00675 #else
00676 doiolist(chainp p0)
00677 #endif
00678 {
00679 chainp p;
00680 register tagptr q;
00681 register expptr qe;
00682 register Namep qn;
00683 Addrp tp;
00684 int range;
00685 extern char *ohalign;
00686
00687 for (p = p0 ; p ; p = p->nextp)
00688 {
00689 q = (tagptr)p->datap;
00690 if(q->tag == TIMPLDO)
00691 {
00692 exdo(range = (int)newlabel(), (Namep)0,
00693 q->impldoblock.impdospec);
00694 doiolist(q->impldoblock.datalist);
00695 enddo(range);
00696 free( (charptr) q);
00697 }
00698 else {
00699 if(q->tag==TPRIM && q->primblock.argsp==NULL
00700 && q->primblock.namep->vdim!=NULL)
00701 {
00702 vardcl(qn = q->primblock.namep);
00703 if(qn->vdim->nelt) {
00704 putio( fixtype(cpexpr(qn->vdim->nelt)),
00705 (expptr)mkscalar(qn) );
00706 qn->vlastdim = 0;
00707 }
00708 else
00709 err("attempt to i/o array of unknown size");
00710 }
00711 else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
00712 (qe = (expptr) memversion(q->primblock.namep)) )
00713 putio(ICON(1),qe);
00714 else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
00715 halign = 0;
00716 putio(ICON(1), qe = fixtype(cpexpr(q)));
00717 halign = ohalign;
00718 }
00719 else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
00720 (qe->addrblock.uname_tag != UNAM_CONST ||
00721 !ISCOMPLEX(qe -> addrblock.vtype))) ||
00722 (qe -> tag == TCONST && !ISCOMPLEX(qe ->
00723 headblock.vtype))) {
00724 if (qe -> tag == TCONST)
00725 qe = (expptr) putconst((Constp)qe);
00726 putio(ICON(1), qe);
00727 }
00728 else if(qe->headblock.vtype != TYERROR)
00729 {
00730 if(iostmt == IOWRITE)
00731 {
00732 expptr qvl;
00733 qvl = NULL;
00734 if( ISCHAR(qe) )
00735 {
00736 qvl = (expptr)
00737 cpexpr(qe->headblock.vleng);
00738 tp = mktmp(qe->headblock.vtype,
00739 ICON(lencat(qe)));
00740 }
00741 else
00742 tp = mktmp(qe->headblock.vtype,
00743 qe->headblock.vleng);
00744 puteq( cpexpr((expptr)tp), qe);
00745 if(qvl)
00746 {
00747 frexpr(tp->vleng);
00748 tp->vleng = qvl;
00749 }
00750 putio(ICON(1), (expptr)tp);
00751 }
00752 else
00753 err("non-left side in READ list");
00754 }
00755 frexpr(q);
00756 }
00757 }
00758 frchain( &p0 );
00759 }
00760
00761 int iocalladdr = TYADDR;
00762 int typeconv[TYERROR+1] = {
00763 #ifdef TYQUAD
00764 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
00765 #else
00766 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14
00767 #endif
00768 };
00769
00770 LOCAL void
00771 #ifdef KR_headers
00772 putio(nelt, addr)
00773 expptr nelt;
00774 register expptr addr;
00775 #else
00776 putio(expptr nelt, register expptr addr)
00777 #endif
00778 {
00779 int type;
00780 register expptr q;
00781 register Addrp c = 0;
00782
00783 type = addr->headblock.vtype;
00784 if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
00785 {
00786 nelt = mkexpr(OPSTAR, ICON(2), nelt);
00787 type -= (TYCOMPLEX-TYREAL);
00788 }
00789
00790
00791 if(type != TYCHAR)
00792 {
00793
00794 if( ISCONST(addr) )
00795 addr = (expptr) putconst((Constp)addr);
00796 c = ALLOC(Addrblock);
00797 c->tag = TADDR;
00798 c->vtype = TYLENG;
00799 c->vstg = STGAUTO;
00800 c->ntempelt = 1;
00801 c->isarray = 1;
00802 c->memoffset = ICON(0);
00803 c->uname_tag = UNAM_IDENT;
00804 c->charleng = 1;
00805 sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
00806 addr = mkexpr(OPCHARCAST, addr, ENULL);
00807 }
00808
00809 nelt = fixtype( mkconv(tyioint,nelt) );
00810 if(ioformatted == LISTDIRECTED) {
00811 expptr mc = mkconv(tyioint, ICON(typeconv[type]));
00812 q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
00813 : call3(TYINT, "do_lio", mc, nelt, addr);
00814 }
00815 else {
00816 char *s = ioformatted==FORMATTED ? "do_fio"
00817 : !byterev ? "do_uio"
00818 : ONEOF(type, M(TYCHAR)|M(TYINT1)|M(TYLOGICAL1))
00819 ? "do_ucio" : "do_unio";
00820 q = c ? call3(TYINT, s, nelt, addr, (expptr)c)
00821 : call2(TYINT, s, nelt, addr);
00822 }
00823 iocalladdr = TYCHAR;
00824 putiocall(q);
00825 iocalladdr = TYADDR;
00826 }
00827
00828
00829
00830 void
00831 endio(Void)
00832 {
00833 if(skiplab)
00834 {
00835 if (ioformatted != NAMEDIRECTED)
00836 p1_label((long)(skiplabel - labeltab));
00837 if(ioendlab) {
00838 exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
00839 exgoto(execlab(ioendlab));
00840 exendif();
00841 }
00842 if(ioerrlab) {
00843 exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
00844 ? OPGT : OPNE,
00845 cpexpr(IOSTP), ICON(0)));
00846 exgoto(execlab(ioerrlab));
00847 exendif();
00848 }
00849 }
00850
00851 if(IOSTP)
00852 frexpr(IOSTP);
00853 }
00854
00855
00856
00857 LOCAL void
00858 #ifdef KR_headers
00859 putiocall(q)
00860 register expptr q;
00861 #else
00862 putiocall(register expptr q)
00863 #endif
00864 {
00865 int tyintsave;
00866
00867 tyintsave = tyint;
00868 tyint = tyioint;
00869
00870 if(IOSTP)
00871 {
00872 q->headblock.vtype = TYINT;
00873 q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
00874 }
00875 putexpr(q);
00876 if(jumplab) {
00877 exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
00878 exgoto(execlab(jumplab));
00879 exendif();
00880 }
00881 tyint = tyintsave;
00882 }
00883
00884 void
00885 #ifdef KR_headers
00886 fmtname(np, q)
00887 Namep np;
00888 register Addrp q;
00889 #else
00890 fmtname(Namep np, register Addrp q)
00891 #endif
00892 {
00893 register int k;
00894 register char *s, *t;
00895 extern chainp assigned_fmts;
00896
00897 if (!np->vfmt_asg) {
00898 np->vfmt_asg = 1;
00899 assigned_fmts = mkchain((char *)np, assigned_fmts);
00900 }
00901 k = strlen(s = np->fvarname);
00902 if (k < IDENT_LEN - 4) {
00903 q->uname_tag = UNAM_IDENT;
00904 t = q->user.ident;
00905 }
00906 else {
00907 q->uname_tag = UNAM_CHARP;
00908 q->user.Charp = t = mem(k + 5,0);
00909 }
00910 sprintf(t, "%s_fmt", s);
00911 }
00912
00913 LOCAL Addrp
00914 #ifdef KR_headers
00915 asg_addr(p)
00916 union Expression *p;
00917 #else
00918 asg_addr(union Expression *p)
00919 #endif
00920 {
00921 register Addrp q;
00922
00923 if (p->tag != TPRIM)
00924 badtag("asg_addr", p->tag);
00925 q = ALLOC(Addrblock);
00926 q->tag = TADDR;
00927 q->vtype = TYCHAR;
00928 q->vstg = STGAUTO;
00929 q->ntempelt = 1;
00930 q->isarray = 0;
00931 q->memoffset = ICON(0);
00932 fmtname(p->primblock.namep, q);
00933 return q;
00934 }
00935
00936 void
00937 startrw(Void)
00938 {
00939 register expptr p;
00940 register Namep np;
00941 register Addrp unitp, fmtp, recp;
00942 register expptr nump;
00943 int iostmt1;
00944 flag intfile, sequential, ok, varfmt;
00945 struct io_setup *ios;
00946
00947
00948
00949 ok = YES;
00950 statstruct = YES;
00951
00952 intfile = NO;
00953 if(p = V(IOSUNIT))
00954 {
00955 if( ISINT(p->headblock.vtype) ) {
00956 int_unit:
00957 unitp = (Addrp) cpexpr(p);
00958 }
00959 else if(p->headblock.vtype == TYCHAR)
00960 {
00961 if (nioctl == 1 && iostmt == IOREAD) {
00962
00963 V(IOSFMT) = p;
00964 V(IOSUNIT) = p = (expptr) IOSTDIN;
00965 ioformatted = FORMATTED;
00966 goto int_unit;
00967 }
00968 intfile = YES;
00969 if(p->tag==TPRIM && p->primblock.argsp==NULL &&
00970 (np = p->primblock.namep)->vdim!=NULL)
00971 {
00972 vardcl(np);
00973 if(nump = np->vdim->nelt)
00974 {
00975 nump = fixtype(cpexpr(nump));
00976 if( ! ISCONST(nump) ) {
00977 statstruct = NO;
00978 np->vlastdim = 0;
00979 }
00980 }
00981 else
00982 {
00983 err("attempt to use internal unit array of unknown size");
00984 ok = NO;
00985 nump = ICON(1);
00986 }
00987 unitp = mkscalar(np);
00988 }
00989 else {
00990 nump = ICON(1);
00991 unitp = (Addrp ) fixtype(cpexpr(p));
00992 }
00993 if(! isstatic((expptr)unitp) )
00994 statstruct = NO;
00995 }
00996 else {
00997 err("unit specifier not of type integer or character");
00998 ok = NO;
00999 }
01000 }
01001 else
01002 {
01003 err("bad unit specifier");
01004 ok = NO;
01005 }
01006
01007 sequential = YES;
01008 if(p = V(IOSREC))
01009 if( ISINT(p->headblock.vtype) )
01010 {
01011 recp = (Addrp) cpexpr(p);
01012 sequential = NO;
01013 }
01014 else {
01015 err("bad REC= clause");
01016 ok = NO;
01017 }
01018 else
01019 recp = NULL;
01020
01021
01022 varfmt = YES;
01023 fmtp = NULL;
01024 if(p = V(IOSFMT))
01025 {
01026 if(p->tag==TPRIM && p->primblock.argsp==NULL)
01027 {
01028 np = p->primblock.namep;
01029 if(np->vclass == CLNAMELIST)
01030 {
01031 ioformatted = NAMEDIRECTED;
01032 fmtp = (Addrp) fixtype(p);
01033 V(IOSFMT) = (expptr)fmtp;
01034 if (skiplab)
01035 jumplab = 0;
01036 goto endfmt;
01037 }
01038 vardcl(np);
01039 if(np->vdim)
01040 {
01041 if( ! ONEOF(np->vstg, MSKSTATIC) )
01042 statstruct = NO;
01043 fmtp = mkscalar(np);
01044 goto endfmt;
01045 }
01046 if( ISINT(np->vtype) )
01047 {
01048 statstruct = NO;
01049 varfmt = YES;
01050 fmtp = asg_addr(p);
01051 goto endfmt;
01052 }
01053 }
01054 p = V(IOSFMT) = fixtype(p);
01055 if(p->headblock.vtype == TYCHAR
01056
01057
01058 || p->tag == TADDR && ISINT(p->addrblock.vtype))
01059 {
01060 if( ! isstatic(p) )
01061 statstruct = NO;
01062 fmtp = (Addrp) cpexpr(p);
01063 }
01064 else if( ISICON(p) )
01065 {
01066 struct Labelblock *lp;
01067 lp = mklabel(p->constblock.Const.ci);
01068 if (fmtstmt(lp) > 0)
01069 {
01070 fmtp = (Addrp)mkaddcon(lp->stateno);
01071
01072 lp->fmtlabused = 1;
01073 varfmt = NO;
01074 }
01075 else
01076 ioformatted = UNFORMATTED;
01077 }
01078 else {
01079 err("bad format descriptor");
01080 ioformatted = UNFORMATTED;
01081 ok = NO;
01082 }
01083 }
01084 else
01085 fmtp = NULL;
01086
01087 endfmt:
01088 if(intfile) {
01089 if (ioformatted==UNFORMATTED) {
01090 err("unformatted internal I/O not allowed");
01091 ok = NO;
01092 }
01093 if (recp) {
01094 err("direct internal I/O not allowed");
01095 ok = NO;
01096 }
01097 }
01098 if(!sequential && ioformatted==LISTDIRECTED)
01099 {
01100 err("direct list-directed I/O not allowed");
01101 ok = NO;
01102 }
01103 if(!sequential && ioformatted==NAMEDIRECTED)
01104 {
01105 err("direct namelist I/O not allowed");
01106 ok = NO;
01107 }
01108
01109 if( ! ok ) {
01110 statstruct = NO;
01111 return;
01112 }
01113
01114
01115
01116
01117
01118
01119 if (intfile) {
01120 ios = io_stuff + iostmt;
01121 iostmt1 = IOREAD;
01122 }
01123 else {
01124 ios = io_stuff;
01125 iostmt1 = 0;
01126 }
01127 io_fields = ios->fields;
01128 if(statstruct)
01129 {
01130 ioblkp = ALLOC(Addrblock);
01131 ioblkp->tag = TADDR;
01132 ioblkp->vtype = ios->type;
01133 ioblkp->vclass = CLVAR;
01134 ioblkp->vstg = STGINIT;
01135 ioblkp->memno = ++lastvarno;
01136 ioblkp->memoffset = ICON(0);
01137 ioblkp -> uname_tag = UNAM_IDENT;
01138 new_iob_data(ios,
01139 temp_name("io_", lastvarno, ioblkp->user.ident)); }
01140 else if(!(ioblkp = io_structs[iostmt1]))
01141 io_structs[iostmt1] = ioblkp =
01142 autovar(1, ios->type, ENULL, "");
01143
01144 ioset(TYIOINT, XERR, ICON(errbit));
01145 if(iostmt == IOREAD)
01146 ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
01147
01148 if(intfile)
01149 {
01150 ioset(TYIOINT, XIRNUM, nump);
01151 ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
01152 ioseta(XIUNIT, unitp);
01153 }
01154 else
01155 ioset(TYIOINT, XUNIT, (expptr) unitp);
01156
01157 if(recp)
01158 ioset(TYIOINT, XREC, (expptr) recp);
01159
01160 if(varfmt)
01161 ioseta( intfile ? XIFMT : XFMT , fmtp);
01162 else
01163 ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
01164
01165 ioroutine[0] = 's';
01166 ioroutine[1] = '_';
01167 ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
01168 ioroutine[3] = "ds"[sequential];
01169 ioroutine[4] = "ufln"[ioformatted];
01170 ioroutine[5] = "ei"[intfile];
01171 ioroutine[6] = '\0';
01172
01173 putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
01174
01175 if(statstruct)
01176 {
01177 frexpr((expptr)ioblkp);
01178 statstruct = NO;
01179 ioblkp = 0;
01180 }
01181 }
01182
01183
01184
01185 LOCAL void
01186 dofopen(Void)
01187 {
01188 register expptr p;
01189
01190 if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
01191 ioset(TYIOINT, XUNIT, cpexpr(p) );
01192 else
01193 err("bad unit in open");
01194 if( (p = V(IOSFILE)) )
01195 if(p->headblock.vtype == TYCHAR)
01196 ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
01197 else
01198 err("bad file in open");
01199
01200 iosetc(XFNAME, p);
01201
01202 if(p = V(IOSRECL))
01203 if( ISINT(p->headblock.vtype) )
01204 ioset(TYIOINT, XRECLEN, cpexpr(p) );
01205 else
01206 err("bad recl");
01207 else
01208 ioset(TYIOINT, XRECLEN, ICON(0) );
01209
01210 iosetc(XSTATUS, V(IOSSTATUS));
01211 iosetc(XACCESS, V(IOSACCESS));
01212 iosetc(XFORMATTED, V(IOSFORM));
01213 iosetc(XBLANK, V(IOSBLANK));
01214
01215 putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
01216 }
01217
01218
01219 LOCAL void
01220 dofclose(Void)
01221 {
01222 register expptr p;
01223
01224 if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
01225 {
01226 ioset(TYIOINT, XUNIT, cpexpr(p) );
01227 iosetc(XCLSTATUS, V(IOSSTATUS));
01228 putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
01229 }
01230 else
01231 err("bad unit in close statement");
01232 }
01233
01234
01235 LOCAL void
01236 dofinquire(Void)
01237 {
01238 register expptr p;
01239 if(p = V(IOSUNIT))
01240 {
01241 if( V(IOSFILE) )
01242 err("inquire by unit or by file, not both");
01243 ioset(TYIOINT, XUNIT, cpexpr(p) );
01244 }
01245 else if( ! V(IOSFILE) )
01246 err("must inquire by unit or by file");
01247 iosetlc(IOSFILE, XFILE, XFILELEN);
01248 iosetip(IOSEXISTS, XEXISTS);
01249 iosetip(IOSOPENED, XOPEN);
01250 iosetip(IOSNUMBER, XNUMBER);
01251 iosetip(IOSNAMED, XNAMED);
01252 iosetlc(IOSNAME, XNAME, XNAMELEN);
01253 iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
01254 iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
01255 iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
01256 iosetlc(IOSFORM, XFORM, XFORMLEN);
01257 iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
01258 iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
01259 iosetip(IOSRECL, XQRECL);
01260 iosetip(IOSNEXTREC, XNEXTREC);
01261 iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
01262
01263 putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) ));
01264 }
01265
01266
01267
01268 LOCAL void
01269 #ifdef KR_headers
01270 dofmove(subname)
01271 char *subname;
01272 #else
01273 dofmove(char *subname)
01274 #endif
01275 {
01276 register expptr p;
01277
01278 if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
01279 {
01280 ioset(TYIOINT, XUNIT, cpexpr(p) );
01281 putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
01282 }
01283 else
01284 err("bad unit in I/O motion statement");
01285 }
01286
01287 static int ioset_assign = OPASSIGN;
01288
01289 LOCAL void
01290 #ifdef KR_headers
01291 ioset(type, offset, p)
01292 int type;
01293 int offset;
01294 register expptr p;
01295 #else
01296 ioset(int type, int offset, register expptr p)
01297 #endif
01298 {
01299 offset /= SZLONG;
01300 if(statstruct && ISCONST(p)) {
01301 register char *s;
01302 switch(type) {
01303 case TYADDR:
01304 s = "fmt_";
01305 break;
01306 case TYIOINT:
01307 s = "";
01308 break;
01309 default:
01310 badtype("ioset", type);
01311 }
01312 iob_list->fields[offset] =
01313 string_num(s, p->constblock.Const.ci);
01314 frexpr(p);
01315 }
01316 else {
01317 register Addrp q;
01318
01319 q = ALLOC(Addrblock);
01320 q->tag = TADDR;
01321 q->vtype = type;
01322 q->vstg = STGAUTO;
01323 q->ntempelt = 1;
01324 q->isarray = 0;
01325 q->memoffset = ICON(0);
01326 q->uname_tag = UNAM_IDENT;
01327 sprintf(q->user.ident, "%s.%s",
01328 statstruct ? iob_list->name : ioblkp->user.ident,
01329 io_fields[offset + 1]);
01330 if (type == TYADDR && p->tag == TCONST
01331 && p->constblock.vtype == TYADDR) {
01332
01333 register Addrp p1;
01334 p1 = ALLOC(Addrblock);
01335 p1->tag = TADDR;
01336 p1->vtype = type;
01337 p1->vstg = STGAUTO;
01338 p1->ntempelt = 1;
01339 p1->isarray = 0;
01340 p1->memoffset = ICON(0);
01341 p1->uname_tag = UNAM_IDENT;
01342 sprintf(p1->user.ident, "fmt_%ld",
01343 p->constblock.Const.ci);
01344 frexpr(p);
01345 p = (expptr)p1;
01346 }
01347 if (type == TYADDR && p->headblock.vtype == TYCHAR)
01348 q->vtype = TYCHAR;
01349 putexpr(mkexpr(ioset_assign, (expptr)q, p));
01350 }
01351 }
01352
01353
01354
01355
01356 LOCAL void
01357 #ifdef KR_headers
01358 iosetc(offset, p)
01359 int offset;
01360 register expptr p;
01361 #else
01362 iosetc(int offset, register expptr p)
01363 #endif
01364 {
01365 if(p == NULL)
01366 ioset(TYADDR, offset, ICON(0) );
01367 else if(p->headblock.vtype == TYCHAR) {
01368 p = putx(fixtype((expptr)putchop(cpexpr(p))));
01369 ioset(TYADDR, offset, addrof(p));
01370 }
01371 else
01372 err("non-character control clause");
01373 }
01374
01375
01376
01377 LOCAL void
01378 #ifdef KR_headers
01379 ioseta(offset, p)
01380 int offset;
01381 register Addrp p;
01382 #else
01383 ioseta(int offset, register Addrp p)
01384 #endif
01385 {
01386 char *s, *s1;
01387 static char who[] = "ioseta";
01388 expptr e, mo;
01389 Namep np;
01390 ftnint ci;
01391 int k;
01392 char buf[24], buf1[24];
01393 Extsym *comm;
01394 extern int usedefsforcommon;
01395
01396 if(statstruct)
01397 {
01398 if (!p)
01399 return;
01400 if (p->tag != TADDR)
01401 badtag(who, p->tag);
01402 offset /= SZLONG;
01403 switch(p->uname_tag) {
01404 case UNAM_NAME:
01405 mo = p->memoffset;
01406 if (mo->tag != TCONST)
01407 badtag("ioseta/memoffset", mo->tag);
01408 np = p->user.name;
01409 np->visused = 1;
01410 ci = mo->constblock.Const.ci - np->voffset;
01411 if (np->vstg == STGCOMMON
01412 && !np->vcommequiv
01413 && !usedefsforcommon) {
01414 comm = &extsymtab[np->vardesc.varno];
01415 sprintf(buf, "%d.", comm->curno);
01416 k = strlen(buf) + strlen(comm->cextname)
01417 + strlen(np->cvarname);
01418 if (ci) {
01419 sprintf(buf1, "+%ld", ci);
01420 k += strlen(buf1);
01421 }
01422 else
01423 buf1[0] = 0;
01424 s = mem(k + 1, 0);
01425 sprintf(s, "%s%s%s%s", comm->cextname, buf,
01426 np->cvarname, buf1);
01427 }
01428 else if (ci) {
01429 sprintf(buf,"%ld", ci);
01430 s1 = p->user.name->cvarname;
01431 k = strlen(buf) + strlen(s1);
01432 sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
01433 }
01434 else
01435 s = cpstring(np->cvarname);
01436 break;
01437 case UNAM_CONST:
01438 s = tostring(p->user.Const.ccp1.ccp0,
01439 (int)p->vleng->constblock.Const.ci);
01440 break;
01441 default:
01442 badthing("uname_tag", who, p->uname_tag);
01443 }
01444
01445 if (p->vtype != TYCHAR) {
01446 s1 = mem(strlen(s)+10,0);
01447 sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
01448 s = s1;
01449 }
01450 iob_list->fields[offset] = s;
01451 }
01452 else {
01453 if (!p)
01454 e = ICON(0);
01455 else if (p->vtype != TYCHAR) {
01456 NOEXT("non-character variable as format or internal unit");
01457 e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
01458 }
01459 else
01460 e = addrof((expptr)p);
01461 ioset(TYADDR, offset, e);
01462 }
01463 }
01464
01465
01466
01467
01468 LOCAL void
01469 #ifdef KR_headers
01470 iosetip(i, offset)
01471 int i;
01472 int offset;
01473 #else
01474 iosetip(int i, int offset)
01475 #endif
01476 {
01477 register expptr p;
01478
01479 if(p = V(i))
01480 if(p->tag==TADDR &&
01481 ONEOF(p->addrblock.vtype, inqmask) ) {
01482 ioset_assign = OPASSIGNI;
01483 ioset(TYADDR, offset, addrof(cpexpr(p)) );
01484 ioset_assign = OPASSIGN;
01485 }
01486 else
01487 errstr("impossible inquire parameter %s", ioc[i].iocname);
01488 else
01489 ioset(TYADDR, offset, ICON(0) );
01490 }
01491
01492
01493
01494 LOCAL void
01495 #ifdef KR_headers
01496 iosetlc(i, offp, offl)
01497 int i;
01498 int offp;
01499 int offl;
01500 #else
01501 iosetlc(int i, int offp, int offl)
01502 #endif
01503 {
01504 register expptr p;
01505 if( (p = V(i)) && p->headblock.vtype==TYCHAR)
01506 ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
01507 iosetc(offp, p);
01508 }
