![[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 [CSRG BSD Unix] / 40BSD / cmd / efl|
Return to io.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / efl |
1.1 root 1: #include <ctype.h>
2:
3: #include "defs"
4:
5: static int lastfmtchar;
6: static int writeop;
7: static int needcomma;
8:
9:
10: ptr mkiost(kwd,unit,list)
11: int kwd;
12: ptr unit;
13: ptr list;
14: {
15: register ptr p;
16:
17: if(unit!=NULL && unit->vtype!=TYINT)
18: {
19: execerr("I/O unit must be an integer", "");
20: return(NULL);
21: }
22: p = allexpblock();
23: p->tag = TIOSTAT;
24: p->vtype = TYINT;
25: p->iokwd = kwd;
26: p->iounit = unit;
27: p->iolist = list;
28:
29: return(p);
30: }
31:
32:
33:
34:
35: struct iogroup *mkiogroup(list, format, dop)
36: ptr list;
37: char *format;
38: ptr dop;
39: {
40: register struct iogroup *p;
41:
42: p = ALLOC(iogroup);
43: p->tag = TIOGROUP;
44: p->doptr = dop;
45: p->iofmt = format;
46: p->ioitems = list;
47: return(p);
48: }
49:
50: ptr exio(iostp, errhandle)
51: struct iostblock *iostp;
52: int errhandle;
53: {
54: ptr unit, list;
55: int fmtlabel, errlabel, endlabel, jumplabel;
56: ptr errval;
57: int fmtio;
58:
59: if(iostp == NULL)
60: return( errnode() );
61: unit = iostp->iounit;
62: list = iostp->iolist;
63:
64: /* kwd= 0 binary input 2 formatted input
65: 1 binary output 3 formatted output
66: */
67:
68: writeop = iostp->iokwd & 01;
69: if( fmtio = (iostp->iokwd & 02) )
70: fmtlabel = nextlab() ;
71: frexpblock(iostp);
72:
73: errval = 0;
74: endlabel = 0;
75: if(errhandle)
76: {
77: switch(tailor.errmode)
78: {
79: default:
80: execerr("no error handling ", "");
81: return( errnode() );
82:
83: case IOERRIBM: /* ibm: err=, end= */
84: jumplabel = nextlab();
85: break;
86:
87: case IOERRFORT77: /* New Fortran Standard: iostat= */
88: break;
89:
90: }
91: errval = gent(TYINT, PNULL);
92: }
93: if(unit)
94: unit = simple(RVAL, unit);
95: else unit = mkint(writeop ? tailor.ftnout : tailor.ftnin);
96:
97: if(unit->tag!=TCONST && (unit->tag!=TNAME || unit->vsubs!=0))
98: unit = simple(LVAL, mknode(TASGNOP,OPASGN,gent(TYINT,PNULL),unit));
99:
100: simlist(list);
101:
102: exlab(0);
103: putic(ICKEYWORD, (writeop ? FWRITE : FREAD) );
104: putic(ICOP, OPLPAR);
105: prexpr(unit);
106: frexpr(unit);
107:
108: if( fmtio )
109: {
110: putic(ICOP, OPCOMMA);
111: putic(ICLABEL, fmtlabel);
112: }
113:
114: if(errhandle) switch(tailor.errmode)
115: {
116: case IOERRIBM:
117: putic(ICOP,OPCOMMA);
118: putsii(ICCONST, "err =");
119: putic(ICLABEL, errlabel = nextlab() );
120: if(!writeop)
121: {
122: putic(ICOP,OPCOMMA);
123: putsii(ICCONST, "end =");
124: putic(ICLABEL, endlabel = nextlab() );
125: }
126: break;
127:
128: case IOERRFORT77:
129: putic(ICOP,OPCOMMA);
130: putsii(ICCONST, "iostat =");
131: putname(errval);
132: break;
133: }
134:
135: putic(ICOP,OPRPAR);
136: putic(ICBLANK, 1);
137:
138: needcomma = NO;
139: doiolist(list);
140: if(fmtio)
141: {
142: exlab(fmtlabel);
143: putic(ICKEYWORD, FFORMAT);
144: putic(ICOP, OPLPAR);
145: lastfmtchar = '(';
146: doformat(1, list);
147: putic(ICOP, OPRPAR);
148: }
149: friolist(list);
150:
151: if(errhandle && tailor.errmode==IOERRIBM)
152: {
153: exasgn(cpexpr(errval), OPASGN, mkint(0) );
154: exgoto(jumplabel);
155: exlab(errlabel);
156: exasgn(cpexpr(errval), OPASGN, mkint(1) );
157: if(endlabel)
158: {
159: exgoto(jumplabel);
160: exlab(endlabel);
161: exasgn(cpexpr(errval), OPASGN,
162: mknode(TNEGOP,OPMINUS,mkint(1),PNULL) );
163: }
164: exlab(jumplabel);
165: }
166:
167: return( errval );
168: }
169:
170: doiolist(list)
171: ptr list;
172: {
173: register ptr p, q;
174: register struct doblock *dop;
175: for(p = list ; p ; p = p->nextp)
176: {
177: switch( (q = p->datap) ->tag)
178: {
179: case TIOGROUP:
180: if(dop = q->doptr)
181: {
182: if(needcomma)
183: putic(ICOP, OPCOMMA);
184: putic(ICOP, OPLPAR);
185: needcomma = NO;
186: }
187: doiolist(q->ioitems);
188: if(dop)
189: {
190: putic(ICOP,OPCOMMA);
191: prexpr(dop->dovar);
192: putic(ICOP, OPEQUALS);
193: prexpr(dop->dopar[0]);
194: putic(ICOP, OPCOMMA);
195: prexpr(dop->dopar[1]);
196: if(dop->dopar[2])
197: {
198: putic(ICOP, OPCOMMA);
199: prexpr(dop->dopar[2]);
200: }
201: putic(ICOP, OPRPAR);
202: needcomma = YES;
203: }
204: break;
205:
206: case TIOITEM:
207: if(q->ioexpr)
208: {
209: if(needcomma)
210: putic(ICOP, OPCOMMA);
211: prexpr(q->ioexpr);
212: needcomma = YES;
213: }
214: break;
215:
216: default:
217: badtag("doiolist", q->tag);
218: }
219: }
220: }
221:
222: doformat(nrep, list)
223: int nrep;
224: ptr list;
225: {
226: register ptr p, q;
227: int k;
228: ptr arrsize();
229:
230: if(nrep > 1)
231: {
232: fmtnum(nrep);
233: fmtop(OPLPAR);
234: }
235:
236: for(p = list ; p ; p = p->nextp)
237: switch( (q = p->datap) ->tag)
238: {
239: case TIOGROUP:
240: if(q->iofmt)
241: prfmt(q->nrep, q->iofmt);
242: else {
243: doformat(q->nrep>0 ? q->nrep :
244: (q->doptr ? repfac(q->doptr) : 1),
245: q->ioitems);
246: }
247: break;
248:
249: case TIOITEM:
250: if(q->iofmt == NULL)
251: break;
252:
253: if(q->nrep==0 && q->ioexpr && q->ioexpr->vdim)
254: {
255: if( ! isicon(arrsize(q->ioexpr), &k) )
256: execerr("io of adjustable array", "");
257: else
258: prfmt(k, q->iofmt);
259: }
260: else
261: prfmt(q->nrep, q->iofmt);
262: }
263: if(nrep > 1)
264: fmtop(OPRPAR);
265: }
266:
267: fmtop(op)
268: register int op;
269: {
270: register c;
271:
272: c = (op==OPLPAR ? '(' : (op==OPRPAR ? ')' : 'x') );
273: fmtcom(c);
274: putic(ICOP, op);
275: lastfmtchar = c;
276: }
277:
278:
279:
280:
281: fmtnum(k)
282: int k;
283: {
284: fmtcom('1');
285: prexpr( mkint(k) );
286: lastfmtchar = ','; /* prevent further comma after factor*/
287: }
288:
289:
290:
291:
292:
293:
294:
295:
296: /* separate formats with comma unless already a slash*/
297: fmtcom(c)
298: int c;
299: {
300: if( c!='/' && c!=')' && lastfmtchar!='/' && lastfmtchar!='(' && lastfmtchar!=',' )
301: {
302: putic(ICOP, OPCOMMA);
303: lastfmtchar = ',';
304: }
305: }
306:
307: prfmt(nrep, str)
308: int nrep;
309: char *str;
310: {
311: char fmt[20];
312: register int k, k0, k1, k2;
313: register char *t;
314:
315: fmtcom(nrep>1 ? '1' : str[0]);
316:
317: if(nrep > 1)
318: {
319: fmtnum(nrep);
320: fmtop(OPLPAR);
321: }
322:
323: switch(str[0])
324: {
325: case 'd':
326: case 'e':
327: case 'g':
328: if(writeop)
329: {
330: putsii(ICCONST, "1p");
331: break;
332: }
333:
334: case 'f':
335: putsii(ICCONST, "0p");
336: break;
337:
338: case 'c':
339: k = convci(str+1);
340: k0 = tailor.ftnchwd;
341: k1 = k / k0;
342: k2 = k % k0;
343: if(k1>0 && k2>0)
344: sprintf(fmt, "(%da%d,a%d)",k1,k0,k2);
345: else if(k1>1)
346: sprintf(fmt, "(%da%d)", k1, k0);
347: else sprintf(fmt, "a%d", k);
348: putsii(ICCONST, fmt);
349: lastfmtchar = 'f'; /* last char isnt operator */
350: goto close;
351:
352: default:
353: break;
354: }
355: putsii(ICCONST,str);
356: /* if the format is an nH, act as if it ended with a non-operator character */
357: if( isdigit(str[0]) )
358: {
359: for(t = str+1 ; isdigit(*t) ; ++t);
360: ;
361: if(*t=='h' || *t=='H')
362: {
363: lastfmtchar = 'f';
364: goto close;
365: }
366: }
367: lastfmtchar = str[ strlen(str)-1 ];
368:
369: close:
370: if(nrep > 1)
371: fmtop(OPRPAR);
372: }
373:
374: friolist(list)
375: ptr list;
376: {
377: register ptr p, q;
378: register struct doblock *dop;
379:
380: for(p = list; p; p = p->nextp)
381: {
382: switch ( (q = p->datap) ->tag)
383: {
384: case TIOGROUP:
385: if(dop = q->doptr)
386: {
387: frexpr(dop->dovar);
388: frexpr(dop->dopar[0]);
389: frexpr(dop->dopar[1]);
390: if(dop->dopar[2])
391: frexpr(dop->dopar[2]);
392: cfree(dop);
393: }
394: friolist(q->ioitems);
395: break;
396:
397: case TIOITEM:
398: if(q->ioexpr)
399: frexpr(q->ioexpr);
400: break;
401:
402: default:
403: badtag("friolist", q->tag);
404: }
405: if(q->iofmt)
406: cfree(q->iofmt);
407: cfree(q);
408: }
409: frchain( &list );
410: }
411:
412: simlist(p)
413: register ptr p;
414: {
415: register ptr q, ep;
416: struct iogroup *enloop();
417:
418: for( ; p ; p = p->nextp)
419: switch( (q = p->datap) ->tag )
420: {
421: case TIOGROUP:
422: simlist(q->ioitems);
423: break;
424:
425: case TIOITEM:
426: if(ep = q->ioexpr)
427: {
428: /* if element is a subaggregate, need
429: an implied do loop */
430: if( (ep->voffset || ep->vsubs) &&
431: (ep->vdim || ep->vtypep) )
432: p->datap = enloop(q);
433: else
434: q->ioexpr = simple(LVAL,ep);
435: }
436: break;
437:
438: default:
439: badtag("ioblock", q->tag);
440: }
441: }
442:
443:
444:
445:
446: /* replace an aggregate by an implied do loop of elements */
447:
448: struct iogroup *enloop(p)
449: struct ioitem *p;
450: {
451: register struct doblock *dop;
452: struct iogroup *gp;
453: ptr np, q, v, arrsize(), mkioitem();
454: int nrep, k, nwd;
455:
456: q = p->ioexpr;
457: np = arrsize(q);
458: if( ! isicon(np, &nrep) )
459: nrep = 0;
460:
461: if(q->vtype == TYCHAR)
462: {
463: nwd = ceil(conval(q->vtypep), tailor.ftnchwd);
464: if(nwd != 1)
465: np = simple(LVAL, mknode(TAROP,OPSTAR,np,mkint(nwd)));
466: }
467: else
468: nwd = 0;
469:
470: if( isicon(np, &k) && k==1)
471: return(p);
472:
473: dop = ALLOC(doblock);
474: dop->tag = TDOBLOCK;
475:
476: dop->dovar = v = gent(TYINT, PNULL);
477: dop->dopar[0] = mkint(1);
478: dop->dopar[1] = simple(SUBVAL, np);
479: dop->dopar[2] = NULL;
480:
481: q = simple(LVAL, q);
482: if(q->vsubs == NULL)
483: q->vsubs = mknode(TLIST,0, mkchain(cpexpr(v),CHNULL), PNULL);
484: else
485: q->vsubs->leftp->datap = simple(SUBVAL, mknode(TAROP,OPPLUS, cpexpr(v),
486: mknode(TAROP,OPMINUS,q->vsubs->leftp->datap,mkint(1))));
487: q->vdim = NULL;
488: gp = mkiogroup( mkchain(mkioitem(q,CNULL), CHNULL), p->iofmt, dop);
489: gp->nrep = nrep;
490: cfree(p);
491: return(gp);
492: }
493:
494: ptr mkformat(letter, n1, n2)
495: char letter;
496: register ptr n1, n2;
497: {
498: char f[20], *fp, *s;
499: int k;
500:
501: if(letter == 's')
502: {
503: if(n1)
504: {
505: k = conval(n1);
506: frexpr(n1);
507: }
508: else k = 1;
509:
510: for(fp = f; k-->0 ; )
511: *fp++ = '/';
512: *fp = '\0';
513: return( copys(f) );
514: }
515:
516: f[0] = letter;
517: fp = f+1;
518:
519: if(n1) {
520: n1 = simple(RVAL,n1);
521: if(n1->tag==TCONST && n1->vtype==TYINT)
522: {
523: for(s = n1->leftp ; *s; )
524: *fp++ = *s++;
525: }
526: else execerr("bad format component %s", n1->leftp);
527: frexpr(n1);
528: }
529:
530: if(n2) {
531: if(n2->tag==TCONST && n2->vtype==TYINT)
532: {
533: *fp++ = '.';
534: for(s = n2->leftp ; *s; )
535: *fp++ = *s++;
536: }
537: else execerr("bad format component %s", n2->leftp);
538: frexpr(n2);
539: }
540:
541: if( letter == 'x' )
542: {
543: if(n1 == 0)
544: *fp++ = '1';
545: fp[0] = 'x';
546: fp[1] = '\0';
547: return( copys(f+1) );
548: }
549: else {
550: *fp = '\0';
551: return( copys(f) );
552: }
553: }
554:
555: ptr mkioitem(e,f)
556: register ptr e;
557: char *f;
558: {
559: register ptr p;
560: char fmt[10];
561: ptr gentemp();
562:
563: p = ALLOC(ioitem);
564: p->tag = TIOITEM;
565: if(e!=NULL && e->tag==TCONST)
566: if(e->vtype==TYCHAR && (f==0 || (f[0]=='c' && f[1]=='\0') ))
567: {
568: p->ioexpr = 0;
569: sprintf(msg, "%dh%s", strlen(e->leftp), e->leftp);
570: p->iofmt = copys(msg);
571: frexpr(e);
572: return(p);
573: }
574: else e = mknode(TASGNOP,OPASGN,gentemp(e),e);
575:
576: if(e && e->vtype==TYCHAR && f && f[0]=='c' && f[1]=='\0')
577: f = NULL;
578: if(f == NULL)
579: {
580: switch(e->vtype)
581: {
582: case TYINT:
583: case TYREAL:
584: case TYLREAL:
585: case TYCOMPLEX:
586: case TYLOG:
587: f = copys( tailor.dfltfmt[e->vtype] );
588: break;
589:
590: case TYCHAR:
591: if(e->vtypep->tag != TCONST)
592: {
593: execerr("no adjustable character formats", "");
594: f = 0;
595: }
596: else {
597: sprintf(fmt, "c%s", e->vtypep->leftp);
598: f = copys(fmt);
599: }
600: break;
601:
602: default:
603: execerr("cannot do I/O on structures", "");
604: f = 0;
605: break;
606: }
607: }
608:
609: p->ioexpr = e;
610: p->iofmt = f;
611: return(p);
612: }
613:
614:
615:
616: ptr arrsize(p)
617: ptr p;
618: {
619: register ptr b;
620: ptr f, q;
621:
622: q = mkint(1);
623:
624: if(b = p->vdim)
625: for(b = b->datap ; b ; b = b->nextp)
626: {
627: if(b->upperb == 0) continue;
628: f = cpexpr(b->upperb);
629: if(b->lowerb)
630: f = mknode(TAROP,OPPLUS,f,
631: mknode(TAROP,OPMINUS,mkint(1),cpexpr(b->lowerb)));
632: q = simple(RVAL, mknode(TAROP,OPSTAR,q,f));
633: }
634: return(q);
635: }
636:
637:
638:
639:
640: repfac(dop)
641: register struct doblock *dop;
642: {
643: int m1, m2, m3;
644:
645: m3 = 1;
646: if( isicon(dop->dopar[0],&m1) && isicon(dop->dopar[1],&m2) &&
647: (dop->dopar[2]==NULL || isicon(dop->dopar[2],&m3)) )
648: {
649: if(m3 > 0)
650: return(1 + (m2-m1)/m3);
651: }
652: else execerr("nonconstant implied do", "");
653: return(1);
654: }
655:
656:
657:
658: ioop(s)
659: char *s;
660: {
661: if( equals(s, "backspace") )
662: return(FBACKSPACE);
663: if( equals(s, "rewind") )
664: return(FREWIND);
665: if( equals(s, "endfile") )
666: return(FENDFILE);
667: return(0);
668: }
669:
670:
671:
672:
673: ptr exioop(p, errcheck)
674: register struct exprblock *p;
675: int errcheck;
676: {
677: register ptr q, t;
678:
679: if( (q = p->rightp)==NULL || (q = q->leftp)==NULL )
680: {
681: execerr("bad I/O operation", "");
682: return(NULL);
683: }
684: q = simple(LVAL, cpexpr(q->datap) );
685:
686: exlab(0);
687: putic(ICKEYWORD, ioop(p->leftp->sthead->namep));
688:
689: if(errcheck)
690: {
691: if(tailor.errmode != IOERRFORT77)
692: {
693: execerr("cannot test value of IOOP without ftn77", "");
694: return( errnode() );
695: }
696: putic(ICOP, OPLPAR);
697: prexpr(q);
698: putic(ICOP, OPCOMMA);
699: putsii(ICCONST, "iostat =");
700: prexpr(cpexpr( t = gent(TYINT,PNULL)));
701: putic(ICOP, OPRPAR);
702: return( t );
703: }
704: else {
705: putic(ICBLANK, 1);
706: prexpr(q);
707: }
708: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.