1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
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 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
34 /* transfer.c -- Top level handling of data transfer statements. */
42 /* Calling conventions: Data transfer statements are unlike other
43 library calls in that they extend over several calls.
45 The first call is always a call to st_read() or st_write(). These
46 subroutines return no status unless a namelist read or write is
47 being done, in which case there is the usual status. No further
48 calls are necessary in this case.
50 For other sorts of data transfer, there are zero or more data
51 transfer statement that depend on the format of the data transfer
57 transfer_character_wide
61 These subroutines do not return status.
63 The last call is a call to st_[read|write]_done(). While
64 something can easily go wrong with the initial st_read() or
65 st_write(), an error inhibits any data from actually being
68 extern void transfer_integer (st_parameter_dt
*, void *, int);
69 export_proto(transfer_integer
);
71 extern void transfer_real (st_parameter_dt
*, void *, int);
72 export_proto(transfer_real
);
74 extern void transfer_logical (st_parameter_dt
*, void *, int);
75 export_proto(transfer_logical
);
77 extern void transfer_character (st_parameter_dt
*, void *, int);
78 export_proto(transfer_character
);
80 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
81 export_proto(transfer_character_wide
);
83 extern void transfer_complex (st_parameter_dt
*, void *, int);
84 export_proto(transfer_complex
);
86 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
88 export_proto(transfer_array
);
90 static void us_read (st_parameter_dt
*, int);
91 static void us_write (st_parameter_dt
*, int);
92 static void next_record_r_unf (st_parameter_dt
*, int);
93 static void next_record_w_unf (st_parameter_dt
*, int);
95 static const st_option advance_opt
[] = {
102 static const st_option decimal_opt
[] = {
103 {"point", DECIMAL_POINT
},
104 {"comma", DECIMAL_COMMA
},
109 static const st_option sign_opt
[] = {
111 {"suppress", SIGN_SS
},
112 {"processor_defined", SIGN_S
},
116 static const st_option blank_opt
[] = {
117 {"null", BLANK_NULL
},
118 {"zero", BLANK_ZERO
},
122 static const st_option delim_opt
[] = {
123 {"apostrophe", DELIM_APOSTROPHE
},
124 {"quote", DELIM_QUOTE
},
125 {"none", DELIM_NONE
},
129 static const st_option pad_opt
[] = {
136 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
137 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
143 current_mode (st_parameter_dt
*dtp
)
147 m
= FORM_UNSPECIFIED
;
149 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
151 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
152 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
154 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
156 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
157 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
159 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
161 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
162 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
169 /* Mid level data transfer statements. These subroutines do reading
170 and writing in the style of salloc_r()/salloc_w() within the
173 /* When reading sequential formatted records we have a problem. We
174 don't know how long the line is until we read the trailing newline,
175 and we don't want to read too much. If we read too much, we might
176 have to do a physical seek backwards depending on how much data is
177 present, and devices like terminals aren't seekable and would cause
180 Given this, the solution is to read a byte at a time, stopping if
181 we hit the newline. For small allocations, we use a static buffer.
182 For larger allocations, we are forced to allocate memory on the
183 heap. Hopefully this won't happen very often. */
186 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
193 if (*length
> SCRATCH_SIZE
)
194 dtp
->u
.p
.line_buffer
= get_mem (*length
);
195 p
= base
= dtp
->u
.p
.line_buffer
;
197 /* If we have seen an eor previously, return a length of 0. The
198 caller is responsible for correctly padding the input field. */
199 if (dtp
->u
.p
.sf_seen_eor
)
205 if (is_internal_unit (dtp
))
208 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, p
, &readlen
) != 0
209 || readlen
< (size_t) *length
))
211 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
223 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0))
225 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
229 /* If we have a line without a terminating \n, drop through to
231 if (readlen
< 1 && n
== 0)
233 if (likely (no_error
))
235 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
239 if (readlen
< 1 || q
== '\n' || q
== '\r')
241 /* Unexpected end of line. */
243 /* If we see an EOR during non-advancing I/O, we need to skip
244 the rest of the I/O statement. Set the corresponding flag. */
245 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
246 dtp
->u
.p
.eor_condition
= 1;
249 /* If we encounter a CR, it might be a CRLF. */
250 if (q
== '\r') /* Probably a CRLF */
253 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
254 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
)
257 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
260 if (q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
261 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
266 /* Without padding, terminate the I/O statement without assigning
267 the value. With padding, the value still needs to be assigned,
268 so we can just continue with a short read. */
269 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
271 if (likely (no_error
))
273 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
278 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
281 /* Short circuit the read if a comma is found during numeric input.
282 The flag is set to zero during character reads so that commas in
283 strings are not ignored */
285 if (dtp
->u
.p
.sf_read_comma
== 1)
287 notify_std (&dtp
->common
, GFC_STD_GNU
,
288 "Comma in formatted numeric read.");
295 dtp
->u
.p
.sf_seen_eor
= 0;
300 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
302 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
303 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *length
;
309 /* Function for reading the next couple of bytes from the current
310 file, advancing the current position. We return FAILURE on end of record or
311 end of file. This function is only for formatted I/O, unformatted uses
314 If the read is short, then it is because the current record does not
315 have enough data to satisfy the read request and the file was
316 opened with PAD=YES. The caller must assume tailing spaces for
320 read_block_form (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
326 if (!is_stream_io (dtp
))
328 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
330 /* For preconnected units with default record length, set bytes left
331 to unit record length and proceed, otherwise error. */
332 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
333 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
334 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
337 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
339 /* Not enough data left. */
340 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
345 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
347 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
348 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
352 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
356 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
357 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
358 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
361 source
= read_sf (dtp
, &nb
, 0);
363 dtp
->u
.p
.current_unit
->strm_pos
+=
364 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
367 memcpy (buf
, source
, *nbytes
);
370 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
373 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0))
375 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
379 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
380 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) nread
;
382 if (nread
!= *nbytes
)
383 { /* Short read, this shouldn't happen. */
384 if (likely (dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
))
388 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
393 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
399 /* Reads a block directly into application data space. This is for
400 unformatted files. */
403 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
405 size_t to_read_record
;
406 size_t have_read_record
;
407 size_t to_read_subrecord
;
408 size_t have_read_subrecord
;
411 if (is_stream_io (dtp
))
413 to_read_record
= *nbytes
;
414 have_read_record
= to_read_record
;
415 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
)
418 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
422 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
424 if (unlikely (to_read_record
!= have_read_record
))
426 /* Short read, e.g. if we hit EOF. For stream files,
427 we have to set the end-of-file condition. */
428 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
434 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
436 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
439 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
440 *nbytes
= to_read_record
;
446 to_read_record
= *nbytes
;
449 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
451 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
)
454 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
458 if (to_read_record
!= *nbytes
)
460 /* Short read, e.g. if we hit EOF. Apparently, we read
461 more than was written to the last record. */
462 *nbytes
= to_read_record
;
466 if (unlikely (short_record
))
468 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
474 /* Unformatted sequential. We loop over the subrecords, reading
475 until the request has been fulfilled or the record has run out
476 of continuation subrecords. */
478 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
480 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
484 /* Check whether we exceed the total record length. */
486 if (dtp
->u
.p
.current_unit
->flags
.has_recl
487 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
489 to_read_record
= (size_t) 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
= (size_t) 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
= to_read_subrecord
;
516 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
517 &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 *nbytes
= have_read_record
;
533 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
537 if (to_read_record
> 0)
539 if (likely (dtp
->u
.p
.current_unit
->continued
))
541 next_record_r_unf (dtp
, 0);
546 /* Let's make sure the file position is correctly pre-positioned
547 for the next read statement. */
549 dtp
->u
.p
.current_unit
->current_record
= 0;
550 next_record_r_unf (dtp
, 0);
551 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
557 /* Normal exit, the read request has been fulfilled. */
562 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
563 if (unlikely (short_record
))
565 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
572 /* Function for writing a block of bytes to the current file at the
573 current position, advancing the file pointer. We are given a length
574 and return a pointer to a buffer that the caller must (completely)
575 fill in. Returns NULL on error. */
578 write_block (st_parameter_dt
*dtp
, int length
)
582 if (!is_stream_io (dtp
))
584 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
586 /* For preconnected units with default record length, set bytes left
587 to unit record length and proceed, otherwise error. */
588 if (likely ((dtp
->u
.p
.current_unit
->unit_number
589 == options
.stdout_unit
590 || dtp
->u
.p
.current_unit
->unit_number
591 == options
.stderr_unit
)
592 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
593 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
596 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
601 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
604 if (is_internal_unit (dtp
))
606 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
610 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
614 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
615 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
619 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
622 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
627 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
628 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
630 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
636 /* High level interface to swrite(), taking care of errors. This is only
637 called for unformatted files. There are three cases to consider:
638 Stream I/O, unformatted direct, unformatted sequential. */
641 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
644 size_t have_written
, to_write_subrecord
;
649 if (is_stream_io (dtp
))
651 if (unlikely (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0))
653 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
657 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
662 /* Unformatted direct access. */
664 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
666 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
668 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
672 if (buf
== NULL
&& nbytes
== 0)
675 if (unlikely (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0))
677 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
681 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
682 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
687 /* Unformatted sequential. */
691 if (dtp
->u
.p
.current_unit
->flags
.has_recl
692 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
694 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
706 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
707 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
709 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
710 (gfc_offset
) to_write_subrecord
;
712 if (unlikely (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
713 &to_write_subrecord
) != 0))
715 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
719 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
720 nbytes
-= to_write_subrecord
;
721 have_written
+= to_write_subrecord
;
726 next_record_w_unf (dtp
, 1);
729 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
730 if (unlikely (short_record
))
732 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
739 /* Master function for unformatted reads. */
742 unformatted_read (st_parameter_dt
*dtp
, bt type
,
743 void *dest
, int kind
, size_t size
, size_t nelems
)
747 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
751 if (type
== BT_CHARACTER
)
752 sz
*= GFC_SIZE_OF_CHAR_KIND(kind
);
753 read_block_direct (dtp
, dest
, &sz
);
762 /* Handle wide chracters. */
763 if (type
== BT_CHARACTER
&& kind
!= 1)
769 /* Break up complex into its constituent reals. */
770 if (type
== BT_COMPLEX
)
776 /* By now, all complex variables have been split into their
777 constituent reals. */
779 for (i
= 0; i
< nelems
; i
++)
781 read_block_direct (dtp
, buffer
, &size
);
782 reverse_memcpy (p
, buffer
, size
);
789 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
790 bytes on 64 bit machines. The unused bytes are not initialized and never
791 used, which can show an error with memory checking analyzers like
795 unformatted_write (st_parameter_dt
*dtp
, bt type
,
796 void *source
, int kind
, size_t size
, size_t nelems
)
798 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
801 size_t stride
= type
== BT_CHARACTER
?
802 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
804 write_buf (dtp
, source
, stride
* nelems
);
814 /* Handle wide chracters. */
815 if (type
== BT_CHARACTER
&& kind
!= 1)
821 /* Break up complex into its constituent reals. */
822 if (type
== BT_COMPLEX
)
828 /* By now, all complex variables have been split into their
829 constituent reals. */
831 for (i
= 0; i
< nelems
; i
++)
833 reverse_memcpy(buffer
, p
, size
);
835 write_buf (dtp
, buffer
, size
);
841 /* Return a pointer to the name of a type. */
866 internal_error (NULL
, "type_name(): Bad type");
873 /* Write a constant string to the output.
874 This is complicated because the string can have doubled delimiters
875 in it. The length in the format node is the true length. */
878 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
880 char c
, delimiter
, *p
, *q
;
883 length
= f
->u
.string
.length
;
887 p
= write_block (dtp
, length
);
894 for (; length
> 0; length
--)
897 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
898 q
++; /* Skip the doubled delimiter. */
903 /* Given actual and expected types in a formatted data transfer, make
904 sure they agree. If not, an error message is generated. Returns
905 nonzero if something went wrong. */
908 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
912 if (actual
== expected
)
915 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
916 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
918 format_error (dtp
, f
, buffer
);
923 /* This subroutine is the main loop for a formatted data transfer
924 statement. It would be natural to implement this as a coroutine
925 with the user program, but C makes that awkward. We loop,
926 processing format elements. When we actually have to transfer
927 data instead of just setting flags, we return control to the user
928 program which calls a subroutine that supplies the address and type
929 of the next element, then comes back here to process it. */
932 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
935 char scratch
[SCRATCH_SIZE
];
940 int consume_data_flag
;
942 /* Change a complex data item into a pair of reals. */
944 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
945 if (type
== BT_COMPLEX
)
951 /* If there's an EOR condition, we simulate finalizing the transfer
953 if (dtp
->u
.p
.eor_condition
)
956 /* Set this flag so that commas in reads cause the read to complete before
957 the entire field has been read. The next read field will start right after
958 the comma in the stream. (Set to 0 for character reads). */
959 dtp
->u
.p
.sf_read_comma
=
960 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
962 dtp
->u
.p
.line_buffer
= scratch
;
966 /* If reversion has occurred and there is another real data item,
967 then we have to move to the next record. */
968 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
970 dtp
->u
.p
.reversion_flag
= 0;
971 next_record (dtp
, 0);
974 consume_data_flag
= 1;
975 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
978 f
= next_format (dtp
);
981 /* No data descriptors left. */
982 if (unlikely (n
> 0))
983 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
984 "Insufficient data descriptors in format after reversion");
988 /* Now discharge T, TR and X movements to the right. This is delayed
989 until a data producing format to suppress trailing spaces. */
992 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
993 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
994 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
995 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
996 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
999 if (dtp
->u
.p
.skips
> 0)
1002 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1003 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1004 - dtp
->u
.p
.current_unit
->bytes_left
);
1006 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1008 if (dtp
->u
.p
.skips
< 0)
1010 if (is_internal_unit (dtp
))
1011 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1013 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
);
1014 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1016 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1019 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1020 - dtp
->u
.p
.current_unit
->bytes_left
);
1022 if (is_stream_io(dtp
))
1030 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1033 if (dtp
->u
.p
.mode
== READING
)
1034 read_decimal (dtp
, f
, p
, kind
);
1036 write_i (dtp
, f
, p
, kind
);
1044 if (compile_options
.allow_std
< GFC_STD_GNU
1045 && require_type (dtp
, BT_INTEGER
, type
, f
))
1048 if (dtp
->u
.p
.mode
== READING
)
1049 read_radix (dtp
, f
, p
, kind
, 2);
1051 write_b (dtp
, f
, p
, kind
);
1059 if (compile_options
.allow_std
< GFC_STD_GNU
1060 && require_type (dtp
, BT_INTEGER
, type
, f
))
1063 if (dtp
->u
.p
.mode
== READING
)
1064 read_radix (dtp
, f
, p
, kind
, 8);
1066 write_o (dtp
, f
, p
, kind
);
1074 if (compile_options
.allow_std
< GFC_STD_GNU
1075 && require_type (dtp
, BT_INTEGER
, type
, f
))
1078 if (dtp
->u
.p
.mode
== READING
)
1079 read_radix (dtp
, f
, p
, kind
, 16);
1081 write_z (dtp
, f
, p
, kind
);
1089 /* It is possible to have FMT_A with something not BT_CHARACTER such
1090 as when writing out hollerith strings, so check both type
1091 and kind before calling wide character routines. */
1092 if (dtp
->u
.p
.mode
== READING
)
1094 if (type
== BT_CHARACTER
&& kind
== 4)
1095 read_a_char4 (dtp
, f
, p
, size
);
1097 read_a (dtp
, f
, p
, size
);
1101 if (type
== BT_CHARACTER
&& kind
== 4)
1102 write_a_char4 (dtp
, f
, p
, size
);
1104 write_a (dtp
, f
, p
, size
);
1112 if (dtp
->u
.p
.mode
== READING
)
1113 read_l (dtp
, f
, p
, kind
);
1115 write_l (dtp
, f
, p
, kind
);
1122 if (require_type (dtp
, BT_REAL
, type
, f
))
1125 if (dtp
->u
.p
.mode
== READING
)
1126 read_f (dtp
, f
, p
, kind
);
1128 write_d (dtp
, f
, p
, kind
);
1135 if (require_type (dtp
, BT_REAL
, type
, f
))
1138 if (dtp
->u
.p
.mode
== READING
)
1139 read_f (dtp
, f
, p
, kind
);
1141 write_e (dtp
, f
, p
, kind
);
1147 if (require_type (dtp
, BT_REAL
, type
, f
))
1150 if (dtp
->u
.p
.mode
== READING
)
1151 read_f (dtp
, f
, p
, kind
);
1153 write_en (dtp
, f
, p
, kind
);
1160 if (require_type (dtp
, BT_REAL
, type
, f
))
1163 if (dtp
->u
.p
.mode
== READING
)
1164 read_f (dtp
, f
, p
, kind
);
1166 write_es (dtp
, f
, p
, kind
);
1173 if (require_type (dtp
, BT_REAL
, type
, f
))
1176 if (dtp
->u
.p
.mode
== READING
)
1177 read_f (dtp
, f
, p
, kind
);
1179 write_f (dtp
, f
, p
, kind
);
1186 if (dtp
->u
.p
.mode
== READING
)
1190 read_decimal (dtp
, f
, p
, kind
);
1193 read_l (dtp
, f
, p
, kind
);
1197 read_a_char4 (dtp
, f
, p
, size
);
1199 read_a (dtp
, f
, p
, size
);
1202 read_f (dtp
, f
, p
, kind
);
1211 write_i (dtp
, f
, p
, kind
);
1214 write_l (dtp
, f
, p
, kind
);
1218 write_a_char4 (dtp
, f
, p
, size
);
1220 write_a (dtp
, f
, p
, size
);
1223 if (f
->u
.real
.w
== 0)
1224 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1226 write_d (dtp
, f
, p
, kind
);
1230 internal_error (&dtp
->common
,
1231 "formatted_transfer(): Bad type");
1237 consume_data_flag
= 0;
1238 if (dtp
->u
.p
.mode
== READING
)
1240 format_error (dtp
, f
, "Constant string in input format");
1243 write_constant_string (dtp
, f
);
1246 /* Format codes that don't transfer data. */
1249 consume_data_flag
= 0;
1251 dtp
->u
.p
.skips
+= f
->u
.n
;
1252 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1253 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1255 /* Writes occur just before the switch on f->format, above, so
1256 that trailing blanks are suppressed, unless we are doing a
1257 non-advancing write in which case we want to output the blanks
1259 if (dtp
->u
.p
.mode
== WRITING
1260 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1262 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1263 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1266 if (dtp
->u
.p
.mode
== READING
)
1267 read_x (dtp
, f
->u
.n
);
1273 consume_data_flag
= 0;
1275 if (f
->format
== FMT_TL
)
1278 /* Handle the special case when no bytes have been used yet.
1279 Cannot go below zero. */
1280 if (bytes_used
== 0)
1282 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1283 dtp
->u
.p
.skips
-= f
->u
.n
;
1284 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1287 pos
= bytes_used
- f
->u
.n
;
1291 if (dtp
->u
.p
.mode
== READING
)
1294 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1297 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1298 left tab limit. We do not check if the position has gone
1299 beyond the end of record because a subsequent tab could
1300 bring us back again. */
1301 pos
= pos
< 0 ? 0 : pos
;
1303 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1304 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1305 + pos
- dtp
->u
.p
.max_pos
;
1306 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1307 ? 0 : dtp
->u
.p
.pending_spaces
;
1309 if (dtp
->u
.p
.skips
== 0)
1312 /* Writes occur just before the switch on f->format, above, so that
1313 trailing blanks are suppressed. */
1314 if (dtp
->u
.p
.mode
== READING
)
1316 /* Adjust everything for end-of-record condition */
1317 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1319 if (dtp
->u
.p
.sf_seen_eor
== 2)
1321 /* The EOR was a CRLF (two bytes wide). */
1322 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1323 dtp
->u
.p
.skips
-= 2;
1327 /* The EOR marker was only one byte wide. */
1328 dtp
->u
.p
.current_unit
->bytes_left
--;
1332 dtp
->u
.p
.sf_seen_eor
= 0;
1334 if (dtp
->u
.p
.skips
< 0)
1336 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1337 dtp
->u
.p
.current_unit
->bytes_left
1338 -= (gfc_offset
) dtp
->u
.p
.skips
;
1339 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1342 read_x (dtp
, dtp
->u
.p
.skips
);
1348 consume_data_flag
= 0;
1349 dtp
->u
.p
.sign_status
= SIGN_S
;
1353 consume_data_flag
= 0;
1354 dtp
->u
.p
.sign_status
= SIGN_SS
;
1358 consume_data_flag
= 0;
1359 dtp
->u
.p
.sign_status
= SIGN_SP
;
1363 consume_data_flag
= 0 ;
1364 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1368 consume_data_flag
= 0;
1369 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1373 consume_data_flag
= 0;
1374 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1378 consume_data_flag
= 0;
1379 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1383 consume_data_flag
= 0;
1384 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1388 consume_data_flag
= 0;
1389 dtp
->u
.p
.seen_dollar
= 1;
1393 consume_data_flag
= 0;
1394 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1395 next_record (dtp
, 0);
1399 /* A colon descriptor causes us to exit this loop (in
1400 particular preventing another / descriptor from being
1401 processed) unless there is another data item to be
1403 consume_data_flag
= 0;
1409 internal_error (&dtp
->common
, "Bad format node");
1412 /* Free a buffer that we had to allocate during a sequential
1413 formatted read of a block that was larger than the static
1416 if (dtp
->u
.p
.line_buffer
!= scratch
)
1418 free_mem (dtp
->u
.p
.line_buffer
);
1419 dtp
->u
.p
.line_buffer
= scratch
;
1422 /* Adjust the item count and data pointer. */
1424 if ((consume_data_flag
> 0) && (n
> 0))
1427 p
= ((char *) p
) + size
;
1430 if (dtp
->u
.p
.mode
== READING
)
1433 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1434 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1440 /* Come here when we need a data descriptor but don't have one. We
1441 push the current format node back onto the input, then return and
1442 let the user program call us back with the data. */
1444 unget_format (dtp
, f
);
1448 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1449 size_t size
, size_t nelems
)
1455 size_t stride
= type
== BT_CHARACTER
?
1456 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1457 /* Big loop over all the elements. */
1458 for (elem
= 0; elem
< nelems
; elem
++)
1460 dtp
->u
.p
.item_count
++;
1461 formatted_transfer_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1467 /* Data transfer entry points. The type of the data entity is
1468 implicit in the subroutine call. This prevents us from having to
1469 share a common enum with the compiler. */
1472 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1474 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1476 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1481 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1484 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1486 size
= size_from_real_kind (kind
);
1487 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1492 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1494 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1496 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1501 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1503 static char *empty_string
[0];
1505 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1508 /* Strings of zero length can have p == NULL, which confuses the
1509 transfer routines into thinking we need more data elements. To avoid
1510 this, we give them a nice pointer. */
1511 if (len
== 0 && p
== NULL
)
1514 /* Set kind here to 1. */
1515 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1519 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1521 static char *empty_string
[0];
1523 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1526 /* Strings of zero length can have p == NULL, which confuses the
1527 transfer routines into thinking we need more data elements. To avoid
1528 this, we give them a nice pointer. */
1529 if (len
== 0 && p
== NULL
)
1532 /* Here we pass the actual kind value. */
1533 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1538 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1541 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1543 size
= size_from_complex_kind (kind
);
1544 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1549 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1550 gfc_charlen_type charlen
)
1552 index_type count
[GFC_MAX_DIMENSIONS
];
1553 index_type extent
[GFC_MAX_DIMENSIONS
];
1554 index_type stride
[GFC_MAX_DIMENSIONS
];
1555 index_type stride0
, rank
, size
, type
, n
;
1560 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1563 type
= GFC_DESCRIPTOR_TYPE (desc
);
1564 size
= GFC_DESCRIPTOR_SIZE (desc
);
1566 /* FIXME: What a kludge: Array descriptors and the IO library use
1567 different enums for types. */
1570 case GFC_DTYPE_UNKNOWN
:
1571 iotype
= BT_NULL
; /* Is this correct? */
1573 case GFC_DTYPE_INTEGER
:
1574 iotype
= BT_INTEGER
;
1576 case GFC_DTYPE_LOGICAL
:
1577 iotype
= BT_LOGICAL
;
1579 case GFC_DTYPE_REAL
:
1582 case GFC_DTYPE_COMPLEX
:
1583 iotype
= BT_COMPLEX
;
1585 case GFC_DTYPE_CHARACTER
:
1586 iotype
= BT_CHARACTER
;
1589 case GFC_DTYPE_DERIVED
:
1590 internal_error (&dtp
->common
,
1591 "Derived type I/O should have been handled via the frontend.");
1594 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1597 rank
= GFC_DESCRIPTOR_RANK (desc
);
1598 for (n
= 0; n
< rank
; n
++)
1601 stride
[n
] = iotype
== BT_CHARACTER
?
1602 desc
->dim
[n
].stride
* GFC_SIZE_OF_CHAR_KIND(kind
) :
1603 desc
->dim
[n
].stride
;
1604 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1606 /* If the extent of even one dimension is zero, then the entire
1607 array section contains zero elements, so we return after writing
1608 a zero array record. */
1613 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1618 stride0
= stride
[0];
1620 /* If the innermost dimension has stride 1, we can do the transfer
1621 in contiguous chunks. */
1627 data
= GFC_DESCRIPTOR_DATA (desc
);
1631 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1632 data
+= stride0
* size
* tsize
;
1635 while (count
[n
] == extent
[n
])
1638 data
-= stride
[n
] * extent
[n
] * size
;
1648 data
+= stride
[n
] * size
;
1655 /* Preposition a sequential unformatted file while reading. */
1658 us_read (st_parameter_dt
*dtp
, int continued
)
1665 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1668 if (compile_options
.record_marker
== 0)
1669 n
= sizeof (GFC_INTEGER_4
);
1671 n
= compile_options
.record_marker
;
1675 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, &i
, &n
) != 0))
1677 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1683 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1684 return; /* end of file */
1687 if (unlikely (n
!= nr
))
1689 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1693 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1694 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1698 case sizeof(GFC_INTEGER_4
):
1699 memcpy (&i4
, &i
, sizeof (i4
));
1703 case sizeof(GFC_INTEGER_8
):
1704 memcpy (&i8
, &i
, sizeof (i8
));
1709 runtime_error ("Illegal value for record marker");
1716 case sizeof(GFC_INTEGER_4
):
1717 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1721 case sizeof(GFC_INTEGER_8
):
1722 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1727 runtime_error ("Illegal value for record marker");
1733 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1734 dtp
->u
.p
.current_unit
->continued
= 0;
1738 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1739 dtp
->u
.p
.current_unit
->continued
= 1;
1743 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1747 /* Preposition a sequential unformatted file while writing. This
1748 amount to writing a bogus length that will be filled in later. */
1751 us_write (st_parameter_dt
*dtp
, int continued
)
1758 if (compile_options
.record_marker
== 0)
1759 nbytes
= sizeof (GFC_INTEGER_4
);
1761 nbytes
= compile_options
.record_marker
;
1763 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1764 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1766 /* For sequential unformatted, if RECL= was not specified in the OPEN
1767 we write until we have more bytes than can fit in the subrecord
1768 markers, then we write a new subrecord. */
1770 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1771 dtp
->u
.p
.current_unit
->recl_subrecord
;
1772 dtp
->u
.p
.current_unit
->continued
= continued
;
1776 /* Position to the next record prior to transfer. We are assumed to
1777 be before the next record. We also calculate the bytes in the next
1781 pre_position (st_parameter_dt
*dtp
)
1783 if (dtp
->u
.p
.current_unit
->current_record
)
1784 return; /* Already positioned. */
1786 switch (current_mode (dtp
))
1788 case FORMATTED_STREAM
:
1789 case UNFORMATTED_STREAM
:
1790 /* There are no records with stream I/O. If the position was specified
1791 data_transfer_init has already positioned the file. If no position
1792 was specified, we continue from where we last left off. I.e.
1793 there is nothing to do here. */
1796 case UNFORMATTED_SEQUENTIAL
:
1797 if (dtp
->u
.p
.mode
== READING
)
1804 case FORMATTED_SEQUENTIAL
:
1805 case FORMATTED_DIRECT
:
1806 case UNFORMATTED_DIRECT
:
1807 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1811 dtp
->u
.p
.current_unit
->current_record
= 1;
1815 /* Initialize things for a data transfer. This code is common for
1816 both reading and writing. */
1819 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1821 unit_flags u_flags
; /* Used for creating a unit if needed. */
1822 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1823 namelist_info
*ionml
;
1825 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1827 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1829 dtp
->u
.p
.ionml
= ionml
;
1830 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1832 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1835 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1836 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1838 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1839 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1840 { /* Open the unit with some default flags. */
1841 st_parameter_open opp
;
1844 if (dtp
->common
.unit
< 0)
1846 close_unit (dtp
->u
.p
.current_unit
);
1847 dtp
->u
.p
.current_unit
= NULL
;
1848 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1849 "Bad unit number in OPEN statement");
1852 memset (&u_flags
, '\0', sizeof (u_flags
));
1853 u_flags
.access
= ACCESS_SEQUENTIAL
;
1854 u_flags
.action
= ACTION_READWRITE
;
1856 /* Is it unformatted? */
1857 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1858 | IOPARM_DT_IONML_SET
)))
1859 u_flags
.form
= FORM_UNFORMATTED
;
1861 u_flags
.form
= FORM_UNSPECIFIED
;
1863 u_flags
.delim
= DELIM_UNSPECIFIED
;
1864 u_flags
.blank
= BLANK_UNSPECIFIED
;
1865 u_flags
.pad
= PAD_UNSPECIFIED
;
1866 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1867 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1868 u_flags
.async
= ASYNC_UNSPECIFIED
;
1869 u_flags
.round
= ROUND_UNSPECIFIED
;
1870 u_flags
.sign
= SIGN_UNSPECIFIED
;
1872 u_flags
.status
= STATUS_UNKNOWN
;
1874 conv
= get_unformatted_convert (dtp
->common
.unit
);
1876 if (conv
== GFC_CONVERT_NONE
)
1877 conv
= compile_options
.convert
;
1879 /* We use big_endian, which is 0 on little-endian machines
1880 and 1 on big-endian machines. */
1883 case GFC_CONVERT_NATIVE
:
1884 case GFC_CONVERT_SWAP
:
1887 case GFC_CONVERT_BIG
:
1888 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1891 case GFC_CONVERT_LITTLE
:
1892 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1896 internal_error (&opp
.common
, "Illegal value for CONVERT");
1900 u_flags
.convert
= conv
;
1902 opp
.common
= dtp
->common
;
1903 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1904 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1905 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1906 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1907 if (dtp
->u
.p
.current_unit
== NULL
)
1911 /* Check the action. */
1913 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1915 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1916 "Cannot read from file opened for WRITE");
1920 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1922 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1923 "Cannot write to file opened for READ");
1927 dtp
->u
.p
.first_item
= 1;
1929 /* Check the format. */
1931 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1934 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1935 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1938 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1939 "Format present for UNFORMATTED data transfer");
1943 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1945 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1946 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1947 "A format cannot be specified with a namelist");
1949 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1950 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1952 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1953 "Missing format for FORMATTED data transfer");
1956 if (is_internal_unit (dtp
)
1957 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1959 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1960 "Internal file cannot be accessed by UNFORMATTED "
1965 /* Check the record number. */
1967 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1968 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1970 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1971 "Direct access data transfer requires record number");
1975 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1976 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1978 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1979 "Record number not allowed for sequential access "
1984 /* Process the ADVANCE option. */
1986 dtp
->u
.p
.advance_status
1987 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1988 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1989 "Bad ADVANCE parameter in data transfer statement");
1991 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1993 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1995 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1996 "ADVANCE specification conflicts with sequential "
2001 if (is_internal_unit (dtp
))
2003 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2004 "ADVANCE specification conflicts with internal file");
2008 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2009 != IOPARM_DT_HAS_FORMAT
)
2011 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2012 "ADVANCE specification requires an explicit format");
2019 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2021 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2023 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2024 "EOR specification requires an ADVANCE specification "
2029 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2030 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2032 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2033 "SIZE specification requires an ADVANCE "
2034 "specification of NO");
2039 { /* Write constraints. */
2040 if ((cf
& IOPARM_END
) != 0)
2042 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2043 "END specification cannot appear in a write "
2048 if ((cf
& IOPARM_EOR
) != 0)
2050 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2051 "EOR specification cannot appear in a write "
2056 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2058 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2059 "SIZE specification cannot appear in a write "
2065 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2066 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2068 /* Check the decimal mode. */
2069 dtp
->u
.p
.current_unit
->decimal_status
2070 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2071 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2072 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2075 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2076 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2078 /* Check the sign mode. */
2079 dtp
->u
.p
.sign_status
2080 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2081 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2082 "Bad SIGN parameter in data transfer statement");
2084 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2085 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2087 /* Check the blank mode. */
2088 dtp
->u
.p
.blank_status
2089 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2090 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2092 "Bad BLANK parameter in data transfer statement");
2094 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2095 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2097 /* Check the delim mode. */
2098 dtp
->u
.p
.current_unit
->delim_status
2099 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2100 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2101 delim_opt
, "Bad DELIM parameter in data transfer statement");
2103 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2104 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2106 /* Check the pad mode. */
2107 dtp
->u
.p
.current_unit
->pad_status
2108 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2109 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2110 "Bad PAD parameter in data transfer statement");
2112 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2113 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2115 /* Check the POS= specifier: that it is in range and that it is used with a
2116 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2118 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2120 if (is_stream_io (dtp
))
2125 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2126 "POS=specifier must be positive");
2130 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2132 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2133 "POS=specifier too large");
2137 dtp
->rec
= dtp
->pos
;
2139 if (dtp
->u
.p
.mode
== READING
)
2141 /* Required for compatibility between 4.3 and 4.4 runtime. Check
2142 to see if we might be reading what we wrote before */
2143 if (dtp
->u
.p
.current_unit
->mode
== WRITING
)
2145 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2146 flush(dtp
->u
.p
.current_unit
->s
);
2149 if (dtp
->pos
< file_length (dtp
->u
.p
.current_unit
->s
))
2150 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2153 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2155 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2156 flush (dtp
->u
.p
.current_unit
->s
);
2157 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1) == FAILURE
)
2159 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2162 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2167 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2168 "POS=specifier not allowed, "
2169 "Try OPEN with ACCESS='stream'");
2174 /* Sanity checks on the record number. */
2175 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2179 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2180 "Record number must be positive");
2184 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2186 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2187 "Record number too large");
2191 /* Check to see if we might be reading what we wrote before */
2193 if (dtp
->u
.p
.mode
== READING
2194 && dtp
->u
.p
.current_unit
->mode
== WRITING
2195 && !is_internal_unit (dtp
))
2197 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2198 flush(dtp
->u
.p
.current_unit
->s
);
2201 /* Check whether the record exists to be read. Only
2202 a partial record needs to exist. */
2204 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2205 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2207 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2208 "Non-existing record number");
2212 /* Position the file. */
2213 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2214 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2216 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2220 /* TODO: This is required to maintain compatibility between
2221 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2223 if (is_stream_io (dtp
))
2224 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2226 /* TODO: Un-comment this code when ABI changes from 4.3.
2227 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2229 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2230 "Record number not allowed for stream access "
2237 /* Overwriting an existing sequential file ?
2238 it is always safe to truncate the file on the first write */
2239 if (dtp
->u
.p
.mode
== WRITING
2240 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2241 && dtp
->u
.p
.current_unit
->last_record
== 0
2242 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2243 struncate(dtp
->u
.p
.current_unit
->s
);
2245 /* Bugware for badly written mixed C-Fortran I/O. */
2246 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2248 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2250 /* Set the maximum position reached from the previous I/O operation. This
2251 could be greater than zero from a previous non-advancing write. */
2252 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2257 /* Set up the subroutine that will handle the transfers. */
2261 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2262 dtp
->u
.p
.transfer
= unformatted_read
;
2265 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2266 dtp
->u
.p
.transfer
= list_formatted_read
;
2268 dtp
->u
.p
.transfer
= formatted_transfer
;
2273 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2274 dtp
->u
.p
.transfer
= unformatted_write
;
2277 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2278 dtp
->u
.p
.transfer
= list_formatted_write
;
2280 dtp
->u
.p
.transfer
= formatted_transfer
;
2284 /* Make sure that we don't do a read after a nonadvancing write. */
2288 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2290 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2291 "Cannot READ after a nonadvancing WRITE");
2297 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2298 dtp
->u
.p
.current_unit
->read_bad
= 1;
2301 /* Start the data transfer if we are doing a formatted transfer. */
2302 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2303 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2304 && dtp
->u
.p
.ionml
== NULL
)
2305 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2308 /* Initialize an array_loop_spec given the array descriptor. The function
2309 returns the index of the last element of the array, and also returns
2310 starting record, where the first I/O goes to (necessary in case of
2311 negative strides). */
2314 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2315 gfc_offset
*start_record
)
2317 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2326 for (i
=0; i
<rank
; i
++)
2328 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2329 ls
[i
].start
= desc
->dim
[i
].lbound
;
2330 ls
[i
].end
= desc
->dim
[i
].ubound
;
2331 ls
[i
].step
= desc
->dim
[i
].stride
;
2332 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2334 if (desc
->dim
[i
].stride
> 0)
2336 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2337 * desc
->dim
[i
].stride
;
2341 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2342 * desc
->dim
[i
].stride
;
2343 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2344 * desc
->dim
[i
].stride
;
2354 /* Determine the index to the next record in an internal unit array by
2355 by incrementing through the array_loop_spec. */
2358 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2366 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2371 if (ls
[i
].idx
> ls
[i
].end
)
2373 ls
[i
].idx
= ls
[i
].start
;
2379 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2389 /* Skip to the end of the current record, taking care of an optional
2390 record marker of size bytes. If the file is not seekable, we
2391 read chunks of size MAX_READ until we get to the right
2395 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2399 static const size_t MAX_READ
= 4096;
2402 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2403 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2406 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2408 new = file_position (dtp
->u
.p
.current_unit
->s
)
2409 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2411 /* Direct access files do not generate END conditions,
2413 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2414 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2417 { /* Seek by reading data. */
2418 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2421 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2422 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2424 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2426 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2430 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2437 /* Advance to the next record reading unformatted files, taking
2438 care of subrecords. If complete_record is nonzero, we loop
2439 until all subrecords are cleared. */
2442 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2446 bytes
= compile_options
.record_marker
== 0 ?
2447 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2452 /* Skip over tail */
2454 skip_record (dtp
, bytes
);
2456 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2464 static inline gfc_offset
2465 min_off (gfc_offset a
, gfc_offset b
)
2467 return (a
< b
? a
: b
);
2471 /* Space to the next record for read mode. */
2474 next_record_r (st_parameter_dt
*dtp
)
2481 switch (current_mode (dtp
))
2483 /* No records in unformatted STREAM I/O. */
2484 case UNFORMATTED_STREAM
:
2487 case UNFORMATTED_SEQUENTIAL
:
2488 next_record_r_unf (dtp
, 1);
2489 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2492 case FORMATTED_DIRECT
:
2493 case UNFORMATTED_DIRECT
:
2494 skip_record (dtp
, 0);
2497 case FORMATTED_STREAM
:
2498 case FORMATTED_SEQUENTIAL
:
2500 /* sf_read has already terminated input because of an '\n' */
2501 if (dtp
->u
.p
.sf_seen_eor
)
2503 dtp
->u
.p
.sf_seen_eor
= 0;
2507 if (is_internal_unit (dtp
))
2509 if (is_array_io (dtp
))
2513 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2516 /* Now seek to this record. */
2517 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2518 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2520 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2523 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2527 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2528 bytes_left
= min_off (bytes_left
,
2529 file_length (dtp
->u
.p
.current_unit
->s
)
2530 - file_position (dtp
->u
.p
.current_unit
->s
));
2531 if (sseek (dtp
->u
.p
.current_unit
->s
,
2532 file_position (dtp
->u
.p
.current_unit
->s
)
2533 + bytes_left
) == FAILURE
)
2535 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2538 dtp
->u
.p
.current_unit
->bytes_left
2539 = dtp
->u
.p
.current_unit
->recl
;
2545 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2547 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2553 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2557 if (is_stream_io (dtp
))
2558 dtp
->u
.p
.current_unit
->strm_pos
++;
2565 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2566 && !dtp
->u
.p
.namelist_mode
2567 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2568 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2569 file_position (dtp
->u
.p
.current_unit
->s
)))
2570 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2575 /* Small utility function to write a record marker, taking care of
2576 byte swapping and of choosing the correct size. */
2579 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2584 char p
[sizeof (GFC_INTEGER_8
)];
2586 if (compile_options
.record_marker
== 0)
2587 len
= sizeof (GFC_INTEGER_4
);
2589 len
= compile_options
.record_marker
;
2591 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2592 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2596 case sizeof (GFC_INTEGER_4
):
2598 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2601 case sizeof (GFC_INTEGER_8
):
2603 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2607 runtime_error ("Illegal value for record marker");
2615 case sizeof (GFC_INTEGER_4
):
2617 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2618 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2621 case sizeof (GFC_INTEGER_8
):
2623 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2624 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2628 runtime_error ("Illegal value for record marker");
2635 /* Position to the next (sub)record in write mode for
2636 unformatted sequential files. */
2639 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2641 gfc_offset c
, m
, m_write
;
2642 size_t record_marker
;
2644 /* Bytes written. */
2645 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2646 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2647 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2649 /* Write the length tail. If we finish a record containing
2650 subrecords, we write out the negative length. */
2652 if (dtp
->u
.p
.current_unit
->continued
)
2657 if (unlikely (write_us_marker (dtp
, m_write
) != 0))
2660 if (compile_options
.record_marker
== 0)
2661 record_marker
= sizeof (GFC_INTEGER_4
);
2663 record_marker
= compile_options
.record_marker
;
2665 /* Seek to the head and overwrite the bogus length with the real
2668 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2677 if (unlikely (write_us_marker (dtp
, m_write
) != 0))
2680 /* Seek past the end of the current record. */
2682 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
)
2689 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2694 /* Position to the next record in write mode. */
2697 next_record_w (st_parameter_dt
*dtp
, int done
)
2699 gfc_offset m
, record
, max_pos
;
2702 /* Flush and reset the format buffer. */
2703 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2705 /* Zero counters for X- and T-editing. */
2706 max_pos
= dtp
->u
.p
.max_pos
;
2707 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2709 switch (current_mode (dtp
))
2711 /* No records in unformatted STREAM I/O. */
2712 case UNFORMATTED_STREAM
:
2715 case FORMATTED_DIRECT
:
2716 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2719 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2720 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2725 case UNFORMATTED_DIRECT
:
2726 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2728 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2729 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2734 case UNFORMATTED_SEQUENTIAL
:
2735 next_record_w_unf (dtp
, 0);
2736 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2739 case FORMATTED_STREAM
:
2740 case FORMATTED_SEQUENTIAL
:
2742 if (is_internal_unit (dtp
))
2744 if (is_array_io (dtp
))
2748 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2750 /* If the farthest position reached is greater than current
2751 position, adjust the position and set length to pad out
2752 whats left. Otherwise just pad whats left.
2753 (for character array unit) */
2754 m
= dtp
->u
.p
.current_unit
->recl
2755 - dtp
->u
.p
.current_unit
->bytes_left
;
2758 length
= (int) (max_pos
- m
);
2759 if (sseek (dtp
->u
.p
.current_unit
->s
,
2760 file_position (dtp
->u
.p
.current_unit
->s
)
2761 + length
) == FAILURE
)
2763 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2766 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2769 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2771 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2775 /* Now that the current record has been padded out,
2776 determine where the next record in the array is. */
2777 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2780 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2782 /* Now seek to this record */
2783 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2785 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2787 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2791 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2797 /* If this is the last call to next_record move to the farthest
2798 position reached and set length to pad out the remainder
2799 of the record. (for character scaler unit) */
2802 m
= dtp
->u
.p
.current_unit
->recl
2803 - dtp
->u
.p
.current_unit
->bytes_left
;
2806 length
= (int) (max_pos
- m
);
2807 if (sseek (dtp
->u
.p
.current_unit
->s
,
2808 file_position (dtp
->u
.p
.current_unit
->s
)
2809 + length
) == FAILURE
)
2811 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2814 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2817 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2820 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2822 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2830 const char crlf
[] = "\r\n";
2837 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2840 if (is_stream_io (dtp
))
2842 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2843 if (dtp
->u
.p
.current_unit
->strm_pos
2844 < file_length (dtp
->u
.p
.current_unit
->s
))
2845 struncate (dtp
->u
.p
.current_unit
->s
);
2852 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2857 /* Position to the next record, which means moving to the end of the
2858 current record. This can happen under several different
2859 conditions. If the done flag is not set, we get ready to process
2863 next_record (st_parameter_dt
*dtp
, int done
)
2865 gfc_offset fp
; /* File position. */
2867 dtp
->u
.p
.current_unit
->read_bad
= 0;
2869 if (dtp
->u
.p
.mode
== READING
)
2870 next_record_r (dtp
);
2872 next_record_w (dtp
, done
);
2874 if (!is_stream_io (dtp
))
2876 /* Keep position up to date for INQUIRE */
2878 update_position (dtp
->u
.p
.current_unit
);
2880 dtp
->u
.p
.current_unit
->current_record
= 0;
2881 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2883 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2884 /* Calculate next record, rounding up partial records. */
2885 dtp
->u
.p
.current_unit
->last_record
=
2886 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2887 dtp
->u
.p
.current_unit
->recl
;
2890 dtp
->u
.p
.current_unit
->last_record
++;
2898 /* Finalize the current data transfer. For a nonadvancing transfer,
2899 this means advancing to the next record. For internal units close the
2900 stream associated with the unit. */
2903 finalize_transfer (st_parameter_dt
*dtp
)
2906 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2908 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2909 *dtp
->size
= dtp
->u
.p
.size_used
;
2911 if (dtp
->u
.p
.eor_condition
)
2913 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2917 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2920 if ((dtp
->u
.p
.ionml
!= NULL
)
2921 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2923 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2924 namelist_read (dtp
);
2926 namelist_write (dtp
);
2929 dtp
->u
.p
.transfer
= NULL
;
2930 if (dtp
->u
.p
.current_unit
== NULL
)
2933 dtp
->u
.p
.eof_jump
= &eof_jump
;
2934 if (setjmp (eof_jump
))
2936 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2940 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2942 finish_list_read (dtp
);
2943 sfree (dtp
->u
.p
.current_unit
->s
);
2947 if (dtp
->u
.p
.mode
== WRITING
)
2948 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2949 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2951 if (is_stream_io (dtp
))
2953 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2954 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2955 next_record (dtp
, 1);
2957 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2958 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2960 flush (dtp
->u
.p
.current_unit
->s
);
2961 sfree (dtp
->u
.p
.current_unit
->s
);
2966 dtp
->u
.p
.current_unit
->current_record
= 0;
2968 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2970 dtp
->u
.p
.seen_dollar
= 0;
2971 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2972 sfree (dtp
->u
.p
.current_unit
->s
);
2976 /* For non-advancing I/O, save the current maximum position for use in the
2977 next I/O operation if needed. */
2978 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2980 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2981 - dtp
->u
.p
.current_unit
->bytes_left
);
2982 dtp
->u
.p
.current_unit
->saved_pos
=
2983 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2984 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2985 flush (dtp
->u
.p
.current_unit
->s
);
2989 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2991 next_record (dtp
, 1);
2992 sfree (dtp
->u
.p
.current_unit
->s
);
2995 /* Transfer function for IOLENGTH. It doesn't actually do any
2996 data transfer, it just updates the length counter. */
2999 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3000 void *dest
__attribute__ ((unused
)),
3001 int kind
__attribute__((unused
)),
3002 size_t size
, size_t nelems
)
3004 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3005 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
3009 /* Initialize the IOLENGTH data transfer. This function is in essence
3010 a very much simplified version of data_transfer_init(), because it
3011 doesn't have to deal with units at all. */
3014 iolength_transfer_init (st_parameter_dt
*dtp
)
3016 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3019 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3021 /* Set up the subroutine that will handle the transfers. */
3023 dtp
->u
.p
.transfer
= iolength_transfer
;
3027 /* Library entry point for the IOLENGTH form of the INQUIRE
3028 statement. The IOLENGTH form requires no I/O to be performed, but
3029 it must still be a runtime library call so that we can determine
3030 the iolength for dynamic arrays and such. */
3032 extern void st_iolength (st_parameter_dt
*);
3033 export_proto(st_iolength
);
3036 st_iolength (st_parameter_dt
*dtp
)
3038 library_start (&dtp
->common
);
3039 iolength_transfer_init (dtp
);
3042 extern void st_iolength_done (st_parameter_dt
*);
3043 export_proto(st_iolength_done
);
3046 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3049 if (dtp
->u
.p
.scratch
!= NULL
)
3050 free_mem (dtp
->u
.p
.scratch
);
3055 /* The READ statement. */
3057 extern void st_read (st_parameter_dt
*);
3058 export_proto(st_read
);
3061 st_read (st_parameter_dt
*dtp
)
3063 library_start (&dtp
->common
);
3065 data_transfer_init (dtp
, 1);
3067 /* Handle complications dealing with the endfile record. */
3069 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3070 switch (dtp
->u
.p
.current_unit
->endfile
)
3076 if (!is_internal_unit (dtp
))
3078 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3079 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3080 dtp
->u
.p
.current_unit
->current_record
= 0;
3085 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3086 dtp
->u
.p
.current_unit
->current_record
= 0;
3091 extern void st_read_done (st_parameter_dt
*);
3092 export_proto(st_read_done
);
3095 st_read_done (st_parameter_dt
*dtp
)
3097 finalize_transfer (dtp
);
3098 free_format_data (dtp
);
3100 if (dtp
->u
.p
.scratch
!= NULL
)
3101 free_mem (dtp
->u
.p
.scratch
);
3102 if (dtp
->u
.p
.current_unit
!= NULL
)
3103 unlock_unit (dtp
->u
.p
.current_unit
);
3105 free_internal_unit (dtp
);
3110 extern void st_write (st_parameter_dt
*);
3111 export_proto(st_write
);
3114 st_write (st_parameter_dt
*dtp
)
3116 library_start (&dtp
->common
);
3117 data_transfer_init (dtp
, 0);
3120 extern void st_write_done (st_parameter_dt
*);
3121 export_proto(st_write_done
);
3124 st_write_done (st_parameter_dt
*dtp
)
3126 finalize_transfer (dtp
);
3128 /* Deal with endfile conditions associated with sequential files. */
3130 if (dtp
->u
.p
.current_unit
!= NULL
3131 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3132 switch (dtp
->u
.p
.current_unit
->endfile
)
3134 case AT_ENDFILE
: /* Remain at the endfile record. */
3138 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3142 /* Get rid of whatever is after this record. */
3143 if (!is_internal_unit (dtp
))
3145 flush (dtp
->u
.p
.current_unit
->s
);
3146 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3147 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3149 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3153 free_format_data (dtp
);
3155 if (dtp
->u
.p
.scratch
!= NULL
)
3156 free_mem (dtp
->u
.p
.scratch
);
3157 if (dtp
->u
.p
.current_unit
!= NULL
)
3158 unlock_unit (dtp
->u
.p
.current_unit
);
3160 free_internal_unit (dtp
);
3166 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3168 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3173 /* Receives the scalar information for namelist objects and stores it
3174 in a linked list of namelist_info types. */
3176 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3177 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3178 export_proto(st_set_nml_var
);
3182 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3183 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3184 GFC_INTEGER_4 dtype
)
3186 namelist_info
*t1
= NULL
;
3188 size_t var_name_len
= strlen (var_name
);
3190 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3192 nml
->mem_pos
= var_addr
;
3194 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3195 memcpy (nml
->var_name
, var_name
, var_name_len
);
3196 nml
->var_name
[var_name_len
] = '\0';
3198 nml
->len
= (int) len
;
3199 nml
->string_length
= (index_type
) string_length
;
3201 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3202 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3203 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3205 if (nml
->var_rank
> 0)
3207 nml
->dim
= (descriptor_dimension
*)
3208 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3209 nml
->ls
= (array_loop_spec
*)
3210 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3220 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3222 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3223 dtp
->u
.p
.ionml
= nml
;
3227 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3232 /* Store the dimensional information for the namelist object. */
3233 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3234 index_type
, index_type
,
3236 export_proto(st_set_nml_var_dim
);
3239 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3240 index_type stride
, index_type lbound
,
3243 namelist_info
* nml
;
3248 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3250 nml
->dim
[n
].stride
= stride
;
3251 nml
->dim
[n
].lbound
= lbound
;
3252 nml
->dim
[n
].ubound
= ubound
;
3255 /* Reverse memcpy - used for byte swapping. */
3257 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3263 s
= (char *) src
+ n
- 1;
3265 /* Write with ascending order - this is likely faster
3266 on modern architectures because of write combining. */