1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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 95 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. These subroutines do reading
179 and writing in the style of salloc_r()/salloc_w() within the
182 /* When reading sequential formatted records we have a problem. We
183 don't know how long the line is until we read the trailing newline,
184 and we don't want to read too much. If we read too much, we might
185 have to do a physical seek backwards depending on how much data is
186 present, and devices like terminals aren't seekable and would cause
189 Given this, the solution is to read a byte at a time, stopping if
190 we hit the newline. For small allocations, we use a static buffer.
191 For larger allocations, we are forced to allocate memory on the
192 heap. Hopefully this won't happen very often. */
195 read_sf (st_parameter_dt
*dtp
, int * length
, int no_error
)
197 static char *empty_string
[0];
199 int n
, lorig
, memread
, seen_comma
;
201 /* If we hit EOF previously with the no_error flag set (i.e. X, T,
202 TR edit descriptors), and we now try to read again, this time
203 without setting no_error. */
204 if (!no_error
&& dtp
->u
.p
.at_eof
)
211 /* If we have seen an eor previously, return a length of 0. The
212 caller is responsible for correctly padding the input field. */
213 if (dtp
->u
.p
.sf_seen_eor
)
216 /* Just return something that isn't a NULL pointer, otherwise the
217 caller thinks an error occured. */
218 return (char*) empty_string
;
221 if (is_internal_unit (dtp
))
224 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
225 if (unlikely (memread
> *length
))
236 /* Read data into format buffer and scan through it. */
238 base
= p
= fbuf_read (dtp
->u
.p
.current_unit
, length
);
246 if (q
== '\n' || q
== '\r')
248 /* Unexpected end of line. Set the position. */
249 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ 1 ,SEEK_CUR
);
250 dtp
->u
.p
.sf_seen_eor
= 1;
252 /* If we see an EOR during non-advancing I/O, we need to skip
253 the rest of the I/O statement. Set the corresponding flag. */
254 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
255 dtp
->u
.p
.eor_condition
= 1;
257 /* If we encounter a CR, it might be a CRLF. */
258 if (q
== '\r') /* Probably a CRLF */
260 /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
261 the position is not advanced unless it really is an LF. */
263 p
= fbuf_read (dtp
->u
.p
.current_unit
, &readlen
);
264 if (*p
== '\n' && readlen
== 1)
266 dtp
->u
.p
.sf_seen_eor
= 2;
267 fbuf_seek (dtp
->u
.p
.current_unit
, 1 ,SEEK_CUR
);
271 /* Without padding, terminate the I/O statement without assigning
272 the value. With padding, the value still needs to be assigned,
273 so we can just continue with a short read. */
274 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
276 if (likely (no_error
))
278 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
285 /* Short circuit the read if a comma is found during numeric input.
286 The flag is set to zero during character reads so that commas in
287 strings are not ignored */
289 if (dtp
->u
.p
.sf_read_comma
== 1)
292 notify_std (&dtp
->common
, GFC_STD_GNU
,
293 "Comma in formatted numeric read.");
301 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ seen_comma
, SEEK_CUR
);
303 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
304 some other stuff. Set the relevant flags. */
305 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
307 if (n
> 0 || no_error
)
309 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
311 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
317 dtp
->u
.p
.eor_condition
= 1;
331 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
333 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
334 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
340 /* Function for reading the next couple of bytes from the current
341 file, advancing the current position. We return FAILURE on end of record or
342 end of file. This function is only for formatted I/O, unformatted uses
345 If the read is short, then it is because the current record does not
346 have enough data to satisfy the read request and the file was
347 opened with PAD=YES. The caller must assume tailing spaces for
351 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
356 if (!is_stream_io (dtp
))
358 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
360 /* For preconnected units with default record length, set bytes left
361 to unit record length and proceed, otherwise error. */
362 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
363 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
364 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
367 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
369 /* Not enough data left. */
370 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
375 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
381 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
385 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
386 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
387 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
389 source
= read_sf (dtp
, nbytes
, 0);
390 dtp
->u
.p
.current_unit
->strm_pos
+=
391 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
395 /* If we reach here, we can assume it's direct access. */
397 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
400 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
401 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
403 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
404 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
406 if (norig
!= *nbytes
)
408 /* Short read, this shouldn't happen. */
409 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
411 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
416 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
422 /* Reads a block directly into application data space. This is for
423 unformatted files. */
426 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
428 ssize_t to_read_record
;
429 ssize_t have_read_record
;
430 ssize_t to_read_subrecord
;
431 ssize_t have_read_subrecord
;
434 if (is_stream_io (dtp
))
436 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
438 if (unlikely (have_read_record
< 0))
440 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
444 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
446 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
448 /* Short read, e.g. if we hit EOF. For stream files,
449 we have to set the end-of-file condition. */
455 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
457 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
460 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
461 nbytes
= to_read_record
;
466 to_read_record
= nbytes
;
469 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
471 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
472 if (unlikely (to_read_record
< 0))
474 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
478 if (to_read_record
!= (ssize_t
) nbytes
)
480 /* Short read, e.g. if we hit EOF. Apparently, we read
481 more than was written to the last record. */
485 if (unlikely (short_record
))
487 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
492 /* Unformatted sequential. We loop over the subrecords, reading
493 until the request has been fulfilled or the record has run out
494 of continuation subrecords. */
496 /* Check whether we exceed the total record length. */
498 if (dtp
->u
.p
.current_unit
->flags
.has_recl
499 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
501 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
506 to_read_record
= nbytes
;
509 have_read_record
= 0;
513 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
514 < (gfc_offset
) to_read_record
)
516 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
517 to_read_record
-= to_read_subrecord
;
521 to_read_subrecord
= to_read_record
;
525 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
527 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
528 buf
+ have_read_record
, to_read_subrecord
);
529 if (unlikely (have_read_subrecord
) < 0)
531 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
535 have_read_record
+= have_read_subrecord
;
537 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
540 /* Short read, e.g. if we hit EOF. This means the record
541 structure has been corrupted, or the trailing record
542 marker would still be present. */
544 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
548 if (to_read_record
> 0)
550 if (likely (dtp
->u
.p
.current_unit
->continued
))
552 next_record_r_unf (dtp
, 0);
557 /* Let's make sure the file position is correctly pre-positioned
558 for the next read statement. */
560 dtp
->u
.p
.current_unit
->current_record
= 0;
561 next_record_r_unf (dtp
, 0);
562 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
568 /* Normal exit, the read request has been fulfilled. */
573 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
574 if (unlikely (short_record
))
576 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
583 /* Function for writing a block of bytes to the current file at the
584 current position, advancing the file pointer. We are given a length
585 and return a pointer to a buffer that the caller must (completely)
586 fill in. Returns NULL on error. */
589 write_block (st_parameter_dt
*dtp
, int length
)
593 if (!is_stream_io (dtp
))
595 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
597 /* For preconnected units with default record length, set bytes left
598 to unit record length and proceed, otherwise error. */
599 if (likely ((dtp
->u
.p
.current_unit
->unit_number
600 == options
.stdout_unit
601 || dtp
->u
.p
.current_unit
->unit_number
602 == options
.stderr_unit
)
603 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
604 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
607 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
612 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
615 if (is_internal_unit (dtp
))
617 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
621 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
625 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
626 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
630 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
633 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
638 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
639 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
641 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
647 /* High level interface to swrite(), taking care of errors. This is only
648 called for unformatted files. There are three cases to consider:
649 Stream I/O, unformatted direct, unformatted sequential. */
652 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
655 ssize_t have_written
;
656 ssize_t to_write_subrecord
;
661 if (is_stream_io (dtp
))
663 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
664 if (unlikely (have_written
< 0))
666 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
670 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
675 /* Unformatted direct access. */
677 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
679 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
681 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
685 if (buf
== NULL
&& nbytes
== 0)
688 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
689 if (unlikely (have_written
< 0))
691 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
695 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
696 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
701 /* Unformatted sequential. */
705 if (dtp
->u
.p
.current_unit
->flags
.has_recl
706 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
708 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
720 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
721 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
723 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
724 (gfc_offset
) to_write_subrecord
;
726 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
727 buf
+ have_written
, to_write_subrecord
);
728 if (unlikely (to_write_subrecord
< 0))
730 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
734 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
735 nbytes
-= to_write_subrecord
;
736 have_written
+= to_write_subrecord
;
741 next_record_w_unf (dtp
, 1);
744 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
745 if (unlikely (short_record
))
747 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
754 /* Master function for unformatted reads. */
757 unformatted_read (st_parameter_dt
*dtp
, bt type
,
758 void *dest
, int kind
, size_t size
, size_t nelems
)
760 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
763 if (type
== BT_CHARACTER
)
764 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
765 read_block_direct (dtp
, dest
, size
* nelems
);
775 /* Handle wide chracters. */
776 if (type
== BT_CHARACTER
&& kind
!= 1)
782 /* Break up complex into its constituent reals. */
783 if (type
== BT_COMPLEX
)
789 /* By now, all complex variables have been split into their
790 constituent reals. */
792 for (i
= 0; i
< nelems
; i
++)
794 read_block_direct (dtp
, buffer
, size
);
795 reverse_memcpy (p
, buffer
, size
);
802 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
803 bytes on 64 bit machines. The unused bytes are not initialized and never
804 used, which can show an error with memory checking analyzers like
808 unformatted_write (st_parameter_dt
*dtp
, bt type
,
809 void *source
, int kind
, size_t size
, size_t nelems
)
811 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
814 size_t stride
= type
== BT_CHARACTER
?
815 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
817 write_buf (dtp
, source
, stride
* nelems
);
827 /* Handle wide chracters. */
828 if (type
== BT_CHARACTER
&& kind
!= 1)
834 /* Break up complex into its constituent reals. */
835 if (type
== BT_COMPLEX
)
841 /* By now, all complex variables have been split into their
842 constituent reals. */
844 for (i
= 0; i
< nelems
; i
++)
846 reverse_memcpy(buffer
, p
, size
);
848 write_buf (dtp
, buffer
, size
);
854 /* Return a pointer to the name of a type. */
879 internal_error (NULL
, "type_name(): Bad type");
886 /* Write a constant string to the output.
887 This is complicated because the string can have doubled delimiters
888 in it. The length in the format node is the true length. */
891 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
893 char c
, delimiter
, *p
, *q
;
896 length
= f
->u
.string
.length
;
900 p
= write_block (dtp
, length
);
907 for (; length
> 0; length
--)
910 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
911 q
++; /* Skip the doubled delimiter. */
916 /* Given actual and expected types in a formatted data transfer, make
917 sure they agree. If not, an error message is generated. Returns
918 nonzero if something went wrong. */
921 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
925 if (actual
== expected
)
928 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
929 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
931 format_error (dtp
, f
, buffer
);
936 /* This function is in the main loop for a formatted data transfer
937 statement. It would be natural to implement this as a coroutine
938 with the user program, but C makes that awkward. We loop,
939 processing format elements. When we actually have to transfer
940 data instead of just setting flags, we return control to the user
941 program which calls a function that supplies the address and type
942 of the next element, then comes back here to process it. */
945 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
952 int consume_data_flag
;
954 /* Change a complex data item into a pair of reals. */
956 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
957 if (type
== BT_COMPLEX
)
963 /* If there's an EOR condition, we simulate finalizing the transfer
965 if (dtp
->u
.p
.eor_condition
)
968 /* Set this flag so that commas in reads cause the read to complete before
969 the entire field has been read. The next read field will start right after
970 the comma in the stream. (Set to 0 for character reads). */
971 dtp
->u
.p
.sf_read_comma
=
972 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
976 /* If reversion has occurred and there is another real data item,
977 then we have to move to the next record. */
978 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
980 dtp
->u
.p
.reversion_flag
= 0;
981 next_record (dtp
, 0);
984 consume_data_flag
= 1;
985 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
988 f
= next_format (dtp
);
991 /* No data descriptors left. */
992 if (unlikely (n
> 0))
993 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
994 "Insufficient data descriptors in format after reversion");
1000 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1001 - dtp
->u
.p
.current_unit
->bytes_left
);
1003 if (is_stream_io(dtp
))
1010 goto need_read_data
;
1011 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1013 read_decimal (dtp
, f
, p
, kind
);
1018 goto need_read_data
;
1019 if (compile_options
.allow_std
< GFC_STD_GNU
1020 && require_type (dtp
, BT_INTEGER
, type
, f
))
1022 read_radix (dtp
, f
, p
, kind
, 2);
1027 goto need_read_data
;
1028 if (compile_options
.allow_std
< GFC_STD_GNU
1029 && require_type (dtp
, BT_INTEGER
, type
, f
))
1031 read_radix (dtp
, f
, p
, kind
, 8);
1036 goto need_read_data
;
1037 if (compile_options
.allow_std
< GFC_STD_GNU
1038 && require_type (dtp
, BT_INTEGER
, type
, f
))
1040 read_radix (dtp
, f
, p
, kind
, 16);
1045 goto need_read_data
;
1047 /* It is possible to have FMT_A with something not BT_CHARACTER such
1048 as when writing out hollerith strings, so check both type
1049 and kind before calling wide character routines. */
1050 if (type
== BT_CHARACTER
&& kind
== 4)
1051 read_a_char4 (dtp
, f
, p
, size
);
1053 read_a (dtp
, f
, p
, size
);
1058 goto need_read_data
;
1059 read_l (dtp
, f
, p
, kind
);
1064 goto need_read_data
;
1065 if (require_type (dtp
, BT_REAL
, type
, f
))
1067 read_f (dtp
, f
, p
, kind
);
1072 goto need_read_data
;
1073 if (require_type (dtp
, BT_REAL
, type
, f
))
1075 read_f (dtp
, f
, p
, kind
);
1080 goto need_read_data
;
1081 if (require_type (dtp
, BT_REAL
, type
, f
))
1083 read_f (dtp
, f
, p
, kind
);
1088 goto need_read_data
;
1089 if (require_type (dtp
, BT_REAL
, type
, f
))
1091 read_f (dtp
, f
, p
, kind
);
1096 goto need_read_data
;
1097 if (require_type (dtp
, BT_REAL
, type
, f
))
1099 read_f (dtp
, f
, p
, kind
);
1104 goto need_read_data
;
1108 read_decimal (dtp
, f
, p
, kind
);
1111 read_l (dtp
, f
, p
, kind
);
1115 read_a_char4 (dtp
, f
, p
, size
);
1117 read_a (dtp
, f
, p
, size
);
1120 read_f (dtp
, f
, p
, kind
);
1123 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1128 consume_data_flag
= 0;
1129 format_error (dtp
, f
, "Constant string in input format");
1132 /* Format codes that don't transfer data. */
1135 consume_data_flag
= 0;
1136 dtp
->u
.p
.skips
+= f
->u
.n
;
1137 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1138 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1139 read_x (dtp
, f
->u
.n
);
1144 consume_data_flag
= 0;
1146 if (f
->format
== FMT_TL
)
1148 /* Handle the special case when no bytes have been used yet.
1149 Cannot go below zero. */
1150 if (bytes_used
== 0)
1152 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1153 dtp
->u
.p
.skips
-= f
->u
.n
;
1154 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1157 pos
= bytes_used
- f
->u
.n
;
1162 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1163 left tab limit. We do not check if the position has gone
1164 beyond the end of record because a subsequent tab could
1165 bring us back again. */
1166 pos
= pos
< 0 ? 0 : pos
;
1168 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1169 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1170 + pos
- dtp
->u
.p
.max_pos
;
1171 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1172 ? 0 : dtp
->u
.p
.pending_spaces
;
1173 if (dtp
->u
.p
.skips
== 0)
1176 /* Adjust everything for end-of-record condition */
1177 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1179 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1180 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1182 dtp
->u
.p
.sf_seen_eor
= 0;
1184 if (dtp
->u
.p
.skips
< 0)
1186 if (is_internal_unit (dtp
))
1187 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1189 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1190 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1191 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1194 read_x (dtp
, dtp
->u
.p
.skips
);
1198 consume_data_flag
= 0;
1199 dtp
->u
.p
.sign_status
= SIGN_S
;
1203 consume_data_flag
= 0;
1204 dtp
->u
.p
.sign_status
= SIGN_SS
;
1208 consume_data_flag
= 0;
1209 dtp
->u
.p
.sign_status
= SIGN_SP
;
1213 consume_data_flag
= 0 ;
1214 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1218 consume_data_flag
= 0;
1219 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1223 consume_data_flag
= 0;
1224 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1228 consume_data_flag
= 0;
1229 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1233 consume_data_flag
= 0;
1234 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1238 consume_data_flag
= 0;
1239 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1243 consume_data_flag
= 0;
1244 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1248 consume_data_flag
= 0;
1249 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1253 consume_data_flag
= 0;
1254 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1258 consume_data_flag
= 0;
1259 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1263 consume_data_flag
= 0;
1264 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1268 consume_data_flag
= 0;
1269 dtp
->u
.p
.seen_dollar
= 1;
1273 consume_data_flag
= 0;
1274 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1275 next_record (dtp
, 0);
1279 /* A colon descriptor causes us to exit this loop (in
1280 particular preventing another / descriptor from being
1281 processed) unless there is another data item to be
1283 consume_data_flag
= 0;
1289 internal_error (&dtp
->common
, "Bad format node");
1292 /* Adjust the item count and data pointer. */
1294 if ((consume_data_flag
> 0) && (n
> 0))
1297 p
= ((char *) p
) + size
;
1302 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1303 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1308 /* Come here when we need a data descriptor but don't have one. We
1309 push the current format node back onto the input, then return and
1310 let the user program call us back with the data. */
1312 unget_format (dtp
, f
);
1317 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1320 int pos
, bytes_used
;
1324 int consume_data_flag
;
1326 /* Change a complex data item into a pair of reals. */
1328 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1329 if (type
== BT_COMPLEX
)
1335 /* If there's an EOR condition, we simulate finalizing the transfer
1336 by doing nothing. */
1337 if (dtp
->u
.p
.eor_condition
)
1340 /* Set this flag so that commas in reads cause the read to complete before
1341 the entire field has been read. The next read field will start right after
1342 the comma in the stream. (Set to 0 for character reads). */
1343 dtp
->u
.p
.sf_read_comma
=
1344 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1348 /* If reversion has occurred and there is another real data item,
1349 then we have to move to the next record. */
1350 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1352 dtp
->u
.p
.reversion_flag
= 0;
1353 next_record (dtp
, 0);
1356 consume_data_flag
= 1;
1357 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1360 f
= next_format (dtp
);
1363 /* No data descriptors left. */
1364 if (unlikely (n
> 0))
1365 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1366 "Insufficient data descriptors in format after reversion");
1370 /* Now discharge T, TR and X movements to the right. This is delayed
1371 until a data producing format to suppress trailing spaces. */
1374 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1375 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1376 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1377 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1378 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1379 || t
== FMT_STRING
))
1381 if (dtp
->u
.p
.skips
> 0)
1384 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1385 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1386 - dtp
->u
.p
.current_unit
->bytes_left
);
1388 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1390 if (dtp
->u
.p
.skips
< 0)
1392 if (is_internal_unit (dtp
))
1393 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1395 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1396 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1398 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1401 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1402 - dtp
->u
.p
.current_unit
->bytes_left
);
1404 if (is_stream_io(dtp
))
1412 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1414 write_i (dtp
, f
, p
, kind
);
1420 if (compile_options
.allow_std
< GFC_STD_GNU
1421 && require_type (dtp
, BT_INTEGER
, type
, f
))
1423 write_b (dtp
, f
, p
, kind
);
1429 if (compile_options
.allow_std
< GFC_STD_GNU
1430 && require_type (dtp
, BT_INTEGER
, type
, f
))
1432 write_o (dtp
, f
, p
, kind
);
1438 if (compile_options
.allow_std
< GFC_STD_GNU
1439 && require_type (dtp
, BT_INTEGER
, type
, f
))
1441 write_z (dtp
, f
, p
, kind
);
1448 /* It is possible to have FMT_A with something not BT_CHARACTER such
1449 as when writing out hollerith strings, so check both type
1450 and kind before calling wide character routines. */
1451 if (type
== BT_CHARACTER
&& kind
== 4)
1452 write_a_char4 (dtp
, f
, p
, size
);
1454 write_a (dtp
, f
, p
, size
);
1460 write_l (dtp
, f
, p
, kind
);
1466 if (require_type (dtp
, BT_REAL
, type
, f
))
1468 write_d (dtp
, f
, p
, kind
);
1474 if (require_type (dtp
, BT_REAL
, type
, f
))
1476 write_e (dtp
, f
, p
, kind
);
1482 if (require_type (dtp
, BT_REAL
, type
, f
))
1484 write_en (dtp
, f
, p
, kind
);
1490 if (require_type (dtp
, BT_REAL
, type
, f
))
1492 write_es (dtp
, f
, p
, kind
);
1498 if (require_type (dtp
, BT_REAL
, type
, f
))
1500 write_f (dtp
, f
, p
, kind
);
1509 write_i (dtp
, f
, p
, kind
);
1512 write_l (dtp
, f
, p
, kind
);
1516 write_a_char4 (dtp
, f
, p
, size
);
1518 write_a (dtp
, f
, p
, size
);
1521 if (f
->u
.real
.w
== 0)
1522 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1524 write_d (dtp
, f
, p
, kind
);
1527 internal_error (&dtp
->common
,
1528 "formatted_transfer(): Bad type");
1533 consume_data_flag
= 0;
1534 write_constant_string (dtp
, f
);
1537 /* Format codes that don't transfer data. */
1540 consume_data_flag
= 0;
1542 dtp
->u
.p
.skips
+= f
->u
.n
;
1543 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1544 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1545 /* Writes occur just before the switch on f->format, above, so
1546 that trailing blanks are suppressed, unless we are doing a
1547 non-advancing write in which case we want to output the blanks
1549 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1551 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1552 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1558 consume_data_flag
= 0;
1560 if (f
->format
== FMT_TL
)
1563 /* Handle the special case when no bytes have been used yet.
1564 Cannot go below zero. */
1565 if (bytes_used
== 0)
1567 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1568 dtp
->u
.p
.skips
-= f
->u
.n
;
1569 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1572 pos
= bytes_used
- f
->u
.n
;
1575 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1577 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1578 left tab limit. We do not check if the position has gone
1579 beyond the end of record because a subsequent tab could
1580 bring us back again. */
1581 pos
= pos
< 0 ? 0 : pos
;
1583 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1584 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1585 + pos
- dtp
->u
.p
.max_pos
;
1586 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1587 ? 0 : dtp
->u
.p
.pending_spaces
;
1591 consume_data_flag
= 0;
1592 dtp
->u
.p
.sign_status
= SIGN_S
;
1596 consume_data_flag
= 0;
1597 dtp
->u
.p
.sign_status
= SIGN_SS
;
1601 consume_data_flag
= 0;
1602 dtp
->u
.p
.sign_status
= SIGN_SP
;
1606 consume_data_flag
= 0 ;
1607 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1611 consume_data_flag
= 0;
1612 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1616 consume_data_flag
= 0;
1617 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1621 consume_data_flag
= 0;
1622 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1626 consume_data_flag
= 0;
1627 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1631 consume_data_flag
= 0;
1632 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1636 consume_data_flag
= 0;
1637 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1641 consume_data_flag
= 0;
1642 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1646 consume_data_flag
= 0;
1647 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1651 consume_data_flag
= 0;
1652 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1656 consume_data_flag
= 0;
1657 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1661 consume_data_flag
= 0;
1662 dtp
->u
.p
.seen_dollar
= 1;
1666 consume_data_flag
= 0;
1667 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1668 next_record (dtp
, 0);
1672 /* A colon descriptor causes us to exit this loop (in
1673 particular preventing another / descriptor from being
1674 processed) unless there is another data item to be
1676 consume_data_flag
= 0;
1682 internal_error (&dtp
->common
, "Bad format node");
1685 /* Adjust the item count and data pointer. */
1687 if ((consume_data_flag
> 0) && (n
> 0))
1690 p
= ((char *) p
) + size
;
1693 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1694 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1699 /* Come here when we need a data descriptor but don't have one. We
1700 push the current format node back onto the input, then return and
1701 let the user program call us back with the data. */
1703 unget_format (dtp
, f
);
1708 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1709 size_t size
, size_t nelems
)
1715 size_t stride
= type
== BT_CHARACTER
?
1716 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1717 if (dtp
->u
.p
.mode
== READING
)
1719 /* Big loop over all the elements. */
1720 for (elem
= 0; elem
< nelems
; elem
++)
1722 dtp
->u
.p
.item_count
++;
1723 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1728 /* Big loop over all the elements. */
1729 for (elem
= 0; elem
< nelems
; elem
++)
1731 dtp
->u
.p
.item_count
++;
1732 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1738 /* Data transfer entry points. The type of the data entity is
1739 implicit in the subroutine call. This prevents us from having to
1740 share a common enum with the compiler. */
1743 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1745 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1747 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1752 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1755 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1757 size
= size_from_real_kind (kind
);
1758 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1763 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1765 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1767 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1772 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1774 static char *empty_string
[0];
1776 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1779 /* Strings of zero length can have p == NULL, which confuses the
1780 transfer routines into thinking we need more data elements. To avoid
1781 this, we give them a nice pointer. */
1782 if (len
== 0 && p
== NULL
)
1785 /* Set kind here to 1. */
1786 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1790 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1792 static char *empty_string
[0];
1794 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1797 /* Strings of zero length can have p == NULL, which confuses the
1798 transfer routines into thinking we need more data elements. To avoid
1799 this, we give them a nice pointer. */
1800 if (len
== 0 && p
== NULL
)
1803 /* Here we pass the actual kind value. */
1804 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1809 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1812 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1814 size
= size_from_complex_kind (kind
);
1815 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1820 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1821 gfc_charlen_type charlen
)
1823 index_type count
[GFC_MAX_DIMENSIONS
];
1824 index_type extent
[GFC_MAX_DIMENSIONS
];
1825 index_type stride
[GFC_MAX_DIMENSIONS
];
1826 index_type stride0
, rank
, size
, type
, n
;
1831 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1834 type
= GFC_DESCRIPTOR_TYPE (desc
);
1835 size
= GFC_DESCRIPTOR_SIZE (desc
);
1837 /* FIXME: What a kludge: Array descriptors and the IO library use
1838 different enums for types. */
1841 case GFC_DTYPE_UNKNOWN
:
1842 iotype
= BT_NULL
; /* Is this correct? */
1844 case GFC_DTYPE_INTEGER
:
1845 iotype
= BT_INTEGER
;
1847 case GFC_DTYPE_LOGICAL
:
1848 iotype
= BT_LOGICAL
;
1850 case GFC_DTYPE_REAL
:
1853 case GFC_DTYPE_COMPLEX
:
1854 iotype
= BT_COMPLEX
;
1856 case GFC_DTYPE_CHARACTER
:
1857 iotype
= BT_CHARACTER
;
1860 case GFC_DTYPE_DERIVED
:
1861 internal_error (&dtp
->common
,
1862 "Derived type I/O should have been handled via the frontend.");
1865 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1868 rank
= GFC_DESCRIPTOR_RANK (desc
);
1869 for (n
= 0; n
< rank
; n
++)
1872 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
1873 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
1875 /* If the extent of even one dimension is zero, then the entire
1876 array section contains zero elements, so we return after writing
1877 a zero array record. */
1882 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1887 stride0
= stride
[0];
1889 /* If the innermost dimension has a stride of 1, we can do the transfer
1890 in contiguous chunks. */
1891 if (stride0
== size
)
1896 data
= GFC_DESCRIPTOR_DATA (desc
);
1900 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1901 data
+= stride0
* tsize
;
1904 while (count
[n
] == extent
[n
])
1907 data
-= stride
[n
] * extent
[n
];
1924 /* Preposition a sequential unformatted file while reading. */
1927 us_read (st_parameter_dt
*dtp
, int continued
)
1934 if (compile_options
.record_marker
== 0)
1935 n
= sizeof (GFC_INTEGER_4
);
1937 n
= compile_options
.record_marker
;
1939 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1940 if (unlikely (nr
< 0))
1942 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1948 return; /* end of file */
1950 else if (unlikely (n
!= nr
))
1952 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1956 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1957 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1961 case sizeof(GFC_INTEGER_4
):
1962 memcpy (&i4
, &i
, sizeof (i4
));
1966 case sizeof(GFC_INTEGER_8
):
1967 memcpy (&i8
, &i
, sizeof (i8
));
1972 runtime_error ("Illegal value for record marker");
1979 case sizeof(GFC_INTEGER_4
):
1980 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1984 case sizeof(GFC_INTEGER_8
):
1985 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1990 runtime_error ("Illegal value for record marker");
1996 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1997 dtp
->u
.p
.current_unit
->continued
= 0;
2001 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
2002 dtp
->u
.p
.current_unit
->continued
= 1;
2006 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2010 /* Preposition a sequential unformatted file while writing. This
2011 amount to writing a bogus length that will be filled in later. */
2014 us_write (st_parameter_dt
*dtp
, int continued
)
2021 if (compile_options
.record_marker
== 0)
2022 nbytes
= sizeof (GFC_INTEGER_4
);
2024 nbytes
= compile_options
.record_marker
;
2026 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2027 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2029 /* For sequential unformatted, if RECL= was not specified in the OPEN
2030 we write until we have more bytes than can fit in the subrecord
2031 markers, then we write a new subrecord. */
2033 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2034 dtp
->u
.p
.current_unit
->recl_subrecord
;
2035 dtp
->u
.p
.current_unit
->continued
= continued
;
2039 /* Position to the next record prior to transfer. We are assumed to
2040 be before the next record. We also calculate the bytes in the next
2044 pre_position (st_parameter_dt
*dtp
)
2046 if (dtp
->u
.p
.current_unit
->current_record
)
2047 return; /* Already positioned. */
2049 switch (current_mode (dtp
))
2051 case FORMATTED_STREAM
:
2052 case UNFORMATTED_STREAM
:
2053 /* There are no records with stream I/O. If the position was specified
2054 data_transfer_init has already positioned the file. If no position
2055 was specified, we continue from where we last left off. I.e.
2056 there is nothing to do here. */
2059 case UNFORMATTED_SEQUENTIAL
:
2060 if (dtp
->u
.p
.mode
== READING
)
2067 case FORMATTED_SEQUENTIAL
:
2068 case FORMATTED_DIRECT
:
2069 case UNFORMATTED_DIRECT
:
2070 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2074 dtp
->u
.p
.current_unit
->current_record
= 1;
2078 /* Initialize things for a data transfer. This code is common for
2079 both reading and writing. */
2082 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2084 unit_flags u_flags
; /* Used for creating a unit if needed. */
2085 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2086 namelist_info
*ionml
;
2088 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2090 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2092 dtp
->u
.p
.ionml
= ionml
;
2093 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2095 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2098 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2099 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2101 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2102 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2103 { /* Open the unit with some default flags. */
2104 st_parameter_open opp
;
2107 if (dtp
->common
.unit
< 0)
2109 close_unit (dtp
->u
.p
.current_unit
);
2110 dtp
->u
.p
.current_unit
= NULL
;
2111 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2112 "Bad unit number in statement");
2115 memset (&u_flags
, '\0', sizeof (u_flags
));
2116 u_flags
.access
= ACCESS_SEQUENTIAL
;
2117 u_flags
.action
= ACTION_READWRITE
;
2119 /* Is it unformatted? */
2120 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2121 | IOPARM_DT_IONML_SET
)))
2122 u_flags
.form
= FORM_UNFORMATTED
;
2124 u_flags
.form
= FORM_UNSPECIFIED
;
2126 u_flags
.delim
= DELIM_UNSPECIFIED
;
2127 u_flags
.blank
= BLANK_UNSPECIFIED
;
2128 u_flags
.pad
= PAD_UNSPECIFIED
;
2129 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2130 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2131 u_flags
.async
= ASYNC_UNSPECIFIED
;
2132 u_flags
.round
= ROUND_UNSPECIFIED
;
2133 u_flags
.sign
= SIGN_UNSPECIFIED
;
2135 u_flags
.status
= STATUS_UNKNOWN
;
2137 conv
= get_unformatted_convert (dtp
->common
.unit
);
2139 if (conv
== GFC_CONVERT_NONE
)
2140 conv
= compile_options
.convert
;
2142 /* We use big_endian, which is 0 on little-endian machines
2143 and 1 on big-endian machines. */
2146 case GFC_CONVERT_NATIVE
:
2147 case GFC_CONVERT_SWAP
:
2150 case GFC_CONVERT_BIG
:
2151 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2154 case GFC_CONVERT_LITTLE
:
2155 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2159 internal_error (&opp
.common
, "Illegal value for CONVERT");
2163 u_flags
.convert
= conv
;
2165 opp
.common
= dtp
->common
;
2166 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2167 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2168 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2169 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2170 if (dtp
->u
.p
.current_unit
== NULL
)
2174 /* Check the action. */
2176 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2178 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2179 "Cannot read from file opened for WRITE");
2183 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2185 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2186 "Cannot write to file opened for READ");
2190 dtp
->u
.p
.first_item
= 1;
2192 /* Check the format. */
2194 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2197 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2198 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2201 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2202 "Format present for UNFORMATTED data transfer");
2206 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2208 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2209 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2210 "A format cannot be specified with a namelist");
2212 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2213 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2215 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2216 "Missing format for FORMATTED data transfer");
2219 if (is_internal_unit (dtp
)
2220 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2222 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2223 "Internal file cannot be accessed by UNFORMATTED "
2228 /* Check the record or position number. */
2230 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2231 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2233 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2234 "Direct access data transfer requires record number");
2238 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2239 && (cf
& IOPARM_DT_HAS_REC
) != 0)
2241 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2242 "Record number not allowed for sequential access "
2247 /* Process the ADVANCE option. */
2249 dtp
->u
.p
.advance_status
2250 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2251 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2252 "Bad ADVANCE parameter in data transfer statement");
2254 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2256 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2258 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2259 "ADVANCE specification conflicts with sequential "
2264 if (is_internal_unit (dtp
))
2266 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2267 "ADVANCE specification conflicts with internal file");
2271 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2272 != IOPARM_DT_HAS_FORMAT
)
2274 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2275 "ADVANCE specification requires an explicit format");
2282 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2284 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2286 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2287 "EOR specification requires an ADVANCE specification "
2292 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2293 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2295 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2296 "SIZE specification requires an ADVANCE "
2297 "specification of NO");
2302 { /* Write constraints. */
2303 if ((cf
& IOPARM_END
) != 0)
2305 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2306 "END specification cannot appear in a write "
2311 if ((cf
& IOPARM_EOR
) != 0)
2313 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2314 "EOR specification cannot appear in a write "
2319 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2321 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2322 "SIZE specification cannot appear in a write "
2328 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2329 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2331 /* Check the decimal mode. */
2332 dtp
->u
.p
.current_unit
->decimal_status
2333 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2334 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2335 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2338 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2339 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2341 /* Check the round mode. */
2342 dtp
->u
.p
.current_unit
->round_status
2343 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2344 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2345 round_opt
, "Bad ROUND parameter in data transfer "
2348 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2349 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2351 /* Check the sign mode. */
2352 dtp
->u
.p
.sign_status
2353 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2354 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2355 "Bad SIGN parameter in data transfer statement");
2357 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2358 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2360 /* Check the blank mode. */
2361 dtp
->u
.p
.blank_status
2362 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2363 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2365 "Bad BLANK parameter in data transfer statement");
2367 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2368 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2370 /* Check the delim mode. */
2371 dtp
->u
.p
.current_unit
->delim_status
2372 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2373 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2374 delim_opt
, "Bad DELIM parameter in data transfer statement");
2376 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2377 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2379 /* Check the pad mode. */
2380 dtp
->u
.p
.current_unit
->pad_status
2381 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2382 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2383 "Bad PAD parameter in data transfer statement");
2385 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2386 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2388 /* Check to see if we might be reading what we wrote before */
2390 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2391 && !is_internal_unit (dtp
))
2393 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2395 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2396 sflush(dtp
->u
.p
.current_unit
->s
);
2399 /* Check the POS= specifier: that it is in range and that it is used with a
2400 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2402 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2404 if (is_stream_io (dtp
))
2409 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2410 "POS=specifier must be positive");
2414 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2416 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2417 "POS=specifier too large");
2421 dtp
->rec
= dtp
->pos
;
2423 if (dtp
->u
.p
.mode
== READING
)
2425 /* Reset the endfile flag; if we hit EOF during reading
2426 we'll set the flag and generate an error at that point
2427 rather than worrying about it here. */
2428 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2431 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2433 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2434 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2436 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2439 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2444 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2445 "POS=specifier not allowed, "
2446 "Try OPEN with ACCESS='stream'");
2452 /* Sanity checks on the record number. */
2453 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2457 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2458 "Record number must be positive");
2462 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2464 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2465 "Record number too large");
2469 /* Make sure format buffer is reset. */
2470 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2471 fbuf_reset (dtp
->u
.p
.current_unit
);
2474 /* Check whether the record exists to be read. Only
2475 a partial record needs to exist. */
2477 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2478 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2480 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2481 "Non-existing record number");
2485 /* Position the file. */
2486 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2487 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2489 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2493 /* TODO: This is required to maintain compatibility between
2494 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2496 if (is_stream_io (dtp
))
2497 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2499 /* TODO: Un-comment this code when ABI changes from 4.3.
2500 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2502 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2503 "Record number not allowed for stream access "
2509 /* Bugware for badly written mixed C-Fortran I/O. */
2510 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2512 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2514 /* Set the maximum position reached from the previous I/O operation. This
2515 could be greater than zero from a previous non-advancing write. */
2516 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2521 /* Set up the subroutine that will handle the transfers. */
2525 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2526 dtp
->u
.p
.transfer
= unformatted_read
;
2529 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2530 dtp
->u
.p
.transfer
= list_formatted_read
;
2532 dtp
->u
.p
.transfer
= formatted_transfer
;
2537 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2538 dtp
->u
.p
.transfer
= unformatted_write
;
2541 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2542 dtp
->u
.p
.transfer
= list_formatted_write
;
2544 dtp
->u
.p
.transfer
= formatted_transfer
;
2548 /* Make sure that we don't do a read after a nonadvancing write. */
2552 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2554 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2555 "Cannot READ after a nonadvancing WRITE");
2561 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2562 dtp
->u
.p
.current_unit
->read_bad
= 1;
2565 /* Start the data transfer if we are doing a formatted transfer. */
2566 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2567 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2568 && dtp
->u
.p
.ionml
== NULL
)
2569 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2572 /* Initialize an array_loop_spec given the array descriptor. The function
2573 returns the index of the last element of the array, and also returns
2574 starting record, where the first I/O goes to (necessary in case of
2575 negative strides). */
2578 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2579 gfc_offset
*start_record
)
2581 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2590 for (i
=0; i
<rank
; i
++)
2592 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2593 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2594 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2595 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2596 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2597 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2599 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2601 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2602 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2606 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2607 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2608 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2609 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2619 /* Determine the index to the next record in an internal unit array by
2620 by incrementing through the array_loop_spec. */
2623 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2631 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2636 if (ls
[i
].idx
> ls
[i
].end
)
2638 ls
[i
].idx
= ls
[i
].start
;
2644 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2654 /* Skip to the end of the current record, taking care of an optional
2655 record marker of size bytes. If the file is not seekable, we
2656 read chunks of size MAX_READ until we get to the right
2660 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2662 ssize_t rlength
, readb
;
2663 static const ssize_t MAX_READ
= 4096;
2666 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2667 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2670 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2672 /* Direct access files do not generate END conditions,
2674 if (sseek (dtp
->u
.p
.current_unit
->s
,
2675 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2676 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2678 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
2681 { /* Seek by reading data. */
2682 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2685 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2686 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2688 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2691 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2695 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2702 /* Advance to the next record reading unformatted files, taking
2703 care of subrecords. If complete_record is nonzero, we loop
2704 until all subrecords are cleared. */
2707 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2711 bytes
= compile_options
.record_marker
== 0 ?
2712 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2717 /* Skip over tail */
2719 skip_record (dtp
, bytes
);
2721 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2729 static inline gfc_offset
2730 min_off (gfc_offset a
, gfc_offset b
)
2732 return (a
< b
? a
: b
);
2736 /* Space to the next record for read mode. */
2739 next_record_r (st_parameter_dt
*dtp
)
2746 switch (current_mode (dtp
))
2748 /* No records in unformatted STREAM I/O. */
2749 case UNFORMATTED_STREAM
:
2752 case UNFORMATTED_SEQUENTIAL
:
2753 next_record_r_unf (dtp
, 1);
2754 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2757 case FORMATTED_DIRECT
:
2758 case UNFORMATTED_DIRECT
:
2759 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
2762 case FORMATTED_STREAM
:
2763 case FORMATTED_SEQUENTIAL
:
2764 /* read_sf has already terminated input because of an '\n', or
2766 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2768 dtp
->u
.p
.sf_seen_eor
= 0;
2769 dtp
->u
.p
.at_eof
= 0;
2773 if (is_internal_unit (dtp
))
2775 if (is_array_io (dtp
))
2779 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2782 /* Now seek to this record. */
2783 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2784 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2786 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2789 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2793 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2794 bytes_left
= min_off (bytes_left
,
2795 file_length (dtp
->u
.p
.current_unit
->s
)
2796 - stell (dtp
->u
.p
.current_unit
->s
));
2797 if (sseek (dtp
->u
.p
.current_unit
->s
,
2798 bytes_left
, SEEK_CUR
) < 0)
2800 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2803 dtp
->u
.p
.current_unit
->bytes_left
2804 = dtp
->u
.p
.current_unit
->recl
;
2813 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2817 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2823 if (is_stream_io (dtp
))
2824 dtp
->u
.p
.current_unit
->strm_pos
++;
2835 /* Small utility function to write a record marker, taking care of
2836 byte swapping and of choosing the correct size. */
2839 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2844 char p
[sizeof (GFC_INTEGER_8
)];
2846 if (compile_options
.record_marker
== 0)
2847 len
= sizeof (GFC_INTEGER_4
);
2849 len
= compile_options
.record_marker
;
2851 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2852 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2856 case sizeof (GFC_INTEGER_4
):
2858 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2861 case sizeof (GFC_INTEGER_8
):
2863 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2867 runtime_error ("Illegal value for record marker");
2875 case sizeof (GFC_INTEGER_4
):
2877 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2878 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2881 case sizeof (GFC_INTEGER_8
):
2883 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2884 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2888 runtime_error ("Illegal value for record marker");
2895 /* Position to the next (sub)record in write mode for
2896 unformatted sequential files. */
2899 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2901 gfc_offset m
, m_write
, record_marker
;
2903 /* Bytes written. */
2904 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2905 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2907 /* Write the length tail. If we finish a record containing
2908 subrecords, we write out the negative length. */
2910 if (dtp
->u
.p
.current_unit
->continued
)
2915 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2918 if (compile_options
.record_marker
== 0)
2919 record_marker
= sizeof (GFC_INTEGER_4
);
2921 record_marker
= compile_options
.record_marker
;
2923 /* Seek to the head and overwrite the bogus length with the real
2926 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2935 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2938 /* Seek past the end of the current record. */
2940 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2947 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2953 /* Utility function like memset() but operating on streams. Return
2954 value is same as for POSIX write(). */
2957 sset (stream
* s
, int c
, ssize_t nbyte
)
2959 static const int WRITE_CHUNK
= 256;
2960 char p
[WRITE_CHUNK
];
2961 ssize_t bytes_left
, trans
;
2963 if (nbyte
< WRITE_CHUNK
)
2964 memset (p
, c
, nbyte
);
2966 memset (p
, c
, WRITE_CHUNK
);
2969 while (bytes_left
> 0)
2971 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2972 trans
= swrite (s
, p
, trans
);
2975 bytes_left
-= trans
;
2978 return nbyte
- bytes_left
;
2981 /* Position to the next record in write mode. */
2984 next_record_w (st_parameter_dt
*dtp
, int done
)
2986 gfc_offset m
, record
, max_pos
;
2989 /* Zero counters for X- and T-editing. */
2990 max_pos
= dtp
->u
.p
.max_pos
;
2991 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2993 switch (current_mode (dtp
))
2995 /* No records in unformatted STREAM I/O. */
2996 case UNFORMATTED_STREAM
:
2999 case FORMATTED_DIRECT
:
3000 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
3003 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3004 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3005 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3006 dtp
->u
.p
.current_unit
->bytes_left
)
3007 != dtp
->u
.p
.current_unit
->bytes_left
)
3012 case UNFORMATTED_DIRECT
:
3013 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3015 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3016 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3021 case UNFORMATTED_SEQUENTIAL
:
3022 next_record_w_unf (dtp
, 0);
3023 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3026 case FORMATTED_STREAM
:
3027 case FORMATTED_SEQUENTIAL
:
3029 if (is_internal_unit (dtp
))
3031 if (is_array_io (dtp
))
3035 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3037 /* If the farthest position reached is greater than current
3038 position, adjust the position and set length to pad out
3039 whats left. Otherwise just pad whats left.
3040 (for character array unit) */
3041 m
= dtp
->u
.p
.current_unit
->recl
3042 - dtp
->u
.p
.current_unit
->bytes_left
;
3045 length
= (int) (max_pos
- m
);
3046 if (sseek (dtp
->u
.p
.current_unit
->s
,
3047 length
, SEEK_CUR
) < 0)
3049 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3052 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3055 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3057 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3061 /* Now that the current record has been padded out,
3062 determine where the next record in the array is. */
3063 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3066 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3068 /* Now seek to this record */
3069 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3071 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3073 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3077 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3083 /* If this is the last call to next_record move to the farthest
3084 position reached and set length to pad out the remainder
3085 of the record. (for character scaler unit) */
3088 m
= dtp
->u
.p
.current_unit
->recl
3089 - dtp
->u
.p
.current_unit
->bytes_left
;
3092 length
= (int) (max_pos
- m
);
3093 if (sseek (dtp
->u
.p
.current_unit
->s
,
3094 length
, SEEK_CUR
) < 0)
3096 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3099 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3102 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3105 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3107 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3119 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3120 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3127 if (is_stream_io (dtp
))
3129 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3130 if (dtp
->u
.p
.current_unit
->strm_pos
3131 < file_length (dtp
->u
.p
.current_unit
->s
))
3132 unit_truncate (dtp
->u
.p
.current_unit
,
3133 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3141 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3146 /* Position to the next record, which means moving to the end of the
3147 current record. This can happen under several different
3148 conditions. If the done flag is not set, we get ready to process
3152 next_record (st_parameter_dt
*dtp
, int done
)
3154 gfc_offset fp
; /* File position. */
3156 dtp
->u
.p
.current_unit
->read_bad
= 0;
3158 if (dtp
->u
.p
.mode
== READING
)
3159 next_record_r (dtp
);
3161 next_record_w (dtp
, done
);
3163 if (!is_stream_io (dtp
))
3165 /* Keep position up to date for INQUIRE */
3167 update_position (dtp
->u
.p
.current_unit
);
3169 dtp
->u
.p
.current_unit
->current_record
= 0;
3170 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3172 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3173 /* Calculate next record, rounding up partial records. */
3174 dtp
->u
.p
.current_unit
->last_record
=
3175 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3176 dtp
->u
.p
.current_unit
->recl
;
3179 dtp
->u
.p
.current_unit
->last_record
++;
3185 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3189 /* Finalize the current data transfer. For a nonadvancing transfer,
3190 this means advancing to the next record. For internal units close the
3191 stream associated with the unit. */
3194 finalize_transfer (st_parameter_dt
*dtp
)
3197 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3199 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3200 *dtp
->size
= dtp
->u
.p
.size_used
;
3202 if (dtp
->u
.p
.eor_condition
)
3204 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3208 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3210 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3211 dtp
->u
.p
.current_unit
->current_record
= 0;
3215 if ((dtp
->u
.p
.ionml
!= NULL
)
3216 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3218 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3219 namelist_read (dtp
);
3221 namelist_write (dtp
);
3224 dtp
->u
.p
.transfer
= NULL
;
3225 if (dtp
->u
.p
.current_unit
== NULL
)
3228 dtp
->u
.p
.eof_jump
= &eof_jump
;
3229 if (setjmp (eof_jump
))
3231 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3235 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3237 finish_list_read (dtp
);
3241 if (dtp
->u
.p
.mode
== WRITING
)
3242 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3243 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3245 if (is_stream_io (dtp
))
3247 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3248 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3249 next_record (dtp
, 1);
3254 dtp
->u
.p
.current_unit
->current_record
= 0;
3256 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3258 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3259 dtp
->u
.p
.seen_dollar
= 0;
3263 /* For non-advancing I/O, save the current maximum position for use in the
3264 next I/O operation if needed. */
3265 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3267 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3268 - dtp
->u
.p
.current_unit
->bytes_left
);
3269 dtp
->u
.p
.current_unit
->saved_pos
=
3270 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3271 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3274 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3275 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3276 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3278 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3280 next_record (dtp
, 1);
3283 /* Transfer function for IOLENGTH. It doesn't actually do any
3284 data transfer, it just updates the length counter. */
3287 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3288 void *dest
__attribute__ ((unused
)),
3289 int kind
__attribute__((unused
)),
3290 size_t size
, size_t nelems
)
3292 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3293 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3297 /* Initialize the IOLENGTH data transfer. This function is in essence
3298 a very much simplified version of data_transfer_init(), because it
3299 doesn't have to deal with units at all. */
3302 iolength_transfer_init (st_parameter_dt
*dtp
)
3304 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3307 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3309 /* Set up the subroutine that will handle the transfers. */
3311 dtp
->u
.p
.transfer
= iolength_transfer
;
3315 /* Library entry point for the IOLENGTH form of the INQUIRE
3316 statement. The IOLENGTH form requires no I/O to be performed, but
3317 it must still be a runtime library call so that we can determine
3318 the iolength for dynamic arrays and such. */
3320 extern void st_iolength (st_parameter_dt
*);
3321 export_proto(st_iolength
);
3324 st_iolength (st_parameter_dt
*dtp
)
3326 library_start (&dtp
->common
);
3327 iolength_transfer_init (dtp
);
3330 extern void st_iolength_done (st_parameter_dt
*);
3331 export_proto(st_iolength_done
);
3334 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3341 /* The READ statement. */
3343 extern void st_read (st_parameter_dt
*);
3344 export_proto(st_read
);
3347 st_read (st_parameter_dt
*dtp
)
3349 library_start (&dtp
->common
);
3351 data_transfer_init (dtp
, 1);
3354 extern void st_read_done (st_parameter_dt
*);
3355 export_proto(st_read_done
);
3358 st_read_done (st_parameter_dt
*dtp
)
3360 finalize_transfer (dtp
);
3361 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3362 free_format_data (dtp
->u
.p
.fmt
);
3364 if (dtp
->u
.p
.current_unit
!= NULL
)
3365 unlock_unit (dtp
->u
.p
.current_unit
);
3367 free_internal_unit (dtp
);
3372 extern void st_write (st_parameter_dt
*);
3373 export_proto(st_write
);
3376 st_write (st_parameter_dt
*dtp
)
3378 library_start (&dtp
->common
);
3379 data_transfer_init (dtp
, 0);
3382 extern void st_write_done (st_parameter_dt
*);
3383 export_proto(st_write_done
);
3386 st_write_done (st_parameter_dt
*dtp
)
3388 finalize_transfer (dtp
);
3390 /* Deal with endfile conditions associated with sequential files. */
3392 if (dtp
->u
.p
.current_unit
!= NULL
3393 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3394 switch (dtp
->u
.p
.current_unit
->endfile
)
3396 case AT_ENDFILE
: /* Remain at the endfile record. */
3400 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3404 /* Get rid of whatever is after this record. */
3405 if (!is_internal_unit (dtp
))
3406 unit_truncate (dtp
->u
.p
.current_unit
,
3407 stell (dtp
->u
.p
.current_unit
->s
),
3409 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3413 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3414 free_format_data (dtp
->u
.p
.fmt
);
3416 if (dtp
->u
.p
.current_unit
!= NULL
)
3417 unlock_unit (dtp
->u
.p
.current_unit
);
3419 free_internal_unit (dtp
);
3425 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3427 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3432 /* Receives the scalar information for namelist objects and stores it
3433 in a linked list of namelist_info types. */
3435 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3436 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3437 export_proto(st_set_nml_var
);
3441 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3442 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3443 GFC_INTEGER_4 dtype
)
3445 namelist_info
*t1
= NULL
;
3447 size_t var_name_len
= strlen (var_name
);
3449 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3451 nml
->mem_pos
= var_addr
;
3453 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3454 memcpy (nml
->var_name
, var_name
, var_name_len
);
3455 nml
->var_name
[var_name_len
] = '\0';
3457 nml
->len
= (int) len
;
3458 nml
->string_length
= (index_type
) string_length
;
3460 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3461 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3462 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3464 if (nml
->var_rank
> 0)
3466 nml
->dim
= (descriptor_dimension
*)
3467 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3468 nml
->ls
= (array_loop_spec
*)
3469 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3479 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3481 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3482 dtp
->u
.p
.ionml
= nml
;
3486 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3491 /* Store the dimensional information for the namelist object. */
3492 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3493 index_type
, index_type
,
3495 export_proto(st_set_nml_var_dim
);
3498 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3499 index_type stride
, index_type lbound
,
3502 namelist_info
* nml
;
3507 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3509 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3512 /* Reverse memcpy - used for byte swapping. */
3514 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3520 s
= (char *) src
+ n
- 1;
3522 /* Write with ascending order - this is likely faster
3523 on modern architectures because of write combining. */
3529 /* Once upon a time, a poor innocent Fortran program was reading a
3530 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3531 the OS doesn't tell whether we're at the EOF or whether we already
3532 went past it. Luckily our hero, libgfortran, keeps track of this.
3533 Call this function when you detect an EOF condition. See Section
3537 hit_eof (st_parameter_dt
* dtp
)
3539 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3541 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3542 switch (dtp
->u
.p
.current_unit
->endfile
)
3546 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3547 if (!is_internal_unit (dtp
))
3549 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3550 dtp
->u
.p
.current_unit
->current_record
= 0;
3553 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3557 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3558 dtp
->u
.p
.current_unit
->current_record
= 0;
3563 /* Non-sequential files don't have an ENDFILE record, so we
3564 can't be at AFTER_ENDFILE. */
3565 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3566 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3567 dtp
->u
.p
.current_unit
->current_record
= 0;