1 /* Copyright (C) 2002-2016 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
4 F2003 I/O support contributed by Jerry DeLisle
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 3, or (at your option)
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
28 /* transfer.c -- Top level handling of data transfer statements. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
50 statement. For READ (and for backwards compatibily: for WRITE), one has
55 transfer_character_wide
63 transfer_integer_write
64 transfer_logical_write
65 transfer_character_write
66 transfer_character_wide_write
68 transfer_complex_write
69 transfer_real128_write
70 transfer_complex128_write
72 These subroutines do not return status. The *128 functions
73 are in the file transfer128.c.
75 The last call is a call to st_[read|write]_done(). While
76 something can easily go wrong with the initial st_read() or
77 st_write(), an error inhibits any data from actually being
80 extern void transfer_integer (st_parameter_dt
*, void *, int);
81 export_proto(transfer_integer
);
83 extern void transfer_integer_write (st_parameter_dt
*, void *, int);
84 export_proto(transfer_integer_write
);
86 extern void transfer_real (st_parameter_dt
*, void *, int);
87 export_proto(transfer_real
);
89 extern void transfer_real_write (st_parameter_dt
*, void *, int);
90 export_proto(transfer_real_write
);
92 extern void transfer_logical (st_parameter_dt
*, void *, int);
93 export_proto(transfer_logical
);
95 extern void transfer_logical_write (st_parameter_dt
*, void *, int);
96 export_proto(transfer_logical_write
);
98 extern void transfer_character (st_parameter_dt
*, void *, int);
99 export_proto(transfer_character
);
101 extern void transfer_character_write (st_parameter_dt
*, void *, int);
102 export_proto(transfer_character_write
);
104 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
105 export_proto(transfer_character_wide
);
107 extern void transfer_character_wide_write (st_parameter_dt
*,
109 export_proto(transfer_character_wide_write
);
111 extern void transfer_complex (st_parameter_dt
*, void *, int);
112 export_proto(transfer_complex
);
114 extern void transfer_complex_write (st_parameter_dt
*, void *, int);
115 export_proto(transfer_complex_write
);
117 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
119 export_proto(transfer_array
);
121 extern void transfer_array_write (st_parameter_dt
*, gfc_array_char
*, int,
123 export_proto(transfer_array_write
);
125 /* User defined derived type input/output. */
127 transfer_derived (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
128 export_proto(transfer_derived
);
131 transfer_derived_write (st_parameter_dt
*dtp
, void *dtio_source
, void *dtio_proc
);
132 export_proto(transfer_derived_write
);
134 static void us_read (st_parameter_dt
*, int);
135 static void us_write (st_parameter_dt
*, int);
136 static void next_record_r_unf (st_parameter_dt
*, int);
137 static void next_record_w_unf (st_parameter_dt
*, int);
139 static const st_option advance_opt
[] = {
140 {"yes", ADVANCE_YES
},
146 static const st_option decimal_opt
[] = {
147 {"point", DECIMAL_POINT
},
148 {"comma", DECIMAL_COMMA
},
152 static const st_option round_opt
[] = {
154 {"down", ROUND_DOWN
},
155 {"zero", ROUND_ZERO
},
156 {"nearest", ROUND_NEAREST
},
157 {"compatible", ROUND_COMPATIBLE
},
158 {"processor_defined", ROUND_PROCDEFINED
},
163 static const st_option sign_opt
[] = {
165 {"suppress", SIGN_SS
},
166 {"processor_defined", SIGN_S
},
170 static const st_option blank_opt
[] = {
171 {"null", BLANK_NULL
},
172 {"zero", BLANK_ZERO
},
176 static const st_option delim_opt
[] = {
177 {"apostrophe", DELIM_APOSTROPHE
},
178 {"quote", DELIM_QUOTE
},
179 {"none", DELIM_NONE
},
183 static const st_option pad_opt
[] = {
190 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
191 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
197 current_mode (st_parameter_dt
*dtp
)
201 m
= FORM_UNSPECIFIED
;
203 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
205 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
206 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
208 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
210 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
211 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
213 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
215 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
216 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
223 /* Mid level data transfer statements. */
225 /* Read sequential file - internal unit */
228 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
230 static char *empty_string
[0];
234 /* Zero size array gives internal unit len of 0. Nothing to read. */
235 if (dtp
->internal_unit_len
== 0
236 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
239 /* If we have seen an eor previously, return a length of 0. The
240 caller is responsible for correctly padding the input field. */
241 if (dtp
->u
.p
.sf_seen_eor
)
244 /* Just return something that isn't a NULL pointer, otherwise the
245 caller thinks an error occurred. */
246 return (char*) empty_string
;
250 if (is_char4_unit(dtp
))
253 gfc_char4_t
*p
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
,
255 base
= fbuf_alloc (dtp
->u
.p
.current_unit
, lorig
);
256 for (i
= 0; i
< *length
; i
++, p
++)
257 base
[i
] = *p
> 255 ? '?' : (unsigned char) *p
;
260 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
262 if (unlikely (lorig
> *length
))
268 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
270 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
271 dtp
->u
.p
.current_unit
->has_size
)
272 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *length
;
278 /* When reading sequential formatted records we have a problem. We
279 don't know how long the line is until we read the trailing newline,
280 and we don't want to read too much. If we read too much, we might
281 have to do a physical seek backwards depending on how much data is
282 present, and devices like terminals aren't seekable and would cause
285 Given this, the solution is to read a byte at a time, stopping if
286 we hit the newline. For small allocations, we use a static buffer.
287 For larger allocations, we are forced to allocate memory on the
288 heap. Hopefully this won't happen very often. */
290 /* Read sequential file - external unit */
293 read_sf (st_parameter_dt
*dtp
, int * length
)
295 static char *empty_string
[0];
297 int n
, lorig
, seen_comma
;
299 /* If we have seen an eor previously, return a length of 0. The
300 caller is responsible for correctly padding the input field. */
301 if (dtp
->u
.p
.sf_seen_eor
)
304 /* Just return something that isn't a NULL pointer, otherwise the
305 caller thinks an error occurred. */
306 return (char*) empty_string
;
311 /* Read data into format buffer and scan through it. */
316 q
= fbuf_getc (dtp
->u
.p
.current_unit
);
319 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
320 && (q
== '\n' || q
== '\r'))
322 /* Unexpected end of line. Set the position. */
323 dtp
->u
.p
.sf_seen_eor
= 1;
325 /* If we see an EOR during non-advancing I/O, we need to skip
326 the rest of the I/O statement. Set the corresponding flag. */
327 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
328 dtp
->u
.p
.eor_condition
= 1;
330 /* If we encounter a CR, it might be a CRLF. */
331 if (q
== '\r') /* Probably a CRLF */
333 /* See if there is an LF. */
334 q2
= fbuf_getc (dtp
->u
.p
.current_unit
);
336 dtp
->u
.p
.sf_seen_eor
= 2;
337 else if (q2
!= EOF
) /* Oops, seek back. */
338 fbuf_seek (dtp
->u
.p
.current_unit
, -1, SEEK_CUR
);
341 /* Without padding, terminate the I/O statement without assigning
342 the value. With padding, the value still needs to be assigned,
343 so we can just continue with a short read. */
344 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
346 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
353 /* Short circuit the read if a comma is found during numeric input.
354 The flag is set to zero during character reads so that commas in
355 strings are not ignored */
357 if (dtp
->u
.p
.sf_read_comma
== 1)
360 notify_std (&dtp
->common
, GFC_STD_GNU
,
361 "Comma in formatted numeric read.");
369 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
370 some other stuff. Set the relevant flags. */
371 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
375 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
377 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
383 dtp
->u
.p
.eor_condition
= 1;
388 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
389 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
390 || dtp
->u
.p
.current_unit
->bytes_left
391 == dtp
->u
.p
.current_unit
->recl
)
400 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
402 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
403 dtp
->u
.p
.current_unit
->has_size
)
404 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) n
;
406 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
407 fbuf_getc might reallocate the buffer. So return current pointer
408 minus all the advances, which is n plus up to two characters
409 of newline or comma. */
410 return fbuf_getptr (dtp
->u
.p
.current_unit
)
411 - n
- dtp
->u
.p
.sf_seen_eor
- seen_comma
;
415 /* Function for reading the next couple of bytes from the current
416 file, advancing the current position. We return NULL on end of record or
417 end of file. This function is only for formatted I/O, unformatted uses
420 If the read is short, then it is because the current record does not
421 have enough data to satisfy the read request and the file was
422 opened with PAD=YES. The caller must assume tailing spaces for
426 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
431 if (!is_stream_io (dtp
))
433 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
435 /* For preconnected units with default record length, set bytes left
436 to unit record length and proceed, otherwise error. */
437 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
438 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
439 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
442 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
443 && !is_internal_unit (dtp
))
445 /* Not enough data left. */
446 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
451 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
452 && !is_internal_unit(dtp
)))
458 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
462 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
463 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
464 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
466 if (is_internal_unit (dtp
))
467 source
= read_sf_internal (dtp
, nbytes
);
469 source
= read_sf (dtp
, nbytes
);
471 dtp
->u
.p
.current_unit
->strm_pos
+=
472 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
476 /* If we reach here, we can assume it's direct access. */
478 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
481 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
482 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
484 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
485 dtp
->u
.p
.current_unit
->has_size
)
486 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
488 if (norig
!= *nbytes
)
490 /* Short read, this shouldn't happen. */
491 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
493 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
498 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
504 /* Read a block from a character(kind=4) internal unit, to be transferred into
505 a character(kind=4) variable. Note: Portions of this code borrowed from
508 read_block_form4 (st_parameter_dt
*dtp
, int * nbytes
)
510 static gfc_char4_t
*empty_string
[0];
514 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
515 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
517 /* Zero size array gives internal unit len of 0. Nothing to read. */
518 if (dtp
->internal_unit_len
== 0
519 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
522 /* If we have seen an eor previously, return a length of 0. The
523 caller is responsible for correctly padding the input field. */
524 if (dtp
->u
.p
.sf_seen_eor
)
527 /* Just return something that isn't a NULL pointer, otherwise the
528 caller thinks an error occurred. */
533 source
= (gfc_char4_t
*) mem_alloc_r4 (dtp
->u
.p
.current_unit
->s
, nbytes
);
535 if (unlikely (lorig
> *nbytes
))
541 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
543 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
544 dtp
->u
.p
.current_unit
->has_size
)
545 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) *nbytes
;
551 /* Reads a block directly into application data space. This is for
552 unformatted files. */
555 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
557 ssize_t to_read_record
;
558 ssize_t have_read_record
;
559 ssize_t to_read_subrecord
;
560 ssize_t have_read_subrecord
;
563 if (is_stream_io (dtp
))
565 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
567 if (unlikely (have_read_record
< 0))
569 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
573 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
575 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
577 /* Short read, e.g. if we hit EOF. For stream files,
578 we have to set the end-of-file condition. */
584 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
586 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
589 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
590 nbytes
= to_read_record
;
595 to_read_record
= nbytes
;
598 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
600 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
601 if (unlikely (to_read_record
< 0))
603 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
607 if (to_read_record
!= (ssize_t
) nbytes
)
609 /* Short read, e.g. if we hit EOF. Apparently, we read
610 more than was written to the last record. */
614 if (unlikely (short_record
))
616 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
621 /* Unformatted sequential. We loop over the subrecords, reading
622 until the request has been fulfilled or the record has run out
623 of continuation subrecords. */
625 /* Check whether we exceed the total record length. */
627 if (dtp
->u
.p
.current_unit
->flags
.has_recl
628 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
630 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
635 to_read_record
= nbytes
;
638 have_read_record
= 0;
642 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
643 < (gfc_offset
) to_read_record
)
645 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
646 to_read_record
-= to_read_subrecord
;
650 to_read_subrecord
= to_read_record
;
654 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
656 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
657 buf
+ have_read_record
, to_read_subrecord
);
658 if (unlikely (have_read_subrecord
< 0))
660 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
664 have_read_record
+= have_read_subrecord
;
666 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
668 /* Short read, e.g. if we hit EOF. This means the record
669 structure has been corrupted, or the trailing record
670 marker would still be present. */
672 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
676 if (to_read_record
> 0)
678 if (likely (dtp
->u
.p
.current_unit
->continued
))
680 next_record_r_unf (dtp
, 0);
685 /* Let's make sure the file position is correctly pre-positioned
686 for the next read statement. */
688 dtp
->u
.p
.current_unit
->current_record
= 0;
689 next_record_r_unf (dtp
, 0);
690 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
696 /* Normal exit, the read request has been fulfilled. */
701 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
702 if (unlikely (short_record
))
704 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
711 /* Function for writing a block of bytes to the current file at the
712 current position, advancing the file pointer. We are given a length
713 and return a pointer to a buffer that the caller must (completely)
714 fill in. Returns NULL on error. */
717 write_block (st_parameter_dt
*dtp
, int length
)
721 if (!is_stream_io (dtp
))
723 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
725 /* For preconnected units with default record length, set bytes left
726 to unit record length and proceed, otherwise error. */
727 if (likely ((dtp
->u
.p
.current_unit
->unit_number
728 == options
.stdout_unit
729 || dtp
->u
.p
.current_unit
->unit_number
730 == options
.stderr_unit
)
731 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
732 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
735 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
740 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
743 if (is_internal_unit (dtp
))
745 if (is_char4_unit(dtp
)) /* char4 internel unit. */
748 dest4
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
751 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
757 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
761 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
765 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
766 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
770 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
773 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
778 if (((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0) ||
779 dtp
->u
.p
.current_unit
->has_size
)
780 dtp
->u
.p
.current_unit
->size_used
+= (GFC_IO_INT
) length
;
782 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
788 /* High level interface to swrite(), taking care of errors. This is only
789 called for unformatted files. There are three cases to consider:
790 Stream I/O, unformatted direct, unformatted sequential. */
793 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
796 ssize_t have_written
;
797 ssize_t to_write_subrecord
;
802 if (is_stream_io (dtp
))
804 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
805 if (unlikely (have_written
< 0))
807 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
811 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
816 /* Unformatted direct access. */
818 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
820 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
822 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
826 if (buf
== NULL
&& nbytes
== 0)
829 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
830 if (unlikely (have_written
< 0))
832 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
836 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
837 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
842 /* Unformatted sequential. */
846 if (dtp
->u
.p
.current_unit
->flags
.has_recl
847 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
849 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
861 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
862 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
864 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
865 (gfc_offset
) to_write_subrecord
;
867 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
868 buf
+ have_written
, to_write_subrecord
);
869 if (unlikely (to_write_subrecord
< 0))
871 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
875 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
876 nbytes
-= to_write_subrecord
;
877 have_written
+= to_write_subrecord
;
882 next_record_w_unf (dtp
, 1);
885 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
886 if (unlikely (short_record
))
888 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
895 /* Reverse memcpy - used for byte swapping. */
898 reverse_memcpy (void *dest
, const void *src
, size_t n
)
904 s
= (char *) src
+ n
- 1;
906 /* Write with ascending order - this is likely faster
907 on modern architectures because of write combining. */
913 /* Utility function for byteswapping an array, using the bswap
914 builtins if possible. dest and src can overlap completely, or then
915 they must point to separate objects; partial overlaps are not
919 bswap_array (void *dest
, const void *src
, size_t size
, size_t nelems
)
929 for (size_t i
= 0; i
< nelems
; i
++)
930 ((uint16_t*)dest
)[i
] = __builtin_bswap16 (((uint16_t*)src
)[i
]);
933 for (size_t i
= 0; i
< nelems
; i
++)
934 ((uint32_t*)dest
)[i
] = __builtin_bswap32 (((uint32_t*)src
)[i
]);
937 for (size_t i
= 0; i
< nelems
; i
++)
938 ((uint64_t*)dest
)[i
] = __builtin_bswap64 (((uint64_t*)src
)[i
]);
943 for (size_t i
= 0; i
< nelems
; i
++)
946 memcpy (&tmp
, ps
, 4);
947 *(uint32_t*)pd
= __builtin_bswap32 (*(uint32_t*)(ps
+ 8));
948 *(uint32_t*)(pd
+ 4) = __builtin_bswap32 (*(uint32_t*)(ps
+ 4));
949 *(uint32_t*)(pd
+ 8) = __builtin_bswap32 (tmp
);
957 for (size_t i
= 0; i
< nelems
; i
++)
960 memcpy (&tmp
, ps
, 8);
961 *(uint64_t*)pd
= __builtin_bswap64 (*(uint64_t*)(ps
+ 8));
962 *(uint64_t*)(pd
+ 8) = __builtin_bswap64 (tmp
);
972 for (size_t i
= 0; i
< nelems
; i
++)
974 reverse_memcpy (pd
, ps
, size
);
981 /* In-place byte swap. */
982 for (size_t i
= 0; i
< nelems
; i
++)
984 char tmp
, *low
= pd
, *high
= pd
+ size
- 1;
985 for (size_t j
= 0; j
< size
/2; j
++)
1000 /* Master function for unformatted reads. */
1003 unformatted_read (st_parameter_dt
*dtp
, bt type
,
1004 void *dest
, int kind
, size_t size
, size_t nelems
)
1006 if (type
== BT_CLASS
)
1008 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1009 char tmp_iomsg
[IOMSG_LEN
] = "";
1011 gfc_charlen_type child_iomsg_len
;
1013 int *child_iostat
= NULL
;
1015 /* Set iostat, intent(out). */
1017 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1018 dtp
->common
.iostat
: &noiostat
;
1020 /* Set iomsg, intent(inout). */
1021 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1023 child_iomsg
= dtp
->common
.iomsg
;
1024 child_iomsg_len
= dtp
->common
.iomsg_len
;
1028 child_iomsg
= tmp_iomsg
;
1029 child_iomsg_len
= IOMSG_LEN
;
1032 /* Call the user defined unformatted READ procedure. */
1033 dtp
->u
.p
.current_unit
->child_dtio
++;
1034 dtp
->u
.p
.ufdtio_ptr (dest
, &unit
, child_iostat
, child_iomsg
,
1036 dtp
->u
.p
.current_unit
->child_dtio
--;
1040 if (type
== BT_CHARACTER
)
1041 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
1042 read_block_direct (dtp
, dest
, size
* nelems
);
1044 if (unlikely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_SWAP
)
1047 /* Handle wide chracters. */
1048 if (type
== BT_CHARACTER
)
1054 /* Break up complex into its constituent reals. */
1055 else if (type
== BT_COMPLEX
)
1060 bswap_array (dest
, dest
, size
, nelems
);
1065 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1066 bytes on 64 bit machines. The unused bytes are not initialized and never
1067 used, which can show an error with memory checking analyzers like
1068 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
1071 unformatted_write (st_parameter_dt
*dtp
, bt type
,
1072 void *source
, int kind
, size_t size
, size_t nelems
)
1074 if (type
== BT_CLASS
)
1076 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1077 char tmp_iomsg
[IOMSG_LEN
] = "";
1079 gfc_charlen_type child_iomsg_len
;
1081 int *child_iostat
= NULL
;
1083 /* Set iostat, intent(out). */
1085 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1086 dtp
->common
.iostat
: &noiostat
;
1088 /* Set iomsg, intent(inout). */
1089 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1091 child_iomsg
= dtp
->common
.iomsg
;
1092 child_iomsg_len
= dtp
->common
.iomsg_len
;
1096 child_iomsg
= tmp_iomsg
;
1097 child_iomsg_len
= IOMSG_LEN
;
1100 /* Call the user defined unformatted WRITE procedure. */
1101 dtp
->u
.p
.current_unit
->child_dtio
++;
1102 dtp
->u
.p
.ufdtio_ptr (source
, &unit
, child_iostat
, child_iomsg
,
1104 dtp
->u
.p
.current_unit
->child_dtio
--;
1108 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1111 size_t stride
= type
== BT_CHARACTER
?
1112 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1114 write_buf (dtp
, source
, stride
* nelems
);
1118 #define BSWAP_BUFSZ 512
1119 char buffer
[BSWAP_BUFSZ
];
1125 /* Handle wide chracters. */
1126 if (type
== BT_CHARACTER
&& kind
!= 1)
1132 /* Break up complex into its constituent reals. */
1133 if (type
== BT_COMPLEX
)
1139 /* By now, all complex variables have been split into their
1140 constituent reals. */
1146 if (size
* nrem
> BSWAP_BUFSZ
)
1147 nc
= BSWAP_BUFSZ
/ size
;
1151 bswap_array (buffer
, p
, size
, nc
);
1152 write_buf (dtp
, buffer
, size
* nc
);
1161 /* Return a pointer to the name of a type. */
1186 p
= "CLASS or DERIVED";
1189 internal_error (NULL
, "type_name(): Bad type");
1196 /* Write a constant string to the output.
1197 This is complicated because the string can have doubled delimiters
1198 in it. The length in the format node is the true length. */
1201 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
1203 char c
, delimiter
, *p
, *q
;
1206 length
= f
->u
.string
.length
;
1210 p
= write_block (dtp
, length
);
1217 for (; length
> 0; length
--)
1220 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
1221 q
++; /* Skip the doubled delimiter. */
1226 /* Given actual and expected types in a formatted data transfer, make
1227 sure they agree. If not, an error message is generated. Returns
1228 nonzero if something went wrong. */
1231 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
1234 char buffer
[BUFLEN
];
1236 if (actual
== expected
)
1239 /* Adjust item_count before emitting error message. */
1240 snprintf (buffer
, BUFLEN
,
1241 "Expected %s for item %d in formatted transfer, got %s",
1242 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
1244 format_error (dtp
, f
, buffer
);
1250 require_numeric_type (st_parameter_dt
*dtp
, bt actual
, const fnode
*f
)
1253 char buffer
[BUFLEN
];
1255 if (actual
== BT_INTEGER
|| actual
== BT_REAL
|| actual
== BT_COMPLEX
)
1258 /* Adjust item_count before emitting error message. */
1259 snprintf (buffer
, BUFLEN
,
1260 "Expected numeric type for item %d in formatted transfer, got %s",
1261 dtp
->u
.p
.item_count
- 1, type_name (actual
));
1263 format_error (dtp
, f
, buffer
);
1268 /* This function is in the main loop for a formatted data transfer
1269 statement. It would be natural to implement this as a coroutine
1270 with the user program, but C makes that awkward. We loop,
1271 processing format elements. When we actually have to transfer
1272 data instead of just setting flags, we return control to the user
1273 program which calls a function that supplies the address and type
1274 of the next element, then comes back here to process it. */
1277 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1280 int pos
, bytes_used
;
1284 int consume_data_flag
;
1286 /* Change a complex data item into a pair of reals. */
1288 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1289 if (type
== BT_COMPLEX
)
1295 /* If there's an EOR condition, we simulate finalizing the transfer
1296 by doing nothing. */
1297 if (dtp
->u
.p
.eor_condition
)
1300 /* Set this flag so that commas in reads cause the read to complete before
1301 the entire field has been read. The next read field will start right after
1302 the comma in the stream. (Set to 0 for character reads). */
1303 dtp
->u
.p
.sf_read_comma
=
1304 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1308 /* If reversion has occurred and there is another real data item,
1309 then we have to move to the next record. */
1310 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1312 dtp
->u
.p
.reversion_flag
= 0;
1313 next_record (dtp
, 0);
1316 consume_data_flag
= 1;
1317 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1320 f
= next_format (dtp
);
1323 /* No data descriptors left. */
1324 if (unlikely (n
> 0))
1325 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1326 "Insufficient data descriptors in format after reversion");
1332 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1333 - dtp
->u
.p
.current_unit
->bytes_left
);
1335 if (is_stream_io(dtp
))
1342 goto need_read_data
;
1343 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1345 read_decimal (dtp
, f
, p
, kind
);
1350 goto need_read_data
;
1351 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1352 && require_numeric_type (dtp
, type
, f
))
1354 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1355 && require_type (dtp
, BT_INTEGER
, type
, f
))
1357 read_radix (dtp
, f
, p
, kind
, 2);
1362 goto need_read_data
;
1363 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1364 && require_numeric_type (dtp
, type
, f
))
1366 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1367 && require_type (dtp
, BT_INTEGER
, type
, f
))
1369 read_radix (dtp
, f
, p
, kind
, 8);
1374 goto need_read_data
;
1375 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1376 && require_numeric_type (dtp
, type
, f
))
1378 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1379 && require_type (dtp
, BT_INTEGER
, type
, f
))
1381 read_radix (dtp
, f
, p
, kind
, 16);
1386 goto need_read_data
;
1388 /* It is possible to have FMT_A with something not BT_CHARACTER such
1389 as when writing out hollerith strings, so check both type
1390 and kind before calling wide character routines. */
1391 if (type
== BT_CHARACTER
&& kind
== 4)
1392 read_a_char4 (dtp
, f
, p
, size
);
1394 read_a (dtp
, f
, p
, size
);
1399 goto need_read_data
;
1400 read_l (dtp
, f
, p
, kind
);
1405 goto need_read_data
;
1406 if (require_type (dtp
, BT_REAL
, type
, f
))
1408 read_f (dtp
, f
, p
, kind
);
1413 goto need_read_data
;
1414 if (require_type (dtp
, BT_CLASS
, type
, f
))
1416 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1418 char tmp_iomsg
[IOMSG_LEN
] = "";
1420 gfc_charlen_type child_iomsg_len
;
1422 int *child_iostat
= NULL
;
1423 char *iotype
= f
->u
.udf
.string
;
1424 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1426 /* Build the iotype string. */
1427 if (iotype_len
== 0)
1435 iotype
= xmalloc (iotype_len
);
1438 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1441 /* Set iostat, intent(out). */
1443 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1444 dtp
->common
.iostat
: &noiostat
;
1446 /* Set iomsg, intent(inout). */
1447 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1449 child_iomsg
= dtp
->common
.iomsg
;
1450 child_iomsg_len
= dtp
->common
.iomsg_len
;
1454 child_iomsg
= tmp_iomsg
;
1455 child_iomsg_len
= IOMSG_LEN
;
1458 /* Call the user defined formatted READ procedure. */
1459 dtp
->u
.p
.current_unit
->child_dtio
++;
1460 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1461 child_iostat
, child_iomsg
,
1462 iotype_len
, child_iomsg_len
);
1463 dtp
->u
.p
.current_unit
->child_dtio
--;
1465 if (f
->u
.udf
.string_len
!= 0)
1467 /* Note: vlist is freed in free_format_data. */
1472 goto need_read_data
;
1473 if (require_type (dtp
, BT_REAL
, type
, f
))
1475 read_f (dtp
, f
, p
, kind
);
1480 goto need_read_data
;
1481 if (require_type (dtp
, BT_REAL
, type
, f
))
1483 read_f (dtp
, f
, p
, kind
);
1488 goto need_read_data
;
1489 if (require_type (dtp
, BT_REAL
, type
, f
))
1491 read_f (dtp
, f
, p
, kind
);
1496 goto need_read_data
;
1497 if (require_type (dtp
, BT_REAL
, type
, f
))
1499 read_f (dtp
, f
, p
, kind
);
1504 goto need_read_data
;
1508 read_decimal (dtp
, f
, p
, kind
);
1511 read_l (dtp
, f
, p
, kind
);
1515 read_a_char4 (dtp
, f
, p
, size
);
1517 read_a (dtp
, f
, p
, size
);
1520 read_f (dtp
, f
, p
, kind
);
1523 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1528 consume_data_flag
= 0;
1529 format_error (dtp
, f
, "Constant string in input format");
1532 /* Format codes that don't transfer data. */
1535 consume_data_flag
= 0;
1536 dtp
->u
.p
.skips
+= f
->u
.n
;
1537 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1538 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1539 read_x (dtp
, f
->u
.n
);
1544 consume_data_flag
= 0;
1546 if (f
->format
== FMT_TL
)
1548 /* Handle the special case when no bytes have been used yet.
1549 Cannot go below zero. */
1550 if (bytes_used
== 0)
1552 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1553 dtp
->u
.p
.skips
-= f
->u
.n
;
1554 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1557 pos
= bytes_used
- f
->u
.n
;
1562 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1563 left tab limit. We do not check if the position has gone
1564 beyond the end of record because a subsequent tab could
1565 bring us back again. */
1566 pos
= pos
< 0 ? 0 : pos
;
1568 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1569 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1570 + pos
- dtp
->u
.p
.max_pos
;
1571 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1572 ? 0 : dtp
->u
.p
.pending_spaces
;
1573 if (dtp
->u
.p
.skips
== 0)
1576 /* Adjust everything for end-of-record condition */
1577 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1579 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1580 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1582 dtp
->u
.p
.sf_seen_eor
= 0;
1584 if (dtp
->u
.p
.skips
< 0)
1586 if (is_internal_unit (dtp
))
1587 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1589 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1590 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1591 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1594 read_x (dtp
, dtp
->u
.p
.skips
);
1598 consume_data_flag
= 0;
1599 dtp
->u
.p
.sign_status
= SIGN_S
;
1603 consume_data_flag
= 0;
1604 dtp
->u
.p
.sign_status
= SIGN_SS
;
1608 consume_data_flag
= 0;
1609 dtp
->u
.p
.sign_status
= SIGN_SP
;
1613 consume_data_flag
= 0 ;
1614 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1618 consume_data_flag
= 0;
1619 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1623 consume_data_flag
= 0;
1624 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1628 consume_data_flag
= 0;
1629 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1633 consume_data_flag
= 0;
1634 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1638 consume_data_flag
= 0;
1639 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1643 consume_data_flag
= 0;
1644 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1648 consume_data_flag
= 0;
1649 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1653 consume_data_flag
= 0;
1654 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1658 consume_data_flag
= 0;
1659 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1663 consume_data_flag
= 0;
1664 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1668 consume_data_flag
= 0;
1669 dtp
->u
.p
.seen_dollar
= 1;
1673 consume_data_flag
= 0;
1674 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1675 next_record (dtp
, 0);
1679 /* A colon descriptor causes us to exit this loop (in
1680 particular preventing another / descriptor from being
1681 processed) unless there is another data item to be
1683 consume_data_flag
= 0;
1689 internal_error (&dtp
->common
, "Bad format node");
1692 /* Adjust the item count and data pointer. */
1694 if ((consume_data_flag
> 0) && (n
> 0))
1697 p
= ((char *) p
) + size
;
1702 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1703 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1708 /* Come here when we need a data descriptor but don't have one. We
1709 push the current format node back onto the input, then return and
1710 let the user program call us back with the data. */
1712 unget_format (dtp
, f
);
1717 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1720 int pos
, bytes_used
;
1724 int consume_data_flag
;
1726 /* Change a complex data item into a pair of reals. */
1728 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1729 if (type
== BT_COMPLEX
)
1735 /* If there's an EOR condition, we simulate finalizing the transfer
1736 by doing nothing. */
1737 if (dtp
->u
.p
.eor_condition
)
1740 /* Set this flag so that commas in reads cause the read to complete before
1741 the entire field has been read. The next read field will start right after
1742 the comma in the stream. (Set to 0 for character reads). */
1743 dtp
->u
.p
.sf_read_comma
=
1744 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1748 /* If reversion has occurred and there is another real data item,
1749 then we have to move to the next record. */
1750 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1752 dtp
->u
.p
.reversion_flag
= 0;
1753 next_record (dtp
, 0);
1756 consume_data_flag
= 1;
1757 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1760 f
= next_format (dtp
);
1763 /* No data descriptors left. */
1764 if (unlikely (n
> 0))
1765 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1766 "Insufficient data descriptors in format after reversion");
1770 /* Now discharge T, TR and X movements to the right. This is delayed
1771 until a data producing format to suppress trailing spaces. */
1774 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1775 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1776 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1777 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1778 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
1780 || t
== FMT_STRING
))
1782 if (dtp
->u
.p
.skips
> 0)
1785 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1786 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1787 - dtp
->u
.p
.current_unit
->bytes_left
);
1789 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1792 if (dtp
->u
.p
.skips
< 0)
1794 if (is_internal_unit (dtp
))
1795 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1797 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1798 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1800 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1803 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1804 - dtp
->u
.p
.current_unit
->bytes_left
);
1806 if (is_stream_io(dtp
))
1814 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1816 write_i (dtp
, f
, p
, kind
);
1822 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1823 && require_numeric_type (dtp
, type
, f
))
1825 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1826 && require_type (dtp
, BT_INTEGER
, type
, f
))
1828 write_b (dtp
, f
, p
, kind
);
1834 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1835 && require_numeric_type (dtp
, type
, f
))
1837 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1838 && require_type (dtp
, BT_INTEGER
, type
, f
))
1840 write_o (dtp
, f
, p
, kind
);
1846 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1847 && require_numeric_type (dtp
, type
, f
))
1849 if (!(compile_options
.allow_std
& GFC_STD_F2008
)
1850 && require_type (dtp
, BT_INTEGER
, type
, f
))
1852 write_z (dtp
, f
, p
, kind
);
1859 /* It is possible to have FMT_A with something not BT_CHARACTER such
1860 as when writing out hollerith strings, so check both type
1861 and kind before calling wide character routines. */
1862 if (type
== BT_CHARACTER
&& kind
== 4)
1863 write_a_char4 (dtp
, f
, p
, size
);
1865 write_a (dtp
, f
, p
, size
);
1871 write_l (dtp
, f
, p
, kind
);
1877 if (require_type (dtp
, BT_REAL
, type
, f
))
1879 write_d (dtp
, f
, p
, kind
);
1885 int unit
= dtp
->u
.p
.current_unit
->unit_number
;
1887 char tmp_iomsg
[IOMSG_LEN
] = "";
1889 gfc_charlen_type child_iomsg_len
;
1891 int *child_iostat
= NULL
;
1892 char *iotype
= f
->u
.udf
.string
;
1893 gfc_charlen_type iotype_len
= f
->u
.udf
.string_len
;
1895 /* Build the iotype string. */
1896 if (iotype_len
== 0)
1904 iotype
= xmalloc (iotype_len
);
1907 memcpy (iotype
+ 2, f
->u
.udf
.string
, f
->u
.udf
.string_len
);
1910 /* Set iostat, intent(out). */
1912 child_iostat
= (dtp
->common
.flags
& IOPARM_HAS_IOSTAT
) ?
1913 dtp
->common
.iostat
: &noiostat
;
1915 /* Set iomsg, intent(inout). */
1916 if (dtp
->common
.flags
& IOPARM_HAS_IOMSG
)
1918 child_iomsg
= dtp
->common
.iomsg
;
1919 child_iomsg_len
= dtp
->common
.iomsg_len
;
1923 child_iomsg
= tmp_iomsg
;
1924 child_iomsg_len
= IOMSG_LEN
;
1927 /* Call the user defined formatted WRITE procedure. */
1928 dtp
->u
.p
.current_unit
->child_dtio
++;
1929 dtp
->u
.p
.fdtio_ptr (p
, &unit
, iotype
, f
->u
.udf
.vlist
,
1930 child_iostat
, child_iomsg
,
1931 iotype_len
, child_iomsg_len
);
1932 dtp
->u
.p
.current_unit
->child_dtio
--;
1934 if (f
->u
.udf
.string_len
!= 0)
1936 /* Note: vlist is freed in free_format_data. */
1942 if (require_type (dtp
, BT_REAL
, type
, f
))
1944 write_e (dtp
, f
, p
, kind
);
1950 if (require_type (dtp
, BT_REAL
, type
, f
))
1952 write_en (dtp
, f
, p
, kind
);
1958 if (require_type (dtp
, BT_REAL
, type
, f
))
1960 write_es (dtp
, f
, p
, kind
);
1966 if (require_type (dtp
, BT_REAL
, type
, f
))
1968 write_f (dtp
, f
, p
, kind
);
1977 write_i (dtp
, f
, p
, kind
);
1980 write_l (dtp
, f
, p
, kind
);
1984 write_a_char4 (dtp
, f
, p
, size
);
1986 write_a (dtp
, f
, p
, size
);
1989 if (f
->u
.real
.w
== 0)
1990 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1992 write_d (dtp
, f
, p
, kind
);
1995 internal_error (&dtp
->common
,
1996 "formatted_transfer(): Bad type");
2001 consume_data_flag
= 0;
2002 write_constant_string (dtp
, f
);
2005 /* Format codes that don't transfer data. */
2008 consume_data_flag
= 0;
2010 dtp
->u
.p
.skips
+= f
->u
.n
;
2011 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
2012 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
2013 /* Writes occur just before the switch on f->format, above, so
2014 that trailing blanks are suppressed, unless we are doing a
2015 non-advancing write in which case we want to output the blanks
2017 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2019 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
2020 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2026 consume_data_flag
= 0;
2028 if (f
->format
== FMT_TL
)
2031 /* Handle the special case when no bytes have been used yet.
2032 Cannot go below zero. */
2033 if (bytes_used
== 0)
2035 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
2036 dtp
->u
.p
.skips
-= f
->u
.n
;
2037 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
2040 pos
= bytes_used
- f
->u
.n
;
2043 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
2045 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2046 left tab limit. We do not check if the position has gone
2047 beyond the end of record because a subsequent tab could
2048 bring us back again. */
2049 pos
= pos
< 0 ? 0 : pos
;
2051 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
2052 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
2053 + pos
- dtp
->u
.p
.max_pos
;
2054 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
2055 ? 0 : dtp
->u
.p
.pending_spaces
;
2059 consume_data_flag
= 0;
2060 dtp
->u
.p
.sign_status
= SIGN_S
;
2064 consume_data_flag
= 0;
2065 dtp
->u
.p
.sign_status
= SIGN_SS
;
2069 consume_data_flag
= 0;
2070 dtp
->u
.p
.sign_status
= SIGN_SP
;
2074 consume_data_flag
= 0 ;
2075 dtp
->u
.p
.blank_status
= BLANK_NULL
;
2079 consume_data_flag
= 0;
2080 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
2084 consume_data_flag
= 0;
2085 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
2089 consume_data_flag
= 0;
2090 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
2094 consume_data_flag
= 0;
2095 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
2099 consume_data_flag
= 0;
2100 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
2104 consume_data_flag
= 0;
2105 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
2109 consume_data_flag
= 0;
2110 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
2114 consume_data_flag
= 0;
2115 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
2119 consume_data_flag
= 0;
2120 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
2124 consume_data_flag
= 0;
2125 dtp
->u
.p
.scale_factor
= f
->u
.k
;
2129 consume_data_flag
= 0;
2130 dtp
->u
.p
.seen_dollar
= 1;
2134 consume_data_flag
= 0;
2135 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2136 next_record (dtp
, 0);
2140 /* A colon descriptor causes us to exit this loop (in
2141 particular preventing another / descriptor from being
2142 processed) unless there is another data item to be
2144 consume_data_flag
= 0;
2150 internal_error (&dtp
->common
, "Bad format node");
2153 /* Adjust the item count and data pointer. */
2155 if ((consume_data_flag
> 0) && (n
> 0))
2158 p
= ((char *) p
) + size
;
2161 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
2162 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
2167 /* Come here when we need a data descriptor but don't have one. We
2168 push the current format node back onto the input, then return and
2169 let the user program call us back with the data. */
2171 unget_format (dtp
, f
);
2174 /* This function is first called from data_init_transfer to initiate the loop
2175 over each item in the format, transferring data as required. Subsequent
2176 calls to this function occur for each data item foound in the READ/WRITE
2177 statement. The item_count is incremented for each call. Since the first
2178 call is from data_transfer_init, the item_count is always one greater than
2179 the actual count number of the item being transferred. */
2182 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
2183 size_t size
, size_t nelems
)
2189 size_t stride
= type
== BT_CHARACTER
?
2190 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
2191 if (dtp
->u
.p
.mode
== READING
)
2193 /* Big loop over all the elements. */
2194 for (elem
= 0; elem
< nelems
; elem
++)
2196 dtp
->u
.p
.item_count
++;
2197 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2202 /* Big loop over all the elements. */
2203 for (elem
= 0; elem
< nelems
; elem
++)
2205 dtp
->u
.p
.item_count
++;
2206 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
2212 /* Data transfer entry points. The type of the data entity is
2213 implicit in the subroutine call. This prevents us from having to
2214 share a common enum with the compiler. */
2217 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
2219 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2221 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
2225 transfer_integer_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2227 transfer_integer (dtp
, p
, kind
);
2231 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
2234 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2236 size
= size_from_real_kind (kind
);
2237 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
2241 transfer_real_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2243 transfer_real (dtp
, p
, kind
);
2247 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
2249 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2251 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
2255 transfer_logical_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2257 transfer_logical (dtp
, p
, kind
);
2261 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
2263 static char *empty_string
[0];
2265 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2268 /* Strings of zero length can have p == NULL, which confuses the
2269 transfer routines into thinking we need more data elements. To avoid
2270 this, we give them a nice pointer. */
2271 if (len
== 0 && p
== NULL
)
2274 /* Set kind here to 1. */
2275 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
2279 transfer_character_write (st_parameter_dt
*dtp
, void *p
, int len
)
2281 transfer_character (dtp
, p
, len
);
2285 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2287 static char *empty_string
[0];
2289 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2292 /* Strings of zero length can have p == NULL, which confuses the
2293 transfer routines into thinking we need more data elements. To avoid
2294 this, we give them a nice pointer. */
2295 if (len
== 0 && p
== NULL
)
2298 /* Here we pass the actual kind value. */
2299 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
2303 transfer_character_wide_write (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
2305 transfer_character_wide (dtp
, p
, len
, kind
);
2309 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
2312 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2314 size
= size_from_complex_kind (kind
);
2315 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
2319 transfer_complex_write (st_parameter_dt
*dtp
, void *p
, int kind
)
2321 transfer_complex (dtp
, p
, kind
);
2325 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2326 gfc_charlen_type charlen
)
2328 index_type count
[GFC_MAX_DIMENSIONS
];
2329 index_type extent
[GFC_MAX_DIMENSIONS
];
2330 index_type stride
[GFC_MAX_DIMENSIONS
];
2331 index_type stride0
, rank
, size
, n
;
2336 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2339 iotype
= (bt
) GFC_DESCRIPTOR_TYPE (desc
);
2340 size
= iotype
== BT_CHARACTER
? charlen
: GFC_DESCRIPTOR_SIZE (desc
);
2342 rank
= GFC_DESCRIPTOR_RANK (desc
);
2343 for (n
= 0; n
< rank
; n
++)
2346 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
2347 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
2349 /* If the extent of even one dimension is zero, then the entire
2350 array section contains zero elements, so we return after writing
2351 a zero array record. */
2356 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2361 stride0
= stride
[0];
2363 /* If the innermost dimension has a stride of 1, we can do the transfer
2364 in contiguous chunks. */
2365 if (stride0
== size
)
2370 data
= GFC_DESCRIPTOR_DATA (desc
);
2374 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
2375 data
+= stride0
* tsize
;
2378 while (count
[n
] == extent
[n
])
2381 data
-= stride
[n
] * extent
[n
];
2398 transfer_array_write (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
2399 gfc_charlen_type charlen
)
2401 transfer_array (dtp
, desc
, kind
, charlen
);
2405 /* User defined input/output iomsg. */
2407 #define IOMSG_LEN 256
2410 transfer_derived (st_parameter_dt
*parent
, void *dtio_source
, void *dtio_proc
)
2412 if (parent
->u
.p
.current_unit
)
2414 if (parent
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2415 parent
->u
.p
.ufdtio_ptr
= (unformatted_dtio
) dtio_proc
;
2417 parent
->u
.p
.fdtio_ptr
= (formatted_dtio
) dtio_proc
;
2419 parent
->u
.p
.transfer (parent
, BT_CLASS
, dtio_source
, 0, 0, 1);
2423 /* Preposition a sequential unformatted file while reading. */
2426 us_read (st_parameter_dt
*dtp
, int continued
)
2433 if (compile_options
.record_marker
== 0)
2434 n
= sizeof (GFC_INTEGER_4
);
2436 n
= compile_options
.record_marker
;
2438 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
2439 if (unlikely (nr
< 0))
2441 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2447 return; /* end of file */
2449 else if (unlikely (n
!= nr
))
2451 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
2455 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2456 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2460 case sizeof(GFC_INTEGER_4
):
2461 memcpy (&i4
, &i
, sizeof (i4
));
2465 case sizeof(GFC_INTEGER_8
):
2466 memcpy (&i8
, &i
, sizeof (i8
));
2471 runtime_error ("Illegal value for record marker");
2481 case sizeof(GFC_INTEGER_4
):
2482 memcpy (&u32
, &i
, sizeof (u32
));
2483 u32
= __builtin_bswap32 (u32
);
2484 memcpy (&i4
, &u32
, sizeof (i4
));
2488 case sizeof(GFC_INTEGER_8
):
2489 memcpy (&u64
, &i
, sizeof (u64
));
2490 u64
= __builtin_bswap64 (u64
);
2491 memcpy (&i8
, &u64
, sizeof (i8
));
2496 runtime_error ("Illegal value for record marker");
2503 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2504 dtp
->u
.p
.current_unit
->continued
= 0;
2508 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2509 dtp
->u
.p
.current_unit
->continued
= 1;
2513 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2517 /* Preposition a sequential unformatted file while writing. This
2518 amount to writing a bogus length that will be filled in later. */
2521 us_write (st_parameter_dt
*dtp
, int continued
)
2528 if (compile_options
.record_marker
== 0)
2529 nbytes
= sizeof (GFC_INTEGER_4
);
2531 nbytes
= compile_options
.record_marker
;
2533 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2534 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2536 /* For sequential unformatted, if RECL= was not specified in the OPEN
2537 we write until we have more bytes than can fit in the subrecord
2538 markers, then we write a new subrecord. */
2540 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2541 dtp
->u
.p
.current_unit
->recl_subrecord
;
2542 dtp
->u
.p
.current_unit
->continued
= continued
;
2546 /* Position to the next record prior to transfer. We are assumed to
2547 be before the next record. We also calculate the bytes in the next
2551 pre_position (st_parameter_dt
*dtp
)
2553 if (dtp
->u
.p
.current_unit
->current_record
)
2554 return; /* Already positioned. */
2556 switch (current_mode (dtp
))
2558 case FORMATTED_STREAM
:
2559 case UNFORMATTED_STREAM
:
2560 /* There are no records with stream I/O. If the position was specified
2561 data_transfer_init has already positioned the file. If no position
2562 was specified, we continue from where we last left off. I.e.
2563 there is nothing to do here. */
2566 case UNFORMATTED_SEQUENTIAL
:
2567 if (dtp
->u
.p
.mode
== READING
)
2574 case FORMATTED_SEQUENTIAL
:
2575 case FORMATTED_DIRECT
:
2576 case UNFORMATTED_DIRECT
:
2577 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2581 dtp
->u
.p
.current_unit
->current_record
= 1;
2585 /* Initialize things for a data transfer. This code is common for
2586 both reading and writing. */
2589 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2591 unit_flags u_flags
; /* Used for creating a unit if needed. */
2592 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2593 namelist_info
*ionml
;
2595 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2597 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2599 dtp
->u
.p
.ionml
= ionml
;
2600 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2602 dtp
->u
.p
.cc
.len
= 0;
2604 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2607 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2609 if (dtp
->u
.p
.current_unit
== NULL
)
2611 /* This means we tried to access an external unit < 0 without
2612 having opened it first with NEWUNIT=. */
2613 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2614 "Unit number is negative and unit was not already "
2615 "opened with OPEN(NEWUNIT=...)");
2618 else if (dtp
->u
.p
.current_unit
->s
== NULL
)
2619 { /* Open the unit with some default flags. */
2620 st_parameter_open opp
;
2623 memset (&u_flags
, '\0', sizeof (u_flags
));
2624 u_flags
.access
= ACCESS_SEQUENTIAL
;
2625 u_flags
.action
= ACTION_READWRITE
;
2627 /* Is it unformatted? */
2628 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2629 | IOPARM_DT_IONML_SET
)))
2630 u_flags
.form
= FORM_UNFORMATTED
;
2632 u_flags
.form
= FORM_UNSPECIFIED
;
2634 u_flags
.delim
= DELIM_UNSPECIFIED
;
2635 u_flags
.blank
= BLANK_UNSPECIFIED
;
2636 u_flags
.pad
= PAD_UNSPECIFIED
;
2637 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2638 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2639 u_flags
.async
= ASYNC_UNSPECIFIED
;
2640 u_flags
.round
= ROUND_UNSPECIFIED
;
2641 u_flags
.sign
= SIGN_UNSPECIFIED
;
2642 u_flags
.share
= SHARE_UNSPECIFIED
;
2643 u_flags
.cc
= CC_UNSPECIFIED
;
2644 u_flags
.readonly
= 0;
2646 u_flags
.status
= STATUS_UNKNOWN
;
2648 conv
= get_unformatted_convert (dtp
->common
.unit
);
2650 if (conv
== GFC_CONVERT_NONE
)
2651 conv
= compile_options
.convert
;
2653 /* We use big_endian, which is 0 on little-endian machines
2654 and 1 on big-endian machines. */
2657 case GFC_CONVERT_NATIVE
:
2658 case GFC_CONVERT_SWAP
:
2661 case GFC_CONVERT_BIG
:
2662 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2665 case GFC_CONVERT_LITTLE
:
2666 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2670 internal_error (&opp
.common
, "Illegal value for CONVERT");
2674 u_flags
.convert
= conv
;
2676 opp
.common
= dtp
->common
;
2677 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2678 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2679 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2680 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2681 if (dtp
->u
.p
.current_unit
== NULL
)
2685 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
2687 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2689 dtp
->u
.p
.current_unit
->has_size
= true;
2690 /* Initialize the count. */
2691 dtp
->u
.p
.current_unit
->size_used
= 0;
2694 dtp
->u
.p
.current_unit
->has_size
= false;
2697 /* Check the action. */
2699 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2701 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2702 "Cannot read from file opened for WRITE");
2706 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2708 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2709 "Cannot write to file opened for READ");
2713 dtp
->u
.p
.first_item
= 1;
2715 /* Check the format. */
2717 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2720 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2721 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2724 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2725 "Format present for UNFORMATTED data transfer");
2729 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2731 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2733 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2734 "A format cannot be specified with a namelist");
2738 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2739 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2741 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2742 "Missing format for FORMATTED data transfer");
2746 if (is_internal_unit (dtp
)
2747 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2749 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2750 "Internal file cannot be accessed by UNFORMATTED "
2755 /* Check the record or position number. */
2757 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2758 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2760 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2761 "Direct access data transfer requires record number");
2765 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2767 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2769 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2770 "Record number not allowed for sequential access "
2775 if (compile_options
.warn_std
&&
2776 dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2778 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2779 "Sequential READ or WRITE not allowed after "
2780 "EOF marker, possibly use REWIND or BACKSPACE");
2784 /* Process the ADVANCE option. */
2786 dtp
->u
.p
.advance_status
2787 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2788 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2789 "Bad ADVANCE parameter in data transfer statement");
2791 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2793 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2795 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2796 "ADVANCE specification conflicts with sequential "
2801 if (is_internal_unit (dtp
))
2803 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2804 "ADVANCE specification conflicts with internal file");
2808 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2809 != IOPARM_DT_HAS_FORMAT
)
2811 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2812 "ADVANCE specification requires an explicit format");
2819 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2821 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2823 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2824 "EOR specification requires an ADVANCE specification "
2829 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2830 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2832 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2833 "SIZE specification requires an ADVANCE "
2834 "specification of NO");
2839 { /* Write constraints. */
2840 if ((cf
& IOPARM_END
) != 0)
2842 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2843 "END specification cannot appear in a write "
2848 if ((cf
& IOPARM_EOR
) != 0)
2850 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2851 "EOR specification cannot appear in a write "
2856 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2858 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2859 "SIZE specification cannot appear in a write "
2865 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2866 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2868 /* Check the decimal mode. */
2869 dtp
->u
.p
.current_unit
->decimal_status
2870 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2871 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2872 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2875 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2876 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2878 /* Check the round mode. */
2879 dtp
->u
.p
.current_unit
->round_status
2880 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2881 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2882 round_opt
, "Bad ROUND parameter in data transfer "
2885 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2886 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2888 /* Check the sign mode. */
2889 dtp
->u
.p
.sign_status
2890 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2891 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2892 "Bad SIGN parameter in data transfer statement");
2894 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2895 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2897 /* Check the blank mode. */
2898 dtp
->u
.p
.blank_status
2899 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2900 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2902 "Bad BLANK parameter in data transfer statement");
2904 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2905 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2907 /* Check the delim mode. */
2908 dtp
->u
.p
.current_unit
->delim_status
2909 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2910 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2911 delim_opt
, "Bad DELIM parameter in data transfer statement");
2913 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2915 if (ionml
&& dtp
->u
.p
.current_unit
->flags
.delim
== DELIM_UNSPECIFIED
)
2916 dtp
->u
.p
.current_unit
->delim_status
= DELIM_QUOTE
;
2918 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2921 /* Check the pad mode. */
2922 dtp
->u
.p
.current_unit
->pad_status
2923 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2924 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2925 "Bad PAD parameter in data transfer statement");
2927 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2928 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2930 /* Check to see if we might be reading what we wrote before */
2932 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2933 && !is_internal_unit (dtp
))
2935 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2937 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2938 sflush(dtp
->u
.p
.current_unit
->s
);
2941 /* Check the POS= specifier: that it is in range and that it is used with a
2942 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2944 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2946 if (is_stream_io (dtp
))
2951 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2952 "POS=specifier must be positive");
2956 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2958 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2959 "POS=specifier too large");
2963 dtp
->rec
= dtp
->pos
;
2965 if (dtp
->u
.p
.mode
== READING
)
2967 /* Reset the endfile flag; if we hit EOF during reading
2968 we'll set the flag and generate an error at that point
2969 rather than worrying about it here. */
2970 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2973 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2975 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2976 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2978 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2981 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2986 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2987 "POS=specifier not allowed, "
2988 "Try OPEN with ACCESS='stream'");
2994 /* Sanity checks on the record number. */
2995 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2999 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3000 "Record number must be positive");
3004 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
3006 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3007 "Record number too large");
3011 /* Make sure format buffer is reset. */
3012 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3013 fbuf_reset (dtp
->u
.p
.current_unit
);
3016 /* Check whether the record exists to be read. Only
3017 a partial record needs to exist. */
3019 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
3020 * dtp
->u
.p
.current_unit
->recl
>= ssize (dtp
->u
.p
.current_unit
->s
))
3022 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3023 "Non-existing record number");
3027 /* Position the file. */
3028 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
3029 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
3031 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3035 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
3037 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
3038 "Record number not allowed for stream access "
3044 /* Bugware for badly written mixed C-Fortran I/O. */
3045 if (!is_internal_unit (dtp
))
3046 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
3048 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
3050 /* Set the maximum position reached from the previous I/O operation. This
3051 could be greater than zero from a previous non-advancing write. */
3052 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
3057 /* Set up the subroutine that will handle the transfers. */
3061 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3062 dtp
->u
.p
.transfer
= unformatted_read
;
3065 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3067 if (dtp
->u
.p
.current_unit
->child_dtio
== 0)
3068 dtp
->u
.p
.current_unit
->last_char
= EOF
- 1;
3069 dtp
->u
.p
.transfer
= list_formatted_read
;
3072 dtp
->u
.p
.transfer
= formatted_transfer
;
3077 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
3078 dtp
->u
.p
.transfer
= unformatted_write
;
3081 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
3082 dtp
->u
.p
.transfer
= list_formatted_write
;
3084 dtp
->u
.p
.transfer
= formatted_transfer
;
3088 /* Make sure that we don't do a read after a nonadvancing write. */
3092 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
3094 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
3095 "Cannot READ after a nonadvancing WRITE");
3101 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
3102 dtp
->u
.p
.current_unit
->read_bad
= 1;
3105 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
3107 #ifdef HAVE_USELOCALE
3108 dtp
->u
.p
.old_locale
= uselocale (c_locale
);
3110 __gthread_mutex_lock (&old_locale_lock
);
3111 if (!old_locale_ctr
++)
3113 old_locale
= setlocale (LC_NUMERIC
, NULL
);
3114 setlocale (LC_NUMERIC
, "C");
3116 __gthread_mutex_unlock (&old_locale_lock
);
3118 /* Start the data transfer if we are doing a formatted transfer. */
3119 if ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0
3120 && dtp
->u
.p
.ionml
== NULL
)
3121 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
3126 /* Initialize an array_loop_spec given the array descriptor. The function
3127 returns the index of the last element of the array, and also returns
3128 starting record, where the first I/O goes to (necessary in case of
3129 negative strides). */
3132 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
3133 gfc_offset
*start_record
)
3135 int rank
= GFC_DESCRIPTOR_RANK(desc
);
3144 for (i
=0; i
<rank
; i
++)
3146 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3147 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
3148 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
3149 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
3150 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
3151 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
3153 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
3155 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3156 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3160 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3161 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3162 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
3163 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
3173 /* Determine the index to the next record in an internal unit array by
3174 by incrementing through the array_loop_spec. */
3177 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
3185 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
3190 if (ls
[i
].idx
> ls
[i
].end
)
3192 ls
[i
].idx
= ls
[i
].start
;
3198 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
3208 /* Skip to the end of the current record, taking care of an optional
3209 record marker of size bytes. If the file is not seekable, we
3210 read chunks of size MAX_READ until we get to the right
3214 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
3216 ssize_t rlength
, readb
;
3217 #define MAX_READ 4096
3220 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
3221 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
3224 /* Direct access files do not generate END conditions,
3226 if (sseek (dtp
->u
.p
.current_unit
->s
,
3227 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
3229 /* Seeking failed, fall back to seeking by reading data. */
3230 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
3233 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
3234 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3236 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
3239 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3243 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
3247 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
3251 /* Advance to the next record reading unformatted files, taking
3252 care of subrecords. If complete_record is nonzero, we loop
3253 until all subrecords are cleared. */
3256 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
3260 bytes
= compile_options
.record_marker
== 0 ?
3261 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
3266 /* Skip over tail */
3268 skip_record (dtp
, bytes
);
3270 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
3279 min_off (gfc_offset a
, gfc_offset b
)
3281 return (a
< b
? a
: b
);
3285 /* Space to the next record for read mode. */
3288 next_record_r (st_parameter_dt
*dtp
, int done
)
3295 switch (current_mode (dtp
))
3297 /* No records in unformatted STREAM I/O. */
3298 case UNFORMATTED_STREAM
:
3301 case UNFORMATTED_SEQUENTIAL
:
3302 next_record_r_unf (dtp
, 1);
3303 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3306 case FORMATTED_DIRECT
:
3307 case UNFORMATTED_DIRECT
:
3308 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
3311 case FORMATTED_STREAM
:
3312 case FORMATTED_SEQUENTIAL
:
3313 /* read_sf has already terminated input because of an '\n', or
3315 if (dtp
->u
.p
.sf_seen_eor
)
3317 dtp
->u
.p
.sf_seen_eor
= 0;
3321 if (is_internal_unit (dtp
))
3323 if (is_array_io (dtp
))
3327 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3329 if (!done
&& finished
)
3332 /* Now seek to this record. */
3333 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3334 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3336 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3339 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3343 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3344 bytes_left
= min_off (bytes_left
,
3345 ssize (dtp
->u
.p
.current_unit
->s
)
3346 - stell (dtp
->u
.p
.current_unit
->s
));
3347 if (sseek (dtp
->u
.p
.current_unit
->s
,
3348 bytes_left
, SEEK_CUR
) < 0)
3350 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3353 dtp
->u
.p
.current_unit
->bytes_left
3354 = dtp
->u
.p
.current_unit
->recl
;
3358 else if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3363 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
3367 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3370 if (is_stream_io (dtp
)
3371 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
3372 || dtp
->u
.p
.current_unit
->bytes_left
3373 == dtp
->u
.p
.current_unit
->recl
)
3379 if (is_stream_io (dtp
))
3380 dtp
->u
.p
.current_unit
->strm_pos
++;
3391 /* Small utility function to write a record marker, taking care of
3392 byte swapping and of choosing the correct size. */
3395 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
3401 if (compile_options
.record_marker
== 0)
3402 len
= sizeof (GFC_INTEGER_4
);
3404 len
= compile_options
.record_marker
;
3406 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
3407 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
3411 case sizeof (GFC_INTEGER_4
):
3413 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
3416 case sizeof (GFC_INTEGER_8
):
3418 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
3422 runtime_error ("Illegal value for record marker");
3432 case sizeof (GFC_INTEGER_4
):
3434 memcpy (&u32
, &buf4
, sizeof (u32
));
3435 u32
= __builtin_bswap32 (u32
);
3436 return swrite (dtp
->u
.p
.current_unit
->s
, &u32
, len
);
3439 case sizeof (GFC_INTEGER_8
):
3441 memcpy (&u64
, &buf8
, sizeof (u64
));
3442 u64
= __builtin_bswap64 (u64
);
3443 return swrite (dtp
->u
.p
.current_unit
->s
, &u64
, len
);
3447 runtime_error ("Illegal value for record marker");
3454 /* Position to the next (sub)record in write mode for
3455 unformatted sequential files. */
3458 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
3460 gfc_offset m
, m_write
, record_marker
;
3462 /* Bytes written. */
3463 m
= dtp
->u
.p
.current_unit
->recl_subrecord
3464 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
3466 if (compile_options
.record_marker
== 0)
3467 record_marker
= sizeof (GFC_INTEGER_4
);
3469 record_marker
= compile_options
.record_marker
;
3471 /* Seek to the head and overwrite the bogus length with the real
3474 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- record_marker
,
3483 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3486 /* Seek past the end of the current record. */
3488 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
, SEEK_CUR
) < 0))
3491 /* Write the length tail. If we finish a record containing
3492 subrecords, we write out the negative length. */
3494 if (dtp
->u
.p
.current_unit
->continued
)
3499 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
3505 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3511 /* Utility function like memset() but operating on streams. Return
3512 value is same as for POSIX write(). */
3515 sset (stream
* s
, int c
, ssize_t nbyte
)
3517 #define WRITE_CHUNK 256
3518 char p
[WRITE_CHUNK
];
3519 ssize_t bytes_left
, trans
;
3521 if (nbyte
< WRITE_CHUNK
)
3522 memset (p
, c
, nbyte
);
3524 memset (p
, c
, WRITE_CHUNK
);
3527 while (bytes_left
> 0)
3529 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3530 trans
= swrite (s
, p
, trans
);
3533 bytes_left
-= trans
;
3536 return nbyte
- bytes_left
;
3540 /* Finish up a record according to the legacy carriagecontrol type, based
3541 on the first character in the record. */
3544 next_record_cc (st_parameter_dt
*dtp
)
3546 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3547 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_FORTRAN
)
3550 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3551 if (dtp
->u
.p
.cc
.len
> 0)
3553 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, dtp
->u
.p
.cc
.len
);
3555 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3557 /* Output CR for the first character with default CC setting. */
3558 *(p
++) = dtp
->u
.p
.cc
.u
.end
;
3559 if (dtp
->u
.p
.cc
.len
> 1)
3560 *p
= dtp
->u
.p
.cc
.u
.end
;
3564 /* Position to the next record in write mode. */
3567 next_record_w (st_parameter_dt
*dtp
, int done
)
3569 gfc_offset m
, record
, max_pos
;
3572 /* Zero counters for X- and T-editing. */
3573 max_pos
= dtp
->u
.p
.max_pos
;
3574 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3576 switch (current_mode (dtp
))
3578 /* No records in unformatted STREAM I/O. */
3579 case UNFORMATTED_STREAM
:
3582 case FORMATTED_DIRECT
:
3583 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3586 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3587 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3588 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3589 dtp
->u
.p
.current_unit
->bytes_left
)
3590 != dtp
->u
.p
.current_unit
->bytes_left
)
3595 case UNFORMATTED_DIRECT
:
3596 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3598 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3599 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3604 case UNFORMATTED_SEQUENTIAL
:
3605 next_record_w_unf (dtp
, 0);
3606 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3609 case FORMATTED_STREAM
:
3610 case FORMATTED_SEQUENTIAL
:
3612 if (is_internal_unit (dtp
))
3615 if (is_array_io (dtp
))
3619 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3621 /* If the farthest position reached is greater than current
3622 position, adjust the position and set length to pad out
3623 whats left. Otherwise just pad whats left.
3624 (for character array unit) */
3625 m
= dtp
->u
.p
.current_unit
->recl
3626 - dtp
->u
.p
.current_unit
->bytes_left
;
3629 length
= (int) (max_pos
- m
);
3630 if (sseek (dtp
->u
.p
.current_unit
->s
,
3631 length
, SEEK_CUR
) < 0)
3633 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3636 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3639 p
= write_block (dtp
, length
);
3643 if (unlikely (is_char4_unit (dtp
)))
3645 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3646 memset4 (p4
, ' ', length
);
3649 memset (p
, ' ', length
);
3651 /* Now that the current record has been padded out,
3652 determine where the next record in the array is. */
3653 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3656 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3658 /* Now seek to this record */
3659 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3661 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3663 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3667 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3673 /* If this is the last call to next_record move to the farthest
3674 position reached and set length to pad out the remainder
3675 of the record. (for character scaler unit) */
3678 m
= dtp
->u
.p
.current_unit
->recl
3679 - dtp
->u
.p
.current_unit
->bytes_left
;
3682 length
= (int) (max_pos
- m
);
3683 if (sseek (dtp
->u
.p
.current_unit
->s
,
3684 length
, SEEK_CUR
) < 0)
3686 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3689 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3692 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3696 p
= write_block (dtp
, length
);
3700 if (unlikely (is_char4_unit (dtp
)))
3702 gfc_char4_t
*p4
= (gfc_char4_t
*) p
;
3703 memset4 (p4
, (gfc_char4_t
) ' ', length
);
3706 memset (p
, ' ', length
);
3710 /* Handle legacy CARRIAGECONTROL line endings. */
3711 else if (dtp
->u
.p
.current_unit
->flags
.cc
== CC_FORTRAN
)
3712 next_record_cc (dtp
);
3715 /* Skip newlines for CC=CC_NONE. */
3716 const int len
= (dtp
->u
.p
.current_unit
->flags
.cc
== CC_NONE
)
3723 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3724 if (dtp
->u
.p
.current_unit
->flags
.cc
!= CC_NONE
)
3726 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3734 if (is_stream_io (dtp
))
3736 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3737 if (dtp
->u
.p
.current_unit
->strm_pos
3738 < ssize (dtp
->u
.p
.current_unit
->s
))
3739 unit_truncate (dtp
->u
.p
.current_unit
,
3740 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3748 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3753 /* Position to the next record, which means moving to the end of the
3754 current record. This can happen under several different
3755 conditions. If the done flag is not set, we get ready to process
3759 next_record (st_parameter_dt
*dtp
, int done
)
3761 gfc_offset fp
; /* File position. */
3763 dtp
->u
.p
.current_unit
->read_bad
= 0;
3765 if (dtp
->u
.p
.mode
== READING
)
3766 next_record_r (dtp
, done
);
3768 next_record_w (dtp
, done
);
3770 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3772 if (!is_stream_io (dtp
))
3774 /* Since we have changed the position, set it to unspecified so
3775 that INQUIRE(POSITION=) knows it needs to look into it. */
3777 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_UNSPECIFIED
;
3779 dtp
->u
.p
.current_unit
->current_record
= 0;
3780 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3782 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3783 /* Calculate next record, rounding up partial records. */
3784 dtp
->u
.p
.current_unit
->last_record
=
3785 (fp
+ dtp
->u
.p
.current_unit
->recl
) /
3786 dtp
->u
.p
.current_unit
->recl
- 1;
3789 dtp
->u
.p
.current_unit
->last_record
++;
3795 smarkeor (dtp
->u
.p
.current_unit
->s
);
3799 /* Finalize the current data transfer. For a nonadvancing transfer,
3800 this means advancing to the next record. For internal units close the
3801 stream associated with the unit. */
3804 finalize_transfer (st_parameter_dt
*dtp
)
3806 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3808 if ((dtp
->u
.p
.ionml
!= NULL
)
3809 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3811 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3812 namelist_read (dtp
);
3814 namelist_write (dtp
);
3817 if (dtp
->u
.p
.current_unit
&& (dtp
->u
.p
.current_unit
->child_dtio
> 0))
3819 if (cf
& IOPARM_DT_HAS_FORMAT
)
3821 free (dtp
->u
.p
.fmt
);
3827 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3828 *dtp
->size
= dtp
->u
.p
.current_unit
->size_used
;
3830 if (dtp
->u
.p
.eor_condition
)
3832 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3836 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3838 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3839 dtp
->u
.p
.current_unit
->current_record
= 0;
3843 dtp
->u
.p
.transfer
= NULL
;
3844 if (dtp
->u
.p
.current_unit
== NULL
)
3847 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3849 finish_list_read (dtp
);
3853 if (dtp
->u
.p
.mode
== WRITING
)
3854 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3855 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3857 if (is_stream_io (dtp
))
3859 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3860 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3861 next_record (dtp
, 1);
3866 dtp
->u
.p
.current_unit
->current_record
= 0;
3868 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3870 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3871 dtp
->u
.p
.seen_dollar
= 0;
3875 /* For non-advancing I/O, save the current maximum position for use in the
3876 next I/O operation if needed. */
3877 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3879 if (dtp
->u
.p
.skips
> 0)
3882 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
3883 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
3884 - dtp
->u
.p
.current_unit
->bytes_left
);
3886 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
3889 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3890 - dtp
->u
.p
.current_unit
->bytes_left
);
3891 dtp
->u
.p
.current_unit
->saved_pos
=
3892 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3893 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3896 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3897 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3898 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3900 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3902 next_record (dtp
, 1);
3905 #ifdef HAVE_USELOCALE
3906 if (dtp
->u
.p
.old_locale
!= (locale_t
) 0)
3908 uselocale (dtp
->u
.p
.old_locale
);
3909 dtp
->u
.p
.old_locale
= (locale_t
) 0;
3912 __gthread_mutex_lock (&old_locale_lock
);
3913 if (!--old_locale_ctr
)
3915 setlocale (LC_NUMERIC
, old_locale
);
3918 __gthread_mutex_unlock (&old_locale_lock
);
3922 /* Transfer function for IOLENGTH. It doesn't actually do any
3923 data transfer, it just updates the length counter. */
3926 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3927 void *dest
__attribute__ ((unused
)),
3928 int kind
__attribute__((unused
)),
3929 size_t size
, size_t nelems
)
3931 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3932 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3936 /* Initialize the IOLENGTH data transfer. This function is in essence
3937 a very much simplified version of data_transfer_init(), because it
3938 doesn't have to deal with units at all. */
3941 iolength_transfer_init (st_parameter_dt
*dtp
)
3943 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3946 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3948 /* Set up the subroutine that will handle the transfers. */
3950 dtp
->u
.p
.transfer
= iolength_transfer
;
3954 /* Library entry point for the IOLENGTH form of the INQUIRE
3955 statement. The IOLENGTH form requires no I/O to be performed, but
3956 it must still be a runtime library call so that we can determine
3957 the iolength for dynamic arrays and such. */
3959 extern void st_iolength (st_parameter_dt
*);
3960 export_proto(st_iolength
);
3963 st_iolength (st_parameter_dt
*dtp
)
3965 library_start (&dtp
->common
);
3966 iolength_transfer_init (dtp
);
3969 extern void st_iolength_done (st_parameter_dt
*);
3970 export_proto(st_iolength_done
);
3973 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3980 /* The READ statement. */
3982 extern void st_read (st_parameter_dt
*);
3983 export_proto(st_read
);
3986 st_read (st_parameter_dt
*dtp
)
3988 library_start (&dtp
->common
);
3990 data_transfer_init (dtp
, 1);
3993 extern void st_read_done (st_parameter_dt
*);
3994 export_proto(st_read_done
);
3997 st_read_done (st_parameter_dt
*dtp
)
3999 finalize_transfer (dtp
);
4003 /* If this is a parent READ statement we do not need to retain the
4004 internal unit structure for child use. Free it and stash the unit
4005 number for reuse. */
4006 if (dtp
->u
.p
.current_unit
!= NULL
4007 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4009 if (is_internal_unit (dtp
) &&
4010 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4012 free (dtp
->u
.p
.current_unit
->filename
);
4013 dtp
->u
.p
.current_unit
->filename
= NULL
;
4014 free (dtp
->u
.p
.current_unit
->s
);
4015 dtp
->u
.p
.current_unit
->s
= NULL
;
4016 if (dtp
->u
.p
.current_unit
->ls
)
4017 free (dtp
->u
.p
.current_unit
->ls
);
4018 dtp
->u
.p
.current_unit
->ls
= NULL
;
4019 stash_internal_unit (dtp
);
4021 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4023 free_format_data (dtp
->u
.p
.fmt
);
4026 unlock_unit (dtp
->u
.p
.current_unit
);
4032 extern void st_write (st_parameter_dt
*);
4033 export_proto(st_write
);
4036 st_write (st_parameter_dt
*dtp
)
4038 library_start (&dtp
->common
);
4039 data_transfer_init (dtp
, 0);
4042 extern void st_write_done (st_parameter_dt
*);
4043 export_proto(st_write_done
);
4046 st_write_done (st_parameter_dt
*dtp
)
4048 finalize_transfer (dtp
);
4050 if (dtp
->u
.p
.current_unit
!= NULL
4051 && dtp
->u
.p
.current_unit
->child_dtio
== 0)
4053 /* Deal with endfile conditions associated with sequential files. */
4054 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4055 switch (dtp
->u
.p
.current_unit
->endfile
)
4057 case AT_ENDFILE
: /* Remain at the endfile record. */
4061 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
4065 /* Get rid of whatever is after this record. */
4066 if (!is_internal_unit (dtp
))
4067 unit_truncate (dtp
->u
.p
.current_unit
,
4068 stell (dtp
->u
.p
.current_unit
->s
),
4070 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4076 /* If this is a parent WRITE statement we do not need to retain the
4077 internal unit structure for child use. Free it and stash the
4078 unit number for reuse. */
4079 if (is_internal_unit (dtp
) &&
4080 (dtp
->common
.flags
& IOPARM_DT_HAS_UDTIO
) == 0)
4082 free (dtp
->u
.p
.current_unit
->filename
);
4083 dtp
->u
.p
.current_unit
->filename
= NULL
;
4084 free (dtp
->u
.p
.current_unit
->s
);
4085 dtp
->u
.p
.current_unit
->s
= NULL
;
4086 if (dtp
->u
.p
.current_unit
->ls
)
4087 free (dtp
->u
.p
.current_unit
->ls
);
4088 dtp
->u
.p
.current_unit
->ls
= NULL
;
4089 stash_internal_unit (dtp
);
4091 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
4093 free_format_data (dtp
->u
.p
.fmt
);
4096 unlock_unit (dtp
->u
.p
.current_unit
);
4102 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
4104 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
4109 /* Receives the scalar information for namelist objects and stores it
4110 in a linked list of namelist_info types. */
4113 set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4114 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4115 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4117 namelist_info
*t1
= NULL
;
4119 size_t var_name_len
= strlen (var_name
);
4121 nml
= (namelist_info
*) xmalloc (sizeof (namelist_info
));
4123 nml
->mem_pos
= var_addr
;
4124 nml
->dtio_sub
= dtio_sub
;
4125 nml
->vtable
= vtable
;
4127 nml
->var_name
= (char*) xmalloc (var_name_len
+ 1);
4128 memcpy (nml
->var_name
, var_name
, var_name_len
);
4129 nml
->var_name
[var_name_len
] = '\0';
4131 nml
->len
= (int) len
;
4132 nml
->string_length
= (index_type
) string_length
;
4134 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
4135 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
4136 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
4138 if (nml
->var_rank
> 0)
4140 nml
->dim
= (descriptor_dimension
*)
4141 xmallocarray (nml
->var_rank
, sizeof (descriptor_dimension
));
4142 nml
->ls
= (array_loop_spec
*)
4143 xmallocarray (nml
->var_rank
, sizeof (array_loop_spec
));
4153 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
4155 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
4156 dtp
->u
.p
.ionml
= nml
;
4160 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
4165 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
4166 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
4167 export_proto(st_set_nml_var
);
4170 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4171 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4172 GFC_INTEGER_4 dtype
)
4174 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4179 /* Essentially the same as previous but carrying the dtio procedure
4180 and the vtable as additional arguments. */
4181 extern void st_set_nml_dtio_var (st_parameter_dt
*dtp
, void *, char *,
4182 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
,
4184 export_proto(st_set_nml_dtio_var
);
4188 st_set_nml_dtio_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
4189 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
4190 GFC_INTEGER_4 dtype
, void *dtio_sub
, void *vtable
)
4192 set_nml_var (dtp
, var_addr
, var_name
, len
, string_length
,
4193 dtype
, dtio_sub
, vtable
);
4196 /* Store the dimensional information for the namelist object. */
4197 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
4198 index_type
, index_type
,
4200 export_proto(st_set_nml_var_dim
);
4203 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
4204 index_type stride
, index_type lbound
,
4207 namelist_info
* nml
;
4212 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
4214 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
4218 /* Once upon a time, a poor innocent Fortran program was reading a
4219 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4220 the OS doesn't tell whether we're at the EOF or whether we already
4221 went past it. Luckily our hero, libgfortran, keeps track of this.
4222 Call this function when you detect an EOF condition. See Section
4226 hit_eof (st_parameter_dt
* dtp
)
4228 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
4230 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
4231 switch (dtp
->u
.p
.current_unit
->endfile
)
4235 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4236 if (!is_internal_unit (dtp
) && !dtp
->u
.p
.namelist_mode
)
4238 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
4239 dtp
->u
.p
.current_unit
->current_record
= 0;
4242 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4246 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
4247 dtp
->u
.p
.current_unit
->current_record
= 0;
4252 /* Non-sequential files don't have an ENDFILE record, so we
4253 can't be at AFTER_ENDFILE. */
4254 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
4255 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
4256 dtp
->u
.p
.current_unit
->current_record
= 0;