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
)
197 static char *empty_string
[0];
199 int n
, lorig
, memread
, seen_comma
;
201 /* If we have seen an eor previously, return a length of 0. The
202 caller is responsible for correctly padding the input field. */
203 if (dtp
->u
.p
.sf_seen_eor
)
206 /* Just return something that isn't a NULL pointer, otherwise the
207 caller thinks an error occured. */
208 return (char*) empty_string
;
211 if (is_internal_unit (dtp
))
214 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
215 if (unlikely (memread
> *length
))
226 /* Read data into format buffer and scan through it. */
228 base
= p
= fbuf_read (dtp
->u
.p
.current_unit
, length
);
236 if (q
== '\n' || q
== '\r')
238 /* Unexpected end of line. Set the position. */
239 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ 1 ,SEEK_CUR
);
240 dtp
->u
.p
.sf_seen_eor
= 1;
242 /* If we see an EOR during non-advancing I/O, we need to skip
243 the rest of the I/O statement. Set the corresponding flag. */
244 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
245 dtp
->u
.p
.eor_condition
= 1;
247 /* If we encounter a CR, it might be a CRLF. */
248 if (q
== '\r') /* Probably a CRLF */
250 /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
251 the position is not advanced unless it really is an LF. */
253 p
= fbuf_read (dtp
->u
.p
.current_unit
, &readlen
);
254 if (*p
== '\n' && readlen
== 1)
256 dtp
->u
.p
.sf_seen_eor
= 2;
257 fbuf_seek (dtp
->u
.p
.current_unit
, 1 ,SEEK_CUR
);
261 /* Without padding, terminate the I/O statement without assigning
262 the value. With padding, the value still needs to be assigned,
263 so we can just continue with a short read. */
264 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
266 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
273 /* Short circuit the read if a comma is found during numeric input.
274 The flag is set to zero during character reads so that commas in
275 strings are not ignored */
277 if (dtp
->u
.p
.sf_read_comma
== 1)
280 notify_std (&dtp
->common
, GFC_STD_GNU
,
281 "Comma in formatted numeric read.");
289 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ seen_comma
, SEEK_CUR
);
291 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
292 some other stuff. Set the relevant flags. */
293 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
297 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
299 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
305 dtp
->u
.p
.eor_condition
= 1;
319 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
321 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
322 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
328 /* Function for reading the next couple of bytes from the current
329 file, advancing the current position. We return FAILURE on end of record or
330 end of file. This function is only for formatted I/O, unformatted uses
333 If the read is short, then it is because the current record does not
334 have enough data to satisfy the read request and the file was
335 opened with PAD=YES. The caller must assume tailing spaces for
339 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
344 if (!is_stream_io (dtp
))
346 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
348 /* For preconnected units with default record length, set bytes left
349 to unit record length and proceed, otherwise error. */
350 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
351 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
352 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
355 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
357 /* Not enough data left. */
358 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
363 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
369 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
373 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
374 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
375 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
377 source
= read_sf (dtp
, nbytes
);
378 dtp
->u
.p
.current_unit
->strm_pos
+=
379 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
383 /* If we reach here, we can assume it's direct access. */
385 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
388 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
389 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
391 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
392 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
394 if (norig
!= *nbytes
)
396 /* Short read, this shouldn't happen. */
397 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
399 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
404 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
410 /* Reads a block directly into application data space. This is for
411 unformatted files. */
414 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
416 ssize_t to_read_record
;
417 ssize_t have_read_record
;
418 ssize_t to_read_subrecord
;
419 ssize_t have_read_subrecord
;
422 if (is_stream_io (dtp
))
424 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
426 if (unlikely (have_read_record
< 0))
428 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
432 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
434 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
436 /* Short read, e.g. if we hit EOF. For stream files,
437 we have to set the end-of-file condition. */
443 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
445 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
448 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
449 nbytes
= to_read_record
;
454 to_read_record
= nbytes
;
457 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
459 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
460 if (unlikely (to_read_record
< 0))
462 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
466 if (to_read_record
!= (ssize_t
) nbytes
)
468 /* Short read, e.g. if we hit EOF. Apparently, we read
469 more than was written to the last record. */
473 if (unlikely (short_record
))
475 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
480 /* Unformatted sequential. We loop over the subrecords, reading
481 until the request has been fulfilled or the record has run out
482 of continuation subrecords. */
484 /* Check whether we exceed the total record length. */
486 if (dtp
->u
.p
.current_unit
->flags
.has_recl
487 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
489 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
494 to_read_record
= nbytes
;
497 have_read_record
= 0;
501 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
502 < (gfc_offset
) to_read_record
)
504 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
505 to_read_record
-= to_read_subrecord
;
509 to_read_subrecord
= to_read_record
;
513 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
515 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
516 buf
+ have_read_record
, to_read_subrecord
);
517 if (unlikely (have_read_subrecord
) < 0)
519 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
523 have_read_record
+= have_read_subrecord
;
525 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
528 /* Short read, e.g. if we hit EOF. This means the record
529 structure has been corrupted, or the trailing record
530 marker would still be present. */
532 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
536 if (to_read_record
> 0)
538 if (likely (dtp
->u
.p
.current_unit
->continued
))
540 next_record_r_unf (dtp
, 0);
545 /* Let's make sure the file position is correctly pre-positioned
546 for the next read statement. */
548 dtp
->u
.p
.current_unit
->current_record
= 0;
549 next_record_r_unf (dtp
, 0);
550 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
556 /* Normal exit, the read request has been fulfilled. */
561 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
562 if (unlikely (short_record
))
564 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
571 /* Function for writing a block of bytes to the current file at the
572 current position, advancing the file pointer. We are given a length
573 and return a pointer to a buffer that the caller must (completely)
574 fill in. Returns NULL on error. */
577 write_block (st_parameter_dt
*dtp
, int length
)
581 if (!is_stream_io (dtp
))
583 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
585 /* For preconnected units with default record length, set bytes left
586 to unit record length and proceed, otherwise error. */
587 if (likely ((dtp
->u
.p
.current_unit
->unit_number
588 == options
.stdout_unit
589 || dtp
->u
.p
.current_unit
->unit_number
590 == options
.stderr_unit
)
591 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
592 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
595 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
600 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
603 if (is_internal_unit (dtp
))
605 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
609 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
613 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
614 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
618 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
621 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
626 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
627 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
629 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
635 /* High level interface to swrite(), taking care of errors. This is only
636 called for unformatted files. There are three cases to consider:
637 Stream I/O, unformatted direct, unformatted sequential. */
640 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
643 ssize_t have_written
;
644 ssize_t to_write_subrecord
;
649 if (is_stream_io (dtp
))
651 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
652 if (unlikely (have_written
< 0))
654 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
658 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
663 /* Unformatted direct access. */
665 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
667 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
669 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
673 if (buf
== NULL
&& nbytes
== 0)
676 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
677 if (unlikely (have_written
< 0))
679 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
683 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
684 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
689 /* Unformatted sequential. */
693 if (dtp
->u
.p
.current_unit
->flags
.has_recl
694 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
696 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
708 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
709 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
711 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
712 (gfc_offset
) to_write_subrecord
;
714 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
715 buf
+ have_written
, to_write_subrecord
);
716 if (unlikely (to_write_subrecord
< 0))
718 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
722 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
723 nbytes
-= to_write_subrecord
;
724 have_written
+= to_write_subrecord
;
729 next_record_w_unf (dtp
, 1);
732 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
733 if (unlikely (short_record
))
735 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
742 /* Master function for unformatted reads. */
745 unformatted_read (st_parameter_dt
*dtp
, bt type
,
746 void *dest
, int kind
, size_t size
, size_t nelems
)
748 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
751 if (type
== BT_CHARACTER
)
752 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
753 read_block_direct (dtp
, dest
, size
* nelems
);
763 /* Handle wide chracters. */
764 if (type
== BT_CHARACTER
&& kind
!= 1)
770 /* Break up complex into its constituent reals. */
771 if (type
== BT_COMPLEX
)
777 /* By now, all complex variables have been split into their
778 constituent reals. */
780 for (i
= 0; i
< nelems
; i
++)
782 read_block_direct (dtp
, buffer
, size
);
783 reverse_memcpy (p
, buffer
, size
);
790 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
791 bytes on 64 bit machines. The unused bytes are not initialized and never
792 used, which can show an error with memory checking analyzers like
796 unformatted_write (st_parameter_dt
*dtp
, bt type
,
797 void *source
, int kind
, size_t size
, size_t nelems
)
799 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
802 size_t stride
= type
== BT_CHARACTER
?
803 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
805 write_buf (dtp
, source
, stride
* nelems
);
815 /* Handle wide chracters. */
816 if (type
== BT_CHARACTER
&& kind
!= 1)
822 /* Break up complex into its constituent reals. */
823 if (type
== BT_COMPLEX
)
829 /* By now, all complex variables have been split into their
830 constituent reals. */
832 for (i
= 0; i
< nelems
; i
++)
834 reverse_memcpy(buffer
, p
, size
);
836 write_buf (dtp
, buffer
, size
);
842 /* Return a pointer to the name of a type. */
867 internal_error (NULL
, "type_name(): Bad type");
874 /* Write a constant string to the output.
875 This is complicated because the string can have doubled delimiters
876 in it. The length in the format node is the true length. */
879 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
881 char c
, delimiter
, *p
, *q
;
884 length
= f
->u
.string
.length
;
888 p
= write_block (dtp
, length
);
895 for (; length
> 0; length
--)
898 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
899 q
++; /* Skip the doubled delimiter. */
904 /* Given actual and expected types in a formatted data transfer, make
905 sure they agree. If not, an error message is generated. Returns
906 nonzero if something went wrong. */
909 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
913 if (actual
== expected
)
916 /* Adjust item_count before emitting error message. */
917 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
918 type_name (expected
), dtp
->u
.p
.item_count
- 1, type_name (actual
));
920 format_error (dtp
, f
, buffer
);
925 /* This function is in the main loop for a formatted data transfer
926 statement. It would be natural to implement this as a coroutine
927 with the user program, but C makes that awkward. We loop,
928 processing format elements. When we actually have to transfer
929 data instead of just setting flags, we return control to the user
930 program which calls a function that supplies the address and type
931 of the next element, then comes back here to process it. */
934 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
941 int consume_data_flag
;
943 /* Change a complex data item into a pair of reals. */
945 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
946 if (type
== BT_COMPLEX
)
952 /* If there's an EOR condition, we simulate finalizing the transfer
954 if (dtp
->u
.p
.eor_condition
)
957 /* Set this flag so that commas in reads cause the read to complete before
958 the entire field has been read. The next read field will start right after
959 the comma in the stream. (Set to 0 for character reads). */
960 dtp
->u
.p
.sf_read_comma
=
961 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
965 /* If reversion has occurred and there is another real data item,
966 then we have to move to the next record. */
967 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
969 dtp
->u
.p
.reversion_flag
= 0;
970 next_record (dtp
, 0);
973 consume_data_flag
= 1;
974 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
977 f
= next_format (dtp
);
980 /* No data descriptors left. */
981 if (unlikely (n
> 0))
982 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
983 "Insufficient data descriptors in format after reversion");
989 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
990 - dtp
->u
.p
.current_unit
->bytes_left
);
992 if (is_stream_io(dtp
))
1000 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1002 read_decimal (dtp
, f
, p
, kind
);
1007 goto need_read_data
;
1008 if (compile_options
.allow_std
< GFC_STD_GNU
1009 && require_type (dtp
, BT_INTEGER
, type
, f
))
1011 read_radix (dtp
, f
, p
, kind
, 2);
1016 goto need_read_data
;
1017 if (compile_options
.allow_std
< GFC_STD_GNU
1018 && require_type (dtp
, BT_INTEGER
, type
, f
))
1020 read_radix (dtp
, f
, p
, kind
, 8);
1025 goto need_read_data
;
1026 if (compile_options
.allow_std
< GFC_STD_GNU
1027 && require_type (dtp
, BT_INTEGER
, type
, f
))
1029 read_radix (dtp
, f
, p
, kind
, 16);
1034 goto need_read_data
;
1036 /* It is possible to have FMT_A with something not BT_CHARACTER such
1037 as when writing out hollerith strings, so check both type
1038 and kind before calling wide character routines. */
1039 if (type
== BT_CHARACTER
&& kind
== 4)
1040 read_a_char4 (dtp
, f
, p
, size
);
1042 read_a (dtp
, f
, p
, size
);
1047 goto need_read_data
;
1048 read_l (dtp
, f
, p
, kind
);
1053 goto need_read_data
;
1054 if (require_type (dtp
, BT_REAL
, type
, f
))
1056 read_f (dtp
, f
, p
, kind
);
1061 goto need_read_data
;
1062 if (require_type (dtp
, BT_REAL
, type
, f
))
1064 read_f (dtp
, f
, p
, kind
);
1069 goto need_read_data
;
1070 if (require_type (dtp
, BT_REAL
, type
, f
))
1072 read_f (dtp
, f
, p
, kind
);
1077 goto need_read_data
;
1078 if (require_type (dtp
, BT_REAL
, type
, f
))
1080 read_f (dtp
, f
, p
, kind
);
1085 goto need_read_data
;
1086 if (require_type (dtp
, BT_REAL
, type
, f
))
1088 read_f (dtp
, f
, p
, kind
);
1093 goto need_read_data
;
1097 read_decimal (dtp
, f
, p
, kind
);
1100 read_l (dtp
, f
, p
, kind
);
1104 read_a_char4 (dtp
, f
, p
, size
);
1106 read_a (dtp
, f
, p
, size
);
1109 read_f (dtp
, f
, p
, kind
);
1112 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1117 consume_data_flag
= 0;
1118 format_error (dtp
, f
, "Constant string in input format");
1121 /* Format codes that don't transfer data. */
1124 consume_data_flag
= 0;
1125 dtp
->u
.p
.skips
+= f
->u
.n
;
1126 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1127 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1128 read_x (dtp
, f
->u
.n
);
1133 consume_data_flag
= 0;
1135 if (f
->format
== FMT_TL
)
1137 /* Handle the special case when no bytes have been used yet.
1138 Cannot go below zero. */
1139 if (bytes_used
== 0)
1141 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1142 dtp
->u
.p
.skips
-= f
->u
.n
;
1143 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1146 pos
= bytes_used
- f
->u
.n
;
1151 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1152 left tab limit. We do not check if the position has gone
1153 beyond the end of record because a subsequent tab could
1154 bring us back again. */
1155 pos
= pos
< 0 ? 0 : pos
;
1157 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1158 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1159 + pos
- dtp
->u
.p
.max_pos
;
1160 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1161 ? 0 : dtp
->u
.p
.pending_spaces
;
1162 if (dtp
->u
.p
.skips
== 0)
1165 /* Adjust everything for end-of-record condition */
1166 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1168 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1169 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1171 dtp
->u
.p
.sf_seen_eor
= 0;
1173 if (dtp
->u
.p
.skips
< 0)
1175 if (is_internal_unit (dtp
))
1176 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1178 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1179 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1180 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1183 read_x (dtp
, dtp
->u
.p
.skips
);
1187 consume_data_flag
= 0;
1188 dtp
->u
.p
.sign_status
= SIGN_S
;
1192 consume_data_flag
= 0;
1193 dtp
->u
.p
.sign_status
= SIGN_SS
;
1197 consume_data_flag
= 0;
1198 dtp
->u
.p
.sign_status
= SIGN_SP
;
1202 consume_data_flag
= 0 ;
1203 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1207 consume_data_flag
= 0;
1208 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1212 consume_data_flag
= 0;
1213 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1217 consume_data_flag
= 0;
1218 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1222 consume_data_flag
= 0;
1223 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1227 consume_data_flag
= 0;
1228 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1232 consume_data_flag
= 0;
1233 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1237 consume_data_flag
= 0;
1238 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1242 consume_data_flag
= 0;
1243 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1247 consume_data_flag
= 0;
1248 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1252 consume_data_flag
= 0;
1253 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1257 consume_data_flag
= 0;
1258 dtp
->u
.p
.seen_dollar
= 1;
1262 consume_data_flag
= 0;
1263 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1264 next_record (dtp
, 0);
1268 /* A colon descriptor causes us to exit this loop (in
1269 particular preventing another / descriptor from being
1270 processed) unless there is another data item to be
1272 consume_data_flag
= 0;
1278 internal_error (&dtp
->common
, "Bad format node");
1281 /* Adjust the item count and data pointer. */
1283 if ((consume_data_flag
> 0) && (n
> 0))
1286 p
= ((char *) p
) + size
;
1291 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1292 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1297 /* Come here when we need a data descriptor but don't have one. We
1298 push the current format node back onto the input, then return and
1299 let the user program call us back with the data. */
1301 unget_format (dtp
, f
);
1306 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1309 int pos
, bytes_used
;
1313 int consume_data_flag
;
1315 /* Change a complex data item into a pair of reals. */
1317 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1318 if (type
== BT_COMPLEX
)
1324 /* If there's an EOR condition, we simulate finalizing the transfer
1325 by doing nothing. */
1326 if (dtp
->u
.p
.eor_condition
)
1329 /* Set this flag so that commas in reads cause the read to complete before
1330 the entire field has been read. The next read field will start right after
1331 the comma in the stream. (Set to 0 for character reads). */
1332 dtp
->u
.p
.sf_read_comma
=
1333 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1337 /* If reversion has occurred and there is another real data item,
1338 then we have to move to the next record. */
1339 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1341 dtp
->u
.p
.reversion_flag
= 0;
1342 next_record (dtp
, 0);
1345 consume_data_flag
= 1;
1346 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1349 f
= next_format (dtp
);
1352 /* No data descriptors left. */
1353 if (unlikely (n
> 0))
1354 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1355 "Insufficient data descriptors in format after reversion");
1359 /* Now discharge T, TR and X movements to the right. This is delayed
1360 until a data producing format to suppress trailing spaces. */
1363 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1364 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1365 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1366 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1367 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1368 || t
== FMT_STRING
))
1370 if (dtp
->u
.p
.skips
> 0)
1373 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1374 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1375 - dtp
->u
.p
.current_unit
->bytes_left
);
1377 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1379 if (dtp
->u
.p
.skips
< 0)
1381 if (is_internal_unit (dtp
))
1382 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1384 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1385 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1387 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1390 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1391 - dtp
->u
.p
.current_unit
->bytes_left
);
1393 if (is_stream_io(dtp
))
1401 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1403 write_i (dtp
, f
, p
, kind
);
1409 if (compile_options
.allow_std
< GFC_STD_GNU
1410 && require_type (dtp
, BT_INTEGER
, type
, f
))
1412 write_b (dtp
, f
, p
, kind
);
1418 if (compile_options
.allow_std
< GFC_STD_GNU
1419 && require_type (dtp
, BT_INTEGER
, type
, f
))
1421 write_o (dtp
, f
, p
, kind
);
1427 if (compile_options
.allow_std
< GFC_STD_GNU
1428 && require_type (dtp
, BT_INTEGER
, type
, f
))
1430 write_z (dtp
, f
, p
, kind
);
1437 /* It is possible to have FMT_A with something not BT_CHARACTER such
1438 as when writing out hollerith strings, so check both type
1439 and kind before calling wide character routines. */
1440 if (type
== BT_CHARACTER
&& kind
== 4)
1441 write_a_char4 (dtp
, f
, p
, size
);
1443 write_a (dtp
, f
, p
, size
);
1449 write_l (dtp
, f
, p
, kind
);
1455 if (require_type (dtp
, BT_REAL
, type
, f
))
1457 write_d (dtp
, f
, p
, kind
);
1463 if (require_type (dtp
, BT_REAL
, type
, f
))
1465 write_e (dtp
, f
, p
, kind
);
1471 if (require_type (dtp
, BT_REAL
, type
, f
))
1473 write_en (dtp
, f
, p
, kind
);
1479 if (require_type (dtp
, BT_REAL
, type
, f
))
1481 write_es (dtp
, f
, p
, kind
);
1487 if (require_type (dtp
, BT_REAL
, type
, f
))
1489 write_f (dtp
, f
, p
, kind
);
1498 write_i (dtp
, f
, p
, kind
);
1501 write_l (dtp
, f
, p
, kind
);
1505 write_a_char4 (dtp
, f
, p
, size
);
1507 write_a (dtp
, f
, p
, size
);
1510 if (f
->u
.real
.w
== 0)
1511 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1513 write_d (dtp
, f
, p
, kind
);
1516 internal_error (&dtp
->common
,
1517 "formatted_transfer(): Bad type");
1522 consume_data_flag
= 0;
1523 write_constant_string (dtp
, f
);
1526 /* Format codes that don't transfer data. */
1529 consume_data_flag
= 0;
1531 dtp
->u
.p
.skips
+= f
->u
.n
;
1532 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1533 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1534 /* Writes occur just before the switch on f->format, above, so
1535 that trailing blanks are suppressed, unless we are doing a
1536 non-advancing write in which case we want to output the blanks
1538 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1540 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1541 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1547 consume_data_flag
= 0;
1549 if (f
->format
== FMT_TL
)
1552 /* Handle the special case when no bytes have been used yet.
1553 Cannot go below zero. */
1554 if (bytes_used
== 0)
1556 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1557 dtp
->u
.p
.skips
-= f
->u
.n
;
1558 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1561 pos
= bytes_used
- f
->u
.n
;
1564 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1566 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1567 left tab limit. We do not check if the position has gone
1568 beyond the end of record because a subsequent tab could
1569 bring us back again. */
1570 pos
= pos
< 0 ? 0 : pos
;
1572 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1573 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1574 + pos
- dtp
->u
.p
.max_pos
;
1575 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1576 ? 0 : dtp
->u
.p
.pending_spaces
;
1580 consume_data_flag
= 0;
1581 dtp
->u
.p
.sign_status
= SIGN_S
;
1585 consume_data_flag
= 0;
1586 dtp
->u
.p
.sign_status
= SIGN_SS
;
1590 consume_data_flag
= 0;
1591 dtp
->u
.p
.sign_status
= SIGN_SP
;
1595 consume_data_flag
= 0 ;
1596 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1600 consume_data_flag
= 0;
1601 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1605 consume_data_flag
= 0;
1606 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1610 consume_data_flag
= 0;
1611 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1615 consume_data_flag
= 0;
1616 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1620 consume_data_flag
= 0;
1621 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1625 consume_data_flag
= 0;
1626 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1630 consume_data_flag
= 0;
1631 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1635 consume_data_flag
= 0;
1636 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1640 consume_data_flag
= 0;
1641 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1645 consume_data_flag
= 0;
1646 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1650 consume_data_flag
= 0;
1651 dtp
->u
.p
.seen_dollar
= 1;
1655 consume_data_flag
= 0;
1656 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1657 next_record (dtp
, 0);
1661 /* A colon descriptor causes us to exit this loop (in
1662 particular preventing another / descriptor from being
1663 processed) unless there is another data item to be
1665 consume_data_flag
= 0;
1671 internal_error (&dtp
->common
, "Bad format node");
1674 /* Adjust the item count and data pointer. */
1676 if ((consume_data_flag
> 0) && (n
> 0))
1679 p
= ((char *) p
) + size
;
1682 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1683 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1688 /* Come here when we need a data descriptor but don't have one. We
1689 push the current format node back onto the input, then return and
1690 let the user program call us back with the data. */
1692 unget_format (dtp
, f
);
1695 /* This function is first called from data_init_transfer to initiate the loop
1696 over each item in the format, transferring data as required. Subsequent
1697 calls to this function occur for each data item foound in the READ/WRITE
1698 statement. The item_count is incremented for each call. Since the first
1699 call is from data_transfer_init, the item_count is always one greater than
1700 the actual count number of the item being transferred. */
1703 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1704 size_t size
, size_t nelems
)
1710 size_t stride
= type
== BT_CHARACTER
?
1711 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1712 if (dtp
->u
.p
.mode
== READING
)
1714 /* Big loop over all the elements. */
1715 for (elem
= 0; elem
< nelems
; elem
++)
1717 dtp
->u
.p
.item_count
++;
1718 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1723 /* Big loop over all the elements. */
1724 for (elem
= 0; elem
< nelems
; elem
++)
1726 dtp
->u
.p
.item_count
++;
1727 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1733 /* Data transfer entry points. The type of the data entity is
1734 implicit in the subroutine call. This prevents us from having to
1735 share a common enum with the compiler. */
1738 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1740 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1742 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1747 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1750 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1752 size
= size_from_real_kind (kind
);
1753 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1758 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1760 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1762 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1767 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1769 static char *empty_string
[0];
1771 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1774 /* Strings of zero length can have p == NULL, which confuses the
1775 transfer routines into thinking we need more data elements. To avoid
1776 this, we give them a nice pointer. */
1777 if (len
== 0 && p
== NULL
)
1780 /* Set kind here to 1. */
1781 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1785 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1787 static char *empty_string
[0];
1789 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1792 /* Strings of zero length can have p == NULL, which confuses the
1793 transfer routines into thinking we need more data elements. To avoid
1794 this, we give them a nice pointer. */
1795 if (len
== 0 && p
== NULL
)
1798 /* Here we pass the actual kind value. */
1799 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1804 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1807 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1809 size
= size_from_complex_kind (kind
);
1810 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1815 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1816 gfc_charlen_type charlen
)
1818 index_type count
[GFC_MAX_DIMENSIONS
];
1819 index_type extent
[GFC_MAX_DIMENSIONS
];
1820 index_type stride
[GFC_MAX_DIMENSIONS
];
1821 index_type stride0
, rank
, size
, type
, n
;
1826 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1829 type
= GFC_DESCRIPTOR_TYPE (desc
);
1830 size
= GFC_DESCRIPTOR_SIZE (desc
);
1832 /* FIXME: What a kludge: Array descriptors and the IO library use
1833 different enums for types. */
1836 case GFC_DTYPE_UNKNOWN
:
1837 iotype
= BT_NULL
; /* Is this correct? */
1839 case GFC_DTYPE_INTEGER
:
1840 iotype
= BT_INTEGER
;
1842 case GFC_DTYPE_LOGICAL
:
1843 iotype
= BT_LOGICAL
;
1845 case GFC_DTYPE_REAL
:
1848 case GFC_DTYPE_COMPLEX
:
1849 iotype
= BT_COMPLEX
;
1851 case GFC_DTYPE_CHARACTER
:
1852 iotype
= BT_CHARACTER
;
1855 case GFC_DTYPE_DERIVED
:
1856 internal_error (&dtp
->common
,
1857 "Derived type I/O should have been handled via the frontend.");
1860 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1863 rank
= GFC_DESCRIPTOR_RANK (desc
);
1864 for (n
= 0; n
< rank
; n
++)
1867 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
1868 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
1870 /* If the extent of even one dimension is zero, then the entire
1871 array section contains zero elements, so we return after writing
1872 a zero array record. */
1877 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1882 stride0
= stride
[0];
1884 /* If the innermost dimension has a stride of 1, we can do the transfer
1885 in contiguous chunks. */
1886 if (stride0
== size
)
1891 data
= GFC_DESCRIPTOR_DATA (desc
);
1895 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1896 data
+= stride0
* tsize
;
1899 while (count
[n
] == extent
[n
])
1902 data
-= stride
[n
] * extent
[n
];
1919 /* Preposition a sequential unformatted file while reading. */
1922 us_read (st_parameter_dt
*dtp
, int continued
)
1929 if (compile_options
.record_marker
== 0)
1930 n
= sizeof (GFC_INTEGER_4
);
1932 n
= compile_options
.record_marker
;
1934 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1935 if (unlikely (nr
< 0))
1937 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1943 return; /* end of file */
1945 else if (unlikely (n
!= nr
))
1947 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1951 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1952 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1956 case sizeof(GFC_INTEGER_4
):
1957 memcpy (&i4
, &i
, sizeof (i4
));
1961 case sizeof(GFC_INTEGER_8
):
1962 memcpy (&i8
, &i
, sizeof (i8
));
1967 runtime_error ("Illegal value for record marker");
1974 case sizeof(GFC_INTEGER_4
):
1975 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1979 case sizeof(GFC_INTEGER_8
):
1980 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1985 runtime_error ("Illegal value for record marker");
1991 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1992 dtp
->u
.p
.current_unit
->continued
= 0;
1996 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1997 dtp
->u
.p
.current_unit
->continued
= 1;
2001 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2005 /* Preposition a sequential unformatted file while writing. This
2006 amount to writing a bogus length that will be filled in later. */
2009 us_write (st_parameter_dt
*dtp
, int continued
)
2016 if (compile_options
.record_marker
== 0)
2017 nbytes
= sizeof (GFC_INTEGER_4
);
2019 nbytes
= compile_options
.record_marker
;
2021 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2022 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2024 /* For sequential unformatted, if RECL= was not specified in the OPEN
2025 we write until we have more bytes than can fit in the subrecord
2026 markers, then we write a new subrecord. */
2028 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2029 dtp
->u
.p
.current_unit
->recl_subrecord
;
2030 dtp
->u
.p
.current_unit
->continued
= continued
;
2034 /* Position to the next record prior to transfer. We are assumed to
2035 be before the next record. We also calculate the bytes in the next
2039 pre_position (st_parameter_dt
*dtp
)
2041 if (dtp
->u
.p
.current_unit
->current_record
)
2042 return; /* Already positioned. */
2044 switch (current_mode (dtp
))
2046 case FORMATTED_STREAM
:
2047 case UNFORMATTED_STREAM
:
2048 /* There are no records with stream I/O. If the position was specified
2049 data_transfer_init has already positioned the file. If no position
2050 was specified, we continue from where we last left off. I.e.
2051 there is nothing to do here. */
2054 case UNFORMATTED_SEQUENTIAL
:
2055 if (dtp
->u
.p
.mode
== READING
)
2062 case FORMATTED_SEQUENTIAL
:
2063 case FORMATTED_DIRECT
:
2064 case UNFORMATTED_DIRECT
:
2065 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2069 dtp
->u
.p
.current_unit
->current_record
= 1;
2073 /* Initialize things for a data transfer. This code is common for
2074 both reading and writing. */
2077 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2079 unit_flags u_flags
; /* Used for creating a unit if needed. */
2080 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2081 namelist_info
*ionml
;
2083 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2085 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2087 dtp
->u
.p
.ionml
= ionml
;
2088 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2090 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2093 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2094 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2096 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2097 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2098 { /* Open the unit with some default flags. */
2099 st_parameter_open opp
;
2102 if (dtp
->common
.unit
< 0)
2104 close_unit (dtp
->u
.p
.current_unit
);
2105 dtp
->u
.p
.current_unit
= NULL
;
2106 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2107 "Bad unit number in statement");
2110 memset (&u_flags
, '\0', sizeof (u_flags
));
2111 u_flags
.access
= ACCESS_SEQUENTIAL
;
2112 u_flags
.action
= ACTION_READWRITE
;
2114 /* Is it unformatted? */
2115 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2116 | IOPARM_DT_IONML_SET
)))
2117 u_flags
.form
= FORM_UNFORMATTED
;
2119 u_flags
.form
= FORM_UNSPECIFIED
;
2121 u_flags
.delim
= DELIM_UNSPECIFIED
;
2122 u_flags
.blank
= BLANK_UNSPECIFIED
;
2123 u_flags
.pad
= PAD_UNSPECIFIED
;
2124 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2125 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2126 u_flags
.async
= ASYNC_UNSPECIFIED
;
2127 u_flags
.round
= ROUND_UNSPECIFIED
;
2128 u_flags
.sign
= SIGN_UNSPECIFIED
;
2130 u_flags
.status
= STATUS_UNKNOWN
;
2132 conv
= get_unformatted_convert (dtp
->common
.unit
);
2134 if (conv
== GFC_CONVERT_NONE
)
2135 conv
= compile_options
.convert
;
2137 /* We use big_endian, which is 0 on little-endian machines
2138 and 1 on big-endian machines. */
2141 case GFC_CONVERT_NATIVE
:
2142 case GFC_CONVERT_SWAP
:
2145 case GFC_CONVERT_BIG
:
2146 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2149 case GFC_CONVERT_LITTLE
:
2150 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2154 internal_error (&opp
.common
, "Illegal value for CONVERT");
2158 u_flags
.convert
= conv
;
2160 opp
.common
= dtp
->common
;
2161 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2162 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2163 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2164 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2165 if (dtp
->u
.p
.current_unit
== NULL
)
2169 /* Check the action. */
2171 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2173 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2174 "Cannot read from file opened for WRITE");
2178 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2180 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2181 "Cannot write to file opened for READ");
2185 dtp
->u
.p
.first_item
= 1;
2187 /* Check the format. */
2189 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2192 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2193 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2196 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2197 "Format present for UNFORMATTED data transfer");
2201 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2203 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2204 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2205 "A format cannot be specified with a namelist");
2207 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2208 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2210 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2211 "Missing format for FORMATTED data transfer");
2214 if (is_internal_unit (dtp
)
2215 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2217 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2218 "Internal file cannot be accessed by UNFORMATTED "
2223 /* Check the record or position number. */
2225 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2226 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2228 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2229 "Direct access data transfer requires record number");
2233 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2234 && (cf
& IOPARM_DT_HAS_REC
) != 0)
2236 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2237 "Record number not allowed for sequential access "
2242 /* Process the ADVANCE option. */
2244 dtp
->u
.p
.advance_status
2245 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2246 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2247 "Bad ADVANCE parameter in data transfer statement");
2249 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2251 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2253 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2254 "ADVANCE specification conflicts with sequential "
2259 if (is_internal_unit (dtp
))
2261 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2262 "ADVANCE specification conflicts with internal file");
2266 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2267 != IOPARM_DT_HAS_FORMAT
)
2269 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2270 "ADVANCE specification requires an explicit format");
2277 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2279 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2281 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2282 "EOR specification requires an ADVANCE specification "
2287 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2288 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2290 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2291 "SIZE specification requires an ADVANCE "
2292 "specification of NO");
2297 { /* Write constraints. */
2298 if ((cf
& IOPARM_END
) != 0)
2300 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2301 "END specification cannot appear in a write "
2306 if ((cf
& IOPARM_EOR
) != 0)
2308 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2309 "EOR specification cannot appear in a write "
2314 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2316 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2317 "SIZE specification cannot appear in a write "
2323 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2324 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2326 /* Check the decimal mode. */
2327 dtp
->u
.p
.current_unit
->decimal_status
2328 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2329 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2330 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2333 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2334 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2336 /* Check the round mode. */
2337 dtp
->u
.p
.current_unit
->round_status
2338 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2339 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2340 round_opt
, "Bad ROUND parameter in data transfer "
2343 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2344 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2346 /* Check the sign mode. */
2347 dtp
->u
.p
.sign_status
2348 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2349 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2350 "Bad SIGN parameter in data transfer statement");
2352 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2353 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2355 /* Check the blank mode. */
2356 dtp
->u
.p
.blank_status
2357 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2358 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2360 "Bad BLANK parameter in data transfer statement");
2362 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2363 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2365 /* Check the delim mode. */
2366 dtp
->u
.p
.current_unit
->delim_status
2367 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2368 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2369 delim_opt
, "Bad DELIM parameter in data transfer statement");
2371 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2372 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2374 /* Check the pad mode. */
2375 dtp
->u
.p
.current_unit
->pad_status
2376 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2377 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2378 "Bad PAD parameter in data transfer statement");
2380 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2381 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2383 /* Check to see if we might be reading what we wrote before */
2385 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2386 && !is_internal_unit (dtp
))
2388 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2390 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2391 sflush(dtp
->u
.p
.current_unit
->s
);
2394 /* Check the POS= specifier: that it is in range and that it is used with a
2395 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2397 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2399 if (is_stream_io (dtp
))
2404 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2405 "POS=specifier must be positive");
2409 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2411 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2412 "POS=specifier too large");
2416 dtp
->rec
= dtp
->pos
;
2418 if (dtp
->u
.p
.mode
== READING
)
2420 /* Reset the endfile flag; if we hit EOF during reading
2421 we'll set the flag and generate an error at that point
2422 rather than worrying about it here. */
2423 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2426 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2428 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2429 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2431 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2434 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2439 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2440 "POS=specifier not allowed, "
2441 "Try OPEN with ACCESS='stream'");
2447 /* Sanity checks on the record number. */
2448 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2452 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2453 "Record number must be positive");
2457 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2459 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2460 "Record number too large");
2464 /* Make sure format buffer is reset. */
2465 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2466 fbuf_reset (dtp
->u
.p
.current_unit
);
2469 /* Check whether the record exists to be read. Only
2470 a partial record needs to exist. */
2472 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2473 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2475 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2476 "Non-existing record number");
2480 /* Position the file. */
2481 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2482 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2484 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2488 /* TODO: This is required to maintain compatibility between
2489 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2491 if (is_stream_io (dtp
))
2492 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2494 /* TODO: Un-comment this code when ABI changes from 4.3.
2495 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2497 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2498 "Record number not allowed for stream access "
2504 /* Bugware for badly written mixed C-Fortran I/O. */
2505 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2507 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2509 /* Set the maximum position reached from the previous I/O operation. This
2510 could be greater than zero from a previous non-advancing write. */
2511 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2516 /* Set up the subroutine that will handle the transfers. */
2520 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2521 dtp
->u
.p
.transfer
= unformatted_read
;
2524 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2525 dtp
->u
.p
.transfer
= list_formatted_read
;
2527 dtp
->u
.p
.transfer
= formatted_transfer
;
2532 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2533 dtp
->u
.p
.transfer
= unformatted_write
;
2536 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2537 dtp
->u
.p
.transfer
= list_formatted_write
;
2539 dtp
->u
.p
.transfer
= formatted_transfer
;
2543 /* Make sure that we don't do a read after a nonadvancing write. */
2547 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2549 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2550 "Cannot READ after a nonadvancing WRITE");
2556 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2557 dtp
->u
.p
.current_unit
->read_bad
= 1;
2560 /* Start the data transfer if we are doing a formatted transfer. */
2561 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2562 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2563 && dtp
->u
.p
.ionml
== NULL
)
2564 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2567 /* Initialize an array_loop_spec given the array descriptor. The function
2568 returns the index of the last element of the array, and also returns
2569 starting record, where the first I/O goes to (necessary in case of
2570 negative strides). */
2573 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2574 gfc_offset
*start_record
)
2576 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2585 for (i
=0; i
<rank
; i
++)
2587 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2588 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2589 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2590 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2591 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2592 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2594 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2596 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2597 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2601 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2602 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2603 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2604 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2614 /* Determine the index to the next record in an internal unit array by
2615 by incrementing through the array_loop_spec. */
2618 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2626 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2631 if (ls
[i
].idx
> ls
[i
].end
)
2633 ls
[i
].idx
= ls
[i
].start
;
2639 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2649 /* Skip to the end of the current record, taking care of an optional
2650 record marker of size bytes. If the file is not seekable, we
2651 read chunks of size MAX_READ until we get to the right
2655 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2657 ssize_t rlength
, readb
;
2658 static const ssize_t MAX_READ
= 4096;
2661 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2662 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2665 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2667 /* Direct access files do not generate END conditions,
2669 if (sseek (dtp
->u
.p
.current_unit
->s
,
2670 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2671 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2673 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= 0;
2676 { /* Seek by reading data. */
2677 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2680 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2681 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2683 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2686 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2690 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2697 /* Advance to the next record reading unformatted files, taking
2698 care of subrecords. If complete_record is nonzero, we loop
2699 until all subrecords are cleared. */
2702 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2706 bytes
= compile_options
.record_marker
== 0 ?
2707 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2712 /* Skip over tail */
2714 skip_record (dtp
, bytes
);
2716 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2724 static inline gfc_offset
2725 min_off (gfc_offset a
, gfc_offset b
)
2727 return (a
< b
? a
: b
);
2731 /* Space to the next record for read mode. */
2734 next_record_r (st_parameter_dt
*dtp
)
2741 switch (current_mode (dtp
))
2743 /* No records in unformatted STREAM I/O. */
2744 case UNFORMATTED_STREAM
:
2747 case UNFORMATTED_SEQUENTIAL
:
2748 next_record_r_unf (dtp
, 1);
2749 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2752 case FORMATTED_DIRECT
:
2753 case UNFORMATTED_DIRECT
:
2754 skip_record (dtp
, dtp
->u
.p
.current_unit
->bytes_left
);
2757 case FORMATTED_STREAM
:
2758 case FORMATTED_SEQUENTIAL
:
2759 /* read_sf has already terminated input because of an '\n', or
2761 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2763 dtp
->u
.p
.sf_seen_eor
= 0;
2764 dtp
->u
.p
.at_eof
= 0;
2768 if (is_internal_unit (dtp
))
2770 if (is_array_io (dtp
))
2774 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2777 /* Now seek to this record. */
2778 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2779 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2781 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2784 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2788 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2789 bytes_left
= min_off (bytes_left
,
2790 file_length (dtp
->u
.p
.current_unit
->s
)
2791 - stell (dtp
->u
.p
.current_unit
->s
));
2792 if (sseek (dtp
->u
.p
.current_unit
->s
,
2793 bytes_left
, SEEK_CUR
) < 0)
2795 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2798 dtp
->u
.p
.current_unit
->bytes_left
2799 = dtp
->u
.p
.current_unit
->recl
;
2808 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2812 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2813 else if (dtp
->u
.p
.item_count
== 1)
2818 if (is_stream_io (dtp
))
2819 dtp
->u
.p
.current_unit
->strm_pos
++;
2830 /* Small utility function to write a record marker, taking care of
2831 byte swapping and of choosing the correct size. */
2834 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2839 char p
[sizeof (GFC_INTEGER_8
)];
2841 if (compile_options
.record_marker
== 0)
2842 len
= sizeof (GFC_INTEGER_4
);
2844 len
= compile_options
.record_marker
;
2846 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2847 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2851 case sizeof (GFC_INTEGER_4
):
2853 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2856 case sizeof (GFC_INTEGER_8
):
2858 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2862 runtime_error ("Illegal value for record marker");
2870 case sizeof (GFC_INTEGER_4
):
2872 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2873 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2876 case sizeof (GFC_INTEGER_8
):
2878 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2879 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2883 runtime_error ("Illegal value for record marker");
2890 /* Position to the next (sub)record in write mode for
2891 unformatted sequential files. */
2894 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2896 gfc_offset m
, m_write
, record_marker
;
2898 /* Bytes written. */
2899 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2900 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2902 /* Write the length tail. If we finish a record containing
2903 subrecords, we write out the negative length. */
2905 if (dtp
->u
.p
.current_unit
->continued
)
2910 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2913 if (compile_options
.record_marker
== 0)
2914 record_marker
= sizeof (GFC_INTEGER_4
);
2916 record_marker
= compile_options
.record_marker
;
2918 /* Seek to the head and overwrite the bogus length with the real
2921 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2930 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2933 /* Seek past the end of the current record. */
2935 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2942 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2948 /* Utility function like memset() but operating on streams. Return
2949 value is same as for POSIX write(). */
2952 sset (stream
* s
, int c
, ssize_t nbyte
)
2954 static const int WRITE_CHUNK
= 256;
2955 char p
[WRITE_CHUNK
];
2956 ssize_t bytes_left
, trans
;
2958 if (nbyte
< WRITE_CHUNK
)
2959 memset (p
, c
, nbyte
);
2961 memset (p
, c
, WRITE_CHUNK
);
2964 while (bytes_left
> 0)
2966 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2967 trans
= swrite (s
, p
, trans
);
2970 bytes_left
-= trans
;
2973 return nbyte
- bytes_left
;
2976 /* Position to the next record in write mode. */
2979 next_record_w (st_parameter_dt
*dtp
, int done
)
2981 gfc_offset m
, record
, max_pos
;
2984 /* Zero counters for X- and T-editing. */
2985 max_pos
= dtp
->u
.p
.max_pos
;
2986 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2988 switch (current_mode (dtp
))
2990 /* No records in unformatted STREAM I/O. */
2991 case UNFORMATTED_STREAM
:
2994 case FORMATTED_DIRECT
:
2995 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2998 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2999 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
3000 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
3001 dtp
->u
.p
.current_unit
->bytes_left
)
3002 != dtp
->u
.p
.current_unit
->bytes_left
)
3007 case UNFORMATTED_DIRECT
:
3008 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3010 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3011 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3016 case UNFORMATTED_SEQUENTIAL
:
3017 next_record_w_unf (dtp
, 0);
3018 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3021 case FORMATTED_STREAM
:
3022 case FORMATTED_SEQUENTIAL
:
3024 if (is_internal_unit (dtp
))
3026 if (is_array_io (dtp
))
3030 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3032 /* If the farthest position reached is greater than current
3033 position, adjust the position and set length to pad out
3034 whats left. Otherwise just pad whats left.
3035 (for character array unit) */
3036 m
= dtp
->u
.p
.current_unit
->recl
3037 - dtp
->u
.p
.current_unit
->bytes_left
;
3040 length
= (int) (max_pos
- m
);
3041 if (sseek (dtp
->u
.p
.current_unit
->s
,
3042 length
, SEEK_CUR
) < 0)
3044 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3047 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3050 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3052 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3056 /* Now that the current record has been padded out,
3057 determine where the next record in the array is. */
3058 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3061 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3063 /* Now seek to this record */
3064 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3066 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3068 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3072 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3078 /* If this is the last call to next_record move to the farthest
3079 position reached and set length to pad out the remainder
3080 of the record. (for character scaler unit) */
3083 m
= dtp
->u
.p
.current_unit
->recl
3084 - dtp
->u
.p
.current_unit
->bytes_left
;
3087 length
= (int) (max_pos
- m
);
3088 if (sseek (dtp
->u
.p
.current_unit
->s
,
3089 length
, SEEK_CUR
) < 0)
3091 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3094 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3097 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3100 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3102 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3114 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3115 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3122 if (is_stream_io (dtp
))
3124 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3125 if (dtp
->u
.p
.current_unit
->strm_pos
3126 < file_length (dtp
->u
.p
.current_unit
->s
))
3127 unit_truncate (dtp
->u
.p
.current_unit
,
3128 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3136 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3141 /* Position to the next record, which means moving to the end of the
3142 current record. This can happen under several different
3143 conditions. If the done flag is not set, we get ready to process
3147 next_record (st_parameter_dt
*dtp
, int done
)
3149 gfc_offset fp
; /* File position. */
3151 dtp
->u
.p
.current_unit
->read_bad
= 0;
3153 if (dtp
->u
.p
.mode
== READING
)
3154 next_record_r (dtp
);
3156 next_record_w (dtp
, done
);
3158 if (!is_stream_io (dtp
))
3160 /* Keep position up to date for INQUIRE */
3162 update_position (dtp
->u
.p
.current_unit
);
3164 dtp
->u
.p
.current_unit
->current_record
= 0;
3165 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3167 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3168 /* Calculate next record, rounding up partial records. */
3169 dtp
->u
.p
.current_unit
->last_record
=
3170 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3171 dtp
->u
.p
.current_unit
->recl
;
3174 dtp
->u
.p
.current_unit
->last_record
++;
3180 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3184 /* Finalize the current data transfer. For a nonadvancing transfer,
3185 this means advancing to the next record. For internal units close the
3186 stream associated with the unit. */
3189 finalize_transfer (st_parameter_dt
*dtp
)
3192 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3194 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3195 *dtp
->size
= dtp
->u
.p
.size_used
;
3197 if (dtp
->u
.p
.eor_condition
)
3199 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3203 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3205 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3206 dtp
->u
.p
.current_unit
->current_record
= 0;
3210 if ((dtp
->u
.p
.ionml
!= NULL
)
3211 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3213 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3214 namelist_read (dtp
);
3216 namelist_write (dtp
);
3219 dtp
->u
.p
.transfer
= NULL
;
3220 if (dtp
->u
.p
.current_unit
== NULL
)
3223 dtp
->u
.p
.eof_jump
= &eof_jump
;
3224 if (setjmp (eof_jump
))
3226 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3230 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3232 finish_list_read (dtp
);
3236 if (dtp
->u
.p
.mode
== WRITING
)
3237 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3238 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3240 if (is_stream_io (dtp
))
3242 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3243 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3244 next_record (dtp
, 1);
3249 dtp
->u
.p
.current_unit
->current_record
= 0;
3251 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3253 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3254 dtp
->u
.p
.seen_dollar
= 0;
3258 /* For non-advancing I/O, save the current maximum position for use in the
3259 next I/O operation if needed. */
3260 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3262 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3263 - dtp
->u
.p
.current_unit
->bytes_left
);
3264 dtp
->u
.p
.current_unit
->saved_pos
=
3265 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3266 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3269 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3270 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3271 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3273 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3275 next_record (dtp
, 1);
3278 /* Transfer function for IOLENGTH. It doesn't actually do any
3279 data transfer, it just updates the length counter. */
3282 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3283 void *dest
__attribute__ ((unused
)),
3284 int kind
__attribute__((unused
)),
3285 size_t size
, size_t nelems
)
3287 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3288 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3292 /* Initialize the IOLENGTH data transfer. This function is in essence
3293 a very much simplified version of data_transfer_init(), because it
3294 doesn't have to deal with units at all. */
3297 iolength_transfer_init (st_parameter_dt
*dtp
)
3299 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3302 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3304 /* Set up the subroutine that will handle the transfers. */
3306 dtp
->u
.p
.transfer
= iolength_transfer
;
3310 /* Library entry point for the IOLENGTH form of the INQUIRE
3311 statement. The IOLENGTH form requires no I/O to be performed, but
3312 it must still be a runtime library call so that we can determine
3313 the iolength for dynamic arrays and such. */
3315 extern void st_iolength (st_parameter_dt
*);
3316 export_proto(st_iolength
);
3319 st_iolength (st_parameter_dt
*dtp
)
3321 library_start (&dtp
->common
);
3322 iolength_transfer_init (dtp
);
3325 extern void st_iolength_done (st_parameter_dt
*);
3326 export_proto(st_iolength_done
);
3329 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3336 /* The READ statement. */
3338 extern void st_read (st_parameter_dt
*);
3339 export_proto(st_read
);
3342 st_read (st_parameter_dt
*dtp
)
3344 library_start (&dtp
->common
);
3346 data_transfer_init (dtp
, 1);
3349 extern void st_read_done (st_parameter_dt
*);
3350 export_proto(st_read_done
);
3353 st_read_done (st_parameter_dt
*dtp
)
3355 finalize_transfer (dtp
);
3356 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3357 free_format_data (dtp
->u
.p
.fmt
);
3359 if (dtp
->u
.p
.current_unit
!= NULL
)
3360 unlock_unit (dtp
->u
.p
.current_unit
);
3362 free_internal_unit (dtp
);
3367 extern void st_write (st_parameter_dt
*);
3368 export_proto(st_write
);
3371 st_write (st_parameter_dt
*dtp
)
3373 library_start (&dtp
->common
);
3374 data_transfer_init (dtp
, 0);
3377 extern void st_write_done (st_parameter_dt
*);
3378 export_proto(st_write_done
);
3381 st_write_done (st_parameter_dt
*dtp
)
3383 finalize_transfer (dtp
);
3385 /* Deal with endfile conditions associated with sequential files. */
3387 if (dtp
->u
.p
.current_unit
!= NULL
3388 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3389 switch (dtp
->u
.p
.current_unit
->endfile
)
3391 case AT_ENDFILE
: /* Remain at the endfile record. */
3395 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3399 /* Get rid of whatever is after this record. */
3400 if (!is_internal_unit (dtp
))
3401 unit_truncate (dtp
->u
.p
.current_unit
,
3402 stell (dtp
->u
.p
.current_unit
->s
),
3404 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3408 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3409 free_format_data (dtp
->u
.p
.fmt
);
3411 if (dtp
->u
.p
.current_unit
!= NULL
)
3412 unlock_unit (dtp
->u
.p
.current_unit
);
3414 free_internal_unit (dtp
);
3420 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3422 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3427 /* Receives the scalar information for namelist objects and stores it
3428 in a linked list of namelist_info types. */
3430 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3431 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3432 export_proto(st_set_nml_var
);
3436 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3437 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3438 GFC_INTEGER_4 dtype
)
3440 namelist_info
*t1
= NULL
;
3442 size_t var_name_len
= strlen (var_name
);
3444 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3446 nml
->mem_pos
= var_addr
;
3448 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3449 memcpy (nml
->var_name
, var_name
, var_name_len
);
3450 nml
->var_name
[var_name_len
] = '\0';
3452 nml
->len
= (int) len
;
3453 nml
->string_length
= (index_type
) string_length
;
3455 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3456 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3457 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3459 if (nml
->var_rank
> 0)
3461 nml
->dim
= (descriptor_dimension
*)
3462 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3463 nml
->ls
= (array_loop_spec
*)
3464 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3474 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3476 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3477 dtp
->u
.p
.ionml
= nml
;
3481 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3486 /* Store the dimensional information for the namelist object. */
3487 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3488 index_type
, index_type
,
3490 export_proto(st_set_nml_var_dim
);
3493 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3494 index_type stride
, index_type lbound
,
3497 namelist_info
* nml
;
3502 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3504 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3507 /* Reverse memcpy - used for byte swapping. */
3509 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3515 s
= (char *) src
+ n
- 1;
3517 /* Write with ascending order - this is likely faster
3518 on modern architectures because of write combining. */
3524 /* Once upon a time, a poor innocent Fortran program was reading a
3525 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3526 the OS doesn't tell whether we're at the EOF or whether we already
3527 went past it. Luckily our hero, libgfortran, keeps track of this.
3528 Call this function when you detect an EOF condition. See Section
3532 hit_eof (st_parameter_dt
* dtp
)
3534 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3536 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3537 switch (dtp
->u
.p
.current_unit
->endfile
)
3541 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3542 if (!is_internal_unit (dtp
))
3544 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3545 dtp
->u
.p
.current_unit
->current_record
= 0;
3548 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3552 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3553 dtp
->u
.p
.current_unit
->current_record
= 0;
3558 /* Non-sequential files don't have an ENDFILE record, so we
3559 can't be at AFTER_ENDFILE. */
3560 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3561 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3562 dtp
->u
.p
.current_unit
->current_record
= 0;