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