![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to io.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to io.c CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: /****************************************************************
2: Copyright 1990, 1991, 1993 by AT&T Bell Laboratories and Bellcore.
3:
4: Permission to use, copy, modify, and distribute this software
5: and its documentation for any purpose and without fee is hereby
6: granted, provided that the above copyright notice appear in all
7: copies and that both that the copyright notice and this
8: permission notice and warranty disclaimer appear in supporting
9: documentation, and that the names of AT&T Bell Laboratories or
10: Bellcore or any of their entities not be used in advertising or
11: publicity pertaining to distribution of the software without
12: specific, written prior permission.
13:
14: AT&T and Bellcore disclaim all warranties with regard to this
15: software, including all implied warranties of merchantability
16: and fitness. In no event shall AT&T or Bellcore be liable for
17: any special, indirect or consequential damages or any damages
18: whatsoever resulting from loss of use, data or profits, whether
19: in an action of contract, negligence or other tortious action,
20: arising out of or in connection with the use or performance of
21: this software.
22: ****************************************************************/
23:
24: /* Routines to generate code for I/O statements.
25: Some corrections and improvements due to David Wasley, U. C. Berkeley
26: */
27:
28: /* TEMPORARY */
29: #define TYIOINT TYLONG
30: #define SZIOINT SZLONG
31:
32: #include "defs.h"
33: #include "names.h"
34: #include "iob.h"
35:
36: extern int inqmask;
37:
38: LOCAL void dofclose(), dofinquire(), dofinquire(), dofmove(), dofopen(),
39: doiolist(), ioset(), ioseta(), iosetc(), iosetip(), iosetlc(),
40: putio(), putiocall();
41:
42: iob_data *iob_list;
43: Addrp io_structs[9];
44:
45: LOCAL char ioroutine[12];
46:
47: LOCAL long ioendlab;
48: LOCAL long ioerrlab;
49: LOCAL int endbit;
50: LOCAL int errbit;
51: LOCAL long jumplab;
52: LOCAL long skiplab;
53: LOCAL int ioformatted;
54: LOCAL int statstruct = NO;
55: LOCAL struct Labelblock *skiplabel;
56: Addrp ioblkp;
57:
58: #define UNFORMATTED 0
59: #define FORMATTED 1
60: #define LISTDIRECTED 2
61: #define NAMEDIRECTED 3
62:
63: #define V(z) ioc[z].iocval
64:
65: #define IOALL 07777
66:
67: LOCAL struct Ioclist
68: {
69: char *iocname;
70: int iotype;
71: expptr iocval;
72: }
73: ioc[ ] =
74: {
75: { "", 0 },
76: { "unit", IOALL },
77: { "fmt", M(IOREAD) | M(IOWRITE) },
78: { "err", IOALL },
79: { "end", M(IOREAD) },
80: { "iostat", IOALL },
81: { "rec", M(IOREAD) | M(IOWRITE) },
82: { "recl", M(IOOPEN) | M(IOINQUIRE) },
83: { "file", M(IOOPEN) | M(IOINQUIRE) },
84: { "status", M(IOOPEN) | M(IOCLOSE) },
85: { "access", M(IOOPEN) | M(IOINQUIRE) },
86: { "form", M(IOOPEN) | M(IOINQUIRE) },
87: { "blank", M(IOOPEN) | M(IOINQUIRE) },
88: { "exist", M(IOINQUIRE) },
89: { "opened", M(IOINQUIRE) },
90: { "number", M(IOINQUIRE) },
91: { "named", M(IOINQUIRE) },
92: { "name", M(IOINQUIRE) },
93: { "sequential", M(IOINQUIRE) },
94: { "direct", M(IOINQUIRE) },
95: { "formatted", M(IOINQUIRE) },
96: { "unformatted", M(IOINQUIRE) },
97: { "nextrec", M(IOINQUIRE) },
98: { "nml", M(IOREAD) | M(IOWRITE) }
99: };
100:
101: #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1)
102:
103: /* #define IOSUNIT 1 */
104: /* #define IOSFMT 2 */
105: #define IOSERR 3
106: #define IOSEND 4
107: #define IOSIOSTAT 5
108: #define IOSREC 6
109: #define IOSRECL 7
110: #define IOSFILE 8
111: #define IOSSTATUS 9
112: #define IOSACCESS 10
113: #define IOSFORM 11
114: #define IOSBLANK 12
115: #define IOSEXISTS 13
116: #define IOSOPENED 14
117: #define IOSNUMBER 15
118: #define IOSNAMED 16
119: #define IOSNAME 17
120: #define IOSSEQUENTIAL 18
121: #define IOSDIRECT 19
122: #define IOSFORMATTED 20
123: #define IOSUNFORMATTED 21
124: #define IOSNEXTREC 22
125: #define IOSNML 23
126:
127: #define IOSTP V(IOSIOSTAT)
128:
129:
130: /* offsets in generated structures */
131:
132: #define SZFLAG SZIOINT
133:
134: /* offsets for external READ and WRITE statements */
135:
136: #define XERR 0
137: #define XUNIT SZFLAG
138: #define XEND SZFLAG + SZIOINT
139: #define XFMT 2*SZFLAG + SZIOINT
140: #define XREC 2*SZFLAG + SZIOINT + SZADDR
141:
142: /* offsets for internal READ and WRITE statements */
143:
144: #define XIUNIT SZFLAG
145: #define XIEND SZFLAG + SZADDR
146: #define XIFMT 2*SZFLAG + SZADDR
147: #define XIRLEN 2*SZFLAG + 2*SZADDR
148: #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT
149: #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT
150:
151: /* offsets for OPEN statements */
152:
153: #define XFNAME SZFLAG + SZIOINT
154: #define XFNAMELEN SZFLAG + SZIOINT + SZADDR
155: #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR
156: #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR
157: #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR
158: #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR
159: #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR
160:
161: /* offset for CLOSE statement */
162:
163: #define XCLSTATUS SZFLAG + SZIOINT
164:
165: /* offsets for INQUIRE statement */
166:
167: #define XFILE SZFLAG + SZIOINT
168: #define XFILELEN SZFLAG + SZIOINT + SZADDR
169: #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR
170: #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR
171: #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR
172: #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR
173: #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR
174: #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR
175: #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR
176: #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR
177: #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR
178: #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR
179: #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR
180: #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR
181: #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR
182: #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR
183: #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR
184: #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR
185: #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR
186: #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR
187: #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR
188: #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR
189: #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR
190: #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR
191:
192: LOCAL char *cilist_names[] = {
193: "cilist",
194: "cierr",
195: "ciunit",
196: "ciend",
197: "cifmt",
198: "cirec"
199: };
200: LOCAL char *icilist_names[] = {
201: "icilist",
202: "icierr",
203: "iciunit",
204: "iciend",
205: "icifmt",
206: "icirlen",
207: "icirnum"
208: };
209: LOCAL char *olist_names[] = {
210: "olist",
211: "oerr",
212: "ounit",
213: "ofnm",
214: "ofnmlen",
215: "osta",
216: "oacc",
217: "ofm",
218: "orl",
219: "oblnk"
220: };
221: LOCAL char *cllist_names[] = {
222: "cllist",
223: "cerr",
224: "cunit",
225: "csta"
226: };
227: LOCAL char *alist_names[] = {
228: "alist",
229: "aerr",
230: "aunit"
231: };
232: LOCAL char *inlist_names[] = {
233: "inlist",
234: "inerr",
235: "inunit",
236: "infile",
237: "infilen",
238: "inex",
239: "inopen",
240: "innum",
241: "innamed",
242: "inname",
243: "innamlen",
244: "inacc",
245: "inacclen",
246: "inseq",
247: "inseqlen",
248: "indir",
249: "indirlen",
250: "infmt",
251: "infmtlen",
252: "inform",
253: "informlen",
254: "inunf",
255: "inunflen",
256: "inrecl",
257: "innrec",
258: "inblank",
259: "inblanklen"
260: };
261:
262: LOCAL char **io_fields;
263:
264: #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
265:
266: LOCAL io_setup io_stuff[] = {
267: zork(cilist_names, TYCILIST), /* external read/write */
268: zork(inlist_names, TYINLIST), /* inquire */
269: zork(olist_names, TYOLIST), /* open */
270: zork(cllist_names, TYCLLIST), /* close */
271: zork(alist_names, TYALIST), /* rewind */
272: zork(alist_names, TYALIST), /* backspace */
273: zork(alist_names, TYALIST), /* endfile */
274: zork(icilist_names,TYICILIST), /* internal read */
275: zork(icilist_names,TYICILIST) /* internal write */
276: };
277:
278: #undef zork
279:
280:
281: fmtstmt(lp)
282: register struct Labelblock *lp;
283: {
284: if(lp == NULL)
285: {
286: execerr("unlabeled format statement" , CNULL);
287: return(-1);
288: }
289: if(lp->labtype == LABUNKNOWN)
290: {
291: lp->labtype = LABFORMAT;
292: lp->labelno = newlabel();
293: }
294: else if(lp->labtype != LABFORMAT)
295: {
296: execerr("bad format number", CNULL);
297: return(-1);
298: }
299: return(lp->labelno);
300: }
301:
302:
303: setfmt(lp)
304: struct Labelblock *lp;
305: {
306: int n;
307: char *s0, *lexline();
308: register char *s, *se, *t;
309: register k;
310:
311: s0 = s = lexline(&n);
312: se = t = s + n;
313:
314: /* warn of trivial errors, e.g. " 11 CONTINUE" (one too few spaces) */
315: /* following FORMAT... */
316:
317: if (n <= 0)
318: warn("No (...) after FORMAT");
319: else if (*s != '(')
320: warni("%c rather than ( after FORMAT", *s);
321: else if (se[-1] != ')') {
322: *se = 0;
323: while(--t > s && *t != ')') ;
324: if (t <= s)
325: warn("No ) at end of FORMAT statement");
326: else if (se - t > 30)
327: warn1("Extraneous text at end of FORMAT: ...%s", se-12);
328: else
329: warn1("Extraneous text at end of FORMAT: %s", t+1);
330: t = se;
331: }
332:
333: /* fix MYQUOTES (\002's) and \\'s */
334:
335: while(s < se)
336: switch(*s++) {
337: case 2:
338: t += 3; break;
339: case '"':
340: case '\\':
341: t++; break;
342: }
343: s = s0;
344: if (lp) {
345: lp->fmtstring = t = mem((int)(t - s + 1), 0);
346: while(s < se)
347: switch(k = *s++) {
348: case 2:
349: t[0] = '\\';
350: t[1] = '0';
351: t[2] = '0';
352: t[3] = '2';
353: t += 4;
354: break;
355: case '"':
356: case '\\':
357: *t++ = '\\';
358: /* no break */
359: default:
360: *t++ = k;
361: }
362: *t = 0;
363: }
364: flline();
365: }
366:
367:
368:
369: startioctl()
370: {
371: register int i;
372:
373: inioctl = YES;
374: nioctl = 0;
375: ioformatted = UNFORMATTED;
376: for(i = 1 ; i<=NIOS ; ++i)
377: V(i) = NULL;
378: }
379:
380: static long
381: newiolabel() {
382: long rv;
383: rv = ++lastiolabno;
384: skiplabel = mklabel(rv);
385: skiplabel->labdefined = 1;
386: return rv;
387: }
388:
389:
390: endioctl()
391: {
392: int i;
393: expptr p;
394: struct io_setup *ios;
395:
396: inioctl = NO;
397:
398: /* set up for error recovery */
399:
400: ioerrlab = ioendlab = skiplab = jumplab = 0;
401:
402: if(p = V(IOSEND))
403: if(ISICON(p))
404: execlab(ioendlab = p->constblock.Const.ci);
405: else
406: err("bad end= clause");
407:
408: if(p = V(IOSERR))
409: if(ISICON(p))
410: execlab(ioerrlab = p->constblock.Const.ci);
411: else
412: err("bad err= clause");
413:
414: if(IOSTP)
415: if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) )
416: {
417: err("iostat must be an integer variable");
418: frexpr(IOSTP);
419: IOSTP = NULL;
420: }
421:
422: if(iostmt == IOREAD)
423: {
424: if(IOSTP)
425: {
426: if(ioerrlab && ioendlab && ioerrlab==ioendlab)
427: jumplab = ioerrlab;
428: else
429: skiplab = jumplab = newiolabel();
430: }
431: else {
432: if(ioerrlab && ioendlab && ioerrlab!=ioendlab)
433: {
434: IOSTP = (expptr) mktmp(TYINT, ENULL);
435: skiplab = jumplab = newiolabel();
436: }
437: else
438: jumplab = (ioerrlab ? ioerrlab : ioendlab);
439: }
440: }
441: else if(iostmt == IOWRITE)
442: {
443: if(IOSTP && !ioerrlab)
444: skiplab = jumplab = newiolabel();
445: else
446: jumplab = ioerrlab;
447: }
448: else
449: jumplab = ioerrlab;
450:
451: endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */
452: errbit = IOSTP!=NULL || ioerrlab!=0;
453: if (jumplab && !IOSTP)
454: IOSTP = (expptr) mktmp(TYINT, ENULL);
455:
456: if(iostmt!=IOREAD && iostmt!=IOWRITE)
457: {
458: ios = io_stuff + iostmt;
459: io_fields = ios->fields;
460: ioblkp = io_structs[iostmt];
461: if(ioblkp == NULL)
462: io_structs[iostmt] = ioblkp =
463: autovar(1, ios->type, ENULL, "");
464: ioset(TYIOINT, XERR, ICON(errbit));
465: }
466:
467: switch(iostmt)
468: {
469: case IOOPEN:
470: dofopen();
471: break;
472:
473: case IOCLOSE:
474: dofclose();
475: break;
476:
477: case IOINQUIRE:
478: dofinquire();
479: break;
480:
481: case IOBACKSPACE:
482: dofmove("f_back");
483: break;
484:
485: case IOREWIND:
486: dofmove("f_rew");
487: break;
488:
489: case IOENDFILE:
490: dofmove("f_end");
491: break;
492:
493: case IOREAD:
494: case IOWRITE:
495: startrw();
496: break;
497:
498: default:
499: fatali("impossible iostmt %d", iostmt);
500: }
501: for(i = 1 ; i<=NIOS ; ++i)
502: if(i!=IOSIOSTAT && V(i)!=NULL)
503: frexpr(V(i));
504: }
505:
506:
507:
508: iocname()
509: {
510: register int i;
511: int found, mask;
512:
513: found = 0;
514: mask = M(iostmt);
515: for(i = 1 ; i <= NIOS ; ++i)
516: if(!strcmp(ioc[i].iocname, token))
517: if(ioc[i].iotype & mask)
518: return(i);
519: else {
520: found = i;
521: break;
522: }
523: if(found) {
524: if (iostmt == IOOPEN && !strcmp(ioc[i].iocname, "name")) {
525: NOEXT("open with \"name=\" treated as \"file=\"");
526: for(i = 1; strcmp(ioc[i].iocname, "file"); i++);
527: return i;
528: }
529: errstr("invalid control %s for statement", ioc[found].iocname);
530: }
531: else
532: errstr("unknown iocontrol %s", token);
533: return(IOSBAD);
534: }
535:
536:
537: ioclause(n, p)
538: register int n;
539: register expptr p;
540: {
541: struct Ioclist *iocp;
542:
543: ++nioctl;
544: if(n == IOSBAD)
545: return;
546: if(n == IOSPOSITIONAL)
547: {
548: n = nioctl;
549: if (n == IOSFMT) {
550: if (iostmt == IOOPEN) {
551: n = IOSFILE;
552: NOEXT("file= specifier omitted from open");
553: }
554: else if (iostmt < IOREAD)
555: goto illegal;
556: }
557: else if(n > IOSFMT)
558: {
559: illegal:
560: err("illegal positional iocontrol");
561: return;
562: }
563: }
564: else if (n == IOSNML)
565: n = IOSFMT;
566:
567: if(p == NULL)
568: {
569: if(n == IOSUNIT)
570: p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT);
571: else if(n != IOSFMT)
572: {
573: err("illegal * iocontrol");
574: return;
575: }
576: }
577: if(n == IOSFMT)
578: ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED);
579:
580: iocp = & ioc[n];
581: if(iocp->iocval == NULL)
582: {
583: if(n!=IOSFMT && ( n!=IOSUNIT || (p && p->headblock.vtype!=TYCHAR) ) )
584: p = fixtype(p);
585: else if (p && p->tag == TPRIM
586: && p->primblock.namep->vclass == CLUNKNOWN) {
587: /* kludge made necessary by attempt to infer types
588: * for untyped external parameters: given an error
589: * in calling sequences, an integer argument might
590: * tentatively be assumed TYCHAR; this would otherwise
591: * be corrected too late in startrw after startrw
592: * had decided this to be an internal file.
593: */
594: vardcl(p->primblock.namep);
595: p->primblock.vtype = p->primblock.namep->vtype;
596: }
597: iocp->iocval = p;
598: }
599: else
600: errstr("iocontrol %s repeated", iocp->iocname);
601: }
602:
603: /* io list item */
604:
605: doio(list)
606: chainp list;
607: {
608: expptr call0();
609:
610: if(ioformatted == NAMEDIRECTED)
611: {
612: if(list)
613: err("no I/O list allowed in NAMELIST read/write");
614: }
615: else
616: {
617: doiolist(list);
618: ioroutine[0] = 'e';
619: if (skiplab || ioroutine[4] == 'l')
620: jumplab = 0;
621: putiocall( call0(TYINT, ioroutine) );
622: }
623: }
624:
625:
626:
627:
628:
629: LOCAL void
630: doiolist(p0)
631: chainp p0;
632: {
633: chainp p;
634: register tagptr q;
635: register expptr qe;
636: register Namep qn;
637: Addrp tp, mkscalar();
638: int range;
639: extern char *ohalign;
640:
641: for (p = p0 ; p ; p = p->nextp)
642: {
643: q = (tagptr)p->datap;
644: if(q->tag == TIMPLDO)
645: {
646: exdo(range=newlabel(), (Namep)0,
647: q->impldoblock.impdospec);
648: doiolist(q->impldoblock.datalist);
649: enddo(range);
650: free( (charptr) q);
651: }
652: else {
653: if(q->tag==TPRIM && q->primblock.argsp==NULL
654: && q->primblock.namep->vdim!=NULL)
655: {
656: vardcl(qn = q->primblock.namep);
657: if(qn->vdim->nelt) {
658: putio( fixtype(cpexpr(qn->vdim->nelt)),
659: (expptr)mkscalar(qn) );
660: qn->vlastdim = 0;
661: }
662: else
663: err("attempt to i/o array of unknown size");
664: }
665: else if(q->tag==TPRIM && q->primblock.argsp==NULL &&
666: (qe = (expptr) memversion(q->primblock.namep)) )
667: putio(ICON(1),qe);
668: else if (ISCONST(q) && q->constblock.vtype == TYCHAR) {
669: halign = 0;
670: putio(ICON(1), qe = fixtype(cpexpr(q)));
671: halign = ohalign;
672: }
673: else if(((qe = fixtype(cpexpr(q)))->tag==TADDR &&
674: (qe->addrblock.uname_tag != UNAM_CONST ||
675: !ISCOMPLEX(qe -> addrblock.vtype))) ||
676: (qe -> tag == TCONST && !ISCOMPLEX(qe ->
677: headblock.vtype))) {
678: if (qe -> tag == TCONST)
679: qe = (expptr) putconst((Constp)qe);
680: putio(ICON(1), qe);
681: }
682: else if(qe->headblock.vtype != TYERROR)
683: {
684: if(iostmt == IOWRITE)
685: {
686: ftnint lencat();
687: expptr qvl;
688: qvl = NULL;
689: if( ISCHAR(qe) )
690: {
691: qvl = (expptr)
692: cpexpr(qe->headblock.vleng);
693: tp = mktmp(qe->headblock.vtype,
694: ICON(lencat(qe)));
695: }
696: else
697: tp = mktmp(qe->headblock.vtype,
698: qe->headblock.vleng);
699: puteq( cpexpr((expptr)tp), qe);
700: if(qvl) /* put right length on block */
701: {
702: frexpr(tp->vleng);
703: tp->vleng = qvl;
704: }
705: putio(ICON(1), (expptr)tp);
706: }
707: else
708: err("non-left side in READ list");
709: }
710: frexpr(q);
711: }
712: }
713: frchain( &p0 );
714: }
715:
716: int iocalladdr = TYADDR; /* for fixing TYADDR in saveargtypes */
717: int typeconv[TYERROR+1] = {
718: #ifdef TYQUAD
719: 0, 1, 11, 2, 3, 14, 4, 5, 6, 7, 12, 13, 8, 9, 10, 15
720: #else
721: 0, 1, 11, 2, 3, 4, 5, 6, 7, 12, 13, 8, 9, 10, 14
722: #endif
723: };
724:
725: LOCAL void
726: putio(nelt, addr)
727: expptr nelt;
728: register expptr addr;
729: {
730: int type;
731: register expptr q;
732: register Addrp c = 0;
733:
734: type = addr->headblock.vtype;
735: if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) )
736: {
737: nelt = mkexpr(OPSTAR, ICON(2), nelt);
738: type -= (TYCOMPLEX-TYREAL);
739: }
740:
741: /* pass a length with every item. for noncharacter data, fake one */
742: if(type != TYCHAR)
743: {
744:
745: if( ISCONST(addr) )
746: addr = (expptr) putconst((Constp)addr);
747: c = ALLOC(Addrblock);
748: c->tag = TADDR;
749: c->vtype = TYLENG;
750: c->vstg = STGAUTO;
751: c->ntempelt = 1;
752: c->isarray = 1;
753: c->memoffset = ICON(0);
754: c->uname_tag = UNAM_IDENT;
755: c->charleng = 1;
756: sprintf(c->user.ident, "(ftnlen)sizeof(%s)", typename[type]);
757: addr = mkexpr(OPCHARCAST, addr, ENULL);
758: }
759:
760: nelt = fixtype( mkconv(tyioint,nelt) );
761: if(ioformatted == LISTDIRECTED) {
762: expptr mc = mkconv(tyioint, ICON(typeconv[type]));
763: q = c ? call4(TYINT, "do_lio", mc, nelt, addr, (expptr)c)
764: : call3(TYINT, "do_lio", mc, nelt, addr);
765: }
766: else {
767: char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
768: q = c ? call3(TYINT, s, nelt, addr, (expptr)c)
769: : call2(TYINT, s, nelt, addr);
770: }
771: iocalladdr = TYCHAR;
772: putiocall(q);
773: iocalladdr = TYADDR;
774: }
775:
776:
777:
778:
779: endio()
780: {
781: extern void p1_label();
782:
783: if(skiplab)
784: {
785: if (ioformatted != NAMEDIRECTED)
786: p1_label((long)(skiplabel - labeltab));
787: if(ioendlab) {
788: exif( mkexpr(OPLT, cpexpr(IOSTP), ICON(0)));
789: exgoto(execlab(ioendlab));
790: exendif();
791: }
792: if(ioerrlab) {
793: exif( mkexpr(iostmt==IOREAD||iostmt==IOWRITE
794: ? OPGT : OPNE,
795: cpexpr(IOSTP), ICON(0)));
796: exgoto(execlab(ioerrlab));
797: exendif();
798: }
799: }
800:
801: if(IOSTP)
802: frexpr(IOSTP);
803: }
804:
805:
806:
807: LOCAL void
808: putiocall(q)
809: register expptr q;
810: {
811: int tyintsave;
812:
813: tyintsave = tyint;
814: tyint = tyioint; /* for -I2 and -i2 */
815:
816: if(IOSTP)
817: {
818: q->headblock.vtype = TYINT;
819: q = fixexpr((Exprp)mkexpr(OPASSIGN, cpexpr(IOSTP), q));
820: }
821: putexpr(q);
822: if(jumplab) {
823: exif(mkexpr(OPNE, cpexpr(IOSTP), ICON(0)));
824: exgoto(execlab(jumplab));
825: exendif();
826: }
827: tyint = tyintsave;
828: }
829:
830: void
831: fmtname(np, q)
832: Namep np;
833: register Addrp q;
834: {
835: register int k;
836: register char *s, *t;
837: extern chainp assigned_fmts;
838:
839: if (!np->vfmt_asg) {
840: np->vfmt_asg = 1;
841: assigned_fmts = mkchain((char *)np, assigned_fmts);
842: }
843: k = strlen(s = np->fvarname);
844: if (k < IDENT_LEN - 4) {
845: q->uname_tag = UNAM_IDENT;
846: t = q->user.ident;
847: }
848: else {
849: q->uname_tag = UNAM_CHARP;
850: q->user.Charp = t = mem(k + 5,0);
851: }
852: sprintf(t, "%s_fmt", s);
853: }
854:
855: LOCAL Addrp asg_addr(p)
856: union Expression *p;
857: {
858: register Addrp q;
859:
860: if (p->tag != TPRIM)
861: badtag("asg_addr", p->tag);
862: q = ALLOC(Addrblock);
863: q->tag = TADDR;
864: q->vtype = TYCHAR;
865: q->vstg = STGAUTO;
866: q->ntempelt = 1;
867: q->isarray = 0;
868: q->memoffset = ICON(0);
869: fmtname(p->primblock.namep, q);
870: return q;
871: }
872:
873: startrw()
874: {
875: register expptr p;
876: register Namep np;
877: register Addrp unitp, fmtp, recp;
878: register expptr nump;
879: Addrp mkscalar();
880: expptr mkaddcon();
881: int iostmt1;
882: flag intfile, sequential, ok, varfmt;
883: struct io_setup *ios;
884:
885: /* First look at all the parameters and determine what is to be done */
886:
887: ok = YES;
888: statstruct = YES;
889:
890: intfile = NO;
891: if(p = V(IOSUNIT))
892: {
893: if( ISINT(p->headblock.vtype) ) {
894: int_unit:
895: unitp = (Addrp) cpexpr(p);
896: }
897: else if(p->headblock.vtype == TYCHAR)
898: {
899: if (nioctl == 1 && iostmt == IOREAD) {
900: /* kludge to recognize READ(format expr) */
901: V(IOSFMT) = p;
902: V(IOSUNIT) = p = (expptr) IOSTDIN;
903: ioformatted = FORMATTED;
904: goto int_unit;
905: }
906: intfile = YES;
907: if(p->tag==TPRIM && p->primblock.argsp==NULL &&
908: (np = p->primblock.namep)->vdim!=NULL)
909: {
910: vardcl(np);
911: if(nump = np->vdim->nelt)
912: {
913: nump = fixtype(cpexpr(nump));
914: if( ! ISCONST(nump) ) {
915: statstruct = NO;
916: np->vlastdim = 0;
917: }
918: }
919: else
920: {
921: err("attempt to use internal unit array of unknown size");
922: ok = NO;
923: nump = ICON(1);
924: }
925: unitp = mkscalar(np);
926: }
927: else {
928: nump = ICON(1);
929: unitp = (Addrp /*pjw */) fixtype(cpexpr(p));
930: }
931: if(! isstatic((expptr)unitp) )
932: statstruct = NO;
933: }
934: else {
935: err("unit specifier not of type integer or character");
936: ok = NO;
937: }
938: }
939: else
940: {
941: err("bad unit specifier");
942: ok = NO;
943: }
944:
945: sequential = YES;
946: if(p = V(IOSREC))
947: if( ISINT(p->headblock.vtype) )
948: {
949: recp = (Addrp) cpexpr(p);
950: sequential = NO;
951: }
952: else {
953: err("bad REC= clause");
954: ok = NO;
955: }
956: else
957: recp = NULL;
958:
959:
960: varfmt = YES;
961: fmtp = NULL;
962: if(p = V(IOSFMT))
963: {
964: if(p->tag==TPRIM && p->primblock.argsp==NULL)
965: {
966: np = p->primblock.namep;
967: if(np->vclass == CLNAMELIST)
968: {
969: ioformatted = NAMEDIRECTED;
970: fmtp = (Addrp) fixtype(p);
971: V(IOSFMT) = (expptr)fmtp;
972: if (skiplab)
973: jumplab = 0;
974: goto endfmt;
975: }
976: vardcl(np);
977: if(np->vdim)
978: {
979: if( ! ONEOF(np->vstg, MSKSTATIC) )
980: statstruct = NO;
981: fmtp = mkscalar(np);
982: goto endfmt;
983: }
984: if( ISINT(np->vtype) ) /* ASSIGNed label */
985: {
986: statstruct = NO;
987: varfmt = YES;
988: fmtp = asg_addr(p);
989: goto endfmt;
990: }
991: }
992: p = V(IOSFMT) = fixtype(p);
993: if(p->headblock.vtype == TYCHAR
994: /* Since we allow write(6,n) */
995: /* we may as well allow write(6,n(2)) */
996: || p->tag == TADDR && ISINT(p->addrblock.vtype))
997: {
998: if( ! isstatic(p) )
999: statstruct = NO;
1000: fmtp = (Addrp) cpexpr(p);
1001: }
1002: else if( ISICON(p) )
1003: {
1004: struct Labelblock *lp;
1005: lp = mklabel(p->constblock.Const.ci);
1006: if (fmtstmt(lp) > 0)
1007: {
1008: fmtp = (Addrp)mkaddcon(lp->stateno);
1009: /* lp->stateno for names fmt_nnn */
1010: lp->fmtlabused = 1;
1011: varfmt = NO;
1012: }
1013: else
1014: ioformatted = UNFORMATTED;
1015: }
1016: else {
1017: err("bad format descriptor");
1018: ioformatted = UNFORMATTED;
1019: ok = NO;
1020: }
1021: }
1022: else
1023: fmtp = NULL;
1024:
1025: endfmt:
1026: if(intfile) {
1027: if (ioformatted==UNFORMATTED) {
1028: err("unformatted internal I/O not allowed");
1029: ok = NO;
1030: }
1031: if (recp) {
1032: err("direct internal I/O not allowed");
1033: ok = NO;
1034: }
1035: }
1036: if(!sequential && ioformatted==LISTDIRECTED)
1037: {
1038: err("direct list-directed I/O not allowed");
1039: ok = NO;
1040: }
1041: if(!sequential && ioformatted==NAMEDIRECTED)
1042: {
1043: err("direct namelist I/O not allowed");
1044: ok = NO;
1045: }
1046:
1047: if( ! ok ) {
1048: statstruct = NO;
1049: return;
1050: }
1051:
1052: /*
1053: Now put out the I/O structure, statically if all the clauses
1054: are constants, dynamically otherwise
1055: */
1056:
1057: if (intfile) {
1058: ios = io_stuff + iostmt;
1059: iostmt1 = IOREAD;
1060: }
1061: else {
1062: ios = io_stuff;
1063: iostmt1 = 0;
1064: }
1065: io_fields = ios->fields;
1066: if(statstruct)
1067: {
1068: ioblkp = ALLOC(Addrblock);
1069: ioblkp->tag = TADDR;
1070: ioblkp->vtype = ios->type;
1071: ioblkp->vclass = CLVAR;
1072: ioblkp->vstg = STGINIT;
1073: ioblkp->memno = ++lastvarno;
1074: ioblkp->memoffset = ICON(0);
1075: ioblkp -> uname_tag = UNAM_IDENT;
1076: new_iob_data(ios,
1077: temp_name("io_", lastvarno, ioblkp->user.ident)); }
1078: else if(!(ioblkp = io_structs[iostmt1]))
1079: io_structs[iostmt1] = ioblkp =
1080: autovar(1, ios->type, ENULL, "");
1081:
1082: ioset(TYIOINT, XERR, ICON(errbit));
1083: if(iostmt == IOREAD)
1084: ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) );
1085:
1086: if(intfile)
1087: {
1088: ioset(TYIOINT, XIRNUM, nump);
1089: ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) );
1090: ioseta(XIUNIT, unitp);
1091: }
1092: else
1093: ioset(TYIOINT, XUNIT, (expptr) unitp);
1094:
1095: if(recp)
1096: ioset(TYIOINT, /* intfile ? XIREC : */ XREC, (expptr) recp);
1097:
1098: if(varfmt)
1099: ioseta( intfile ? XIFMT : XFMT , fmtp);
1100: else
1101: ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp);
1102:
1103: ioroutine[0] = 's';
1104: ioroutine[1] = '_';
1105: ioroutine[2] = iostmt==IOREAD ? 'r' : 'w';
1106: ioroutine[3] = "ds"[sequential];
1107: ioroutine[4] = "ufln"[ioformatted];
1108: ioroutine[5] = "ei"[intfile];
1109: ioroutine[6] = '\0';
1110:
1111: putiocall( call1(TYINT, ioroutine, cpexpr((expptr)ioblkp) ));
1112:
1113: if(statstruct)
1114: {
1115: frexpr((expptr)ioblkp);
1116: statstruct = NO;
1117: ioblkp = 0; /* unnecessary */
1118: }
1119: }
1120:
1121:
1122:
1123: LOCAL void
1124: dofopen()
1125: {
1126: register expptr p;
1127:
1128: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
1129: ioset(TYIOINT, XUNIT, cpexpr(p) );
1130: else
1131: err("bad unit in open");
1132: if( (p = V(IOSFILE)) )
1133: if(p->headblock.vtype == TYCHAR)
1134: ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) );
1135: else
1136: err("bad file in open");
1137:
1138: iosetc(XFNAME, p);
1139:
1140: if(p = V(IOSRECL))
1141: if( ISINT(p->headblock.vtype) )
1142: ioset(TYIOINT, XRECLEN, cpexpr(p) );
1143: else
1144: err("bad recl");
1145: else
1146: ioset(TYIOINT, XRECLEN, ICON(0) );
1147:
1148: iosetc(XSTATUS, V(IOSSTATUS));
1149: iosetc(XACCESS, V(IOSACCESS));
1150: iosetc(XFORMATTED, V(IOSFORM));
1151: iosetc(XBLANK, V(IOSBLANK));
1152:
1153: putiocall( call1(TYINT, "f_open", cpexpr((expptr)ioblkp) ));
1154: }
1155:
1156:
1157: LOCAL void
1158: dofclose()
1159: {
1160: register expptr p;
1161:
1162: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
1163: {
1164: ioset(TYIOINT, XUNIT, cpexpr(p) );
1165: iosetc(XCLSTATUS, V(IOSSTATUS));
1166: putiocall( call1(TYINT, "f_clos", cpexpr((expptr)ioblkp)) );
1167: }
1168: else
1169: err("bad unit in close statement");
1170: }
1171:
1172:
1173: LOCAL void
1174: dofinquire()
1175: {
1176: register expptr p;
1177: if(p = V(IOSUNIT))
1178: {
1179: if( V(IOSFILE) )
1180: err("inquire by unit or by file, not both");
1181: ioset(TYIOINT, XUNIT, cpexpr(p) );
1182: }
1183: else if( ! V(IOSFILE) )
1184: err("must inquire by unit or by file");
1185: iosetlc(IOSFILE, XFILE, XFILELEN);
1186: iosetip(IOSEXISTS, XEXISTS);
1187: iosetip(IOSOPENED, XOPEN);
1188: iosetip(IOSNUMBER, XNUMBER);
1189: iosetip(IOSNAMED, XNAMED);
1190: iosetlc(IOSNAME, XNAME, XNAMELEN);
1191: iosetlc(IOSACCESS, XQACCESS, XQACCLEN);
1192: iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN);
1193: iosetlc(IOSDIRECT, XDIRECT, XDIRLEN);
1194: iosetlc(IOSFORM, XFORM, XFORMLEN);
1195: iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN);
1196: iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN);
1197: iosetip(IOSRECL, XQRECL);
1198: iosetip(IOSNEXTREC, XNEXTREC);
1199: iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN);
1200:
1201: putiocall( call1(TYINT, "f_inqu", cpexpr((expptr)ioblkp) ));
1202: }
1203:
1204:
1205:
1206: LOCAL void
1207: dofmove(subname)
1208: char *subname;
1209: {
1210: register expptr p;
1211:
1212: if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) )
1213: {
1214: ioset(TYIOINT, XUNIT, cpexpr(p) );
1215: putiocall( call1(TYINT, subname, cpexpr((expptr)ioblkp) ));
1216: }
1217: else
1218: err("bad unit in I/O motion statement");
1219: }
1220:
1221: static int ioset_assign = OPASSIGN;
1222:
1223: LOCAL void
1224: ioset(type, offset, p)
1225: int type, offset;
1226: register expptr p;
1227: {
1228: offset /= SZLONG;
1229: if(statstruct && ISCONST(p)) {
1230: register char *s;
1231: switch(type) {
1232: case TYADDR: /* stmt label */
1233: s = "fmt_";
1234: break;
1235: case TYIOINT:
1236: s = "";
1237: break;
1238: default:
1239: badtype("ioset", type);
1240: }
1241: iob_list->fields[offset] =
1242: string_num(s, p->constblock.Const.ci);
1243: frexpr(p);
1244: }
1245: else {
1246: register Addrp q;
1247:
1248: q = ALLOC(Addrblock);
1249: q->tag = TADDR;
1250: q->vtype = type;
1251: q->vstg = STGAUTO;
1252: q->ntempelt = 1;
1253: q->isarray = 0;
1254: q->memoffset = ICON(0);
1255: q->uname_tag = UNAM_IDENT;
1256: sprintf(q->user.ident, "%s.%s",
1257: statstruct ? iob_list->name : ioblkp->user.ident,
1258: io_fields[offset + 1]);
1259: if (type == TYADDR && p->tag == TCONST
1260: && p->constblock.vtype == TYADDR) {
1261: /* kludge */
1262: register Addrp p1;
1263: p1 = ALLOC(Addrblock);
1264: p1->tag = TADDR;
1265: p1->vtype = type;
1266: p1->vstg = STGAUTO; /* wrong, but who cares? */
1267: p1->ntempelt = 1;
1268: p1->isarray = 0;
1269: p1->memoffset = ICON(0);
1270: p1->uname_tag = UNAM_IDENT;
1271: sprintf(p1->user.ident, "fmt_%ld",
1272: p->constblock.Const.ci);
1273: frexpr(p);
1274: p = (expptr)p1;
1275: }
1276: if (type == TYADDR && p->headblock.vtype == TYCHAR)
1277: q->vtype = TYCHAR;
1278: putexpr(mkexpr(ioset_assign, (expptr)q, p));
1279: }
1280: }
1281:
1282:
1283:
1284:
1285: LOCAL void
1286: iosetc(offset, p)
1287: int offset;
1288: register expptr p;
1289: {
1290: extern Addrp putchop();
1291:
1292: if(p == NULL)
1293: ioset(TYADDR, offset, ICON(0) );
1294: else if(p->headblock.vtype == TYCHAR) {
1295: p = putx(fixtype((expptr)putchop(cpexpr(p))));
1296: ioset(TYADDR, offset, addrof(p));
1297: }
1298: else
1299: err("non-character control clause");
1300: }
1301:
1302:
1303:
1304: LOCAL void
1305: ioseta(offset, p)
1306: int offset;
1307: register Addrp p;
1308: {
1309: char *s, *s1;
1310: static char who[] = "ioseta";
1311: expptr e, mo;
1312: Namep np;
1313: ftnint ci;
1314: int k;
1315: char buf[24], buf1[24];
1316: Extsym *comm;
1317: extern int usedefsforcommon;
1318:
1319: if(statstruct)
1320: {
1321: if (!p)
1322: return;
1323: if (p->tag != TADDR)
1324: badtag(who, p->tag);
1325: offset /= SZLONG;
1326: switch(p->uname_tag) {
1327: case UNAM_NAME:
1328: mo = p->memoffset;
1329: if (mo->tag != TCONST)
1330: badtag("ioseta/memoffset", mo->tag);
1331: np = p->user.name;
1332: np->visused = 1;
1333: ci = mo->constblock.Const.ci - np->voffset;
1334: if (np->vstg == STGCOMMON
1335: && !np->vcommequiv
1336: && !usedefsforcommon) {
1337: comm = &extsymtab[np->vardesc.varno];
1338: sprintf(buf, "%d.", comm->curno);
1339: k = strlen(buf) + strlen(comm->cextname)
1340: + strlen(np->cvarname);
1341: if (ci) {
1342: sprintf(buf1, "+%ld", ci);
1343: k += strlen(buf1);
1344: }
1345: else
1346: buf1[0] = 0;
1347: s = mem(k + 1, 0);
1348: sprintf(s, "%s%s%s%s", comm->cextname, buf,
1349: np->cvarname, buf1);
1350: }
1351: else if (ci) {
1352: sprintf(buf,"%ld", ci);
1353: s1 = p->user.name->cvarname;
1354: k = strlen(buf) + strlen(s1);
1355: sprintf(s = mem(k+2,0), "%s+%s", s1, buf);
1356: }
1357: else
1358: s = cpstring(np->cvarname);
1359: break;
1360: case UNAM_CONST:
1361: s = tostring(p->user.Const.ccp1.ccp0,
1362: (int)p->vleng->constblock.Const.ci);
1363: break;
1364: default:
1365: badthing("uname_tag", who, p->uname_tag);
1366: }
1367: /* kludge for Hollerith */
1368: if (p->vtype != TYCHAR) {
1369: s1 = mem(strlen(s)+10,0);
1370: sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
1371: s = s1;
1372: }
1373: iob_list->fields[offset] = s;
1374: }
1375: else {
1376: if (!p)
1377: e = ICON(0);
1378: else if (p->vtype != TYCHAR) {
1379: NOEXT("non-character variable as format or internal unit");
1380: e = mkexpr(OPCHARCAST, (expptr)p, ENULL);
1381: }
1382: else
1383: e = addrof((expptr)p);
1384: ioset(TYADDR, offset, e);
1385: }
1386: }
1387:
1388:
1389:
1390:
1391: LOCAL void
1392: iosetip(i, offset)
1393: int i, offset;
1394: {
1395: register expptr p;
1396:
1397: if(p = V(i))
1398: if(p->tag==TADDR &&
1399: ONEOF(p->addrblock.vtype, inqmask) ) {
1400: ioset_assign = OPASSIGNI;
1401: ioset(TYADDR, offset, addrof(cpexpr(p)) );
1402: ioset_assign = OPASSIGN;
1403: }
1404: else
1405: errstr("impossible inquire parameter %s", ioc[i].iocname);
1406: else
1407: ioset(TYADDR, offset, ICON(0) );
1408: }
1409:
1410:
1411:
1412: LOCAL void
1413: iosetlc(i, offp, offl)
1414: int i, offp, offl;
1415: {
1416: register expptr p;
1417: if( (p = V(i)) && p->headblock.vtype==TYCHAR)
1418: ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) );
1419: iosetc(offp, p);
1420: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.