1 /* Copyright (C) 2002-2016 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
6 This file is part of the GNU Fortran runtime library (libgfortran).
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)
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.
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.
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/>. */
28 /* transfer.c -- Top level handling of data transfer statements. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
50 statement. For READ (and for backwards compatibily: for WRITE), one has
55 transfer_character_wide
63 transfer_integer_write
64 transfer_logical_write
65 transfer_character_write
66 transfer_character_wide_write
68 transfer_complex_write
69 transfer_real128_write
70 transfer_complex128_write
72 These subroutines do not return status. The *128 functions
73 are in the file transfer128.c.
75 The last call is a call to st_[read|write]_done(). While
76 something can easily go wrong with the initial st_read() or
77 st_write(), an error inhibits any data from actually being
80 extern void transfer_integer (st_parameter_dt
*, void *, int);
81 export_proto(transfer_integer
);
83 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
84 export_proto(transfer_integer_write
);
86 extern void transfer_real (st_parameter_dt
*, void *, int);
87 export_proto(transfer_real
);
89 extern void transfer_real_write (st_parameter_dt
*, void *, int);
90 export_proto(transfer_real_write
);
92 extern void transfer_logical (st_parameter_dt
*, void *, int);
93 export_proto(transfer_logical
);
95 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
96 export_proto(transfer_logical_write
);
98 extern void transfer_character (st_parameter_dt
*, void *, int);
99 export_proto(transfer_character
);
101 extern void transfer_character_write (st_parameter_dt
*, void *, int);
102 export_proto(transfer_character_write
);
104 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
105 export_proto(transfer_character_wide
);
107 extern void transfer_character_wide_write (st_parameter_dt
*,
109 export_proto(transfer_character_wide_write
);
111 extern void transfer_complex (st_parameter_dt
*, void *, int);
112 export_proto(transfer_complex
);
114 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
115 export_proto(transfer_complex_write
);
117 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
119 export_proto(transfer_array
);
121 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
123 export_proto(transfer_array_write
);
125 /* User defined derived type input/output. */
127 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
128 export_proto(transfer_derived
);
131 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
132 export_proto(transfer_derived_write
);
134 static void us_read (st_parameter_dt
*, int);
135 static void us_write (st_parameter_dt
*, int);
136 static void next_record_r_unf (st_parameter_dt
*, int);
137 static void next_record_w_unf (st_parameter_dt
*, int);
139 static const st_option advance_opt
[] = {
140 {"yes", ADVANCE_YES
},
146 static const st_option decimal_opt
[] = {
147 {"point", DECIMAL_POINT
},
148 {"comma", DECIMAL_COMMA
},
152 static const st_option round_opt
[] = {
154 {"down", ROUND_DOWN
},
155 {"zero", ROUND_ZERO
},
156 {"nearest", ROUND_NEAREST
},
157 {"compatible", ROUND_COMPATIBLE
},
158 {"processor_defined", ROUND_PROCDEFINED
},
163 static const st_option sign_opt
[] = {
165 {"suppress", SIGN_SS
},
166 {"processor_defined", SIGN_S
},
170 static const st_option blank_opt
[] = {
171 {"null", BLANK_NULL
},
172 {"zero", BLANK_ZERO
},
176 static const st_option delim_opt
[] = {
177 {"apostrophe", DELIM_APOSTROPHE
},
178 {"quote", DELIM_QUOTE
},
179 {"none", DELIM_NONE
},
183 static const st_option pad_opt
[] = {
190 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
191 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
197 current_mode (st_parameter_dt
*dtp
)
201 m
= FORM_UNSPECIFIED
;
203 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
205 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
206 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
208 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
210 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
211 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
213 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
215 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
216 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
223 /* Mid level data transfer statements. */
225 /* Read sequential file - internal unit */
228 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
230 static char *empty_string
[0];
234 /* Zero size array gives internal unit len of 0. Nothing to read. */
235 if (dtp
->internal_unit_len
== 0
236 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
239 /* If we have seen an eor previously, return a length of 0. The
240 caller is responsible for correctly padding the input field. */
241 if (dtp
->u
.p
.sf_seen_eor
)
244 /* Just return something that isn't a NULL pointer, otherwise the
245 caller thinks an error occurred. */
246 return (char*) empty_string
;
250 if (is_char4_unit(dtp
))
253 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
255 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
256 for (i
= 0; i
< *length
; i
++, p
++)
257 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
260 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
262 if (unlikely (lorig
> *length
))
268 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
270 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
271 dtp
->u
.p
.current_unit
->has_size
)
272 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *length
;
278 /* When reading sequential formatted records we have a problem. We
279 don't know how long the line is until we read the trailing newline,
280 and we don't want to read too much. If we read too much, we might
281 have to do a physical seek backwards depending on how much data is
282 present, and devices like terminals aren't seekable and would cause
285 Given this, the solution is to read a byte at a time, stopping if
286 we hit the newline. For small allocations, we use a static buffer.
287 For larger allocations, we are forced to allocate memory on the
288 heap. Hopefully this won't happen very often. */
290 /* Read sequential file - external unit */
293 read_sf (st_parameter_dt
*dtp
, int * length
)
295 static char *empty_string
[0];
297 int n
, lorig
, seen_comma
;
299 /* If we have seen an eor previously, return a length of 0. The
300 caller is responsible for correctly padding the input field. */
301 if (dtp
->u
.p
.sf_seen_eor
)
304 /* Just return something that isn't a NULL pointer, otherwise the
305 caller thinks an error occurred. */
306 return (char*) empty_string
;
311 /* Read data into format buffer and scan through it. */
316 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
319 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
320 && (q
== '\n' || q
== '\r'))
322 /* Unexpected end of line. Set the position. */
323 dtp
->u
.p
.sf_seen_eor
= 1;
325 /* If we see an EOR during non-advancing I/O, we need to skip
326 the rest of the I/O statement. Set the corresponding flag. */
327 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
328 dtp
->u
.p
.eor_condition
= 1;
330 /* If we encounter a CR, it might be a CRLF. */
331 if (q
== '\r') /* Probably a CRLF */
333 /* See if there is an LF. */
334 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
336 dtp
->u
.p
.sf_seen_eor
= 2;
337 else if (q2
!= EOF
) /* Oops, seek back. */
338 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
341 /* Without padding, terminate the I/O statement without assigning
342 the value. With padding, the value still needs to be assigned,
343 so we can just continue with a short read. */
344 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
346 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
353 /* Short circuit the read if a comma is found during numeric input.
354 The flag is set to zero during character reads so that commas in
355 strings are not ignored */
357 if (dtp
->u
.p
.sf_read_comma
== 1)
360 notify_std (&dtp
->common
, GFC_STD_GNU
,
361 "Comma in formatted numeric read.");
369 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
370 some other stuff. Set the relevant flags. */
371 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
375 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
377 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
383 dtp
->u
.p
.eor_condition
= 1;
388 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
389 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
390 || dtp
->u
.p
.current_unit
->bytes_left
391 == dtp
->u
.p
.current_unit
->recl
)
400 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
402 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
403 dtp
->u
.p
.current_unit
->has_size
)
404 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
406 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
407 fbuf_getc might reallocate the buffer. So return current pointer
408 minus all the advances, which is n plus up to two characters
409 of newline or comma. */
410 return fbuf_getptr (dtp
->u
.p
.current_unit
)
411 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
415 /* Function for reading the next couple of bytes from the current
416 file, advancing the current position. We return NULL on end of record or
417 end of file. This function is only for formatted I/O, unformatted uses
420 If the read is short, then it is because the current record does not
421 have enough data to satisfy the read request and the file was
422 opened with PAD=YES. The caller must assume tailing spaces for
426 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
431 if (!is_stream_io (dtp
))
433 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
435 /* For preconnected units with default record length, set bytes left
436 to unit record length and proceed, otherwise error. */
437 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
438 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
439 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
442 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
443 && !is_internal_unit (dtp
))
445 /* Not enough data left. */
446 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
451 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
452 && !is_internal_unit(dtp
)))
458 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
462 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
463 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
464 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
466 if (is_internal_unit (dtp
))
467 source
= read_sf_internal (dtp
, nbytes
);
469 source
= read_sf (dtp
, nbytes
);
471 dtp
->u
.p
.current_unit
->strm_pos
+=
472 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
476 /* If we reach here, we can assume it's direct access. */
478 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
481 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
482 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
484 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
485 dtp
->u
.p
.current_unit
->has_size
)
486 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
488 if (norig
!= *nbytes
)
490 /* Short read, this shouldn't happen. */
491 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
493 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
498 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
504 /* Read a block from a character(kind=4) internal unit, to be transferred into
505 a character(kind=4) variable. Note: Portions of this code borrowed from
508 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
510 static gfc_char4_t
*empty_string
[0];
514 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
515 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
517 /* Zero size array gives internal unit len of 0. Nothing to read. */
518 if (dtp
->internal_unit_len
== 0
519 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
522 /* If we have seen an eor previously, return a length of 0. The
523 caller is responsible for correctly padding the input field. */
524 if (dtp
->u
.p
.sf_seen_eor
)
527 /* Just return something that isn't a NULL pointer, otherwise the
528 caller thinks an error occurred. */
533 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
535 if (unlikely (lorig
> *nbytes
))
541 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
543 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
544 dtp
->u
.p
.current_unit
->has_size
)
545 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
551 /* Reads a block directly into application data space. This is for
552 unformatted files. */
555 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
557 ssize_t to_read_record
;
558 ssize_t have_read_record
;
559 ssize_t to_read_subrecord
;
560 ssize_t have_read_subrecord
;
563 if (is_stream_io (dtp
))
565 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
567 if (unlikely (have_read_record
< 0))
569 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
573 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
575 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
577 /* Short read, e.g. if we hit EOF. For stream files,
578 we have to set the end-of-file condition. */
584 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
586 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
589 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
590 nbytes
= to_read_record
;
595 to_read_record
= nbytes
;
598 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
600 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
601 if (unlikely (to_read_record
< 0))
603 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
607 if (to_read_record
!= (ssize_t
) nbytes
)
609 /* Short read, e.g. if we hit EOF. Apparently, we read
610 more than was written to the last record. */
614 if (unlikely (short_record
))
616 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
621 /* Unformatted sequential. We loop over the subrecords, reading
622 until the request has been fulfilled or the record has run out
623 of continuation subrecords. */
625 /* Check whether we exceed the total record length. */
627 if (dtp
->u
.p
.current_unit
->flags
.has_recl
628 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
630 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
635 to_read_record
= nbytes
;
638 have_read_record
= 0;
642 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
643 < (gfc_offset
) to_read_record
)
645 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
646 to_read_record
-= to_read_subrecord
;
650 to_read_subrecord
= to_read_record
;
654 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
656 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
657 buf
+ have_read_record
, to_read_subrecord
);
658 if (unlikely (have_read_subrecord
< 0))
660 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
664 have_read_record
+= have_read_subrecord
;
666 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
668 /* Short read, e.g. if we hit EOF. This means the record
669 structure has been corrupted, or the trailing record
670 marker would still be present. */
672 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
676 if (to_read_record
> 0)
678 if (likely (dtp
->u
.p
.current_unit
->continued
))
680 next_record_r_unf (dtp
, 0);
685 /* Let's make sure the file position is correctly pre-positioned
686 for the next read statement. */
688 dtp
->u
.p
.current_unit
->current_record
= 0;
689 next_record_r_unf (dtp
, 0);
690 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
696 /* Normal exit, the read request has been fulfilled. */
701 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
702 if (unlikely (short_record
))
704 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
711 /* Function for writing a block of bytes to the current file at the
712 current position, advancing the file pointer. We are given a length
713 and return a pointer to a buffer that the caller must (completely)
714 fill in. Returns NULL on error. */
717 write_block (st_parameter_dt
*dtp
, int length
)
721 if (!is_stream_io (dtp
))
723 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
725 /* For preconnected units with default record length, set bytes left
726 to unit record length and proceed, otherwise error. */
727 if (likely ((dtp
->u
.p
.current_unit
->unit_number
728 == options
.stdout_unit
729 || dtp
->u
.p
.current_unit
->unit_number
730 == options
.stderr_unit
)
731 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
732 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
735 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
740 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
743 if (is_internal_unit (dtp
))
745 if (is_char4_unit(dtp
)) /* char4 internel unit. */
748 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
751 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
757 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
761 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
765 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
766 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
770 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
773 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
778 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
779 dtp
->u
.p
.current_unit
->has_size
)
780 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
782 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
788 /* High level interface to swrite(), taking care of errors. This is only
789 called for unformatted files. There are three cases to consider:
790 Stream I/O, unformatted direct, unformatted sequential. */
793 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
796 ssize_t have_written
;
797 ssize_t to_write_subrecord
;
802 if (is_stream_io (dtp
))
804 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
805 if (unlikely (have_written
< 0))
807 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
811 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
816 /* Unformatted direct access. */
818 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
820 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
822 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
826 if (buf
== NULL
&& nbytes
== 0)
829 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
830 if (unlikely (have_written
< 0))
832 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
836 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
837 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
842 /* Unformatted sequential. */
846 if (dtp
->u
.p
.current_unit
->flags
.has_recl
847 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
849 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
861 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
862 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
864 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
865 (gfc_offset
) to_write_subrecord
;
867 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
868 buf
+ have_written
, to_write_subrecord
);
869 if (unlikely (to_write_subrecord
< 0))
871 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
875 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
876 nbytes
-= to_write_subrecord
;
877 have_written
+= to_write_subrecord
;
882 next_record_w_unf (dtp
, 1);
885 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
886 if (unlikely (short_record
))
888 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
895 /* Reverse memcpy - used for byte swapping. */
898 reverse_memcpy (void *dest
, const void *src
, size_t n
)
904 s
= (char *) src
+ n
- 1;
906 /* Write with ascending order - this is likely faster
907 on modern architectures because of write combining. */
913 /* Utility function for byteswapping an array, using the bswap
914 builtins if possible. dest and src can overlap completely, or then
915 they must point to separate objects; partial overlaps are not
919 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
929 for (size_t i
= 0; i
< nelems
; i
++)
930 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
933 for (size_t i
= 0; i
< nelems
; i
++)
934 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
937 for (size_t i
= 0; i
< nelems
; i
++)
938 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
943 for (size_t i
= 0; i
< nelems
; i
++)
946 memcpy (&tmp
, ps
, 4);
947 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
948 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
949 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
957 for (size_t i
= 0; i
< nelems
; i
++)
960 memcpy (&tmp
, ps
, 8);
961 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
962 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
972 for (size_t i
= 0; i
< nelems
; i
++)
974 reverse_memcpy (pd
, ps
, size
);
981 /* In-place byte swap. */
982 for (size_t i
= 0; i
< nelems
; i
++)
984 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
985 for (size_t j
= 0; j
< size
/2; j
++)
1000 /* Master function for unformatted reads. */
1003 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1004 void *dest
, int kind
, size_t size
, size_t nelems
)
1006 if (type
== BT_CLASS
)
1008 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1009 char tmp_iomsg
[IOMSG_LEN
] = "";
1011 gfc_charlen_type child_iomsg_len
;
1013 int *child_iostat
= NULL
;
1015 /* Set iostat, intent(out). */
1017 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1018 dtp
->common
.iostat
: &noiostat
;
1020 /* Set iomsg, intent(inout). */
1021 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1023 child_iomsg
= dtp
->common
.iomsg
;
1024 child_iomsg_len
= dtp
->common
.iomsg_len
;
1028 child_iomsg
= tmp_iomsg
;
1029 child_iomsg_len
= IOMSG_LEN
;
1032 /* Call the user defined unformatted READ procedure. */
1033 dtp
->u
.p
.current_unit
->child_dtio
++;
1034 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1036 dtp
->u
.p
.current_unit
->child_dtio
--;
1040 if (type
== BT_CHARACTER
)
1041 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1042 read_block_direct (dtp
, dest
, size
* nelems
);
1044 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1047 /* Handle wide chracters. */
1048 if (type
== BT_CHARACTER
)
1054 /* Break up complex into its constituent reals. */
1055 else if (type
== BT_COMPLEX
)
1060 bswap_array (dest
, dest
, size
, nelems
);
1065 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1066 bytes on 64 bit machines. The unused bytes are not initialized and never
1067 used, which can show an error with memory checking analyzers like
1068 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1071 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1072 void *source
, int kind
, size_t size
, size_t nelems
)
1074 if (type
== BT_CLASS
)
1076 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1077 char tmp_iomsg
[IOMSG_LEN
] = "";
1079 gfc_charlen_type child_iomsg_len
;
1081 int *child_iostat
= NULL
;
1083 /* Set iostat, intent(out). */
1085 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1086 dtp
->common
.iostat
: &noiostat
;
1088 /* Set iomsg, intent(inout). */
1089 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1091 child_iomsg
= dtp
->common
.iomsg
;
1092 child_iomsg_len
= dtp
->common
.iomsg_len
;
1096 child_iomsg
= tmp_iomsg
;
1097 child_iomsg_len
= IOMSG_LEN
;
1100 /* Call the user defined unformatted WRITE procedure. */
1101 dtp
->u
.p
.current_unit
->child_dtio
++;
1102 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1104 dtp
->u
.p
.current_unit
->child_dtio
--;
1108 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1111 size_t stride
= type
== BT_CHARACTER
?
1112 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1114 write_buf (dtp
, source
, stride
* nelems
);
1118 #define BSWAP_BUFSZ 512
1119 char buffer
[BSWAP_BUFSZ
];
1125 /* Handle wide chracters. */
1126 if (type
== BT_CHARACTER
&& kind
!= 1)
1132 /* Break up complex into its constituent reals. */
1133 if (type
== BT_COMPLEX
)
1139 /* By now, all complex variables have been split into their
1140 constituent reals. */
1146 if (size
* nrem
> BSWAP_BUFSZ
)
1147 nc
= BSWAP_BUFSZ
/ size
;
1151 bswap_array (buffer
, p
, size
, nc
);
1152 write_buf (dtp
, buffer
, size
* nc
);
1161 /* Return a pointer to the name of a type. */
1186 p
= "CLASS or DERIVED";
1189 internal_error (NULL
, "type_name(): Bad type");
1196 /* Write a constant string to the output.
1197 This is complicated because the string can have doubled delimiters
1198 in it. The length in the format node is the true length. */
1201 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1203 char c
, delimiter
, *p
, *q
;
1206 length
= f
->u
.string
.length
;
1210 p
= write_block (dtp
, length
);
1217 for (; length
> 0; length
--)
1220 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1221 q
++; /* Skip the doubled delimiter. */
1226 /* Given actual and expected types in a formatted data transfer, make
1227 sure they agree. If not, an error message is generated. Returns
1228 nonzero if something went wrong. */
1231 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1234 char buffer
[BUFLEN
];
1236 if (actual
== expected
)
1239 /* Adjust item_count before emitting error message. */
1240 snprintf (buffer
, BUFLEN
,
1241 "Expected %s for item %d in formatted transfer, got %s",
1242 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1244 format_error (dtp
, f
, buffer
);
1250 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1253 char buffer
[BUFLEN
];
1255 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1258 /* Adjust item_count before emitting error message. */
1259 snprintf (buffer
, BUFLEN
,
1260 "Expected numeric type for item %d in formatted transfer, got %s",
1261 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1263 format_error (dtp
, f
, buffer
);
1268 /* This function is in the main loop for a formatted data transfer
1269 statement. It would be natural to implement this as a coroutine
1270 with the user program, but C makes that awkward. We loop,
1271 processing format elements. When we actually have to transfer
1272 data instead of just setting flags, we return control to the user
1273 program which calls a function that supplies the address and type
1274 of the next element, then comes back here to process it. */
1277 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1280 int pos
, bytes_used
;
1284 int consume_data_flag
;
1286 /* Change a complex data item into a pair of reals. */
1288 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1289 if (type
== BT_COMPLEX
)
1295 /* If there's an EOR condition, we simulate finalizing the transfer
1296 by doing nothing. */
1297 if (dtp
->u
.p
.eor_condition
)
1300 /* Set this flag so that commas in reads cause the read to complete before
1301 the entire field has been read. The next read field will start right after
1302 the comma in the stream. (Set to 0 for character reads). */
1303 dtp
->u
.p
.sf_read_comma
=
1304 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1308 /* If reversion has occurred and there is another real data item,
1309 then we have to move to the next record. */
1310 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1312 dtp
->u
.p
.reversion_flag
= 0;
1313 next_record (dtp
, 0);
1316 consume_data_flag
= 1;
1317 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1320 f
= next_format (dtp
);
1323 /* No data descriptors left. */
1324 if (unlikely (n
> 0))
1325 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1326 "Insufficient data descriptors in format after reversion");
1332 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1333 - dtp
->u
.p
.current_unit
->bytes_left
);
1335 if (is_stream_io(dtp
))
1342 goto need_read_data
;
1343 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1345 read_decimal (dtp
, f
, p
, kind
);
1350 goto need_read_data
;
1351 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1352 && require_numeric_type (dtp
, type
, f
))
1354 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1355 && require_type (dtp
, BT_INTEGER
, type
, f
))
1357 read_radix (dtp
, f
, p
, kind
, 2);
1362 goto need_read_data
;
1363 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1364 && require_numeric_type (dtp
, type
, f
))
1366 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1367 && require_type (dtp
, BT_INTEGER
, type
, f
))
1369 read_radix (dtp
, f
, p
, kind
, 8);
1374 goto need_read_data
;
1375 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1376 && require_numeric_type (dtp
, type
, f
))
1378 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1379 && require_type (dtp
, BT_INTEGER
, type
, f
))
1381 read_radix (dtp
, f
, p
, kind
, 16);
1386 goto need_read_data
;
1388 /* It is possible to have FMT_A with something not BT_CHARACTER such
1389 as when writing out hollerith strings, so check both type
1390 and kind before calling wide character routines. */
1391 if (type
== BT_CHARACTER
&& kind
== 4)
1392 read_a_char4 (dtp
, f
, p
, size
);
1394 read_a (dtp
, f
, p
, size
);
1399 goto need_read_data
;
1400 read_l (dtp
, f
, p
, kind
);
1405 goto need_read_data
;
1406 if (require_type (dtp
, BT_REAL
, type
, f
))
1408 read_f (dtp
, f
, p
, kind
);
1413 goto need_read_data
;
1414 if (require_type (dtp
, BT_CLASS
, type
, f
))
1416 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1418 char tmp_iomsg
[IOMSG_LEN
] = "";
1420 gfc_charlen_type child_iomsg_len
;
1422 int *child_iostat
= NULL
;
1423 char *iotype
= f
->u
.udf
.string
;
1424 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1426 /* Build the iotype string. */
1427 if (iotype_len
== 0)
1435 iotype
= xmalloc (iotype_len
);
1438 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1441 /* Set iostat, intent(out). */
1443 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1444 dtp
->common
.iostat
: &noiostat
;
1446 /* Set iomsg, intent(inout). */
1447 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1449 child_iomsg
= dtp
->common
.iomsg
;
1450 child_iomsg_len
= dtp
->common
.iomsg_len
;
1454 child_iomsg
= tmp_iomsg
;
1455 child_iomsg_len
= IOMSG_LEN
;
1458 /* Call the user defined formatted READ procedure. */
1459 dtp
->u
.p
.current_unit
->child_dtio
++;
1460 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1461 child_iostat
, child_iomsg
,
1462 iotype_len
, child_iomsg_len
);
1463 dtp
->u
.p
.current_unit
->child_dtio
--;
1465 if (f
->u
.udf
.string_len
!= 0)
1467 /* Note: vlist is freed in free_format_data. */
1472 goto need_read_data
;
1473 if (require_type (dtp
, BT_REAL
, type
, f
))
1475 read_f (dtp
, f
, p
, kind
);
1480 goto need_read_data
;
1481 if (require_type (dtp
, BT_REAL
, type
, f
))
1483 read_f (dtp
, f
, p
, kind
);
1488 goto need_read_data
;
1489 if (require_type (dtp
, BT_REAL
, type
, f
))
1491 read_f (dtp
, f
, p
, kind
);
1496 goto need_read_data
;
1497 if (require_type (dtp
, BT_REAL
, type
, f
))
1499 read_f (dtp
, f
, p
, kind
);
1504 goto need_read_data
;
1508 read_decimal (dtp
, f
, p
, kind
);
1511 read_l (dtp
, f
, p
, kind
);
1515 read_a_char4 (dtp
, f
, p
, size
);
1517 read_a (dtp
, f
, p
, size
);
1520 read_f (dtp
, f
, p
, kind
);
1523 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1528 consume_data_flag
= 0;
1529 format_error (dtp
, f
, "Constant string in input format");
1532 /* Format codes that don't transfer data. */
1535 consume_data_flag
= 0;
1536 dtp
->u
.p
.skips
+= f
->u
.n
;
1537 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1538 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1539 read_x (dtp
, f
->u
.n
);
1544 consume_data_flag
= 0;
1546 if (f
->format
== FMT_TL
)
1548 /* Handle the special case when no bytes have been used yet.
1549 Cannot go below zero. */
1550 if (bytes_used
== 0)
1552 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1553 dtp
->u
.p
.skips
-= f
->u
.n
;
1554 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1557 pos
= bytes_used
- f
->u
.n
;
1562 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1563 left tab limit. We do not check if the position has gone
1564 beyond the end of record because a subsequent tab could
1565 bring us back again. */
1566 pos
= pos
< 0 ? 0 : pos
;
1568 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1569 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1570 + pos
- dtp
->u
.p
.max_pos
;
1571 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1572 ? 0 : dtp
->u
.p
.pending_spaces
;
1573 if (dtp
->u
.p
.skips
== 0)
1576 /* Adjust everything for end-of-record condition */
1577 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1579 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1580 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1582 if (dtp
->u
.p
.pending_spaces
== 0)
1583 dtp
->u
.p
.sf_seen_eor
= 0;
1585 if (dtp
->u
.p
.skips
< 0)
1587 if (is_internal_unit (dtp
))
1588 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1590 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1591 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1592 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1595 read_x (dtp
, dtp
->u
.p
.skips
);
1599 consume_data_flag
= 0;
1600 dtp
->u
.p
.sign_status
= SIGN_S
;
1604 consume_data_flag
= 0;
1605 dtp
->u
.p
.sign_status
= SIGN_SS
;
1609 consume_data_flag
= 0;
1610 dtp
->u
.p
.sign_status
= SIGN_SP
;
1614 consume_data_flag
= 0 ;
1615 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1619 consume_data_flag
= 0;
1620 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1624 consume_data_flag
= 0;
1625 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1629 consume_data_flag
= 0;
1630 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1634 consume_data_flag
= 0;
1635 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1639 consume_data_flag
= 0;
1640 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1644 consume_data_flag
= 0;
1645 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1649 consume_data_flag
= 0;
1650 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1654 consume_data_flag
= 0;
1655 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1659 consume_data_flag
= 0;
1660 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1664 consume_data_flag
= 0;
1665 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1669 consume_data_flag
= 0;
1670 dtp
->u
.p
.seen_dollar
= 1;
1674 consume_data_flag
= 0;
1675 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1676 next_record (dtp
, 0);
1680 /* A colon descriptor causes us to exit this loop (in
1681 particular preventing another / descriptor from being
1682 processed) unless there is another data item to be
1684 consume_data_flag
= 0;
1690 internal_error (&dtp
->common
, "Bad format node");
1693 /* Adjust the item count and data pointer. */
1695 if ((consume_data_flag
> 0) && (n
> 0))
1698 p
= ((char *) p
) + size
;
1703 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1704 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1709 /* Come here when we need a data descriptor but don't have one. We
1710 push the current format node back onto the input, then return and
1711 let the user program call us back with the data. */
1713 unget_format (dtp
, f
);
1718 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1721 int pos
, bytes_used
;
1725 int consume_data_flag
;
1727 /* Change a complex data item into a pair of reals. */
1729 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1730 if (type
== BT_COMPLEX
)
1736 /* If there's an EOR condition, we simulate finalizing the transfer
1737 by doing nothing. */
1738 if (dtp
->u
.p
.eor_condition
)
1741 /* Set this flag so that commas in reads cause the read to complete before
1742 the entire field has been read. The next read field will start right after
1743 the comma in the stream. (Set to 0 for character reads). */
1744 dtp
->u
.p
.sf_read_comma
=
1745 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1749 /* If reversion has occurred and there is another real data item,
1750 then we have to move to the next record. */
1751 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1753 dtp
->u
.p
.reversion_flag
= 0;
1754 next_record (dtp
, 0);
1757 consume_data_flag
= 1;
1758 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1761 f
= next_format (dtp
);
1764 /* No data descriptors left. */
1765 if (unlikely (n
> 0))
1766 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1767 "Insufficient data descriptors in format after reversion");
1771 /* Now discharge T, TR and X movements to the right. This is delayed
1772 until a data producing format to suppress trailing spaces. */
1775 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1776 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1777 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1778 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1779 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1781 || t
== FMT_STRING
))
1783 if (dtp
->u
.p
.skips
> 0)
1786 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1787 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1788 - dtp
->u
.p
.current_unit
->bytes_left
);
1790 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1793 if (dtp
->u
.p
.skips
< 0)
1795 if (is_internal_unit (dtp
))
1796 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1798 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1799 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1801 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1804 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1805 - dtp
->u
.p
.current_unit
->bytes_left
);
1807 if (is_stream_io(dtp
))
1815 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1817 write_i (dtp
, f
, p
, kind
);
1823 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1824 && require_numeric_type (dtp
, type
, f
))
1826 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1827 && require_type (dtp
, BT_INTEGER
, type
, f
))
1829 write_b (dtp
, f
, p
, kind
);
1835 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1836 && require_numeric_type (dtp
, type
, f
))
1838 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1839 && require_type (dtp
, BT_INTEGER
, type
, f
))
1841 write_o (dtp
, f
, p
, kind
);
1847 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1848 && require_numeric_type (dtp
, type
, f
))
1850 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1851 && require_type (dtp
, BT_INTEGER
, type
, f
))
1853 write_z (dtp
, f
, p
, kind
);
1860 /* It is possible to have FMT_A with something not BT_CHARACTER such
1861 as when writing out hollerith strings, so check both type
1862 and kind before calling wide character routines. */
1863 if (type
== BT_CHARACTER
&& kind
== 4)
1864 write_a_char4 (dtp
, f
, p
, size
);
1866 write_a (dtp
, f
, p
, size
);
1872 write_l (dtp
, f
, p
, kind
);
1878 if (require_type (dtp
, BT_REAL
, type
, f
))
1880 write_d (dtp
, f
, p
, kind
);
1886 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1888 char tmp_iomsg
[IOMSG_LEN
] = "";
1890 gfc_charlen_type child_iomsg_len
;
1892 int *child_iostat
= NULL
;
1893 char *iotype
= f
->u
.udf
.string
;
1894 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1896 /* Build the iotype string. */
1897 if (iotype_len
== 0)
1905 iotype
= xmalloc (iotype_len
);
1908 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1911 /* Set iostat, intent(out). */
1913 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1914 dtp
->common
.iostat
: &noiostat
;
1916 /* Set iomsg, intent(inout). */
1917 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1919 child_iomsg
= dtp
->common
.iomsg
;
1920 child_iomsg_len
= dtp
->common
.iomsg_len
;
1924 child_iomsg
= tmp_iomsg
;
1925 child_iomsg_len
= IOMSG_LEN
;
1928 /* Call the user defined formatted WRITE procedure. */
1929 dtp
->u
.p
.current_unit
->child_dtio
++;
1930 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1931 child_iostat
, child_iomsg
,
1932 iotype_len
, child_iomsg_len
);
1933 dtp
->u
.p
.current_unit
->child_dtio
--;
1935 if (f
->u
.udf
.string_len
!= 0)
1937 /* Note: vlist is freed in free_format_data. */
1943 if (require_type (dtp
, BT_REAL
, type
, f
))
1945 write_e (dtp
, f
, p
, kind
);
1951 if (require_type (dtp
, BT_REAL
, type
, f
))
1953 write_en (dtp
, f
, p
, kind
);
1959 if (require_type (dtp
, BT_REAL
, type
, f
))
1961 write_es (dtp
, f
, p
, kind
);
1967 if (require_type (dtp
, BT_REAL
, type
, f
))
1969 write_f (dtp
, f
, p
, kind
);
1978 write_i (dtp
, f
, p
, kind
);
1981 write_l (dtp
, f
, p
, kind
);
1985 write_a_char4 (dtp
, f
, p
, size
);
1987 write_a (dtp
, f
, p
, size
);
1990 if (f
->u
.real
.w
== 0)
1991 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1993 write_d (dtp
, f
, p
, kind
);
1996 internal_error (&dtp
->common
,
1997 "formatted_transfer(): Bad type");
2002 consume_data_flag
= 0;
2003 write_constant_string (dtp
, f
);
2006 /* Format codes that don't transfer data. */
2009 consume_data_flag
= 0;
2011 dtp
->u
.p
.skips
+= f
->u
.n
;
2012 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2013 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2014 /* Writes occur just before the switch on f->format, above, so
2015 that trailing blanks are suppressed, unless we are doing a
2016 non-advancing write in which case we want to output the blanks
2018 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2020 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2021 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2027 consume_data_flag
= 0;
2029 if (f
->format
== FMT_TL
)
2032 /* Handle the special case when no bytes have been used yet.
2033 Cannot go below zero. */
2034 if (bytes_used
== 0)
2036 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2037 dtp
->u
.p
.skips
-= f
->u
.n
;
2038 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2041 pos
= bytes_used
- f
->u
.n
;
2044 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2046 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2047 left tab limit. We do not check if the position has gone
2048 beyond the end of record because a subsequent tab could
2049 bring us back again. */
2050 pos
= pos
< 0 ? 0 : pos
;
2052 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2053 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2054 + pos
- dtp
->u
.p
.max_pos
;
2055 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2056 ? 0 : dtp
->u
.p
.pending_spaces
;
2060 consume_data_flag
= 0;
2061 dtp
->u
.p
.sign_status
= SIGN_S
;
2065 consume_data_flag
= 0;
2066 dtp
->u
.p
.sign_status
= SIGN_SS
;
2070 consume_data_flag
= 0;
2071 dtp
->u
.p
.sign_status
= SIGN_SP
;
2075 consume_data_flag
= 0 ;
2076 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2080 consume_data_flag
= 0;
2081 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2085 consume_data_flag
= 0;
2086 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2090 consume_data_flag
= 0;
2091 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2095 consume_data_flag
= 0;
2096 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2100 consume_data_flag
= 0;
2101 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2105 consume_data_flag
= 0;
2106 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2110 consume_data_flag
= 0;
2111 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2115 consume_data_flag
= 0;
2116 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2120 consume_data_flag
= 0;
2121 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2125 consume_data_flag
= 0;
2126 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2130 consume_data_flag
= 0;
2131 dtp
->u
.p
.seen_dollar
= 1;
2135 consume_data_flag
= 0;
2136 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2137 next_record (dtp
, 0);
2141 /* A colon descriptor causes us to exit this loop (in
2142 particular preventing another / descriptor from being
2143 processed) unless there is another data item to be
2145 consume_data_flag
= 0;
2151 internal_error (&dtp
->common
, "Bad format node");
2154 /* Adjust the item count and data pointer. */
2156 if ((consume_data_flag
> 0) && (n
> 0))
2159 p
= ((char *) p
) + size
;
2162 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2163 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2168 /* Come here when we need a data descriptor but don't have one. We
2169 push the current format node back onto the input, then return and
2170 let the user program call us back with the data. */
2172 unget_format (dtp
, f
);
2175 /* This function is first called from data_init_transfer to initiate the loop
2176 over each item in the format, transferring data as required. Subsequent
2177 calls to this function occur for each data item foound in the READ/WRITE
2178 statement. The item_count is incremented for each call. Since the first
2179 call is from data_transfer_init, the item_count is always one greater than
2180 the actual count number of the item being transferred. */
2183 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2184 size_t size
, size_t nelems
)
2190 size_t stride
= type
== BT_CHARACTER
?
2191 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2192 if (dtp
->u
.p
.mode
== READING
)
2194 /* Big loop over all the elements. */
2195 for (elem
= 0; elem
< nelems
; elem
++)
2197 dtp
->u
.p
.item_count
++;
2198 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2203 /* Big loop over all the elements. */
2204 for (elem
= 0; elem
< nelems
; elem
++)
2206 dtp
->u
.p
.item_count
++;
2207 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2213 /* Data transfer entry points. The type of the data entity is
2214 implicit in the subroutine call. This prevents us from having to
2215 share a common enum with the compiler. */
2218 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2220 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2222 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2226 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2228 transfer_integer (dtp
, p
, kind
);
2232 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2235 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2237 size
= size_from_real_kind (kind
);
2238 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2242 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2244 transfer_real (dtp
, p
, kind
);
2248 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2250 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2252 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2256 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2258 transfer_logical (dtp
, p
, kind
);
2262 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2264 static char *empty_string
[0];
2266 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2269 /* Strings of zero length can have p == NULL, which confuses the
2270 transfer routines into thinking we need more data elements. To avoid
2271 this, we give them a nice pointer. */
2272 if (len
== 0 && p
== NULL
)
2275 /* Set kind here to 1. */
2276 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2280 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2282 transfer_character (dtp
, p
, len
);
2286 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2288 static char *empty_string
[0];
2290 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2293 /* Strings of zero length can have p == NULL, which confuses the
2294 transfer routines into thinking we need more data elements. To avoid
2295 this, we give them a nice pointer. */
2296 if (len
== 0 && p
== NULL
)
2299 /* Here we pass the actual kind value. */
2300 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2304 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2306 transfer_character_wide (dtp
, p
, len
, kind
);
2310 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2313 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2315 size
= size_from_complex_kind (kind
);
2316 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2320 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2322 transfer_complex (dtp
, p
, kind
);
2326 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2327 gfc_charlen_type charlen
)
2329 index_type count
[GFC_MAX_DIMENSIONS
];
2330 index_type extent
[GFC_MAX_DIMENSIONS
];
2331 index_type stride
[GFC_MAX_DIMENSIONS
];
2332 index_type stride0
, rank
, size
, n
;
2337 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2340 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2341 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2343 rank
= GFC_DESCRIPTOR_RANK (desc
);
2344 for (n
= 0; n
< rank
; n
++)
2347 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2348 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2350 /* If the extent of even one dimension is zero, then the entire
2351 array section contains zero elements, so we return after writing
2352 a zero array record. */
2357 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2362 stride0
= stride
[0];
2364 /* If the innermost dimension has a stride of 1, we can do the transfer
2365 in contiguous chunks. */
2366 if (stride0
== size
)
2371 data
= GFC_DESCRIPTOR_DATA (desc
);
2375 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2376 data
+= stride0
* tsize
;
2379 while (count
[n
] == extent
[n
])
2382 data
-= stride
[n
] * extent
[n
];
2399 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2400 gfc_charlen_type charlen
)
2402 transfer_array (dtp
, desc
, kind
, charlen
);
2406 /* User defined input/output iomsg. */
2408 #define IOMSG_LEN 256
2411 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2413 if (parent
->u
.p
.current_unit
)
2415 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2416 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2418 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2420 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2424 /* Preposition a sequential unformatted file while reading. */
2427 us_read (st_parameter_dt
*dtp
, int continued
)
2434 if (compile_options
.record_marker
== 0)
2435 n
= sizeof (GFC_INTEGER_4
);
2437 n
= compile_options
.record_marker
;
2439 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2440 if (unlikely (nr
< 0))
2442 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2448 return; /* end of file */
2450 else if (unlikely (n
!= nr
))
2452 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2456 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2457 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2461 case sizeof(GFC_INTEGER_4
):
2462 memcpy (&i4
, &i
, sizeof (i4
));
2466 case sizeof(GFC_INTEGER_8
):
2467 memcpy (&i8
, &i
, sizeof (i8
));
2472 runtime_error ("Illegal value for record marker");
2482 case sizeof(GFC_INTEGER_4
):
2483 memcpy (&u32
, &i
, sizeof (u32
));
2484 u32
= __builtin_bswap32 (u32
);
2485 memcpy (&i4
, &u32
, sizeof (i4
));
2489 case sizeof(GFC_INTEGER_8
):
2490 memcpy (&u64
, &i
, sizeof (u64
));
2491 u64
= __builtin_bswap64 (u64
);
2492 memcpy (&i8
, &u64
, sizeof (i8
));
2497 runtime_error ("Illegal value for record marker");
2504 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2505 dtp
->u
.p
.current_unit
->continued
= 0;
2509 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2510 dtp
->u
.p
.current_unit
->continued
= 1;
2514 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2518 /* Preposition a sequential unformatted file while writing. This
2519 amount to writing a bogus length that will be filled in later. */
2522 us_write (st_parameter_dt
*dtp
, int continued
)
2529 if (compile_options
.record_marker
== 0)
2530 nbytes
= sizeof (GFC_INTEGER_4
);
2532 nbytes
= compile_options
.record_marker
;
2534 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2535 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2537 /* For sequential unformatted, if RECL= was not specified in the OPEN
2538 we write until we have more bytes than can fit in the subrecord
2539 markers, then we write a new subrecord. */
2541 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2542 dtp
->u
.p
.current_unit
->recl_subrecord
;
2543 dtp
->u
.p
.current_unit
->continued
= continued
;
2547 /* Position to the next record prior to transfer. We are assumed to
2548 be before the next record. We also calculate the bytes in the next
2552 pre_position (st_parameter_dt
*dtp
)
2554 if (dtp
->u
.p
.current_unit
->current_record
)
2555 return; /* Already positioned. */
2557 switch (current_mode (dtp
))
2559 case FORMATTED_STREAM
:
2560 case UNFORMATTED_STREAM
:
2561 /* There are no records with stream I/O. If the position was specified
2562 data_transfer_init has already positioned the file. If no position
2563 was specified, we continue from where we last left off. I.e.
2564 there is nothing to do here. */
2567 case UNFORMATTED_SEQUENTIAL
:
2568 if (dtp
->u
.p
.mode
== READING
)
2575 case FORMATTED_SEQUENTIAL
:
2576 case FORMATTED_DIRECT
:
2577 case UNFORMATTED_DIRECT
:
2578 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2582 dtp
->u
.p
.current_unit
->current_record
= 1;
2586 /* Initialize things for a data transfer. This code is common for
2587 both reading and writing. */
2590 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2592 unit_flags u_flags
; /* Used for creating a unit if needed. */
2593 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2594 namelist_info
*ionml
;
2596 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2598 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2600 dtp
->u
.p
.ionml
= ionml
;
2601 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2603 dtp
->u
.p
.cc
.len
= 0;
2605 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2608 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2610 if (dtp
->u
.p
.current_unit
== NULL
)
2612 /* This means we tried to access an external unit < 0 without
2613 having opened it first with NEWUNIT=. */
2614 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2615 "Unit number is negative and unit was not already "
2616 "opened with OPEN(NEWUNIT=...)");
2619 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2620 { /* Open the unit with some default flags. */
2621 st_parameter_open opp
;
2624 memset (&u_flags
, '\0', sizeof (u_flags
));
2625 u_flags
.access
= ACCESS_SEQUENTIAL
;
2626 u_flags
.action
= ACTION_READWRITE
;
2628 /* Is it unformatted? */
2629 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2630 | IOPARM_DT_IONML_SET
)))
2631 u_flags
.form
= FORM_UNFORMATTED
;
2633 u_flags
.form
= FORM_UNSPECIFIED
;
2635 u_flags
.delim
= DELIM_UNSPECIFIED
;
2636 u_flags
.blank
= BLANK_UNSPECIFIED
;
2637 u_flags
.pad
= PAD_UNSPECIFIED
;
2638 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2639 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2640 u_flags
.async
= ASYNC_UNSPECIFIED
;
2641 u_flags
.round
= ROUND_UNSPECIFIED
;
2642 u_flags
.sign
= SIGN_UNSPECIFIED
;
2643 u_flags
.share
= SHARE_UNSPECIFIED
;
2644 u_flags
.cc
= CC_UNSPECIFIED
;
2645 u_flags
.readonly
= 0;
2647 u_flags
.status
= STATUS_UNKNOWN
;
2649 conv
= get_unformatted_convert (dtp
->common
.unit
);
2651 if (conv
== GFC_CONVERT_NONE
)
2652 conv
= compile_options
.convert
;
2654 /* We use big_endian, which is 0 on little-endian machines
2655 and 1 on big-endian machines. */
2658 case GFC_CONVERT_NATIVE
:
2659 case GFC_CONVERT_SWAP
:
2662 case GFC_CONVERT_BIG
:
2663 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2666 case GFC_CONVERT_LITTLE
:
2667 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2671 internal_error (&opp
.common
, "Illegal value for CONVERT");
2675 u_flags
.convert
= conv
;
2677 opp
.common
= dtp
->common
;
2678 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2679 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2680 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2681 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2682 if (dtp
->u
.p
.current_unit
== NULL
)
2686 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2688 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2690 dtp
->u
.p
.current_unit
->has_size
= true;
2691 /* Initialize the count. */
2692 dtp
->u
.p
.current_unit
->size_used
= 0;
2695 dtp
->u
.p
.current_unit
->has_size
= false;
2698 /* Check the action. */
2700 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2702 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2703 "Cannot read from file opened for WRITE");
2707 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2709 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2710 "Cannot write to file opened for READ");
2714 dtp
->u
.p
.first_item
= 1;
2716 /* Check the format. */
2718 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2721 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2722 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2725 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2726 "Format present for UNFORMATTED data transfer");
2730 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2732 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2734 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2735 "A format cannot be specified with a namelist");
2739 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2740 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2742 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2743 "Missing format for FORMATTED data transfer");
2747 if (is_internal_unit (dtp
)
2748 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2750 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2751 "Internal file cannot be accessed by UNFORMATTED "
2756 /* Check the record or position number. */
2758 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2759 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2761 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2762 "Direct access data transfer requires record number");
2766 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2768 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2770 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2771 "Record number not allowed for sequential access "
2776 if (compile_options
.warn_std
&&
2777 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2779 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2780 "Sequential READ or WRITE not allowed after "
2781 "EOF marker, possibly use REWIND or BACKSPACE");
2785 /* Process the ADVANCE option. */
2787 dtp
->u
.p
.advance_status
2788 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2789 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2790 "Bad ADVANCE parameter in data transfer statement");
2792 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2794 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2796 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2797 "ADVANCE specification conflicts with sequential "
2802 if (is_internal_unit (dtp
))
2804 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2805 "ADVANCE specification conflicts with internal file");
2809 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2810 != IOPARM_DT_HAS_FORMAT
)
2812 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2813 "ADVANCE specification requires an explicit format");
2820 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2822 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2824 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2825 "EOR specification requires an ADVANCE specification "
2830 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2831 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2833 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2834 "SIZE specification requires an ADVANCE "
2835 "specification of NO");
2840 { /* Write constraints. */
2841 if ((cf
& IOPARM_END
) != 0)
2843 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2844 "END specification cannot appear in a write "
2849 if ((cf
& IOPARM_EOR
) != 0)
2851 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2852 "EOR specification cannot appear in a write "
2857 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2859 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2860 "SIZE specification cannot appear in a write "
2866 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2867 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2869 /* Check the decimal mode. */
2870 dtp
->u
.p
.current_unit
->decimal_status
2871 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2872 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2873 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2876 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2877 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2879 /* Check the round mode. */
2880 dtp
->u
.p
.current_unit
->round_status
2881 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2882 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2883 round_opt
, "Bad ROUND parameter in data transfer "
2886 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2887 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2889 /* Check the sign mode. */
2890 dtp
->u
.p
.sign_status
2891 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2892 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2893 "Bad SIGN parameter in data transfer statement");
2895 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2896 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2898 /* Check the blank mode. */
2899 dtp
->u
.p
.blank_status
2900 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2901 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2903 "Bad BLANK parameter in data transfer statement");
2905 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2906 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2908 /* Check the delim mode. */
2909 dtp
->u
.p
.current_unit
->delim_status
2910 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2911 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2912 delim_opt
, "Bad DELIM parameter in data transfer statement");
2914 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2916 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2917 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2919 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2922 /* Check the pad mode. */
2923 dtp
->u
.p
.current_unit
->pad_status
2924 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2925 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2926 "Bad PAD parameter in data transfer statement");
2928 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2929 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2931 /* Check to see if we might be reading what we wrote before */
2933 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2934 && !is_internal_unit (dtp
))
2936 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2938 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2939 sflush(dtp
->u
.p
.current_unit
->s
);
2942 /* Check the POS= specifier: that it is in range and that it is used with a
2943 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2945 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2947 if (is_stream_io (dtp
))
2952 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2953 "POS=specifier must be positive");
2957 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2959 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2960 "POS=specifier too large");
2964 dtp
->rec
= dtp
->pos
;
2966 if (dtp
->u
.p
.mode
== READING
)
2968 /* Reset the endfile flag; if we hit EOF during reading
2969 we'll set the flag and generate an error at that point
2970 rather than worrying about it here. */
2971 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2974 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2976 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2977 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2979 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2982 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2987 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2988 "POS=specifier not allowed, "
2989 "Try OPEN with ACCESS='stream'");
2995 /* Sanity checks on the record number. */
2996 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
3000 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3001 "Record number must be positive");
3005 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3007 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3008 "Record number too large");
3012 /* Make sure format buffer is reset. */
3013 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3014 fbuf_reset (dtp
->u
.p
.current_unit
);
3017 /* Check whether the record exists to be read. Only
3018 a partial record needs to exist. */
3020 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3021 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3023 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3024 "Non-existing record number");
3028 /* Position the file. */
3029 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3030 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3032 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3036 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3038 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3039 "Record number not allowed for stream access "
3045 /* Bugware for badly written mixed C-Fortran I/O. */
3046 if (!is_internal_unit (dtp
))
3047 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3049 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3051 /* Set the maximum position reached from the previous I/O operation. This
3052 could be greater than zero from a previous non-advancing write. */
3053 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3058 /* Set up the subroutine that will handle the transfers. */
3062 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3063 dtp
->u
.p
.transfer
= unformatted_read
;
3066 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3068 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3069 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3070 dtp
->u
.p
.transfer
= list_formatted_read
;
3073 dtp
->u
.p
.transfer
= formatted_transfer
;
3078 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3079 dtp
->u
.p
.transfer
= unformatted_write
;
3082 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3083 dtp
->u
.p
.transfer
= list_formatted_write
;
3085 dtp
->u
.p
.transfer
= formatted_transfer
;
3089 /* Make sure that we don't do a read after a nonadvancing write. */
3093 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3095 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3096 "Cannot READ after a nonadvancing WRITE");
3102 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3103 dtp
->u
.p
.current_unit
->read_bad
= 1;
3106 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3108 #ifdef HAVE_USELOCALE
3109 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3111 __gthread_mutex_lock (&old_locale_lock
);
3112 if (!old_locale_ctr
++)
3114 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3115 setlocale (LC_NUMERIC
, "C");
3117 __gthread_mutex_unlock (&old_locale_lock
);
3119 /* Start the data transfer if we are doing a formatted transfer. */
3120 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3121 && dtp
->u
.p
.ionml
== NULL
)
3122 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3127 /* Initialize an array_loop_spec given the array descriptor. The function
3128 returns the index of the last element of the array, and also returns
3129 starting record, where the first I/O goes to (necessary in case of
3130 negative strides). */
3133 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3134 gfc_offset
*start_record
)
3136 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3145 for (i
=0; i
<rank
; i
++)
3147 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3148 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3149 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3150 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3151 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3152 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3154 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3156 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3157 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3161 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3162 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3163 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3164 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3174 /* Determine the index to the next record in an internal unit array by
3175 by incrementing through the array_loop_spec. */
3178 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3186 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3191 if (ls
[i
].idx
> ls
[i
].end
)
3193 ls
[i
].idx
= ls
[i
].start
;
3199 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3209 /* Skip to the end of the current record, taking care of an optional
3210 record marker of size bytes. If the file is not seekable, we
3211 read chunks of size MAX_READ until we get to the right
3215 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
3217 ssize_t rlength
, readb
;
3218 #define MAX_READ 4096
3221 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3222 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3225 /* Direct access files do not generate END conditions,
3227 if (sseek (dtp
->u
.p
.current_unit
->s
,
3228 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3230 /* Seeking failed, fall back to seeking by reading data. */
3231 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3234 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3235 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3237 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3240 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3244 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3248 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3252 /* Advance to the next record reading unformatted files, taking
3253 care of subrecords. If complete_record is nonzero, we loop
3254 until all subrecords are cleared. */
3257 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3261 bytes
= compile_options
.record_marker
== 0 ?
3262 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3267 /* Skip over tail */
3269 skip_record (dtp
, bytes
);
3271 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3280 min_off (gfc_offset a
, gfc_offset b
)
3282 return (a
< b
? a
: b
);
3286 /* Space to the next record for read mode. */
3289 next_record_r (st_parameter_dt
*dtp
, int done
)
3296 switch (current_mode (dtp
))
3298 /* No records in unformatted STREAM I/O. */
3299 case UNFORMATTED_STREAM
:
3302 case UNFORMATTED_SEQUENTIAL
:
3303 next_record_r_unf (dtp
, 1);
3304 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3307 case FORMATTED_DIRECT
:
3308 case UNFORMATTED_DIRECT
:
3309 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3312 case FORMATTED_STREAM
:
3313 case FORMATTED_SEQUENTIAL
:
3314 /* read_sf has already terminated input because of an '\n', or
3316 if (dtp
->u
.p
.sf_seen_eor
)
3318 dtp
->u
.p
.sf_seen_eor
= 0;
3322 if (is_internal_unit (dtp
))
3324 if (is_array_io (dtp
))
3328 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3330 if (!done
&& finished
)
3333 /* Now seek to this record. */
3334 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3335 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3337 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3340 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3344 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3345 bytes_left
= min_off (bytes_left
,
3346 ssize (dtp
->u
.p
.current_unit
->s
)
3347 - stell (dtp
->u
.p
.current_unit
->s
));
3348 if (sseek (dtp
->u
.p
.current_unit
->s
,
3349 bytes_left
, SEEK_CUR
) < 0)
3351 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3354 dtp
->u
.p
.current_unit
->bytes_left
3355 = dtp
->u
.p
.current_unit
->recl
;
3359 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3364 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3368 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3371 if (is_stream_io (dtp
)
3372 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3373 || dtp
->u
.p
.current_unit
->bytes_left
3374 == dtp
->u
.p
.current_unit
->recl
)
3380 if (is_stream_io (dtp
))
3381 dtp
->u
.p
.current_unit
->strm_pos
++;
3392 /* Small utility function to write a record marker, taking care of
3393 byte swapping and of choosing the correct size. */
3396 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3402 if (compile_options
.record_marker
== 0)
3403 len
= sizeof (GFC_INTEGER_4
);
3405 len
= compile_options
.record_marker
;
3407 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3408 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3412 case sizeof (GFC_INTEGER_4
):
3414 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3417 case sizeof (GFC_INTEGER_8
):
3419 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3423 runtime_error ("Illegal value for record marker");
3433 case sizeof (GFC_INTEGER_4
):
3435 memcpy (&u32
, &buf4
, sizeof (u32
));
3436 u32
= __builtin_bswap32 (u32
);
3437 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3440 case sizeof (GFC_INTEGER_8
):
3442 memcpy (&u64
, &buf8
, sizeof (u64
));
3443 u64
= __builtin_bswap64 (u64
);
3444 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3448 runtime_error ("Illegal value for record marker");
3455 /* Position to the next (sub)record in write mode for
3456 unformatted sequential files. */
3459 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3461 gfc_offset m
, m_write
, record_marker
;
3463 /* Bytes written. */
3464 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3465 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3467 if (compile_options
.record_marker
== 0)
3468 record_marker
= sizeof (GFC_INTEGER_4
);
3470 record_marker
= compile_options
.record_marker
;
3472 /* Seek to the head and overwrite the bogus length with the real
3475 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3484 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3487 /* Seek past the end of the current record. */
3489 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3492 /* Write the length tail. If we finish a record containing
3493 subrecords, we write out the negative length. */
3495 if (dtp
->u
.p
.current_unit
->continued
)
3500 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3506 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3512 /* Utility function like memset() but operating on streams. Return
3513 value is same as for POSIX write(). */
3516 sset (stream
* s
, int c
, ssize_t nbyte
)
3518 #define WRITE_CHUNK 256
3519 char p
[WRITE_CHUNK
];
3520 ssize_t bytes_left
, trans
;
3522 if (nbyte
< WRITE_CHUNK
)
3523 memset (p
, c
, nbyte
);
3525 memset (p
, c
, WRITE_CHUNK
);
3528 while (bytes_left
> 0)
3530 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3531 trans
= swrite (s
, p
, trans
);
3534 bytes_left
-= trans
;
3537 return nbyte
- bytes_left
;
3541 /* Finish up a record according to the legacy carriagecontrol type, based
3542 on the first character in the record. */
3545 next_record_cc (st_parameter_dt
*dtp
)
3547 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3548 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
3551 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3552 if (dtp
->u
.p
.cc
.len
> 0)
3554 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
3556 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3558 /* Output CR for the first character with default CC setting. */
3559 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
3560 if (dtp
->u
.p
.cc
.len
> 1)
3561 *p
= dtp
->u
.p
.cc
.u
.end
;
3565 /* Position to the next record in write mode. */
3568 next_record_w (st_parameter_dt
*dtp
, int done
)
3570 gfc_offset m
, record
, max_pos
;
3573 /* Zero counters for X- and T-editing. */
3574 max_pos
= dtp
->u
.p
.max_pos
;
3575 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3577 switch (current_mode (dtp
))
3579 /* No records in unformatted STREAM I/O. */
3580 case UNFORMATTED_STREAM
:
3583 case FORMATTED_DIRECT
:
3584 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3587 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3588 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3589 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3590 dtp
->u
.p
.current_unit
->bytes_left
)
3591 != dtp
->u
.p
.current_unit
->bytes_left
)
3596 case UNFORMATTED_DIRECT
:
3597 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3599 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3600 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3605 case UNFORMATTED_SEQUENTIAL
:
3606 next_record_w_unf (dtp
, 0);
3607 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3610 case FORMATTED_STREAM
:
3611 case FORMATTED_SEQUENTIAL
:
3613 if (is_internal_unit (dtp
))
3616 if (is_array_io (dtp
))
3620 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3622 /* If the farthest position reached is greater than current
3623 position, adjust the position and set length to pad out
3624 whats left. Otherwise just pad whats left.
3625 (for character array unit) */
3626 m
= dtp
->u
.p
.current_unit
->recl
3627 - dtp
->u
.p
.current_unit
->bytes_left
;
3630 length
= (int) (max_pos
- m
);
3631 if (sseek (dtp
->u
.p
.current_unit
->s
,
3632 length
, SEEK_CUR
) < 0)
3634 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3637 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3640 p
= write_block (dtp
, length
);
3644 if (unlikely (is_char4_unit (dtp
)))
3646 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3647 memset4 (p4
, ' ', length
);
3650 memset (p
, ' ', length
);
3652 /* Now that the current record has been padded out,
3653 determine where the next record in the array is. */
3654 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3657 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3659 /* Now seek to this record */
3660 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3662 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3664 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3668 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3674 /* If this is the last call to next_record move to the farthest
3675 position reached and set length to pad out the remainder
3676 of the record. (for character scaler unit) */
3679 m
= dtp
->u
.p
.current_unit
->recl
3680 - dtp
->u
.p
.current_unit
->bytes_left
;
3683 length
= (int) (max_pos
- m
);
3684 if (sseek (dtp
->u
.p
.current_unit
->s
,
3685 length
, SEEK_CUR
) < 0)
3687 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3690 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3693 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3697 p
= write_block (dtp
, length
);
3701 if (unlikely (is_char4_unit (dtp
)))
3703 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3704 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3707 memset (p
, ' ', length
);
3711 /* Handle legacy CARRIAGECONTROL line endings. */
3712 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
3713 next_record_cc (dtp
);
3716 /* Skip newlines for CC=CC_NONE. */
3717 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
3724 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3725 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3727 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3735 if (is_stream_io (dtp
))
3737 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3738 if (dtp
->u
.p
.current_unit
->strm_pos
3739 < ssize (dtp
->u
.p
.current_unit
->s
))
3740 unit_truncate (dtp
->u
.p
.current_unit
,
3741 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3749 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3754 /* Position to the next record, which means moving to the end of the
3755 current record. This can happen under several different
3756 conditions. If the done flag is not set, we get ready to process
3760 next_record (st_parameter_dt
*dtp
, int done
)
3762 gfc_offset fp
; /* File position. */
3764 dtp
->u
.p
.current_unit
->read_bad
= 0;
3766 if (dtp
->u
.p
.mode
== READING
)
3767 next_record_r (dtp
, done
);
3769 next_record_w (dtp
, done
);
3771 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3773 if (!is_stream_io (dtp
))
3775 /* Since we have changed the position, set it to unspecified so
3776 that INQUIRE(POSITION=) knows it needs to look into it. */
3778 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3780 dtp
->u
.p
.current_unit
->current_record
= 0;
3781 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3783 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3784 /* Calculate next record, rounding up partial records. */
3785 dtp
->u
.p
.current_unit
->last_record
=
3786 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3787 dtp
->u
.p
.current_unit
->recl
- 1;
3790 dtp
->u
.p
.current_unit
->last_record
++;
3796 smarkeor (dtp
->u
.p
.current_unit
->s
);
3800 /* Finalize the current data transfer. For a nonadvancing transfer,
3801 this means advancing to the next record. For internal units close the
3802 stream associated with the unit. */
3805 finalize_transfer (st_parameter_dt
*dtp
)
3807 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3809 if ((dtp
->u
.p
.ionml
!= NULL
)
3810 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3812 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3813 namelist_read (dtp
);
3815 namelist_write (dtp
);
3818 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3820 if (cf
& IOPARM_DT_HAS_FORMAT
)
3822 free (dtp
->u
.p
.fmt
);
3828 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3829 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
3831 if (dtp
->u
.p
.eor_condition
)
3833 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3837 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3839 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3840 dtp
->u
.p
.current_unit
->current_record
= 0;
3844 dtp
->u
.p
.transfer
= NULL
;
3845 if (dtp
->u
.p
.current_unit
== NULL
)
3848 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3850 finish_list_read (dtp
);
3854 if (dtp
->u
.p
.mode
== WRITING
)
3855 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3856 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3858 if (is_stream_io (dtp
))
3860 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3861 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3862 next_record (dtp
, 1);
3867 dtp
->u
.p
.current_unit
->current_record
= 0;
3869 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3871 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3872 dtp
->u
.p
.seen_dollar
= 0;
3876 /* For non-advancing I/O, save the current maximum position for use in the
3877 next I/O operation if needed. */
3878 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3880 if (dtp
->u
.p
.skips
> 0)
3883 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3884 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3885 - dtp
->u
.p
.current_unit
->bytes_left
);
3887 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3890 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3891 - dtp
->u
.p
.current_unit
->bytes_left
);
3892 dtp
->u
.p
.current_unit
->saved_pos
=
3893 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3894 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3897 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3898 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3899 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3901 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3903 next_record (dtp
, 1);
3906 #ifdef HAVE_USELOCALE
3907 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3909 uselocale (dtp
->u
.p
.old_locale
);
3910 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3913 __gthread_mutex_lock (&old_locale_lock
);
3914 if (!--old_locale_ctr
)
3916 setlocale (LC_NUMERIC
, old_locale
);
3919 __gthread_mutex_unlock (&old_locale_lock
);
3923 /* Transfer function for IOLENGTH. It doesn't actually do any
3924 data transfer, it just updates the length counter. */
3927 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3928 void *dest
__attribute__ ((unused
)),
3929 int kind
__attribute__((unused
)),
3930 size_t size
, size_t nelems
)
3932 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3933 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3937 /* Initialize the IOLENGTH data transfer. This function is in essence
3938 a very much simplified version of data_transfer_init(), because it
3939 doesn't have to deal with units at all. */
3942 iolength_transfer_init (st_parameter_dt
*dtp
)
3944 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3947 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3949 /* Set up the subroutine that will handle the transfers. */
3951 dtp
->u
.p
.transfer
= iolength_transfer
;
3955 /* Library entry point for the IOLENGTH form of the INQUIRE
3956 statement. The IOLENGTH form requires no I/O to be performed, but
3957 it must still be a runtime library call so that we can determine
3958 the iolength for dynamic arrays and such. */
3960 extern void st_iolength (st_parameter_dt
*);
3961 export_proto(st_iolength
);
3964 st_iolength (st_parameter_dt
*dtp
)
3966 library_start (&dtp
->common
);
3967 iolength_transfer_init (dtp
);
3970 extern void st_iolength_done (st_parameter_dt
*);
3971 export_proto(st_iolength_done
);
3974 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3981 /* The READ statement. */
3983 extern void st_read (st_parameter_dt
*);
3984 export_proto(st_read
);
3987 st_read (st_parameter_dt
*dtp
)
3989 library_start (&dtp
->common
);
3991 data_transfer_init (dtp
, 1);
3994 extern void st_read_done (st_parameter_dt
*);
3995 export_proto(st_read_done
);
3998 st_read_done (st_parameter_dt
*dtp
)
4000 finalize_transfer (dtp
);
4004 /* If this is a parent READ statement we do not need to retain the
4005 internal unit structure for child use. Free it and stash the unit
4006 number for reuse. */
4007 if (dtp
->u
.p
.current_unit
!= NULL
4008 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4010 if (is_internal_unit (dtp
) &&
4011 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4013 free (dtp
->u
.p
.current_unit
->filename
);
4014 dtp
->u
.p
.current_unit
->filename
= NULL
;
4015 free (dtp
->u
.p
.current_unit
->s
);
4016 dtp
->u
.p
.current_unit
->s
= NULL
;
4017 if (dtp
->u
.p
.current_unit
->ls
)
4018 free (dtp
->u
.p
.current_unit
->ls
);
4019 dtp
->u
.p
.current_unit
->ls
= NULL
;
4020 stash_internal_unit (dtp
);
4022 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4024 free_format_data (dtp
->u
.p
.fmt
);
4027 unlock_unit (dtp
->u
.p
.current_unit
);
4033 extern void st_write (st_parameter_dt
*);
4034 export_proto(st_write
);
4037 st_write (st_parameter_dt
*dtp
)
4039 library_start (&dtp
->common
);
4040 data_transfer_init (dtp
, 0);
4043 extern void st_write_done (st_parameter_dt
*);
4044 export_proto(st_write_done
);
4047 st_write_done (st_parameter_dt
*dtp
)
4049 finalize_transfer (dtp
);
4051 if (dtp
->u
.p
.current_unit
!= NULL
4052 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4054 /* Deal with endfile conditions associated with sequential files. */
4055 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4056 switch (dtp
->u
.p
.current_unit
->endfile
)
4058 case AT_ENDFILE
: /* Remain at the endfile record. */
4062 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4066 /* Get rid of whatever is after this record. */
4067 if (!is_internal_unit (dtp
))
4068 unit_truncate (dtp
->u
.p
.current_unit
,
4069 stell (dtp
->u
.p
.current_unit
->s
),
4071 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4077 /* If this is a parent WRITE statement we do not need to retain the
4078 internal unit structure for child use. Free it and stash the
4079 unit number for reuse. */
4080 if (is_internal_unit (dtp
) &&
4081 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4083 free (dtp
->u
.p
.current_unit
->filename
);
4084 dtp
->u
.p
.current_unit
->filename
= NULL
;
4085 free (dtp
->u
.p
.current_unit
->s
);
4086 dtp
->u
.p
.current_unit
->s
= NULL
;
4087 if (dtp
->u
.p
.current_unit
->ls
)
4088 free (dtp
->u
.p
.current_unit
->ls
);
4089 dtp
->u
.p
.current_unit
->ls
= NULL
;
4090 stash_internal_unit (dtp
);
4092 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4094 free_format_data (dtp
->u
.p
.fmt
);
4097 unlock_unit (dtp
->u
.p
.current_unit
);
4103 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4105 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4110 /* Receives the scalar information for namelist objects and stores it
4111 in a linked list of namelist_info types. */
4114 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4115 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4116 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4118 namelist_info
*t1
= NULL
;
4120 size_t var_name_len
= strlen (var_name
);
4122 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4124 nml
->mem_pos
= var_addr
;
4125 nml
->dtio_sub
= dtio_sub
;
4126 nml
->vtable
= vtable
;
4128 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4129 memcpy (nml
->var_name
, var_name
, var_name_len
);
4130 nml
->var_name
[var_name_len
] = '\0';
4132 nml
->len
= (int) len
;
4133 nml
->string_length
= (index_type
) string_length
;
4135 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4136 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4137 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4139 if (nml
->var_rank
> 0)
4141 nml
->dim
= (descriptor_dimension
*)
4142 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4143 nml
->ls
= (array_loop_spec
*)
4144 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4154 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4156 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4157 dtp
->u
.p
.ionml
= nml
;
4161 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4166 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4167 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4168 export_proto(st_set_nml_var
);
4171 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4172 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4173 GFC_INTEGER_4 dtype
)
4175 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4180 /* Essentially the same as previous but carrying the dtio procedure
4181 and the vtable as additional arguments. */
4182 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4183 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4185 export_proto(st_set_nml_dtio_var
);
4189 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4190 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4191 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4193 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4194 dtype
, dtio_sub
, vtable
);
4197 /* Store the dimensional information for the namelist object. */
4198 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4199 index_type
, index_type
,
4201 export_proto(st_set_nml_var_dim
);
4204 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4205 index_type stride
, index_type lbound
,
4208 namelist_info
* nml
;
4213 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4215 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4219 /* Once upon a time, a poor innocent Fortran program was reading a
4220 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4221 the OS doesn't tell whether we're at the EOF or whether we already
4222 went past it. Luckily our hero, libgfortran, keeps track of this.
4223 Call this function when you detect an EOF condition. See Section
4227 hit_eof (st_parameter_dt
* dtp
)
4229 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4231 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4232 switch (dtp
->u
.p
.current_unit
->endfile
)
4236 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4237 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4239 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4240 dtp
->u
.p
.current_unit
->current_record
= 0;
4243 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4247 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4248 dtp
->u
.p
.current_unit
->current_record
= 0;
4253 /* Non-sequential files don't have an ENDFILE record, so we
4254 can't be at AFTER_ENDFILE. */
4255 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4256 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4257 dtp
->u
.p
.current_unit
->current_record
= 0;