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