Commit | Line | Data |
---|---|---|
cea95857 KM |
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 | |
d8d00b87 | 8 | static char *sccsid = "@(#)io.c 5.3 (Berkeley) %G%"; |
cea95857 KM |
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 | * | |
d8d00b87 | 19 | * $Header: io.c,v 5.3 86/03/04 17:45:33 donn Exp $ |
cea95857 | 20 | * $Log: io.c,v $ |
d8d00b87 DS |
21 | * Revision 5.3 86/03/04 17:45:33 donn |
22 | * Change the order of length and offset code in startrw() -- always emit | |
23 | * the memoffset first, since it may define a temporary which is used in | |
24 | * the length expression. | |
25 | * | |
401d8e4a DS |
26 | * Revision 5.2 85/12/19 17:22:35 donn |
27 | * Don't permit more than one 'positional iocontrol' parameter unless we | |
28 | * are doing a READ or a WRITE. | |
29 | * | |
30 | * Revision 5.1 85/08/10 03:47:42 donn | |
31 | * 4.3 alpha | |
32 | * | |
cea95857 KM |
33 | * Revision 2.4 85/02/23 21:09:02 donn |
34 | * Jerry Berkman's compiled format fixes move setfmt into a separate file. | |
35 | * | |
36 | * Revision 2.3 85/01/10 22:33:41 donn | |
37 | * Added some strategic cpexpr()s to prevent memory management bugs. | |
38 | * | |
39 | * Revision 2.2 84/08/04 21:15:47 donn | |
40 | * Removed code that creates extra statement labels, per Jerry Berkman's | |
41 | * fixes to make ASSIGNs work right. | |
42 | * | |
43 | * Revision 2.1 84/07/19 12:03:33 donn | |
44 | * Changed comment headers for UofU. | |
45 | * | |
46 | * Revision 1.2 84/02/26 06:35:57 donn | |
47 | * Added Berkeley changes necessary for shortening offsets to data. | |
48 | * | |
49 | */ | |
50 | ||
51 | /* TEMPORARY */ | |
52 | #define TYIOINT TYLONG | |
53 | #define SZIOINT SZLONG | |
54 | ||
55 | #include "defs.h" | |
56 | #include "io.h" | |
57 | ||
58 | ||
59 | LOCAL char ioroutine[XL+1]; | |
60 | ||
61 | LOCAL int ioendlab; | |
62 | LOCAL int ioerrlab; | |
63 | LOCAL int endbit; | |
64 | LOCAL int errbit; | |
65 | LOCAL int jumplab; | |
66 | LOCAL int skiplab; | |
67 | LOCAL int ioformatted; | |
68 | LOCAL int statstruct = NO; | |
69 | LOCAL ftnint blklen; | |
70 | ||
71 | LOCAL offsetlist *mkiodata(); | |
72 | ||
73 | ||
74 | #define UNFORMATTED 0 | |
75 | #define FORMATTED 1 | |
76 | #define LISTDIRECTED 2 | |
77 | #define NAMEDIRECTED 3 | |
78 | ||
79 | #define V(z) ioc[z].iocval | |
80 | ||
81 | #define IOALL 07777 | |
82 | ||
83 | LOCAL struct Ioclist | |
84 | { | |
85 | char *iocname; | |
86 | int iotype; | |
87 | expptr iocval; | |
88 | } ioc[ ] = | |
89 | { | |
90 | { "", 0 }, | |
91 | { "unit", IOALL }, | |
92 | { "fmt", M(IOREAD) | M(IOWRITE) }, | |
93 | { "err", IOALL }, | |
94 | { "end", M(IOREAD) }, | |
95 | { "iostat", IOALL }, | |
96 | { "rec", M(IOREAD) | M(IOWRITE) }, | |
97 | { "recl", M(IOOPEN) | M(IOINQUIRE) }, | |
98 | { "file", M(IOOPEN) | M(IOINQUIRE) }, | |
99 | { "status", M(IOOPEN) | M(IOCLOSE) }, | |
100 | { "access", M(IOOPEN) | M(IOINQUIRE) }, | |
101 | { "form", M(IOOPEN) | M(IOINQUIRE) }, | |
102 | { "blank", M(IOOPEN) | M(IOINQUIRE) }, | |
103 | { "exist", M(IOINQUIRE) }, | |
104 | { "opened", M(IOINQUIRE) }, | |
105 | { "number", M(IOINQUIRE) }, | |
106 | { "named", M(IOINQUIRE) }, | |
107 | { "name", M(IOINQUIRE) }, | |
108 | { "sequential", M(IOINQUIRE) }, | |
109 | { "direct", M(IOINQUIRE) }, | |
110 | { "formatted", M(IOINQUIRE) }, | |
111 | { "unformatted", M(IOINQUIRE) }, | |
112 | { "nextrec", M(IOINQUIRE) } | |
113 | } ; | |
114 | ||
115 | #define NIOS (sizeof(ioc)/sizeof(struct Ioclist) - 1) | |
116 | #define MAXIO SZFLAG + 10*SZIOINT + 15*SZADDR | |
117 | ||
118 | #define IOSUNIT 1 | |
119 | #define IOSFMT 2 | |
120 | #define IOSERR 3 | |
121 | #define IOSEND 4 | |
122 | #define IOSIOSTAT 5 | |
123 | #define IOSREC 6 | |
124 | #define IOSRECL 7 | |
125 | #define IOSFILE 8 | |
126 | #define IOSSTATUS 9 | |
127 | #define IOSACCESS 10 | |
128 | #define IOSFORM 11 | |
129 | #define IOSBLANK 12 | |
130 | #define IOSEXISTS 13 | |
131 | #define IOSOPENED 14 | |
132 | #define IOSNUMBER 15 | |
133 | #define IOSNAMED 16 | |
134 | #define IOSNAME 17 | |
135 | #define IOSSEQUENTIAL 18 | |
136 | #define IOSDIRECT 19 | |
137 | #define IOSFORMATTED 20 | |
138 | #define IOSUNFORMATTED 21 | |
139 | #define IOSNEXTREC 22 | |
140 | ||
141 | #define IOSTP V(IOSIOSTAT) | |
142 | ||
143 | ||
144 | /* offsets in generated structures */ | |
145 | ||
146 | #define SZFLAG SZIOINT | |
147 | ||
148 | /* offsets for external READ and WRITE statements */ | |
149 | ||
150 | #define XERR 0 | |
151 | #define XUNIT SZFLAG | |
152 | #define XEND SZFLAG + SZIOINT | |
153 | #define XFMT 2*SZFLAG + SZIOINT | |
154 | #define XREC 2*SZFLAG + SZIOINT + SZADDR | |
155 | #define XRLEN 2*SZFLAG + 2*SZADDR | |
156 | #define XRNUM 2*SZFLAG + 2*SZADDR + SZIOINT | |
157 | ||
158 | /* offsets for internal READ and WRITE statements */ | |
159 | ||
160 | #define XIERR 0 | |
161 | #define XIUNIT SZFLAG | |
162 | #define XIEND SZFLAG + SZADDR | |
163 | #define XIFMT 2*SZFLAG + SZADDR | |
164 | #define XIRLEN 2*SZFLAG + 2*SZADDR | |
165 | #define XIRNUM 2*SZFLAG + 2*SZADDR + SZIOINT | |
166 | #define XIREC 2*SZFLAG + 2*SZADDR + 2*SZIOINT | |
167 | ||
168 | /* offsets for OPEN statements */ | |
169 | ||
170 | #define XFNAME SZFLAG + SZIOINT | |
171 | #define XFNAMELEN SZFLAG + SZIOINT + SZADDR | |
172 | #define XSTATUS SZFLAG + 2*SZIOINT + SZADDR | |
173 | #define XACCESS SZFLAG + 2*SZIOINT + 2*SZADDR | |
174 | #define XFORMATTED SZFLAG + 2*SZIOINT + 3*SZADDR | |
175 | #define XRECLEN SZFLAG + 2*SZIOINT + 4*SZADDR | |
176 | #define XBLANK SZFLAG + 3*SZIOINT + 4*SZADDR | |
177 | ||
178 | /* offset for CLOSE statement */ | |
179 | ||
180 | #define XCLSTATUS SZFLAG + SZIOINT | |
181 | ||
182 | /* offsets for INQUIRE statement */ | |
183 | ||
184 | #define XFILE SZFLAG + SZIOINT | |
185 | #define XFILELEN SZFLAG + SZIOINT + SZADDR | |
186 | #define XEXISTS SZFLAG + 2*SZIOINT + SZADDR | |
187 | #define XOPEN SZFLAG + 2*SZIOINT + 2*SZADDR | |
188 | #define XNUMBER SZFLAG + 2*SZIOINT + 3*SZADDR | |
189 | #define XNAMED SZFLAG + 2*SZIOINT + 4*SZADDR | |
190 | #define XNAME SZFLAG + 2*SZIOINT + 5*SZADDR | |
191 | #define XNAMELEN SZFLAG + 2*SZIOINT + 6*SZADDR | |
192 | #define XQACCESS SZFLAG + 3*SZIOINT + 6*SZADDR | |
193 | #define XQACCLEN SZFLAG + 3*SZIOINT + 7*SZADDR | |
194 | #define XSEQ SZFLAG + 4*SZIOINT + 7*SZADDR | |
195 | #define XSEQLEN SZFLAG + 4*SZIOINT + 8*SZADDR | |
196 | #define XDIRECT SZFLAG + 5*SZIOINT + 8*SZADDR | |
197 | #define XDIRLEN SZFLAG + 5*SZIOINT + 9*SZADDR | |
198 | #define XFORM SZFLAG + 6*SZIOINT + 9*SZADDR | |
199 | #define XFORMLEN SZFLAG + 6*SZIOINT + 10*SZADDR | |
200 | #define XFMTED SZFLAG + 7*SZIOINT + 10*SZADDR | |
201 | #define XFMTEDLEN SZFLAG + 7*SZIOINT + 11*SZADDR | |
202 | #define XUNFMT SZFLAG + 8*SZIOINT + 11*SZADDR | |
203 | #define XUNFMTLEN SZFLAG + 8*SZIOINT + 12*SZADDR | |
204 | #define XQRECL SZFLAG + 9*SZIOINT + 12*SZADDR | |
205 | #define XNEXTREC SZFLAG + 9*SZIOINT + 13*SZADDR | |
206 | #define XQBLANK SZFLAG + 9*SZIOINT + 14*SZADDR | |
207 | #define XQBLANKLEN SZFLAG + 9*SZIOINT + 15*SZADDR | |
208 | \f | |
209 | fmtstmt(lp) | |
210 | register struct Labelblock *lp; | |
211 | { | |
212 | if(lp == NULL) | |
213 | { | |
214 | execerr("unlabeled format statement" , CNULL); | |
215 | return(-1); | |
216 | } | |
217 | if(lp->labtype == LABUNKNOWN) | |
218 | lp->labtype = LABFORMAT; | |
219 | else if(lp->labtype != LABFORMAT) | |
220 | { | |
221 | execerr("bad format number", CNULL); | |
222 | return(-1); | |
223 | } | |
224 | return(lp->labelno); | |
225 | } | |
226 | ||
227 | ||
228 | ||
229 | startioctl() | |
230 | { | |
231 | register int i; | |
232 | ||
233 | inioctl = YES; | |
234 | nioctl = 0; | |
235 | ioformatted = UNFORMATTED; | |
236 | for(i = 1 ; i<=NIOS ; ++i) | |
237 | V(i) = NULL; | |
238 | } | |
239 | ||
240 | ||
241 | ||
242 | endioctl() | |
243 | { | |
244 | int i; | |
245 | expptr p; | |
246 | ||
247 | inioctl = NO; | |
248 | ||
249 | /* set up for error recovery */ | |
250 | ||
251 | ioerrlab = ioendlab = skiplab = jumplab = 0; | |
252 | ||
253 | if(p = V(IOSEND)) | |
254 | if(ISICON(p)) | |
255 | ioendlab = execlab(p->constblock.const.ci) ->labelno; | |
256 | else | |
257 | err("bad end= clause"); | |
258 | ||
259 | if(p = V(IOSERR)) | |
260 | if(ISICON(p)) | |
261 | ioerrlab = execlab(p->constblock.const.ci) ->labelno; | |
262 | else | |
263 | err("bad err= clause"); | |
264 | ||
265 | if(IOSTP) | |
266 | if(IOSTP->tag!=TADDR || ! ISINT(IOSTP->addrblock.vtype) ) | |
267 | { | |
268 | err("iostat must be an integer variable"); | |
269 | frexpr(IOSTP); | |
270 | IOSTP = NULL; | |
271 | } | |
272 | ||
273 | if(iostmt == IOREAD) | |
274 | { | |
275 | if(IOSTP) | |
276 | { | |
277 | if(ioerrlab && ioendlab && ioerrlab==ioendlab) | |
278 | jumplab = ioerrlab; | |
279 | else | |
280 | skiplab = jumplab = newlabel(); | |
281 | } | |
282 | else { | |
283 | if(ioerrlab && ioendlab && ioerrlab!=ioendlab) | |
284 | { | |
285 | IOSTP = (expptr) mktemp(TYINT, PNULL); | |
286 | skiplab = jumplab = newlabel(); | |
287 | } | |
288 | else | |
289 | jumplab = (ioerrlab ? ioerrlab : ioendlab); | |
290 | } | |
291 | } | |
292 | else if(iostmt == IOWRITE) | |
293 | { | |
294 | if(IOSTP && !ioerrlab) | |
295 | skiplab = jumplab = newlabel(); | |
296 | else | |
297 | jumplab = ioerrlab; | |
298 | } | |
299 | else | |
300 | jumplab = ioerrlab; | |
301 | ||
302 | endbit = IOSTP!=NULL || ioendlab!=0; /* for use in startrw() */ | |
303 | errbit = IOSTP!=NULL || ioerrlab!=0; | |
304 | if(iostmt!=IOREAD && iostmt!=IOWRITE) | |
305 | { | |
306 | if(ioblkp == NULL) | |
307 | ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL); | |
308 | ioset(TYIOINT, XERR, ICON(errbit)); | |
309 | } | |
310 | ||
311 | switch(iostmt) | |
312 | { | |
313 | case IOOPEN: | |
314 | dofopen(); break; | |
315 | ||
316 | case IOCLOSE: | |
317 | dofclose(); break; | |
318 | ||
319 | case IOINQUIRE: | |
320 | dofinquire(); break; | |
321 | ||
322 | case IOBACKSPACE: | |
323 | dofmove("f_back"); break; | |
324 | ||
325 | case IOREWIND: | |
326 | dofmove("f_rew"); break; | |
327 | ||
328 | case IOENDFILE: | |
329 | dofmove("f_end"); break; | |
330 | ||
331 | case IOREAD: | |
332 | case IOWRITE: | |
333 | startrw(); break; | |
334 | ||
335 | default: | |
336 | fatali("impossible iostmt %d", iostmt); | |
337 | } | |
338 | for(i = 1 ; i<=NIOS ; ++i) | |
339 | if(i!=IOSIOSTAT && V(i)!=NULL) | |
340 | frexpr(V(i)); | |
341 | } | |
342 | ||
343 | ||
344 | ||
345 | iocname() | |
346 | { | |
347 | register int i; | |
348 | int found, mask; | |
349 | ||
350 | found = 0; | |
351 | mask = M(iostmt); | |
352 | for(i = 1 ; i <= NIOS ; ++i) | |
353 | if(toklen==strlen(ioc[i].iocname) && eqn(toklen, token, ioc[i].iocname)) | |
354 | if(ioc[i].iotype & mask) | |
355 | return(i); | |
356 | else found = i; | |
357 | if(found) | |
358 | errstr("invalid control %s for statement", ioc[found].iocname); | |
359 | else | |
360 | errstr("unknown iocontrol %s", varstr(toklen, token) ); | |
361 | return(IOSBAD); | |
362 | } | |
363 | ||
364 | ||
365 | ioclause(n, p) | |
366 | register int n; | |
367 | register expptr p; | |
368 | { | |
369 | struct Ioclist *iocp; | |
370 | ||
371 | ++nioctl; | |
372 | if(n == IOSBAD) | |
373 | return; | |
374 | if(n == IOSPOSITIONAL) | |
375 | { | |
401d8e4a DS |
376 | if(nioctl > IOSFMT || |
377 | nioctl > IOSUNIT && !(iostmt == IOREAD || iostmt == IOWRITE)) | |
cea95857 KM |
378 | { |
379 | err("illegal positional iocontrol"); | |
380 | return; | |
381 | } | |
382 | n = nioctl; | |
383 | } | |
384 | ||
385 | if(p == NULL) | |
386 | { | |
387 | if(n == IOSUNIT) | |
388 | p = (expptr) (iostmt==IOREAD ? IOSTDIN : IOSTDOUT); | |
389 | else if(n != IOSFMT) | |
390 | { | |
391 | err("illegal * iocontrol"); | |
392 | return; | |
393 | } | |
394 | } | |
395 | if(n == IOSFMT) | |
396 | ioformatted = (p==NULL ? LISTDIRECTED : FORMATTED); | |
397 | ||
398 | iocp = & ioc[n]; | |
399 | if(iocp->iocval == NULL) | |
400 | { | |
401 | p = (expptr) cpexpr(p); | |
402 | if(n!=IOSFMT && ( n!=IOSUNIT || (p!=NULL && p->headblock.vtype!=TYCHAR) ) ) | |
403 | p = fixtype(p); | |
404 | if(p!=NULL && ISCONST(p) && p->constblock.vtype==TYCHAR) | |
405 | p = (expptr) putconst(p); | |
406 | iocp->iocval = p; | |
407 | } | |
408 | else | |
409 | errstr("iocontrol %s repeated", iocp->iocname); | |
410 | } | |
411 | ||
412 | /* io list item */ | |
413 | ||
414 | doio(list) | |
415 | chainp list; | |
416 | { | |
417 | expptr call0(); | |
418 | ||
419 | if(ioformatted == NAMEDIRECTED) | |
420 | { | |
421 | if(list) | |
422 | err("no I/O list allowed in NAMELIST read/write"); | |
423 | } | |
424 | else | |
425 | { | |
426 | doiolist(list); | |
427 | ioroutine[0] = 'e'; | |
428 | putiocall( call0(TYINT, ioroutine) ); | |
429 | } | |
430 | } | |
431 | ||
432 | ||
433 | ||
434 | ||
435 | ||
436 | LOCAL doiolist(p0) | |
437 | chainp p0; | |
438 | { | |
439 | chainp p; | |
440 | register tagptr q; | |
441 | register expptr qe; | |
442 | register Namep qn; | |
443 | Addrp tp, mkscalar(); | |
444 | int range; | |
445 | expptr expr; | |
446 | ||
447 | for (p = p0 ; p ; p = p->nextp) | |
448 | { | |
449 | q = p->datap; | |
450 | if(q->tag == TIMPLDO) | |
451 | { | |
452 | exdo(range=newlabel(), q->impldoblock.impdospec); | |
453 | doiolist(q->impldoblock.datalist); | |
454 | enddo(range); | |
455 | free( (charptr) q); | |
456 | } | |
457 | else { | |
458 | if(q->tag==TPRIM && q->primblock.argsp==NULL | |
459 | && q->primblock.namep->vdim!=NULL) | |
460 | { | |
461 | vardcl(qn = q->primblock.namep); | |
462 | if(qn->vdim->nelt) | |
463 | putio( fixtype(cpexpr(qn->vdim->nelt)), | |
464 | mkscalar(qn) ); | |
465 | else | |
466 | err("attempt to i/o array of unknown size"); | |
467 | } | |
468 | else if(q->tag==TPRIM && q->primblock.argsp==NULL && | |
469 | (qe = (expptr) memversion(q->primblock.namep)) ) | |
470 | putio(ICON(1),qe); | |
471 | else if( (qe = fixtype(cpexpr(q)))->tag==TADDR) | |
472 | putio(ICON(1), qe); | |
473 | else if(qe->headblock.vtype != TYERROR) | |
474 | { | |
475 | if(iostmt == IOWRITE) | |
476 | { | |
477 | ftnint lencat(); | |
478 | expptr qvl; | |
479 | qvl = NULL; | |
480 | if( ISCHAR(qe) ) | |
481 | { | |
482 | qvl = (expptr) | |
483 | cpexpr(qe->headblock.vleng); | |
484 | tp = mktemp(qe->headblock.vtype, | |
485 | ICON(lencat(qe))); | |
486 | } | |
487 | else | |
488 | tp = mktemp(qe->headblock.vtype, | |
489 | qe->headblock.vleng); | |
490 | if (optimflag) | |
491 | { | |
492 | expr = mkexpr(OPASSIGN,cpexpr(tp),qe); | |
493 | optbuff (SKEQ,expr,0,0); | |
494 | } | |
495 | else | |
496 | puteq (cpexpr(tp),qe); | |
497 | if(qvl) /* put right length on block */ | |
498 | { | |
499 | frexpr(tp->vleng); | |
500 | tp->vleng = qvl; | |
501 | } | |
502 | putio(ICON(1), tp); | |
503 | } | |
504 | else | |
505 | err("non-left side in READ list"); | |
506 | } | |
507 | frexpr(q); | |
508 | } | |
509 | } | |
510 | frchain( &p0 ); | |
511 | } | |
512 | ||
513 | ||
514 | ||
515 | ||
516 | ||
517 | LOCAL putio(nelt, addr) | |
518 | expptr nelt; | |
519 | register expptr addr; | |
520 | { | |
521 | int type; | |
522 | register expptr q; | |
523 | ||
524 | type = addr->headblock.vtype; | |
525 | if(ioformatted!=LISTDIRECTED && ISCOMPLEX(type) ) | |
526 | { | |
527 | nelt = mkexpr(OPSTAR, ICON(2), nelt); | |
528 | type -= (TYCOMPLEX-TYREAL); | |
529 | } | |
530 | ||
531 | /* pass a length with every item. for noncharacter data, fake one */ | |
532 | if(type != TYCHAR) | |
533 | { | |
534 | addr->headblock.vtype = TYCHAR; | |
535 | addr->headblock.vleng = ICON( typesize[type] ); | |
536 | } | |
537 | ||
538 | nelt = fixtype( mkconv(TYLENG,nelt) ); | |
539 | if(ioformatted == LISTDIRECTED) | |
540 | q = call3(TYINT, "do_lio", mkconv(TYLONG, ICON(type)), nelt, addr); | |
541 | else | |
542 | q = call2(TYINT, (ioformatted==FORMATTED ? "do_fio" : "do_uio"), | |
543 | nelt, addr); | |
544 | putiocall(q); | |
545 | } | |
546 | ||
547 | ||
548 | ||
549 | ||
550 | endio() | |
551 | { | |
552 | if(skiplab) | |
553 | { | |
554 | if (optimflag) | |
555 | optbuff (SKLABEL, 0, skiplab, 0); | |
556 | else | |
557 | putlabel (skiplab); | |
558 | if(ioendlab) | |
559 | { | |
560 | expptr test; | |
561 | test = mkexpr(OPGE, cpexpr(IOSTP), ICON(0)); | |
562 | if (optimflag) | |
563 | optbuff (SKIOIFN,test,ioendlab,0); | |
564 | else | |
565 | putif (test,ioendlab); | |
566 | } | |
567 | if(ioerrlab) | |
568 | { | |
569 | expptr test; | |
570 | test = mkexpr | |
571 | ( ((iostmt==IOREAD||iostmt==IOWRITE) ? OPLE : OPEQ), | |
572 | cpexpr(IOSTP), ICON(0)); | |
573 | if (optimflag) | |
574 | optbuff (SKIOIFN,test,ioerrlab,0); | |
575 | else | |
576 | putif (test,ioerrlab); | |
577 | } | |
578 | } | |
579 | if(IOSTP) | |
580 | frexpr(IOSTP); | |
581 | } | |
582 | ||
583 | ||
584 | ||
585 | LOCAL putiocall(q) | |
586 | register expptr q; | |
587 | { | |
588 | if(IOSTP) | |
589 | { | |
590 | q->headblock.vtype = TYINT; | |
591 | q = fixexpr( mkexpr(OPASSIGN, cpexpr(IOSTP), q)); | |
592 | } | |
593 | ||
594 | if(jumplab) | |
595 | if (optimflag) | |
596 | optbuff (SKIOIFN,mkexpr(OPEQ,q,ICON(0)),jumplab,0); | |
597 | else | |
598 | putif (mkexpr(OPEQ,q,ICON(0)),jumplab); | |
599 | else | |
600 | if (optimflag) | |
601 | optbuff (SKEQ, q, 0, 0); | |
602 | else | |
603 | putexpr(q); | |
604 | } | |
605 | \f | |
606 | startrw() | |
607 | { | |
608 | register expptr p; | |
609 | register Namep np; | |
610 | register Addrp unitp, fmtp, recp, tioblkp; | |
611 | register expptr nump; | |
612 | register ioblock *t; | |
613 | Addrp mkscalar(); | |
614 | expptr mkaddcon(); | |
615 | int k; | |
616 | flag intfile, sequential, ok, varfmt; | |
617 | ||
618 | /* First look at all the parameters and determine what is to be done */ | |
619 | ||
620 | ok = YES; | |
621 | statstruct = YES; | |
622 | ||
623 | intfile = NO; | |
624 | if(p = V(IOSUNIT)) | |
625 | { | |
626 | if( ISINT(p->headblock.vtype) ) | |
627 | unitp = (Addrp) cpexpr(p); | |
628 | else if(p->headblock.vtype == TYCHAR) | |
629 | { | |
630 | intfile = YES; | |
631 | if(p->tag==TPRIM && p->primblock.argsp==NULL && | |
632 | (np = p->primblock.namep)->vdim!=NULL) | |
633 | { | |
634 | vardcl(np); | |
635 | if(np->vdim->nelt) | |
636 | { | |
637 | nump = (expptr) cpexpr(np->vdim->nelt); | |
638 | if( ! ISCONST(nump) ) | |
639 | statstruct = NO; | |
640 | } | |
641 | else | |
642 | { | |
643 | err("attempt to use internal unit array of unknown size"); | |
644 | ok = NO; | |
645 | nump = ICON(1); | |
646 | } | |
647 | unitp = mkscalar(np); | |
648 | } | |
649 | else { | |
650 | nump = ICON(1); | |
651 | unitp = (Addrp) fixtype(cpexpr(p)); | |
652 | } | |
653 | if(! isstatic(unitp) ) | |
654 | statstruct = NO; | |
655 | } | |
656 | else | |
657 | { | |
658 | err("bad unit specifier type"); | |
659 | ok = NO; | |
660 | } | |
661 | } | |
662 | else | |
663 | { | |
664 | err("bad unit specifier"); | |
665 | ok = NO; | |
666 | } | |
667 | ||
668 | sequential = YES; | |
669 | if(p = V(IOSREC)) | |
670 | if( ISINT(p->headblock.vtype) ) | |
671 | { | |
672 | recp = (Addrp) cpexpr(p); | |
673 | sequential = NO; | |
674 | } | |
675 | else { | |
676 | err("bad REC= clause"); | |
677 | ok = NO; | |
678 | } | |
679 | else | |
680 | recp = NULL; | |
681 | ||
682 | ||
683 | varfmt = YES; | |
684 | fmtp = NULL; | |
685 | if(p = V(IOSFMT)) | |
686 | { | |
687 | if(p->tag==TPRIM && p->primblock.argsp==NULL) | |
688 | { | |
689 | np = p->primblock.namep; | |
690 | if(np->vclass == CLNAMELIST) | |
691 | { | |
692 | ioformatted = NAMEDIRECTED; | |
693 | fmtp = (Addrp) fixtype(cpexpr(p)); | |
694 | goto endfmt; | |
695 | } | |
696 | vardcl(np); | |
697 | if(np->vdim) | |
698 | { | |
699 | if( ! ONEOF(np->vstg, MSKSTATIC) ) | |
700 | statstruct = NO; | |
701 | fmtp = mkscalar(np); | |
702 | goto endfmt; | |
703 | } | |
704 | if( ISINT(np->vtype) ) /* ASSIGNed label */ | |
705 | { | |
706 | statstruct = NO; | |
707 | varfmt = NO; | |
708 | fmtp = (Addrp) fixtype(cpexpr(p)); | |
709 | goto endfmt; | |
710 | } | |
711 | } | |
712 | p = V(IOSFMT) = fixtype(p); | |
713 | if(p->headblock.vtype == TYCHAR) | |
714 | { | |
715 | if (p->tag == TCONST) p = (expptr) putconst(p); | |
716 | if( ! isstatic(p) ) | |
717 | statstruct = NO; | |
718 | fmtp = (Addrp) cpexpr(p); | |
719 | } | |
720 | else if( ISICON(p) ) | |
721 | { | |
722 | if( (k = fmtstmt( mklabel(p->constblock.const.ci) )) > 0 ) | |
723 | { | |
724 | fmtp = (Addrp) mkaddcon(k); | |
725 | varfmt = NO; | |
726 | } | |
727 | else | |
728 | ioformatted = UNFORMATTED; | |
729 | } | |
730 | else { | |
731 | err("bad format descriptor"); | |
732 | ioformatted = UNFORMATTED; | |
733 | ok = NO; | |
734 | } | |
735 | } | |
736 | else | |
737 | fmtp = NULL; | |
738 | ||
739 | endfmt: | |
740 | if(intfile && ioformatted==UNFORMATTED) | |
741 | { | |
742 | err("unformatted internal I/O not allowed"); | |
743 | ok = NO; | |
744 | } | |
745 | if(!sequential && ioformatted==LISTDIRECTED) | |
746 | { | |
747 | err("direct list-directed I/O not allowed"); | |
748 | ok = NO; | |
749 | } | |
750 | if(!sequential && ioformatted==NAMEDIRECTED) | |
751 | { | |
752 | err("direct namelist I/O not allowed"); | |
753 | ok = NO; | |
754 | } | |
755 | ||
756 | if( ! ok ) | |
757 | return; | |
758 | ||
759 | if (optimflag && ISCONST (fmtp)) | |
760 | fmtp = putconst ( (expptr) fmtp); | |
761 | ||
762 | /* | |
763 | Now put out the I/O structure, statically if all the clauses | |
764 | are constants, dynamically otherwise | |
765 | */ | |
766 | ||
767 | if(statstruct) | |
768 | { | |
769 | tioblkp = ioblkp; | |
770 | ioblkp = ALLOC(Addrblock); | |
771 | ioblkp->tag = TADDR; | |
772 | ioblkp->vtype = TYIOINT; | |
773 | ioblkp->vclass = CLVAR; | |
774 | ioblkp->vstg = STGINIT; | |
775 | ioblkp->memno = ++lastvarno; | |
776 | ioblkp->memoffset = ICON(0); | |
777 | blklen = (intfile ? XIREC+SZIOINT : | |
778 | (sequential ? XFMT+SZADDR : XRNUM+SZIOINT) ); | |
779 | t = ALLOC(IoBlock); | |
780 | t->blkno = ioblkp->memno; | |
781 | t->len = blklen; | |
782 | t->next = iodata; | |
783 | iodata = t; | |
784 | } | |
785 | else if(ioblkp == NULL) | |
786 | ioblkp = autovar( (MAXIO+SZIOINT-1)/SZIOINT , TYIOINT, PNULL); | |
787 | ||
788 | ioset(TYIOINT, XERR, ICON(errbit)); | |
789 | if(iostmt == IOREAD) | |
790 | ioset(TYIOINT, (intfile ? XIEND : XEND), ICON(endbit) ); | |
791 | ||
792 | if(intfile) | |
793 | { | |
794 | ioset(TYIOINT, XIRNUM, nump); | |
d8d00b87 | 795 | ioseta(XIUNIT, cpexpr(unitp)); |
cea95857 | 796 | ioset(TYIOINT, XIRLEN, cpexpr(unitp->vleng) ); |
d8d00b87 | 797 | frexpr(unitp); |
cea95857 KM |
798 | } |
799 | else | |
800 | ioset(TYIOINT, XUNIT, (expptr) unitp); | |
801 | ||
802 | if(recp) | |
803 | ioset(TYIOINT, (intfile ? XIREC : XREC) , (expptr) recp); | |
804 | ||
805 | if(varfmt) | |
806 | ioseta( intfile ? XIFMT : XFMT , fmtp); | |
807 | else | |
808 | ioset(TYADDR, intfile ? XIFMT : XFMT, (expptr) fmtp); | |
809 | ||
810 | ioroutine[0] = 's'; | |
811 | ioroutine[1] = '_'; | |
812 | ioroutine[2] = (iostmt==IOREAD ? 'r' : 'w'); | |
813 | ioroutine[3] = (sequential ? 's' : 'd'); | |
814 | ioroutine[4] = "ufln" [ioformatted]; | |
815 | ioroutine[5] = (intfile ? 'i' : 'e'); | |
816 | ioroutine[6] = '\0'; | |
817 | ||
818 | putiocall( call1(TYINT, ioroutine, cpexpr(ioblkp) )); | |
819 | ||
820 | if(statstruct) | |
821 | { | |
822 | frexpr(ioblkp); | |
823 | ioblkp = tioblkp; | |
824 | statstruct = NO; | |
825 | } | |
826 | } | |
827 | ||
828 | ||
829 | ||
830 | LOCAL dofopen() | |
831 | { | |
832 | register expptr p; | |
833 | ||
834 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) | |
835 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
836 | else | |
837 | err("bad unit in open"); | |
838 | if( (p = V(IOSFILE)) ) | |
839 | if(p->headblock.vtype == TYCHAR) | |
840 | ioset(TYIOINT, XFNAMELEN, cpexpr(p->headblock.vleng) ); | |
841 | else | |
842 | err("bad file in open"); | |
843 | ||
844 | iosetc(XFNAME, p); | |
845 | ||
846 | if(p = V(IOSRECL)) | |
847 | if( ISINT(p->headblock.vtype) ) | |
848 | ioset(TYIOINT, XRECLEN, cpexpr(p) ); | |
849 | else | |
850 | err("bad recl"); | |
851 | else | |
852 | ioset(TYIOINT, XRECLEN, ICON(0) ); | |
853 | ||
854 | iosetc(XSTATUS, V(IOSSTATUS)); | |
855 | iosetc(XACCESS, V(IOSACCESS)); | |
856 | iosetc(XFORMATTED, V(IOSFORM)); | |
857 | iosetc(XBLANK, V(IOSBLANK)); | |
858 | ||
859 | putiocall( call1(TYINT, "f_open", cpexpr(ioblkp) )); | |
860 | } | |
861 | ||
862 | ||
863 | LOCAL dofclose() | |
864 | { | |
865 | register expptr p; | |
866 | ||
867 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) | |
868 | { | |
869 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
870 | iosetc(XCLSTATUS, V(IOSSTATUS)); | |
871 | putiocall( call1(TYINT, "f_clos", cpexpr(ioblkp)) ); | |
872 | } | |
873 | else | |
874 | err("bad unit in close statement"); | |
875 | } | |
876 | ||
877 | ||
878 | LOCAL dofinquire() | |
879 | { | |
880 | register expptr p; | |
881 | if(p = V(IOSUNIT)) | |
882 | { | |
883 | if( V(IOSFILE) ) | |
884 | err("inquire by unit or by file, not both"); | |
885 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
886 | } | |
887 | else if( ! V(IOSFILE) ) | |
888 | err("must inquire by unit or by file"); | |
889 | iosetlc(IOSFILE, XFILE, XFILELEN); | |
890 | iosetip(IOSEXISTS, XEXISTS); | |
891 | iosetip(IOSOPENED, XOPEN); | |
892 | iosetip(IOSNUMBER, XNUMBER); | |
893 | iosetip(IOSNAMED, XNAMED); | |
894 | iosetlc(IOSNAME, XNAME, XNAMELEN); | |
895 | iosetlc(IOSACCESS, XQACCESS, XQACCLEN); | |
896 | iosetlc(IOSSEQUENTIAL, XSEQ, XSEQLEN); | |
897 | iosetlc(IOSDIRECT, XDIRECT, XDIRLEN); | |
898 | iosetlc(IOSFORM, XFORM, XFORMLEN); | |
899 | iosetlc(IOSFORMATTED, XFMTED, XFMTEDLEN); | |
900 | iosetlc(IOSUNFORMATTED, XUNFMT, XUNFMTLEN); | |
901 | iosetip(IOSRECL, XQRECL); | |
902 | iosetip(IOSNEXTREC, XNEXTREC); | |
903 | iosetlc(IOSBLANK, XQBLANK, XQBLANKLEN); | |
904 | ||
905 | putiocall( call1(TYINT, "f_inqu", cpexpr(ioblkp) )); | |
906 | } | |
907 | ||
908 | ||
909 | ||
910 | LOCAL dofmove(subname) | |
911 | char *subname; | |
912 | { | |
913 | register expptr p; | |
914 | ||
915 | if( (p = V(IOSUNIT)) && ISINT(p->headblock.vtype) ) | |
916 | { | |
917 | ioset(TYIOINT, XUNIT, cpexpr(p) ); | |
918 | putiocall( call1(TYINT, subname, cpexpr(ioblkp) )); | |
919 | } | |
920 | else | |
921 | err("bad unit in I/O motion statement"); | |
922 | } | |
923 | ||
924 | ||
925 | ||
926 | LOCAL | |
927 | ioset(type, offset, p) | |
928 | int type; | |
929 | int offset; | |
930 | register expptr p; | |
931 | { | |
932 | static char *badoffset = "badoffset in ioset"; | |
933 | ||
934 | register Addrp q; | |
935 | register offsetlist *op; | |
936 | ||
937 | q = (Addrp) cpexpr(ioblkp); | |
938 | q->vtype = type; | |
939 | q->memoffset = fixtype( mkexpr(OPPLUS, q->memoffset, ICON(offset)) ); | |
940 | ||
941 | if (statstruct && ISCONST(p)) | |
942 | { | |
943 | if (!ISICON(q->memoffset)) | |
944 | fatal(badoffset); | |
945 | ||
946 | op = mkiodata(q->memno, q->memoffset->constblock.const.ci, blklen); | |
947 | if (op->tag != 0) | |
948 | fatal(badoffset); | |
949 | ||
950 | if (type == TYADDR) | |
951 | { | |
952 | op->tag = NDLABEL; | |
953 | op->val.label = p->constblock.const.ci; | |
954 | } | |
955 | else | |
956 | { | |
957 | op->tag = NDDATA; | |
958 | op->val.cp = (Constp) convconst(type, 0, p); | |
959 | } | |
960 | ||
961 | frexpr((tagptr) p); | |
962 | frexpr((tagptr) q); | |
963 | } | |
964 | else | |
965 | if (optimflag) | |
966 | optbuff (SKEQ, mkexpr(OPASSIGN,q,p), 0,0); | |
967 | else | |
968 | puteq (q,p); | |
969 | ||
970 | return; | |
971 | } | |
972 | ||
973 | ||
974 | ||
975 | ||
976 | LOCAL iosetc(offset, p) | |
977 | int offset; | |
978 | register expptr p; | |
979 | { | |
980 | if(p == NULL) | |
981 | ioset(TYADDR, offset, ICON(0) ); | |
982 | else if(p->headblock.vtype == TYCHAR) | |
983 | ioset(TYADDR, offset, addrof(cpexpr(p) )); | |
984 | else | |
985 | err("non-character control clause"); | |
986 | } | |
987 | ||
988 | ||
989 | ||
990 | LOCAL ioseta(offset, p) | |
991 | int offset; | |
992 | register Addrp p; | |
993 | { | |
994 | static char *badoffset = "bad offset in ioseta"; | |
995 | ||
996 | int blkno; | |
997 | register offsetlist *op; | |
998 | ||
999 | if(statstruct) | |
1000 | { | |
1001 | blkno = ioblkp->memno; | |
1002 | op = mkiodata(blkno, offset, blklen); | |
1003 | if (op->tag != 0) | |
1004 | fatal(badoffset); | |
1005 | ||
1006 | if (p == NULL) | |
1007 | op->tag = NDNULL; | |
1008 | else if (p->tag == TADDR) | |
1009 | { | |
1010 | op->tag = NDADDR; | |
1011 | op->val.addr.stg = p->vstg; | |
1012 | op->val.addr.memno = p->memno; | |
1013 | op->val.addr.offset = p->memoffset->constblock.const.ci; | |
1014 | } | |
1015 | else | |
1016 | badtag("ioseta", p->tag); | |
1017 | } | |
1018 | else | |
1019 | ioset(TYADDR, offset, p ? addrof(p) : ICON(0) ); | |
1020 | ||
1021 | return; | |
1022 | } | |
1023 | ||
1024 | ||
1025 | ||
1026 | ||
1027 | LOCAL iosetip(i, offset) | |
1028 | int i, offset; | |
1029 | { | |
1030 | register expptr p; | |
1031 | ||
1032 | if(p = V(i)) | |
1033 | if(p->tag==TADDR && | |
1034 | ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) ) | |
1035 | ioset(TYADDR, offset, addrof(cpexpr(p)) ); | |
1036 | else | |
1037 | errstr("impossible inquire parameter %s", ioc[i].iocname); | |
1038 | else | |
1039 | ioset(TYADDR, offset, ICON(0) ); | |
1040 | } | |
1041 | ||
1042 | ||
1043 | ||
1044 | LOCAL iosetlc(i, offp, offl) | |
1045 | int i, offp, offl; | |
1046 | { | |
1047 | register expptr p; | |
1048 | if( (p = V(i)) && p->headblock.vtype==TYCHAR) | |
1049 | ioset(TYIOINT, offl, cpexpr(p->headblock.vleng) ); | |
1050 | iosetc(offp, p); | |
1051 | } | |
1052 | ||
1053 | ||
1054 | LOCAL offsetlist * | |
1055 | mkiodata(blkno, offset, len) | |
1056 | int blkno; | |
1057 | ftnint offset; | |
1058 | ftnint len; | |
1059 | { | |
1060 | register offsetlist *p, *q; | |
1061 | register ioblock *t; | |
1062 | register int found; | |
1063 | ||
1064 | found = NO; | |
1065 | t = iodata; | |
1066 | ||
1067 | while (found == NO && t != NULL) | |
1068 | { | |
1069 | if (t->blkno == blkno) | |
1070 | found = YES; | |
1071 | else | |
1072 | t = t->next; | |
1073 | } | |
1074 | ||
1075 | if (found == NO) | |
1076 | { | |
1077 | t = ALLOC(IoBlock); | |
1078 | t->blkno = blkno; | |
1079 | t->next = iodata; | |
1080 | iodata = t; | |
1081 | } | |
1082 | ||
1083 | if (len > t->len) | |
1084 | t->len = len; | |
1085 | ||
1086 | p = t->olist; | |
1087 | ||
1088 | if (p == NULL) | |
1089 | { | |
1090 | p = ALLOC(OffsetList); | |
1091 | p->next = NULL; | |
1092 | p->offset = offset; | |
1093 | t->olist = p; | |
1094 | return (p); | |
1095 | } | |
1096 | ||
1097 | for (;;) | |
1098 | { | |
1099 | if (p->offset == offset) | |
1100 | return (p); | |
1101 | else if (p->next != NULL && | |
1102 | p->next->offset <= offset) | |
1103 | p = p->next; | |
1104 | else | |
1105 | { | |
1106 | q = ALLOC(OffsetList); | |
1107 | q->next = p->next; | |
1108 | p->next = q; | |
1109 | q->offset = offset; | |
1110 | return (q); | |
1111 | } | |
1112 | } | |
1113 | } | |
1114 | ||
1115 | ||
1116 | outiodata() | |
1117 | { | |
1118 | static char *varfmt = "v.%d:\n"; | |
1119 | ||
1120 | register ioblock *p; | |
1121 | register ioblock *t; | |
1122 | ||
1123 | if (iodata == NULL) return; | |
1124 | ||
1125 | p = iodata; | |
1126 | ||
1127 | while (p != NULL) | |
1128 | { | |
1129 | pralign(ALIDOUBLE); | |
1130 | fprintf(initfile, varfmt, p->blkno); | |
1131 | outolist(p->olist, p->len); | |
1132 | ||
1133 | t = p; | |
1134 | p = t->next; | |
1135 | free((char *) t); | |
1136 | } | |
1137 | ||
1138 | iodata = NULL; | |
1139 | return; | |
1140 | } | |
1141 | ||
1142 | ||
1143 | ||
1144 | LOCAL | |
1145 | outolist(op, len) | |
1146 | register offsetlist *op; | |
1147 | register int len; | |
1148 | { | |
1149 | static char *overlap = "overlapping i/o fields in outolist"; | |
1150 | static char *toolong = "offset too large in outolist"; | |
1151 | ||
1152 | register offsetlist *t; | |
1153 | register ftnint clen; | |
1154 | register Constp cp; | |
1155 | register int type; | |
1156 | ||
1157 | clen = 0; | |
1158 | ||
1159 | while (op != NULL) | |
1160 | { | |
1161 | if (clen > op->offset) | |
1162 | fatal(overlap); | |
1163 | ||
1164 | if (clen < op->offset) | |
1165 | { | |
1166 | prspace(op->offset - clen); | |
1167 | clen = op->offset; | |
1168 | } | |
1169 | ||
1170 | switch (op->tag) | |
1171 | { | |
1172 | default: | |
1173 | badtag("outolist", op->tag); | |
1174 | ||
1175 | case NDDATA: | |
1176 | cp = op->val.cp; | |
1177 | type = cp->vtype; | |
1178 | if (type != TYIOINT) | |
1179 | badtype("outolist", type); | |
1180 | prconi(initfile, type, cp->const.ci); | |
1181 | clen += typesize[type]; | |
1182 | frexpr((tagptr) cp); | |
1183 | break; | |
1184 | ||
1185 | case NDLABEL: | |
1186 | prcona(initfile, op->val.label); | |
1187 | clen += typesize[TYADDR]; | |
1188 | break; | |
1189 | ||
1190 | case NDADDR: | |
1191 | praddr(initfile, op->val.addr.stg, op->val.addr.memno, | |
1192 | op->val.addr.offset); | |
1193 | clen += typesize[TYADDR]; | |
1194 | break; | |
1195 | ||
1196 | case NDNULL: | |
1197 | praddr(initfile, STGNULL, 0, (ftnint) 0); | |
1198 | clen += typesize[TYADDR]; | |
1199 | break; | |
1200 | } | |
1201 | ||
1202 | t = op; | |
1203 | op = t->next; | |
1204 | free((char *) t); | |
1205 | } | |
1206 | ||
1207 | if (clen > len) | |
1208 | fatal(toolong); | |
1209 | ||
1210 | if (clen < len) | |
1211 | prspace(len - clen); | |
1212 | ||
1213 | return; | |
1214 | } |