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