1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
29 /* transfer.c -- Top level handling of data transfer statements. */
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
56 transfer_character_wide
60 These subroutines do not return status.
62 The last call is a call to st_[read|write]_done(). While
63 something can easily go wrong with the initial st_read() or
64 st_write(), an error inhibits any data from actually being
67 extern void transfer_integer (st_parameter_dt
*, void *, int);
68 export_proto(transfer_integer
);
70 extern void transfer_real (st_parameter_dt
*, void *, int);
71 export_proto(transfer_real
);
73 extern void transfer_logical (st_parameter_dt
*, void *, int);
74 export_proto(transfer_logical
);
76 extern void transfer_character (st_parameter_dt
*, void *, int);
77 export_proto(transfer_character
);
79 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
80 export_proto(transfer_character_wide
);
82 extern void transfer_complex (st_parameter_dt
*, void *, int);
83 export_proto(transfer_complex
);
85 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
87 export_proto(transfer_array
);
89 static void us_read (st_parameter_dt
*, int);
90 static void us_write (st_parameter_dt
*, int);
91 static void next_record_r_unf (st_parameter_dt
*, int);
92 static void next_record_w_unf (st_parameter_dt
*, int);
94 static const st_option advance_opt
[] = {
101 static const st_option decimal_opt
[] = {
102 {"point", DECIMAL_POINT
},
103 {"comma", DECIMAL_COMMA
},
107 static const st_option round_opt
[] = {
109 {"down", ROUND_DOWN
},
110 {"zero", ROUND_ZERO
},
111 {"nearest", ROUND_NEAREST
},
112 {"compatible", ROUND_COMPATIBLE
},
113 {"processor_defined", ROUND_PROCDEFINED
},
118 static const st_option sign_opt
[] = {
120 {"suppress", SIGN_SS
},
121 {"processor_defined", SIGN_S
},
125 static const st_option blank_opt
[] = {
126 {"null", BLANK_NULL
},
127 {"zero", BLANK_ZERO
},
131 static const st_option delim_opt
[] = {
132 {"apostrophe", DELIM_APOSTROPHE
},
133 {"quote", DELIM_QUOTE
},
134 {"none", DELIM_NONE
},
138 static const st_option pad_opt
[] = {
145 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
146 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
152 current_mode (st_parameter_dt
*dtp
)
156 m
= FORM_UNSPECIFIED
;
158 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
160 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
161 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
163 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
165 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
166 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
168 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
170 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
171 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
178 /* Mid level data transfer statements. */
180 /* Read sequential file - internal unit */
183 read_sf_internal (st_parameter_dt
*dtp
, int * length
)
185 static char *empty_string
[0];
189 /* Zero size array gives internal unit len of 0. Nothing to read. */
190 if (dtp
->internal_unit_len
== 0
191 && dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
194 /* If we have seen an eor previously, return a length of 0. The
195 caller is responsible for correctly padding the input field. */
196 if (dtp
->u
.p
.sf_seen_eor
)
199 /* Just return something that isn't a NULL pointer, otherwise the
200 caller thinks an error occured. */
201 return (char*) empty_string
;
205 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
207 if (unlikely (lorig
> *length
))
213 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
215 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
216 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *length
;
222 /* When reading sequential formatted records we have a problem. We
223 don't know how long the line is until we read the trailing newline,
224 and we don't want to read too much. If we read too much, we might
225 have to do a physical seek backwards depending on how much data is
226 present, and devices like terminals aren't seekable and would cause
229 Given this, the solution is to read a byte at a time, stopping if
230 we hit the newline. For small allocations, we use a static buffer.
231 For larger allocations, we are forced to allocate memory on the
232 heap. Hopefully this won't happen very often. */
234 /* Read sequential file - external unit */
237 read_sf (st_parameter_dt
*dtp
, int * length
)
239 static char *empty_string
[0];
241 int n
, lorig
, seen_comma
;
243 /* If we have seen an eor previously, return a length of 0. The
244 caller is responsible for correctly padding the input field. */
245 if (dtp
->u
.p
.sf_seen_eor
)
248 /* Just return something that isn't a NULL pointer, otherwise the
249 caller thinks an error occured. */
250 return (char*) empty_string
;
255 /* Read data into format buffer and scan through it. */
257 base
= p
= fbuf_read (dtp
->u
.p
.current_unit
, length
);
265 if (q
== '\n' || q
== '\r')
267 /* Unexpected end of line. Set the position. */
268 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ 1 ,SEEK_CUR
);
269 dtp
->u
.p
.sf_seen_eor
= 1;
271 /* If we see an EOR during non-advancing I/O, we need to skip
272 the rest of the I/O statement. Set the corresponding flag. */
273 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
274 dtp
->u
.p
.eor_condition
= 1;
276 /* If we encounter a CR, it might be a CRLF. */
277 if (q
== '\r') /* Probably a CRLF */
279 /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
280 the position is not advanced unless it really is an LF. */
282 p
= fbuf_read (dtp
->u
.p
.current_unit
, &readlen
);
283 if (*p
== '\n' && readlen
== 1)
285 dtp
->u
.p
.sf_seen_eor
= 2;
286 fbuf_seek (dtp
->u
.p
.current_unit
, 1 ,SEEK_CUR
);
290 /* Without padding, terminate the I/O statement without assigning
291 the value. With padding, the value still needs to be assigned,
292 so we can just continue with a short read. */
293 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
295 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
302 /* Short circuit the read if a comma is found during numeric input.
303 The flag is set to zero during character reads so that commas in
304 strings are not ignored */
306 if (dtp
->u
.p
.sf_read_comma
== 1)
309 notify_std (&dtp
->common
, GFC_STD_GNU
,
310 "Comma in formatted numeric read.");
318 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ seen_comma
, SEEK_CUR
);
320 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
321 some other stuff. Set the relevant flags. */
322 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
326 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
328 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
334 dtp
->u
.p
.eor_condition
= 1;
339 else if (dtp
->u
.p
.advance_status
== ADVANCE_NO
340 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
341 || dtp
->u
.p
.current_unit
->bytes_left
342 == dtp
->u
.p
.current_unit
->recl
)
351 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
353 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
354 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
360 /* Function for reading the next couple of bytes from the current
361 file, advancing the current position. We return FAILURE on end of record or
362 end of file. This function is only for formatted I/O, unformatted uses
365 If the read is short, then it is because the current record does not
366 have enough data to satisfy the read request and the file was
367 opened with PAD=YES. The caller must assume tailing spaces for
371 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
376 if (!is_stream_io (dtp
))
378 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
380 /* For preconnected units with default record length, set bytes left
381 to unit record length and proceed, otherwise error. */
382 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
383 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
384 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
387 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
388 && !is_internal_unit (dtp
))
390 /* Not enough data left. */
391 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
396 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0
397 && !is_internal_unit(dtp
)))
403 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
407 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
408 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
409 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
411 if (is_internal_unit (dtp
))
412 source
= read_sf_internal (dtp
, nbytes
);
414 source
= read_sf (dtp
, nbytes
);
416 dtp
->u
.p
.current_unit
->strm_pos
+=
417 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
421 /* If we reach here, we can assume it's direct access. */
423 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
426 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
427 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
429 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
430 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
432 if (norig
!= *nbytes
)
434 /* Short read, this shouldn't happen. */
435 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
437 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
442 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
448 /* Reads a block directly into application data space. This is for
449 unformatted files. */
452 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
454 ssize_t to_read_record
;
455 ssize_t have_read_record
;
456 ssize_t to_read_subrecord
;
457 ssize_t have_read_subrecord
;
460 if (is_stream_io (dtp
))
462 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
464 if (unlikely (have_read_record
< 0))
466 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
470 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
472 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
474 /* Short read, e.g. if we hit EOF. For stream files,
475 we have to set the end-of-file condition. */
481 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
483 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
486 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
487 nbytes
= to_read_record
;
492 to_read_record
= nbytes
;
495 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
497 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
498 if (unlikely (to_read_record
< 0))
500 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
504 if (to_read_record
!= (ssize_t
) nbytes
)
506 /* Short read, e.g. if we hit EOF. Apparently, we read
507 more than was written to the last record. */
511 if (unlikely (short_record
))
513 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
518 /* Unformatted sequential. We loop over the subrecords, reading
519 until the request has been fulfilled or the record has run out
520 of continuation subrecords. */
522 /* Check whether we exceed the total record length. */
524 if (dtp
->u
.p
.current_unit
->flags
.has_recl
525 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
527 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
532 to_read_record
= nbytes
;
535 have_read_record
= 0;
539 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
540 < (gfc_offset
) to_read_record
)
542 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
543 to_read_record
-= to_read_subrecord
;
547 to_read_subrecord
= to_read_record
;
551 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
553 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
554 buf
+ have_read_record
, to_read_subrecord
);
555 if (unlikely (have_read_subrecord
) < 0)
557 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
561 have_read_record
+= have_read_subrecord
;
563 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
566 /* Short read, e.g. if we hit EOF. This means the record
567 structure has been corrupted, or the trailing record
568 marker would still be present. */
570 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
574 if (to_read_record
> 0)
576 if (likely (dtp
->u
.p
.current_unit
->continued
))
578 next_record_r_unf (dtp
, 0);
583 /* Let's make sure the file position is correctly pre-positioned
584 for the next read statement. */
586 dtp
->u
.p
.current_unit
->current_record
= 0;
587 next_record_r_unf (dtp
, 0);
588 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
594 /* Normal exit, the read request has been fulfilled. */
599 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
600 if (unlikely (short_record
))
602 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
609 /* Function for writing a block of bytes to the current file at the
610 current position, advancing the file pointer. We are given a length
611 and return a pointer to a buffer that the caller must (completely)
612 fill in. Returns NULL on error. */
615 write_block (st_parameter_dt
*dtp
, int length
)
619 if (!is_stream_io (dtp
))
621 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
623 /* For preconnected units with default record length, set bytes left
624 to unit record length and proceed, otherwise error. */
625 if (likely ((dtp
->u
.p
.current_unit
->unit_number
626 == options
.stdout_unit
627 || dtp
->u
.p
.current_unit
->unit_number
628 == options
.stderr_unit
)
629 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
630 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
633 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
638 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
641 if (is_internal_unit (dtp
))
643 if (dtp
->common
.unit
) /* char4 internal unit. */
644 dest
= mem_alloc_w4 (dtp
->u
.p
.current_unit
->s
, &length
);
646 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
650 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
654 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
655 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
659 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
662 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
667 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
668 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
670 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
676 /* High level interface to swrite(), taking care of errors. This is only
677 called for unformatted files. There are three cases to consider:
678 Stream I/O, unformatted direct, unformatted sequential. */
681 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
684 ssize_t have_written
;
685 ssize_t to_write_subrecord
;
690 if (is_stream_io (dtp
))
692 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
693 if (unlikely (have_written
< 0))
695 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
699 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
704 /* Unformatted direct access. */
706 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
708 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
710 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
714 if (buf
== NULL
&& nbytes
== 0)
717 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
718 if (unlikely (have_written
< 0))
720 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
724 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
725 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
730 /* Unformatted sequential. */
734 if (dtp
->u
.p
.current_unit
->flags
.has_recl
735 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
737 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
749 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
750 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
752 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
753 (gfc_offset
) to_write_subrecord
;
755 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
756 buf
+ have_written
, to_write_subrecord
);
757 if (unlikely (to_write_subrecord
< 0))
759 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
763 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
764 nbytes
-= to_write_subrecord
;
765 have_written
+= to_write_subrecord
;
770 next_record_w_unf (dtp
, 1);
773 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
774 if (unlikely (short_record
))
776 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
783 /* Master function for unformatted reads. */
786 unformatted_read (st_parameter_dt
*dtp
, bt type
,
787 void *dest
, int kind
, size_t size
, size_t nelems
)
789 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
792 if (type
== BT_CHARACTER
)
793 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
794 read_block_direct (dtp
, dest
, size
* nelems
);
804 /* Handle wide chracters. */
805 if (type
== BT_CHARACTER
&& kind
!= 1)
811 /* Break up complex into its constituent reals. */
812 if (type
== BT_COMPLEX
)
818 /* By now, all complex variables have been split into their
819 constituent reals. */
821 for (i
= 0; i
< nelems
; i
++)
823 read_block_direct (dtp
, buffer
, size
);
824 reverse_memcpy (p
, buffer
, size
);
831 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
832 bytes on 64 bit machines. The unused bytes are not initialized and never
833 used, which can show an error with memory checking analyzers like
837 unformatted_write (st_parameter_dt
*dtp
, bt type
,
838 void *source
, int kind
, size_t size
, size_t nelems
)
840 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
843 size_t stride
= type
== BT_CHARACTER
?
844 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
846 write_buf (dtp
, source
, stride
* nelems
);
856 /* Handle wide chracters. */
857 if (type
== BT_CHARACTER
&& kind
!= 1)
863 /* Break up complex into its constituent reals. */
864 if (type
== BT_COMPLEX
)
870 /* By now, all complex variables have been split into their
871 constituent reals. */
873 for (i
= 0; i
< nelems
; i
++)
875 reverse_memcpy(buffer
, p
, size
);
877 write_buf (dtp
, buffer
, size
);
883 /* Return a pointer to the name of a type. */
908 internal_error (NULL
, "type_name(): Bad type");
915 /* Write a constant string to the output.
916 This is complicated because the string can have doubled delimiters
917 in it. The length in the format node is the true length. */
920 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
922 char c
, delimiter
, *p
, *q
;
925 length
= f
->u
.string
.length
;
929 p
= write_block (dtp
, length
);
936 for (; length
> 0; length
--)
939 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
940 q
++; /* Skip the doubled delimiter. */
945 /* Given actual and expected types in a formatted data transfer, make
946 sure they agree. If not, an error message is generated. Returns
947 nonzero if something went wrong. */
950 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
954 if (actual
== expected
)
957 /* Adjust item_count before emitting error message. */
958 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
959 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
961 format_error (dtp
, f
, buffer
);
966 /* This function is in the main loop for a formatted data transfer
967 statement. It would be natural to implement this as a coroutine
968 with the user program, but C makes that awkward. We loop,
969 processing format elements. When we actually have to transfer
970 data instead of just setting flags, we return control to the user
971 program which calls a function that supplies the address and type
972 of the next element, then comes back here to process it. */
975 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
982 int consume_data_flag
;
984 /* Change a complex data item into a pair of reals. */
986 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
987 if (type
== BT_COMPLEX
)
993 /* If there's an EOR condition, we simulate finalizing the transfer
995 if (dtp
->u
.p
.eor_condition
)
998 /* Set this flag so that commas in reads cause the read to complete before
999 the entire field has been read. The next read field will start right after
1000 the comma in the stream. (Set to 0 for character reads). */
1001 dtp
->u
.p
.sf_read_comma
=
1002 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1006 /* If reversion has occurred and there is another real data item,
1007 then we have to move to the next record. */
1008 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1010 dtp
->u
.p
.reversion_flag
= 0;
1011 next_record (dtp
, 0);
1014 consume_data_flag
= 1;
1015 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1018 f
= next_format (dtp
);
1021 /* No data descriptors left. */
1022 if (unlikely (n
> 0))
1023 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1024 "Insufficient data descriptors in format after reversion");
1030 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1031 - dtp
->u
.p
.current_unit
->bytes_left
);
1033 if (is_stream_io(dtp
))
1040 goto need_read_data
;
1041 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1043 read_decimal (dtp
, f
, p
, kind
);
1048 goto need_read_data
;
1049 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1050 && require_type (dtp
, BT_INTEGER
, type
, f
))
1052 read_radix (dtp
, f
, p
, kind
, 2);
1057 goto need_read_data
;
1058 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1059 && require_type (dtp
, BT_INTEGER
, type
, f
))
1061 read_radix (dtp
, f
, p
, kind
, 8);
1066 goto need_read_data
;
1067 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1068 && require_type (dtp
, BT_INTEGER
, type
, f
))
1070 read_radix (dtp
, f
, p
, kind
, 16);
1075 goto need_read_data
;
1077 /* It is possible to have FMT_A with something not BT_CHARACTER such
1078 as when writing out hollerith strings, so check both type
1079 and kind before calling wide character routines. */
1080 if (type
== BT_CHARACTER
&& kind
== 4)
1081 read_a_char4 (dtp
, f
, p
, size
);
1083 read_a (dtp
, f
, p
, size
);
1088 goto need_read_data
;
1089 read_l (dtp
, f
, p
, kind
);
1094 goto need_read_data
;
1095 if (require_type (dtp
, BT_REAL
, type
, f
))
1097 read_f (dtp
, f
, p
, kind
);
1102 goto need_read_data
;
1103 if (require_type (dtp
, BT_REAL
, type
, f
))
1105 read_f (dtp
, f
, p
, kind
);
1110 goto need_read_data
;
1111 if (require_type (dtp
, BT_REAL
, type
, f
))
1113 read_f (dtp
, f
, p
, kind
);
1118 goto need_read_data
;
1119 if (require_type (dtp
, BT_REAL
, type
, f
))
1121 read_f (dtp
, f
, p
, kind
);
1126 goto need_read_data
;
1127 if (require_type (dtp
, BT_REAL
, type
, f
))
1129 read_f (dtp
, f
, p
, kind
);
1134 goto need_read_data
;
1138 read_decimal (dtp
, f
, p
, kind
);
1141 read_l (dtp
, f
, p
, kind
);
1145 read_a_char4 (dtp
, f
, p
, size
);
1147 read_a (dtp
, f
, p
, size
);
1150 read_f (dtp
, f
, p
, kind
);
1153 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1158 consume_data_flag
= 0;
1159 format_error (dtp
, f
, "Constant string in input format");
1162 /* Format codes that don't transfer data. */
1165 consume_data_flag
= 0;
1166 dtp
->u
.p
.skips
+= f
->u
.n
;
1167 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1168 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1169 read_x (dtp
, f
->u
.n
);
1174 consume_data_flag
= 0;
1176 if (f
->format
== FMT_TL
)
1178 /* Handle the special case when no bytes have been used yet.
1179 Cannot go below zero. */
1180 if (bytes_used
== 0)
1182 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1183 dtp
->u
.p
.skips
-= f
->u
.n
;
1184 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1187 pos
= bytes_used
- f
->u
.n
;
1192 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1193 left tab limit. We do not check if the position has gone
1194 beyond the end of record because a subsequent tab could
1195 bring us back again. */
1196 pos
= pos
< 0 ? 0 : pos
;
1198 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1199 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1200 + pos
- dtp
->u
.p
.max_pos
;
1201 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1202 ? 0 : dtp
->u
.p
.pending_spaces
;
1203 if (dtp
->u
.p
.skips
== 0)
1206 /* Adjust everything for end-of-record condition */
1207 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1209 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1210 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1212 dtp
->u
.p
.sf_seen_eor
= 0;
1214 if (dtp
->u
.p
.skips
< 0)
1216 if (is_internal_unit (dtp
))
1217 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1219 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1220 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1221 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1224 read_x (dtp
, dtp
->u
.p
.skips
);
1228 consume_data_flag
= 0;
1229 dtp
->u
.p
.sign_status
= SIGN_S
;
1233 consume_data_flag
= 0;
1234 dtp
->u
.p
.sign_status
= SIGN_SS
;
1238 consume_data_flag
= 0;
1239 dtp
->u
.p
.sign_status
= SIGN_SP
;
1243 consume_data_flag
= 0 ;
1244 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1248 consume_data_flag
= 0;
1249 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1253 consume_data_flag
= 0;
1254 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1258 consume_data_flag
= 0;
1259 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1263 consume_data_flag
= 0;
1264 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1268 consume_data_flag
= 0;
1269 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1273 consume_data_flag
= 0;
1274 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1278 consume_data_flag
= 0;
1279 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1283 consume_data_flag
= 0;
1284 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1288 consume_data_flag
= 0;
1289 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1293 consume_data_flag
= 0;
1294 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1298 consume_data_flag
= 0;
1299 dtp
->u
.p
.seen_dollar
= 1;
1303 consume_data_flag
= 0;
1304 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1305 next_record (dtp
, 0);
1309 /* A colon descriptor causes us to exit this loop (in
1310 particular preventing another / descriptor from being
1311 processed) unless there is another data item to be
1313 consume_data_flag
= 0;
1319 internal_error (&dtp
->common
, "Bad format node");
1322 /* Adjust the item count and data pointer. */
1324 if ((consume_data_flag
> 0) && (n
> 0))
1327 p
= ((char *) p
) + size
;
1332 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1333 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1338 /* Come here when we need a data descriptor but don't have one. We
1339 push the current format node back onto the input, then return and
1340 let the user program call us back with the data. */
1342 unget_format (dtp
, f
);
1347 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1350 int pos
, bytes_used
;
1354 int consume_data_flag
;
1356 /* Change a complex data item into a pair of reals. */
1358 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1359 if (type
== BT_COMPLEX
)
1365 /* If there's an EOR condition, we simulate finalizing the transfer
1366 by doing nothing. */
1367 if (dtp
->u
.p
.eor_condition
)
1370 /* Set this flag so that commas in reads cause the read to complete before
1371 the entire field has been read. The next read field will start right after
1372 the comma in the stream. (Set to 0 for character reads). */
1373 dtp
->u
.p
.sf_read_comma
=
1374 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1378 /* If reversion has occurred and there is another real data item,
1379 then we have to move to the next record. */
1380 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1382 dtp
->u
.p
.reversion_flag
= 0;
1383 next_record (dtp
, 0);
1386 consume_data_flag
= 1;
1387 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1390 f
= next_format (dtp
);
1393 /* No data descriptors left. */
1394 if (unlikely (n
> 0))
1395 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1396 "Insufficient data descriptors in format after reversion");
1400 /* Now discharge T, TR and X movements to the right. This is delayed
1401 until a data producing format to suppress trailing spaces. */
1404 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1405 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1406 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1407 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1408 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1409 || t
== FMT_STRING
))
1411 if (dtp
->u
.p
.skips
> 0)
1414 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1415 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1416 - dtp
->u
.p
.current_unit
->bytes_left
);
1418 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1420 if (dtp
->u
.p
.skips
< 0)
1422 if (is_internal_unit (dtp
))
1423 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1425 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1426 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1428 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1431 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1432 - dtp
->u
.p
.current_unit
->bytes_left
);
1434 if (is_stream_io(dtp
))
1442 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1444 write_i (dtp
, f
, p
, kind
);
1450 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1451 && require_type (dtp
, BT_INTEGER
, type
, f
))
1453 write_b (dtp
, f
, p
, kind
);
1459 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1460 && require_type (dtp
, BT_INTEGER
, type
, f
))
1462 write_o (dtp
, f
, p
, kind
);
1468 if (!(compile_options
.allow_std
& GFC_STD_GNU
)
1469 && require_type (dtp
, BT_INTEGER
, type
, f
))
1471 write_z (dtp
, f
, p
, kind
);
1478 /* It is possible to have FMT_A with something not BT_CHARACTER such
1479 as when writing out hollerith strings, so check both type
1480 and kind before calling wide character routines. */
1481 if (type
== BT_CHARACTER
&& kind
== 4)
1482 write_a_char4 (dtp
, f
, p
, size
);
1484 write_a (dtp
, f
, p
, size
);
1490 write_l (dtp
, f
, p
, kind
);
1496 if (require_type (dtp
, BT_REAL
, type
, f
))
1498 write_d (dtp
, f
, p
, kind
);
1504 if (require_type (dtp
, BT_REAL
, type
, f
))
1506 write_e (dtp
, f
, p
, kind
);
1512 if (require_type (dtp
, BT_REAL
, type
, f
))
1514 write_en (dtp
, f
, p
, kind
);
1520 if (require_type (dtp
, BT_REAL
, type
, f
))
1522 write_es (dtp
, f
, p
, kind
);
1528 if (require_type (dtp
, BT_REAL
, type
, f
))
1530 write_f (dtp
, f
, p
, kind
);
1539 write_i (dtp
, f
, p
, kind
);
1542 write_l (dtp
, f
, p
, kind
);
1546 write_a_char4 (dtp
, f
, p
, size
);
1548 write_a (dtp
, f
, p
, size
);
1551 if (f
->u
.real
.w
== 0)
1552 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1554 write_d (dtp
, f
, p
, kind
);
1557 internal_error (&dtp
->common
,
1558 "formatted_transfer(): Bad type");
1563 consume_data_flag
= 0;
1564 write_constant_string (dtp
, f
);
1567 /* Format codes that don't transfer data. */
1570 consume_data_flag
= 0;
1572 dtp
->u
.p
.skips
+= f
->u
.n
;
1573 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1574 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1575 /* Writes occur just before the switch on f->format, above, so
1576 that trailing blanks are suppressed, unless we are doing a
1577 non-advancing write in which case we want to output the blanks
1579 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1581 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1582 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1588 consume_data_flag
= 0;
1590 if (f
->format
== FMT_TL
)
1593 /* Handle the special case when no bytes have been used yet.
1594 Cannot go below zero. */
1595 if (bytes_used
== 0)
1597 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1598 dtp
->u
.p
.skips
-= f
->u
.n
;
1599 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1602 pos
= bytes_used
- f
->u
.n
;
1605 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1607 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1608 left tab limit. We do not check if the position has gone
1609 beyond the end of record because a subsequent tab could
1610 bring us back again. */
1611 pos
= pos
< 0 ? 0 : pos
;
1613 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1614 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1615 + pos
- dtp
->u
.p
.max_pos
;
1616 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1617 ? 0 : dtp
->u
.p
.pending_spaces
;
1621 consume_data_flag
= 0;
1622 dtp
->u
.p
.sign_status
= SIGN_S
;
1626 consume_data_flag
= 0;
1627 dtp
->u
.p
.sign_status
= SIGN_SS
;
1631 consume_data_flag
= 0;
1632 dtp
->u
.p
.sign_status
= SIGN_SP
;
1636 consume_data_flag
= 0 ;
1637 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1641 consume_data_flag
= 0;
1642 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1646 consume_data_flag
= 0;
1647 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1651 consume_data_flag
= 0;
1652 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1656 consume_data_flag
= 0;
1657 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1661 consume_data_flag
= 0;
1662 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1666 consume_data_flag
= 0;
1667 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1671 consume_data_flag
= 0;
1672 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1676 consume_data_flag
= 0;
1677 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1681 consume_data_flag
= 0;
1682 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1686 consume_data_flag
= 0;
1687 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1691 consume_data_flag
= 0;
1692 dtp
->u
.p
.seen_dollar
= 1;
1696 consume_data_flag
= 0;
1697 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1698 next_record (dtp
, 0);
1702 /* A colon descriptor causes us to exit this loop (in
1703 particular preventing another / descriptor from being
1704 processed) unless there is another data item to be
1706 consume_data_flag
= 0;
1712 internal_error (&dtp
->common
, "Bad format node");
1715 /* Adjust the item count and data pointer. */
1717 if ((consume_data_flag
> 0) && (n
> 0))
1720 p
= ((char *) p
) + size
;
1723 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1724 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1729 /* Come here when we need a data descriptor but don't have one. We
1730 push the current format node back onto the input, then return and
1731 let the user program call us back with the data. */
1733 unget_format (dtp
, f
);
1736 /* This function is first called from data_init_transfer to initiate the loop
1737 over each item in the format, transferring data as required. Subsequent
1738 calls to this function occur for each data item foound in the READ/WRITE
1739 statement. The item_count is incremented for each call. Since the first
1740 call is from data_transfer_init, the item_count is always one greater than
1741 the actual count number of the item being transferred. */
1744 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1745 size_t size
, size_t nelems
)
1751 size_t stride
= type
== BT_CHARACTER
?
1752 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1753 if (dtp
->u
.p
.mode
== READING
)
1755 /* Big loop over all the elements. */
1756 for (elem
= 0; elem
< nelems
; elem
++)
1758 dtp
->u
.p
.item_count
++;
1759 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1764 /* Big loop over all the elements. */
1765 for (elem
= 0; elem
< nelems
; elem
++)
1767 dtp
->u
.p
.item_count
++;
1768 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1774 /* Data transfer entry points. The type of the data entity is
1775 implicit in the subroutine call. This prevents us from having to
1776 share a common enum with the compiler. */
1779 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1781 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1783 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1788 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1791 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1793 size
= size_from_real_kind (kind
);
1794 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1799 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1801 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1803 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1808 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1810 static char *empty_string
[0];
1812 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1815 /* Strings of zero length can have p == NULL, which confuses the
1816 transfer routines into thinking we need more data elements. To avoid
1817 this, we give them a nice pointer. */
1818 if (len
== 0 && p
== NULL
)
1821 /* Set kind here to 1. */
1822 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1826 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1828 static char *empty_string
[0];
1830 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1833 /* Strings of zero length can have p == NULL, which confuses the
1834 transfer routines into thinking we need more data elements. To avoid
1835 this, we give them a nice pointer. */
1836 if (len
== 0 && p
== NULL
)
1839 /* Here we pass the actual kind value. */
1840 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1845 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1848 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1850 size
= size_from_complex_kind (kind
);
1851 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1856 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1857 gfc_charlen_type charlen
)
1859 index_type count
[GFC_MAX_DIMENSIONS
];
1860 index_type extent
[GFC_MAX_DIMENSIONS
];
1861 index_type stride
[GFC_MAX_DIMENSIONS
];
1862 index_type stride0
, rank
, size
, type
, n
;
1867 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1870 type
= GFC_DESCRIPTOR_TYPE (desc
);
1871 size
= GFC_DESCRIPTOR_SIZE (desc
);
1873 /* FIXME: What a kludge: Array descriptors and the IO library use
1874 different enums for types. */
1877 case GFC_DTYPE_UNKNOWN
:
1878 iotype
= BT_NULL
; /* Is this correct? */
1880 case GFC_DTYPE_INTEGER
:
1881 iotype
= BT_INTEGER
;
1883 case GFC_DTYPE_LOGICAL
:
1884 iotype
= BT_LOGICAL
;
1886 case GFC_DTYPE_REAL
:
1889 case GFC_DTYPE_COMPLEX
:
1890 iotype
= BT_COMPLEX
;
1892 case GFC_DTYPE_CHARACTER
:
1893 iotype
= BT_CHARACTER
;
1896 case GFC_DTYPE_DERIVED
:
1897 internal_error (&dtp
->common
,
1898 "Derived type I/O should have been handled via the frontend.");
1901 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1904 rank
= GFC_DESCRIPTOR_RANK (desc
);
1905 for (n
= 0; n
< rank
; n
++)
1908 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
1909 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
1911 /* If the extent of even one dimension is zero, then the entire
1912 array section contains zero elements, so we return after writing
1913 a zero array record. */
1918 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1923 stride0
= stride
[0];
1925 /* If the innermost dimension has a stride of 1, we can do the transfer
1926 in contiguous chunks. */
1927 if (stride0
== size
)
1932 data
= GFC_DESCRIPTOR_DATA (desc
);
1936 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1937 data
+= stride0
* tsize
;
1940 while (count
[n
] == extent
[n
])
1943 data
-= stride
[n
] * extent
[n
];
1960 /* Preposition a sequential unformatted file while reading. */
1963 us_read (st_parameter_dt
*dtp
, int continued
)
1970 if (compile_options
.record_marker
== 0)
1971 n
= sizeof (GFC_INTEGER_4
);
1973 n
= compile_options
.record_marker
;
1975 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1976 if (unlikely (nr
< 0))
1978 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1984 return; /* end of file */
1986 else if (unlikely (n
!= nr
))
1988 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1992 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1993 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1997 case sizeof(GFC_INTEGER_4
):
1998 memcpy (&i4
, &i
, sizeof (i4
));
2002 case sizeof(GFC_INTEGER_8
):
2003 memcpy (&i8
, &i
, sizeof (i8
));
2008 runtime_error ("Illegal value for record marker");
2015 case sizeof(GFC_INTEGER_4
):
2016 reverse_memcpy (&i4
, &i
, sizeof (i4
));
2020 case sizeof(GFC_INTEGER_8
):
2021 reverse_memcpy (&i8
, &i
, sizeof (i8
));
2026 runtime_error ("Illegal value for record marker");
2032 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
2033 dtp
->u
.p
.current_unit
->continued
= 0;
2037 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2038 dtp
->u
.p
.current_unit
->continued
= 1;
2042 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2046 /* Preposition a sequential unformatted file while writing. This
2047 amount to writing a bogus length that will be filled in later. */
2050 us_write (st_parameter_dt
*dtp
, int continued
)
2057 if (compile_options
.record_marker
== 0)
2058 nbytes
= sizeof (GFC_INTEGER_4
);
2060 nbytes
= compile_options
.record_marker
;
2062 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2063 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2065 /* For sequential unformatted, if RECL= was not specified in the OPEN
2066 we write until we have more bytes than can fit in the subrecord
2067 markers, then we write a new subrecord. */
2069 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2070 dtp
->u
.p
.current_unit
->recl_subrecord
;
2071 dtp
->u
.p
.current_unit
->continued
= continued
;
2075 /* Position to the next record prior to transfer. We are assumed to
2076 be before the next record. We also calculate the bytes in the next
2080 pre_position (st_parameter_dt
*dtp
)
2082 if (dtp
->u
.p
.current_unit
->current_record
)
2083 return; /* Already positioned. */
2085 switch (current_mode (dtp
))
2087 case FORMATTED_STREAM
:
2088 case UNFORMATTED_STREAM
:
2089 /* There are no records with stream I/O. If the position was specified
2090 data_transfer_init has already positioned the file. If no position
2091 was specified, we continue from where we last left off. I.e.
2092 there is nothing to do here. */
2095 case UNFORMATTED_SEQUENTIAL
:
2096 if (dtp
->u
.p
.mode
== READING
)
2103 case FORMATTED_SEQUENTIAL
:
2104 case FORMATTED_DIRECT
:
2105 case UNFORMATTED_DIRECT
:
2106 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2110 dtp
->u
.p
.current_unit
->current_record
= 1;
2114 /* Initialize things for a data transfer. This code is common for
2115 both reading and writing. */
2118 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2120 unit_flags u_flags
; /* Used for creating a unit if needed. */
2121 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2122 namelist_info
*ionml
;
2124 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2126 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2128 dtp
->u
.p
.ionml
= ionml
;
2129 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2131 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2134 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2135 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2137 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2138 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2139 { /* Open the unit with some default flags. */
2140 st_parameter_open opp
;
2143 if (dtp
->common
.unit
< 0)
2145 close_unit (dtp
->u
.p
.current_unit
);
2146 dtp
->u
.p
.current_unit
= NULL
;
2147 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2148 "Bad unit number in statement");
2151 memset (&u_flags
, '\0', sizeof (u_flags
));
2152 u_flags
.access
= ACCESS_SEQUENTIAL
;
2153 u_flags
.action
= ACTION_READWRITE
;
2155 /* Is it unformatted? */
2156 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2157 | IOPARM_DT_IONML_SET
)))
2158 u_flags
.form
= FORM_UNFORMATTED
;
2160 u_flags
.form
= FORM_UNSPECIFIED
;
2162 u_flags
.delim
= DELIM_UNSPECIFIED
;
2163 u_flags
.blank
= BLANK_UNSPECIFIED
;
2164 u_flags
.pad
= PAD_UNSPECIFIED
;
2165 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2166 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2167 u_flags
.async
= ASYNC_UNSPECIFIED
;
2168 u_flags
.round
= ROUND_UNSPECIFIED
;
2169 u_flags
.sign
= SIGN_UNSPECIFIED
;
2171 u_flags
.status
= STATUS_UNKNOWN
;
2173 conv
= get_unformatted_convert (dtp
->common
.unit
);
2175 if (conv
== GFC_CONVERT_NONE
)
2176 conv
= compile_options
.convert
;
2178 /* We use big_endian, which is 0 on little-endian machines
2179 and 1 on big-endian machines. */
2182 case GFC_CONVERT_NATIVE
:
2183 case GFC_CONVERT_SWAP
:
2186 case GFC_CONVERT_BIG
:
2187 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2190 case GFC_CONVERT_LITTLE
:
2191 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2195 internal_error (&opp
.common
, "Illegal value for CONVERT");
2199 u_flags
.convert
= conv
;
2201 opp
.common
= dtp
->common
;
2202 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2203 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2204 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2205 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2206 if (dtp
->u
.p
.current_unit
== NULL
)
2210 /* Check the action. */
2212 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2214 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2215 "Cannot read from file opened for WRITE");
2219 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2221 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2222 "Cannot write to file opened for READ");
2226 dtp
->u
.p
.first_item
= 1;
2228 /* Check the format. */
2230 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2233 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2234 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2237 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2238 "Format present for UNFORMATTED data transfer");
2242 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2244 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2245 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2246 "A format cannot be specified with a namelist");
2248 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2249 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2251 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2252 "Missing format for FORMATTED data transfer");
2255 if (is_internal_unit (dtp
)
2256 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2258 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2259 "Internal file cannot be accessed by UNFORMATTED "
2264 /* Check the record or position number. */
2266 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2267 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2269 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2270 "Direct access data transfer requires record number");
2274 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2276 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2278 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2279 "Record number not allowed for sequential access "
2284 if (dtp
->u
.p
.current_unit
->endfile
== AFTER_ENDFILE
)
2286 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2287 "Sequential READ or WRITE not allowed after "
2288 "EOF marker, possibly use REWIND or BACKSPACE");
2293 /* Process the ADVANCE option. */
2295 dtp
->u
.p
.advance_status
2296 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2297 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2298 "Bad ADVANCE parameter in data transfer statement");
2300 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2302 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2304 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2305 "ADVANCE specification conflicts with sequential "
2310 if (is_internal_unit (dtp
))
2312 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2313 "ADVANCE specification conflicts with internal file");
2317 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2318 != IOPARM_DT_HAS_FORMAT
)
2320 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2321 "ADVANCE specification requires an explicit format");
2328 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2330 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2332 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2333 "EOR specification requires an ADVANCE specification "
2338 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2339 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2341 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2342 "SIZE specification requires an ADVANCE "
2343 "specification of NO");
2348 { /* Write constraints. */
2349 if ((cf
& IOPARM_END
) != 0)
2351 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2352 "END specification cannot appear in a write "
2357 if ((cf
& IOPARM_EOR
) != 0)
2359 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2360 "EOR specification cannot appear in a write "
2365 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2367 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2368 "SIZE specification cannot appear in a write "
2374 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2375 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2377 /* Check the decimal mode. */
2378 dtp
->u
.p
.current_unit
->decimal_status
2379 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2380 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2381 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2384 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2385 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2387 /* Check the round mode. */
2388 dtp
->u
.p
.current_unit
->round_status
2389 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2390 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2391 round_opt
, "Bad ROUND parameter in data transfer "
2394 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2395 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2397 /* Check the sign mode. */
2398 dtp
->u
.p
.sign_status
2399 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2400 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2401 "Bad SIGN parameter in data transfer statement");
2403 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2404 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2406 /* Check the blank mode. */
2407 dtp
->u
.p
.blank_status
2408 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2409 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2411 "Bad BLANK parameter in data transfer statement");
2413 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2414 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2416 /* Check the delim mode. */
2417 dtp
->u
.p
.current_unit
->delim_status
2418 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2419 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2420 delim_opt
, "Bad DELIM parameter in data transfer statement");
2422 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2423 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2425 /* Check the pad mode. */
2426 dtp
->u
.p
.current_unit
->pad_status
2427 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2428 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2429 "Bad PAD parameter in data transfer statement");
2431 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2432 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2434 /* Check to see if we might be reading what we wrote before */
2436 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2437 && !is_internal_unit (dtp
))
2439 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2441 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2442 sflush(dtp
->u
.p
.current_unit
->s
);
2445 /* Check the POS= specifier: that it is in range and that it is used with a
2446 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2448 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2450 if (is_stream_io (dtp
))
2455 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2456 "POS=specifier must be positive");
2460 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2462 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2463 "POS=specifier too large");
2467 dtp
->rec
= dtp
->pos
;
2469 if (dtp
->u
.p
.mode
== READING
)
2471 /* Reset the endfile flag; if we hit EOF during reading
2472 we'll set the flag and generate an error at that point
2473 rather than worrying about it here. */
2474 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2477 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2479 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2480 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2482 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2485 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2490 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2491 "POS=specifier not allowed, "
2492 "Try OPEN with ACCESS='stream'");
2498 /* Sanity checks on the record number. */
2499 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2503 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2504 "Record number must be positive");
2508 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2510 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2511 "Record number too large");
2515 /* Make sure format buffer is reset. */
2516 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2517 fbuf_reset (dtp
->u
.p
.current_unit
);
2520 /* Check whether the record exists to be read. Only
2521 a partial record needs to exist. */
2523 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2524 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2526 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2527 "Non-existing record number");
2531 /* Position the file. */
2532 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2533 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2535 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2539 /* TODO: This is required to maintain compatibility between
2540 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2542 if (is_stream_io (dtp
))
2543 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2545 /* TODO: Un-comment this code when ABI changes from 4.3.
2546 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2548 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2549 "Record number not allowed for stream access "
2555 /* Bugware for badly written mixed C-Fortran I/O. */
2556 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2558 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2560 /* Set the maximum position reached from the previous I/O operation. This
2561 could be greater than zero from a previous non-advancing write. */
2562 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2567 /* Set up the subroutine that will handle the transfers. */
2571 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2572 dtp
->u
.p
.transfer
= unformatted_read
;
2575 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2576 dtp
->u
.p
.transfer
= list_formatted_read
;
2578 dtp
->u
.p
.transfer
= formatted_transfer
;
2583 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2584 dtp
->u
.p
.transfer
= unformatted_write
;
2587 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2588 dtp
->u
.p
.transfer
= list_formatted_write
;
2590 dtp
->u
.p
.transfer
= formatted_transfer
;
2594 /* Make sure that we don't do a read after a nonadvancing write. */
2598 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2600 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2601 "Cannot READ after a nonadvancing WRITE");
2607 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2608 dtp
->u
.p
.current_unit
->read_bad
= 1;
2611 /* Start the data transfer if we are doing a formatted transfer. */
2612 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2613 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2614 && dtp
->u
.p
.ionml
== NULL
)
2615 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2618 /* Initialize an array_loop_spec given the array descriptor. The function
2619 returns the index of the last element of the array, and also returns
2620 starting record, where the first I/O goes to (necessary in case of
2621 negative strides). */
2624 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2625 gfc_offset
*start_record
)
2627 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2636 for (i
=0; i
<rank
; i
++)
2638 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2639 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2640 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2641 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2642 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2643 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2645 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2647 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2648 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2652 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2653 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2654 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2655 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2665 /* Determine the index to the next record in an internal unit array by
2666 by incrementing through the array_loop_spec. */
2669 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2677 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2682 if (ls
[i
].idx
> ls
[i
].end
)
2684 ls
[i
].idx
= ls
[i
].start
;
2690 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2700 /* Skip to the end of the current record, taking care of an optional
2701 record marker of size bytes. If the file is not seekable, we
2702 read chunks of size MAX_READ until we get to the right
2706 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2708 ssize_t rlength
, readb
;
2709 static const ssize_t MAX_READ
= 4096;
2712 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2713 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2716 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2718 /* Direct access files do not generate END conditions,
2720 if (sseek (dtp
->u
.p
.current_unit
->s
,
2721 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2722 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2724 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
2727 { /* Seek by reading data. */
2728 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2731 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2732 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2734 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2737 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2741 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2748 /* Advance to the next record reading unformatted files, taking
2749 care of subrecords. If complete_record is nonzero, we loop
2750 until all subrecords are cleared. */
2753 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2757 bytes
= compile_options
.record_marker
== 0 ?
2758 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2763 /* Skip over tail */
2765 skip_record (dtp
, bytes
);
2767 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2775 static inline gfc_offset
2776 min_off (gfc_offset a
, gfc_offset b
)
2778 return (a
< b
? a
: b
);
2782 /* Space to the next record for read mode. */
2785 next_record_r (st_parameter_dt
*dtp
, int done
)
2792 switch (current_mode (dtp
))
2794 /* No records in unformatted STREAM I/O. */
2795 case UNFORMATTED_STREAM
:
2798 case UNFORMATTED_SEQUENTIAL
:
2799 next_record_r_unf (dtp
, 1);
2800 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2803 case FORMATTED_DIRECT
:
2804 case UNFORMATTED_DIRECT
:
2805 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
2808 case FORMATTED_STREAM
:
2809 case FORMATTED_SEQUENTIAL
:
2810 /* read_sf has already terminated input because of an '\n', or
2812 if (dtp
->u
.p
.sf_seen_eor
)
2814 dtp
->u
.p
.sf_seen_eor
= 0;
2818 if (is_internal_unit (dtp
))
2820 if (is_array_io (dtp
))
2824 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2826 if (!done
&& finished
)
2829 /* Now seek to this record. */
2830 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2831 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2833 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2836 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2840 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2841 bytes_left
= min_off (bytes_left
,
2842 file_length (dtp
->u
.p
.current_unit
->s
)
2843 - stell (dtp
->u
.p
.current_unit
->s
));
2844 if (sseek (dtp
->u
.p
.current_unit
->s
,
2845 bytes_left
, SEEK_CUR
) < 0)
2847 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2850 dtp
->u
.p
.current_unit
->bytes_left
2851 = dtp
->u
.p
.current_unit
->recl
;
2860 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2864 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2867 if (is_stream_io (dtp
)
2868 || dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
2869 || dtp
->u
.p
.current_unit
->bytes_left
2870 == dtp
->u
.p
.current_unit
->recl
)
2876 if (is_stream_io (dtp
))
2877 dtp
->u
.p
.current_unit
->strm_pos
++;
2888 /* Small utility function to write a record marker, taking care of
2889 byte swapping and of choosing the correct size. */
2892 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2897 char p
[sizeof (GFC_INTEGER_8
)];
2899 if (compile_options
.record_marker
== 0)
2900 len
= sizeof (GFC_INTEGER_4
);
2902 len
= compile_options
.record_marker
;
2904 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2905 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2909 case sizeof (GFC_INTEGER_4
):
2911 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2914 case sizeof (GFC_INTEGER_8
):
2916 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2920 runtime_error ("Illegal value for record marker");
2928 case sizeof (GFC_INTEGER_4
):
2930 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2931 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2934 case sizeof (GFC_INTEGER_8
):
2936 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2937 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2941 runtime_error ("Illegal value for record marker");
2948 /* Position to the next (sub)record in write mode for
2949 unformatted sequential files. */
2952 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2954 gfc_offset m
, m_write
, record_marker
;
2956 /* Bytes written. */
2957 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2958 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2960 /* Write the length tail. If we finish a record containing
2961 subrecords, we write out the negative length. */
2963 if (dtp
->u
.p
.current_unit
->continued
)
2968 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2971 if (compile_options
.record_marker
== 0)
2972 record_marker
= sizeof (GFC_INTEGER_4
);
2974 record_marker
= compile_options
.record_marker
;
2976 /* Seek to the head and overwrite the bogus length with the real
2979 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2988 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2991 /* Seek past the end of the current record. */
2993 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
3000 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3006 /* Utility function like memset() but operating on streams. Return
3007 value is same as for POSIX write(). */
3010 sset (stream
* s
, int c
, ssize_t nbyte
)
3012 static const int WRITE_CHUNK
= 256;
3013 char p
[WRITE_CHUNK
];
3014 ssize_t bytes_left
, trans
;
3016 if (nbyte
< WRITE_CHUNK
)
3017 memset (p
, c
, nbyte
);
3019 memset (p
, c
, WRITE_CHUNK
);
3022 while (bytes_left
> 0)
3024 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
3025 trans
= swrite (s
, p
, trans
);
3028 bytes_left
-= trans
;
3031 return nbyte
- bytes_left
;
3034 /* Position to the next record in write mode. */
3037 next_record_w (st_parameter_dt
*dtp
, int done
)
3039 gfc_offset m
, record
, max_pos
;
3042 /* Zero counters for X- and T-editing. */
3043 max_pos
= dtp
->u
.p
.max_pos
;
3044 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
3046 switch (current_mode (dtp
))
3048 /* No records in unformatted STREAM I/O. */
3049 case UNFORMATTED_STREAM
:
3052 case FORMATTED_DIRECT
:
3053 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3056 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3057 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3058 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3059 dtp
->u
.p
.current_unit
->bytes_left
)
3060 != dtp
->u
.p
.current_unit
->bytes_left
)
3065 case UNFORMATTED_DIRECT
:
3066 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3068 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3069 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3074 case UNFORMATTED_SEQUENTIAL
:
3075 next_record_w_unf (dtp
, 0);
3076 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3079 case FORMATTED_STREAM
:
3080 case FORMATTED_SEQUENTIAL
:
3082 if (is_internal_unit (dtp
))
3084 if (is_array_io (dtp
))
3088 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3090 /* If the farthest position reached is greater than current
3091 position, adjust the position and set length to pad out
3092 whats left. Otherwise just pad whats left.
3093 (for character array unit) */
3094 m
= dtp
->u
.p
.current_unit
->recl
3095 - dtp
->u
.p
.current_unit
->bytes_left
;
3098 length
= (int) (max_pos
- m
);
3099 if (sseek (dtp
->u
.p
.current_unit
->s
,
3100 length
, SEEK_CUR
) < 0)
3102 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3105 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3108 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3110 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3114 /* Now that the current record has been padded out,
3115 determine where the next record in the array is. */
3116 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3119 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3121 /* Now seek to this record */
3122 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3124 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3126 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3130 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3136 /* If this is the last call to next_record move to the farthest
3137 position reached and set length to pad out the remainder
3138 of the record. (for character scaler unit) */
3141 m
= dtp
->u
.p
.current_unit
->recl
3142 - dtp
->u
.p
.current_unit
->bytes_left
;
3145 length
= (int) (max_pos
- m
);
3146 if (sseek (dtp
->u
.p
.current_unit
->s
,
3147 length
, SEEK_CUR
) < 0)
3149 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3152 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3155 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3158 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3160 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3172 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3173 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3180 if (is_stream_io (dtp
))
3182 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3183 if (dtp
->u
.p
.current_unit
->strm_pos
3184 < file_length (dtp
->u
.p
.current_unit
->s
))
3185 unit_truncate (dtp
->u
.p
.current_unit
,
3186 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3194 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3199 /* Position to the next record, which means moving to the end of the
3200 current record. This can happen under several different
3201 conditions. If the done flag is not set, we get ready to process
3205 next_record (st_parameter_dt
*dtp
, int done
)
3207 gfc_offset fp
; /* File position. */
3209 dtp
->u
.p
.current_unit
->read_bad
= 0;
3211 if (dtp
->u
.p
.mode
== READING
)
3212 next_record_r (dtp
, done
);
3214 next_record_w (dtp
, done
);
3216 if (!is_stream_io (dtp
))
3218 /* Keep position up to date for INQUIRE */
3220 update_position (dtp
->u
.p
.current_unit
);
3222 dtp
->u
.p
.current_unit
->current_record
= 0;
3223 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3225 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3226 /* Calculate next record, rounding up partial records. */
3227 dtp
->u
.p
.current_unit
->last_record
=
3228 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3229 dtp
->u
.p
.current_unit
->recl
;
3232 dtp
->u
.p
.current_unit
->last_record
++;
3238 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3242 /* Finalize the current data transfer. For a nonadvancing transfer,
3243 this means advancing to the next record. For internal units close the
3244 stream associated with the unit. */
3247 finalize_transfer (st_parameter_dt
*dtp
)
3250 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3252 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3253 *dtp
->size
= dtp
->u
.p
.size_used
;
3255 if (dtp
->u
.p
.eor_condition
)
3257 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3261 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3263 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3264 dtp
->u
.p
.current_unit
->current_record
= 0;
3268 if ((dtp
->u
.p
.ionml
!= NULL
)
3269 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3271 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3272 namelist_read (dtp
);
3274 namelist_write (dtp
);
3277 dtp
->u
.p
.transfer
= NULL
;
3278 if (dtp
->u
.p
.current_unit
== NULL
)
3281 dtp
->u
.p
.eof_jump
= &eof_jump
;
3282 if (setjmp (eof_jump
))
3284 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3288 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3290 finish_list_read (dtp
);
3294 if (dtp
->u
.p
.mode
== WRITING
)
3295 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3296 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3298 if (is_stream_io (dtp
))
3300 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3301 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3302 next_record (dtp
, 1);
3307 dtp
->u
.p
.current_unit
->current_record
= 0;
3309 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3311 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3312 dtp
->u
.p
.seen_dollar
= 0;
3316 /* For non-advancing I/O, save the current maximum position for use in the
3317 next I/O operation if needed. */
3318 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3320 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3321 - dtp
->u
.p
.current_unit
->bytes_left
);
3322 dtp
->u
.p
.current_unit
->saved_pos
=
3323 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3324 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3327 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3328 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3329 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3331 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3333 next_record (dtp
, 1);
3336 /* Transfer function for IOLENGTH. It doesn't actually do any
3337 data transfer, it just updates the length counter. */
3340 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3341 void *dest
__attribute__ ((unused
)),
3342 int kind
__attribute__((unused
)),
3343 size_t size
, size_t nelems
)
3345 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3346 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3350 /* Initialize the IOLENGTH data transfer. This function is in essence
3351 a very much simplified version of data_transfer_init(), because it
3352 doesn't have to deal with units at all. */
3355 iolength_transfer_init (st_parameter_dt
*dtp
)
3357 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3360 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3362 /* Set up the subroutine that will handle the transfers. */
3364 dtp
->u
.p
.transfer
= iolength_transfer
;
3368 /* Library entry point for the IOLENGTH form of the INQUIRE
3369 statement. The IOLENGTH form requires no I/O to be performed, but
3370 it must still be a runtime library call so that we can determine
3371 the iolength for dynamic arrays and such. */
3373 extern void st_iolength (st_parameter_dt
*);
3374 export_proto(st_iolength
);
3377 st_iolength (st_parameter_dt
*dtp
)
3379 library_start (&dtp
->common
);
3380 iolength_transfer_init (dtp
);
3383 extern void st_iolength_done (st_parameter_dt
*);
3384 export_proto(st_iolength_done
);
3387 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3394 /* The READ statement. */
3396 extern void st_read (st_parameter_dt
*);
3397 export_proto(st_read
);
3400 st_read (st_parameter_dt
*dtp
)
3402 library_start (&dtp
->common
);
3404 data_transfer_init (dtp
, 1);
3407 extern void st_read_done (st_parameter_dt
*);
3408 export_proto(st_read_done
);
3411 st_read_done (st_parameter_dt
*dtp
)
3413 finalize_transfer (dtp
);
3414 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3415 free_format_data (dtp
->u
.p
.fmt
);
3417 if (dtp
->u
.p
.current_unit
!= NULL
)
3418 unlock_unit (dtp
->u
.p
.current_unit
);
3420 free_internal_unit (dtp
);
3425 extern void st_write (st_parameter_dt
*);
3426 export_proto(st_write
);
3429 st_write (st_parameter_dt
*dtp
)
3431 library_start (&dtp
->common
);
3432 data_transfer_init (dtp
, 0);
3435 extern void st_write_done (st_parameter_dt
*);
3436 export_proto(st_write_done
);
3439 st_write_done (st_parameter_dt
*dtp
)
3441 finalize_transfer (dtp
);
3443 /* Deal with endfile conditions associated with sequential files. */
3445 if (dtp
->u
.p
.current_unit
!= NULL
3446 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3447 switch (dtp
->u
.p
.current_unit
->endfile
)
3449 case AT_ENDFILE
: /* Remain at the endfile record. */
3453 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3457 /* Get rid of whatever is after this record. */
3458 if (!is_internal_unit (dtp
))
3459 unit_truncate (dtp
->u
.p
.current_unit
,
3460 stell (dtp
->u
.p
.current_unit
->s
),
3462 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3466 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3467 free_format_data (dtp
->u
.p
.fmt
);
3469 if (dtp
->u
.p
.current_unit
!= NULL
)
3470 unlock_unit (dtp
->u
.p
.current_unit
);
3472 free_internal_unit (dtp
);
3478 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3480 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3485 /* Receives the scalar information for namelist objects and stores it
3486 in a linked list of namelist_info types. */
3488 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3489 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3490 export_proto(st_set_nml_var
);
3494 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3495 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3496 GFC_INTEGER_4 dtype
)
3498 namelist_info
*t1
= NULL
;
3500 size_t var_name_len
= strlen (var_name
);
3502 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3504 nml
->mem_pos
= var_addr
;
3506 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3507 memcpy (nml
->var_name
, var_name
, var_name_len
);
3508 nml
->var_name
[var_name_len
] = '\0';
3510 nml
->len
= (int) len
;
3511 nml
->string_length
= (index_type
) string_length
;
3513 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3514 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3515 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3517 if (nml
->var_rank
> 0)
3519 nml
->dim
= (descriptor_dimension
*)
3520 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3521 nml
->ls
= (array_loop_spec
*)
3522 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3532 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3534 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3535 dtp
->u
.p
.ionml
= nml
;
3539 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3544 /* Store the dimensional information for the namelist object. */
3545 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3546 index_type
, index_type
,
3548 export_proto(st_set_nml_var_dim
);
3551 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3552 index_type stride
, index_type lbound
,
3555 namelist_info
* nml
;
3560 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3562 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3565 /* Reverse memcpy - used for byte swapping. */
3567 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3573 s
= (char *) src
+ n
- 1;
3575 /* Write with ascending order - this is likely faster
3576 on modern architectures because of write combining. */
3582 /* Once upon a time, a poor innocent Fortran program was reading a
3583 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3584 the OS doesn't tell whether we're at the EOF or whether we already
3585 went past it. Luckily our hero, libgfortran, keeps track of this.
3586 Call this function when you detect an EOF condition. See Section
3590 hit_eof (st_parameter_dt
* dtp
)
3592 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3594 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3595 switch (dtp
->u
.p
.current_unit
->endfile
)
3599 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3600 if (!is_internal_unit (dtp
))
3602 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3603 dtp
->u
.p
.current_unit
->current_record
= 0;
3606 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3610 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3611 dtp
->u
.p
.current_unit
->current_record
= 0;
3616 /* Non-sequential files don't have an ENDFILE record, so we
3617 can't be at AFTER_ENDFILE. */
3618 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3619 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3620 dtp
->u
.p
.current_unit
->current_record
= 0;