![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f77|
Return to io.c CVS log | Up to [Research Unix] / researchv10no / cmd / f77 |
1.1 root 1: /* Routines to generate code for I/O statements.
2: Some corrections and improvements due to David Wasley, U. C. Berkeley
3: */
4:
5: /* TEMPORARY */
6: #define TYIOINT TYLONG
7: #define SZIOINT SZLONG
8:
9: #include "defs"
10:
11: LOCAL int doiolist(), dofclose(), dofinquire(), dofopen(), dofmove(),
12: ioset(), ioseta(), iosetc(), iosetip(), iosetlc(), putio(),
13: putiocall();
14:
15:
16: LOCAL char ioroutine[XL+1];
17:
18: LOCAL int ioendlab;
19: LOCAL int ioerrlab;
20: LOCAL int endbit;
21: LOCAL int errbit;
22: LOCAL int jumplab;
23: LOCAL int skiplab;
24: LOCAL int ioformatted;
25: LOCAL int statstruct = NO;
26: LOCAL ftnint blklen;
27:
28: #define UNFORMATTED 0
29: #define FORMATTED 1
30: #define LISTDIRECTED 2
31: #define NAMEDIRECTED 3
32:
33: #define V(z) ioc[z].iocval
34:
35: #define IOALL 07777
36:
37: LOCAL struct Ioclist
38: {
39: char *iocname;
40: int iotype;
41: expptr iocval;
42: }
43: ioc[ ] =
44: {
45: { "", 0 },
46: { "unit", IOALL },
47: { "fmt", M(IOREAD) | M(IOWRITE) },
48: { "err", IOALL },
49: { "end", M(IOREAD) },
50: { "iostat", IOALL },
51: { "rec", M(IOREAD) | M(IOWRITE) },
52: { "recl", M(IOOPEN) | M(IOINQUIRE) },
53: { "file", M(IOOPEN) | M(IOINQUIRE) },
54: { "status", M(IOOPEN) | M(IOCLOSE) },
55: { "access", M(IOOPEN) | M(IOINQUIRE) },
56: { "form", M(IOOPEN) | M(IOINQUIRE) },
57: { "blank", M(IOOPEN) | M(IOINQUIRE) },
58: { "exist", M(IOINQUIRE) },
59: { "opened", M(IOINQUIRE) },
60: { "number", M(IOINQUIRE) },
61: { "named", M(IOINQUIRE) },
62: { "name", M(IOINQUIRE) },
63: { "sequential", M(IOINQUIRE) },
64: { "direct", M(IOINQUIRE) },
65: { "formatted", M(IOINQUIRE) },
66: { "unformatted", M(IOINQUIRE) },
67: { "nextrec", M(IOINQUIRE) },
68: { "nml", M(IOREAD) | M(IOWRITE) }
69: };
70:
71: #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
72: #define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR
73:
74: #define IOSUNIT 1
75: #define IOSFMT 2
76: #define IOSERR 3
77: #define IOSEND 4
78: #define IOSIOSTAT 5
79: #define IOSREC 6
80: #define IOSRECL 7
81: #define IOSFILE 8
82: #define IOSSTATUS 9
83: #define IOSACCESS 10
84: #define IOSFORM 11
85: #define IOSBLANK 12
86: #define IOSEXISTS 13
87: #define IOSOPENED 14
88: #define IOSNUMBER 15
89: #define IOSNAMED 16
90: #define IOSNAME 17
91: #define IOSSEQUENTIAL 18
92: #define IOSDIRECT 19
93: #define IOSFORMATTED 20
94: #define IOSUNFORMATTED 21
95: #define IOSNEXTREC 22
96: #define IOSNML 23
97:
98: #define IOSTP V(IOSIOSTAT)
99:
100:
101: /* offsets in generated structures */
102:
103: #define SZFLAG SZIOINT
104:
105: /* offsets for external READ and WRITE statements */
106:
107: #define XERR 0
108: #define XUNIT SZFLAG
109: #define XEND SZFLAG + SZIOINT
110: #define XFMT 2*SZFLAG + SZIOINT
111: #define XREC 2*SZFLAG + SZIOINT + SZADDR
112: #define XRLEN 2*SZFLAG + 2*SZADDR
113: #define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
114:
115: /* offsets for internal READ and WRITE statements */
116:
117: #define XIERR 0
118: #define XIUNIT SZFLAG
119: #define XIEND SZFLAG + SZADDR
120: #define XIFMT 2*SZFLAG + SZADDR
121: #define XIRLEN 2*SZFLAG + 2*SZADDR
122: #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
123: #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT
124:
125: /* offsets for OPEN statements */
126:
127: #define XFNAME SZFLAG + SZIOINT
128: #define XFNAMELEN SZFLAG + SZIOINT + SZADDR
129: #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
130: #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
131: #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR
132: #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
133: #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
134:
135: /* offset for CLOSE statement */
136:
137: #define XCLSTATUS SZFLAG + SZIOINT
138:
139: /* offsets for INQUIRE statement */
140:
141: #define XFILE SZFLAG + SZIOINT
142: #define XFILELEN SZFLAG + SZIOINT + SZADDR
143: #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
144: #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR
145: #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
146: #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
147: #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR
148: #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR
149: #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR
150: #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR
151: #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR
152: #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
153: #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
154: #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
155: #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR
156: #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR
157: #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
158: #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR
159: #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
160: #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR
161: #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
162: #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR
163: #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
164: #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR
165:
166: fmtstmt(lp)
167: register struct Labelblock *lp;
168: {
169: extern expptr labelfudge();
170: int oldlbl;
171:
172: if(lp == NULL)
173: {
174: execerr("unlabeled format statement" , CNULL);
175: return(-1);
176: }
177: if(lp->labtype == LABUNKNOWN)
178: {
179: oldlbl = lp->labelno;
180: lp->labtype = LABFORMAT;
181: lp->labelno = newlabel();
182: labelfudge(oldlbl, lp->labelno);
183: }
184: else if(lp->labtype != LABFORMAT)
185: {
186: execerr("bad format number", CNULL);
187: return(-1);
188: }
189: return(lp->labelno);
190: }
191:
192:
193:
194: setfmt(lp)
195: struct Labelblock *lp;
196: {
197: int n;
198: char *s, *lexline();
199:
200: s = lexline(&n);
201: preven(ALILONG);
202: prlabel(asmfile, lp->labelno);
203: putstr(asmfile, s, n);
204: flline();
205: }
206:
207:
208:
209: startioctl()
210: {
211: register int i;
212:
213: inioctl = YES;
214: nioctl = 0;
215: ioformatted = UNFORMATTED;
216: for(i = 1 ; i<=NIOS ; ++i)
217: V(i) = NULL;
218: }
219:
220:
221:
222: endioctl()
223: {
224: int i;
225: expptr p;
226:
227: inioctl = NO;
228:
229: /* set up for error recovery */
230:
231: ioerrlab = ioendlab = skiplab = jumplab = 0;
232:
233: if(p = V(IOSEND))
234: if(ISICON(p))
235: ioendlab = execlab(p->constblock.Const.ci) ->labelno;
236: else
237: err("bad end= clause");
238:
239: if(p = V(IOSERR))
240: if(ISICON(p))
241: ioerrlab = execlab(p->constblock.Const.ci) ->labelno;
242: else
243: err("bad err= clause");
244:
245: if(IOSTP)
246: if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
247: {
248: err("iostat must be an integer variable");
249: frexpr(IOSTP);
250: IOSTP = NULL;
251: }
252:
253: if(iostmt == IOREAD)
254: {
255: if(IOSTP)
256: {
257: if(ioerrlab && ioendlab && ioerrlab==ioendlab)
258: jumplab = ioerrlab;
259: else
260: skiplab = jumplab = newlabel();
261: }
262: else {
263: if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
264: {
265: IOSTP = (expptr) mktemp(TYINT, PNULL);
266: skiplab = jumplab = newlabel();
267: }
268: else
269: jumplab = (ioerrlab ? ioerrlab : ioendlab);
270: }
271: }
272: else if(iostmt == IOWRITE)
273: {
274: if(IOSTP && !ioerrlab)
275: skiplab = jumplab = newlabel();
276: else
277: jumplab = ioerrlab;
278: }
279: else
280: jumplab = ioerrlab;
281:
282: endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */
283: errbit = IOSTP!=NULL || ioerrlab!=0;
284: if(iostmt!=IOREAD && iostmt!=IOWRITE)
285: {
286: if(ioblkp == NULL)
287: ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
288: ioset(TYIOINT, XERR, ICON(errbit));
289: }
290:
291: switch(iostmt)
292: {
293: case IOOPEN:
294: dofopen();
295: break;
296:
297: case IOCLOSE:
298: dofclose();
299: break;
300:
301: case IOINQUIRE:
302: dofinquire();
303: break;
304:
305: case IOBACKSPACE:
306: dofmove("f_back");
307: break;
308:
309: case IOREWIND:
310: dofmove("f_rew");
311: break;
312:
313: case IOENDFILE:
314: dofmove("f_end");
315: break;
316:
317: case IOREAD:
318: case IOWRITE:
319: startrw();
320: break;
321:
322: default:
323: fatali("impossible iostmt %d", iostmt);
324: }
325: for(i = 1 ; i<=NIOS ; ++i)
326: if(i!=IOSIOSTAT && V(i)!=NULL)
327: frexpr(V(i));
328: }
329:
330:
331:
332: iocname()
333: {
334: register int i;
335: int found, mask;
336:
337: found = 0;
338: mask = M(iostmt);
339: for(i = 1 ; i <= NIOS ; ++i)
340: if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
341: if(ioc[i].iotype & mask)
342: return(i);
343: else found = i;
344: if(found)
345: errstr("invalid control %s for statement", ioc[found].iocname);
346: else
347: errstr("unknown iocontrol %s", varstr(toklen, token) );
348: return(IOSBAD);
349: }
350:
351:
352: ioclause(n, p)
353: register int n;
354: register expptr p;
355: {
356: struct Ioclist *iocp;
357:
358: ++nioctl;
359: if(n == IOSBAD)
360: return;
361: if(n == IOSPOSITIONAL)
362: {
363: n = nioctl;
364: if (nioctl == IOSFMT) {
365: if (iostmt == IOOPEN) {
366: n = IOSFILE;
367: NOEXT("file= specifier omitted from open");
368: }
369: else if (iostmt < IOREAD)
370: goto illegal;
371: }
372: else if(nioctl > IOSFMT)
373: {
374: illegal:
375: err("illegal positional iocontrol");
376: return;
377: }
378: }
379: else if (n == IOSNML)
380: n = IOSFMT;
381:
382: if(p == NULL)
383: {
384: if(n == IOSUNIT)
385: p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
386: else if(n != IOSFMT)
387: {
388: err("illegal * iocontrol");
389: return;
390: }
391: }
392: if(n == IOSFMT)
393: ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
394:
395: iocp = & ioc[n];
396: if(iocp->iocval == NULL)
397: {
398: if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) )
399: p = fixtype(p);
400: iocp->iocval = p;
401: }
402: else
403: errstr("iocontrol %s repeated", iocp->iocname);
404: }
405:
406: /* io list item */
407:
408: doio(list)
409: chainp list;
410: {
411: expptr call0();
412:
413: if(ioformatted == NAMEDIRECTED)
414: {
415: if(list)
416: err("no I/O list allowed in NAMELIST read/write");
417: }
418: else
419: {
420: doiolist(list);
421: ioroutine[0] = 'e';
422: putiocall( call0(TYINT, ioroutine) );
423: }
424: }
425:
426:
427:
428:
429:
430: LOCAL doiolist(p0)
431: chainp p0;
432: {
433: chainp p;
434: register tagptr q;
435: register expptr qe;
436: register Namep qn;
437: Addrp tp, mkscalar();
438: int range;
439:
440: for (p = p0 ; p ; p = p->nextp)
441: {
442: q = p->datap;
443: if(q->tag == TIMPLDO)
444: {
445: exdo(range=newlabel(), q->impldoblock.impdospec);
446: doiolist(q->impldoblock.datalist);
447: enddo(range);
448: free( (charptr) q);
449: }
450: else {
451: if(q->tag==TPRIM && q->primblock.argsp==NULL
452: && q->primblock.namep->vdim!=NULL)
453: {
454: vardcl(qn = q->primblock.namep);
455: if(qn->vdim->nelt)
456: putio( fixtype(cpexpr(qn->vdim->nelt)),
457: mkscalar(qn) );
458: else
459: err("attempt to i/o array of unknown size");
460: }
461: else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
462: (qe = (expptr) memversion(q->primblock.namep)) )
463: putio(ICON(1),qe);
464: else if( (qe = fixtype(cpexpr(q)))->tag==TADDR)
465: putio(ICON(1), qe);
466: else if(qe->headblock.vtype != TYERROR)
467: {
468: if(iostmt == IOWRITE)
469: {
470: ftnint lencat();
471: expptr qvl;
472: qvl = NULL;
473: if( ISCHAR(qe) )
474: {
475: qvl = (expptr)
476: cpexpr(qe->headblock.vleng);
477: tp = mktemp(qe->headblock.vtype,
478: ICON(lencat(qe)));
479: }
480: else
481: tp = mktemp(qe->headblock.vtype,
482: qe->headblock.vleng);
483: puteq( cpexpr(tp), qe);
484: if(qvl) /* put right length on block */
485: {
486: frexpr(tp->vleng);
487: tp->vleng = qvl;
488: }
489: putio(ICON(1), tp);
490: }
491: else
492: err("non-left side in READ list");
493: }
494: frexpr(q);
495: }
496: }
497: frchain( &p0 );
498: }
499:
500:
501:
502:
503:
504: LOCAL putio(nelt, addr)
505: expptr nelt;
506: register expptr addr;
507: {
508: int type;
509: register expptr q;
510:
511: type = addr->headblock.vtype;
512: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
513: {
514: nelt = mkexpr(OPSTAR, ICON(2), nelt);
515: type -= (TYCOMPLEX-TYREAL);
516: }
517:
518: /* pass a length with every item. for noncharacter data, fake one */
519: if(type != TYCHAR)
520: {
521: if( ISCONST(addr) )
522: addr = (expptr) putconst(addr);
523: addr->headblock.vtype = TYCHAR;
524: addr->headblock.vleng = ICON( typesize[type] );
525: }
526:
527: nelt = fixtype( mkconv(TYLENG,nelt) );
528: if(ioformatted == LISTDIRECTED)
529: q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
530: else
531: q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
532: nelt, addr);
533: putiocall(q);
534: }
535:
536:
537:
538:
539: endio()
540: {
541: if(skiplab)
542: {
543: putlabel(skiplab);
544: if(ioendlab)
545: putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab);
546: if(ioerrlab)
547: putif( mkexpr( ( (iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ),
548: cpexpr(IOSTP), ICON(0)) , ioerrlab);
549: }
550: if(IOSTP)
551: frexpr(IOSTP);
552: }
553:
554:
555:
556: LOCAL putiocall(q)
557: register expptr q;
558: {
559: if(IOSTP)
560: {
561: q->headblock.vtype = TYINT;
562: q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
563: }
564:
565: if(jumplab)
566: putif( mkexpr(OPEQ, q, ICON(0) ), jumplab);
567: else
568: putexpr(q);
569: }
570:
571: startrw()
572: {
573: register expptr p;
574: register Namep np;
575: register Addrp unitp, fmtp, recp, tioblkp;
576: register expptr nump;
577: Addrp mkscalar();
578: expptr mkaddcon();
579: int k;
580: flag intfile, sequential, ok, varfmt;
581:
582: /* First look at all the parameters and determine what is to be done */
583:
584: ok = YES;
585: statstruct = YES;
586:
587: intfile = NO;
588: if(p = V(IOSUNIT))
589: {
590: if( ISINT(p->headblock.vtype) )
591: unitp = (Addrp) cpexpr(p);
592: else if(p->headblock.vtype == TYCHAR)
593: {
594: intfile = YES;
595: if(p->tag==TPRIM && p->primblock.argsp==NULL &&
596: (np = p->primblock.namep)->vdim!=NULL)
597: {
598: vardcl(np);
599: if(np->vdim->nelt)
600: {
601: nump = (expptr) cpexpr(np->vdim->nelt);
602: if( ! ISCONST(nump) )
603: statstruct = NO;
604: }
605: else
606: {
607: err("attempt to use internal unit array of unknown size");
608: ok = NO;
609: nump = ICON(1);
610: }
611: unitp = mkscalar(np);
612: }
613: else {
614: nump = ICON(1);
615: unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
616: }
617: if(! isstatic(unitp) )
618: statstruct = NO;
619: }
620: }
621: else
622: {
623: err("bad unit specifier");
624: ok = NO;
625: }
626:
627: sequential = YES;
628: if(p = V(IOSREC))
629: if( ISINT(p->headblock.vtype) )
630: {
631: recp = (Addrp) cpexpr(p);
632: sequential = NO;
633: }
634: else {
635: err("bad REC= clause");
636: ok = NO;
637: }
638: else
639: recp = NULL;
640:
641:
642: varfmt = YES;
643: fmtp = NULL;
644: if(p = V(IOSFMT))
645: {
646: if(p->tag==TPRIM && p->primblock.argsp==NULL)
647: {
648: np = p->primblock.namep;
649: if(np->vclass == CLNAMELIST)
650: {
651: ioformatted = NAMEDIRECTED;
652: fmtp = (Addrp) fixtype(p);
653: V(IOSFMT) = (expptr)fmtp;
654: goto endfmt;
655: }
656: vardcl(np);
657: if(np->vdim)
658: {
659: if( ! ONEOF(np->vstg, MSKSTATIC) )
660: statstruct = NO;
661: fmtp = mkscalar(np);
662: goto endfmt;
663: }
664: if( ISINT(np->vtype) ) /* ASSIGNed label */
665: {
666: statstruct = NO;
667: varfmt = NO;
668: fmtp = (Addrp) fixtype(p);
669: if (!(bugwarn & 2)) {
670: V(IOSFMT) = 0;
671: if (bugwarn)
672: warnb("old f77 died here");
673: }
674: goto endfmt;
675: }
676: }
677: p = V(IOSFMT) = fixtype(p);
678: if(p->headblock.vtype == TYCHAR)
679: {
680: if( ! isstatic(p) )
681: statstruct = NO;
682: fmtp = (Addrp) cpexpr(p);
683: }
684: else if( ISICON(p) )
685: {
686: if( (k = fmtstmt( mklabel(p->constblock.Const.ci) )) > 0 )
687: {
688: fmtp = (Addrp) mkaddcon(k);
689: varfmt = NO;
690: }
691: else
692: ioformatted = UNFORMATTED;
693: }
694: else {
695: err("bad format descriptor");
696: ioformatted = UNFORMATTED;
697: ok = NO;
698: }
699: }
700: else
701: fmtp = NULL;
702:
703: endfmt:
704: if(intfile) {
705: if (ioformatted==UNFORMATTED) {
706: err("unformatted internal I/O not allowed");
707: ok = NO;
708: }
709: if (recp) {
710: err("direct internal I/O not allowed");
711: ok = NO;
712: }
713: }
714: if(!sequential && ioformatted==LISTDIRECTED)
715: {
716: err("direct list-directed I/O not allowed");
717: ok = NO;
718: }
719: if(!sequential && ioformatted==NAMEDIRECTED)
720: {
721: err("direct namelist I/O not allowed");
722: ok = NO;
723: }
724:
725: if( ! ok )
726: return;
727:
728: /*
729: Now put out the I/O structure, statically if all the clauses
730: are constants, dynamically otherwise
731: */
732:
733: if(statstruct)
734: {
735: tioblkp = ioblkp;
736: ioblkp = ALLOC(Addrblock);
737: ioblkp->tag = TADDR;
738: ioblkp->vtype = TYIOINT;
739: ioblkp->vclass = CLVAR;
740: ioblkp->vstg = STGINIT;
741: ioblkp->memno = ++lastvarno;
742: ioblkp->memoffset = ICON(0);
743: blklen = (intfile ? XIREC+SZIOINT :
744: (sequential ? XFMT+SZADDR : XRNUM+SZIOINT) );
745: }
746: else if(ioblkp == NULL)
747: ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
748:
749: ioset(TYIOINT, XERR, ICON(errbit));
750: if(iostmt == IOREAD)
751: ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
752:
753: if(intfile)
754: {
755: ioset(TYIOINT, XIRNUM, nump);
756: ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
757: ioseta(XIUNIT, unitp);
758: }
759: else
760: ioset(TYIOINT, XUNIT, (expptr) unitp);
761:
762: if(recp)
763: ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp);
764:
765: if(varfmt)
766: ioseta( intfile ? XIFMT : XFMT , fmtp);
767: else
768: ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
769:
770: ioroutine[0] = 's';
771: ioroutine[1] = '_';
772: ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
773: ioroutine[3] = (sequential ? 's' : 'd');
774: ioroutine[4] = "ufln" [ioformatted];
775: ioroutine[5] = (intfile ? 'i' : 'e');
776: ioroutine[6] = '\0';
777:
778: putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
779:
780: if(statstruct)
781: {
782: frexpr(ioblkp);
783: ioblkp = tioblkp;
784: statstruct = NO;
785: }
786: }
787:
788:
789:
790: LOCAL dofopen()
791: {
792: register expptr p;
793:
794: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
795: ioset(TYIOINT, XUNIT, cpexpr(p) );
796: else
797: err("bad unit in open");
798: if( (p = V(IOSFILE)) )
799: if(p->headblock.vtype == TYCHAR)
800: ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
801: else
802: err("bad file in open");
803:
804: iosetc(XFNAME, p);
805:
806: if(p = V(IOSRECL))
807: if( ISINT(p->headblock.vtype) )
808: ioset(TYIOINT, XRECLEN, cpexpr(p) );
809: else
810: err("bad recl");
811: else
812: ioset(TYIOINT, XRECLEN, ICON(0) );
813:
814: iosetc(XSTATUS, V(IOSSTATUS));
815: iosetc(XACCESS, V(IOSACCESS));
816: iosetc(XFORMATTED, V(IOSFORM));
817: iosetc(XBLANK, V(IOSBLANK));
818:
819: putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
820: }
821:
822:
823: LOCAL dofclose()
824: {
825: register expptr p;
826:
827: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
828: {
829: ioset(TYIOINT, XUNIT, cpexpr(p) );
830: iosetc(XCLSTATUS, V(IOSSTATUS));
831: putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
832: }
833: else
834: err("bad unit in close statement");
835: }
836:
837:
838: LOCAL dofinquire()
839: {
840: register expptr p;
841: if(p = V(IOSUNIT))
842: {
843: if( V(IOSFILE) )
844: err("inquire by unit or by file, not both");
845: ioset(TYIOINT, XUNIT, cpexpr(p) );
846: }
847: else if( ! V(IOSFILE) )
848: err("must inquire by unit or by file");
849: iosetlc(IOSFILE, XFILE, XFILELEN);
850: iosetip(IOSEXISTS, XEXISTS);
851: iosetip(IOSOPENED, XOPEN);
852: iosetip(IOSNUMBER, XNUMBER);
853: iosetip(IOSNAMED, XNAMED);
854: iosetlc(IOSNAME, XNAME, XNAMELEN);
855: iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
856: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
857: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
858: iosetlc(IOSFORM, XFORM, XFORMLEN);
859: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
860: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
861: iosetip(IOSRECL, XQRECL);
862: iosetip(IOSNEXTREC, XNEXTREC);
863: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
864:
865: putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) ));
866: }
867:
868:
869:
870: LOCAL dofmove(subname)
871: char *subname;
872: {
873: register expptr p;
874:
875: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
876: {
877: ioset(TYIOINT, XUNIT, cpexpr(p) );
878: putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
879: }
880: else
881: err("bad unit in I/O motion statement");
882: }
883:
884:
885:
886: LOCAL ioset(type, offset, p)
887: int type, offset;
888: register expptr p;
889: {
890: register Addrp q;
891:
892: q = (Addrp) cpexpr(ioblkp);
893: q->vtype = type;
894: q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) );
895: if(statstruct && ISCONST(p))
896: {
897: setdata(q, p, 0L, blklen);
898: frexpr(q);
899: frexpr(p);
900: }
901: else
902: puteq(q, p);
903: }
904:
905:
906:
907:
908: LOCAL iosetc(offset, p)
909: int offset;
910: register expptr p;
911: {
912: if(p == NULL)
913: ioset(TYADDR, offset, ICON(0) );
914: else if(p->headblock.vtype == TYCHAR)
915: ioset(TYADDR, offset, addrof(cpexpr(p) ));
916: else
917: err("non-character control clause");
918: }
919:
920:
921:
922: LOCAL ioseta(offset, p)
923: int offset;
924: register Addrp p;
925: {
926: char *dataname();
927:
928: if(statstruct)
929: {
930: dataline(dataname(STGINIT,ioblkp->memno), (ftnint) offset,
931: blklen, TYADDR);
932: if(p)
933: praddr(initfile, p->vstg, p->memno,
934: p->memoffset->constblock.Const.ci);
935: else
936: praddr(initfile, STGNULL, 0, (ftnint) 0);
937: }
938: else
939: ioset(TYADDR, offset, p ? addrof(p) : ICON(0) );
940: }
941:
942:
943:
944:
945: LOCAL iosetip(i, offset)
946: int i, offset;
947: {
948: register expptr p;
949:
950: if(p = V(i))
951: if(p->tag==TADDR &&
952: ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) )
953: ioset(TYADDR, offset, addrof(cpexpr(p)) );
954: else
955: errstr("impossible inquire parameter %s", ioc[i].iocname);
956: else
957: ioset(TYADDR, offset, ICON(0) );
958: }
959:
960:
961:
962: LOCAL iosetlc(i, offp, offl)
963: int i, offp, offl;
964: {
965: register expptr p;
966: if( (p = V(i)) && p->headblock.vtype==TYCHAR)
967: ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
968: iosetc(offp, p);
969: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.