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
fmtstmt(lp)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
startioctl()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
endioctl()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
iocname()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
ioclause(n,p)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
doio(list)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
doiolist(p0)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
putio(nelt,addr)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
endio()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
putiocall(q)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
startrw()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
dofopen()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
dofclose()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
dofinquire()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
dofmove(subname)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
ioset(type,offset,p)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
iosetc(offset,p)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
ioseta(offset,p)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
iosetip(i,offset)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
iosetlc(i,offp,offl)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 *
mkiodata(blkno,offset,len)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
outiodata()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
outolist(op,len)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