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