xref: /original-bsd/usr.bin/f77/pass1.vax/io.c (revision a4d3ae46) 
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.4 (Berkeley) 01/03/88";
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.constant.ci) ->labelno;
256 	else
257 		err("bad end= clause");
258 
259 if(p = V(IOSERR))
260 	if(ISICON(p))
261 		ioerrlab = execlab(p->constblock.constant.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.constant.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.constant.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.constant.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.constant.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->constant.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 }
1215