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
);
2816 if (is_stream_io (dtp
))
2817 dtp
->u
.p
.current_unit
->strm_pos
++;
2828 /* Small utility function to write a record marker, taking care of
2829 byte swapping and of choosing the correct size. */
2832 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2837 char p
[sizeof (GFC_INTEGER_8
)];
2839 if (compile_options
.record_marker
== 0)
2840 len
= sizeof (GFC_INTEGER_4
);
2842 len
= compile_options
.record_marker
;
2844 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2845 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2849 case sizeof (GFC_INTEGER_4
):
2851 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2854 case sizeof (GFC_INTEGER_8
):
2856 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2860 runtime_error ("Illegal value for record marker");
2868 case sizeof (GFC_INTEGER_4
):
2870 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2871 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2874 case sizeof (GFC_INTEGER_8
):
2876 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2877 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2881 runtime_error ("Illegal value for record marker");
2888 /* Position to the next (sub)record in write mode for
2889 unformatted sequential files. */
2892 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2894 gfc_offset m
, m_write
, record_marker
;
2896 /* Bytes written. */
2897 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2898 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2900 /* Write the length tail. If we finish a record containing
2901 subrecords, we write out the negative length. */
2903 if (dtp
->u
.p
.current_unit
->continued
)
2908 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2911 if (compile_options
.record_marker
== 0)
2912 record_marker
= sizeof (GFC_INTEGER_4
);
2914 record_marker
= compile_options
.record_marker
;
2916 /* Seek to the head and overwrite the bogus length with the real
2919 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2928 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2931 /* Seek past the end of the current record. */
2933 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2940 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2946 /* Utility function like memset() but operating on streams. Return
2947 value is same as for POSIX write(). */
2950 sset (stream
* s
, int c
, ssize_t nbyte
)
2952 static const int WRITE_CHUNK
= 256;
2953 char p
[WRITE_CHUNK
];
2954 ssize_t bytes_left
, trans
;
2956 if (nbyte
< WRITE_CHUNK
)
2957 memset (p
, c
, nbyte
);
2959 memset (p
, c
, WRITE_CHUNK
);
2962 while (bytes_left
> 0)
2964 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2965 trans
= swrite (s
, p
, trans
);
2968 bytes_left
-= trans
;
2971 return nbyte
- bytes_left
;
2974 /* Position to the next record in write mode. */
2977 next_record_w (st_parameter_dt
*dtp
, int done
)
2979 gfc_offset m
, record
, max_pos
;
2982 /* Zero counters for X- and T-editing. */
2983 max_pos
= dtp
->u
.p
.max_pos
;
2984 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2986 switch (current_mode (dtp
))
2988 /* No records in unformatted STREAM I/O. */
2989 case UNFORMATTED_STREAM
:
2992 case FORMATTED_DIRECT
:
2993 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2996 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2997 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2998 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2999 dtp
->u
.p
.current_unit
->bytes_left
)
3000 != dtp
->u
.p
.current_unit
->bytes_left
)
3005 case UNFORMATTED_DIRECT
:
3006 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
3008 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3009 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3014 case UNFORMATTED_SEQUENTIAL
:
3015 next_record_w_unf (dtp
, 0);
3016 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3019 case FORMATTED_STREAM
:
3020 case FORMATTED_SEQUENTIAL
:
3022 if (is_internal_unit (dtp
))
3024 if (is_array_io (dtp
))
3028 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3030 /* If the farthest position reached is greater than current
3031 position, adjust the position and set length to pad out
3032 whats left. Otherwise just pad whats left.
3033 (for character array unit) */
3034 m
= dtp
->u
.p
.current_unit
->recl
3035 - dtp
->u
.p
.current_unit
->bytes_left
;
3038 length
= (int) (max_pos
- m
);
3039 if (sseek (dtp
->u
.p
.current_unit
->s
,
3040 length
, SEEK_CUR
) < 0)
3042 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3045 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3048 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3050 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3054 /* Now that the current record has been padded out,
3055 determine where the next record in the array is. */
3056 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3059 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3061 /* Now seek to this record */
3062 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3064 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3066 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3070 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3076 /* If this is the last call to next_record move to the farthest
3077 position reached and set length to pad out the remainder
3078 of the record. (for character scaler unit) */
3081 m
= dtp
->u
.p
.current_unit
->recl
3082 - dtp
->u
.p
.current_unit
->bytes_left
;
3085 length
= (int) (max_pos
- m
);
3086 if (sseek (dtp
->u
.p
.current_unit
->s
,
3087 length
, SEEK_CUR
) < 0)
3089 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3092 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3095 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3098 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3100 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3112 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3113 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3120 if (is_stream_io (dtp
))
3122 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3123 if (dtp
->u
.p
.current_unit
->strm_pos
3124 < file_length (dtp
->u
.p
.current_unit
->s
))
3125 unit_truncate (dtp
->u
.p
.current_unit
,
3126 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3134 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3139 /* Position to the next record, which means moving to the end of the
3140 current record. This can happen under several different
3141 conditions. If the done flag is not set, we get ready to process
3145 next_record (st_parameter_dt
*dtp
, int done
)
3147 gfc_offset fp
; /* File position. */
3149 dtp
->u
.p
.current_unit
->read_bad
= 0;
3151 if (dtp
->u
.p
.mode
== READING
)
3152 next_record_r (dtp
);
3154 next_record_w (dtp
, done
);
3156 if (!is_stream_io (dtp
))
3158 /* Keep position up to date for INQUIRE */
3160 update_position (dtp
->u
.p
.current_unit
);
3162 dtp
->u
.p
.current_unit
->current_record
= 0;
3163 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3165 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3166 /* Calculate next record, rounding up partial records. */
3167 dtp
->u
.p
.current_unit
->last_record
=
3168 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3169 dtp
->u
.p
.current_unit
->recl
;
3172 dtp
->u
.p
.current_unit
->last_record
++;
3178 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3182 /* Finalize the current data transfer. For a nonadvancing transfer,
3183 this means advancing to the next record. For internal units close the
3184 stream associated with the unit. */
3187 finalize_transfer (st_parameter_dt
*dtp
)
3190 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3192 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3193 *dtp
->size
= dtp
->u
.p
.size_used
;
3195 if (dtp
->u
.p
.eor_condition
)
3197 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3201 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3203 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3204 dtp
->u
.p
.current_unit
->current_record
= 0;
3208 if ((dtp
->u
.p
.ionml
!= NULL
)
3209 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3211 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3212 namelist_read (dtp
);
3214 namelist_write (dtp
);
3217 dtp
->u
.p
.transfer
= NULL
;
3218 if (dtp
->u
.p
.current_unit
== NULL
)
3221 dtp
->u
.p
.eof_jump
= &eof_jump
;
3222 if (setjmp (eof_jump
))
3224 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3228 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3230 finish_list_read (dtp
);
3234 if (dtp
->u
.p
.mode
== WRITING
)
3235 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3236 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3238 if (is_stream_io (dtp
))
3240 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3241 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3242 next_record (dtp
, 1);
3247 dtp
->u
.p
.current_unit
->current_record
= 0;
3249 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3251 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3252 dtp
->u
.p
.seen_dollar
= 0;
3256 /* For non-advancing I/O, save the current maximum position for use in the
3257 next I/O operation if needed. */
3258 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3260 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3261 - dtp
->u
.p
.current_unit
->bytes_left
);
3262 dtp
->u
.p
.current_unit
->saved_pos
=
3263 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3264 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3267 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3268 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3269 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3271 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3273 next_record (dtp
, 1);
3276 /* Transfer function for IOLENGTH. It doesn't actually do any
3277 data transfer, it just updates the length counter. */
3280 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3281 void *dest
__attribute__ ((unused
)),
3282 int kind
__attribute__((unused
)),
3283 size_t size
, size_t nelems
)
3285 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3286 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3290 /* Initialize the IOLENGTH data transfer. This function is in essence
3291 a very much simplified version of data_transfer_init(), because it
3292 doesn't have to deal with units at all. */
3295 iolength_transfer_init (st_parameter_dt
*dtp
)
3297 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3300 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3302 /* Set up the subroutine that will handle the transfers. */
3304 dtp
->u
.p
.transfer
= iolength_transfer
;
3308 /* Library entry point for the IOLENGTH form of the INQUIRE
3309 statement. The IOLENGTH form requires no I/O to be performed, but
3310 it must still be a runtime library call so that we can determine
3311 the iolength for dynamic arrays and such. */
3313 extern void st_iolength (st_parameter_dt
*);
3314 export_proto(st_iolength
);
3317 st_iolength (st_parameter_dt
*dtp
)
3319 library_start (&dtp
->common
);
3320 iolength_transfer_init (dtp
);
3323 extern void st_iolength_done (st_parameter_dt
*);
3324 export_proto(st_iolength_done
);
3327 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3334 /* The READ statement. */
3336 extern void st_read (st_parameter_dt
*);
3337 export_proto(st_read
);
3340 st_read (st_parameter_dt
*dtp
)
3342 library_start (&dtp
->common
);
3344 data_transfer_init (dtp
, 1);
3347 extern void st_read_done (st_parameter_dt
*);
3348 export_proto(st_read_done
);
3351 st_read_done (st_parameter_dt
*dtp
)
3353 finalize_transfer (dtp
);
3354 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3355 free_format_data (dtp
->u
.p
.fmt
);
3357 if (dtp
->u
.p
.current_unit
!= NULL
)
3358 unlock_unit (dtp
->u
.p
.current_unit
);
3360 free_internal_unit (dtp
);
3365 extern void st_write (st_parameter_dt
*);
3366 export_proto(st_write
);
3369 st_write (st_parameter_dt
*dtp
)
3371 library_start (&dtp
->common
);
3372 data_transfer_init (dtp
, 0);
3375 extern void st_write_done (st_parameter_dt
*);
3376 export_proto(st_write_done
);
3379 st_write_done (st_parameter_dt
*dtp
)
3381 finalize_transfer (dtp
);
3383 /* Deal with endfile conditions associated with sequential files. */
3385 if (dtp
->u
.p
.current_unit
!= NULL
3386 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3387 switch (dtp
->u
.p
.current_unit
->endfile
)
3389 case AT_ENDFILE
: /* Remain at the endfile record. */
3393 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3397 /* Get rid of whatever is after this record. */
3398 if (!is_internal_unit (dtp
))
3399 unit_truncate (dtp
->u
.p
.current_unit
,
3400 stell (dtp
->u
.p
.current_unit
->s
),
3402 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3406 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3407 free_format_data (dtp
->u
.p
.fmt
);
3409 if (dtp
->u
.p
.current_unit
!= NULL
)
3410 unlock_unit (dtp
->u
.p
.current_unit
);
3412 free_internal_unit (dtp
);
3418 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3420 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3425 /* Receives the scalar information for namelist objects and stores it
3426 in a linked list of namelist_info types. */
3428 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3429 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3430 export_proto(st_set_nml_var
);
3434 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3435 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3436 GFC_INTEGER_4 dtype
)
3438 namelist_info
*t1
= NULL
;
3440 size_t var_name_len
= strlen (var_name
);
3442 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3444 nml
->mem_pos
= var_addr
;
3446 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3447 memcpy (nml
->var_name
, var_name
, var_name_len
);
3448 nml
->var_name
[var_name_len
] = '\0';
3450 nml
->len
= (int) len
;
3451 nml
->string_length
= (index_type
) string_length
;
3453 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3454 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3455 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3457 if (nml
->var_rank
> 0)
3459 nml
->dim
= (descriptor_dimension
*)
3460 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3461 nml
->ls
= (array_loop_spec
*)
3462 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3472 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3474 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3475 dtp
->u
.p
.ionml
= nml
;
3479 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3484 /* Store the dimensional information for the namelist object. */
3485 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3486 index_type
, index_type
,
3488 export_proto(st_set_nml_var_dim
);
3491 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3492 index_type stride
, index_type lbound
,
3495 namelist_info
* nml
;
3500 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3502 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3505 /* Reverse memcpy - used for byte swapping. */
3507 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3513 s
= (char *) src
+ n
- 1;
3515 /* Write with ascending order - this is likely faster
3516 on modern architectures because of write combining. */
3522 /* Once upon a time, a poor innocent Fortran program was reading a
3523 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3524 the OS doesn't tell whether we're at the EOF or whether we already
3525 went past it. Luckily our hero, libgfortran, keeps track of this.
3526 Call this function when you detect an EOF condition. See Section
3530 hit_eof (st_parameter_dt
* dtp
)
3532 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3534 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3535 switch (dtp
->u
.p
.current_unit
->endfile
)
3539 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3540 if (!is_internal_unit (dtp
))
3542 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3543 dtp
->u
.p
.current_unit
->current_record
= 0;
3546 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3550 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3551 dtp
->u
.p
.current_unit
->current_record
= 0;
3556 /* Non-sequential files don't have an ENDFILE record, so we
3557 can't be at AFTER_ENDFILE. */
3558 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3559 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3560 dtp
->u
.p
.current_unit
->current_record
= 0;