![[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 / usr.bin / f77 / src / f77pass1|
Return to io.c CVS log | Up to [CSRG BSD Unix] / 42BSD / usr.bin / f77 / src / f77pass1 |
1.1 root 1: /* @(#)io.c 1.3 (Berkeley) 6/1/81 */
2: /* Routines to generate code for I/O statements.
3: Some corrections and improvements due to David Wasley, U. C. Berkeley
4: */
5:
6: /* TEMPORARY */
7: #define TYIOINT TYLONG
8: #define SZIOINT SZLONG
9:
10: #include "defs.h"
11: #include "io.h"
12:
13:
14: LOCAL char ioroutine[XL+1];
15:
16: LOCAL int ioendlab;
17: LOCAL int ioerrlab;
18: LOCAL int endbit;
19: LOCAL int errbit;
20: LOCAL int jumplab;
21: LOCAL int skiplab;
22: LOCAL int ioformatted;
23: LOCAL int statstruct = NO;
24: LOCAL ftnint blklen;
25:
26: LOCAL offsetlist *mkiodata();
27:
28:
29: #define UNFORMATTED 0
30: #define FORMATTED 1
31: #define LISTDIRECTED 2
32: #define NAMEDIRECTED 3
33:
34: #define V(z) ioc[z].iocval
35:
36: #define IOALL 07777
37:
38: LOCAL struct Ioclist
39: {
40: char *iocname;
41: int iotype;
42: expptr iocval;
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: } ;
69:
70: #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
71: #define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR
72:
73: #define IOSUNIT 1
74: #define IOSFMT 2
75: #define IOSERR 3
76: #define IOSEND 4
77: #define IOSIOSTAT 5
78: #define IOSREC 6
79: #define IOSRECL 7
80: #define IOSFILE 8
81: #define IOSSTATUS 9
82: #define IOSACCESS 10
83: #define IOSFORM 11
84: #define IOSBLANK 12
85: #define IOSEXISTS 13
86: #define IOSOPENED 14
87: #define IOSNUMBER 15
88: #define IOSNAMED 16
89: #define IOSNAME 17
90: #define IOSSEQUENTIAL 18
91: #define IOSDIRECT 19
92: #define IOSFORMATTED 20
93: #define IOSUNFORMATTED 21
94: #define IOSNEXTREC 22
95:
96: #define IOSTP V(IOSIOSTAT)
97:
98:
99: /* offsets in generated structures */
100:
101: #define SZFLAG SZIOINT
102:
103: /* offsets for external READ and WRITE statements */
104:
105: #define XERR 0
106: #define XUNIT SZFLAG
107: #define XEND SZFLAG + SZIOINT
108: #define XFMT 2*SZFLAG + SZIOINT
109: #define XREC 2*SZFLAG + SZIOINT + SZADDR
110: #define XRLEN 2*SZFLAG + 2*SZADDR
111: #define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
112:
113: /* offsets for internal READ and WRITE statements */
114:
115: #define XIERR 0
116: #define XIUNIT SZFLAG
117: #define XIEND SZFLAG + SZADDR
118: #define XIFMT 2*SZFLAG + SZADDR
119: #define XIRLEN 2*SZFLAG + 2*SZADDR
120: #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
121: #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT
122:
123: /* offsets for OPEN statements */
124:
125: #define XFNAME SZFLAG + SZIOINT
126: #define XFNAMELEN SZFLAG + SZIOINT + SZADDR
127: #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
128: #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
129: #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR
130: #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
131: #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
132:
133: /* offset for CLOSE statement */
134:
135: #define XCLSTATUS SZFLAG + SZIOINT
136:
137: /* offsets for INQUIRE statement */
138:
139: #define XFILE SZFLAG + SZIOINT
140: #define XFILELEN SZFLAG + SZIOINT + SZADDR
141: #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
142: #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR
143: #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
144: #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
145: #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR
146: #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR
147: #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR
148: #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR
149: #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR
150: #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
151: #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
152: #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
153: #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR
154: #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR
155: #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
156: #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR
157: #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
158: #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR
159: #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
160: #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR
161: #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
162: #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR
163:
164: fmtstmt(lp)
165: register struct Labelblock *lp;
166: {
167: if(lp == NULL)
168: {
169: execerr("unlabeled format statement" , CNULL);
170: return(-1);
171: }
172: if(lp->labtype == LABUNKNOWN)
173: {
174: lp->labtype = LABFORMAT;
175: lp->labelno = newlabel();
176: }
177: else if(lp->labtype != LABFORMAT)
178: {
179: execerr("bad format number", CNULL);
180: return(-1);
181: }
182: return(lp->labelno);
183: }
184:
185:
186:
187: setfmt(lp)
188: struct Labelblock *lp;
189: {
190: int n;
191: char *s, *lexline();
192:
193: s = lexline(&n);
194: preven(ALILONG);
195: prlabel(asmfile, lp->labelno);
196: putstr(asmfile, s, n);
197: flline();
198: }
199:
200:
201:
202: startioctl()
203: {
204: register int i;
205:
206: inioctl = YES;
207: nioctl = 0;
208: ioformatted = UNFORMATTED;
209: for(i = 1 ; i<=NIOS ; ++i)
210: V(i) = NULL;
211: }
212:
213:
214:
215: endioctl()
216: {
217: int i;
218: expptr p;
219:
220: inioctl = NO;
221:
222: /* set up for error recovery */
223:
224: ioerrlab = ioendlab = skiplab = jumplab = 0;
225:
226: if(p = V(IOSEND))
227: if(ISICON(p))
228: ioendlab = execlab(p->constblock.const.ci) ->labelno;
229: else
230: err("bad end= clause");
231:
232: if(p = V(IOSERR))
233: if(ISICON(p))
234: ioerrlab = execlab(p->constblock.const.ci) ->labelno;
235: else
236: err("bad err= clause");
237:
238: if(IOSTP)
239: if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
240: {
241: err("iostat must be an integer variable");
242: frexpr(IOSTP);
243: IOSTP = NULL;
244: }
245:
246: if(iostmt == IOREAD)
247: {
248: if(IOSTP)
249: {
250: if(ioerrlab && ioendlab && ioerrlab==ioendlab)
251: jumplab = ioerrlab;
252: else
253: skiplab = jumplab = newlabel();
254: }
255: else {
256: if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
257: {
258: IOSTP = (expptr) mktemp(TYINT, PNULL);
259: skiplab = jumplab = newlabel();
260: }
261: else
262: jumplab = (ioerrlab ? ioerrlab : ioendlab);
263: }
264: }
265: else if(iostmt == IOWRITE)
266: {
267: if(IOSTP && !ioerrlab)
268: skiplab = jumplab = newlabel();
269: else
270: jumplab = ioerrlab;
271: }
272: else
273: jumplab = ioerrlab;
274:
275: endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */
276: errbit = IOSTP!=NULL || ioerrlab!=0;
277: if(iostmt!=IOREAD && iostmt!=IOWRITE)
278: {
279: if(ioblkp == NULL)
280: ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
281: ioset(TYIOINT, XERR, ICON(errbit));
282: }
283:
284: switch(iostmt)
285: {
286: case IOOPEN:
287: dofopen(); break;
288:
289: case IOCLOSE:
290: dofclose(); break;
291:
292: case IOINQUIRE:
293: dofinquire(); break;
294:
295: case IOBACKSPACE:
296: dofmove("f_back"); break;
297:
298: case IOREWIND:
299: dofmove("f_rew"); break;
300:
301: case IOENDFILE:
302: dofmove("f_end"); break;
303:
304: case IOREAD:
305: case IOWRITE:
306: startrw(); break;
307:
308: default:
309: fatali("impossible iostmt %d", iostmt);
310: }
311: for(i = 1 ; i<=NIOS ; ++i)
312: if(i!=IOSIOSTAT && V(i)!=NULL)
313: frexpr(V(i));
314: }
315:
316:
317:
318: iocname()
319: {
320: register int i;
321: int found, mask;
322:
323: found = 0;
324: mask = M(iostmt);
325: for(i = 1 ; i <= NIOS ; ++i)
326: if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname))
327: if(ioc[i].iotype & mask)
328: return(i);
329: else found = i;
330: if(found)
331: errstr("invalid control %s for statement", ioc[found].iocname);
332: else
333: errstr("unknown iocontrol %s", varstr(toklen, token) );
334: return(IOSBAD);
335: }
336:
337:
338: ioclause(n, p)
339: register int n;
340: register expptr p;
341: {
342: struct Ioclist *iocp;
343:
344: ++nioctl;
345: if(n == IOSBAD)
346: return;
347: if(n == IOSPOSITIONAL)
348: {
349: if(nioctl > IOSFMT)
350: {
351: err("illegal positional iocontrol");
352: return;
353: }
354: n = nioctl;
355: }
356:
357: if(p == NULL)
358: {
359: if(n == IOSUNIT)
360: p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
361: else if(n != IOSFMT)
362: {
363: err("illegal * iocontrol");
364: return;
365: }
366: }
367: if(n == IOSFMT)
368: ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
369:
370: iocp = & ioc[n];
371: if(iocp->iocval == NULL)
372: {
373: if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) )
374: p = fixtype(p);
375: if(p!=NULL && ISCONST(p) && p->constblock.vtype==TYCHAR)
376: p = (expptr) putconst(p);
377: iocp->iocval = p;
378: }
379: else
380: errstr("iocontrol %s repeated", iocp->iocname);
381: }
382:
383: /* io list item */
384:
385: doio(list)
386: chainp list;
387: {
388: expptr call0();
389:
390: if(ioformatted == NAMEDIRECTED)
391: {
392: if(list)
393: err("no I/O list allowed in NAMELIST read/write");
394: }
395: else
396: {
397: doiolist(list);
398: ioroutine[0] = 'e';
399: putiocall( call0(TYINT, ioroutine) );
400: }
401: }
402:
403:
404:
405:
406:
407: LOCAL doiolist(p0)
408: chainp p0;
409: {
410: chainp p;
411: register tagptr q;
412: register expptr qe;
413: register Namep qn;
414: Addrp tp, mkscalar();
415: int range;
416: expptr expr;
417:
418: for (p = p0 ; p ; p = p->nextp)
419: {
420: q = p->datap;
421: if(q->tag == TIMPLDO)
422: {
423: exdo(range=newlabel(), q->impldoblock.impdospec);
424: doiolist(q->impldoblock.datalist);
425: enddo(range);
426: free( (charptr) q);
427: }
428: else {
429: if(q->tag==TPRIM && q->primblock.argsp==NULL
430: && q->primblock.namep->vdim!=NULL)
431: {
432: vardcl(qn = q->primblock.namep);
433: if(qn->vdim->nelt)
434: putio( fixtype(cpexpr(qn->vdim->nelt)),
435: mkscalar(qn) );
436: else
437: err("attempt to i/o array of unknown size");
438: }
439: else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
440: (qe = (expptr) memversion(q->primblock.namep)) )
441: putio(ICON(1),qe);
442: else if( (qe = fixtype(cpexpr(q)))->tag==TADDR)
443: putio(ICON(1), qe);
444: else if(qe->headblock.vtype != TYERROR)
445: {
446: if(iostmt == IOWRITE)
447: {
448: ftnint lencat();
449: expptr qvl;
450: qvl = NULL;
451: if( ISCHAR(qe) )
452: {
453: qvl = (expptr)
454: cpexpr(qe->headblock.vleng);
455: tp = mktemp(qe->headblock.vtype,
456: ICON(lencat(qe)));
457: }
458: else
459: tp = mktemp(qe->headblock.vtype,
460: qe->headblock.vleng);
461: if (optimflag)
462: {
463: expr = mkexpr(OPASSIGN,cpexpr(tp),qe);
464: optbuff (SKEQ,expr,0,0);
465: }
466: else
467: puteq (cpexpr(tp),qe);
468: if(qvl) /* put right length on block */
469: {
470: frexpr(tp->vleng);
471: tp->vleng = qvl;
472: }
473: putio(ICON(1), tp);
474: }
475: else
476: err("non-left side in READ list");
477: }
478: frexpr(q);
479: }
480: }
481: frchain( &p0 );
482: }
483:
484:
485:
486:
487:
488: LOCAL putio(nelt, addr)
489: expptr nelt;
490: register expptr addr;
491: {
492: int type;
493: register expptr q;
494:
495: type = addr->headblock.vtype;
496: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
497: {
498: nelt = mkexpr(OPSTAR, ICON(2), nelt);
499: type -= (TYCOMPLEX-TYREAL);
500: }
501:
502: /* pass a length with every item. for noncharacter data, fake one */
503: if(type != TYCHAR)
504: {
505: addr->headblock.vtype = TYCHAR;
506: addr->headblock.vleng = ICON( typesize[type] );
507: }
508:
509: nelt = fixtype( mkconv(TYLENG,nelt) );
510: if(ioformatted == LISTDIRECTED)
511: q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
512: else
513: q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
514: nelt, addr);
515: putiocall(q);
516: }
517:
518:
519:
520:
521: endio()
522: {
523: if(skiplab)
524: {
525: if (optimflag)
526: optbuff (SKLABEL, 0, skiplab, 0);
527: else
528: putlabel (skiplab);
529: if(ioendlab)
530: {
531: expptr test;
532: test = mkexpr(OPGE, cpexpr(IOSTP), ICON(0));
533: if (optimflag)
534: optbuff (SKIOIFN,test,ioendlab,0);
535: else
536: putif (test,ioendlab);
537: }
538: if(ioerrlab)
539: {
540: expptr test;
541: test = mkexpr
542: ( ((iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ),
543: cpexpr(IOSTP), ICON(0));
544: if (optimflag)
545: optbuff (SKIOIFN,test,ioerrlab,0);
546: else
547: putif (test,ioerrlab);
548: }
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: if (optimflag)
567: optbuff (SKIOIFN,mkexpr(OPEQ,q,ICON(0)),jumplab,0);
568: else
569: putif (mkexpr(OPEQ,q,ICON(0)),jumplab);
570: else
571: if (optimflag)
572: optbuff (SKEQ, q, 0, 0);
573: else
574: putexpr(q);
575: }
576:
577: startrw()
578: {
579: register expptr p;
580: register Namep np;
581: register Addrp unitp, fmtp, recp, tioblkp;
582: register expptr nump;
583: register ioblock *t;
584: Addrp mkscalar();
585: expptr mkaddcon();
586: int k;
587: flag intfile, sequential, ok, varfmt;
588:
589: /* First look at all the parameters and determine what is to be done */
590:
591: ok = YES;
592: statstruct = YES;
593:
594: intfile = NO;
595: if(p = V(IOSUNIT))
596: {
597: if( ISINT(p->headblock.vtype) )
598: unitp = (Addrp) cpexpr(p);
599: else if(p->headblock.vtype == TYCHAR)
600: {
601: intfile = YES;
602: if(p->tag==TPRIM && p->primblock.argsp==NULL &&
603: (np = p->primblock.namep)->vdim!=NULL)
604: {
605: vardcl(np);
606: if(np->vdim->nelt)
607: {
608: nump = (expptr) cpexpr(np->vdim->nelt);
609: if( ! ISCONST(nump) )
610: statstruct = NO;
611: }
612: else
613: {
614: err("attempt to use internal unit array of unknown size");
615: ok = NO;
616: nump = ICON(1);
617: }
618: unitp = mkscalar(np);
619: }
620: else {
621: nump = ICON(1);
622: unitp = (Addrp) fixtype(cpexpr(p));
623: }
624: if(! isstatic(unitp) )
625: statstruct = NO;
626: }
627: else
628: {
629: err("bad unit specifier type");
630: ok = NO;
631: }
632: }
633: else
634: {
635: err("bad unit specifier");
636: ok = NO;
637: }
638:
639: sequential = YES;
640: if(p = V(IOSREC))
641: if( ISINT(p->headblock.vtype) )
642: {
643: recp = (Addrp) cpexpr(p);
644: sequential = NO;
645: }
646: else {
647: err("bad REC= clause");
648: ok = NO;
649: }
650: else
651: recp = NULL;
652:
653:
654: varfmt = YES;
655: fmtp = NULL;
656: if(p = V(IOSFMT))
657: {
658: if(p->tag==TPRIM && p->primblock.argsp==NULL)
659: {
660: np = p->primblock.namep;
661: if(np->vclass == CLNAMELIST)
662: {
663: ioformatted = NAMEDIRECTED;
664: fmtp = (Addrp) fixtype(p);
665: goto endfmt;
666: }
667: vardcl(np);
668: if(np->vdim)
669: {
670: if( ! ONEOF(np->vstg, MSKSTATIC) )
671: statstruct = NO;
672: fmtp = mkscalar(np);
673: goto endfmt;
674: }
675: if( ISINT(np->vtype) ) /* ASSIGNed label */
676: {
677: statstruct = NO;
678: varfmt = NO;
679: fmtp = (Addrp) fixtype(p);
680: goto endfmt;
681: }
682: }
683: p = V(IOSFMT) = fixtype(p);
684: if(p->headblock.vtype == TYCHAR)
685: {
686: if (p->tag == TCONST) p = (expptr) putconst(p);
687: if( ! isstatic(p) )
688: statstruct = NO;
689: fmtp = (Addrp) cpexpr(p);
690: }
691: else if( ISICON(p) )
692: {
693: if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 )
694: {
695: fmtp = (Addrp) mkaddcon(k);
696: varfmt = NO;
697: }
698: else
699: ioformatted = UNFORMATTED;
700: }
701: else {
702: err("bad format descriptor");
703: ioformatted = UNFORMATTED;
704: ok = NO;
705: }
706: }
707: else
708: fmtp = NULL;
709:
710: endfmt:
711: if(intfile && ioformatted==UNFORMATTED)
712: {
713: err("unformatted internal I/O not allowed");
714: ok = NO;
715: }
716: if(!sequential && ioformatted==LISTDIRECTED)
717: {
718: err("direct list-directed I/O not allowed");
719: ok = NO;
720: }
721: if(!sequential && ioformatted==NAMEDIRECTED)
722: {
723: err("direct namelist I/O not allowed");
724: ok = NO;
725: }
726:
727: if( ! ok )
728: return;
729:
730: if (optimflag && ISCONST (fmtp))
731: fmtp = putconst ( (expptr) fmtp);
732:
733: /*
734: Now put out the I/O structure, statically if all the clauses
735: are constants, dynamically otherwise
736: */
737:
738: if(statstruct)
739: {
740: tioblkp = ioblkp;
741: ioblkp = ALLOC(Addrblock);
742: ioblkp->tag = TADDR;
743: ioblkp->vtype = TYIOINT;
744: ioblkp->vclass = CLVAR;
745: ioblkp->vstg = STGINIT;
746: ioblkp->memno = ++lastvarno;
747: ioblkp->memoffset = ICON(0);
748: blklen = (intfile ? XIREC+SZIOINT :
749: (sequential ? XFMT+SZADDR : XRNUM+SZIOINT) );
750: t = ALLOC(IoBlock);
751: t->blkno = ioblkp->memno;
752: t->len = blklen;
753: t->next = iodata;
754: iodata = t;
755: }
756: else if(ioblkp == NULL)
757: ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
758:
759: ioset(TYIOINT, XERR, ICON(errbit));
760: if(iostmt == IOREAD)
761: ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
762:
763: if(intfile)
764: {
765: ioset(TYIOINT, XIRNUM, nump);
766: ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
767: ioseta(XIUNIT, unitp);
768: }
769: else
770: ioset(TYIOINT, XUNIT, (expptr) unitp);
771:
772: if(recp)
773: ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp);
774:
775: if(varfmt)
776: ioseta( intfile ? XIFMT : XFMT , fmtp);
777: else
778: ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
779:
780: ioroutine[0] = 's';
781: ioroutine[1] = '_';
782: ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
783: ioroutine[3] = (sequential ? 's' : 'd');
784: ioroutine[4] = "ufln" [ioformatted];
785: ioroutine[5] = (intfile ? 'i' : 'e');
786: ioroutine[6] = '\0';
787:
788: putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
789:
790: if(statstruct)
791: {
792: frexpr(ioblkp);
793: ioblkp = tioblkp;
794: statstruct = NO;
795: }
796: }
797:
798:
799:
800: LOCAL dofopen()
801: {
802: register expptr p;
803:
804: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
805: ioset(TYIOINT, XUNIT, cpexpr(p) );
806: else
807: err("bad unit in open");
808: if( (p = V(IOSFILE)) )
809: if(p->headblock.vtype == TYCHAR)
810: ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
811: else
812: err("bad file in open");
813:
814: iosetc(XFNAME, p);
815:
816: if(p = V(IOSRECL))
817: if( ISINT(p->headblock.vtype) )
818: ioset(TYIOINT, XRECLEN, cpexpr(p) );
819: else
820: err("bad recl");
821: else
822: ioset(TYIOINT, XRECLEN, ICON(0) );
823:
824: iosetc(XSTATUS, V(IOSSTATUS));
825: iosetc(XACCESS, V(IOSACCESS));
826: iosetc(XFORMATTED, V(IOSFORM));
827: iosetc(XBLANK, V(IOSBLANK));
828:
829: putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
830: }
831:
832:
833: LOCAL dofclose()
834: {
835: register expptr p;
836:
837: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
838: {
839: ioset(TYIOINT, XUNIT, cpexpr(p) );
840: iosetc(XCLSTATUS, V(IOSSTATUS));
841: putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) );
842: }
843: else
844: err("bad unit in close statement");
845: }
846:
847:
848: LOCAL dofinquire()
849: {
850: register expptr p;
851: if(p = V(IOSUNIT))
852: {
853: if( V(IOSFILE) )
854: err("inquire by unit or by file, not both");
855: ioset(TYIOINT, XUNIT, cpexpr(p) );
856: }
857: else if( ! V(IOSFILE) )
858: err("must inquire by unit or by file");
859: iosetlc(IOSFILE, XFILE, XFILELEN);
860: iosetip(IOSEXISTS, XEXISTS);
861: iosetip(IOSOPENED, XOPEN);
862: iosetip(IOSNUMBER, XNUMBER);
863: iosetip(IOSNAMED, XNAMED);
864: iosetlc(IOSNAME, XNAME, XNAMELEN);
865: iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
866: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
867: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
868: iosetlc(IOSFORM, XFORM, XFORMLEN);
869: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
870: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
871: iosetip(IOSRECL, XQRECL);
872: iosetip(IOSNEXTREC, XNEXTREC);
873: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
874:
875: putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) ));
876: }
877:
878:
879:
880: LOCAL dofmove(subname)
881: char *subname;
882: {
883: register expptr p;
884:
885: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
886: {
887: ioset(TYIOINT, XUNIT, cpexpr(p) );
888: putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
889: }
890: else
891: err("bad unit in I/O motion statement");
892: }
893:
894:
895:
896: LOCAL
897: ioset(type, offset, p)
898: int type;
899: int offset;
900: register expptr p;
901: {
902: static char *badoffset = "badoffset in ioset";
903:
904: register Addrp q;
905: register offsetlist *op;
906:
907: q = (Addrp) cpexpr(ioblkp);
908: q->vtype = type;
909: q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) );
910:
911: if (statstruct && ISCONST(p))
912: {
913: if (!ISICON(q->memoffset))
914: fatal(badoffset);
915:
916: op = mkiodata(q->memno, q->memoffset->constblock.const.ci, blklen);
917: if (op->tag != 0)
918: fatal(badoffset);
919:
920: if (type == TYADDR)
921: {
922: op->tag = NDLABEL;
923: op->val.label = p->constblock.const.ci;
924: }
925: else
926: {
927: op->tag = NDDATA;
928: op->val.cp = (Constp) convconst(type, 0, p);
929: }
930:
931: frexpr((tagptr) p);
932: frexpr((tagptr) q);
933: }
934: else
935: if (optimflag)
936: optbuff (SKEQ, mkexpr(OPASSIGN,q,p), 0,0);
937: else
938: puteq (q,p);
939:
940: return;
941: }
942:
943:
944:
945:
946: LOCAL iosetc(offset, p)
947: int offset;
948: register expptr p;
949: {
950: if(p == NULL)
951: ioset(TYADDR, offset, ICON(0) );
952: else if(p->headblock.vtype == TYCHAR)
953: ioset(TYADDR, offset, addrof(cpexpr(p) ));
954: else
955: err("non-character control clause");
956: }
957:
958:
959:
960: LOCAL ioseta(offset, p)
961: int offset;
962: register Addrp p;
963: {
964: static char *badoffset = "bad offset in ioseta";
965:
966: int blkno;
967: register offsetlist *op;
968:
969: if(statstruct)
970: {
971: blkno = ioblkp->memno;
972: op = mkiodata(blkno, offset, blklen);
973: if (op->tag != 0)
974: fatal(badoffset);
975:
976: if (p == NULL)
977: op->tag = NDNULL;
978: else if (p->tag == TADDR)
979: {
980: op->tag = NDADDR;
981: op->val.addr.stg = p->vstg;
982: op->val.addr.memno = p->memno;
983: op->val.addr.offset = p->memoffset->constblock.const.ci;
984: }
985: else
986: badtag("ioseta", p->tag);
987: }
988: else
989: ioset(TYADDR, offset, p ? addrof(p) : ICON(0) );
990:
991: return;
992: }
993:
994:
995:
996:
997: LOCAL iosetip(i, offset)
998: int i, offset;
999: {
1000: register expptr p;
1001:
1002: if(p = V(i))
1003: if(p->tag==TADDR &&
1004: ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) )
1005: ioset(TYADDR, offset, addrof(cpexpr(p)) );
1006: else
1007: errstr("impossible inquire parameter %s", ioc[i].iocname);
1008: else
1009: ioset(TYADDR, offset, ICON(0) );
1010: }
1011:
1012:
1013:
1014: LOCAL iosetlc(i, offp, offl)
1015: int i, offp, offl;
1016: {
1017: register expptr p;
1018: if( (p = V(i)) && p->headblock.vtype==TYCHAR)
1019: ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
1020: iosetc(offp, p);
1021: }
1022:
1023:
1024: LOCAL offsetlist *
1025: mkiodata(blkno, offset, len)
1026: int blkno;
1027: ftnint offset;
1028: ftnint len;
1029: {
1030: register offsetlist *p, *q;
1031: register ioblock *t;
1032: register int found;
1033:
1034: found = NO;
1035: t = iodata;
1036:
1037: while (found == NO && t != NULL)
1038: {
1039: if (t->blkno == blkno)
1040: found = YES;
1041: else
1042: t = t->next;
1043: }
1044:
1045: if (found == NO)
1046: {
1047: t = ALLOC(IoBlock);
1048: t->blkno = blkno;
1049: t->next = iodata;
1050: iodata = t;
1051: }
1052:
1053: if (len > t->len)
1054: t->len = len;
1055:
1056: p = t->olist;
1057:
1058: if (p == NULL)
1059: {
1060: p = ALLOC(OffsetList);
1061: p->next = NULL;
1062: p->offset = offset;
1063: t->olist = p;
1064: return (p);
1065: }
1066:
1067: for (;;)
1068: {
1069: if (p->offset == offset)
1070: return (p);
1071: else if (p->next != NULL &&
1072: p->next->offset <= offset)
1073: p = p->next;
1074: else
1075: {
1076: q = ALLOC(OffsetList);
1077: q->next = p->next;
1078: p->next = q;
1079: q->offset = offset;
1080: return (q);
1081: }
1082: }
1083: }
1084:
1085:
1086: outiodata()
1087: {
1088: static char *varfmt = "\t.align\t2\nv.%d:\n";
1089:
1090: register ioblock *p;
1091: register ioblock *t;
1092:
1093: if (iodata == NULL) return;
1094:
1095: p = iodata;
1096:
1097: while (p != NULL)
1098: {
1099: fprintf(initfile, varfmt, p->blkno);
1100: outolist(p->olist, p->len);
1101:
1102: t = p;
1103: p = t->next;
1104: free((char *) t);
1105: }
1106:
1107: iodata = NULL;
1108: return;
1109: }
1110:
1111:
1112:
1113: LOCAL
1114: outolist(op, len)
1115: register offsetlist *op;
1116: register int len;
1117: {
1118: static char *overlap = "overlapping i/o fields in outolist";
1119: static char *toolong = "offset too large in outolist";
1120:
1121: static char *spacefmt = "\t.space\t%d\n";
1122:
1123: register offsetlist *t;
1124: register ftnint clen;
1125: register Constp cp;
1126: register int type;
1127:
1128: clen = 0;
1129:
1130: while (op != NULL)
1131: {
1132: if (clen > op->offset)
1133: fatal(overlap);
1134:
1135: if (clen < op->offset)
1136: {
1137: fprintf(initfile, spacefmt, op->offset - clen);
1138: clen = op->offset;
1139: }
1140:
1141: switch (op->tag)
1142: {
1143: default:
1144: badtag("outolist", op->tag);
1145:
1146: case NDDATA:
1147: cp = op->val.cp;
1148: type = cp->vtype;
1149: if (type != TYIOINT)
1150: badtype("outolist", type);
1151: prconi(initfile, type, cp->const.ci);
1152: clen += typesize[type];
1153: frexpr((tagptr) cp);
1154: break;
1155:
1156: case NDLABEL:
1157: prcona(initfile, op->val.label);
1158: clen += typesize[TYADDR];
1159: break;
1160:
1161: case NDADDR:
1162: praddr(initfile, op->val.addr.stg, op->val.addr.memno,
1163: op->val.addr.offset);
1164: clen += typesize[TYADDR];
1165: break;
1166:
1167: case NDNULL:
1168: praddr(initfile, STGNULL, 0, (ftnint) 0);
1169: clen += typesize[TYADDR];
1170: break;
1171: }
1172:
1173: t = op;
1174: op = t->next;
1175: free((char *) t);
1176: }
1177:
1178: if (clen > len)
1179: fatal(toolong);
1180:
1181: if (clen < len)
1182: fprintf(initfile, spacefmt, len - clen);
1183:
1184: return;
1185: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.