Mercurial > hg > CbC > CbC_gcc
comparison libgfortran/io/transfer.c @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 /* Copyright (C) 2002-2017 Free Software Foundation, Inc. | |
2 Contributed by Andy Vaught | |
3 Namelist transfer functions contributed by Paul Thomas | |
4 F2003 I/O support contributed by Jerry DeLisle | |
5 | |
6 This file is part of the GNU Fortran runtime library (libgfortran). | |
7 | |
8 Libgfortran is free software; you can redistribute it and/or modify | |
9 it under the terms of the GNU General Public License as published by | |
10 the Free Software Foundation; either version 3, or (at your option) | |
11 any later version. | |
12 | |
13 Libgfortran is distributed in the hope that it will be useful, | |
14 but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 GNU General Public License for more details. | |
17 | |
18 Under Section 7 of GPL version 3, you are granted additional | |
19 permissions described in the GCC Runtime Library Exception, version | |
20 3.1, as published by the Free Software Foundation. | |
21 | |
22 You should have received a copy of the GNU General Public License and | |
23 a copy of the GCC Runtime Library Exception along with this program; | |
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
25 <http://www.gnu.org/licenses/>. */ | |
26 | |
27 | |
28 /* transfer.c -- Top level handling of data transfer statements. */ | |
29 | |
30 #include "io.h" | |
31 #include "fbuf.h" | |
32 #include "format.h" | |
33 #include "unix.h" | |
34 #include <string.h> | |
35 #include <errno.h> | |
36 | |
37 | |
38 /* Calling conventions: Data transfer statements are unlike other | |
39 library calls in that they extend over several calls. | |
40 | |
41 The first call is always a call to st_read() or st_write(). These | |
42 subroutines return no status unless a namelist read or write is | |
43 being done, in which case there is the usual status. No further | |
44 calls are necessary in this case. | |
45 | |
46 For other sorts of data transfer, there are zero or more data | |
47 transfer statement that depend on the format of the data transfer | |
48 statement. For READ (and for backwards compatibily: for WRITE), one has | |
49 | |
50 transfer_integer | |
51 transfer_logical | |
52 transfer_character | |
53 transfer_character_wide | |
54 transfer_real | |
55 transfer_complex | |
56 transfer_real128 | |
57 transfer_complex128 | |
58 | |
59 and for WRITE | |
60 | |
61 transfer_integer_write | |
62 transfer_logical_write | |
63 transfer_character_write | |
64 transfer_character_wide_write | |
65 transfer_real_write | |
66 transfer_complex_write | |
67 transfer_real128_write | |
68 transfer_complex128_write | |
69 | |
70 These subroutines do not return status. The *128 functions | |
71 are in the file transfer128.c. | |
72 | |
73 The last call is a call to st_[read|write]_done(). While | |
74 something can easily go wrong with the initial st_read() or | |
75 st_write(), an error inhibits any data from actually being | |
76 transferred. */ | |
77 | |
78 extern void transfer_integer (st_parameter_dt *, void *, int); | |
79 export_proto(transfer_integer); | |
80 | |
81 extern void transfer_integer_write (st_parameter_dt *, void *, int); | |
82 export_proto(transfer_integer_write); | |
83 | |
84 extern void transfer_real (st_parameter_dt *, void *, int); | |
85 export_proto(transfer_real); | |
86 | |
87 extern void transfer_real_write (st_parameter_dt *, void *, int); | |
88 export_proto(transfer_real_write); | |
89 | |
90 extern void transfer_logical (st_parameter_dt *, void *, int); | |
91 export_proto(transfer_logical); | |
92 | |
93 extern void transfer_logical_write (st_parameter_dt *, void *, int); | |
94 export_proto(transfer_logical_write); | |
95 | |
96 extern void transfer_character (st_parameter_dt *, void *, int); | |
97 export_proto(transfer_character); | |
98 | |
99 extern void transfer_character_write (st_parameter_dt *, void *, int); | |
100 export_proto(transfer_character_write); | |
101 | |
102 extern void transfer_character_wide (st_parameter_dt *, void *, int, int); | |
103 export_proto(transfer_character_wide); | |
104 | |
105 extern void transfer_character_wide_write (st_parameter_dt *, | |
106 void *, int, int); | |
107 export_proto(transfer_character_wide_write); | |
108 | |
109 extern void transfer_complex (st_parameter_dt *, void *, int); | |
110 export_proto(transfer_complex); | |
111 | |
112 extern void transfer_complex_write (st_parameter_dt *, void *, int); | |
113 export_proto(transfer_complex_write); | |
114 | |
115 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int, | |
116 gfc_charlen_type); | |
117 export_proto(transfer_array); | |
118 | |
119 extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int, | |
120 gfc_charlen_type); | |
121 export_proto(transfer_array_write); | |
122 | |
123 /* User defined derived type input/output. */ | |
124 extern void | |
125 transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc); | |
126 export_proto(transfer_derived); | |
127 | |
128 extern void | |
129 transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc); | |
130 export_proto(transfer_derived_write); | |
131 | |
132 static void us_read (st_parameter_dt *, int); | |
133 static void us_write (st_parameter_dt *, int); | |
134 static void next_record_r_unf (st_parameter_dt *, int); | |
135 static void next_record_w_unf (st_parameter_dt *, int); | |
136 | |
137 static const st_option advance_opt[] = { | |
138 {"yes", ADVANCE_YES}, | |
139 {"no", ADVANCE_NO}, | |
140 {NULL, 0} | |
141 }; | |
142 | |
143 | |
144 static const st_option decimal_opt[] = { | |
145 {"point", DECIMAL_POINT}, | |
146 {"comma", DECIMAL_COMMA}, | |
147 {NULL, 0} | |
148 }; | |
149 | |
150 static const st_option round_opt[] = { | |
151 {"up", ROUND_UP}, | |
152 {"down", ROUND_DOWN}, | |
153 {"zero", ROUND_ZERO}, | |
154 {"nearest", ROUND_NEAREST}, | |
155 {"compatible", ROUND_COMPATIBLE}, | |
156 {"processor_defined", ROUND_PROCDEFINED}, | |
157 {NULL, 0} | |
158 }; | |
159 | |
160 | |
161 static const st_option sign_opt[] = { | |
162 {"plus", SIGN_SP}, | |
163 {"suppress", SIGN_SS}, | |
164 {"processor_defined", SIGN_S}, | |
165 {NULL, 0} | |
166 }; | |
167 | |
168 static const st_option blank_opt[] = { | |
169 {"null", BLANK_NULL}, | |
170 {"zero", BLANK_ZERO}, | |
171 {NULL, 0} | |
172 }; | |
173 | |
174 static const st_option delim_opt[] = { | |
175 {"apostrophe", DELIM_APOSTROPHE}, | |
176 {"quote", DELIM_QUOTE}, | |
177 {"none", DELIM_NONE}, | |
178 {NULL, 0} | |
179 }; | |
180 | |
181 static const st_option pad_opt[] = { | |
182 {"yes", PAD_YES}, | |
183 {"no", PAD_NO}, | |
184 {NULL, 0} | |
185 }; | |
186 | |
187 typedef enum | |
188 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL, | |
189 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM | |
190 } | |
191 file_mode; | |
192 | |
193 | |
194 static file_mode | |
195 current_mode (st_parameter_dt *dtp) | |
196 { | |
197 file_mode m; | |
198 | |
199 m = FORM_UNSPECIFIED; | |
200 | |
201 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) | |
202 { | |
203 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? | |
204 FORMATTED_DIRECT : UNFORMATTED_DIRECT; | |
205 } | |
206 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
207 { | |
208 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? | |
209 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL; | |
210 } | |
211 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) | |
212 { | |
213 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ? | |
214 FORMATTED_STREAM : UNFORMATTED_STREAM; | |
215 } | |
216 | |
217 return m; | |
218 } | |
219 | |
220 | |
221 /* Mid level data transfer statements. */ | |
222 | |
223 /* Read sequential file - internal unit */ | |
224 | |
225 static char * | |
226 read_sf_internal (st_parameter_dt *dtp, int *length) | |
227 { | |
228 static char *empty_string[0]; | |
229 char *base = NULL; | |
230 int lorig; | |
231 | |
232 /* Zero size array gives internal unit len of 0. Nothing to read. */ | |
233 if (dtp->internal_unit_len == 0 | |
234 && dtp->u.p.current_unit->pad_status == PAD_NO) | |
235 hit_eof (dtp); | |
236 | |
237 /* If we have seen an eor previously, return a length of 0. The | |
238 caller is responsible for correctly padding the input field. */ | |
239 if (dtp->u.p.sf_seen_eor) | |
240 { | |
241 *length = 0; | |
242 /* Just return something that isn't a NULL pointer, otherwise the | |
243 caller thinks an error occurred. */ | |
244 return (char*) empty_string; | |
245 } | |
246 | |
247 /* There are some cases with mixed DTIO where we have read a character | |
248 and saved it in the last character buffer, so we need to backup. */ | |
249 if (unlikely (dtp->u.p.current_unit->child_dtio > 0 && | |
250 dtp->u.p.current_unit->last_char != EOF - 1)) | |
251 { | |
252 dtp->u.p.current_unit->last_char = EOF - 1; | |
253 sseek (dtp->u.p.current_unit->s, -1, SEEK_CUR); | |
254 } | |
255 | |
256 lorig = *length; | |
257 if (is_char4_unit(dtp)) | |
258 { | |
259 int i; | |
260 gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, | |
261 length); | |
262 base = fbuf_alloc (dtp->u.p.current_unit, lorig); | |
263 for (i = 0; i < *length; i++, p++) | |
264 base[i] = *p > 255 ? '?' : (unsigned char) *p; | |
265 } | |
266 else | |
267 base = mem_alloc_r (dtp->u.p.current_unit->s, length); | |
268 | |
269 if (unlikely (lorig > *length)) | |
270 { | |
271 hit_eof (dtp); | |
272 return NULL; | |
273 } | |
274 | |
275 dtp->u.p.current_unit->bytes_left -= *length; | |
276 | |
277 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || | |
278 dtp->u.p.current_unit->has_size) | |
279 dtp->u.p.current_unit->size_used += (GFC_IO_INT) *length; | |
280 | |
281 return base; | |
282 | |
283 } | |
284 | |
285 /* When reading sequential formatted records we have a problem. We | |
286 don't know how long the line is until we read the trailing newline, | |
287 and we don't want to read too much. If we read too much, we might | |
288 have to do a physical seek backwards depending on how much data is | |
289 present, and devices like terminals aren't seekable and would cause | |
290 an I/O error. | |
291 | |
292 Given this, the solution is to read a byte at a time, stopping if | |
293 we hit the newline. For small allocations, we use a static buffer. | |
294 For larger allocations, we are forced to allocate memory on the | |
295 heap. Hopefully this won't happen very often. */ | |
296 | |
297 /* Read sequential file - external unit */ | |
298 | |
299 static char * | |
300 read_sf (st_parameter_dt *dtp, int *length) | |
301 { | |
302 static char *empty_string[0]; | |
303 int q, q2; | |
304 int n, lorig, seen_comma; | |
305 | |
306 /* If we have seen an eor previously, return a length of 0. The | |
307 caller is responsible for correctly padding the input field. */ | |
308 if (dtp->u.p.sf_seen_eor) | |
309 { | |
310 *length = 0; | |
311 /* Just return something that isn't a NULL pointer, otherwise the | |
312 caller thinks an error occurred. */ | |
313 return (char*) empty_string; | |
314 } | |
315 | |
316 /* There are some cases with mixed DTIO where we have read a character | |
317 and saved it in the last character buffer, so we need to backup. */ | |
318 if (unlikely (dtp->u.p.current_unit->child_dtio > 0 && | |
319 dtp->u.p.current_unit->last_char != EOF - 1)) | |
320 { | |
321 dtp->u.p.current_unit->last_char = EOF - 1; | |
322 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR); | |
323 } | |
324 | |
325 n = seen_comma = 0; | |
326 | |
327 /* Read data into format buffer and scan through it. */ | |
328 lorig = *length; | |
329 | |
330 while (n < *length) | |
331 { | |
332 q = fbuf_getc (dtp->u.p.current_unit); | |
333 if (q == EOF) | |
334 break; | |
335 else if (dtp->u.p.current_unit->flags.cc != CC_NONE | |
336 && (q == '\n' || q == '\r')) | |
337 { | |
338 /* Unexpected end of line. Set the position. */ | |
339 dtp->u.p.sf_seen_eor = 1; | |
340 | |
341 /* If we see an EOR during non-advancing I/O, we need to skip | |
342 the rest of the I/O statement. Set the corresponding flag. */ | |
343 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar) | |
344 dtp->u.p.eor_condition = 1; | |
345 | |
346 /* If we encounter a CR, it might be a CRLF. */ | |
347 if (q == '\r') /* Probably a CRLF */ | |
348 { | |
349 /* See if there is an LF. */ | |
350 q2 = fbuf_getc (dtp->u.p.current_unit); | |
351 if (q2 == '\n') | |
352 dtp->u.p.sf_seen_eor = 2; | |
353 else if (q2 != EOF) /* Oops, seek back. */ | |
354 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR); | |
355 } | |
356 | |
357 /* Without padding, terminate the I/O statement without assigning | |
358 the value. With padding, the value still needs to be assigned, | |
359 so we can just continue with a short read. */ | |
360 if (dtp->u.p.current_unit->pad_status == PAD_NO) | |
361 { | |
362 generate_error (&dtp->common, LIBERROR_EOR, NULL); | |
363 return NULL; | |
364 } | |
365 | |
366 *length = n; | |
367 goto done; | |
368 } | |
369 /* Short circuit the read if a comma is found during numeric input. | |
370 The flag is set to zero during character reads so that commas in | |
371 strings are not ignored */ | |
372 else if (q == ',') | |
373 if (dtp->u.p.sf_read_comma == 1) | |
374 { | |
375 seen_comma = 1; | |
376 notify_std (&dtp->common, GFC_STD_GNU, | |
377 "Comma in formatted numeric read."); | |
378 break; | |
379 } | |
380 n++; | |
381 } | |
382 | |
383 *length = n; | |
384 | |
385 /* A short read implies we hit EOF, unless we hit EOR, a comma, or | |
386 some other stuff. Set the relevant flags. */ | |
387 if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma) | |
388 { | |
389 if (n > 0) | |
390 { | |
391 if (dtp->u.p.advance_status == ADVANCE_NO) | |
392 { | |
393 if (dtp->u.p.current_unit->pad_status == PAD_NO) | |
394 { | |
395 hit_eof (dtp); | |
396 return NULL; | |
397 } | |
398 else | |
399 dtp->u.p.eor_condition = 1; | |
400 } | |
401 else | |
402 dtp->u.p.at_eof = 1; | |
403 } | |
404 else if (dtp->u.p.advance_status == ADVANCE_NO | |
405 || dtp->u.p.current_unit->pad_status == PAD_NO | |
406 || dtp->u.p.current_unit->bytes_left | |
407 == dtp->u.p.current_unit->recl) | |
408 { | |
409 hit_eof (dtp); | |
410 return NULL; | |
411 } | |
412 } | |
413 | |
414 done: | |
415 | |
416 dtp->u.p.current_unit->bytes_left -= n; | |
417 | |
418 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || | |
419 dtp->u.p.current_unit->has_size) | |
420 dtp->u.p.current_unit->size_used += (GFC_IO_INT) n; | |
421 | |
422 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because | |
423 fbuf_getc might reallocate the buffer. So return current pointer | |
424 minus all the advances, which is n plus up to two characters | |
425 of newline or comma. */ | |
426 return fbuf_getptr (dtp->u.p.current_unit) | |
427 - n - dtp->u.p.sf_seen_eor - seen_comma; | |
428 } | |
429 | |
430 | |
431 /* Function for reading the next couple of bytes from the current | |
432 file, advancing the current position. We return NULL on end of record or | |
433 end of file. This function is only for formatted I/O, unformatted uses | |
434 read_block_direct. | |
435 | |
436 If the read is short, then it is because the current record does not | |
437 have enough data to satisfy the read request and the file was | |
438 opened with PAD=YES. The caller must assume tailing spaces for | |
439 short reads. */ | |
440 | |
441 void * | |
442 read_block_form (st_parameter_dt *dtp, int *nbytes) | |
443 { | |
444 char *source; | |
445 int norig; | |
446 | |
447 if (!is_stream_io (dtp)) | |
448 { | |
449 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) | |
450 { | |
451 /* For preconnected units with default record length, set bytes left | |
452 to unit record length and proceed, otherwise error. */ | |
453 if (dtp->u.p.current_unit->unit_number == options.stdin_unit | |
454 && dtp->u.p.current_unit->recl == DEFAULT_RECL) | |
455 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
456 else | |
457 { | |
458 if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO) | |
459 && !is_internal_unit (dtp)) | |
460 { | |
461 /* Not enough data left. */ | |
462 generate_error (&dtp->common, LIBERROR_EOR, NULL); | |
463 return NULL; | |
464 } | |
465 } | |
466 | |
467 if (is_internal_unit(dtp)) | |
468 { | |
469 if (*nbytes > 0 && dtp->u.p.current_unit->bytes_left == 0) | |
470 { | |
471 if (dtp->u.p.advance_status == ADVANCE_NO) | |
472 { | |
473 generate_error (&dtp->common, LIBERROR_EOR, NULL); | |
474 return NULL; | |
475 } | |
476 } | |
477 } | |
478 else | |
479 { | |
480 if (unlikely (dtp->u.p.current_unit->bytes_left == 0)) | |
481 { | |
482 hit_eof (dtp); | |
483 return NULL; | |
484 } | |
485 } | |
486 | |
487 *nbytes = dtp->u.p.current_unit->bytes_left; | |
488 } | |
489 } | |
490 | |
491 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && | |
492 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL || | |
493 dtp->u.p.current_unit->flags.access == ACCESS_STREAM)) | |
494 { | |
495 if (is_internal_unit (dtp)) | |
496 source = read_sf_internal (dtp, nbytes); | |
497 else | |
498 source = read_sf (dtp, nbytes); | |
499 | |
500 dtp->u.p.current_unit->strm_pos += | |
501 (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor); | |
502 return source; | |
503 } | |
504 | |
505 /* If we reach here, we can assume it's direct access. */ | |
506 | |
507 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes; | |
508 | |
509 norig = *nbytes; | |
510 source = fbuf_read (dtp->u.p.current_unit, nbytes); | |
511 fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR); | |
512 | |
513 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || | |
514 dtp->u.p.current_unit->has_size) | |
515 dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes; | |
516 | |
517 if (norig != *nbytes) | |
518 { | |
519 /* Short read, this shouldn't happen. */ | |
520 if (dtp->u.p.current_unit->pad_status == PAD_NO) | |
521 { | |
522 generate_error (&dtp->common, LIBERROR_EOR, NULL); | |
523 source = NULL; | |
524 } | |
525 } | |
526 | |
527 dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes; | |
528 | |
529 return source; | |
530 } | |
531 | |
532 | |
533 /* Read a block from a character(kind=4) internal unit, to be transferred into | |
534 a character(kind=4) variable. Note: Portions of this code borrowed from | |
535 read_sf_internal. */ | |
536 void * | |
537 read_block_form4 (st_parameter_dt *dtp, int *nbytes) | |
538 { | |
539 static gfc_char4_t *empty_string[0]; | |
540 gfc_char4_t *source; | |
541 int lorig; | |
542 | |
543 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes) | |
544 *nbytes = dtp->u.p.current_unit->bytes_left; | |
545 | |
546 /* Zero size array gives internal unit len of 0. Nothing to read. */ | |
547 if (dtp->internal_unit_len == 0 | |
548 && dtp->u.p.current_unit->pad_status == PAD_NO) | |
549 hit_eof (dtp); | |
550 | |
551 /* If we have seen an eor previously, return a length of 0. The | |
552 caller is responsible for correctly padding the input field. */ | |
553 if (dtp->u.p.sf_seen_eor) | |
554 { | |
555 *nbytes = 0; | |
556 /* Just return something that isn't a NULL pointer, otherwise the | |
557 caller thinks an error occurred. */ | |
558 return empty_string; | |
559 } | |
560 | |
561 lorig = *nbytes; | |
562 source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes); | |
563 | |
564 if (unlikely (lorig > *nbytes)) | |
565 { | |
566 hit_eof (dtp); | |
567 return NULL; | |
568 } | |
569 | |
570 dtp->u.p.current_unit->bytes_left -= *nbytes; | |
571 | |
572 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || | |
573 dtp->u.p.current_unit->has_size) | |
574 dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes; | |
575 | |
576 return source; | |
577 } | |
578 | |
579 | |
580 /* Reads a block directly into application data space. This is for | |
581 unformatted files. */ | |
582 | |
583 static void | |
584 read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes) | |
585 { | |
586 ssize_t to_read_record; | |
587 ssize_t have_read_record; | |
588 ssize_t to_read_subrecord; | |
589 ssize_t have_read_subrecord; | |
590 int short_record; | |
591 | |
592 if (is_stream_io (dtp)) | |
593 { | |
594 have_read_record = sread (dtp->u.p.current_unit->s, buf, | |
595 nbytes); | |
596 if (unlikely (have_read_record < 0)) | |
597 { | |
598 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
599 return; | |
600 } | |
601 | |
602 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record; | |
603 | |
604 if (unlikely ((ssize_t) nbytes != have_read_record)) | |
605 { | |
606 /* Short read, e.g. if we hit EOF. For stream files, | |
607 we have to set the end-of-file condition. */ | |
608 hit_eof (dtp); | |
609 } | |
610 return; | |
611 } | |
612 | |
613 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) | |
614 { | |
615 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes) | |
616 { | |
617 short_record = 1; | |
618 to_read_record = dtp->u.p.current_unit->bytes_left; | |
619 nbytes = to_read_record; | |
620 } | |
621 else | |
622 { | |
623 short_record = 0; | |
624 to_read_record = nbytes; | |
625 } | |
626 | |
627 dtp->u.p.current_unit->bytes_left -= to_read_record; | |
628 | |
629 to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record); | |
630 if (unlikely (to_read_record < 0)) | |
631 { | |
632 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
633 return; | |
634 } | |
635 | |
636 if (to_read_record != (ssize_t) nbytes) | |
637 { | |
638 /* Short read, e.g. if we hit EOF. Apparently, we read | |
639 more than was written to the last record. */ | |
640 return; | |
641 } | |
642 | |
643 if (unlikely (short_record)) | |
644 { | |
645 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); | |
646 } | |
647 return; | |
648 } | |
649 | |
650 /* Unformatted sequential. We loop over the subrecords, reading | |
651 until the request has been fulfilled or the record has run out | |
652 of continuation subrecords. */ | |
653 | |
654 /* Check whether we exceed the total record length. */ | |
655 | |
656 if (dtp->u.p.current_unit->flags.has_recl | |
657 && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)) | |
658 { | |
659 to_read_record = dtp->u.p.current_unit->bytes_left; | |
660 short_record = 1; | |
661 } | |
662 else | |
663 { | |
664 to_read_record = nbytes; | |
665 short_record = 0; | |
666 } | |
667 have_read_record = 0; | |
668 | |
669 while(1) | |
670 { | |
671 if (dtp->u.p.current_unit->bytes_left_subrecord | |
672 < (gfc_offset) to_read_record) | |
673 { | |
674 to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord; | |
675 to_read_record -= to_read_subrecord; | |
676 } | |
677 else | |
678 { | |
679 to_read_subrecord = to_read_record; | |
680 to_read_record = 0; | |
681 } | |
682 | |
683 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord; | |
684 | |
685 have_read_subrecord = sread (dtp->u.p.current_unit->s, | |
686 buf + have_read_record, to_read_subrecord); | |
687 if (unlikely (have_read_subrecord < 0)) | |
688 { | |
689 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
690 return; | |
691 } | |
692 | |
693 have_read_record += have_read_subrecord; | |
694 | |
695 if (unlikely (to_read_subrecord != have_read_subrecord)) | |
696 { | |
697 /* Short read, e.g. if we hit EOF. This means the record | |
698 structure has been corrupted, or the trailing record | |
699 marker would still be present. */ | |
700 | |
701 generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL); | |
702 return; | |
703 } | |
704 | |
705 if (to_read_record > 0) | |
706 { | |
707 if (likely (dtp->u.p.current_unit->continued)) | |
708 { | |
709 next_record_r_unf (dtp, 0); | |
710 us_read (dtp, 1); | |
711 } | |
712 else | |
713 { | |
714 /* Let's make sure the file position is correctly pre-positioned | |
715 for the next read statement. */ | |
716 | |
717 dtp->u.p.current_unit->current_record = 0; | |
718 next_record_r_unf (dtp, 0); | |
719 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); | |
720 return; | |
721 } | |
722 } | |
723 else | |
724 { | |
725 /* Normal exit, the read request has been fulfilled. */ | |
726 break; | |
727 } | |
728 } | |
729 | |
730 dtp->u.p.current_unit->bytes_left -= have_read_record; | |
731 if (unlikely (short_record)) | |
732 { | |
733 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); | |
734 return; | |
735 } | |
736 return; | |
737 } | |
738 | |
739 | |
740 /* Function for writing a block of bytes to the current file at the | |
741 current position, advancing the file pointer. We are given a length | |
742 and return a pointer to a buffer that the caller must (completely) | |
743 fill in. Returns NULL on error. */ | |
744 | |
745 void * | |
746 write_block (st_parameter_dt *dtp, int length) | |
747 { | |
748 char *dest; | |
749 | |
750 if (!is_stream_io (dtp)) | |
751 { | |
752 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length) | |
753 { | |
754 /* For preconnected units with default record length, set bytes left | |
755 to unit record length and proceed, otherwise error. */ | |
756 if (likely ((dtp->u.p.current_unit->unit_number | |
757 == options.stdout_unit | |
758 || dtp->u.p.current_unit->unit_number | |
759 == options.stderr_unit) | |
760 && dtp->u.p.current_unit->recl == DEFAULT_RECL)) | |
761 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
762 else | |
763 { | |
764 generate_error (&dtp->common, LIBERROR_EOR, NULL); | |
765 return NULL; | |
766 } | |
767 } | |
768 | |
769 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length; | |
770 } | |
771 | |
772 if (is_internal_unit (dtp)) | |
773 { | |
774 if (is_char4_unit(dtp)) /* char4 internel unit. */ | |
775 { | |
776 gfc_char4_t *dest4; | |
777 dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length); | |
778 if (dest4 == NULL) | |
779 { | |
780 generate_error (&dtp->common, LIBERROR_END, NULL); | |
781 return NULL; | |
782 } | |
783 return dest4; | |
784 } | |
785 else | |
786 dest = mem_alloc_w (dtp->u.p.current_unit->s, &length); | |
787 | |
788 if (dest == NULL) | |
789 { | |
790 generate_error (&dtp->common, LIBERROR_END, NULL); | |
791 return NULL; | |
792 } | |
793 | |
794 if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE)) | |
795 generate_error (&dtp->common, LIBERROR_END, NULL); | |
796 } | |
797 else | |
798 { | |
799 dest = fbuf_alloc (dtp->u.p.current_unit, length); | |
800 if (dest == NULL) | |
801 { | |
802 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
803 return NULL; | |
804 } | |
805 } | |
806 | |
807 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) || | |
808 dtp->u.p.current_unit->has_size) | |
809 dtp->u.p.current_unit->size_used += (GFC_IO_INT) length; | |
810 | |
811 dtp->u.p.current_unit->strm_pos += (gfc_offset) length; | |
812 | |
813 return dest; | |
814 } | |
815 | |
816 | |
817 /* High level interface to swrite(), taking care of errors. This is only | |
818 called for unformatted files. There are three cases to consider: | |
819 Stream I/O, unformatted direct, unformatted sequential. */ | |
820 | |
821 static bool | |
822 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes) | |
823 { | |
824 | |
825 ssize_t have_written; | |
826 ssize_t to_write_subrecord; | |
827 int short_record; | |
828 | |
829 /* Stream I/O. */ | |
830 | |
831 if (is_stream_io (dtp)) | |
832 { | |
833 have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); | |
834 if (unlikely (have_written < 0)) | |
835 { | |
836 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
837 return false; | |
838 } | |
839 | |
840 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; | |
841 | |
842 return true; | |
843 } | |
844 | |
845 /* Unformatted direct access. */ | |
846 | |
847 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) | |
848 { | |
849 if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)) | |
850 { | |
851 generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL); | |
852 return false; | |
853 } | |
854 | |
855 if (buf == NULL && nbytes == 0) | |
856 return true; | |
857 | |
858 have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes); | |
859 if (unlikely (have_written < 0)) | |
860 { | |
861 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
862 return false; | |
863 } | |
864 | |
865 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written; | |
866 dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written; | |
867 | |
868 return true; | |
869 } | |
870 | |
871 /* Unformatted sequential. */ | |
872 | |
873 have_written = 0; | |
874 | |
875 if (dtp->u.p.current_unit->flags.has_recl | |
876 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left) | |
877 { | |
878 nbytes = dtp->u.p.current_unit->bytes_left; | |
879 short_record = 1; | |
880 } | |
881 else | |
882 { | |
883 short_record = 0; | |
884 } | |
885 | |
886 while (1) | |
887 { | |
888 | |
889 to_write_subrecord = | |
890 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ? | |
891 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes; | |
892 | |
893 dtp->u.p.current_unit->bytes_left_subrecord -= | |
894 (gfc_offset) to_write_subrecord; | |
895 | |
896 to_write_subrecord = swrite (dtp->u.p.current_unit->s, | |
897 buf + have_written, to_write_subrecord); | |
898 if (unlikely (to_write_subrecord < 0)) | |
899 { | |
900 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
901 return false; | |
902 } | |
903 | |
904 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord; | |
905 nbytes -= to_write_subrecord; | |
906 have_written += to_write_subrecord; | |
907 | |
908 if (nbytes == 0) | |
909 break; | |
910 | |
911 next_record_w_unf (dtp, 1); | |
912 us_write (dtp, 1); | |
913 } | |
914 dtp->u.p.current_unit->bytes_left -= have_written; | |
915 if (unlikely (short_record)) | |
916 { | |
917 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL); | |
918 return false; | |
919 } | |
920 return true; | |
921 } | |
922 | |
923 | |
924 /* Reverse memcpy - used for byte swapping. */ | |
925 | |
926 static void | |
927 reverse_memcpy (void *dest, const void *src, size_t n) | |
928 { | |
929 char *d, *s; | |
930 size_t i; | |
931 | |
932 d = (char *) dest; | |
933 s = (char *) src + n - 1; | |
934 | |
935 /* Write with ascending order - this is likely faster | |
936 on modern architectures because of write combining. */ | |
937 for (i=0; i<n; i++) | |
938 *(d++) = *(s--); | |
939 } | |
940 | |
941 | |
942 /* Utility function for byteswapping an array, using the bswap | |
943 builtins if possible. dest and src can overlap completely, or then | |
944 they must point to separate objects; partial overlaps are not | |
945 allowed. */ | |
946 | |
947 static void | |
948 bswap_array (void *dest, const void *src, size_t size, size_t nelems) | |
949 { | |
950 const char *ps; | |
951 char *pd; | |
952 | |
953 switch (size) | |
954 { | |
955 case 1: | |
956 break; | |
957 case 2: | |
958 for (size_t i = 0; i < nelems; i++) | |
959 ((uint16_t*)dest)[i] = __builtin_bswap16 (((uint16_t*)src)[i]); | |
960 break; | |
961 case 4: | |
962 for (size_t i = 0; i < nelems; i++) | |
963 ((uint32_t*)dest)[i] = __builtin_bswap32 (((uint32_t*)src)[i]); | |
964 break; | |
965 case 8: | |
966 for (size_t i = 0; i < nelems; i++) | |
967 ((uint64_t*)dest)[i] = __builtin_bswap64 (((uint64_t*)src)[i]); | |
968 break; | |
969 case 12: | |
970 ps = src; | |
971 pd = dest; | |
972 for (size_t i = 0; i < nelems; i++) | |
973 { | |
974 uint32_t tmp; | |
975 memcpy (&tmp, ps, 4); | |
976 *(uint32_t*)pd = __builtin_bswap32 (*(uint32_t*)(ps + 8)); | |
977 *(uint32_t*)(pd + 4) = __builtin_bswap32 (*(uint32_t*)(ps + 4)); | |
978 *(uint32_t*)(pd + 8) = __builtin_bswap32 (tmp); | |
979 ps += size; | |
980 pd += size; | |
981 } | |
982 break; | |
983 case 16: | |
984 ps = src; | |
985 pd = dest; | |
986 for (size_t i = 0; i < nelems; i++) | |
987 { | |
988 uint64_t tmp; | |
989 memcpy (&tmp, ps, 8); | |
990 *(uint64_t*)pd = __builtin_bswap64 (*(uint64_t*)(ps + 8)); | |
991 *(uint64_t*)(pd + 8) = __builtin_bswap64 (tmp); | |
992 ps += size; | |
993 pd += size; | |
994 } | |
995 break; | |
996 default: | |
997 pd = dest; | |
998 if (dest != src) | |
999 { | |
1000 ps = src; | |
1001 for (size_t i = 0; i < nelems; i++) | |
1002 { | |
1003 reverse_memcpy (pd, ps, size); | |
1004 ps += size; | |
1005 pd += size; | |
1006 } | |
1007 } | |
1008 else | |
1009 { | |
1010 /* In-place byte swap. */ | |
1011 for (size_t i = 0; i < nelems; i++) | |
1012 { | |
1013 char tmp, *low = pd, *high = pd + size - 1; | |
1014 for (size_t j = 0; j < size/2; j++) | |
1015 { | |
1016 tmp = *low; | |
1017 *low = *high; | |
1018 *high = tmp; | |
1019 low++; | |
1020 high--; | |
1021 } | |
1022 pd += size; | |
1023 } | |
1024 } | |
1025 } | |
1026 } | |
1027 | |
1028 | |
1029 /* Master function for unformatted reads. */ | |
1030 | |
1031 static void | |
1032 unformatted_read (st_parameter_dt *dtp, bt type, | |
1033 void *dest, int kind, size_t size, size_t nelems) | |
1034 { | |
1035 if (type == BT_CLASS) | |
1036 { | |
1037 int unit = dtp->u.p.current_unit->unit_number; | |
1038 char tmp_iomsg[IOMSG_LEN] = ""; | |
1039 char *child_iomsg; | |
1040 gfc_charlen_type child_iomsg_len; | |
1041 int noiostat; | |
1042 int *child_iostat = NULL; | |
1043 | |
1044 /* Set iostat, intent(out). */ | |
1045 noiostat = 0; | |
1046 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? | |
1047 dtp->common.iostat : &noiostat; | |
1048 | |
1049 /* Set iomsg, intent(inout). */ | |
1050 if (dtp->common.flags & IOPARM_HAS_IOMSG) | |
1051 { | |
1052 child_iomsg = dtp->common.iomsg; | |
1053 child_iomsg_len = dtp->common.iomsg_len; | |
1054 } | |
1055 else | |
1056 { | |
1057 child_iomsg = tmp_iomsg; | |
1058 child_iomsg_len = IOMSG_LEN; | |
1059 } | |
1060 | |
1061 /* Call the user defined unformatted READ procedure. */ | |
1062 dtp->u.p.current_unit->child_dtio++; | |
1063 dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg, | |
1064 child_iomsg_len); | |
1065 dtp->u.p.current_unit->child_dtio--; | |
1066 return; | |
1067 } | |
1068 | |
1069 if (type == BT_CHARACTER) | |
1070 size *= GFC_SIZE_OF_CHAR_KIND(kind); | |
1071 read_block_direct (dtp, dest, size * nelems); | |
1072 | |
1073 if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP) | |
1074 && kind != 1) | |
1075 { | |
1076 /* Handle wide chracters. */ | |
1077 if (type == BT_CHARACTER) | |
1078 { | |
1079 nelems *= size; | |
1080 size = kind; | |
1081 } | |
1082 | |
1083 /* Break up complex into its constituent reals. */ | |
1084 else if (type == BT_COMPLEX) | |
1085 { | |
1086 nelems *= 2; | |
1087 size /= 2; | |
1088 } | |
1089 bswap_array (dest, dest, size, nelems); | |
1090 } | |
1091 } | |
1092 | |
1093 | |
1094 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16 | |
1095 bytes on 64 bit machines. The unused bytes are not initialized and never | |
1096 used, which can show an error with memory checking analyzers like | |
1097 valgrind. We us BT_CLASS to denote a User Defined I/O call. */ | |
1098 | |
1099 static void | |
1100 unformatted_write (st_parameter_dt *dtp, bt type, | |
1101 void *source, int kind, size_t size, size_t nelems) | |
1102 { | |
1103 if (type == BT_CLASS) | |
1104 { | |
1105 int unit = dtp->u.p.current_unit->unit_number; | |
1106 char tmp_iomsg[IOMSG_LEN] = ""; | |
1107 char *child_iomsg; | |
1108 gfc_charlen_type child_iomsg_len; | |
1109 int noiostat; | |
1110 int *child_iostat = NULL; | |
1111 | |
1112 /* Set iostat, intent(out). */ | |
1113 noiostat = 0; | |
1114 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? | |
1115 dtp->common.iostat : &noiostat; | |
1116 | |
1117 /* Set iomsg, intent(inout). */ | |
1118 if (dtp->common.flags & IOPARM_HAS_IOMSG) | |
1119 { | |
1120 child_iomsg = dtp->common.iomsg; | |
1121 child_iomsg_len = dtp->common.iomsg_len; | |
1122 } | |
1123 else | |
1124 { | |
1125 child_iomsg = tmp_iomsg; | |
1126 child_iomsg_len = IOMSG_LEN; | |
1127 } | |
1128 | |
1129 /* Call the user defined unformatted WRITE procedure. */ | |
1130 dtp->u.p.current_unit->child_dtio++; | |
1131 dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg, | |
1132 child_iomsg_len); | |
1133 dtp->u.p.current_unit->child_dtio--; | |
1134 return; | |
1135 } | |
1136 | |
1137 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE) | |
1138 || kind == 1) | |
1139 { | |
1140 size_t stride = type == BT_CHARACTER ? | |
1141 size * GFC_SIZE_OF_CHAR_KIND(kind) : size; | |
1142 | |
1143 write_buf (dtp, source, stride * nelems); | |
1144 } | |
1145 else | |
1146 { | |
1147 #define BSWAP_BUFSZ 512 | |
1148 char buffer[BSWAP_BUFSZ]; | |
1149 char *p; | |
1150 size_t nrem; | |
1151 | |
1152 p = source; | |
1153 | |
1154 /* Handle wide chracters. */ | |
1155 if (type == BT_CHARACTER && kind != 1) | |
1156 { | |
1157 nelems *= size; | |
1158 size = kind; | |
1159 } | |
1160 | |
1161 /* Break up complex into its constituent reals. */ | |
1162 if (type == BT_COMPLEX) | |
1163 { | |
1164 nelems *= 2; | |
1165 size /= 2; | |
1166 } | |
1167 | |
1168 /* By now, all complex variables have been split into their | |
1169 constituent reals. */ | |
1170 | |
1171 nrem = nelems; | |
1172 do | |
1173 { | |
1174 size_t nc; | |
1175 if (size * nrem > BSWAP_BUFSZ) | |
1176 nc = BSWAP_BUFSZ / size; | |
1177 else | |
1178 nc = nrem; | |
1179 | |
1180 bswap_array (buffer, p, size, nc); | |
1181 write_buf (dtp, buffer, size * nc); | |
1182 p += size * nc; | |
1183 nrem -= nc; | |
1184 } | |
1185 while (nrem > 0); | |
1186 } | |
1187 } | |
1188 | |
1189 | |
1190 /* Return a pointer to the name of a type. */ | |
1191 | |
1192 const char * | |
1193 type_name (bt type) | |
1194 { | |
1195 const char *p; | |
1196 | |
1197 switch (type) | |
1198 { | |
1199 case BT_INTEGER: | |
1200 p = "INTEGER"; | |
1201 break; | |
1202 case BT_LOGICAL: | |
1203 p = "LOGICAL"; | |
1204 break; | |
1205 case BT_CHARACTER: | |
1206 p = "CHARACTER"; | |
1207 break; | |
1208 case BT_REAL: | |
1209 p = "REAL"; | |
1210 break; | |
1211 case BT_COMPLEX: | |
1212 p = "COMPLEX"; | |
1213 break; | |
1214 case BT_CLASS: | |
1215 p = "CLASS or DERIVED"; | |
1216 break; | |
1217 default: | |
1218 internal_error (NULL, "type_name(): Bad type"); | |
1219 } | |
1220 | |
1221 return p; | |
1222 } | |
1223 | |
1224 | |
1225 /* Write a constant string to the output. | |
1226 This is complicated because the string can have doubled delimiters | |
1227 in it. The length in the format node is the true length. */ | |
1228 | |
1229 static void | |
1230 write_constant_string (st_parameter_dt *dtp, const fnode *f) | |
1231 { | |
1232 char c, delimiter, *p, *q; | |
1233 int length; | |
1234 | |
1235 length = f->u.string.length; | |
1236 if (length == 0) | |
1237 return; | |
1238 | |
1239 p = write_block (dtp, length); | |
1240 if (p == NULL) | |
1241 return; | |
1242 | |
1243 q = f->u.string.p; | |
1244 delimiter = q[-1]; | |
1245 | |
1246 for (; length > 0; length--) | |
1247 { | |
1248 c = *p++ = *q++; | |
1249 if (c == delimiter && c != 'H' && c != 'h') | |
1250 q++; /* Skip the doubled delimiter. */ | |
1251 } | |
1252 } | |
1253 | |
1254 | |
1255 /* Given actual and expected types in a formatted data transfer, make | |
1256 sure they agree. If not, an error message is generated. Returns | |
1257 nonzero if something went wrong. */ | |
1258 | |
1259 static int | |
1260 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f) | |
1261 { | |
1262 #define BUFLEN 100 | |
1263 char buffer[BUFLEN]; | |
1264 | |
1265 if (actual == expected) | |
1266 return 0; | |
1267 | |
1268 /* Adjust item_count before emitting error message. */ | |
1269 snprintf (buffer, BUFLEN, | |
1270 "Expected %s for item %d in formatted transfer, got %s", | |
1271 type_name (expected), dtp->u.p.item_count - 1, type_name (actual)); | |
1272 | |
1273 format_error (dtp, f, buffer); | |
1274 return 1; | |
1275 } | |
1276 | |
1277 | |
1278 /* Check that the dtio procedure required for formatted IO is present. */ | |
1279 | |
1280 static int | |
1281 check_dtio_proc (st_parameter_dt *dtp, const fnode *f) | |
1282 { | |
1283 char buffer[BUFLEN]; | |
1284 | |
1285 if (dtp->u.p.fdtio_ptr != NULL) | |
1286 return 0; | |
1287 | |
1288 snprintf (buffer, BUFLEN, | |
1289 "Missing DTIO procedure or intrinsic type passed for item %d " | |
1290 "in formatted transfer", | |
1291 dtp->u.p.item_count - 1); | |
1292 | |
1293 format_error (dtp, f, buffer); | |
1294 return 1; | |
1295 } | |
1296 | |
1297 | |
1298 static int | |
1299 require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f) | |
1300 { | |
1301 #define BUFLEN 100 | |
1302 char buffer[BUFLEN]; | |
1303 | |
1304 if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX) | |
1305 return 0; | |
1306 | |
1307 /* Adjust item_count before emitting error message. */ | |
1308 snprintf (buffer, BUFLEN, | |
1309 "Expected numeric type for item %d in formatted transfer, got %s", | |
1310 dtp->u.p.item_count - 1, type_name (actual)); | |
1311 | |
1312 format_error (dtp, f, buffer); | |
1313 return 1; | |
1314 } | |
1315 | |
1316 static char * | |
1317 get_dt_format (char *p, gfc_charlen_type *length) | |
1318 { | |
1319 char delim = p[-1]; /* The delimiter is always the first character back. */ | |
1320 char c, *q, *res; | |
1321 gfc_charlen_type len = *length; /* This length already correct, less 'DT'. */ | |
1322 | |
1323 res = q = xmalloc (len + 2); | |
1324 | |
1325 /* Set the beginning of the string to 'DT', length adjusted below. */ | |
1326 *q++ = 'D'; | |
1327 *q++ = 'T'; | |
1328 | |
1329 /* The string may contain doubled quotes so scan and skip as needed. */ | |
1330 for (; len > 0; len--) | |
1331 { | |
1332 c = *q++ = *p++; | |
1333 if (c == delim) | |
1334 p++; /* Skip the doubled delimiter. */ | |
1335 } | |
1336 | |
1337 /* Adjust the string length by two now that we are done. */ | |
1338 *length += 2; | |
1339 | |
1340 return res; | |
1341 } | |
1342 | |
1343 | |
1344 /* This function is in the main loop for a formatted data transfer | |
1345 statement. It would be natural to implement this as a coroutine | |
1346 with the user program, but C makes that awkward. We loop, | |
1347 processing format elements. When we actually have to transfer | |
1348 data instead of just setting flags, we return control to the user | |
1349 program which calls a function that supplies the address and type | |
1350 of the next element, then comes back here to process it. */ | |
1351 | |
1352 static void | |
1353 formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind, | |
1354 size_t size) | |
1355 { | |
1356 int pos, bytes_used; | |
1357 const fnode *f; | |
1358 format_token t; | |
1359 int n; | |
1360 int consume_data_flag; | |
1361 | |
1362 /* Change a complex data item into a pair of reals. */ | |
1363 | |
1364 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); | |
1365 if (type == BT_COMPLEX) | |
1366 { | |
1367 type = BT_REAL; | |
1368 size /= 2; | |
1369 } | |
1370 | |
1371 /* If there's an EOR condition, we simulate finalizing the transfer | |
1372 by doing nothing. */ | |
1373 if (dtp->u.p.eor_condition) | |
1374 return; | |
1375 | |
1376 /* Set this flag so that commas in reads cause the read to complete before | |
1377 the entire field has been read. The next read field will start right after | |
1378 the comma in the stream. (Set to 0 for character reads). */ | |
1379 dtp->u.p.sf_read_comma = | |
1380 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; | |
1381 | |
1382 for (;;) | |
1383 { | |
1384 /* If reversion has occurred and there is another real data item, | |
1385 then we have to move to the next record. */ | |
1386 if (dtp->u.p.reversion_flag && n > 0) | |
1387 { | |
1388 dtp->u.p.reversion_flag = 0; | |
1389 next_record (dtp, 0); | |
1390 } | |
1391 | |
1392 consume_data_flag = 1; | |
1393 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
1394 break; | |
1395 | |
1396 f = next_format (dtp); | |
1397 if (f == NULL) | |
1398 { | |
1399 /* No data descriptors left. */ | |
1400 if (unlikely (n > 0)) | |
1401 generate_error (&dtp->common, LIBERROR_FORMAT, | |
1402 "Insufficient data descriptors in format after reversion"); | |
1403 return; | |
1404 } | |
1405 | |
1406 t = f->format; | |
1407 | |
1408 bytes_used = (int)(dtp->u.p.current_unit->recl | |
1409 - dtp->u.p.current_unit->bytes_left); | |
1410 | |
1411 if (is_stream_io(dtp)) | |
1412 bytes_used = 0; | |
1413 | |
1414 switch (t) | |
1415 { | |
1416 case FMT_I: | |
1417 if (n == 0) | |
1418 goto need_read_data; | |
1419 if (require_type (dtp, BT_INTEGER, type, f)) | |
1420 return; | |
1421 read_decimal (dtp, f, p, kind); | |
1422 break; | |
1423 | |
1424 case FMT_B: | |
1425 if (n == 0) | |
1426 goto need_read_data; | |
1427 if (!(compile_options.allow_std & GFC_STD_GNU) | |
1428 && require_numeric_type (dtp, type, f)) | |
1429 return; | |
1430 if (!(compile_options.allow_std & GFC_STD_F2008) | |
1431 && require_type (dtp, BT_INTEGER, type, f)) | |
1432 return; | |
1433 read_radix (dtp, f, p, kind, 2); | |
1434 break; | |
1435 | |
1436 case FMT_O: | |
1437 if (n == 0) | |
1438 goto need_read_data; | |
1439 if (!(compile_options.allow_std & GFC_STD_GNU) | |
1440 && require_numeric_type (dtp, type, f)) | |
1441 return; | |
1442 if (!(compile_options.allow_std & GFC_STD_F2008) | |
1443 && require_type (dtp, BT_INTEGER, type, f)) | |
1444 return; | |
1445 read_radix (dtp, f, p, kind, 8); | |
1446 break; | |
1447 | |
1448 case FMT_Z: | |
1449 if (n == 0) | |
1450 goto need_read_data; | |
1451 if (!(compile_options.allow_std & GFC_STD_GNU) | |
1452 && require_numeric_type (dtp, type, f)) | |
1453 return; | |
1454 if (!(compile_options.allow_std & GFC_STD_F2008) | |
1455 && require_type (dtp, BT_INTEGER, type, f)) | |
1456 return; | |
1457 read_radix (dtp, f, p, kind, 16); | |
1458 break; | |
1459 | |
1460 case FMT_A: | |
1461 if (n == 0) | |
1462 goto need_read_data; | |
1463 | |
1464 /* It is possible to have FMT_A with something not BT_CHARACTER such | |
1465 as when writing out hollerith strings, so check both type | |
1466 and kind before calling wide character routines. */ | |
1467 if (type == BT_CHARACTER && kind == 4) | |
1468 read_a_char4 (dtp, f, p, size); | |
1469 else | |
1470 read_a (dtp, f, p, size); | |
1471 break; | |
1472 | |
1473 case FMT_L: | |
1474 if (n == 0) | |
1475 goto need_read_data; | |
1476 read_l (dtp, f, p, kind); | |
1477 break; | |
1478 | |
1479 case FMT_D: | |
1480 if (n == 0) | |
1481 goto need_read_data; | |
1482 if (require_type (dtp, BT_REAL, type, f)) | |
1483 return; | |
1484 read_f (dtp, f, p, kind); | |
1485 break; | |
1486 | |
1487 case FMT_DT: | |
1488 if (n == 0) | |
1489 goto need_read_data; | |
1490 | |
1491 if (check_dtio_proc (dtp, f)) | |
1492 return; | |
1493 if (require_type (dtp, BT_CLASS, type, f)) | |
1494 return; | |
1495 int unit = dtp->u.p.current_unit->unit_number; | |
1496 char dt[] = "DT"; | |
1497 char tmp_iomsg[IOMSG_LEN] = ""; | |
1498 char *child_iomsg; | |
1499 gfc_charlen_type child_iomsg_len; | |
1500 int noiostat; | |
1501 int *child_iostat = NULL; | |
1502 char *iotype; | |
1503 gfc_charlen_type iotype_len = f->u.udf.string_len; | |
1504 | |
1505 /* Build the iotype string. */ | |
1506 if (iotype_len == 0) | |
1507 { | |
1508 iotype_len = 2; | |
1509 iotype = dt; | |
1510 } | |
1511 else | |
1512 iotype = get_dt_format (f->u.udf.string, &iotype_len); | |
1513 | |
1514 /* Set iostat, intent(out). */ | |
1515 noiostat = 0; | |
1516 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? | |
1517 dtp->common.iostat : &noiostat; | |
1518 | |
1519 /* Set iomsg, intent(inout). */ | |
1520 if (dtp->common.flags & IOPARM_HAS_IOMSG) | |
1521 { | |
1522 child_iomsg = dtp->common.iomsg; | |
1523 child_iomsg_len = dtp->common.iomsg_len; | |
1524 } | |
1525 else | |
1526 { | |
1527 child_iomsg = tmp_iomsg; | |
1528 child_iomsg_len = IOMSG_LEN; | |
1529 } | |
1530 | |
1531 /* Call the user defined formatted READ procedure. */ | |
1532 dtp->u.p.current_unit->child_dtio++; | |
1533 dtp->u.p.current_unit->last_char = EOF - 1; | |
1534 dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, | |
1535 child_iostat, child_iomsg, | |
1536 iotype_len, child_iomsg_len); | |
1537 dtp->u.p.current_unit->child_dtio--; | |
1538 | |
1539 if (f->u.udf.string_len != 0) | |
1540 free (iotype); | |
1541 /* Note: vlist is freed in free_format_data. */ | |
1542 break; | |
1543 | |
1544 case FMT_E: | |
1545 if (n == 0) | |
1546 goto need_read_data; | |
1547 if (require_type (dtp, BT_REAL, type, f)) | |
1548 return; | |
1549 read_f (dtp, f, p, kind); | |
1550 break; | |
1551 | |
1552 case FMT_EN: | |
1553 if (n == 0) | |
1554 goto need_read_data; | |
1555 if (require_type (dtp, BT_REAL, type, f)) | |
1556 return; | |
1557 read_f (dtp, f, p, kind); | |
1558 break; | |
1559 | |
1560 case FMT_ES: | |
1561 if (n == 0) | |
1562 goto need_read_data; | |
1563 if (require_type (dtp, BT_REAL, type, f)) | |
1564 return; | |
1565 read_f (dtp, f, p, kind); | |
1566 break; | |
1567 | |
1568 case FMT_F: | |
1569 if (n == 0) | |
1570 goto need_read_data; | |
1571 if (require_type (dtp, BT_REAL, type, f)) | |
1572 return; | |
1573 read_f (dtp, f, p, kind); | |
1574 break; | |
1575 | |
1576 case FMT_G: | |
1577 if (n == 0) | |
1578 goto need_read_data; | |
1579 switch (type) | |
1580 { | |
1581 case BT_INTEGER: | |
1582 read_decimal (dtp, f, p, kind); | |
1583 break; | |
1584 case BT_LOGICAL: | |
1585 read_l (dtp, f, p, kind); | |
1586 break; | |
1587 case BT_CHARACTER: | |
1588 if (kind == 4) | |
1589 read_a_char4 (dtp, f, p, size); | |
1590 else | |
1591 read_a (dtp, f, p, size); | |
1592 break; | |
1593 case BT_REAL: | |
1594 read_f (dtp, f, p, kind); | |
1595 break; | |
1596 default: | |
1597 internal_error (&dtp->common, "formatted_transfer(): Bad type"); | |
1598 } | |
1599 break; | |
1600 | |
1601 case FMT_STRING: | |
1602 consume_data_flag = 0; | |
1603 format_error (dtp, f, "Constant string in input format"); | |
1604 return; | |
1605 | |
1606 /* Format codes that don't transfer data. */ | |
1607 case FMT_X: | |
1608 case FMT_TR: | |
1609 consume_data_flag = 0; | |
1610 dtp->u.p.skips += f->u.n; | |
1611 pos = bytes_used + dtp->u.p.skips - 1; | |
1612 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; | |
1613 read_x (dtp, f->u.n); | |
1614 break; | |
1615 | |
1616 case FMT_TL: | |
1617 case FMT_T: | |
1618 consume_data_flag = 0; | |
1619 | |
1620 if (f->format == FMT_TL) | |
1621 { | |
1622 /* Handle the special case when no bytes have been used yet. | |
1623 Cannot go below zero. */ | |
1624 if (bytes_used == 0) | |
1625 { | |
1626 dtp->u.p.pending_spaces -= f->u.n; | |
1627 dtp->u.p.skips -= f->u.n; | |
1628 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; | |
1629 } | |
1630 | |
1631 pos = bytes_used - f->u.n; | |
1632 } | |
1633 else /* FMT_T */ | |
1634 pos = f->u.n - 1; | |
1635 | |
1636 /* Standard 10.6.1.1: excessive left tabbing is reset to the | |
1637 left tab limit. We do not check if the position has gone | |
1638 beyond the end of record because a subsequent tab could | |
1639 bring us back again. */ | |
1640 pos = pos < 0 ? 0 : pos; | |
1641 | |
1642 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; | |
1643 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces | |
1644 + pos - dtp->u.p.max_pos; | |
1645 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 | |
1646 ? 0 : dtp->u.p.pending_spaces; | |
1647 if (dtp->u.p.skips == 0) | |
1648 break; | |
1649 | |
1650 /* Adjust everything for end-of-record condition */ | |
1651 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp)) | |
1652 { | |
1653 dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor; | |
1654 dtp->u.p.skips -= dtp->u.p.sf_seen_eor; | |
1655 bytes_used = pos; | |
1656 if (dtp->u.p.pending_spaces == 0) | |
1657 dtp->u.p.sf_seen_eor = 0; | |
1658 } | |
1659 if (dtp->u.p.skips < 0) | |
1660 { | |
1661 if (is_internal_unit (dtp)) | |
1662 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); | |
1663 else | |
1664 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); | |
1665 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; | |
1666 dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
1667 } | |
1668 else | |
1669 read_x (dtp, dtp->u.p.skips); | |
1670 break; | |
1671 | |
1672 case FMT_S: | |
1673 consume_data_flag = 0; | |
1674 dtp->u.p.sign_status = SIGN_S; | |
1675 break; | |
1676 | |
1677 case FMT_SS: | |
1678 consume_data_flag = 0; | |
1679 dtp->u.p.sign_status = SIGN_SS; | |
1680 break; | |
1681 | |
1682 case FMT_SP: | |
1683 consume_data_flag = 0; | |
1684 dtp->u.p.sign_status = SIGN_SP; | |
1685 break; | |
1686 | |
1687 case FMT_BN: | |
1688 consume_data_flag = 0 ; | |
1689 dtp->u.p.blank_status = BLANK_NULL; | |
1690 break; | |
1691 | |
1692 case FMT_BZ: | |
1693 consume_data_flag = 0; | |
1694 dtp->u.p.blank_status = BLANK_ZERO; | |
1695 break; | |
1696 | |
1697 case FMT_DC: | |
1698 consume_data_flag = 0; | |
1699 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA; | |
1700 break; | |
1701 | |
1702 case FMT_DP: | |
1703 consume_data_flag = 0; | |
1704 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; | |
1705 break; | |
1706 | |
1707 case FMT_RC: | |
1708 consume_data_flag = 0; | |
1709 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE; | |
1710 break; | |
1711 | |
1712 case FMT_RD: | |
1713 consume_data_flag = 0; | |
1714 dtp->u.p.current_unit->round_status = ROUND_DOWN; | |
1715 break; | |
1716 | |
1717 case FMT_RN: | |
1718 consume_data_flag = 0; | |
1719 dtp->u.p.current_unit->round_status = ROUND_NEAREST; | |
1720 break; | |
1721 | |
1722 case FMT_RP: | |
1723 consume_data_flag = 0; | |
1724 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED; | |
1725 break; | |
1726 | |
1727 case FMT_RU: | |
1728 consume_data_flag = 0; | |
1729 dtp->u.p.current_unit->round_status = ROUND_UP; | |
1730 break; | |
1731 | |
1732 case FMT_RZ: | |
1733 consume_data_flag = 0; | |
1734 dtp->u.p.current_unit->round_status = ROUND_ZERO; | |
1735 break; | |
1736 | |
1737 case FMT_P: | |
1738 consume_data_flag = 0; | |
1739 dtp->u.p.scale_factor = f->u.k; | |
1740 break; | |
1741 | |
1742 case FMT_DOLLAR: | |
1743 consume_data_flag = 0; | |
1744 dtp->u.p.seen_dollar = 1; | |
1745 break; | |
1746 | |
1747 case FMT_SLASH: | |
1748 consume_data_flag = 0; | |
1749 dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
1750 next_record (dtp, 0); | |
1751 break; | |
1752 | |
1753 case FMT_COLON: | |
1754 /* A colon descriptor causes us to exit this loop (in | |
1755 particular preventing another / descriptor from being | |
1756 processed) unless there is another data item to be | |
1757 transferred. */ | |
1758 consume_data_flag = 0; | |
1759 if (n == 0) | |
1760 return; | |
1761 break; | |
1762 | |
1763 default: | |
1764 internal_error (&dtp->common, "Bad format node"); | |
1765 } | |
1766 | |
1767 /* Adjust the item count and data pointer. */ | |
1768 | |
1769 if ((consume_data_flag > 0) && (n > 0)) | |
1770 { | |
1771 n--; | |
1772 p = ((char *) p) + size; | |
1773 } | |
1774 | |
1775 dtp->u.p.skips = 0; | |
1776 | |
1777 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); | |
1778 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; | |
1779 } | |
1780 | |
1781 return; | |
1782 | |
1783 /* Come here when we need a data descriptor but don't have one. We | |
1784 push the current format node back onto the input, then return and | |
1785 let the user program call us back with the data. */ | |
1786 need_read_data: | |
1787 unget_format (dtp, f); | |
1788 } | |
1789 | |
1790 | |
1791 static void | |
1792 formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind, | |
1793 size_t size) | |
1794 { | |
1795 int pos, bytes_used; | |
1796 const fnode *f; | |
1797 format_token t; | |
1798 int n; | |
1799 int consume_data_flag; | |
1800 | |
1801 /* Change a complex data item into a pair of reals. */ | |
1802 | |
1803 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2); | |
1804 if (type == BT_COMPLEX) | |
1805 { | |
1806 type = BT_REAL; | |
1807 size /= 2; | |
1808 } | |
1809 | |
1810 /* If there's an EOR condition, we simulate finalizing the transfer | |
1811 by doing nothing. */ | |
1812 if (dtp->u.p.eor_condition) | |
1813 return; | |
1814 | |
1815 /* Set this flag so that commas in reads cause the read to complete before | |
1816 the entire field has been read. The next read field will start right after | |
1817 the comma in the stream. (Set to 0 for character reads). */ | |
1818 dtp->u.p.sf_read_comma = | |
1819 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1; | |
1820 | |
1821 for (;;) | |
1822 { | |
1823 /* If reversion has occurred and there is another real data item, | |
1824 then we have to move to the next record. */ | |
1825 if (dtp->u.p.reversion_flag && n > 0) | |
1826 { | |
1827 dtp->u.p.reversion_flag = 0; | |
1828 next_record (dtp, 0); | |
1829 } | |
1830 | |
1831 consume_data_flag = 1; | |
1832 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
1833 break; | |
1834 | |
1835 f = next_format (dtp); | |
1836 if (f == NULL) | |
1837 { | |
1838 /* No data descriptors left. */ | |
1839 if (unlikely (n > 0)) | |
1840 generate_error (&dtp->common, LIBERROR_FORMAT, | |
1841 "Insufficient data descriptors in format after reversion"); | |
1842 return; | |
1843 } | |
1844 | |
1845 /* Now discharge T, TR and X movements to the right. This is delayed | |
1846 until a data producing format to suppress trailing spaces. */ | |
1847 | |
1848 t = f->format; | |
1849 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0 | |
1850 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O | |
1851 || t == FMT_Z || t == FMT_F || t == FMT_E | |
1852 || t == FMT_EN || t == FMT_ES || t == FMT_G | |
1853 || t == FMT_L || t == FMT_A || t == FMT_D | |
1854 || t == FMT_DT)) | |
1855 || t == FMT_STRING)) | |
1856 { | |
1857 if (dtp->u.p.skips > 0) | |
1858 { | |
1859 int tmp; | |
1860 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); | |
1861 tmp = (int)(dtp->u.p.current_unit->recl | |
1862 - dtp->u.p.current_unit->bytes_left); | |
1863 dtp->u.p.max_pos = | |
1864 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp; | |
1865 dtp->u.p.skips = 0; | |
1866 } | |
1867 if (dtp->u.p.skips < 0) | |
1868 { | |
1869 if (is_internal_unit (dtp)) | |
1870 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR); | |
1871 else | |
1872 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR); | |
1873 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips; | |
1874 } | |
1875 dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
1876 } | |
1877 | |
1878 bytes_used = (int)(dtp->u.p.current_unit->recl | |
1879 - dtp->u.p.current_unit->bytes_left); | |
1880 | |
1881 if (is_stream_io(dtp)) | |
1882 bytes_used = 0; | |
1883 | |
1884 switch (t) | |
1885 { | |
1886 case FMT_I: | |
1887 if (n == 0) | |
1888 goto need_data; | |
1889 if (require_type (dtp, BT_INTEGER, type, f)) | |
1890 return; | |
1891 write_i (dtp, f, p, kind); | |
1892 break; | |
1893 | |
1894 case FMT_B: | |
1895 if (n == 0) | |
1896 goto need_data; | |
1897 if (!(compile_options.allow_std & GFC_STD_GNU) | |
1898 && require_numeric_type (dtp, type, f)) | |
1899 return; | |
1900 if (!(compile_options.allow_std & GFC_STD_F2008) | |
1901 && require_type (dtp, BT_INTEGER, type, f)) | |
1902 return; | |
1903 write_b (dtp, f, p, kind); | |
1904 break; | |
1905 | |
1906 case FMT_O: | |
1907 if (n == 0) | |
1908 goto need_data; | |
1909 if (!(compile_options.allow_std & GFC_STD_GNU) | |
1910 && require_numeric_type (dtp, type, f)) | |
1911 return; | |
1912 if (!(compile_options.allow_std & GFC_STD_F2008) | |
1913 && require_type (dtp, BT_INTEGER, type, f)) | |
1914 return; | |
1915 write_o (dtp, f, p, kind); | |
1916 break; | |
1917 | |
1918 case FMT_Z: | |
1919 if (n == 0) | |
1920 goto need_data; | |
1921 if (!(compile_options.allow_std & GFC_STD_GNU) | |
1922 && require_numeric_type (dtp, type, f)) | |
1923 return; | |
1924 if (!(compile_options.allow_std & GFC_STD_F2008) | |
1925 && require_type (dtp, BT_INTEGER, type, f)) | |
1926 return; | |
1927 write_z (dtp, f, p, kind); | |
1928 break; | |
1929 | |
1930 case FMT_A: | |
1931 if (n == 0) | |
1932 goto need_data; | |
1933 | |
1934 /* It is possible to have FMT_A with something not BT_CHARACTER such | |
1935 as when writing out hollerith strings, so check both type | |
1936 and kind before calling wide character routines. */ | |
1937 if (type == BT_CHARACTER && kind == 4) | |
1938 write_a_char4 (dtp, f, p, size); | |
1939 else | |
1940 write_a (dtp, f, p, size); | |
1941 break; | |
1942 | |
1943 case FMT_L: | |
1944 if (n == 0) | |
1945 goto need_data; | |
1946 write_l (dtp, f, p, kind); | |
1947 break; | |
1948 | |
1949 case FMT_D: | |
1950 if (n == 0) | |
1951 goto need_data; | |
1952 if (require_type (dtp, BT_REAL, type, f)) | |
1953 return; | |
1954 write_d (dtp, f, p, kind); | |
1955 break; | |
1956 | |
1957 case FMT_DT: | |
1958 if (n == 0) | |
1959 goto need_data; | |
1960 int unit = dtp->u.p.current_unit->unit_number; | |
1961 char dt[] = "DT"; | |
1962 char tmp_iomsg[IOMSG_LEN] = ""; | |
1963 char *child_iomsg; | |
1964 gfc_charlen_type child_iomsg_len; | |
1965 int noiostat; | |
1966 int *child_iostat = NULL; | |
1967 char *iotype; | |
1968 gfc_charlen_type iotype_len = f->u.udf.string_len; | |
1969 | |
1970 /* Build the iotype string. */ | |
1971 if (iotype_len == 0) | |
1972 { | |
1973 iotype_len = 2; | |
1974 iotype = dt; | |
1975 } | |
1976 else | |
1977 iotype = get_dt_format (f->u.udf.string, &iotype_len); | |
1978 | |
1979 /* Set iostat, intent(out). */ | |
1980 noiostat = 0; | |
1981 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ? | |
1982 dtp->common.iostat : &noiostat; | |
1983 | |
1984 /* Set iomsg, intent(inout). */ | |
1985 if (dtp->common.flags & IOPARM_HAS_IOMSG) | |
1986 { | |
1987 child_iomsg = dtp->common.iomsg; | |
1988 child_iomsg_len = dtp->common.iomsg_len; | |
1989 } | |
1990 else | |
1991 { | |
1992 child_iomsg = tmp_iomsg; | |
1993 child_iomsg_len = IOMSG_LEN; | |
1994 } | |
1995 | |
1996 if (check_dtio_proc (dtp, f)) | |
1997 return; | |
1998 | |
1999 /* Call the user defined formatted WRITE procedure. */ | |
2000 dtp->u.p.current_unit->child_dtio++; | |
2001 | |
2002 dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, | |
2003 child_iostat, child_iomsg, | |
2004 iotype_len, child_iomsg_len); | |
2005 dtp->u.p.current_unit->child_dtio--; | |
2006 | |
2007 if (f->u.udf.string_len != 0) | |
2008 free (iotype); | |
2009 /* Note: vlist is freed in free_format_data. */ | |
2010 break; | |
2011 | |
2012 case FMT_E: | |
2013 if (n == 0) | |
2014 goto need_data; | |
2015 if (require_type (dtp, BT_REAL, type, f)) | |
2016 return; | |
2017 write_e (dtp, f, p, kind); | |
2018 break; | |
2019 | |
2020 case FMT_EN: | |
2021 if (n == 0) | |
2022 goto need_data; | |
2023 if (require_type (dtp, BT_REAL, type, f)) | |
2024 return; | |
2025 write_en (dtp, f, p, kind); | |
2026 break; | |
2027 | |
2028 case FMT_ES: | |
2029 if (n == 0) | |
2030 goto need_data; | |
2031 if (require_type (dtp, BT_REAL, type, f)) | |
2032 return; | |
2033 write_es (dtp, f, p, kind); | |
2034 break; | |
2035 | |
2036 case FMT_F: | |
2037 if (n == 0) | |
2038 goto need_data; | |
2039 if (require_type (dtp, BT_REAL, type, f)) | |
2040 return; | |
2041 write_f (dtp, f, p, kind); | |
2042 break; | |
2043 | |
2044 case FMT_G: | |
2045 if (n == 0) | |
2046 goto need_data; | |
2047 switch (type) | |
2048 { | |
2049 case BT_INTEGER: | |
2050 write_i (dtp, f, p, kind); | |
2051 break; | |
2052 case BT_LOGICAL: | |
2053 write_l (dtp, f, p, kind); | |
2054 break; | |
2055 case BT_CHARACTER: | |
2056 if (kind == 4) | |
2057 write_a_char4 (dtp, f, p, size); | |
2058 else | |
2059 write_a (dtp, f, p, size); | |
2060 break; | |
2061 case BT_REAL: | |
2062 if (f->u.real.w == 0) | |
2063 write_real_g0 (dtp, p, kind, f->u.real.d); | |
2064 else | |
2065 write_d (dtp, f, p, kind); | |
2066 break; | |
2067 default: | |
2068 internal_error (&dtp->common, | |
2069 "formatted_transfer(): Bad type"); | |
2070 } | |
2071 break; | |
2072 | |
2073 case FMT_STRING: | |
2074 consume_data_flag = 0; | |
2075 write_constant_string (dtp, f); | |
2076 break; | |
2077 | |
2078 /* Format codes that don't transfer data. */ | |
2079 case FMT_X: | |
2080 case FMT_TR: | |
2081 consume_data_flag = 0; | |
2082 | |
2083 dtp->u.p.skips += f->u.n; | |
2084 pos = bytes_used + dtp->u.p.skips - 1; | |
2085 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1; | |
2086 /* Writes occur just before the switch on f->format, above, so | |
2087 that trailing blanks are suppressed, unless we are doing a | |
2088 non-advancing write in which case we want to output the blanks | |
2089 now. */ | |
2090 if (dtp->u.p.advance_status == ADVANCE_NO) | |
2091 { | |
2092 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); | |
2093 dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
2094 } | |
2095 break; | |
2096 | |
2097 case FMT_TL: | |
2098 case FMT_T: | |
2099 consume_data_flag = 0; | |
2100 | |
2101 if (f->format == FMT_TL) | |
2102 { | |
2103 | |
2104 /* Handle the special case when no bytes have been used yet. | |
2105 Cannot go below zero. */ | |
2106 if (bytes_used == 0) | |
2107 { | |
2108 dtp->u.p.pending_spaces -= f->u.n; | |
2109 dtp->u.p.skips -= f->u.n; | |
2110 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips; | |
2111 } | |
2112 | |
2113 pos = bytes_used - f->u.n; | |
2114 } | |
2115 else /* FMT_T */ | |
2116 pos = f->u.n - dtp->u.p.pending_spaces - 1; | |
2117 | |
2118 /* Standard 10.6.1.1: excessive left tabbing is reset to the | |
2119 left tab limit. We do not check if the position has gone | |
2120 beyond the end of record because a subsequent tab could | |
2121 bring us back again. */ | |
2122 pos = pos < 0 ? 0 : pos; | |
2123 | |
2124 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used; | |
2125 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces | |
2126 + pos - dtp->u.p.max_pos; | |
2127 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 | |
2128 ? 0 : dtp->u.p.pending_spaces; | |
2129 break; | |
2130 | |
2131 case FMT_S: | |
2132 consume_data_flag = 0; | |
2133 dtp->u.p.sign_status = SIGN_S; | |
2134 break; | |
2135 | |
2136 case FMT_SS: | |
2137 consume_data_flag = 0; | |
2138 dtp->u.p.sign_status = SIGN_SS; | |
2139 break; | |
2140 | |
2141 case FMT_SP: | |
2142 consume_data_flag = 0; | |
2143 dtp->u.p.sign_status = SIGN_SP; | |
2144 break; | |
2145 | |
2146 case FMT_BN: | |
2147 consume_data_flag = 0 ; | |
2148 dtp->u.p.blank_status = BLANK_NULL; | |
2149 break; | |
2150 | |
2151 case FMT_BZ: | |
2152 consume_data_flag = 0; | |
2153 dtp->u.p.blank_status = BLANK_ZERO; | |
2154 break; | |
2155 | |
2156 case FMT_DC: | |
2157 consume_data_flag = 0; | |
2158 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA; | |
2159 break; | |
2160 | |
2161 case FMT_DP: | |
2162 consume_data_flag = 0; | |
2163 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT; | |
2164 break; | |
2165 | |
2166 case FMT_RC: | |
2167 consume_data_flag = 0; | |
2168 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE; | |
2169 break; | |
2170 | |
2171 case FMT_RD: | |
2172 consume_data_flag = 0; | |
2173 dtp->u.p.current_unit->round_status = ROUND_DOWN; | |
2174 break; | |
2175 | |
2176 case FMT_RN: | |
2177 consume_data_flag = 0; | |
2178 dtp->u.p.current_unit->round_status = ROUND_NEAREST; | |
2179 break; | |
2180 | |
2181 case FMT_RP: | |
2182 consume_data_flag = 0; | |
2183 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED; | |
2184 break; | |
2185 | |
2186 case FMT_RU: | |
2187 consume_data_flag = 0; | |
2188 dtp->u.p.current_unit->round_status = ROUND_UP; | |
2189 break; | |
2190 | |
2191 case FMT_RZ: | |
2192 consume_data_flag = 0; | |
2193 dtp->u.p.current_unit->round_status = ROUND_ZERO; | |
2194 break; | |
2195 | |
2196 case FMT_P: | |
2197 consume_data_flag = 0; | |
2198 dtp->u.p.scale_factor = f->u.k; | |
2199 break; | |
2200 | |
2201 case FMT_DOLLAR: | |
2202 consume_data_flag = 0; | |
2203 dtp->u.p.seen_dollar = 1; | |
2204 break; | |
2205 | |
2206 case FMT_SLASH: | |
2207 consume_data_flag = 0; | |
2208 dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
2209 next_record (dtp, 0); | |
2210 break; | |
2211 | |
2212 case FMT_COLON: | |
2213 /* A colon descriptor causes us to exit this loop (in | |
2214 particular preventing another / descriptor from being | |
2215 processed) unless there is another data item to be | |
2216 transferred. */ | |
2217 consume_data_flag = 0; | |
2218 if (n == 0) | |
2219 return; | |
2220 break; | |
2221 | |
2222 default: | |
2223 internal_error (&dtp->common, "Bad format node"); | |
2224 } | |
2225 | |
2226 /* Adjust the item count and data pointer. */ | |
2227 | |
2228 if ((consume_data_flag > 0) && (n > 0)) | |
2229 { | |
2230 n--; | |
2231 p = ((char *) p) + size; | |
2232 } | |
2233 | |
2234 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left); | |
2235 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos; | |
2236 } | |
2237 | |
2238 return; | |
2239 | |
2240 /* Come here when we need a data descriptor but don't have one. We | |
2241 push the current format node back onto the input, then return and | |
2242 let the user program call us back with the data. */ | |
2243 need_data: | |
2244 unget_format (dtp, f); | |
2245 } | |
2246 | |
2247 /* This function is first called from data_init_transfer to initiate the loop | |
2248 over each item in the format, transferring data as required. Subsequent | |
2249 calls to this function occur for each data item foound in the READ/WRITE | |
2250 statement. The item_count is incremented for each call. Since the first | |
2251 call is from data_transfer_init, the item_count is always one greater than | |
2252 the actual count number of the item being transferred. */ | |
2253 | |
2254 static void | |
2255 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind, | |
2256 size_t size, size_t nelems) | |
2257 { | |
2258 size_t elem; | |
2259 char *tmp; | |
2260 | |
2261 tmp = (char *) p; | |
2262 size_t stride = type == BT_CHARACTER ? | |
2263 size * GFC_SIZE_OF_CHAR_KIND(kind) : size; | |
2264 if (dtp->u.p.mode == READING) | |
2265 { | |
2266 /* Big loop over all the elements. */ | |
2267 for (elem = 0; elem < nelems; elem++) | |
2268 { | |
2269 dtp->u.p.item_count++; | |
2270 formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size); | |
2271 } | |
2272 } | |
2273 else | |
2274 { | |
2275 /* Big loop over all the elements. */ | |
2276 for (elem = 0; elem < nelems; elem++) | |
2277 { | |
2278 dtp->u.p.item_count++; | |
2279 formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size); | |
2280 } | |
2281 } | |
2282 } | |
2283 | |
2284 | |
2285 /* Data transfer entry points. The type of the data entity is | |
2286 implicit in the subroutine call. This prevents us from having to | |
2287 share a common enum with the compiler. */ | |
2288 | |
2289 void | |
2290 transfer_integer (st_parameter_dt *dtp, void *p, int kind) | |
2291 { | |
2292 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2293 return; | |
2294 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1); | |
2295 } | |
2296 | |
2297 void | |
2298 transfer_integer_write (st_parameter_dt *dtp, void *p, int kind) | |
2299 { | |
2300 transfer_integer (dtp, p, kind); | |
2301 } | |
2302 | |
2303 void | |
2304 transfer_real (st_parameter_dt *dtp, void *p, int kind) | |
2305 { | |
2306 size_t size; | |
2307 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2308 return; | |
2309 size = size_from_real_kind (kind); | |
2310 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1); | |
2311 } | |
2312 | |
2313 void | |
2314 transfer_real_write (st_parameter_dt *dtp, void *p, int kind) | |
2315 { | |
2316 transfer_real (dtp, p, kind); | |
2317 } | |
2318 | |
2319 void | |
2320 transfer_logical (st_parameter_dt *dtp, void *p, int kind) | |
2321 { | |
2322 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2323 return; | |
2324 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1); | |
2325 } | |
2326 | |
2327 void | |
2328 transfer_logical_write (st_parameter_dt *dtp, void *p, int kind) | |
2329 { | |
2330 transfer_logical (dtp, p, kind); | |
2331 } | |
2332 | |
2333 void | |
2334 transfer_character (st_parameter_dt *dtp, void *p, int len) | |
2335 { | |
2336 static char *empty_string[0]; | |
2337 | |
2338 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2339 return; | |
2340 | |
2341 /* Strings of zero length can have p == NULL, which confuses the | |
2342 transfer routines into thinking we need more data elements. To avoid | |
2343 this, we give them a nice pointer. */ | |
2344 if (len == 0 && p == NULL) | |
2345 p = empty_string; | |
2346 | |
2347 /* Set kind here to 1. */ | |
2348 dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1); | |
2349 } | |
2350 | |
2351 void | |
2352 transfer_character_write (st_parameter_dt *dtp, void *p, int len) | |
2353 { | |
2354 transfer_character (dtp, p, len); | |
2355 } | |
2356 | |
2357 void | |
2358 transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind) | |
2359 { | |
2360 static char *empty_string[0]; | |
2361 | |
2362 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2363 return; | |
2364 | |
2365 /* Strings of zero length can have p == NULL, which confuses the | |
2366 transfer routines into thinking we need more data elements. To avoid | |
2367 this, we give them a nice pointer. */ | |
2368 if (len == 0 && p == NULL) | |
2369 p = empty_string; | |
2370 | |
2371 /* Here we pass the actual kind value. */ | |
2372 dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1); | |
2373 } | |
2374 | |
2375 void | |
2376 transfer_character_wide_write (st_parameter_dt *dtp, void *p, int len, int kind) | |
2377 { | |
2378 transfer_character_wide (dtp, p, len, kind); | |
2379 } | |
2380 | |
2381 void | |
2382 transfer_complex (st_parameter_dt *dtp, void *p, int kind) | |
2383 { | |
2384 size_t size; | |
2385 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2386 return; | |
2387 size = size_from_complex_kind (kind); | |
2388 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1); | |
2389 } | |
2390 | |
2391 void | |
2392 transfer_complex_write (st_parameter_dt *dtp, void *p, int kind) | |
2393 { | |
2394 transfer_complex (dtp, p, kind); | |
2395 } | |
2396 | |
2397 void | |
2398 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind, | |
2399 gfc_charlen_type charlen) | |
2400 { | |
2401 index_type count[GFC_MAX_DIMENSIONS]; | |
2402 index_type extent[GFC_MAX_DIMENSIONS]; | |
2403 index_type stride[GFC_MAX_DIMENSIONS]; | |
2404 index_type stride0, rank, size, n; | |
2405 size_t tsize; | |
2406 char *data; | |
2407 bt iotype; | |
2408 | |
2409 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2410 return; | |
2411 | |
2412 iotype = (bt) GFC_DESCRIPTOR_TYPE (desc); | |
2413 size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc); | |
2414 | |
2415 rank = GFC_DESCRIPTOR_RANK (desc); | |
2416 for (n = 0; n < rank; n++) | |
2417 { | |
2418 count[n] = 0; | |
2419 stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n); | |
2420 extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n); | |
2421 | |
2422 /* If the extent of even one dimension is zero, then the entire | |
2423 array section contains zero elements, so we return after writing | |
2424 a zero array record. */ | |
2425 if (extent[n] <= 0) | |
2426 { | |
2427 data = NULL; | |
2428 tsize = 0; | |
2429 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); | |
2430 return; | |
2431 } | |
2432 } | |
2433 | |
2434 stride0 = stride[0]; | |
2435 | |
2436 /* If the innermost dimension has a stride of 1, we can do the transfer | |
2437 in contiguous chunks. */ | |
2438 if (stride0 == size) | |
2439 tsize = extent[0]; | |
2440 else | |
2441 tsize = 1; | |
2442 | |
2443 data = GFC_DESCRIPTOR_DATA (desc); | |
2444 | |
2445 while (data) | |
2446 { | |
2447 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize); | |
2448 data += stride0 * tsize; | |
2449 count[0] += tsize; | |
2450 n = 0; | |
2451 while (count[n] == extent[n]) | |
2452 { | |
2453 count[n] = 0; | |
2454 data -= stride[n] * extent[n]; | |
2455 n++; | |
2456 if (n == rank) | |
2457 { | |
2458 data = NULL; | |
2459 break; | |
2460 } | |
2461 else | |
2462 { | |
2463 count[n]++; | |
2464 data += stride[n]; | |
2465 } | |
2466 } | |
2467 } | |
2468 } | |
2469 | |
2470 void | |
2471 transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind, | |
2472 gfc_charlen_type charlen) | |
2473 { | |
2474 transfer_array (dtp, desc, kind, charlen); | |
2475 } | |
2476 | |
2477 | |
2478 /* User defined input/output iomsg. */ | |
2479 | |
2480 #define IOMSG_LEN 256 | |
2481 | |
2482 void | |
2483 transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc) | |
2484 { | |
2485 if (parent->u.p.current_unit) | |
2486 { | |
2487 if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED) | |
2488 parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc; | |
2489 else | |
2490 parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc; | |
2491 } | |
2492 parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1); | |
2493 } | |
2494 | |
2495 | |
2496 /* Preposition a sequential unformatted file while reading. */ | |
2497 | |
2498 static void | |
2499 us_read (st_parameter_dt *dtp, int continued) | |
2500 { | |
2501 ssize_t n, nr; | |
2502 GFC_INTEGER_4 i4; | |
2503 GFC_INTEGER_8 i8; | |
2504 gfc_offset i; | |
2505 | |
2506 if (compile_options.record_marker == 0) | |
2507 n = sizeof (GFC_INTEGER_4); | |
2508 else | |
2509 n = compile_options.record_marker; | |
2510 | |
2511 nr = sread (dtp->u.p.current_unit->s, &i, n); | |
2512 if (unlikely (nr < 0)) | |
2513 { | |
2514 generate_error (&dtp->common, LIBERROR_BAD_US, NULL); | |
2515 return; | |
2516 } | |
2517 else if (nr == 0) | |
2518 { | |
2519 hit_eof (dtp); | |
2520 return; /* end of file */ | |
2521 } | |
2522 else if (unlikely (n != nr)) | |
2523 { | |
2524 generate_error (&dtp->common, LIBERROR_BAD_US, NULL); | |
2525 return; | |
2526 } | |
2527 | |
2528 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ | |
2529 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)) | |
2530 { | |
2531 switch (nr) | |
2532 { | |
2533 case sizeof(GFC_INTEGER_4): | |
2534 memcpy (&i4, &i, sizeof (i4)); | |
2535 i = i4; | |
2536 break; | |
2537 | |
2538 case sizeof(GFC_INTEGER_8): | |
2539 memcpy (&i8, &i, sizeof (i8)); | |
2540 i = i8; | |
2541 break; | |
2542 | |
2543 default: | |
2544 runtime_error ("Illegal value for record marker"); | |
2545 break; | |
2546 } | |
2547 } | |
2548 else | |
2549 { | |
2550 uint32_t u32; | |
2551 uint64_t u64; | |
2552 switch (nr) | |
2553 { | |
2554 case sizeof(GFC_INTEGER_4): | |
2555 memcpy (&u32, &i, sizeof (u32)); | |
2556 u32 = __builtin_bswap32 (u32); | |
2557 memcpy (&i4, &u32, sizeof (i4)); | |
2558 i = i4; | |
2559 break; | |
2560 | |
2561 case sizeof(GFC_INTEGER_8): | |
2562 memcpy (&u64, &i, sizeof (u64)); | |
2563 u64 = __builtin_bswap64 (u64); | |
2564 memcpy (&i8, &u64, sizeof (i8)); | |
2565 i = i8; | |
2566 break; | |
2567 | |
2568 default: | |
2569 runtime_error ("Illegal value for record marker"); | |
2570 break; | |
2571 } | |
2572 } | |
2573 | |
2574 if (i >= 0) | |
2575 { | |
2576 dtp->u.p.current_unit->bytes_left_subrecord = i; | |
2577 dtp->u.p.current_unit->continued = 0; | |
2578 } | |
2579 else | |
2580 { | |
2581 dtp->u.p.current_unit->bytes_left_subrecord = -i; | |
2582 dtp->u.p.current_unit->continued = 1; | |
2583 } | |
2584 | |
2585 if (! continued) | |
2586 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
2587 } | |
2588 | |
2589 | |
2590 /* Preposition a sequential unformatted file while writing. This | |
2591 amount to writing a bogus length that will be filled in later. */ | |
2592 | |
2593 static void | |
2594 us_write (st_parameter_dt *dtp, int continued) | |
2595 { | |
2596 ssize_t nbytes; | |
2597 gfc_offset dummy; | |
2598 | |
2599 dummy = 0; | |
2600 | |
2601 if (compile_options.record_marker == 0) | |
2602 nbytes = sizeof (GFC_INTEGER_4); | |
2603 else | |
2604 nbytes = compile_options.record_marker ; | |
2605 | |
2606 if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes) | |
2607 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
2608 | |
2609 /* For sequential unformatted, if RECL= was not specified in the OPEN | |
2610 we write until we have more bytes than can fit in the subrecord | |
2611 markers, then we write a new subrecord. */ | |
2612 | |
2613 dtp->u.p.current_unit->bytes_left_subrecord = | |
2614 dtp->u.p.current_unit->recl_subrecord; | |
2615 dtp->u.p.current_unit->continued = continued; | |
2616 } | |
2617 | |
2618 | |
2619 /* Position to the next record prior to transfer. We are assumed to | |
2620 be before the next record. We also calculate the bytes in the next | |
2621 record. */ | |
2622 | |
2623 static void | |
2624 pre_position (st_parameter_dt *dtp) | |
2625 { | |
2626 if (dtp->u.p.current_unit->current_record) | |
2627 return; /* Already positioned. */ | |
2628 | |
2629 switch (current_mode (dtp)) | |
2630 { | |
2631 case FORMATTED_STREAM: | |
2632 case UNFORMATTED_STREAM: | |
2633 /* There are no records with stream I/O. If the position was specified | |
2634 data_transfer_init has already positioned the file. If no position | |
2635 was specified, we continue from where we last left off. I.e. | |
2636 there is nothing to do here. */ | |
2637 break; | |
2638 | |
2639 case UNFORMATTED_SEQUENTIAL: | |
2640 if (dtp->u.p.mode == READING) | |
2641 us_read (dtp, 0); | |
2642 else | |
2643 us_write (dtp, 0); | |
2644 | |
2645 break; | |
2646 | |
2647 case FORMATTED_SEQUENTIAL: | |
2648 case FORMATTED_DIRECT: | |
2649 case UNFORMATTED_DIRECT: | |
2650 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
2651 break; | |
2652 } | |
2653 | |
2654 dtp->u.p.current_unit->current_record = 1; | |
2655 } | |
2656 | |
2657 | |
2658 /* Initialize things for a data transfer. This code is common for | |
2659 both reading and writing. */ | |
2660 | |
2661 static void | |
2662 data_transfer_init (st_parameter_dt *dtp, int read_flag) | |
2663 { | |
2664 unit_flags u_flags; /* Used for creating a unit if needed. */ | |
2665 GFC_INTEGER_4 cf = dtp->common.flags; | |
2666 namelist_info *ionml; | |
2667 | |
2668 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL; | |
2669 | |
2670 memset (&dtp->u.p, 0, sizeof (dtp->u.p)); | |
2671 | |
2672 dtp->u.p.ionml = ionml; | |
2673 dtp->u.p.mode = read_flag ? READING : WRITING; | |
2674 | |
2675 dtp->u.p.cc.len = 0; | |
2676 | |
2677 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
2678 return; | |
2679 | |
2680 dtp->u.p.current_unit = get_unit (dtp, 1); | |
2681 | |
2682 if (dtp->u.p.current_unit == NULL) | |
2683 { | |
2684 /* This means we tried to access an external unit < 0 without | |
2685 having opened it first with NEWUNIT=. */ | |
2686 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
2687 "Unit number is negative and unit was not already " | |
2688 "opened with OPEN(NEWUNIT=...)"); | |
2689 return; | |
2690 } | |
2691 else if (dtp->u.p.current_unit->s == NULL) | |
2692 { /* Open the unit with some default flags. */ | |
2693 st_parameter_open opp; | |
2694 unit_convert conv; | |
2695 | |
2696 memset (&u_flags, '\0', sizeof (u_flags)); | |
2697 u_flags.access = ACCESS_SEQUENTIAL; | |
2698 u_flags.action = ACTION_READWRITE; | |
2699 | |
2700 /* Is it unformatted? */ | |
2701 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT | |
2702 | IOPARM_DT_IONML_SET))) | |
2703 u_flags.form = FORM_UNFORMATTED; | |
2704 else | |
2705 u_flags.form = FORM_UNSPECIFIED; | |
2706 | |
2707 u_flags.delim = DELIM_UNSPECIFIED; | |
2708 u_flags.blank = BLANK_UNSPECIFIED; | |
2709 u_flags.pad = PAD_UNSPECIFIED; | |
2710 u_flags.decimal = DECIMAL_UNSPECIFIED; | |
2711 u_flags.encoding = ENCODING_UNSPECIFIED; | |
2712 u_flags.async = ASYNC_UNSPECIFIED; | |
2713 u_flags.round = ROUND_UNSPECIFIED; | |
2714 u_flags.sign = SIGN_UNSPECIFIED; | |
2715 u_flags.share = SHARE_UNSPECIFIED; | |
2716 u_flags.cc = CC_UNSPECIFIED; | |
2717 u_flags.readonly = 0; | |
2718 | |
2719 u_flags.status = STATUS_UNKNOWN; | |
2720 | |
2721 conv = get_unformatted_convert (dtp->common.unit); | |
2722 | |
2723 if (conv == GFC_CONVERT_NONE) | |
2724 conv = compile_options.convert; | |
2725 | |
2726 /* We use big_endian, which is 0 on little-endian machines | |
2727 and 1 on big-endian machines. */ | |
2728 switch (conv) | |
2729 { | |
2730 case GFC_CONVERT_NATIVE: | |
2731 case GFC_CONVERT_SWAP: | |
2732 break; | |
2733 | |
2734 case GFC_CONVERT_BIG: | |
2735 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; | |
2736 break; | |
2737 | |
2738 case GFC_CONVERT_LITTLE: | |
2739 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; | |
2740 break; | |
2741 | |
2742 default: | |
2743 internal_error (&opp.common, "Illegal value for CONVERT"); | |
2744 break; | |
2745 } | |
2746 | |
2747 u_flags.convert = conv; | |
2748 | |
2749 opp.common = dtp->common; | |
2750 opp.common.flags &= IOPARM_COMMON_MASK; | |
2751 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags); | |
2752 dtp->common.flags &= ~IOPARM_COMMON_MASK; | |
2753 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK); | |
2754 if (dtp->u.p.current_unit == NULL) | |
2755 return; | |
2756 } | |
2757 | |
2758 if (dtp->u.p.current_unit->child_dtio == 0) | |
2759 { | |
2760 if ((cf & IOPARM_DT_HAS_SIZE) != 0) | |
2761 { | |
2762 dtp->u.p.current_unit->has_size = true; | |
2763 /* Initialize the count. */ | |
2764 dtp->u.p.current_unit->size_used = 0; | |
2765 } | |
2766 else | |
2767 dtp->u.p.current_unit->has_size = false; | |
2768 } | |
2769 | |
2770 /* Check the action. */ | |
2771 | |
2772 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE) | |
2773 { | |
2774 generate_error (&dtp->common, LIBERROR_BAD_ACTION, | |
2775 "Cannot read from file opened for WRITE"); | |
2776 return; | |
2777 } | |
2778 | |
2779 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ) | |
2780 { | |
2781 generate_error (&dtp->common, LIBERROR_BAD_ACTION, | |
2782 "Cannot write to file opened for READ"); | |
2783 return; | |
2784 } | |
2785 | |
2786 dtp->u.p.first_item = 1; | |
2787 | |
2788 /* Check the format. */ | |
2789 | |
2790 if ((cf & IOPARM_DT_HAS_FORMAT) != 0) | |
2791 parse_format (dtp); | |
2792 | |
2793 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED | |
2794 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) | |
2795 != 0) | |
2796 { | |
2797 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2798 "Format present for UNFORMATTED data transfer"); | |
2799 return; | |
2800 } | |
2801 | |
2802 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL) | |
2803 { | |
2804 if ((cf & IOPARM_DT_HAS_FORMAT) != 0) | |
2805 { | |
2806 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2807 "A format cannot be specified with a namelist"); | |
2808 return; | |
2809 } | |
2810 } | |
2811 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED && | |
2812 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))) | |
2813 { | |
2814 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2815 "Missing format for FORMATTED data transfer"); | |
2816 return; | |
2817 } | |
2818 | |
2819 if (is_internal_unit (dtp) | |
2820 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) | |
2821 { | |
2822 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2823 "Internal file cannot be accessed by UNFORMATTED " | |
2824 "data transfer"); | |
2825 return; | |
2826 } | |
2827 | |
2828 /* Check the record or position number. */ | |
2829 | |
2830 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT | |
2831 && (cf & IOPARM_DT_HAS_REC) == 0) | |
2832 { | |
2833 generate_error (&dtp->common, LIBERROR_MISSING_OPTION, | |
2834 "Direct access data transfer requires record number"); | |
2835 return; | |
2836 } | |
2837 | |
2838 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
2839 { | |
2840 if ((cf & IOPARM_DT_HAS_REC) != 0) | |
2841 { | |
2842 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2843 "Record number not allowed for sequential access " | |
2844 "data transfer"); | |
2845 return; | |
2846 } | |
2847 | |
2848 if (compile_options.warn_std && | |
2849 dtp->u.p.current_unit->endfile == AFTER_ENDFILE) | |
2850 { | |
2851 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2852 "Sequential READ or WRITE not allowed after " | |
2853 "EOF marker, possibly use REWIND or BACKSPACE"); | |
2854 return; | |
2855 } | |
2856 } | |
2857 | |
2858 /* Process the ADVANCE option. */ | |
2859 | |
2860 dtp->u.p.advance_status | |
2861 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED : | |
2862 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt, | |
2863 "Bad ADVANCE parameter in data transfer statement"); | |
2864 | |
2865 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED) | |
2866 { | |
2867 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) | |
2868 { | |
2869 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2870 "ADVANCE specification conflicts with sequential " | |
2871 "access"); | |
2872 return; | |
2873 } | |
2874 | |
2875 if (is_internal_unit (dtp)) | |
2876 { | |
2877 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2878 "ADVANCE specification conflicts with internal file"); | |
2879 return; | |
2880 } | |
2881 | |
2882 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)) | |
2883 != IOPARM_DT_HAS_FORMAT) | |
2884 { | |
2885 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2886 "ADVANCE specification requires an explicit format"); | |
2887 return; | |
2888 } | |
2889 } | |
2890 | |
2891 /* Child IO is non-advancing and any ADVANCE= specifier is ignored. | |
2892 F2008 9.6.2.4 */ | |
2893 if (dtp->u.p.current_unit->child_dtio > 0) | |
2894 dtp->u.p.advance_status = ADVANCE_NO; | |
2895 | |
2896 if (read_flag) | |
2897 { | |
2898 dtp->u.p.current_unit->previous_nonadvancing_write = 0; | |
2899 | |
2900 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO) | |
2901 { | |
2902 generate_error (&dtp->common, LIBERROR_MISSING_OPTION, | |
2903 "EOR specification requires an ADVANCE specification " | |
2904 "of NO"); | |
2905 return; | |
2906 } | |
2907 | |
2908 if ((cf & IOPARM_DT_HAS_SIZE) != 0 | |
2909 && dtp->u.p.advance_status != ADVANCE_NO) | |
2910 { | |
2911 generate_error (&dtp->common, LIBERROR_MISSING_OPTION, | |
2912 "SIZE specification requires an ADVANCE " | |
2913 "specification of NO"); | |
2914 return; | |
2915 } | |
2916 } | |
2917 else | |
2918 { /* Write constraints. */ | |
2919 if ((cf & IOPARM_END) != 0) | |
2920 { | |
2921 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2922 "END specification cannot appear in a write " | |
2923 "statement"); | |
2924 return; | |
2925 } | |
2926 | |
2927 if ((cf & IOPARM_EOR) != 0) | |
2928 { | |
2929 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2930 "EOR specification cannot appear in a write " | |
2931 "statement"); | |
2932 return; | |
2933 } | |
2934 | |
2935 if ((cf & IOPARM_DT_HAS_SIZE) != 0) | |
2936 { | |
2937 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
2938 "SIZE specification cannot appear in a write " | |
2939 "statement"); | |
2940 return; | |
2941 } | |
2942 } | |
2943 | |
2944 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED) | |
2945 dtp->u.p.advance_status = ADVANCE_YES; | |
2946 | |
2947 /* Check the decimal mode. */ | |
2948 dtp->u.p.current_unit->decimal_status | |
2949 = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED : | |
2950 find_option (&dtp->common, dtp->decimal, dtp->decimal_len, | |
2951 decimal_opt, "Bad DECIMAL parameter in data transfer " | |
2952 "statement"); | |
2953 | |
2954 if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED) | |
2955 dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal; | |
2956 | |
2957 /* Check the round mode. */ | |
2958 dtp->u.p.current_unit->round_status | |
2959 = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED : | |
2960 find_option (&dtp->common, dtp->round, dtp->round_len, | |
2961 round_opt, "Bad ROUND parameter in data transfer " | |
2962 "statement"); | |
2963 | |
2964 if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED) | |
2965 dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round; | |
2966 | |
2967 /* Check the sign mode. */ | |
2968 dtp->u.p.sign_status | |
2969 = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED : | |
2970 find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt, | |
2971 "Bad SIGN parameter in data transfer statement"); | |
2972 | |
2973 if (dtp->u.p.sign_status == SIGN_UNSPECIFIED) | |
2974 dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign; | |
2975 | |
2976 /* Check the blank mode. */ | |
2977 dtp->u.p.blank_status | |
2978 = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED : | |
2979 find_option (&dtp->common, dtp->blank, dtp->blank_len, | |
2980 blank_opt, | |
2981 "Bad BLANK parameter in data transfer statement"); | |
2982 | |
2983 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) | |
2984 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank; | |
2985 | |
2986 /* Check the delim mode. */ | |
2987 dtp->u.p.current_unit->delim_status | |
2988 = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED : | |
2989 find_option (&dtp->common, dtp->delim, dtp->delim_len, | |
2990 delim_opt, "Bad DELIM parameter in data transfer statement"); | |
2991 | |
2992 if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED) | |
2993 { | |
2994 if (ionml && dtp->u.p.current_unit->flags.delim == DELIM_UNSPECIFIED) | |
2995 dtp->u.p.current_unit->delim_status = DELIM_QUOTE; | |
2996 else | |
2997 dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim; | |
2998 } | |
2999 | |
3000 /* Check the pad mode. */ | |
3001 dtp->u.p.current_unit->pad_status | |
3002 = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED : | |
3003 find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt, | |
3004 "Bad PAD parameter in data transfer statement"); | |
3005 | |
3006 if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED) | |
3007 dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad; | |
3008 | |
3009 /* Check to see if we might be reading what we wrote before */ | |
3010 | |
3011 if (dtp->u.p.mode != dtp->u.p.current_unit->mode | |
3012 && !is_internal_unit (dtp)) | |
3013 { | |
3014 int pos = fbuf_reset (dtp->u.p.current_unit); | |
3015 if (pos != 0) | |
3016 sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR); | |
3017 sflush(dtp->u.p.current_unit->s); | |
3018 } | |
3019 | |
3020 /* Check the POS= specifier: that it is in range and that it is used with a | |
3021 unit that has been connected for STREAM access. F2003 9.5.1.10. */ | |
3022 | |
3023 if (((cf & IOPARM_DT_HAS_POS) != 0)) | |
3024 { | |
3025 if (is_stream_io (dtp)) | |
3026 { | |
3027 | |
3028 if (dtp->pos <= 0) | |
3029 { | |
3030 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3031 "POS=specifier must be positive"); | |
3032 return; | |
3033 } | |
3034 | |
3035 if (dtp->pos >= dtp->u.p.current_unit->maxrec) | |
3036 { | |
3037 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3038 "POS=specifier too large"); | |
3039 return; | |
3040 } | |
3041 | |
3042 dtp->rec = dtp->pos; | |
3043 | |
3044 if (dtp->u.p.mode == READING) | |
3045 { | |
3046 /* Reset the endfile flag; if we hit EOF during reading | |
3047 we'll set the flag and generate an error at that point | |
3048 rather than worrying about it here. */ | |
3049 dtp->u.p.current_unit->endfile = NO_ENDFILE; | |
3050 } | |
3051 | |
3052 if (dtp->pos != dtp->u.p.current_unit->strm_pos) | |
3053 { | |
3054 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); | |
3055 if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1, SEEK_SET) < 0) | |
3056 { | |
3057 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3058 return; | |
3059 } | |
3060 dtp->u.p.current_unit->strm_pos = dtp->pos; | |
3061 } | |
3062 } | |
3063 else | |
3064 { | |
3065 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3066 "POS=specifier not allowed, " | |
3067 "Try OPEN with ACCESS='stream'"); | |
3068 return; | |
3069 } | |
3070 } | |
3071 | |
3072 | |
3073 /* Sanity checks on the record number. */ | |
3074 if ((cf & IOPARM_DT_HAS_REC) != 0) | |
3075 { | |
3076 if (dtp->rec <= 0) | |
3077 { | |
3078 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3079 "Record number must be positive"); | |
3080 return; | |
3081 } | |
3082 | |
3083 if (dtp->rec >= dtp->u.p.current_unit->maxrec) | |
3084 { | |
3085 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3086 "Record number too large"); | |
3087 return; | |
3088 } | |
3089 | |
3090 /* Make sure format buffer is reset. */ | |
3091 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED) | |
3092 fbuf_reset (dtp->u.p.current_unit); | |
3093 | |
3094 | |
3095 /* Check whether the record exists to be read. Only | |
3096 a partial record needs to exist. */ | |
3097 | |
3098 if (dtp->u.p.mode == READING && (dtp->rec - 1) | |
3099 * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s)) | |
3100 { | |
3101 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3102 "Non-existing record number"); | |
3103 return; | |
3104 } | |
3105 | |
3106 /* Position the file. */ | |
3107 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1) | |
3108 * dtp->u.p.current_unit->recl, SEEK_SET) < 0) | |
3109 { | |
3110 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3111 return; | |
3112 } | |
3113 | |
3114 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM) | |
3115 { | |
3116 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT, | |
3117 "Record number not allowed for stream access " | |
3118 "data transfer"); | |
3119 return; | |
3120 } | |
3121 } | |
3122 | |
3123 /* Bugware for badly written mixed C-Fortran I/O. */ | |
3124 if (!is_internal_unit (dtp)) | |
3125 flush_if_preconnected(dtp->u.p.current_unit->s); | |
3126 | |
3127 dtp->u.p.current_unit->mode = dtp->u.p.mode; | |
3128 | |
3129 /* Set the maximum position reached from the previous I/O operation. This | |
3130 could be greater than zero from a previous non-advancing write. */ | |
3131 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos; | |
3132 | |
3133 pre_position (dtp); | |
3134 | |
3135 | |
3136 /* Set up the subroutine that will handle the transfers. */ | |
3137 | |
3138 if (read_flag) | |
3139 { | |
3140 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) | |
3141 dtp->u.p.transfer = unformatted_read; | |
3142 else | |
3143 { | |
3144 if ((cf & IOPARM_DT_LIST_FORMAT) != 0) | |
3145 { | |
3146 if (dtp->u.p.current_unit->child_dtio == 0) | |
3147 dtp->u.p.current_unit->last_char = EOF - 1; | |
3148 dtp->u.p.transfer = list_formatted_read; | |
3149 } | |
3150 else | |
3151 dtp->u.p.transfer = formatted_transfer; | |
3152 } | |
3153 } | |
3154 else | |
3155 { | |
3156 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED) | |
3157 dtp->u.p.transfer = unformatted_write; | |
3158 else | |
3159 { | |
3160 if ((cf & IOPARM_DT_LIST_FORMAT) != 0) | |
3161 dtp->u.p.transfer = list_formatted_write; | |
3162 else | |
3163 dtp->u.p.transfer = formatted_transfer; | |
3164 } | |
3165 } | |
3166 | |
3167 /* Make sure that we don't do a read after a nonadvancing write. */ | |
3168 | |
3169 if (read_flag) | |
3170 { | |
3171 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp)) | |
3172 { | |
3173 generate_error (&dtp->common, LIBERROR_BAD_OPTION, | |
3174 "Cannot READ after a nonadvancing WRITE"); | |
3175 return; | |
3176 } | |
3177 } | |
3178 else | |
3179 { | |
3180 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar) | |
3181 dtp->u.p.current_unit->read_bad = 1; | |
3182 } | |
3183 | |
3184 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED) | |
3185 { | |
3186 #ifdef HAVE_USELOCALE | |
3187 dtp->u.p.old_locale = uselocale (c_locale); | |
3188 #else | |
3189 __gthread_mutex_lock (&old_locale_lock); | |
3190 if (!old_locale_ctr++) | |
3191 { | |
3192 old_locale = setlocale (LC_NUMERIC, NULL); | |
3193 setlocale (LC_NUMERIC, "C"); | |
3194 } | |
3195 __gthread_mutex_unlock (&old_locale_lock); | |
3196 #endif | |
3197 /* Start the data transfer if we are doing a formatted transfer. */ | |
3198 if ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0 | |
3199 && dtp->u.p.ionml == NULL) | |
3200 formatted_transfer (dtp, 0, NULL, 0, 0, 1); | |
3201 } | |
3202 } | |
3203 | |
3204 | |
3205 /* Initialize an array_loop_spec given the array descriptor. The function | |
3206 returns the index of the last element of the array, and also returns | |
3207 starting record, where the first I/O goes to (necessary in case of | |
3208 negative strides). */ | |
3209 | |
3210 gfc_offset | |
3211 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls, | |
3212 gfc_offset *start_record) | |
3213 { | |
3214 int rank = GFC_DESCRIPTOR_RANK(desc); | |
3215 int i; | |
3216 gfc_offset index; | |
3217 int empty; | |
3218 | |
3219 empty = 0; | |
3220 index = 1; | |
3221 *start_record = 0; | |
3222 | |
3223 for (i=0; i<rank; i++) | |
3224 { | |
3225 ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i); | |
3226 ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i); | |
3227 ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i); | |
3228 ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i); | |
3229 empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i) | |
3230 < GFC_DESCRIPTOR_LBOUND(desc,i)); | |
3231 | |
3232 if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0) | |
3233 { | |
3234 index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) | |
3235 * GFC_DESCRIPTOR_STRIDE(desc,i); | |
3236 } | |
3237 else | |
3238 { | |
3239 index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) | |
3240 * GFC_DESCRIPTOR_STRIDE(desc,i); | |
3241 *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1) | |
3242 * GFC_DESCRIPTOR_STRIDE(desc,i); | |
3243 } | |
3244 } | |
3245 | |
3246 if (empty) | |
3247 return 0; | |
3248 else | |
3249 return index; | |
3250 } | |
3251 | |
3252 /* Determine the index to the next record in an internal unit array by | |
3253 by incrementing through the array_loop_spec. */ | |
3254 | |
3255 gfc_offset | |
3256 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished) | |
3257 { | |
3258 int i, carry; | |
3259 gfc_offset index; | |
3260 | |
3261 carry = 1; | |
3262 index = 0; | |
3263 | |
3264 for (i = 0; i < dtp->u.p.current_unit->rank; i++) | |
3265 { | |
3266 if (carry) | |
3267 { | |
3268 ls[i].idx++; | |
3269 if (ls[i].idx > ls[i].end) | |
3270 { | |
3271 ls[i].idx = ls[i].start; | |
3272 carry = 1; | |
3273 } | |
3274 else | |
3275 carry = 0; | |
3276 } | |
3277 index = index + (ls[i].idx - ls[i].start) * ls[i].step; | |
3278 } | |
3279 | |
3280 *finished = carry; | |
3281 | |
3282 return index; | |
3283 } | |
3284 | |
3285 | |
3286 | |
3287 /* Skip to the end of the current record, taking care of an optional | |
3288 record marker of size bytes. If the file is not seekable, we | |
3289 read chunks of size MAX_READ until we get to the right | |
3290 position. */ | |
3291 | |
3292 static void | |
3293 skip_record (st_parameter_dt *dtp, ssize_t bytes) | |
3294 { | |
3295 ssize_t rlength, readb; | |
3296 #define MAX_READ 4096 | |
3297 char p[MAX_READ]; | |
3298 | |
3299 dtp->u.p.current_unit->bytes_left_subrecord += bytes; | |
3300 if (dtp->u.p.current_unit->bytes_left_subrecord == 0) | |
3301 return; | |
3302 | |
3303 /* Direct access files do not generate END conditions, | |
3304 only I/O errors. */ | |
3305 if (sseek (dtp->u.p.current_unit->s, | |
3306 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0) | |
3307 { | |
3308 /* Seeking failed, fall back to seeking by reading data. */ | |
3309 while (dtp->u.p.current_unit->bytes_left_subrecord > 0) | |
3310 { | |
3311 rlength = | |
3312 (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ? | |
3313 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord; | |
3314 | |
3315 readb = sread (dtp->u.p.current_unit->s, p, rlength); | |
3316 if (readb < 0) | |
3317 { | |
3318 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3319 return; | |
3320 } | |
3321 | |
3322 dtp->u.p.current_unit->bytes_left_subrecord -= readb; | |
3323 } | |
3324 return; | |
3325 } | |
3326 dtp->u.p.current_unit->bytes_left_subrecord = 0; | |
3327 } | |
3328 | |
3329 | |
3330 /* Advance to the next record reading unformatted files, taking | |
3331 care of subrecords. If complete_record is nonzero, we loop | |
3332 until all subrecords are cleared. */ | |
3333 | |
3334 static void | |
3335 next_record_r_unf (st_parameter_dt *dtp, int complete_record) | |
3336 { | |
3337 size_t bytes; | |
3338 | |
3339 bytes = compile_options.record_marker == 0 ? | |
3340 sizeof (GFC_INTEGER_4) : compile_options.record_marker; | |
3341 | |
3342 while(1) | |
3343 { | |
3344 | |
3345 /* Skip over tail */ | |
3346 | |
3347 skip_record (dtp, bytes); | |
3348 | |
3349 if ( ! (complete_record && dtp->u.p.current_unit->continued)) | |
3350 return; | |
3351 | |
3352 us_read (dtp, 1); | |
3353 } | |
3354 } | |
3355 | |
3356 | |
3357 static gfc_offset | |
3358 min_off (gfc_offset a, gfc_offset b) | |
3359 { | |
3360 return (a < b ? a : b); | |
3361 } | |
3362 | |
3363 | |
3364 /* Space to the next record for read mode. */ | |
3365 | |
3366 static void | |
3367 next_record_r (st_parameter_dt *dtp, int done) | |
3368 { | |
3369 gfc_offset record; | |
3370 int bytes_left; | |
3371 char p; | |
3372 int cc; | |
3373 | |
3374 switch (current_mode (dtp)) | |
3375 { | |
3376 /* No records in unformatted STREAM I/O. */ | |
3377 case UNFORMATTED_STREAM: | |
3378 return; | |
3379 | |
3380 case UNFORMATTED_SEQUENTIAL: | |
3381 next_record_r_unf (dtp, 1); | |
3382 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
3383 break; | |
3384 | |
3385 case FORMATTED_DIRECT: | |
3386 case UNFORMATTED_DIRECT: | |
3387 skip_record (dtp, dtp->u.p.current_unit->bytes_left); | |
3388 break; | |
3389 | |
3390 case FORMATTED_STREAM: | |
3391 case FORMATTED_SEQUENTIAL: | |
3392 /* read_sf has already terminated input because of an '\n', or | |
3393 we have hit EOF. */ | |
3394 if (dtp->u.p.sf_seen_eor) | |
3395 { | |
3396 dtp->u.p.sf_seen_eor = 0; | |
3397 break; | |
3398 } | |
3399 | |
3400 if (is_internal_unit (dtp)) | |
3401 { | |
3402 if (is_array_io (dtp)) | |
3403 { | |
3404 int finished; | |
3405 | |
3406 record = next_array_record (dtp, dtp->u.p.current_unit->ls, | |
3407 &finished); | |
3408 if (!done && finished) | |
3409 hit_eof (dtp); | |
3410 | |
3411 /* Now seek to this record. */ | |
3412 record = record * dtp->u.p.current_unit->recl; | |
3413 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) | |
3414 { | |
3415 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); | |
3416 break; | |
3417 } | |
3418 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
3419 } | |
3420 else | |
3421 { | |
3422 bytes_left = (int) dtp->u.p.current_unit->bytes_left; | |
3423 bytes_left = min_off (bytes_left, | |
3424 ssize (dtp->u.p.current_unit->s) | |
3425 - stell (dtp->u.p.current_unit->s)); | |
3426 if (sseek (dtp->u.p.current_unit->s, | |
3427 bytes_left, SEEK_CUR) < 0) | |
3428 { | |
3429 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); | |
3430 break; | |
3431 } | |
3432 dtp->u.p.current_unit->bytes_left | |
3433 = dtp->u.p.current_unit->recl; | |
3434 } | |
3435 break; | |
3436 } | |
3437 else if (dtp->u.p.current_unit->flags.cc != CC_NONE) | |
3438 { | |
3439 do | |
3440 { | |
3441 errno = 0; | |
3442 cc = fbuf_getc (dtp->u.p.current_unit); | |
3443 if (cc == EOF) | |
3444 { | |
3445 if (errno != 0) | |
3446 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3447 else | |
3448 { | |
3449 if (is_stream_io (dtp) | |
3450 || dtp->u.p.current_unit->pad_status == PAD_NO | |
3451 || dtp->u.p.current_unit->bytes_left | |
3452 == dtp->u.p.current_unit->recl) | |
3453 hit_eof (dtp); | |
3454 } | |
3455 break; | |
3456 } | |
3457 | |
3458 if (is_stream_io (dtp)) | |
3459 dtp->u.p.current_unit->strm_pos++; | |
3460 | |
3461 p = (char) cc; | |
3462 } | |
3463 while (p != '\n'); | |
3464 } | |
3465 break; | |
3466 } | |
3467 } | |
3468 | |
3469 | |
3470 /* Small utility function to write a record marker, taking care of | |
3471 byte swapping and of choosing the correct size. */ | |
3472 | |
3473 static int | |
3474 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf) | |
3475 { | |
3476 size_t len; | |
3477 GFC_INTEGER_4 buf4; | |
3478 GFC_INTEGER_8 buf8; | |
3479 | |
3480 if (compile_options.record_marker == 0) | |
3481 len = sizeof (GFC_INTEGER_4); | |
3482 else | |
3483 len = compile_options.record_marker; | |
3484 | |
3485 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */ | |
3486 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)) | |
3487 { | |
3488 switch (len) | |
3489 { | |
3490 case sizeof (GFC_INTEGER_4): | |
3491 buf4 = buf; | |
3492 return swrite (dtp->u.p.current_unit->s, &buf4, len); | |
3493 break; | |
3494 | |
3495 case sizeof (GFC_INTEGER_8): | |
3496 buf8 = buf; | |
3497 return swrite (dtp->u.p.current_unit->s, &buf8, len); | |
3498 break; | |
3499 | |
3500 default: | |
3501 runtime_error ("Illegal value for record marker"); | |
3502 break; | |
3503 } | |
3504 } | |
3505 else | |
3506 { | |
3507 uint32_t u32; | |
3508 uint64_t u64; | |
3509 switch (len) | |
3510 { | |
3511 case sizeof (GFC_INTEGER_4): | |
3512 buf4 = buf; | |
3513 memcpy (&u32, &buf4, sizeof (u32)); | |
3514 u32 = __builtin_bswap32 (u32); | |
3515 return swrite (dtp->u.p.current_unit->s, &u32, len); | |
3516 break; | |
3517 | |
3518 case sizeof (GFC_INTEGER_8): | |
3519 buf8 = buf; | |
3520 memcpy (&u64, &buf8, sizeof (u64)); | |
3521 u64 = __builtin_bswap64 (u64); | |
3522 return swrite (dtp->u.p.current_unit->s, &u64, len); | |
3523 break; | |
3524 | |
3525 default: | |
3526 runtime_error ("Illegal value for record marker"); | |
3527 break; | |
3528 } | |
3529 } | |
3530 | |
3531 } | |
3532 | |
3533 /* Position to the next (sub)record in write mode for | |
3534 unformatted sequential files. */ | |
3535 | |
3536 static void | |
3537 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord) | |
3538 { | |
3539 gfc_offset m, m_write, record_marker; | |
3540 | |
3541 /* Bytes written. */ | |
3542 m = dtp->u.p.current_unit->recl_subrecord | |
3543 - dtp->u.p.current_unit->bytes_left_subrecord; | |
3544 | |
3545 if (compile_options.record_marker == 0) | |
3546 record_marker = sizeof (GFC_INTEGER_4); | |
3547 else | |
3548 record_marker = compile_options.record_marker; | |
3549 | |
3550 /* Seek to the head and overwrite the bogus length with the real | |
3551 length. */ | |
3552 | |
3553 if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker, | |
3554 SEEK_CUR) < 0)) | |
3555 goto io_error; | |
3556 | |
3557 if (next_subrecord) | |
3558 m_write = -m; | |
3559 else | |
3560 m_write = m; | |
3561 | |
3562 if (unlikely (write_us_marker (dtp, m_write) < 0)) | |
3563 goto io_error; | |
3564 | |
3565 /* Seek past the end of the current record. */ | |
3566 | |
3567 if (unlikely (sseek (dtp->u.p.current_unit->s, m, SEEK_CUR) < 0)) | |
3568 goto io_error; | |
3569 | |
3570 /* Write the length tail. If we finish a record containing | |
3571 subrecords, we write out the negative length. */ | |
3572 | |
3573 if (dtp->u.p.current_unit->continued) | |
3574 m_write = -m; | |
3575 else | |
3576 m_write = m; | |
3577 | |
3578 if (unlikely (write_us_marker (dtp, m_write) < 0)) | |
3579 goto io_error; | |
3580 | |
3581 return; | |
3582 | |
3583 io_error: | |
3584 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3585 return; | |
3586 | |
3587 } | |
3588 | |
3589 | |
3590 /* Utility function like memset() but operating on streams. Return | |
3591 value is same as for POSIX write(). */ | |
3592 | |
3593 static ssize_t | |
3594 sset (stream *s, int c, ssize_t nbyte) | |
3595 { | |
3596 #define WRITE_CHUNK 256 | |
3597 char p[WRITE_CHUNK]; | |
3598 ssize_t bytes_left, trans; | |
3599 | |
3600 if (nbyte < WRITE_CHUNK) | |
3601 memset (p, c, nbyte); | |
3602 else | |
3603 memset (p, c, WRITE_CHUNK); | |
3604 | |
3605 bytes_left = nbyte; | |
3606 while (bytes_left > 0) | |
3607 { | |
3608 trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK; | |
3609 trans = swrite (s, p, trans); | |
3610 if (trans <= 0) | |
3611 return trans; | |
3612 bytes_left -= trans; | |
3613 } | |
3614 | |
3615 return nbyte - bytes_left; | |
3616 } | |
3617 | |
3618 | |
3619 /* Finish up a record according to the legacy carriagecontrol type, based | |
3620 on the first character in the record. */ | |
3621 | |
3622 static void | |
3623 next_record_cc (st_parameter_dt *dtp) | |
3624 { | |
3625 /* Only valid with CARRIAGECONTROL=FORTRAN. */ | |
3626 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN) | |
3627 return; | |
3628 | |
3629 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); | |
3630 if (dtp->u.p.cc.len > 0) | |
3631 { | |
3632 char *p = fbuf_alloc (dtp->u.p.current_unit, dtp->u.p.cc.len); | |
3633 if (!p) | |
3634 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3635 | |
3636 /* Output CR for the first character with default CC setting. */ | |
3637 *(p++) = dtp->u.p.cc.u.end; | |
3638 if (dtp->u.p.cc.len > 1) | |
3639 *p = dtp->u.p.cc.u.end; | |
3640 } | |
3641 } | |
3642 | |
3643 /* Position to the next record in write mode. */ | |
3644 | |
3645 static void | |
3646 next_record_w (st_parameter_dt *dtp, int done) | |
3647 { | |
3648 gfc_offset m, record, max_pos; | |
3649 int length; | |
3650 | |
3651 /* Zero counters for X- and T-editing. */ | |
3652 max_pos = dtp->u.p.max_pos; | |
3653 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0; | |
3654 | |
3655 switch (current_mode (dtp)) | |
3656 { | |
3657 /* No records in unformatted STREAM I/O. */ | |
3658 case UNFORMATTED_STREAM: | |
3659 return; | |
3660 | |
3661 case FORMATTED_DIRECT: | |
3662 if (dtp->u.p.current_unit->bytes_left == 0) | |
3663 break; | |
3664 | |
3665 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); | |
3666 fbuf_flush (dtp->u.p.current_unit, WRITING); | |
3667 if (sset (dtp->u.p.current_unit->s, ' ', | |
3668 dtp->u.p.current_unit->bytes_left) | |
3669 != dtp->u.p.current_unit->bytes_left) | |
3670 goto io_error; | |
3671 | |
3672 break; | |
3673 | |
3674 case UNFORMATTED_DIRECT: | |
3675 if (dtp->u.p.current_unit->bytes_left > 0) | |
3676 { | |
3677 length = (int) dtp->u.p.current_unit->bytes_left; | |
3678 if (sset (dtp->u.p.current_unit->s, 0, length) != length) | |
3679 goto io_error; | |
3680 } | |
3681 break; | |
3682 | |
3683 case UNFORMATTED_SEQUENTIAL: | |
3684 next_record_w_unf (dtp, 0); | |
3685 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
3686 break; | |
3687 | |
3688 case FORMATTED_STREAM: | |
3689 case FORMATTED_SEQUENTIAL: | |
3690 | |
3691 if (is_internal_unit (dtp)) | |
3692 { | |
3693 char *p; | |
3694 if (is_array_io (dtp)) | |
3695 { | |
3696 int finished; | |
3697 | |
3698 length = (int) dtp->u.p.current_unit->bytes_left; | |
3699 | |
3700 /* If the farthest position reached is greater than current | |
3701 position, adjust the position and set length to pad out | |
3702 whats left. Otherwise just pad whats left. | |
3703 (for character array unit) */ | |
3704 m = dtp->u.p.current_unit->recl | |
3705 - dtp->u.p.current_unit->bytes_left; | |
3706 if (max_pos > m) | |
3707 { | |
3708 length = (int) (max_pos - m); | |
3709 if (sseek (dtp->u.p.current_unit->s, | |
3710 length, SEEK_CUR) < 0) | |
3711 { | |
3712 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); | |
3713 return; | |
3714 } | |
3715 length = (int) (dtp->u.p.current_unit->recl - max_pos); | |
3716 } | |
3717 | |
3718 p = write_block (dtp, length); | |
3719 if (p == NULL) | |
3720 return; | |
3721 | |
3722 if (unlikely (is_char4_unit (dtp))) | |
3723 { | |
3724 gfc_char4_t *p4 = (gfc_char4_t *) p; | |
3725 memset4 (p4, ' ', length); | |
3726 } | |
3727 else | |
3728 memset (p, ' ', length); | |
3729 | |
3730 /* Now that the current record has been padded out, | |
3731 determine where the next record in the array is. */ | |
3732 record = next_array_record (dtp, dtp->u.p.current_unit->ls, | |
3733 &finished); | |
3734 if (finished) | |
3735 dtp->u.p.current_unit->endfile = AT_ENDFILE; | |
3736 | |
3737 /* Now seek to this record */ | |
3738 record = record * dtp->u.p.current_unit->recl; | |
3739 | |
3740 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0) | |
3741 { | |
3742 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); | |
3743 return; | |
3744 } | |
3745 | |
3746 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl; | |
3747 } | |
3748 else | |
3749 { | |
3750 length = 1; | |
3751 | |
3752 /* If this is the last call to next_record move to the farthest | |
3753 position reached and set length to pad out the remainder | |
3754 of the record. (for character scaler unit) */ | |
3755 if (done) | |
3756 { | |
3757 m = dtp->u.p.current_unit->recl | |
3758 - dtp->u.p.current_unit->bytes_left; | |
3759 if (max_pos > m) | |
3760 { | |
3761 length = (int) (max_pos - m); | |
3762 if (sseek (dtp->u.p.current_unit->s, | |
3763 length, SEEK_CUR) < 0) | |
3764 { | |
3765 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL); | |
3766 return; | |
3767 } | |
3768 length = (int) (dtp->u.p.current_unit->recl - max_pos); | |
3769 } | |
3770 else | |
3771 length = (int) dtp->u.p.current_unit->bytes_left; | |
3772 } | |
3773 if (length > 0) | |
3774 { | |
3775 p = write_block (dtp, length); | |
3776 if (p == NULL) | |
3777 return; | |
3778 | |
3779 if (unlikely (is_char4_unit (dtp))) | |
3780 { | |
3781 gfc_char4_t *p4 = (gfc_char4_t *) p; | |
3782 memset4 (p4, (gfc_char4_t) ' ', length); | |
3783 } | |
3784 else | |
3785 memset (p, ' ', length); | |
3786 } | |
3787 } | |
3788 } | |
3789 /* Handle legacy CARRIAGECONTROL line endings. */ | |
3790 else if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN) | |
3791 next_record_cc (dtp); | |
3792 else | |
3793 { | |
3794 /* Skip newlines for CC=CC_NONE. */ | |
3795 const int len = (dtp->u.p.current_unit->flags.cc == CC_NONE) | |
3796 ? 0 | |
3797 #ifdef HAVE_CRLF | |
3798 : 2; | |
3799 #else | |
3800 : 1; | |
3801 #endif | |
3802 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); | |
3803 if (dtp->u.p.current_unit->flags.cc != CC_NONE) | |
3804 { | |
3805 char *p = fbuf_alloc (dtp->u.p.current_unit, len); | |
3806 if (!p) | |
3807 goto io_error; | |
3808 #ifdef HAVE_CRLF | |
3809 *(p++) = '\r'; | |
3810 #endif | |
3811 *p = '\n'; | |
3812 } | |
3813 if (is_stream_io (dtp)) | |
3814 { | |
3815 dtp->u.p.current_unit->strm_pos += len; | |
3816 if (dtp->u.p.current_unit->strm_pos | |
3817 < ssize (dtp->u.p.current_unit->s)) | |
3818 unit_truncate (dtp->u.p.current_unit, | |
3819 dtp->u.p.current_unit->strm_pos - 1, | |
3820 &dtp->common); | |
3821 } | |
3822 } | |
3823 | |
3824 break; | |
3825 | |
3826 io_error: | |
3827 generate_error (&dtp->common, LIBERROR_OS, NULL); | |
3828 break; | |
3829 } | |
3830 } | |
3831 | |
3832 /* Position to the next record, which means moving to the end of the | |
3833 current record. This can happen under several different | |
3834 conditions. If the done flag is not set, we get ready to process | |
3835 the next record. */ | |
3836 | |
3837 void | |
3838 next_record (st_parameter_dt *dtp, int done) | |
3839 { | |
3840 gfc_offset fp; /* File position. */ | |
3841 | |
3842 dtp->u.p.current_unit->read_bad = 0; | |
3843 | |
3844 if (dtp->u.p.mode == READING) | |
3845 next_record_r (dtp, done); | |
3846 else | |
3847 next_record_w (dtp, done); | |
3848 | |
3849 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); | |
3850 | |
3851 if (!is_stream_io (dtp)) | |
3852 { | |
3853 /* Since we have changed the position, set it to unspecified so | |
3854 that INQUIRE(POSITION=) knows it needs to look into it. */ | |
3855 if (done) | |
3856 dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED; | |
3857 | |
3858 dtp->u.p.current_unit->current_record = 0; | |
3859 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT) | |
3860 { | |
3861 fp = stell (dtp->u.p.current_unit->s); | |
3862 /* Calculate next record, rounding up partial records. */ | |
3863 dtp->u.p.current_unit->last_record = | |
3864 (fp + dtp->u.p.current_unit->recl) / | |
3865 dtp->u.p.current_unit->recl - 1; | |
3866 } | |
3867 else | |
3868 dtp->u.p.current_unit->last_record++; | |
3869 } | |
3870 | |
3871 if (!done) | |
3872 pre_position (dtp); | |
3873 | |
3874 smarkeor (dtp->u.p.current_unit->s); | |
3875 } | |
3876 | |
3877 | |
3878 /* Finalize the current data transfer. For a nonadvancing transfer, | |
3879 this means advancing to the next record. For internal units close the | |
3880 stream associated with the unit. */ | |
3881 | |
3882 static void | |
3883 finalize_transfer (st_parameter_dt *dtp) | |
3884 { | |
3885 GFC_INTEGER_4 cf = dtp->common.flags; | |
3886 | |
3887 if ((dtp->u.p.ionml != NULL) | |
3888 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0) | |
3889 { | |
3890 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0) | |
3891 namelist_read (dtp); | |
3892 else | |
3893 namelist_write (dtp); | |
3894 } | |
3895 | |
3896 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) | |
3897 *dtp->size = dtp->u.p.current_unit->size_used; | |
3898 | |
3899 if (dtp->u.p.eor_condition) | |
3900 { | |
3901 generate_error (&dtp->common, LIBERROR_EOR, NULL); | |
3902 goto done; | |
3903 } | |
3904 | |
3905 if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0)) | |
3906 { | |
3907 if (cf & IOPARM_DT_HAS_FORMAT) | |
3908 { | |
3909 free (dtp->u.p.fmt); | |
3910 free (dtp->format); | |
3911 } | |
3912 return; | |
3913 } | |
3914 | |
3915 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) | |
3916 { | |
3917 if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL) | |
3918 dtp->u.p.current_unit->current_record = 0; | |
3919 goto done; | |
3920 } | |
3921 | |
3922 dtp->u.p.transfer = NULL; | |
3923 if (dtp->u.p.current_unit == NULL) | |
3924 goto done; | |
3925 | |
3926 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING) | |
3927 { | |
3928 finish_list_read (dtp); | |
3929 goto done; | |
3930 } | |
3931 | |
3932 if (dtp->u.p.mode == WRITING) | |
3933 dtp->u.p.current_unit->previous_nonadvancing_write | |
3934 = dtp->u.p.advance_status == ADVANCE_NO; | |
3935 | |
3936 if (is_stream_io (dtp)) | |
3937 { | |
3938 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED | |
3939 && dtp->u.p.advance_status != ADVANCE_NO) | |
3940 next_record (dtp, 1); | |
3941 | |
3942 goto done; | |
3943 } | |
3944 | |
3945 dtp->u.p.current_unit->current_record = 0; | |
3946 | |
3947 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar) | |
3948 { | |
3949 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); | |
3950 dtp->u.p.seen_dollar = 0; | |
3951 goto done; | |
3952 } | |
3953 | |
3954 /* For non-advancing I/O, save the current maximum position for use in the | |
3955 next I/O operation if needed. */ | |
3956 if (dtp->u.p.advance_status == ADVANCE_NO) | |
3957 { | |
3958 if (dtp->u.p.skips > 0) | |
3959 { | |
3960 int tmp; | |
3961 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces); | |
3962 tmp = (int)(dtp->u.p.current_unit->recl | |
3963 - dtp->u.p.current_unit->bytes_left); | |
3964 dtp->u.p.max_pos = | |
3965 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp; | |
3966 dtp->u.p.skips = 0; | |
3967 } | |
3968 int bytes_written = (int) (dtp->u.p.current_unit->recl | |
3969 - dtp->u.p.current_unit->bytes_left); | |
3970 dtp->u.p.current_unit->saved_pos = | |
3971 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0; | |
3972 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode); | |
3973 goto done; | |
3974 } | |
3975 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED | |
3976 && dtp->u.p.mode == WRITING && !is_internal_unit (dtp)) | |
3977 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END); | |
3978 | |
3979 dtp->u.p.current_unit->saved_pos = 0; | |
3980 dtp->u.p.current_unit->last_char = EOF - 1; | |
3981 next_record (dtp, 1); | |
3982 | |
3983 done: | |
3984 #ifdef HAVE_USELOCALE | |
3985 if (dtp->u.p.old_locale != (locale_t) 0) | |
3986 { | |
3987 uselocale (dtp->u.p.old_locale); | |
3988 dtp->u.p.old_locale = (locale_t) 0; | |
3989 } | |
3990 #else | |
3991 __gthread_mutex_lock (&old_locale_lock); | |
3992 if (!--old_locale_ctr) | |
3993 { | |
3994 setlocale (LC_NUMERIC, old_locale); | |
3995 old_locale = NULL; | |
3996 } | |
3997 __gthread_mutex_unlock (&old_locale_lock); | |
3998 #endif | |
3999 } | |
4000 | |
4001 /* Transfer function for IOLENGTH. It doesn't actually do any | |
4002 data transfer, it just updates the length counter. */ | |
4003 | |
4004 static void | |
4005 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)), | |
4006 void *dest __attribute__ ((unused)), | |
4007 int kind __attribute__((unused)), | |
4008 size_t size, size_t nelems) | |
4009 { | |
4010 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) | |
4011 *dtp->iolength += (GFC_IO_INT) (size * nelems); | |
4012 } | |
4013 | |
4014 | |
4015 /* Initialize the IOLENGTH data transfer. This function is in essence | |
4016 a very much simplified version of data_transfer_init(), because it | |
4017 doesn't have to deal with units at all. */ | |
4018 | |
4019 static void | |
4020 iolength_transfer_init (st_parameter_dt *dtp) | |
4021 { | |
4022 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0) | |
4023 *dtp->iolength = 0; | |
4024 | |
4025 memset (&dtp->u.p, 0, sizeof (dtp->u.p)); | |
4026 | |
4027 /* Set up the subroutine that will handle the transfers. */ | |
4028 | |
4029 dtp->u.p.transfer = iolength_transfer; | |
4030 } | |
4031 | |
4032 | |
4033 /* Library entry point for the IOLENGTH form of the INQUIRE | |
4034 statement. The IOLENGTH form requires no I/O to be performed, but | |
4035 it must still be a runtime library call so that we can determine | |
4036 the iolength for dynamic arrays and such. */ | |
4037 | |
4038 extern void st_iolength (st_parameter_dt *); | |
4039 export_proto(st_iolength); | |
4040 | |
4041 void | |
4042 st_iolength (st_parameter_dt *dtp) | |
4043 { | |
4044 library_start (&dtp->common); | |
4045 iolength_transfer_init (dtp); | |
4046 } | |
4047 | |
4048 extern void st_iolength_done (st_parameter_dt *); | |
4049 export_proto(st_iolength_done); | |
4050 | |
4051 void | |
4052 st_iolength_done (st_parameter_dt *dtp __attribute__((unused))) | |
4053 { | |
4054 free_ionml (dtp); | |
4055 library_end (); | |
4056 } | |
4057 | |
4058 | |
4059 /* The READ statement. */ | |
4060 | |
4061 extern void st_read (st_parameter_dt *); | |
4062 export_proto(st_read); | |
4063 | |
4064 void | |
4065 st_read (st_parameter_dt *dtp) | |
4066 { | |
4067 library_start (&dtp->common); | |
4068 | |
4069 data_transfer_init (dtp, 1); | |
4070 } | |
4071 | |
4072 extern void st_read_done (st_parameter_dt *); | |
4073 export_proto(st_read_done); | |
4074 | |
4075 void | |
4076 st_read_done (st_parameter_dt *dtp) | |
4077 { | |
4078 finalize_transfer (dtp); | |
4079 | |
4080 free_ionml (dtp); | |
4081 | |
4082 /* If this is a parent READ statement we do not need to retain the | |
4083 internal unit structure for child use. */ | |
4084 if (dtp->u.p.current_unit != NULL | |
4085 && dtp->u.p.current_unit->child_dtio == 0) | |
4086 { | |
4087 if (is_internal_unit (dtp) && | |
4088 (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0) | |
4089 { | |
4090 free (dtp->u.p.current_unit->filename); | |
4091 dtp->u.p.current_unit->filename = NULL; | |
4092 free (dtp->u.p.current_unit->s); | |
4093 dtp->u.p.current_unit->s = NULL; | |
4094 if (dtp->u.p.current_unit->ls) | |
4095 free (dtp->u.p.current_unit->ls); | |
4096 dtp->u.p.current_unit->ls = NULL; | |
4097 } | |
4098 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) | |
4099 { | |
4100 free_format_data (dtp->u.p.fmt); | |
4101 free_format (dtp); | |
4102 } | |
4103 unlock_unit (dtp->u.p.current_unit); | |
4104 } | |
4105 | |
4106 library_end (); | |
4107 } | |
4108 | |
4109 extern void st_write (st_parameter_dt *); | |
4110 export_proto(st_write); | |
4111 | |
4112 void | |
4113 st_write (st_parameter_dt *dtp) | |
4114 { | |
4115 library_start (&dtp->common); | |
4116 data_transfer_init (dtp, 0); | |
4117 } | |
4118 | |
4119 extern void st_write_done (st_parameter_dt *); | |
4120 export_proto(st_write_done); | |
4121 | |
4122 void | |
4123 st_write_done (st_parameter_dt *dtp) | |
4124 { | |
4125 finalize_transfer (dtp); | |
4126 | |
4127 if (dtp->u.p.current_unit != NULL | |
4128 && dtp->u.p.current_unit->child_dtio == 0) | |
4129 { | |
4130 /* Deal with endfile conditions associated with sequential files. */ | |
4131 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
4132 switch (dtp->u.p.current_unit->endfile) | |
4133 { | |
4134 case AT_ENDFILE: /* Remain at the endfile record. */ | |
4135 break; | |
4136 | |
4137 case AFTER_ENDFILE: | |
4138 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */ | |
4139 break; | |
4140 | |
4141 case NO_ENDFILE: | |
4142 /* Get rid of whatever is after this record. */ | |
4143 if (!is_internal_unit (dtp)) | |
4144 unit_truncate (dtp->u.p.current_unit, | |
4145 stell (dtp->u.p.current_unit->s), | |
4146 &dtp->common); | |
4147 dtp->u.p.current_unit->endfile = AT_ENDFILE; | |
4148 break; | |
4149 } | |
4150 | |
4151 free_ionml (dtp); | |
4152 | |
4153 /* If this is a parent WRITE statement we do not need to retain the | |
4154 internal unit structure for child use. */ | |
4155 if (is_internal_unit (dtp) && | |
4156 (dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0) | |
4157 { | |
4158 free (dtp->u.p.current_unit->filename); | |
4159 dtp->u.p.current_unit->filename = NULL; | |
4160 free (dtp->u.p.current_unit->s); | |
4161 dtp->u.p.current_unit->s = NULL; | |
4162 if (dtp->u.p.current_unit->ls) | |
4163 free (dtp->u.p.current_unit->ls); | |
4164 dtp->u.p.current_unit->ls = NULL; | |
4165 } | |
4166 if (is_internal_unit (dtp) || dtp->u.p.format_not_saved) | |
4167 { | |
4168 free_format_data (dtp->u.p.fmt); | |
4169 free_format (dtp); | |
4170 } | |
4171 unlock_unit (dtp->u.p.current_unit); | |
4172 } | |
4173 library_end (); | |
4174 } | |
4175 | |
4176 | |
4177 /* F2003: This is a stub for the runtime portion of the WAIT statement. */ | |
4178 void | |
4179 st_wait (st_parameter_wait *wtp __attribute__((unused))) | |
4180 { | |
4181 } | |
4182 | |
4183 | |
4184 /* Receives the scalar information for namelist objects and stores it | |
4185 in a linked list of namelist_info types. */ | |
4186 | |
4187 static void | |
4188 set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name, | |
4189 GFC_INTEGER_4 len, gfc_charlen_type string_length, | |
4190 GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable) | |
4191 { | |
4192 namelist_info *t1 = NULL; | |
4193 namelist_info *nml; | |
4194 size_t var_name_len = strlen (var_name); | |
4195 | |
4196 nml = (namelist_info*) xmalloc (sizeof (namelist_info)); | |
4197 | |
4198 nml->mem_pos = var_addr; | |
4199 nml->dtio_sub = dtio_sub; | |
4200 nml->vtable = vtable; | |
4201 | |
4202 nml->var_name = (char*) xmalloc (var_name_len + 1); | |
4203 memcpy (nml->var_name, var_name, var_name_len); | |
4204 nml->var_name[var_name_len] = '\0'; | |
4205 | |
4206 nml->len = (int) len; | |
4207 nml->string_length = (index_type) string_length; | |
4208 | |
4209 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK); | |
4210 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT); | |
4211 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT); | |
4212 | |
4213 if (nml->var_rank > 0) | |
4214 { | |
4215 nml->dim = (descriptor_dimension*) | |
4216 xmallocarray (nml->var_rank, sizeof (descriptor_dimension)); | |
4217 nml->ls = (array_loop_spec*) | |
4218 xmallocarray (nml->var_rank, sizeof (array_loop_spec)); | |
4219 } | |
4220 else | |
4221 { | |
4222 nml->dim = NULL; | |
4223 nml->ls = NULL; | |
4224 } | |
4225 | |
4226 nml->next = NULL; | |
4227 | |
4228 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0) | |
4229 { | |
4230 dtp->common.flags |= IOPARM_DT_IONML_SET; | |
4231 dtp->u.p.ionml = nml; | |
4232 } | |
4233 else | |
4234 { | |
4235 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next); | |
4236 t1->next = nml; | |
4237 } | |
4238 } | |
4239 | |
4240 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *, | |
4241 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4); | |
4242 export_proto(st_set_nml_var); | |
4243 | |
4244 void | |
4245 st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name, | |
4246 GFC_INTEGER_4 len, gfc_charlen_type string_length, | |
4247 GFC_INTEGER_4 dtype) | |
4248 { | |
4249 set_nml_var (dtp, var_addr, var_name, len, string_length, | |
4250 dtype, NULL, NULL); | |
4251 } | |
4252 | |
4253 | |
4254 /* Essentially the same as previous but carrying the dtio procedure | |
4255 and the vtable as additional arguments. */ | |
4256 extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *, | |
4257 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4, | |
4258 void *, void *); | |
4259 export_proto(st_set_nml_dtio_var); | |
4260 | |
4261 | |
4262 void | |
4263 st_set_nml_dtio_var (st_parameter_dt *dtp, void *var_addr, char *var_name, | |
4264 GFC_INTEGER_4 len, gfc_charlen_type string_length, | |
4265 GFC_INTEGER_4 dtype, void *dtio_sub, void *vtable) | |
4266 { | |
4267 set_nml_var (dtp, var_addr, var_name, len, string_length, | |
4268 dtype, dtio_sub, vtable); | |
4269 } | |
4270 | |
4271 /* Store the dimensional information for the namelist object. */ | |
4272 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4, | |
4273 index_type, index_type, | |
4274 index_type); | |
4275 export_proto(st_set_nml_var_dim); | |
4276 | |
4277 void | |
4278 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim, | |
4279 index_type stride, index_type lbound, | |
4280 index_type ubound) | |
4281 { | |
4282 namelist_info *nml; | |
4283 int n; | |
4284 | |
4285 n = (int)n_dim; | |
4286 | |
4287 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next); | |
4288 | |
4289 GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride); | |
4290 } | |
4291 | |
4292 | |
4293 /* Once upon a time, a poor innocent Fortran program was reading a | |
4294 file, when suddenly it hit the end-of-file (EOF). Unfortunately | |
4295 the OS doesn't tell whether we're at the EOF or whether we already | |
4296 went past it. Luckily our hero, libgfortran, keeps track of this. | |
4297 Call this function when you detect an EOF condition. See Section | |
4298 9.10.2 in F2003. */ | |
4299 | |
4300 void | |
4301 hit_eof (st_parameter_dt *dtp) | |
4302 { | |
4303 dtp->u.p.current_unit->flags.position = POSITION_APPEND; | |
4304 | |
4305 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL) | |
4306 switch (dtp->u.p.current_unit->endfile) | |
4307 { | |
4308 case NO_ENDFILE: | |
4309 case AT_ENDFILE: | |
4310 generate_error (&dtp->common, LIBERROR_END, NULL); | |
4311 if (!is_internal_unit (dtp) && !dtp->u.p.namelist_mode) | |
4312 { | |
4313 dtp->u.p.current_unit->endfile = AFTER_ENDFILE; | |
4314 dtp->u.p.current_unit->current_record = 0; | |
4315 } | |
4316 else | |
4317 dtp->u.p.current_unit->endfile = AT_ENDFILE; | |
4318 break; | |
4319 | |
4320 case AFTER_ENDFILE: | |
4321 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL); | |
4322 dtp->u.p.current_unit->current_record = 0; | |
4323 break; | |
4324 } | |
4325 else | |
4326 { | |
4327 /* Non-sequential files don't have an ENDFILE record, so we | |
4328 can't be at AFTER_ENDFILE. */ | |
4329 dtp->u.p.current_unit->endfile = AT_ENDFILE; | |
4330 generate_error (&dtp->common, LIBERROR_END, NULL); | |
4331 dtp->u.p.current_unit->current_record = 0; | |
4332 } | |
4333 } |