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