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