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