projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
date and time created 90/06/17 18:09:03 by bostic
[unix-history] / usr / src / usr.bin / f77 / pass1.tahoe / io.c
CommitLineData
5e70eefe
KB		 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
8static 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
47LOCAL char ioroutine[XL+1];
48
49LOCAL int ioendlab;
50LOCAL int ioerrlab;
51LOCAL int endbit;
52LOCAL int errbit;
53LOCAL int jumplab;
54LOCAL int skiplab;
55LOCAL int ioformatted;
56LOCAL int statstruct = NO;
57LOCAL ftnint blklen;
58
59LOCAL 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
71LOCAL 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\f
197fmtstmt(lp)
198register struct Labelblock *lp;
199{
200if(lp == NULL)
201 {
202 execerr("unlabeled format statement" , CNULL);
203 return(-1);
204 }
205if(lp->labtype == LABUNKNOWN)
206 lp->labtype = LABFORMAT;
207else if(lp->labtype != LABFORMAT)
208 {
209 execerr("bad format number", CNULL);
210 return(-1);
211 }
212return(lp->labelno);
213}
214
215
216
217startioctl()
218{
219register int i;
220
221inioctl = YES;
222nioctl = 0;
223ioformatted = UNFORMATTED;
224for(i = 1 ; i<=NIOS ; ++i)
225 V(i) = NULL;
226}
227
228
229
230endioctl()
231{
232int i;
233expptr p;
234
235inioctl = NO;
236
237/* set up for error recovery */
238
239ioerrlab = ioendlab = skiplab = jumplab = 0;
240
241if(p = V(IOSEND))
242 if(ISICON(p))
243 ioendlab = execlab(p->constblock.const.ci) ->labelno;
244 else
245 err("bad end= clause");
246
247if(p = V(IOSERR))
248 if(ISICON(p))
249 ioerrlab = execlab(p->constblock.const.ci) ->labelno;
250 else
251 err("bad err= clause");
252
253if(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
261if(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 }
280else if(iostmt == IOWRITE)
281 {
282 if(IOSTP && !ioerrlab)
283 skiplab = jumplab = newlabel();
284 else
285 jumplab = ioerrlab;
286 }
287else
288 jumplab = ioerrlab;
289
290endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */
291errbit = IOSTP!=NULL || ioerrlab!=0;
292if(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
299switch(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 }
326for(i = 1 ; i<=NIOS ; ++i)
327 if(i!=IOSIOSTAT && V(i)!=NULL)
328 frexpr(V(i));
329}
330
331
332
333iocname()
334{
335register int i;
336int found, mask;
337
338found = 0;
339mask = M(iostmt);
340for(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;
345if(found)
346 errstr("invalid control %s for statement", ioc[found].iocname);
347else
348 errstr("unknown iocontrol %s", varstr(toklen, token) );
349return(IOSBAD);
350}
351
352
353ioclause(n, p)
354register int n;
355register expptr p;
356{
357struct Ioclist *iocp;
358
359++nioctl;
360if(n == IOSBAD)
361 return;
362if(n == IOSPOSITIONAL)
363 {
364 if(nioctl > IOSFMT)
365 {
366 err("illegal positional iocontrol");
367 return;
368 }
369 n = nioctl;
370 }
371
372if(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 }
382if(n == IOSFMT)
383 ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
384
385iocp = & ioc[n];
386if(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}
395else
396 errstr("iocontrol %s repeated", iocp->iocname);
397}
398
399/* io list item */
400
401doio(list)
402chainp list;
403{
404expptr call0();
405
406if(ioformatted == NAMEDIRECTED)
407 {
408 if(list)
409 err("no I/O list allowed in NAMELIST read/write");
410 }
411else
412 {
413 doiolist(list);
414 ioroutine[0] = 'e';
415 putiocall( call0(TYINT, ioroutine) );
416 }
417}
418
419
420
421
422
423LOCAL doiolist(p0)
424chainp p0;
425{
426chainp p;
427register tagptr q;
428register expptr qe;
429register Namep qn;
430Addrp tp, mkscalar();
431int range;
432expptr expr;
433
434for (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 }
497frchain( &p0 );
498}
499
500
501
502
503
504LOCAL putio(nelt, addr)
505expptr nelt;
506register expptr addr;
507{
508int type;
509register expptr q;
510
511type = addr->headblock.vtype;
512if(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 */
519if(type != TYCHAR)
520 {
521 addr->headblock.vtype = TYCHAR;
522 addr->headblock.vleng = ICON( typesize[type] );
523 }
524
525nelt = fixtype( mkconv(TYLENG,nelt) );
526if(ioformatted == LISTDIRECTED)
527 q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr);
528else
529 q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"),
530 nelt, addr);
531putiocall(q);
532}
533
534
535
536
537endio()
538{
539if(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 }
566if(IOSTP)
567 frexpr(IOSTP);
568}
569
570
571
572LOCAL putiocall(q)
573register expptr q;
574{
575if(IOSTP)
576 {
577 q->headblock.vtype = TYINT;
578 q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q));
579 }
580
581if(jumplab)
582 if (optimflag)
583 optbuff (SKIOIFN,mkexpr(OPEQ,q,ICON(0)),jumplab,0);
584 else
585 putif (mkexpr(OPEQ,q,ICON(0)),jumplab);
586else
587 if (optimflag)
588 optbuff (SKEQ, q, 0, 0);
589 else
590 putexpr(q);
591}
592\f
593startrw()
594{
595register expptr p;
596register Namep np;
597register Addrp unitp, fmtp, recp, tioblkp;
598register expptr nump;
599register ioblock *t;
600Addrp mkscalar();
601expptr mkaddcon();
602int k;
603flag intfile, sequential, ok, varfmt;
604
605/* First look at all the parameters and determine what is to be done */
606
607ok = YES;
608statstruct = YES;
609
610intfile = NO;
611if(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 }
649else
650 {
651 err("bad unit specifier");
652 ok = NO;
653 }
654
655sequential = YES;
656if(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 }
666else
667 recp = NULL;
668
669
670varfmt = YES;
671fmtp = NULL;
672if(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.const.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 }
723else
724 fmtp = NULL;
725
726endfmt:
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
743if( ! ok )
744 return;
745
746if (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
754if(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 }
772else if(ioblkp == NULL)
773 ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL);
774
775ioset(TYIOINT, XERR, ICON(errbit));
776if(iostmt == IOREAD)
777 ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
778
779if(intfile)
780 {
781 ioset(TYIOINT, XIRNUM, nump);
782 ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
783 ioseta(XIUNIT, unitp);
784 }
785else
786 ioset(TYIOINT, XUNIT, (expptr) unitp);
787
788if(recp)
789 ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp);
790
791if(varfmt)
792 ioseta( intfile ? XIFMT : XFMT , fmtp);
793else
794 ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
795
796ioroutine[0] = 's';
797ioroutine[1] = '_';
798ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w');
799ioroutine[3] = (sequential ? 's' : 'd');
800ioroutine[4] = "ufln" [ioformatted];
801ioroutine[5] = (intfile ? 'i' : 'e');
802ioroutine[6] = '\0';
803
804putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) ));
805
806if(statstruct)
807 {
808 frexpr(ioblkp);
809 ioblkp = tioblkp;
810 statstruct = NO;
811 }
812}
813
814
815
816LOCAL dofopen()
817{
818register expptr p;
819
820if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
821 ioset(TYIOINT, XUNIT, cpexpr(p) );
822else
823 err("bad unit in open");
824if( (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
830iosetc(XFNAME, p);
831
832if(p = V(IOSRECL))
833 if( ISINT(p->headblock.vtype) )
834 ioset(TYIOINT, XRECLEN, cpexpr(p) );
835 else
836 err("bad recl");
837else
838 ioset(TYIOINT, XRECLEN, ICON(0) );
839
840iosetc(XSTATUS, V(IOSSTATUS));
841iosetc(XACCESS, V(IOSACCESS));
842iosetc(XFORMATTED, V(IOSFORM));
843iosetc(XBLANK, V(IOSBLANK));
844
845putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) ));
846}
847
848
849LOCAL dofclose()
850{
851register expptr p;
852
853if( (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 }
859else
860 err("bad unit in close statement");
861}
862
863
864LOCAL dofinquire()
865{
866register expptr p;
867if(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 }
873else if( ! V(IOSFILE) )
874 err("must inquire by unit or by file");
875iosetlc(IOSFILE, XFILE, XFILELEN);
876iosetip(IOSEXISTS, XEXISTS);
877iosetip(IOSOPENED, XOPEN);
878iosetip(IOSNUMBER, XNUMBER);
879iosetip(IOSNAMED, XNAMED);
880iosetlc(IOSNAME, XNAME, XNAMELEN);
881iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
882iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
883iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
884iosetlc(IOSFORM, XFORM, XFORMLEN);
885iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
886iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
887iosetip(IOSRECL, XQRECL);
888iosetip(IOSNEXTREC, XNEXTREC);
889iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
890
891putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) ));
892}
893
894
895
896LOCAL dofmove(subname)
897char *subname;
898{
899register expptr p;
900
901if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
902 {
903 ioset(TYIOINT, XUNIT, cpexpr(p) );
904 putiocall( call1(TYINT, subname, cpexpr(ioblkp) ));
905 }
906else
907 err("bad unit in I/O motion statement");
908}
909
910
911
912LOCAL
913ioset(type, offset, p)
914int type;
915int offset;
916register 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.const.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.const.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
962LOCAL iosetc(offset, p)
963int offset;
964register expptr p;
965{
966if(p == NULL)
967 ioset(TYADDR, offset, ICON(0) );
968else if(p->headblock.vtype == TYCHAR)
969 ioset(TYADDR, offset, addrof(cpexpr(p) ));
970else
971 err("non-character control clause");
972}
973
974
975
976LOCAL ioseta(offset, p)
977int offset;
978register 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.const.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
1013LOCAL iosetip(i, offset)
1014int i, offset;
1015{
1016register expptr p;
1017
1018if(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);
1024else
1025 ioset(TYADDR, offset, ICON(0) );
1026}
1027
1028
1029
1030LOCAL iosetlc(i, offp, offl)
1031int i, offp, offl;
1032{
1033register expptr p;
1034if( (p = V(i)) && p->headblock.vtype==TYCHAR)
1035 ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
1036iosetc(offp, p);
1037}
1038
1039
1040LOCAL offsetlist *
1041mkiodata(blkno, offset, len)
1042int blkno;
1043ftnint offset;
1044ftnint 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
1102outiodata()
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
1129LOCAL
1130outolist(op, len)
1131register offsetlist *op;
1132register 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->const.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}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.