Commit | Line | Data |
---|---|---|
55162a5a BJ |
1 | /* Routines to generate code for I/O statements. |
2 | Some corrections and improvements due to David Wasley, U. C. Berkeley | |
3 | Compile with -DKOSHER to force exact conformity with the ANSI std. | |
4 | */ | |
5 | ||
6 | #ifdef KOSHER | |
7 | #define IOSRETURN 1 /* to force ANSI std return on iostat= */ | |
8 | #endif | |
9 | ||
10 | /* TEMPORARY */ | |
11 | #define TYIOINT TYLONG | |
12 | #define SZIOINT SZLONG | |
13 | ||
14 | #include "defs" | |
15 | ||
16 | ||
17 | LOCAL char ioroutine[XL+1]; | |
18 | ||
19 | LOCAL int ioendlab; | |
20 | LOCAL int ioerrlab; | |
21 | LOCAL int iostest; | |
22 | LOCAL int iosreturn; | |
23 | LOCAL int jumplab; | |
24 | LOCAL int skiplab; | |
25 | LOCAL int ioformatted; | |
26 | ||
27 | #define UNFORMATTED 0 | |
28 | #define FORMATTED 1 | |
29 | #define LISTDIRECTED 2 | |
30 | ||
31 | #define V(z) ioc[z].iocval | |
32 | ||
33 | #define IOALL 07777 | |
34 | ||
35 | LOCAL struct Ioclist | |
36 | { | |
37 | char *iocname; | |
38 | int iotype; | |
39 | expptr iocval; | |
40 | } ioc[ ] = | |
41 | { | |
42 | { "", 0 }, | |
43 | { "unit", IOALL }, | |
44 | { "fmt", M(IOREAD) | M(IOWRITE) }, | |
45 | { "err", IOALL }, | |
46 | #ifdef KOSHER | |
47 | { "end", M(IOREAD) }, | |
48 | #else | |
49 | { "end", M(IOREAD) | M(IOWRITE) }, | |
50 | #endif | |
51 | { "iostat", IOALL }, | |
52 | { "rec", M(IOREAD) | M(IOWRITE) }, | |
53 | { "recl", M(IOOPEN) | M(IOINQUIRE) }, | |
54 | { "file", M(IOOPEN) | M(IOINQUIRE) }, | |
55 | { "status", M(IOOPEN) | M(IOCLOSE) }, | |
56 | { "access", M(IOOPEN) | M(IOINQUIRE) }, | |
57 | { "form", M(IOOPEN) | M(IOINQUIRE) }, | |
58 | { "blank", M(IOOPEN) | M(IOINQUIRE) }, | |
59 | { "exist", M(IOINQUIRE) }, | |
60 | { "opened", M(IOINQUIRE) }, | |
61 | { "number", M(IOINQUIRE) }, | |
62 | { "named", M(IOINQUIRE) }, | |
63 | { "name", M(IOINQUIRE) }, | |
64 | { "sequential", M(IOINQUIRE) }, | |
65 | { "direct", M(IOINQUIRE) }, | |
66 | { "formatted", M(IOINQUIRE) }, | |
67 | { "unformatted", M(IOINQUIRE) }, | |
68 | { "nextrec", M(IOINQUIRE) } | |
69 | } ; | |
70 | ||
71 | #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) | |
72 | #define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR | |
73 | ||
74 | #define IOSUNIT 1 | |
75 | #define IOSFMT 2 | |
76 | #define IOSERR 3 | |
77 | #define IOSEND 4 | |
78 | #define IOSIOSTAT 5 | |
79 | #define IOSREC 6 | |
80 | #define IOSRECL 7 | |
81 | #define IOSFILE 8 | |
82 | #define IOSSTATUS 9 | |
83 | #define IOSACCESS 10 | |
84 | #define IOSFORM 11 | |
85 | #define IOSBLANK 12 | |
86 | #define IOSEXIST 13 | |
87 | #define IOSOPENED 14 | |
88 | #define IOSNUMBER 15 | |
89 | #define IOSNAMED 16 | |
90 | #define IOSNAME 17 | |
91 | #define IOSSEQUENTIAL 18 | |
92 | #define IOSDIRECT 19 | |
93 | #define IOSFORMATTED 20 | |
94 | #define IOSUNFORMATTED 21 | |
95 | #define IOSNEXTREC 22 | |
96 | ||
97 | #define IOSTP V(IOSIOSTAT) | |
98 | #define IOSRW (iostmt==IOREAD || iostmt==IOWRITE) | |
99 | ||
100 | ||
101 | /* offsets in generated structures */ | |
102 | ||
103 | #define SZFLAG SZIOINT | |
104 | ||
105 | /* offsets for external READ and WRITE statements */ | |
106 | ||
107 | #define XERR 0 | |
108 | #define XUNIT SZFLAG | |
109 | #define XEND SZFLAG + SZIOINT | |
110 | #define XFMT 2*SZFLAG + SZIOINT | |
111 | #define XREC 2*SZFLAG + SZIOINT + SZADDR | |
112 | ||
113 | /* offsets for internal READ and WRITE statements */ | |
114 | ||
115 | #define XIERR 0 | |
116 | #define XIUNIT SZFLAG | |
117 | #define XIEND SZFLAG + SZADDR | |
118 | #define XIFMT 2*SZFLAG + SZADDR | |
119 | #define XIRLEN 2*SZFLAG + 2*SZADDR | |
120 | #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT | |
121 | #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT | |
122 | ||
123 | /* offsets for OPEN statements */ | |
124 | ||
125 | #define XFNAME SZFLAG + SZIOINT | |
126 | #define XFNAMELEN SZFLAG + SZIOINT + SZADDR | |
127 | #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR | |
128 | #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR | |
129 | #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR | |
130 | #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR | |
131 | #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR | |
132 | ||
133 | /* offset for CLOSE statement */ | |
134 | ||
135 | #define XCLSTATUS SZFLAG + SZIOINT | |
136 | ||
137 | /* offsets for INQUIRE statement */ | |
138 | ||
139 | #define XFILE SZFLAG + SZIOINT | |
140 | #define XFILELEN SZFLAG + SZIOINT + SZADDR | |
141 | #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR | |
142 | #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR | |
143 | #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR | |
144 | #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR | |
145 | #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR | |
146 | #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR | |
147 | #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR | |
148 | #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR | |
149 | #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR | |
150 | #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR | |
151 | #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR | |
152 | #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR | |
153 | #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR | |
154 | #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR | |
155 | #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR | |
156 | #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR | |
157 | #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR | |
158 | #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR | |
159 | #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR | |
160 | #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR | |
161 | #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR | |
162 | #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR | |
163 | \f | |
164 | fmtstmt(lp) | |
165 | register struct Labelblock *lp; | |
166 | { | |
167 | if(lp == NULL) | |
168 | { | |
169 | execerr("unlabeled format statement" , 0); | |
170 | return(-1); | |
171 | } | |
172 | if(lp->labtype == LABUNKNOWN) | |
173 | { | |
174 | lp->labtype = LABFORMAT; | |
175 | lp->labelno = newlabel(); | |
176 | } | |
177 | else if(lp->labtype != LABFORMAT) | |
178 | { | |
179 | execerr("bad format number", 0); | |
180 | return(-1); | |
181 | } | |
182 | return(lp->labelno); | |
183 | } | |
184 | ||
185 | ||
186 | ||
187 | setfmt(lp) | |
188 | struct Labelblock *lp; | |
189 | { | |
190 | ftnint n; | |
191 | char *s, *lexline(); | |
192 | ||
193 | s = lexline(&n); | |
194 | preven(ALILONG); | |
195 | prlabel(asmfile, lp->labelno); | |
196 | putstr(asmfile, s, n); | |
197 | flline(); | |
198 | } | |
199 | ||
200 | ||
201 | ||
202 | startioctl() | |
203 | { | |
204 | register int i; | |
205 | ||
206 | inioctl = YES; | |
207 | nioctl = 0; | |
208 | ioformatted = UNFORMATTED; | |
209 | for(i = 1 ; i<=NIOS ; ++i) | |
210 | V(i) = NULL; | |
211 | } | |
212 | ||
213 | ||
214 | ||
215 | endioctl() | |
216 | { | |
217 | int i; | |
218 | expptr p; | |
219 | ||
220 | inioctl = NO; | |
221 | if(ioblkp == NULL) | |
222 | ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, NULL); | |
223 | ||
224 | /* set up for error recovery */ | |
225 | ||
226 | ioerrlab = ioendlab = jumplab = 0; | |
227 | skiplab = iosreturn = NO; | |
228 | ||
229 | if(p = V(IOSEND)) | |
230 | if(ISICON(p)) | |
231 | ioendlab = mklabel(p->constblock.const.ci)->labelno; | |
232 | else | |
233 | err("bad end= clause"); | |
234 | ||
235 | if(p = V(IOSERR)) | |
236 | if(ISICON(p)) | |
237 | ioerrlab = mklabel(p->constblock.const.ci)->labelno; | |
238 | else | |
239 | err("bad err= clause"); | |
240 | ||
241 | if(IOSTP) | |
242 | if(IOSTP->headblock.tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) | |
243 | { | |
244 | err("iostat must be an integer variable"); | |
245 | frexpr(IOSTP); | |
246 | IOSTP = NULL; | |
247 | } | |
248 | #ifdef IOSRETURN | |
249 | else | |
250 | iosreturn = YES; | |
251 | ||
252 | if(iosreturn && IOSRW && !(ioerrlab && ioendlab) ) | |
253 | { | |
254 | jumplab = newlabel(); | |
255 | iostest = OPEQ; | |
256 | if(ioerrlab || ioendlab) skiplab = YES; | |
257 | } | |
258 | else if(ioerrlab && !ioendlab) | |
259 | ||
260 | #else | |
261 | if(ioerrlab && !ioendlab) | |
262 | #endif | |
263 | { | |
264 | jumplab = ioerrlab; | |
265 | iostest = IOSRW ? OPLE : OPEQ; | |
266 | } | |
267 | else if(!ioerrlab && ioendlab) | |
268 | { | |
269 | jumplab = ioendlab; | |
270 | iostest = OPGE; | |
271 | } | |
272 | else if(ioerrlab && ioendlab) | |
273 | { | |
274 | iostest = OPEQ; | |
275 | if(ioerrlab == ioendlab) | |
276 | jumplab = ioerrlab; | |
277 | else | |
278 | { | |
279 | if(!IOSTP) IOSTP = mktemp(TYINT, NULL); | |
280 | jumplab = newlabel(); | |
281 | skiplab = YES; | |
282 | } | |
283 | } | |
284 | /*else if(IOSTP) /* the standard requires this return! */ | |
285 | /* { | |
286 | /* iosreturn = YES; | |
287 | /* if(iostmt==IOREAD || iostmt==IOWRITE) | |
288 | /* { | |
289 | /* jumplab = newlabel(); | |
290 | /* iostest = OPEQ; | |
291 | /* } | |
292 | /* } | |
293 | */ | |
294 | ||
295 | ||
296 | ioset(TYIOINT, XERR, ICON(ioerrlab!=0 || iosreturn) ); | |
297 | ||
298 | switch(iostmt) | |
299 | { | |
300 | case IOOPEN: | |
301 | dofopen(); break; | |
302 | ||
303 | case IOCLOSE: | |
304 | dofclose(); break; | |
305 | ||
306 | case IOINQUIRE: | |
307 | dofinquire(); break; | |
308 | ||
309 | case IOBACKSPACE: | |
310 | dofmove("f_back"); break; | |
311 | ||
312 | case IOREWIND: | |
313 | dofmove("f_rew"); break; | |
314 | ||
315 | case IOENDFILE: | |
316 | dofmove("f_end"); break; | |
317 | ||
318 | case IOREAD: | |
319 | case IOWRITE: | |
320 | startrw(); break; | |
321 | ||
322 | default: | |
323 | fatali("impossible iostmt %d", iostmt); | |
324 | } | |
325 | for(i = 1 ; i<=NIOS ; ++i) | |
326 | if(i!=IOSIOSTAT && V(i)!=NULL) | |
327 | frexpr(V(i)); | |
328 | } | |
329 | ||
330 | ||
331 | ||
332 | iocname() | |
333 | { | |
334 | register int i; | |
335 | int found, mask; | |
336 | ||
337 | found = 0; | |
338 | mask = M(iostmt); | |
339 | for(i = 1 ; i <= NIOS ; ++i) | |
340 | if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname)) | |
341 | if(ioc[i].iotype & mask) | |
342 | return(i); | |
343 | else found = i; | |
344 | if(found) | |
345 | errstr("invalid control %s for statement", ioc[found].iocname); | |
346 | else | |
347 | errstr("unknown iocontrol %s", varstr(toklen, token) ); | |
348 | return(IOSBAD); | |
349 | } | |
350 | ||
351 | ||
352 | ioclause(n, p) | |
353 | register int n; | |
354 | register expptr p; | |
355 | { | |
356 | struct Ioclist *iocp; | |
357 | ||
358 | ++nioctl; | |
359 | if(n == IOSBAD) | |
360 | return; | |
361 | if(n == IOSPOSITIONAL) | |
362 | { | |
363 | if(nioctl > IOSFMT) | |
364 | { | |
365 | err("illegal positional iocontrol"); | |
366 | return; | |
367 | } | |
368 | n = nioctl; | |
369 | } | |
370 | ||
371 | if(p == NULL) | |
372 | { | |
373 | if(n == IOSUNIT) | |
374 | p = (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); | |
375 | else if(n != IOSFMT) | |
376 | { | |
377 | err("illegal * iocontrol"); | |
378 | return; | |
379 | } | |
380 | } | |
381 | if(n == IOSFMT) | |
382 | ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); | |
383 | ||
384 | iocp = & ioc[n]; | |
385 | if(iocp->iocval == NULL) | |
386 | { | |
387 | if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) ) | |
388 | p = fixtype(p); | |
389 | iocp->iocval = p; | |
390 | } | |
391 | else | |
392 | errstr("iocontrol %s repeated", iocp->iocname); | |
393 | } | |
394 | ||
395 | /* io list item */ | |
396 | ||
397 | doio(list) | |
398 | chainp list; | |
399 | { | |
400 | struct Exprblock *call0(); | |
401 | doiolist(list); | |
402 | ioroutine[0] = 'e'; | |
403 | putiocall( call0(TYINT, ioroutine) ); | |
404 | } | |
405 | ||
406 | ||
407 | ||
408 | ||
409 | ||
410 | LOCAL doiolist(p0) | |
411 | chainp p0; | |
412 | { | |
413 | chainp p; | |
414 | register tagptr q; | |
415 | register expptr qe; | |
416 | register struct Nameblock *qn; | |
417 | struct Addrblock *tp, *mkscalar(); | |
418 | int range; | |
419 | ||
420 | for (p = p0 ; p ; p = p->nextp) | |
421 | { | |
422 | q = p->datap; | |
423 | if(q->headblock.tag == TIMPLDO) | |
424 | { | |
425 | exdo(range=newlabel(), q->impldoblock.varnp); | |
426 | doiolist(q->impldoblock.datalist); | |
427 | enddo(range); | |
428 | free(q); | |
429 | } | |
430 | else { | |
431 | if(q->headblock.tag==TPRIM && q->primblock.argsp==NULL | |
432 | && q->primblock.namep->vdim!=NULL) | |
433 | { | |
434 | vardcl(qn = q->primblock.namep); | |
435 | if(qn->vdim->nelt) | |
436 | putio( fixtype(cpexpr(qn->vdim->nelt)), | |
437 | mkscalar(qn) ); | |
438 | else | |
439 | err("attempt to i/o array of unknown size"); | |
440 | } | |
441 | else if(q->headblock.tag==TPRIM && q->primblock.argsp==NULL && | |
442 | (qe = memversion(q->primblock.namep)) ) | |
443 | putio(ICON(1),qe); | |
444 | else if( (qe = fixtype(cpexpr(q)))->headblock.tag==TADDR) | |
445 | putio(ICON(1), qe); | |
446 | else if(qe->headblock.vtype != TYERROR) | |
447 | { | |
448 | if(iostmt == IOWRITE) | |
449 | { | |
450 | tp = mktemp(qe->headblock.vtype, qe->headblock.vleng); | |
451 | puteq( cpexpr(tp), qe); | |
452 | putio(ICON(1), tp); | |
453 | } | |
454 | else | |
455 | err("non-left side in READ list"); | |
456 | } | |
457 | frexpr(q); | |
458 | } | |
459 | } | |
460 | frchain( &p0 ); | |
461 | } | |
462 | ||
463 | ||
464 | ||
465 | ||
466 | ||
467 | LOCAL putio(nelt, addr) | |
468 | expptr nelt; | |
469 | register expptr addr; | |
470 | { | |
471 | int type; | |
472 | register struct Exprblock *q; | |
473 | ||
474 | type = addr->headblock.vtype; | |
475 | if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) | |
476 | { | |
477 | nelt = mkexpr(OPSTAR, ICON(2), nelt); | |
478 | type -= (TYCOMPLEX-TYREAL); | |
479 | } | |
480 | ||
481 | /* pass a length with every item. for noncharacter data, fake one */ | |
482 | if(type != TYCHAR) | |
483 | { | |
484 | if( ISCONST(addr) ) | |
485 | addr = putconst(addr); | |
486 | addr->headblock.vtype = TYCHAR; | |
487 | addr->headblock.vleng = ICON( typesize[type] ); | |
488 | } | |
489 | ||
490 | nelt = fixtype( mkconv(TYLENG,nelt) ); | |
491 | if(ioformatted == LISTDIRECTED) | |
492 | q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr); | |
493 | else | |
494 | q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"), | |
495 | nelt, addr); | |
496 | putiocall(q); | |
497 | } | |
498 | ||
499 | ||
500 | ||
501 | ||
502 | endio() | |
503 | { | |
504 | if(skiplab) | |
505 | { | |
506 | putlabel(jumplab); | |
507 | if(ioendlab) putif( mkexpr(OPGE, cpexpr(IOSTP), ICON(0)), ioendlab); | |
508 | if(ioerrlab) putif( mkexpr(OPLE, cpexpr(IOSTP), ICON(0)), ioerrlab); | |
509 | } | |
510 | else if(iosreturn && jumplab) | |
511 | putlabel(jumplab); | |
512 | if(IOSTP) | |
513 | frexpr(IOSTP); | |
514 | } | |
515 | ||
516 | ||
517 | ||
518 | LOCAL putiocall(q) | |
519 | register struct Exprblock *q; | |
520 | { | |
521 | if(IOSTP) | |
522 | { | |
523 | q->vtype = TYINT; | |
524 | q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q)); | |
525 | } | |
526 | ||
527 | if(jumplab) | |
528 | putif( mkexpr(iostest, q, ICON(0) ), jumplab); | |
529 | else | |
530 | putexpr(q); | |
531 | } | |
532 | \f | |
533 | ||
534 | startrw() | |
535 | { | |
536 | register expptr p; | |
537 | register struct Nameblock *np; | |
538 | register struct Addrblock *unitp, *nump; | |
539 | struct Constblock *mkaddcon(); | |
540 | int k, fmtoff; | |
541 | int intfile, sequential; | |
542 | ||
543 | intfile = NO; | |
544 | if(p = V(IOSUNIT)) | |
545 | { | |
546 | if( ISINT(p->headblock.vtype) ) | |
547 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
548 | else if(p->headblock.vtype == TYCHAR) | |
549 | { | |
550 | intfile = YES; | |
551 | if(p->headblock.tag==TPRIM && p->primblock.argsp==NULL && | |
552 | (np = p->primblock.namep)->vdim!=NULL) | |
553 | { | |
554 | vardcl(np); | |
555 | if(np->vdim->nelt) | |
556 | nump = cpexpr(np->vdim->nelt); | |
557 | else | |
558 | { | |
559 | err("attempt to use internal unit array of unknown size"); | |
560 | nump = ICON(1); | |
561 | } | |
562 | unitp = mkscalar(np); | |
563 | } | |
564 | else { | |
565 | nump = ICON(1); | |
566 | unitp = fixtype(cpexpr(p)); | |
567 | } | |
568 | ioset(TYIOINT, XIRNUM, nump); | |
569 | ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); | |
570 | ioset(TYADDR, XIUNIT, addrof(unitp) ); | |
571 | } | |
572 | } | |
573 | else | |
574 | err("bad unit specifier"); | |
575 | ||
576 | sequential = YES; | |
577 | if(p = V(IOSREC)) | |
578 | if( ISINT(p->headblock.vtype) ) | |
579 | { | |
580 | ioset(TYIOINT, (intfile ? XIREC : XREC), cpexpr(p) ); | |
581 | sequential = NO; | |
582 | } | |
583 | else | |
584 | err("bad REC= clause"); | |
585 | ||
586 | ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(ioendlab!=0 || iosreturn) ); | |
587 | ||
588 | fmtoff = (intfile ? XIFMT : XFMT); | |
589 | ||
590 | if(p = V(IOSFMT)) | |
591 | { | |
592 | if(p->headblock.tag==TPRIM && p->primblock.argsp==NULL) | |
593 | { | |
594 | vardcl(np = p->primblock.namep); | |
595 | if(np->vdim) | |
596 | { | |
597 | ioset(TYADDR, fmtoff, addrof(mkscalar(np)) ); | |
598 | goto endfmt; | |
599 | } | |
600 | if( ISINT(np->vtype) ) | |
601 | { | |
602 | ioset(TYADDR, fmtoff, p); | |
603 | goto endfmt; | |
604 | } | |
605 | } | |
606 | p = V(IOSFMT) = fixtype(p); | |
607 | if(p->headblock.vtype == TYCHAR) | |
608 | ioset(TYADDR, fmtoff, addrof(cpexpr(p)) ); | |
609 | else if( ISICON(p) ) | |
610 | { | |
611 | if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 ) | |
612 | ioset(TYADDR, fmtoff, mkaddcon(k) ); | |
613 | else | |
614 | ioformatted = UNFORMATTED; | |
615 | } | |
616 | else { | |
617 | err("bad format descriptor"); | |
618 | ioformatted = UNFORMATTED; | |
619 | } | |
620 | } | |
621 | else | |
622 | ioset(TYADDR, fmtoff, ICON(0) ); | |
623 | ||
624 | endfmt: | |
625 | if(intfile && ioformatted==UNFORMATTED) | |
626 | err("unformatted internal I/O not allowed"); | |
627 | if(!sequential && ioformatted==LISTDIRECTED) | |
628 | err("direct list-directed I/O not allowed"); | |
629 | ||
630 | ioroutine[0] = 's'; | |
631 | ioroutine[1] = '_'; | |
632 | ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w'); | |
633 | ioroutine[3] = (sequential ? 's' : 'd'); | |
634 | ioroutine[4] = "ufl" [ioformatted]; | |
635 | ioroutine[5] = (intfile ? 'i' : 'e'); | |
636 | ioroutine[6] = '\0'; | |
637 | putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) )); | |
638 | } | |
639 | ||
640 | ||
641 | ||
642 | LOCAL dofopen() | |
643 | { | |
644 | register expptr p; | |
645 | ||
646 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) | |
647 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
648 | else | |
649 | err("bad unit in open"); | |
650 | if( (p = V(IOSFILE)) ) | |
651 | if(p->headblock.vtype == TYCHAR) | |
652 | ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); | |
653 | else | |
654 | err("bad file in open"); | |
655 | ||
656 | iosetc(XFNAME, p); | |
657 | ||
658 | if(p = V(IOSRECL)) | |
659 | if( ISINT(p->headblock.vtype) ) | |
660 | ioset(TYIOINT, XRECLEN, cpexpr(p) ); | |
661 | else | |
662 | err("bad recl"); | |
663 | else | |
664 | ioset(TYIOINT, XRECLEN, ICON(0) ); | |
665 | ||
666 | iosetc(XSTATUS, V(IOSSTATUS)); | |
667 | iosetc(XACCESS, V(IOSACCESS)); | |
668 | iosetc(XFORMATTED, V(IOSFORM)); | |
669 | iosetc(XBLANK, V(IOSBLANK)); | |
670 | ||
671 | putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) )); | |
672 | } | |
673 | ||
674 | ||
675 | LOCAL dofclose() | |
676 | { | |
677 | register expptr p; | |
678 | ||
679 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) | |
680 | { | |
681 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
682 | iosetc(XCLSTATUS, V(IOSSTATUS)); | |
683 | putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) ); | |
684 | } | |
685 | else | |
686 | err("bad unit in close statement"); | |
687 | } | |
688 | ||
689 | ||
690 | LOCAL dofinquire() | |
691 | { | |
692 | register expptr p; | |
693 | if(p = V(IOSUNIT)) | |
694 | { | |
695 | if( V(IOSFILE) ) | |
696 | err("inquire by unit or by file, not both"); | |
697 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
698 | } | |
699 | else if( ! V(IOSFILE) ) | |
700 | err("must inquire by unit or by file"); | |
701 | iosetlc(IOSFILE, XFILE, XFILELEN); | |
702 | iosetip(IOSEXISTS, XEXISTS); | |
703 | iosetip(IOSOPENED, XOPEN); | |
704 | iosetip(IOSNUMBER, XNUMBER); | |
705 | iosetip(IOSNAMED, XNAMED); | |
706 | iosetlc(IOSNAME, XNAME, XNAMELEN); | |
707 | iosetlc(IOSACCESS, XQACCESS, XQACCLEN); | |
708 | iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); | |
709 | iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); | |
710 | iosetlc(IOSFORM, XFORM, XFORMLEN); | |
711 | iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); | |
712 | iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); | |
713 | iosetip(IOSRECL, XQRECL); | |
714 | iosetip(IOSNEXTREC, XNEXTREC); | |
715 | iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); | |
716 | ||
717 | putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) )); | |
718 | } | |
719 | ||
720 | ||
721 | ||
722 | LOCAL dofmove(subname) | |
723 | char *subname; | |
724 | { | |
725 | register expptr p; | |
726 | ||
727 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) | |
728 | { | |
729 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
730 | putiocall( call1(TYINT, subname, cpexpr(ioblkp) )); | |
731 | } | |
732 | else | |
733 | err("bad unit in I/O motion statement"); | |
734 | } | |
735 | ||
736 | ||
737 | ||
738 | LOCAL ioset(type, offset, p) | |
739 | int type, offset; | |
740 | expptr p; | |
741 | { | |
742 | register struct Addrblock *q; | |
743 | ||
744 | q = cpexpr(ioblkp); | |
745 | q->vtype = type; | |
746 | q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) ); | |
747 | puteq(q, p); | |
748 | } | |
749 | ||
750 | ||
751 | ||
752 | ||
753 | LOCAL iosetc(offset, p) | |
754 | int offset; | |
755 | register expptr p; | |
756 | { | |
757 | if(p == NULL) | |
758 | ioset(TYADDR, offset, ICON(0) ); | |
759 | else if(p->headblock.vtype == TYCHAR) | |
760 | ioset(TYADDR, offset, addrof(cpexpr(p) )); | |
761 | else | |
762 | err("non-character control clause"); | |
763 | } | |
764 | ||
765 | ||
766 | ||
767 | LOCAL iosetip(i, offset) | |
768 | int i, offset; | |
769 | { | |
770 | register expptr p; | |
771 | ||
772 | if(p = V(i)) | |
773 | if(p->headblock.tag==TADDR && | |
774 | ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) ) | |
775 | ioset(TYADDR, offset, addrof(cpexpr(p)) ); | |
776 | else | |
777 | errstr("impossible inquire parameter %s", ioc[i].iocname); | |
778 | else | |
779 | ioset(TYADDR, offset, ICON(0) ); | |
780 | } | |
781 | ||
782 | ||
783 | ||
784 | LOCAL iosetlc(i, offp, offl) | |
785 | int i, offp, offl; | |
786 | { | |
787 | register expptr p; | |
788 | if( (p = V(i)) && p->headblock.vtype==TYCHAR) | |
789 | ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); | |
790 | iosetc(offp, p); | |
791 | } |