Commit | Line | Data |
---|---|---|
64836102 C |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | \f | |
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 | } |