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