Commit | Line | Data |
---|---|---|
f1525c23 WH |
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 | } |