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 (q
== '\n' || q
== '\r')
321 /* Unexpected end of line. Set the position. */
322 dtp
->u
.p
.sf_seen_eor
= 1;
324 /* If we see an EOR during non-advancing I/O, we need to skip
325 the rest of the I/O statement. Set the corresponding flag. */
326 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
327 dtp
->u
.p
.eor_condition
= 1;
329 /* If we encounter a CR, it might be a CRLF. */
330 if (q
== '\r') /* Probably a CRLF */
332 /* See if there is an LF. */
333 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
335 dtp
->u
.p
.sf_seen_eor
= 2;
336 else if (q2
!= EOF
) /* Oops, seek back. */
337 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
340 /* Without padding, terminate the I/O statement without assigning
341 the value. With padding, the value still needs to be assigned,
342 so we can just continue with a short read. */
343 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
345 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
352 /* Short circuit the read if a comma is found during numeric input.
353 The flag is set to zero during character reads so that commas in
354 strings are not ignored */
356 if (dtp
->u
.p
.sf_read_comma
== 1)
359 notify_std (&dtp
->common
, GFC_STD_GNU
,
360 "Comma in formatted numeric read.");
368 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
369 some other stuff. Set the relevant flags. */
370 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
374 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
376 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
382 dtp
->u
.p
.eor_condition
= 1;
387 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
388 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
389 || dtp
->u
.p
.current_unit
->bytes_left
390 == dtp
->u
.p
.current_unit
->recl
)
399 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
401 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
402 dtp
->u
.p
.current_unit
->has_size
)
403 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
405 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
406 fbuf_getc might reallocate the buffer. So return current pointer
407 minus all the advances, which is n plus up to two characters
408 of newline or comma. */
409 return fbuf_getptr (dtp
->u
.p
.current_unit
)
410 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
414 /* Function for reading the next couple of bytes from the current
415 file, advancing the current position. We return NULL on end of record or
416 end of file. This function is only for formatted I/O, unformatted uses
419 If the read is short, then it is because the current record does not
420 have enough data to satisfy the read request and the file was
421 opened with PAD=YES. The caller must assume tailing spaces for
425 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
430 if (!is_stream_io (dtp
))
432 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
434 /* For preconnected units with default record length, set bytes left
435 to unit record length and proceed, otherwise error. */
436 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
437 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
438 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
441 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
442 && !is_internal_unit (dtp
))
444 /* Not enough data left. */
445 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
450 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
451 && !is_internal_unit(dtp
)))
457 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
461 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
462 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
463 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
465 if (is_internal_unit (dtp
))
466 source
= read_sf_internal (dtp
, nbytes
);
468 source
= read_sf (dtp
, nbytes
);
470 dtp
->u
.p
.current_unit
->strm_pos
+=
471 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
475 /* If we reach here, we can assume it's direct access. */
477 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
480 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
481 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
483 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
484 dtp
->u
.p
.current_unit
->has_size
)
485 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
487 if (norig
!= *nbytes
)
489 /* Short read, this shouldn't happen. */
490 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
492 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
497 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
503 /* Read a block from a character(kind=4) internal unit, to be transferred into
504 a character(kind=4) variable. Note: Portions of this code borrowed from
507 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
509 static gfc_char4_t
*empty_string
[0];
513 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
514 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
516 /* Zero size array gives internal unit len of 0. Nothing to read. */
517 if (dtp
->internal_unit_len
== 0
518 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
521 /* If we have seen an eor previously, return a length of 0. The
522 caller is responsible for correctly padding the input field. */
523 if (dtp
->u
.p
.sf_seen_eor
)
526 /* Just return something that isn't a NULL pointer, otherwise the
527 caller thinks an error occurred. */
532 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
534 if (unlikely (lorig
> *nbytes
))
540 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
542 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
543 dtp
->u
.p
.current_unit
->has_size
)
544 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
550 /* Reads a block directly into application data space. This is for
551 unformatted files. */
554 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
556 ssize_t to_read_record
;
557 ssize_t have_read_record
;
558 ssize_t to_read_subrecord
;
559 ssize_t have_read_subrecord
;
562 if (is_stream_io (dtp
))
564 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
566 if (unlikely (have_read_record
< 0))
568 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
572 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
574 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
576 /* Short read, e.g. if we hit EOF. For stream files,
577 we have to set the end-of-file condition. */
583 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
585 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
588 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
589 nbytes
= to_read_record
;
594 to_read_record
= nbytes
;
597 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
599 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
600 if (unlikely (to_read_record
< 0))
602 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
606 if (to_read_record
!= (ssize_t
) nbytes
)
608 /* Short read, e.g. if we hit EOF. Apparently, we read
609 more than was written to the last record. */
613 if (unlikely (short_record
))
615 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
620 /* Unformatted sequential. We loop over the subrecords, reading
621 until the request has been fulfilled or the record has run out
622 of continuation subrecords. */
624 /* Check whether we exceed the total record length. */
626 if (dtp
->u
.p
.current_unit
->flags
.has_recl
627 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
629 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
634 to_read_record
= nbytes
;
637 have_read_record
= 0;
641 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
642 < (gfc_offset
) to_read_record
)
644 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
645 to_read_record
-= to_read_subrecord
;
649 to_read_subrecord
= to_read_record
;
653 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
655 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
656 buf
+ have_read_record
, to_read_subrecord
);
657 if (unlikely (have_read_subrecord
< 0))
659 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
663 have_read_record
+= have_read_subrecord
;
665 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
667 /* Short read, e.g. if we hit EOF. This means the record
668 structure has been corrupted, or the trailing record
669 marker would still be present. */
671 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
675 if (to_read_record
> 0)
677 if (likely (dtp
->u
.p
.current_unit
->continued
))
679 next_record_r_unf (dtp
, 0);
684 /* Let's make sure the file position is correctly pre-positioned
685 for the next read statement. */
687 dtp
->u
.p
.current_unit
->current_record
= 0;
688 next_record_r_unf (dtp
, 0);
689 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
695 /* Normal exit, the read request has been fulfilled. */
700 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
701 if (unlikely (short_record
))
703 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
710 /* Function for writing a block of bytes to the current file at the
711 current position, advancing the file pointer. We are given a length
712 and return a pointer to a buffer that the caller must (completely)
713 fill in. Returns NULL on error. */
716 write_block (st_parameter_dt
*dtp
, int length
)
720 if (!is_stream_io (dtp
))
722 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
724 /* For preconnected units with default record length, set bytes left
725 to unit record length and proceed, otherwise error. */
726 if (likely ((dtp
->u
.p
.current_unit
->unit_number
727 == options
.stdout_unit
728 || dtp
->u
.p
.current_unit
->unit_number
729 == options
.stderr_unit
)
730 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
731 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
734 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
739 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
742 if (is_internal_unit (dtp
))
744 if (is_char4_unit(dtp
)) /* char4 internel unit. */
747 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
750 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
756 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
760 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
764 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
765 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
769 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
772 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
777 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
778 dtp
->u
.p
.current_unit
->has_size
)
779 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
781 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
787 /* High level interface to swrite(), taking care of errors. This is only
788 called for unformatted files. There are three cases to consider:
789 Stream I/O, unformatted direct, unformatted sequential. */
792 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
795 ssize_t have_written
;
796 ssize_t to_write_subrecord
;
801 if (is_stream_io (dtp
))
803 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
804 if (unlikely (have_written
< 0))
806 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
810 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
815 /* Unformatted direct access. */
817 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
819 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
821 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
825 if (buf
== NULL
&& nbytes
== 0)
828 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
829 if (unlikely (have_written
< 0))
831 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
835 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
836 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
841 /* Unformatted sequential. */
845 if (dtp
->u
.p
.current_unit
->flags
.has_recl
846 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
848 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
860 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
861 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
863 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
864 (gfc_offset
) to_write_subrecord
;
866 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
867 buf
+ have_written
, to_write_subrecord
);
868 if (unlikely (to_write_subrecord
< 0))
870 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
874 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
875 nbytes
-= to_write_subrecord
;
876 have_written
+= to_write_subrecord
;
881 next_record_w_unf (dtp
, 1);
884 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
885 if (unlikely (short_record
))
887 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
894 /* Reverse memcpy - used for byte swapping. */
897 reverse_memcpy (void *dest
, const void *src
, size_t n
)
903 s
= (char *) src
+ n
- 1;
905 /* Write with ascending order - this is likely faster
906 on modern architectures because of write combining. */
912 /* Utility function for byteswapping an array, using the bswap
913 builtins if possible. dest and src can overlap completely, or then
914 they must point to separate objects; partial overlaps are not
918 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
928 for (size_t i
= 0; i
< nelems
; i
++)
929 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
932 for (size_t i
= 0; i
< nelems
; i
++)
933 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
936 for (size_t i
= 0; i
< nelems
; i
++)
937 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
942 for (size_t i
= 0; i
< nelems
; i
++)
945 memcpy (&tmp
, ps
, 4);
946 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
947 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
948 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
956 for (size_t i
= 0; i
< nelems
; i
++)
959 memcpy (&tmp
, ps
, 8);
960 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
961 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
971 for (size_t i
= 0; i
< nelems
; i
++)
973 reverse_memcpy (pd
, ps
, size
);
980 /* In-place byte swap. */
981 for (size_t i
= 0; i
< nelems
; i
++)
983 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
984 for (size_t j
= 0; j
< size
/2; j
++)
999 /* Master function for unformatted reads. */
1002 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1003 void *dest
, int kind
, size_t size
, size_t nelems
)
1005 if (type
== BT_CLASS
)
1007 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1008 char tmp_iomsg
[IOMSG_LEN
] = "";
1010 gfc_charlen_type child_iomsg_len
;
1012 int *child_iostat
= NULL
;
1014 /* Set iostat, intent(out). */
1016 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1017 dtp
->common
.iostat
: &noiostat
;
1019 /* Set iomsg, intent(inout). */
1020 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1022 child_iomsg
= dtp
->common
.iomsg
;
1023 child_iomsg_len
= dtp
->common
.iomsg_len
;
1027 child_iomsg
= tmp_iomsg
;
1028 child_iomsg_len
= IOMSG_LEN
;
1031 /* Call the user defined unformatted READ procedure. */
1032 dtp
->u
.p
.current_unit
->child_dtio
++;
1033 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1035 dtp
->u
.p
.current_unit
->child_dtio
--;
1039 if (type
== BT_CHARACTER
)
1040 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1041 read_block_direct (dtp
, dest
, size
* nelems
);
1043 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1046 /* Handle wide chracters. */
1047 if (type
== BT_CHARACTER
)
1053 /* Break up complex into its constituent reals. */
1054 else if (type
== BT_COMPLEX
)
1059 bswap_array (dest
, dest
, size
, nelems
);
1064 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1065 bytes on 64 bit machines. The unused bytes are not initialized and never
1066 used, which can show an error with memory checking analyzers like
1067 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1070 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1071 void *source
, int kind
, size_t size
, size_t nelems
)
1073 if (type
== BT_CLASS
)
1075 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1076 char tmp_iomsg
[IOMSG_LEN
] = "";
1078 gfc_charlen_type child_iomsg_len
;
1080 int *child_iostat
= NULL
;
1082 /* Set iostat, intent(out). */
1084 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1085 dtp
->common
.iostat
: &noiostat
;
1087 /* Set iomsg, intent(inout). */
1088 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1090 child_iomsg
= dtp
->common
.iomsg
;
1091 child_iomsg_len
= dtp
->common
.iomsg_len
;
1095 child_iomsg
= tmp_iomsg
;
1096 child_iomsg_len
= IOMSG_LEN
;
1099 /* Call the user defined unformatted WRITE procedure. */
1100 dtp
->u
.p
.current_unit
->child_dtio
++;
1101 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1103 dtp
->u
.p
.current_unit
->child_dtio
--;
1107 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1110 size_t stride
= type
== BT_CHARACTER
?
1111 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1113 write_buf (dtp
, source
, stride
* nelems
);
1117 #define BSWAP_BUFSZ 512
1118 char buffer
[BSWAP_BUFSZ
];
1124 /* Handle wide chracters. */
1125 if (type
== BT_CHARACTER
&& kind
!= 1)
1131 /* Break up complex into its constituent reals. */
1132 if (type
== BT_COMPLEX
)
1138 /* By now, all complex variables have been split into their
1139 constituent reals. */
1145 if (size
* nrem
> BSWAP_BUFSZ
)
1146 nc
= BSWAP_BUFSZ
/ size
;
1150 bswap_array (buffer
, p
, size
, nc
);
1151 write_buf (dtp
, buffer
, size
* nc
);
1160 /* Return a pointer to the name of a type. */
1185 p
= "CLASS or DERIVED";
1188 internal_error (NULL
, "type_name(): Bad type");
1195 /* Write a constant string to the output.
1196 This is complicated because the string can have doubled delimiters
1197 in it. The length in the format node is the true length. */
1200 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1202 char c
, delimiter
, *p
, *q
;
1205 length
= f
->u
.string
.length
;
1209 p
= write_block (dtp
, length
);
1216 for (; length
> 0; length
--)
1219 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1220 q
++; /* Skip the doubled delimiter. */
1225 /* Given actual and expected types in a formatted data transfer, make
1226 sure they agree. If not, an error message is generated. Returns
1227 nonzero if something went wrong. */
1230 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1233 char buffer
[BUFLEN
];
1235 if (actual
== expected
)
1238 /* Adjust item_count before emitting error message. */
1239 snprintf (buffer
, BUFLEN
,
1240 "Expected %s for item %d in formatted transfer, got %s",
1241 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1243 format_error (dtp
, f
, buffer
);
1249 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1252 char buffer
[BUFLEN
];
1254 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1257 /* Adjust item_count before emitting error message. */
1258 snprintf (buffer
, BUFLEN
,
1259 "Expected numeric type for item %d in formatted transfer, got %s",
1260 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1262 format_error (dtp
, f
, buffer
);
1267 /* This function is in the main loop for a formatted data transfer
1268 statement. It would be natural to implement this as a coroutine
1269 with the user program, but C makes that awkward. We loop,
1270 processing format elements. When we actually have to transfer
1271 data instead of just setting flags, we return control to the user
1272 program which calls a function that supplies the address and type
1273 of the next element, then comes back here to process it. */
1276 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1279 int pos
, bytes_used
;
1283 int consume_data_flag
;
1285 /* Change a complex data item into a pair of reals. */
1287 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1288 if (type
== BT_COMPLEX
)
1294 /* If there's an EOR condition, we simulate finalizing the transfer
1295 by doing nothing. */
1296 if (dtp
->u
.p
.eor_condition
)
1299 /* Set this flag so that commas in reads cause the read to complete before
1300 the entire field has been read. The next read field will start right after
1301 the comma in the stream. (Set to 0 for character reads). */
1302 dtp
->u
.p
.sf_read_comma
=
1303 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1307 /* If reversion has occurred and there is another real data item,
1308 then we have to move to the next record. */
1309 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1311 dtp
->u
.p
.reversion_flag
= 0;
1312 next_record (dtp
, 0);
1315 consume_data_flag
= 1;
1316 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1319 f
= next_format (dtp
);
1322 /* No data descriptors left. */
1323 if (unlikely (n
> 0))
1324 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1325 "Insufficient data descriptors in format after reversion");
1331 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1332 - dtp
->u
.p
.current_unit
->bytes_left
);
1334 if (is_stream_io(dtp
))
1341 goto need_read_data
;
1342 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1344 read_decimal (dtp
, f
, p
, kind
);
1349 goto need_read_data
;
1350 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1351 && require_numeric_type (dtp
, type
, f
))
1353 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1354 && require_type (dtp
, BT_INTEGER
, type
, f
))
1356 read_radix (dtp
, f
, p
, kind
, 2);
1361 goto need_read_data
;
1362 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1363 && require_numeric_type (dtp
, type
, f
))
1365 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1366 && require_type (dtp
, BT_INTEGER
, type
, f
))
1368 read_radix (dtp
, f
, p
, kind
, 8);
1373 goto need_read_data
;
1374 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1375 && require_numeric_type (dtp
, type
, f
))
1377 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1378 && require_type (dtp
, BT_INTEGER
, type
, f
))
1380 read_radix (dtp
, f
, p
, kind
, 16);
1385 goto need_read_data
;
1387 /* It is possible to have FMT_A with something not BT_CHARACTER such
1388 as when writing out hollerith strings, so check both type
1389 and kind before calling wide character routines. */
1390 if (type
== BT_CHARACTER
&& kind
== 4)
1391 read_a_char4 (dtp
, f
, p
, size
);
1393 read_a (dtp
, f
, p
, size
);
1398 goto need_read_data
;
1399 read_l (dtp
, f
, p
, kind
);
1404 goto need_read_data
;
1405 if (require_type (dtp
, BT_REAL
, type
, f
))
1407 read_f (dtp
, f
, p
, kind
);
1412 goto need_read_data
;
1413 if (require_type (dtp
, BT_CLASS
, type
, f
))
1415 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1417 char tmp_iomsg
[IOMSG_LEN
] = "";
1419 gfc_charlen_type child_iomsg_len
;
1421 int *child_iostat
= NULL
;
1422 char *iotype
= f
->u
.udf
.string
;
1423 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1425 /* Build the iotype string. */
1426 if (iotype_len
== 0)
1434 iotype
= xmalloc (iotype_len
);
1437 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1440 /* Set iostat, intent(out). */
1442 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1443 dtp
->common
.iostat
: &noiostat
;
1445 /* Set iomsg, intent(inout). */
1446 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1448 child_iomsg
= dtp
->common
.iomsg
;
1449 child_iomsg_len
= dtp
->common
.iomsg_len
;
1453 child_iomsg
= tmp_iomsg
;
1454 child_iomsg_len
= IOMSG_LEN
;
1457 /* Call the user defined formatted READ procedure. */
1458 dtp
->u
.p
.current_unit
->child_dtio
++;
1459 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1460 child_iostat
, child_iomsg
,
1461 iotype_len
, child_iomsg_len
);
1462 dtp
->u
.p
.current_unit
->child_dtio
--;
1464 if (f
->u
.udf
.string_len
!= 0)
1466 /* Note: vlist is freed in free_format_data. */
1471 goto need_read_data
;
1472 if (require_type (dtp
, BT_REAL
, type
, f
))
1474 read_f (dtp
, f
, p
, kind
);
1479 goto need_read_data
;
1480 if (require_type (dtp
, BT_REAL
, type
, f
))
1482 read_f (dtp
, f
, p
, kind
);
1487 goto need_read_data
;
1488 if (require_type (dtp
, BT_REAL
, type
, f
))
1490 read_f (dtp
, f
, p
, kind
);
1495 goto need_read_data
;
1496 if (require_type (dtp
, BT_REAL
, type
, f
))
1498 read_f (dtp
, f
, p
, kind
);
1503 goto need_read_data
;
1507 read_decimal (dtp
, f
, p
, kind
);
1510 read_l (dtp
, f
, p
, kind
);
1514 read_a_char4 (dtp
, f
, p
, size
);
1516 read_a (dtp
, f
, p
, size
);
1519 read_f (dtp
, f
, p
, kind
);
1522 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1527 consume_data_flag
= 0;
1528 format_error (dtp
, f
, "Constant string in input format");
1531 /* Format codes that don't transfer data. */
1534 consume_data_flag
= 0;
1535 dtp
->u
.p
.skips
+= f
->u
.n
;
1536 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1537 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1538 read_x (dtp
, f
->u
.n
);
1543 consume_data_flag
= 0;
1545 if (f
->format
== FMT_TL
)
1547 /* Handle the special case when no bytes have been used yet.
1548 Cannot go below zero. */
1549 if (bytes_used
== 0)
1551 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1552 dtp
->u
.p
.skips
-= f
->u
.n
;
1553 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1556 pos
= bytes_used
- f
->u
.n
;
1561 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1562 left tab limit. We do not check if the position has gone
1563 beyond the end of record because a subsequent tab could
1564 bring us back again. */
1565 pos
= pos
< 0 ? 0 : pos
;
1567 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1568 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1569 + pos
- dtp
->u
.p
.max_pos
;
1570 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1571 ? 0 : dtp
->u
.p
.pending_spaces
;
1572 if (dtp
->u
.p
.skips
== 0)
1575 /* Adjust everything for end-of-record condition */
1576 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1578 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1579 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1581 dtp
->u
.p
.sf_seen_eor
= 0;
1583 if (dtp
->u
.p
.skips
< 0)
1585 if (is_internal_unit (dtp
))
1586 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1588 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1589 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1590 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1593 read_x (dtp
, dtp
->u
.p
.skips
);
1597 consume_data_flag
= 0;
1598 dtp
->u
.p
.sign_status
= SIGN_S
;
1602 consume_data_flag
= 0;
1603 dtp
->u
.p
.sign_status
= SIGN_SS
;
1607 consume_data_flag
= 0;
1608 dtp
->u
.p
.sign_status
= SIGN_SP
;
1612 consume_data_flag
= 0 ;
1613 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1617 consume_data_flag
= 0;
1618 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1622 consume_data_flag
= 0;
1623 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1627 consume_data_flag
= 0;
1628 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1632 consume_data_flag
= 0;
1633 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1637 consume_data_flag
= 0;
1638 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1642 consume_data_flag
= 0;
1643 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1647 consume_data_flag
= 0;
1648 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1652 consume_data_flag
= 0;
1653 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1657 consume_data_flag
= 0;
1658 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1662 consume_data_flag
= 0;
1663 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1667 consume_data_flag
= 0;
1668 dtp
->u
.p
.seen_dollar
= 1;
1672 consume_data_flag
= 0;
1673 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1674 next_record (dtp
, 0);
1678 /* A colon descriptor causes us to exit this loop (in
1679 particular preventing another / descriptor from being
1680 processed) unless there is another data item to be
1682 consume_data_flag
= 0;
1688 internal_error (&dtp
->common
, "Bad format node");
1691 /* Adjust the item count and data pointer. */
1693 if ((consume_data_flag
> 0) && (n
> 0))
1696 p
= ((char *) p
) + size
;
1701 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1702 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1707 /* Come here when we need a data descriptor but don't have one. We
1708 push the current format node back onto the input, then return and
1709 let the user program call us back with the data. */
1711 unget_format (dtp
, f
);
1716 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1719 int pos
, bytes_used
;
1723 int consume_data_flag
;
1725 /* Change a complex data item into a pair of reals. */
1727 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1728 if (type
== BT_COMPLEX
)
1734 /* If there's an EOR condition, we simulate finalizing the transfer
1735 by doing nothing. */
1736 if (dtp
->u
.p
.eor_condition
)
1739 /* Set this flag so that commas in reads cause the read to complete before
1740 the entire field has been read. The next read field will start right after
1741 the comma in the stream. (Set to 0 for character reads). */
1742 dtp
->u
.p
.sf_read_comma
=
1743 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1747 /* If reversion has occurred and there is another real data item,
1748 then we have to move to the next record. */
1749 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1751 dtp
->u
.p
.reversion_flag
= 0;
1752 next_record (dtp
, 0);
1755 consume_data_flag
= 1;
1756 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1759 f
= next_format (dtp
);
1762 /* No data descriptors left. */
1763 if (unlikely (n
> 0))
1764 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1765 "Insufficient data descriptors in format after reversion");
1769 /* Now discharge T, TR and X movements to the right. This is delayed
1770 until a data producing format to suppress trailing spaces. */
1773 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1774 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1775 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1776 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1777 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1779 || t
== FMT_STRING
))
1781 if (dtp
->u
.p
.skips
> 0)
1784 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1785 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1786 - dtp
->u
.p
.current_unit
->bytes_left
);
1788 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1791 if (dtp
->u
.p
.skips
< 0)
1793 if (is_internal_unit (dtp
))
1794 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1796 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1797 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1799 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1802 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1803 - dtp
->u
.p
.current_unit
->bytes_left
);
1805 if (is_stream_io(dtp
))
1813 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1815 write_i (dtp
, f
, p
, kind
);
1821 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1822 && require_numeric_type (dtp
, type
, f
))
1824 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1825 && require_type (dtp
, BT_INTEGER
, type
, f
))
1827 write_b (dtp
, f
, p
, kind
);
1833 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1834 && require_numeric_type (dtp
, type
, f
))
1836 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1837 && require_type (dtp
, BT_INTEGER
, type
, f
))
1839 write_o (dtp
, f
, p
, kind
);
1845 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1846 && require_numeric_type (dtp
, type
, f
))
1848 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1849 && require_type (dtp
, BT_INTEGER
, type
, f
))
1851 write_z (dtp
, f
, p
, kind
);
1858 /* It is possible to have FMT_A with something not BT_CHARACTER such
1859 as when writing out hollerith strings, so check both type
1860 and kind before calling wide character routines. */
1861 if (type
== BT_CHARACTER
&& kind
== 4)
1862 write_a_char4 (dtp
, f
, p
, size
);
1864 write_a (dtp
, f
, p
, size
);
1870 write_l (dtp
, f
, p
, kind
);
1876 if (require_type (dtp
, BT_REAL
, type
, f
))
1878 write_d (dtp
, f
, p
, kind
);
1884 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1886 char tmp_iomsg
[IOMSG_LEN
] = "";
1888 gfc_charlen_type child_iomsg_len
;
1890 int *child_iostat
= NULL
;
1891 char *iotype
= f
->u
.udf
.string
;
1892 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1894 /* Build the iotype string. */
1895 if (iotype_len
== 0)
1903 iotype
= xmalloc (iotype_len
);
1906 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1909 /* Set iostat, intent(out). */
1911 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1912 dtp
->common
.iostat
: &noiostat
;
1914 /* Set iomsg, intent(inout). */
1915 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1917 child_iomsg
= dtp
->common
.iomsg
;
1918 child_iomsg_len
= dtp
->common
.iomsg_len
;
1922 child_iomsg
= tmp_iomsg
;
1923 child_iomsg_len
= IOMSG_LEN
;
1926 /* Call the user defined formatted WRITE procedure. */
1927 dtp
->u
.p
.current_unit
->child_dtio
++;
1928 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1929 child_iostat
, child_iomsg
,
1930 iotype_len
, child_iomsg_len
);
1931 dtp
->u
.p
.current_unit
->child_dtio
--;
1933 if (f
->u
.udf
.string_len
!= 0)
1935 /* Note: vlist is freed in free_format_data. */
1941 if (require_type (dtp
, BT_REAL
, type
, f
))
1943 write_e (dtp
, f
, p
, kind
);
1949 if (require_type (dtp
, BT_REAL
, type
, f
))
1951 write_en (dtp
, f
, p
, kind
);
1957 if (require_type (dtp
, BT_REAL
, type
, f
))
1959 write_es (dtp
, f
, p
, kind
);
1965 if (require_type (dtp
, BT_REAL
, type
, f
))
1967 write_f (dtp
, f
, p
, kind
);
1976 write_i (dtp
, f
, p
, kind
);
1979 write_l (dtp
, f
, p
, kind
);
1983 write_a_char4 (dtp
, f
, p
, size
);
1985 write_a (dtp
, f
, p
, size
);
1988 if (f
->u
.real
.w
== 0)
1989 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1991 write_d (dtp
, f
, p
, kind
);
1994 internal_error (&dtp
->common
,
1995 "formatted_transfer(): Bad type");
2000 consume_data_flag
= 0;
2001 write_constant_string (dtp
, f
);
2004 /* Format codes that don't transfer data. */
2007 consume_data_flag
= 0;
2009 dtp
->u
.p
.skips
+= f
->u
.n
;
2010 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2011 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2012 /* Writes occur just before the switch on f->format, above, so
2013 that trailing blanks are suppressed, unless we are doing a
2014 non-advancing write in which case we want to output the blanks
2016 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2018 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2019 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2025 consume_data_flag
= 0;
2027 if (f
->format
== FMT_TL
)
2030 /* Handle the special case when no bytes have been used yet.
2031 Cannot go below zero. */
2032 if (bytes_used
== 0)
2034 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2035 dtp
->u
.p
.skips
-= f
->u
.n
;
2036 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2039 pos
= bytes_used
- f
->u
.n
;
2042 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2044 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2045 left tab limit. We do not check if the position has gone
2046 beyond the end of record because a subsequent tab could
2047 bring us back again. */
2048 pos
= pos
< 0 ? 0 : pos
;
2050 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2051 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2052 + pos
- dtp
->u
.p
.max_pos
;
2053 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2054 ? 0 : dtp
->u
.p
.pending_spaces
;
2058 consume_data_flag
= 0;
2059 dtp
->u
.p
.sign_status
= SIGN_S
;
2063 consume_data_flag
= 0;
2064 dtp
->u
.p
.sign_status
= SIGN_SS
;
2068 consume_data_flag
= 0;
2069 dtp
->u
.p
.sign_status
= SIGN_SP
;
2073 consume_data_flag
= 0 ;
2074 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2078 consume_data_flag
= 0;
2079 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2083 consume_data_flag
= 0;
2084 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2088 consume_data_flag
= 0;
2089 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2093 consume_data_flag
= 0;
2094 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2098 consume_data_flag
= 0;
2099 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2103 consume_data_flag
= 0;
2104 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2108 consume_data_flag
= 0;
2109 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2113 consume_data_flag
= 0;
2114 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2118 consume_data_flag
= 0;
2119 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2123 consume_data_flag
= 0;
2124 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2128 consume_data_flag
= 0;
2129 dtp
->u
.p
.seen_dollar
= 1;
2133 consume_data_flag
= 0;
2134 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2135 next_record (dtp
, 0);
2139 /* A colon descriptor causes us to exit this loop (in
2140 particular preventing another / descriptor from being
2141 processed) unless there is another data item to be
2143 consume_data_flag
= 0;
2149 internal_error (&dtp
->common
, "Bad format node");
2152 /* Adjust the item count and data pointer. */
2154 if ((consume_data_flag
> 0) && (n
> 0))
2157 p
= ((char *) p
) + size
;
2160 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2161 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2166 /* Come here when we need a data descriptor but don't have one. We
2167 push the current format node back onto the input, then return and
2168 let the user program call us back with the data. */
2170 unget_format (dtp
, f
);
2173 /* This function is first called from data_init_transfer to initiate the loop
2174 over each item in the format, transferring data as required. Subsequent
2175 calls to this function occur for each data item foound in the READ/WRITE
2176 statement. The item_count is incremented for each call. Since the first
2177 call is from data_transfer_init, the item_count is always one greater than
2178 the actual count number of the item being transferred. */
2181 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2182 size_t size
, size_t nelems
)
2188 size_t stride
= type
== BT_CHARACTER
?
2189 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2190 if (dtp
->u
.p
.mode
== READING
)
2192 /* Big loop over all the elements. */
2193 for (elem
= 0; elem
< nelems
; elem
++)
2195 dtp
->u
.p
.item_count
++;
2196 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2201 /* Big loop over all the elements. */
2202 for (elem
= 0; elem
< nelems
; elem
++)
2204 dtp
->u
.p
.item_count
++;
2205 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2211 /* Data transfer entry points. The type of the data entity is
2212 implicit in the subroutine call. This prevents us from having to
2213 share a common enum with the compiler. */
2216 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2218 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2220 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2224 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2226 transfer_integer (dtp
, p
, kind
);
2230 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2233 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2235 size
= size_from_real_kind (kind
);
2236 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2240 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2242 transfer_real (dtp
, p
, kind
);
2246 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2248 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2250 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2254 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2256 transfer_logical (dtp
, p
, kind
);
2260 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2262 static char *empty_string
[0];
2264 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2267 /* Strings of zero length can have p == NULL, which confuses the
2268 transfer routines into thinking we need more data elements. To avoid
2269 this, we give them a nice pointer. */
2270 if (len
== 0 && p
== NULL
)
2273 /* Set kind here to 1. */
2274 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2278 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2280 transfer_character (dtp
, p
, len
);
2284 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2286 static char *empty_string
[0];
2288 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2291 /* Strings of zero length can have p == NULL, which confuses the
2292 transfer routines into thinking we need more data elements. To avoid
2293 this, we give them a nice pointer. */
2294 if (len
== 0 && p
== NULL
)
2297 /* Here we pass the actual kind value. */
2298 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2302 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2304 transfer_character_wide (dtp
, p
, len
, kind
);
2308 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2311 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2313 size
= size_from_complex_kind (kind
);
2314 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2318 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2320 transfer_complex (dtp
, p
, kind
);
2324 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2325 gfc_charlen_type charlen
)
2327 index_type count
[GFC_MAX_DIMENSIONS
];
2328 index_type extent
[GFC_MAX_DIMENSIONS
];
2329 index_type stride
[GFC_MAX_DIMENSIONS
];
2330 index_type stride0
, rank
, size
, n
;
2335 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2338 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2339 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2341 rank
= GFC_DESCRIPTOR_RANK (desc
);
2342 for (n
= 0; n
< rank
; n
++)
2345 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2346 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2348 /* If the extent of even one dimension is zero, then the entire
2349 array section contains zero elements, so we return after writing
2350 a zero array record. */
2355 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2360 stride0
= stride
[0];
2362 /* If the innermost dimension has a stride of 1, we can do the transfer
2363 in contiguous chunks. */
2364 if (stride0
== size
)
2369 data
= GFC_DESCRIPTOR_DATA (desc
);
2373 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2374 data
+= stride0
* tsize
;
2377 while (count
[n
] == extent
[n
])
2380 data
-= stride
[n
] * extent
[n
];
2397 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2398 gfc_charlen_type charlen
)
2400 transfer_array (dtp
, desc
, kind
, charlen
);
2404 /* User defined input/output iomsg. */
2406 #define IOMSG_LEN 256
2409 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2411 if (parent
->u
.p
.current_unit
)
2413 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2414 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2416 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2418 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2422 /* Preposition a sequential unformatted file while reading. */
2425 us_read (st_parameter_dt
*dtp
, int continued
)
2432 if (compile_options
.record_marker
== 0)
2433 n
= sizeof (GFC_INTEGER_4
);
2435 n
= compile_options
.record_marker
;
2437 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2438 if (unlikely (nr
< 0))
2440 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2446 return; /* end of file */
2448 else if (unlikely (n
!= nr
))
2450 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2454 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2455 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2459 case sizeof(GFC_INTEGER_4
):
2460 memcpy (&i4
, &i
, sizeof (i4
));
2464 case sizeof(GFC_INTEGER_8
):
2465 memcpy (&i8
, &i
, sizeof (i8
));
2470 runtime_error ("Illegal value for record marker");
2480 case sizeof(GFC_INTEGER_4
):
2481 memcpy (&u32
, &i
, sizeof (u32
));
2482 u32
= __builtin_bswap32 (u32
);
2483 memcpy (&i4
, &u32
, sizeof (i4
));
2487 case sizeof(GFC_INTEGER_8
):
2488 memcpy (&u64
, &i
, sizeof (u64
));
2489 u64
= __builtin_bswap64 (u64
);
2490 memcpy (&i8
, &u64
, sizeof (i8
));
2495 runtime_error ("Illegal value for record marker");
2502 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2503 dtp
->u
.p
.current_unit
->continued
= 0;
2507 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2508 dtp
->u
.p
.current_unit
->continued
= 1;
2512 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2516 /* Preposition a sequential unformatted file while writing. This
2517 amount to writing a bogus length that will be filled in later. */
2520 us_write (st_parameter_dt
*dtp
, int continued
)
2527 if (compile_options
.record_marker
== 0)
2528 nbytes
= sizeof (GFC_INTEGER_4
);
2530 nbytes
= compile_options
.record_marker
;
2532 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2533 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2535 /* For sequential unformatted, if RECL= was not specified in the OPEN
2536 we write until we have more bytes than can fit in the subrecord
2537 markers, then we write a new subrecord. */
2539 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2540 dtp
->u
.p
.current_unit
->recl_subrecord
;
2541 dtp
->u
.p
.current_unit
->continued
= continued
;
2545 /* Position to the next record prior to transfer. We are assumed to
2546 be before the next record. We also calculate the bytes in the next
2550 pre_position (st_parameter_dt
*dtp
)
2552 if (dtp
->u
.p
.current_unit
->current_record
)
2553 return; /* Already positioned. */
2555 switch (current_mode (dtp
))
2557 case FORMATTED_STREAM
:
2558 case UNFORMATTED_STREAM
:
2559 /* There are no records with stream I/O. If the position was specified
2560 data_transfer_init has already positioned the file. If no position
2561 was specified, we continue from where we last left off. I.e.
2562 there is nothing to do here. */
2565 case UNFORMATTED_SEQUENTIAL
:
2566 if (dtp
->u
.p
.mode
== READING
)
2573 case FORMATTED_SEQUENTIAL
:
2574 case FORMATTED_DIRECT
:
2575 case UNFORMATTED_DIRECT
:
2576 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2580 dtp
->u
.p
.current_unit
->current_record
= 1;
2584 /* Initialize things for a data transfer. This code is common for
2585 both reading and writing. */
2588 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2590 unit_flags u_flags
; /* Used for creating a unit if needed. */
2591 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2592 namelist_info
*ionml
;
2594 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2596 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2598 dtp
->u
.p
.ionml
= ionml
;
2599 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2601 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2604 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2606 if (dtp
->u
.p
.current_unit
== NULL
)
2608 /* This means we tried to access an external unit < 0 without
2609 having opened it first with NEWUNIT=. */
2610 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2611 "Unit number is negative and unit was not already "
2612 "opened with OPEN(NEWUNIT=...)");
2615 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2616 { /* Open the unit with some default flags. */
2617 st_parameter_open opp
;
2620 memset (&u_flags
, '\0', sizeof (u_flags
));
2621 u_flags
.access
= ACCESS_SEQUENTIAL
;
2622 u_flags
.action
= ACTION_READWRITE
;
2624 /* Is it unformatted? */
2625 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2626 | IOPARM_DT_IONML_SET
)))
2627 u_flags
.form
= FORM_UNFORMATTED
;
2629 u_flags
.form
= FORM_UNSPECIFIED
;
2631 u_flags
.delim
= DELIM_UNSPECIFIED
;
2632 u_flags
.blank
= BLANK_UNSPECIFIED
;
2633 u_flags
.pad
= PAD_UNSPECIFIED
;
2634 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2635 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2636 u_flags
.async
= ASYNC_UNSPECIFIED
;
2637 u_flags
.round
= ROUND_UNSPECIFIED
;
2638 u_flags
.sign
= SIGN_UNSPECIFIED
;
2640 u_flags
.status
= STATUS_UNKNOWN
;
2642 conv
= get_unformatted_convert (dtp
->common
.unit
);
2644 if (conv
== GFC_CONVERT_NONE
)
2645 conv
= compile_options
.convert
;
2647 /* We use big_endian, which is 0 on little-endian machines
2648 and 1 on big-endian machines. */
2651 case GFC_CONVERT_NATIVE
:
2652 case GFC_CONVERT_SWAP
:
2655 case GFC_CONVERT_BIG
:
2656 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2659 case GFC_CONVERT_LITTLE
:
2660 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2664 internal_error (&opp
.common
, "Illegal value for CONVERT");
2668 u_flags
.convert
= conv
;
2670 opp
.common
= dtp
->common
;
2671 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2672 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2673 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2674 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2675 if (dtp
->u
.p
.current_unit
== NULL
)
2679 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2681 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2683 dtp
->u
.p
.current_unit
->has_size
= true;
2684 /* Initialize the count. */
2685 dtp
->u
.p
.current_unit
->size_used
= 0;
2688 dtp
->u
.p
.current_unit
->has_size
= false;
2691 /* Check the action. */
2693 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2695 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2696 "Cannot read from file opened for WRITE");
2700 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2702 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2703 "Cannot write to file opened for READ");
2707 dtp
->u
.p
.first_item
= 1;
2709 /* Check the format. */
2711 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2714 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2715 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2718 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2719 "Format present for UNFORMATTED data transfer");
2723 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2725 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2727 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2728 "A format cannot be specified with a namelist");
2732 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2733 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2735 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2736 "Missing format for FORMATTED data transfer");
2740 if (is_internal_unit (dtp
)
2741 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2743 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2744 "Internal file cannot be accessed by UNFORMATTED "
2749 /* Check the record or position number. */
2751 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2752 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2754 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2755 "Direct access data transfer requires record number");
2759 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2761 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2763 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2764 "Record number not allowed for sequential access "
2769 if (compile_options
.warn_std
&&
2770 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2772 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2773 "Sequential READ or WRITE not allowed after "
2774 "EOF marker, possibly use REWIND or BACKSPACE");
2778 /* Process the ADVANCE option. */
2780 dtp
->u
.p
.advance_status
2781 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2782 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2783 "Bad ADVANCE parameter in data transfer statement");
2785 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2787 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2789 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2790 "ADVANCE specification conflicts with sequential "
2795 if (is_internal_unit (dtp
))
2797 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2798 "ADVANCE specification conflicts with internal file");
2802 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2803 != IOPARM_DT_HAS_FORMAT
)
2805 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2806 "ADVANCE specification requires an explicit format");
2813 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2815 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2817 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2818 "EOR specification requires an ADVANCE specification "
2823 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2824 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2826 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2827 "SIZE specification requires an ADVANCE "
2828 "specification of NO");
2833 { /* Write constraints. */
2834 if ((cf
& IOPARM_END
) != 0)
2836 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2837 "END specification cannot appear in a write "
2842 if ((cf
& IOPARM_EOR
) != 0)
2844 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2845 "EOR specification cannot appear in a write "
2850 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2852 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2853 "SIZE specification cannot appear in a write "
2859 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2860 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2862 /* Check the decimal mode. */
2863 dtp
->u
.p
.current_unit
->decimal_status
2864 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2865 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2866 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2869 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2870 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2872 /* Check the round mode. */
2873 dtp
->u
.p
.current_unit
->round_status
2874 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2875 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2876 round_opt
, "Bad ROUND parameter in data transfer "
2879 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2880 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2882 /* Check the sign mode. */
2883 dtp
->u
.p
.sign_status
2884 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2885 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2886 "Bad SIGN parameter in data transfer statement");
2888 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2889 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2891 /* Check the blank mode. */
2892 dtp
->u
.p
.blank_status
2893 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2894 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2896 "Bad BLANK parameter in data transfer statement");
2898 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2899 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2901 /* Check the delim mode. */
2902 dtp
->u
.p
.current_unit
->delim_status
2903 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2904 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2905 delim_opt
, "Bad DELIM parameter in data transfer statement");
2907 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2909 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2910 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2912 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2915 /* Check the pad mode. */
2916 dtp
->u
.p
.current_unit
->pad_status
2917 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2918 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2919 "Bad PAD parameter in data transfer statement");
2921 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2922 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2924 /* Check to see if we might be reading what we wrote before */
2926 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2927 && !is_internal_unit (dtp
))
2929 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2931 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2932 sflush(dtp
->u
.p
.current_unit
->s
);
2935 /* Check the POS= specifier: that it is in range and that it is used with a
2936 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2938 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2940 if (is_stream_io (dtp
))
2945 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2946 "POS=specifier must be positive");
2950 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2952 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2953 "POS=specifier too large");
2957 dtp
->rec
= dtp
->pos
;
2959 if (dtp
->u
.p
.mode
== READING
)
2961 /* Reset the endfile flag; if we hit EOF during reading
2962 we'll set the flag and generate an error at that point
2963 rather than worrying about it here. */
2964 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2967 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2969 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2970 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2972 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2975 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2980 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2981 "POS=specifier not allowed, "
2982 "Try OPEN with ACCESS='stream'");
2988 /* Sanity checks on the record number. */
2989 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2993 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2994 "Record number must be positive");
2998 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3000 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3001 "Record number too large");
3005 /* Make sure format buffer is reset. */
3006 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3007 fbuf_reset (dtp
->u
.p
.current_unit
);
3010 /* Check whether the record exists to be read. Only
3011 a partial record needs to exist. */
3013 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3014 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3016 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3017 "Non-existing record number");
3021 /* Position the file. */
3022 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3023 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3025 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3029 /* TODO: This is required to maintain compatibility between
3030 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
3032 if (is_stream_io (dtp
))
3033 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
3035 /* TODO: Un-comment this code when ABI changes from 4.3.
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
;
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 /* Position to the next record in write mode. */
3544 next_record_w (st_parameter_dt
*dtp
, int done
)
3546 gfc_offset m
, record
, max_pos
;
3549 /* Zero counters for X- and T-editing. */
3550 max_pos
= dtp
->u
.p
.max_pos
;
3551 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3553 switch (current_mode (dtp
))
3555 /* No records in unformatted STREAM I/O. */
3556 case UNFORMATTED_STREAM
:
3559 case FORMATTED_DIRECT
:
3560 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3563 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3564 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3565 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3566 dtp
->u
.p
.current_unit
->bytes_left
)
3567 != dtp
->u
.p
.current_unit
->bytes_left
)
3572 case UNFORMATTED_DIRECT
:
3573 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3575 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3576 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3581 case UNFORMATTED_SEQUENTIAL
:
3582 next_record_w_unf (dtp
, 0);
3583 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3586 case FORMATTED_STREAM
:
3587 case FORMATTED_SEQUENTIAL
:
3589 if (is_internal_unit (dtp
))
3592 if (is_array_io (dtp
))
3596 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3598 /* If the farthest position reached is greater than current
3599 position, adjust the position and set length to pad out
3600 whats left. Otherwise just pad whats left.
3601 (for character array unit) */
3602 m
= dtp
->u
.p
.current_unit
->recl
3603 - dtp
->u
.p
.current_unit
->bytes_left
;
3606 length
= (int) (max_pos
- m
);
3607 if (sseek (dtp
->u
.p
.current_unit
->s
,
3608 length
, SEEK_CUR
) < 0)
3610 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3613 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3616 p
= write_block (dtp
, length
);
3620 if (unlikely (is_char4_unit (dtp
)))
3622 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3623 memset4 (p4
, ' ', length
);
3626 memset (p
, ' ', length
);
3628 /* Now that the current record has been padded out,
3629 determine where the next record in the array is. */
3630 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3633 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3635 /* Now seek to this record */
3636 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3638 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3640 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3644 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3650 /* If this is the last call to next_record move to the farthest
3651 position reached and set length to pad out the remainder
3652 of the record. (for character scaler unit) */
3655 m
= dtp
->u
.p
.current_unit
->recl
3656 - dtp
->u
.p
.current_unit
->bytes_left
;
3659 length
= (int) (max_pos
- m
);
3660 if (sseek (dtp
->u
.p
.current_unit
->s
,
3661 length
, SEEK_CUR
) < 0)
3663 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3666 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3669 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3673 p
= write_block (dtp
, length
);
3677 if (unlikely (is_char4_unit (dtp
)))
3679 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3680 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3683 memset (p
, ' ', length
);
3694 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3695 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3702 if (is_stream_io (dtp
))
3704 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3705 if (dtp
->u
.p
.current_unit
->strm_pos
3706 < ssize (dtp
->u
.p
.current_unit
->s
))
3707 unit_truncate (dtp
->u
.p
.current_unit
,
3708 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3716 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3721 /* Position to the next record, which means moving to the end of the
3722 current record. This can happen under several different
3723 conditions. If the done flag is not set, we get ready to process
3727 next_record (st_parameter_dt
*dtp
, int done
)
3729 gfc_offset fp
; /* File position. */
3731 dtp
->u
.p
.current_unit
->read_bad
= 0;
3733 if (dtp
->u
.p
.mode
== READING
)
3734 next_record_r (dtp
, done
);
3736 next_record_w (dtp
, done
);
3738 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3740 if (!is_stream_io (dtp
))
3742 /* Since we have changed the position, set it to unspecified so
3743 that INQUIRE(POSITION=) knows it needs to look into it. */
3745 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3747 dtp
->u
.p
.current_unit
->current_record
= 0;
3748 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3750 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3751 /* Calculate next record, rounding up partial records. */
3752 dtp
->u
.p
.current_unit
->last_record
=
3753 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3754 dtp
->u
.p
.current_unit
->recl
- 1;
3757 dtp
->u
.p
.current_unit
->last_record
++;
3763 smarkeor (dtp
->u
.p
.current_unit
->s
);
3767 /* Finalize the current data transfer. For a nonadvancing transfer,
3768 this means advancing to the next record. For internal units close the
3769 stream associated with the unit. */
3772 finalize_transfer (st_parameter_dt
*dtp
)
3774 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3776 if ((dtp
->u
.p
.ionml
!= NULL
)
3777 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3779 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3780 namelist_read (dtp
);
3782 namelist_write (dtp
);
3785 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3787 if (cf
& IOPARM_DT_HAS_FORMAT
)
3789 free (dtp
->u
.p
.fmt
);
3795 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3796 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
3798 if (dtp
->u
.p
.eor_condition
)
3800 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3804 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3806 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3807 dtp
->u
.p
.current_unit
->current_record
= 0;
3811 dtp
->u
.p
.transfer
= NULL
;
3812 if (dtp
->u
.p
.current_unit
== NULL
)
3815 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3817 finish_list_read (dtp
);
3821 if (dtp
->u
.p
.mode
== WRITING
)
3822 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3823 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3825 if (is_stream_io (dtp
))
3827 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3828 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3829 next_record (dtp
, 1);
3834 dtp
->u
.p
.current_unit
->current_record
= 0;
3836 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3838 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3839 dtp
->u
.p
.seen_dollar
= 0;
3843 /* For non-advancing I/O, save the current maximum position for use in the
3844 next I/O operation if needed. */
3845 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3847 if (dtp
->u
.p
.skips
> 0)
3850 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3851 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3852 - dtp
->u
.p
.current_unit
->bytes_left
);
3854 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3857 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3858 - dtp
->u
.p
.current_unit
->bytes_left
);
3859 dtp
->u
.p
.current_unit
->saved_pos
=
3860 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3861 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3864 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3865 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3866 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3868 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3870 next_record (dtp
, 1);
3873 #ifdef HAVE_USELOCALE
3874 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3876 uselocale (dtp
->u
.p
.old_locale
);
3877 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3880 __gthread_mutex_lock (&old_locale_lock
);
3881 if (!--old_locale_ctr
)
3883 setlocale (LC_NUMERIC
, old_locale
);
3886 __gthread_mutex_unlock (&old_locale_lock
);
3890 /* Transfer function for IOLENGTH. It doesn't actually do any
3891 data transfer, it just updates the length counter. */
3894 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3895 void *dest
__attribute__ ((unused
)),
3896 int kind
__attribute__((unused
)),
3897 size_t size
, size_t nelems
)
3899 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3900 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3904 /* Initialize the IOLENGTH data transfer. This function is in essence
3905 a very much simplified version of data_transfer_init(), because it
3906 doesn't have to deal with units at all. */
3909 iolength_transfer_init (st_parameter_dt
*dtp
)
3911 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3914 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3916 /* Set up the subroutine that will handle the transfers. */
3918 dtp
->u
.p
.transfer
= iolength_transfer
;
3922 /* Library entry point for the IOLENGTH form of the INQUIRE
3923 statement. The IOLENGTH form requires no I/O to be performed, but
3924 it must still be a runtime library call so that we can determine
3925 the iolength for dynamic arrays and such. */
3927 extern void st_iolength (st_parameter_dt
*);
3928 export_proto(st_iolength
);
3931 st_iolength (st_parameter_dt
*dtp
)
3933 library_start (&dtp
->common
);
3934 iolength_transfer_init (dtp
);
3937 extern void st_iolength_done (st_parameter_dt
*);
3938 export_proto(st_iolength_done
);
3941 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3948 /* The READ statement. */
3950 extern void st_read (st_parameter_dt
*);
3951 export_proto(st_read
);
3954 st_read (st_parameter_dt
*dtp
)
3956 library_start (&dtp
->common
);
3958 data_transfer_init (dtp
, 1);
3961 extern void st_read_done (st_parameter_dt
*);
3962 export_proto(st_read_done
);
3965 st_read_done (st_parameter_dt
*dtp
)
3967 finalize_transfer (dtp
);
3971 /* If this is a parent READ statement we do not need to retain the
3972 internal unit structure for child use. Free it and stash the unit
3973 number for reuse. */
3974 if (dtp
->u
.p
.current_unit
!= NULL
3975 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
3977 if (is_internal_unit (dtp
) &&
3978 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
3980 free (dtp
->u
.p
.current_unit
->filename
);
3981 dtp
->u
.p
.current_unit
->filename
= NULL
;
3982 free (dtp
->u
.p
.current_unit
->s
);
3983 dtp
->u
.p
.current_unit
->s
= NULL
;
3984 if (dtp
->u
.p
.current_unit
->ls
)
3985 free (dtp
->u
.p
.current_unit
->ls
);
3986 dtp
->u
.p
.current_unit
->ls
= NULL
;
3987 stash_internal_unit (dtp
);
3989 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3991 free_format_data (dtp
->u
.p
.fmt
);
3994 unlock_unit (dtp
->u
.p
.current_unit
);
4000 extern void st_write (st_parameter_dt
*);
4001 export_proto(st_write
);
4004 st_write (st_parameter_dt
*dtp
)
4006 library_start (&dtp
->common
);
4007 data_transfer_init (dtp
, 0);
4010 extern void st_write_done (st_parameter_dt
*);
4011 export_proto(st_write_done
);
4014 st_write_done (st_parameter_dt
*dtp
)
4016 finalize_transfer (dtp
);
4018 if (dtp
->u
.p
.current_unit
!= NULL
4019 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4021 /* Deal with endfile conditions associated with sequential files. */
4022 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4023 switch (dtp
->u
.p
.current_unit
->endfile
)
4025 case AT_ENDFILE
: /* Remain at the endfile record. */
4029 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4033 /* Get rid of whatever is after this record. */
4034 if (!is_internal_unit (dtp
))
4035 unit_truncate (dtp
->u
.p
.current_unit
,
4036 stell (dtp
->u
.p
.current_unit
->s
),
4038 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4044 /* If this is a parent WRITE statement we do not need to retain the
4045 internal unit structure for child use. Free it and stash the
4046 unit number for reuse. */
4047 if (is_internal_unit (dtp
) &&
4048 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4050 free (dtp
->u
.p
.current_unit
->filename
);
4051 dtp
->u
.p
.current_unit
->filename
= NULL
;
4052 free (dtp
->u
.p
.current_unit
->s
);
4053 dtp
->u
.p
.current_unit
->s
= NULL
;
4054 if (dtp
->u
.p
.current_unit
->ls
)
4055 free (dtp
->u
.p
.current_unit
->ls
);
4056 dtp
->u
.p
.current_unit
->ls
= NULL
;
4057 stash_internal_unit (dtp
);
4059 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4061 free_format_data (dtp
->u
.p
.fmt
);
4064 unlock_unit (dtp
->u
.p
.current_unit
);
4070 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4072 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4077 /* Receives the scalar information for namelist objects and stores it
4078 in a linked list of namelist_info types. */
4081 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4082 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4083 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4085 namelist_info
*t1
= NULL
;
4087 size_t var_name_len
= strlen (var_name
);
4089 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4091 nml
->mem_pos
= var_addr
;
4092 nml
->dtio_sub
= dtio_sub
;
4093 nml
->vtable
= vtable
;
4095 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4096 memcpy (nml
->var_name
, var_name
, var_name_len
);
4097 nml
->var_name
[var_name_len
] = '\0';
4099 nml
->len
= (int) len
;
4100 nml
->string_length
= (index_type
) string_length
;
4102 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4103 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4104 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4106 if (nml
->var_rank
> 0)
4108 nml
->dim
= (descriptor_dimension
*)
4109 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4110 nml
->ls
= (array_loop_spec
*)
4111 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4121 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4123 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4124 dtp
->u
.p
.ionml
= nml
;
4128 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4133 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4134 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4135 export_proto(st_set_nml_var
);
4138 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4139 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4140 GFC_INTEGER_4 dtype
)
4142 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4147 /* Essentially the same as previous but carrying the dtio procedure
4148 and the vtable as additional arguments. */
4149 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4150 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4152 export_proto(st_set_nml_dtio_var
);
4156 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4157 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4158 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4160 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4161 dtype
, dtio_sub
, vtable
);
4164 /* Store the dimensional information for the namelist object. */
4165 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4166 index_type
, index_type
,
4168 export_proto(st_set_nml_var_dim
);
4171 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4172 index_type stride
, index_type lbound
,
4175 namelist_info
* nml
;
4180 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4182 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4186 /* Once upon a time, a poor innocent Fortran program was reading a
4187 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4188 the OS doesn't tell whether we're at the EOF or whether we already
4189 went past it. Luckily our hero, libgfortran, keeps track of this.
4190 Call this function when you detect an EOF condition. See Section
4194 hit_eof (st_parameter_dt
* dtp
)
4196 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4198 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4199 switch (dtp
->u
.p
.current_unit
->endfile
)
4203 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4204 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4206 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4207 dtp
->u
.p
.current_unit
->current_record
= 0;
4210 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4214 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4215 dtp
->u
.p
.current_unit
->current_record
= 0;
4220 /* Non-sequential files don't have an ENDFILE record, so we
4221 can't be at AFTER_ENDFILE. */
4222 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4223 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4224 dtp
->u
.p
.current_unit
->current_record
= 0;