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)
1225 if (f
->u
.real
.d
== 0)
1226 write_real (dtp
, p
, kind
);
1228 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1231 write_d (dtp
, f
, p
, kind
);
1235 internal_error (&dtp
->common
,
1236 "formatted_transfer(): Bad type");
1242 consume_data_flag
= 0;
1243 if (dtp
->u
.p
.mode
== READING
)
1245 format_error (dtp
, f
, "Constant string in input format");
1248 write_constant_string (dtp
, f
);
1251 /* Format codes that don't transfer data. */
1254 consume_data_flag
= 0;
1256 dtp
->u
.p
.skips
+= f
->u
.n
;
1257 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1258 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1260 /* Writes occur just before the switch on f->format, above, so
1261 that trailing blanks are suppressed, unless we are doing a
1262 non-advancing write in which case we want to output the blanks
1264 if (dtp
->u
.p
.mode
== WRITING
1265 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1267 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1268 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1271 if (dtp
->u
.p
.mode
== READING
)
1272 read_x (dtp
, f
->u
.n
);
1278 consume_data_flag
= 0;
1280 if (f
->format
== FMT_TL
)
1283 /* Handle the special case when no bytes have been used yet.
1284 Cannot go below zero. */
1285 if (bytes_used
== 0)
1287 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1288 dtp
->u
.p
.skips
-= f
->u
.n
;
1289 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1292 pos
= bytes_used
- f
->u
.n
;
1296 if (dtp
->u
.p
.mode
== READING
)
1299 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1302 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1303 left tab limit. We do not check if the position has gone
1304 beyond the end of record because a subsequent tab could
1305 bring us back again. */
1306 pos
= pos
< 0 ? 0 : pos
;
1308 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1309 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1310 + pos
- dtp
->u
.p
.max_pos
;
1311 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1312 ? 0 : dtp
->u
.p
.pending_spaces
;
1314 if (dtp
->u
.p
.skips
== 0)
1317 /* Writes occur just before the switch on f->format, above, so that
1318 trailing blanks are suppressed. */
1319 if (dtp
->u
.p
.mode
== READING
)
1321 /* Adjust everything for end-of-record condition */
1322 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1324 if (dtp
->u
.p
.sf_seen_eor
== 2)
1326 /* The EOR was a CRLF (two bytes wide). */
1327 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1328 dtp
->u
.p
.skips
-= 2;
1332 /* The EOR marker was only one byte wide. */
1333 dtp
->u
.p
.current_unit
->bytes_left
--;
1337 dtp
->u
.p
.sf_seen_eor
= 0;
1339 if (dtp
->u
.p
.skips
< 0)
1341 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1342 dtp
->u
.p
.current_unit
->bytes_left
1343 -= (gfc_offset
) dtp
->u
.p
.skips
;
1344 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1347 read_x (dtp
, dtp
->u
.p
.skips
);
1353 consume_data_flag
= 0;
1354 dtp
->u
.p
.sign_status
= SIGN_S
;
1358 consume_data_flag
= 0;
1359 dtp
->u
.p
.sign_status
= SIGN_SS
;
1363 consume_data_flag
= 0;
1364 dtp
->u
.p
.sign_status
= SIGN_SP
;
1368 consume_data_flag
= 0 ;
1369 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1373 consume_data_flag
= 0;
1374 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1378 consume_data_flag
= 0;
1379 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1383 consume_data_flag
= 0;
1384 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1388 consume_data_flag
= 0;
1389 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1393 consume_data_flag
= 0;
1394 dtp
->u
.p
.seen_dollar
= 1;
1398 consume_data_flag
= 0;
1399 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1400 next_record (dtp
, 0);
1404 /* A colon descriptor causes us to exit this loop (in
1405 particular preventing another / descriptor from being
1406 processed) unless there is another data item to be
1408 consume_data_flag
= 0;
1414 internal_error (&dtp
->common
, "Bad format node");
1417 /* Free a buffer that we had to allocate during a sequential
1418 formatted read of a block that was larger than the static
1421 if (dtp
->u
.p
.line_buffer
!= scratch
)
1423 free_mem (dtp
->u
.p
.line_buffer
);
1424 dtp
->u
.p
.line_buffer
= scratch
;
1427 /* Adjust the item count and data pointer. */
1429 if ((consume_data_flag
> 0) && (n
> 0))
1432 p
= ((char *) p
) + size
;
1435 if (dtp
->u
.p
.mode
== READING
)
1438 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1439 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1445 /* Come here when we need a data descriptor but don't have one. We
1446 push the current format node back onto the input, then return and
1447 let the user program call us back with the data. */
1449 unget_format (dtp
, f
);
1453 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1454 size_t size
, size_t nelems
)
1460 size_t stride
= type
== BT_CHARACTER
?
1461 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1462 /* Big loop over all the elements. */
1463 for (elem
= 0; elem
< nelems
; elem
++)
1465 dtp
->u
.p
.item_count
++;
1466 formatted_transfer_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1472 /* Data transfer entry points. The type of the data entity is
1473 implicit in the subroutine call. This prevents us from having to
1474 share a common enum with the compiler. */
1477 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1479 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1481 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1486 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1489 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1491 size
= size_from_real_kind (kind
);
1492 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1497 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1499 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1501 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1506 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1508 static char *empty_string
[0];
1510 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1513 /* Strings of zero length can have p == NULL, which confuses the
1514 transfer routines into thinking we need more data elements. To avoid
1515 this, we give them a nice pointer. */
1516 if (len
== 0 && p
== NULL
)
1519 /* Set kind here to 1. */
1520 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1524 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1526 static char *empty_string
[0];
1528 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1531 /* Strings of zero length can have p == NULL, which confuses the
1532 transfer routines into thinking we need more data elements. To avoid
1533 this, we give them a nice pointer. */
1534 if (len
== 0 && p
== NULL
)
1537 /* Here we pass the actual kind value. */
1538 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1543 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1546 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1548 size
= size_from_complex_kind (kind
);
1549 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1554 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1555 gfc_charlen_type charlen
)
1557 index_type count
[GFC_MAX_DIMENSIONS
];
1558 index_type extent
[GFC_MAX_DIMENSIONS
];
1559 index_type stride
[GFC_MAX_DIMENSIONS
];
1560 index_type stride0
, rank
, size
, type
, n
;
1565 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1568 type
= GFC_DESCRIPTOR_TYPE (desc
);
1569 size
= GFC_DESCRIPTOR_SIZE (desc
);
1571 /* FIXME: What a kludge: Array descriptors and the IO library use
1572 different enums for types. */
1575 case GFC_DTYPE_UNKNOWN
:
1576 iotype
= BT_NULL
; /* Is this correct? */
1578 case GFC_DTYPE_INTEGER
:
1579 iotype
= BT_INTEGER
;
1581 case GFC_DTYPE_LOGICAL
:
1582 iotype
= BT_LOGICAL
;
1584 case GFC_DTYPE_REAL
:
1587 case GFC_DTYPE_COMPLEX
:
1588 iotype
= BT_COMPLEX
;
1590 case GFC_DTYPE_CHARACTER
:
1591 iotype
= BT_CHARACTER
;
1594 case GFC_DTYPE_DERIVED
:
1595 internal_error (&dtp
->common
,
1596 "Derived type I/O should have been handled via the frontend.");
1599 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1602 rank
= GFC_DESCRIPTOR_RANK (desc
);
1603 for (n
= 0; n
< rank
; n
++)
1606 stride
[n
] = iotype
== BT_CHARACTER
?
1607 desc
->dim
[n
].stride
* GFC_SIZE_OF_CHAR_KIND(kind
) :
1608 desc
->dim
[n
].stride
;
1609 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1611 /* If the extent of even one dimension is zero, then the entire
1612 array section contains zero elements, so we return after writing
1613 a zero array record. */
1618 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1623 stride0
= stride
[0];
1625 /* If the innermost dimension has stride 1, we can do the transfer
1626 in contiguous chunks. */
1632 data
= GFC_DESCRIPTOR_DATA (desc
);
1636 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1637 data
+= stride0
* size
* tsize
;
1640 while (count
[n
] == extent
[n
])
1643 data
-= stride
[n
] * extent
[n
] * size
;
1653 data
+= stride
[n
] * size
;
1660 /* Preposition a sequential unformatted file while reading. */
1663 us_read (st_parameter_dt
*dtp
, int continued
)
1670 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1673 if (compile_options
.record_marker
== 0)
1674 n
= sizeof (GFC_INTEGER_4
);
1676 n
= compile_options
.record_marker
;
1680 if (unlikely (sread (dtp
->u
.p
.current_unit
->s
, &i
, &n
) != 0))
1682 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1688 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1689 return; /* end of file */
1692 if (unlikely (n
!= nr
))
1694 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1698 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1699 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1703 case sizeof(GFC_INTEGER_4
):
1704 memcpy (&i4
, &i
, sizeof (i4
));
1708 case sizeof(GFC_INTEGER_8
):
1709 memcpy (&i8
, &i
, sizeof (i8
));
1714 runtime_error ("Illegal value for record marker");
1721 case sizeof(GFC_INTEGER_4
):
1722 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1726 case sizeof(GFC_INTEGER_8
):
1727 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1732 runtime_error ("Illegal value for record marker");
1738 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1739 dtp
->u
.p
.current_unit
->continued
= 0;
1743 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1744 dtp
->u
.p
.current_unit
->continued
= 1;
1748 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1752 /* Preposition a sequential unformatted file while writing. This
1753 amount to writing a bogus length that will be filled in later. */
1756 us_write (st_parameter_dt
*dtp
, int continued
)
1763 if (compile_options
.record_marker
== 0)
1764 nbytes
= sizeof (GFC_INTEGER_4
);
1766 nbytes
= compile_options
.record_marker
;
1768 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1769 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1771 /* For sequential unformatted, if RECL= was not specified in the OPEN
1772 we write until we have more bytes than can fit in the subrecord
1773 markers, then we write a new subrecord. */
1775 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1776 dtp
->u
.p
.current_unit
->recl_subrecord
;
1777 dtp
->u
.p
.current_unit
->continued
= continued
;
1781 /* Position to the next record prior to transfer. We are assumed to
1782 be before the next record. We also calculate the bytes in the next
1786 pre_position (st_parameter_dt
*dtp
)
1788 if (dtp
->u
.p
.current_unit
->current_record
)
1789 return; /* Already positioned. */
1791 switch (current_mode (dtp
))
1793 case FORMATTED_STREAM
:
1794 case UNFORMATTED_STREAM
:
1795 /* There are no records with stream I/O. If the position was specified
1796 data_transfer_init has already positioned the file. If no position
1797 was specified, we continue from where we last left off. I.e.
1798 there is nothing to do here. */
1801 case UNFORMATTED_SEQUENTIAL
:
1802 if (dtp
->u
.p
.mode
== READING
)
1809 case FORMATTED_SEQUENTIAL
:
1810 case FORMATTED_DIRECT
:
1811 case UNFORMATTED_DIRECT
:
1812 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1816 dtp
->u
.p
.current_unit
->current_record
= 1;
1820 /* Initialize things for a data transfer. This code is common for
1821 both reading and writing. */
1824 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1826 unit_flags u_flags
; /* Used for creating a unit if needed. */
1827 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1828 namelist_info
*ionml
;
1830 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1832 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1834 dtp
->u
.p
.ionml
= ionml
;
1835 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1837 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1840 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1841 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1843 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1844 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1845 { /* Open the unit with some default flags. */
1846 st_parameter_open opp
;
1849 if (dtp
->common
.unit
< 0)
1851 close_unit (dtp
->u
.p
.current_unit
);
1852 dtp
->u
.p
.current_unit
= NULL
;
1853 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1854 "Bad unit number in OPEN statement");
1857 memset (&u_flags
, '\0', sizeof (u_flags
));
1858 u_flags
.access
= ACCESS_SEQUENTIAL
;
1859 u_flags
.action
= ACTION_READWRITE
;
1861 /* Is it unformatted? */
1862 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1863 | IOPARM_DT_IONML_SET
)))
1864 u_flags
.form
= FORM_UNFORMATTED
;
1866 u_flags
.form
= FORM_UNSPECIFIED
;
1868 u_flags
.delim
= DELIM_UNSPECIFIED
;
1869 u_flags
.blank
= BLANK_UNSPECIFIED
;
1870 u_flags
.pad
= PAD_UNSPECIFIED
;
1871 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1872 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1873 u_flags
.async
= ASYNC_UNSPECIFIED
;
1874 u_flags
.round
= ROUND_UNSPECIFIED
;
1875 u_flags
.sign
= SIGN_UNSPECIFIED
;
1877 u_flags
.status
= STATUS_UNKNOWN
;
1879 conv
= get_unformatted_convert (dtp
->common
.unit
);
1881 if (conv
== GFC_CONVERT_NONE
)
1882 conv
= compile_options
.convert
;
1884 /* We use big_endian, which is 0 on little-endian machines
1885 and 1 on big-endian machines. */
1888 case GFC_CONVERT_NATIVE
:
1889 case GFC_CONVERT_SWAP
:
1892 case GFC_CONVERT_BIG
:
1893 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1896 case GFC_CONVERT_LITTLE
:
1897 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1901 internal_error (&opp
.common
, "Illegal value for CONVERT");
1905 u_flags
.convert
= conv
;
1907 opp
.common
= dtp
->common
;
1908 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1909 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1910 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1911 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1912 if (dtp
->u
.p
.current_unit
== NULL
)
1916 /* Check the action. */
1918 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1920 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1921 "Cannot read from file opened for WRITE");
1925 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1927 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1928 "Cannot write to file opened for READ");
1932 dtp
->u
.p
.first_item
= 1;
1934 /* Check the format. */
1936 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1939 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1940 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1943 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1944 "Format present for UNFORMATTED data transfer");
1948 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1950 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1951 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1952 "A format cannot be specified with a namelist");
1954 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1955 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1957 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1958 "Missing format for FORMATTED data transfer");
1961 if (is_internal_unit (dtp
)
1962 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1964 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1965 "Internal file cannot be accessed by UNFORMATTED "
1970 /* Check the record or position number. */
1972 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1973 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1975 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1976 "Direct access data transfer requires record number");
1980 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1981 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1983 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1984 "Record number not allowed for sequential access "
1989 /* Process the ADVANCE option. */
1991 dtp
->u
.p
.advance_status
1992 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1993 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1994 "Bad ADVANCE parameter in data transfer statement");
1996 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1998 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2000 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2001 "ADVANCE specification conflicts with sequential "
2006 if (is_internal_unit (dtp
))
2008 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2009 "ADVANCE specification conflicts with internal file");
2013 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2014 != IOPARM_DT_HAS_FORMAT
)
2016 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2017 "ADVANCE specification requires an explicit format");
2024 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2026 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2028 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2029 "EOR specification requires an ADVANCE specification "
2034 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2035 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2037 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2038 "SIZE specification requires an ADVANCE "
2039 "specification of NO");
2044 { /* Write constraints. */
2045 if ((cf
& IOPARM_END
) != 0)
2047 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2048 "END specification cannot appear in a write "
2053 if ((cf
& IOPARM_EOR
) != 0)
2055 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2056 "EOR specification cannot appear in a write "
2061 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2063 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2064 "SIZE specification cannot appear in a write "
2070 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2071 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2073 /* Check the decimal mode. */
2074 dtp
->u
.p
.current_unit
->decimal_status
2075 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2076 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2077 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2080 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2081 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2083 /* Check the sign mode. */
2084 dtp
->u
.p
.sign_status
2085 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2086 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2087 "Bad SIGN parameter in data transfer statement");
2089 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2090 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2092 /* Check the blank mode. */
2093 dtp
->u
.p
.blank_status
2094 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2095 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2097 "Bad BLANK parameter in data transfer statement");
2099 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2100 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2102 /* Check the delim mode. */
2103 dtp
->u
.p
.current_unit
->delim_status
2104 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2105 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2106 delim_opt
, "Bad DELIM parameter in data transfer statement");
2108 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2109 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2111 /* Check the pad mode. */
2112 dtp
->u
.p
.current_unit
->pad_status
2113 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2114 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2115 "Bad PAD parameter in data transfer statement");
2117 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2118 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2120 /* Sanity checks on the record number. */
2121 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2125 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2126 "Record number must be positive");
2130 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2132 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2133 "Record number too large");
2137 /* Check to see if we might be reading what we wrote before */
2139 if (dtp
->u
.p
.mode
== READING
2140 && dtp
->u
.p
.current_unit
->mode
== WRITING
2141 && !is_internal_unit (dtp
))
2143 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2144 flush(dtp
->u
.p
.current_unit
->s
);
2147 /* Check whether the record exists to be read. Only
2148 a partial record needs to exist. */
2150 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2151 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2153 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2154 "Non-existing record number");
2158 /* Position the file. */
2159 if (!is_stream_io (dtp
))
2161 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2162 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2164 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2170 if (dtp
->u
.p
.current_unit
->strm_pos
!= dtp
->rec
)
2172 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2173 flush (dtp
->u
.p
.current_unit
->s
);
2174 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->rec
- 1) == FAILURE
)
2176 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2179 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2185 /* Overwriting an existing sequential file ?
2186 it is always safe to truncate the file on the first write */
2187 if (dtp
->u
.p
.mode
== WRITING
2188 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2189 && dtp
->u
.p
.current_unit
->last_record
== 0
2190 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2191 struncate(dtp
->u
.p
.current_unit
->s
);
2193 /* Bugware for badly written mixed C-Fortran I/O. */
2194 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2196 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2198 /* Set the maximum position reached from the previous I/O operation. This
2199 could be greater than zero from a previous non-advancing write. */
2200 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2205 /* Set up the subroutine that will handle the transfers. */
2209 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2210 dtp
->u
.p
.transfer
= unformatted_read
;
2213 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2214 dtp
->u
.p
.transfer
= list_formatted_read
;
2216 dtp
->u
.p
.transfer
= formatted_transfer
;
2221 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2222 dtp
->u
.p
.transfer
= unformatted_write
;
2225 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2226 dtp
->u
.p
.transfer
= list_formatted_write
;
2228 dtp
->u
.p
.transfer
= formatted_transfer
;
2232 /* Make sure that we don't do a read after a nonadvancing write. */
2236 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2238 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2239 "Cannot READ after a nonadvancing WRITE");
2245 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2246 dtp
->u
.p
.current_unit
->read_bad
= 1;
2249 /* Start the data transfer if we are doing a formatted transfer. */
2250 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2251 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2252 && dtp
->u
.p
.ionml
== NULL
)
2253 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2256 /* Initialize an array_loop_spec given the array descriptor. The function
2257 returns the index of the last element of the array, and also returns
2258 starting record, where the first I/O goes to (necessary in case of
2259 negative strides). */
2262 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2263 gfc_offset
*start_record
)
2265 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2274 for (i
=0; i
<rank
; i
++)
2276 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2277 ls
[i
].start
= desc
->dim
[i
].lbound
;
2278 ls
[i
].end
= desc
->dim
[i
].ubound
;
2279 ls
[i
].step
= desc
->dim
[i
].stride
;
2280 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2282 if (desc
->dim
[i
].stride
> 0)
2284 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2285 * desc
->dim
[i
].stride
;
2289 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2290 * desc
->dim
[i
].stride
;
2291 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2292 * desc
->dim
[i
].stride
;
2302 /* Determine the index to the next record in an internal unit array by
2303 by incrementing through the array_loop_spec. */
2306 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2314 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2319 if (ls
[i
].idx
> ls
[i
].end
)
2321 ls
[i
].idx
= ls
[i
].start
;
2327 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2337 /* Skip to the end of the current record, taking care of an optional
2338 record marker of size bytes. If the file is not seekable, we
2339 read chunks of size MAX_READ until we get to the right
2343 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2347 static const size_t MAX_READ
= 4096;
2350 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2351 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2354 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2356 new = file_position (dtp
->u
.p
.current_unit
->s
)
2357 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2359 /* Direct access files do not generate END conditions,
2361 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2362 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2365 { /* Seek by reading data. */
2366 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2369 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2370 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2372 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2374 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2378 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2385 /* Advance to the next record reading unformatted files, taking
2386 care of subrecords. If complete_record is nonzero, we loop
2387 until all subrecords are cleared. */
2390 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2394 bytes
= compile_options
.record_marker
== 0 ?
2395 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2400 /* Skip over tail */
2402 skip_record (dtp
, bytes
);
2404 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2412 static inline gfc_offset
2413 min_off (gfc_offset a
, gfc_offset b
)
2415 return (a
< b
? a
: b
);
2419 /* Space to the next record for read mode. */
2422 next_record_r (st_parameter_dt
*dtp
)
2429 switch (current_mode (dtp
))
2431 /* No records in unformatted STREAM I/O. */
2432 case UNFORMATTED_STREAM
:
2435 case UNFORMATTED_SEQUENTIAL
:
2436 next_record_r_unf (dtp
, 1);
2437 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2440 case FORMATTED_DIRECT
:
2441 case UNFORMATTED_DIRECT
:
2442 skip_record (dtp
, 0);
2445 case FORMATTED_STREAM
:
2446 case FORMATTED_SEQUENTIAL
:
2448 /* sf_read has already terminated input because of an '\n' */
2449 if (dtp
->u
.p
.sf_seen_eor
)
2451 dtp
->u
.p
.sf_seen_eor
= 0;
2455 if (is_internal_unit (dtp
))
2457 if (is_array_io (dtp
))
2461 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2464 /* Now seek to this record. */
2465 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2466 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2468 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2471 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2475 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2476 bytes_left
= min_off (bytes_left
,
2477 file_length (dtp
->u
.p
.current_unit
->s
)
2478 - file_position (dtp
->u
.p
.current_unit
->s
));
2479 if (sseek (dtp
->u
.p
.current_unit
->s
,
2480 file_position (dtp
->u
.p
.current_unit
->s
)
2481 + bytes_left
) == FAILURE
)
2483 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2486 dtp
->u
.p
.current_unit
->bytes_left
2487 = dtp
->u
.p
.current_unit
->recl
;
2493 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2495 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2501 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2505 if (is_stream_io (dtp
))
2506 dtp
->u
.p
.current_unit
->strm_pos
++;
2513 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2514 && !dtp
->u
.p
.namelist_mode
2515 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2516 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2517 file_position (dtp
->u
.p
.current_unit
->s
)))
2518 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2523 /* Small utility function to write a record marker, taking care of
2524 byte swapping and of choosing the correct size. */
2527 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2532 char p
[sizeof (GFC_INTEGER_8
)];
2534 if (compile_options
.record_marker
== 0)
2535 len
= sizeof (GFC_INTEGER_4
);
2537 len
= compile_options
.record_marker
;
2539 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2540 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2544 case sizeof (GFC_INTEGER_4
):
2546 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2549 case sizeof (GFC_INTEGER_8
):
2551 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2555 runtime_error ("Illegal value for record marker");
2563 case sizeof (GFC_INTEGER_4
):
2565 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2566 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2569 case sizeof (GFC_INTEGER_8
):
2571 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2572 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2576 runtime_error ("Illegal value for record marker");
2583 /* Position to the next (sub)record in write mode for
2584 unformatted sequential files. */
2587 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2589 gfc_offset c
, m
, m_write
;
2590 size_t record_marker
;
2592 /* Bytes written. */
2593 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2594 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2595 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2597 /* Write the length tail. If we finish a record containing
2598 subrecords, we write out the negative length. */
2600 if (dtp
->u
.p
.current_unit
->continued
)
2605 if (unlikely (write_us_marker (dtp
, m_write
) != 0))
2608 if (compile_options
.record_marker
== 0)
2609 record_marker
= sizeof (GFC_INTEGER_4
);
2611 record_marker
= compile_options
.record_marker
;
2613 /* Seek to the head and overwrite the bogus length with the real
2616 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2625 if (unlikely (write_us_marker (dtp
, m_write
) != 0))
2628 /* Seek past the end of the current record. */
2630 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
)
2637 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2642 /* Position to the next record in write mode. */
2645 next_record_w (st_parameter_dt
*dtp
, int done
)
2647 gfc_offset m
, record
, max_pos
;
2650 /* Flush and reset the format buffer. */
2651 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2653 /* Zero counters for X- and T-editing. */
2654 max_pos
= dtp
->u
.p
.max_pos
;
2655 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2657 switch (current_mode (dtp
))
2659 /* No records in unformatted STREAM I/O. */
2660 case UNFORMATTED_STREAM
:
2663 case FORMATTED_DIRECT
:
2664 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2667 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2668 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2673 case UNFORMATTED_DIRECT
:
2674 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2676 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2677 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2682 case UNFORMATTED_SEQUENTIAL
:
2683 next_record_w_unf (dtp
, 0);
2684 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2687 case FORMATTED_STREAM
:
2688 case FORMATTED_SEQUENTIAL
:
2690 if (is_internal_unit (dtp
))
2692 if (is_array_io (dtp
))
2696 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2698 /* If the farthest position reached is greater than current
2699 position, adjust the position and set length to pad out
2700 whats left. Otherwise just pad whats left.
2701 (for character array unit) */
2702 m
= dtp
->u
.p
.current_unit
->recl
2703 - dtp
->u
.p
.current_unit
->bytes_left
;
2706 length
= (int) (max_pos
- m
);
2707 if (sseek (dtp
->u
.p
.current_unit
->s
,
2708 file_position (dtp
->u
.p
.current_unit
->s
)
2709 + length
) == FAILURE
)
2711 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2714 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2717 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2719 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2723 /* Now that the current record has been padded out,
2724 determine where the next record in the array is. */
2725 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2728 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2730 /* Now seek to this record */
2731 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2733 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2735 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2739 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2745 /* If this is the last call to next_record move to the farthest
2746 position reached and set length to pad out the remainder
2747 of the record. (for character scaler unit) */
2750 m
= dtp
->u
.p
.current_unit
->recl
2751 - dtp
->u
.p
.current_unit
->bytes_left
;
2754 length
= (int) (max_pos
- m
);
2755 if (sseek (dtp
->u
.p
.current_unit
->s
,
2756 file_position (dtp
->u
.p
.current_unit
->s
)
2757 + length
) == FAILURE
)
2759 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2762 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2765 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2768 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2770 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2778 const char crlf
[] = "\r\n";
2785 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2788 if (is_stream_io (dtp
))
2790 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2791 if (dtp
->u
.p
.current_unit
->strm_pos
2792 < file_length (dtp
->u
.p
.current_unit
->s
))
2793 struncate (dtp
->u
.p
.current_unit
->s
);
2800 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2805 /* Position to the next record, which means moving to the end of the
2806 current record. This can happen under several different
2807 conditions. If the done flag is not set, we get ready to process
2811 next_record (st_parameter_dt
*dtp
, int done
)
2813 gfc_offset fp
; /* File position. */
2815 dtp
->u
.p
.current_unit
->read_bad
= 0;
2817 if (dtp
->u
.p
.mode
== READING
)
2818 next_record_r (dtp
);
2820 next_record_w (dtp
, done
);
2822 if (!is_stream_io (dtp
))
2824 /* Keep position up to date for INQUIRE */
2826 update_position (dtp
->u
.p
.current_unit
);
2828 dtp
->u
.p
.current_unit
->current_record
= 0;
2829 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2831 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2832 /* Calculate next record, rounding up partial records. */
2833 dtp
->u
.p
.current_unit
->last_record
=
2834 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2835 dtp
->u
.p
.current_unit
->recl
;
2838 dtp
->u
.p
.current_unit
->last_record
++;
2846 /* Finalize the current data transfer. For a nonadvancing transfer,
2847 this means advancing to the next record. For internal units close the
2848 stream associated with the unit. */
2851 finalize_transfer (st_parameter_dt
*dtp
)
2854 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2856 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2857 *dtp
->size
= dtp
->u
.p
.size_used
;
2859 if (dtp
->u
.p
.eor_condition
)
2861 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2865 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2868 if ((dtp
->u
.p
.ionml
!= NULL
)
2869 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2871 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2872 namelist_read (dtp
);
2874 namelist_write (dtp
);
2877 dtp
->u
.p
.transfer
= NULL
;
2878 if (dtp
->u
.p
.current_unit
== NULL
)
2881 dtp
->u
.p
.eof_jump
= &eof_jump
;
2882 if (setjmp (eof_jump
))
2884 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2888 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2890 finish_list_read (dtp
);
2891 sfree (dtp
->u
.p
.current_unit
->s
);
2895 if (dtp
->u
.p
.mode
== WRITING
)
2896 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2897 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2899 if (is_stream_io (dtp
))
2901 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2902 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2903 next_record (dtp
, 1);
2905 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2906 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2908 flush (dtp
->u
.p
.current_unit
->s
);
2909 sfree (dtp
->u
.p
.current_unit
->s
);
2914 dtp
->u
.p
.current_unit
->current_record
= 0;
2916 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2918 dtp
->u
.p
.seen_dollar
= 0;
2919 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2920 sfree (dtp
->u
.p
.current_unit
->s
);
2924 /* For non-advancing I/O, save the current maximum position for use in the
2925 next I/O operation if needed. */
2926 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2928 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2929 - dtp
->u
.p
.current_unit
->bytes_left
);
2930 dtp
->u
.p
.current_unit
->saved_pos
=
2931 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2932 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2933 flush (dtp
->u
.p
.current_unit
->s
);
2937 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2939 next_record (dtp
, 1);
2940 sfree (dtp
->u
.p
.current_unit
->s
);
2943 /* Transfer function for IOLENGTH. It doesn't actually do any
2944 data transfer, it just updates the length counter. */
2947 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2948 void *dest
__attribute__ ((unused
)),
2949 int kind
__attribute__((unused
)),
2950 size_t size
, size_t nelems
)
2952 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2953 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2957 /* Initialize the IOLENGTH data transfer. This function is in essence
2958 a very much simplified version of data_transfer_init(), because it
2959 doesn't have to deal with units at all. */
2962 iolength_transfer_init (st_parameter_dt
*dtp
)
2964 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2967 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2969 /* Set up the subroutine that will handle the transfers. */
2971 dtp
->u
.p
.transfer
= iolength_transfer
;
2975 /* Library entry point for the IOLENGTH form of the INQUIRE
2976 statement. The IOLENGTH form requires no I/O to be performed, but
2977 it must still be a runtime library call so that we can determine
2978 the iolength for dynamic arrays and such. */
2980 extern void st_iolength (st_parameter_dt
*);
2981 export_proto(st_iolength
);
2984 st_iolength (st_parameter_dt
*dtp
)
2986 library_start (&dtp
->common
);
2987 iolength_transfer_init (dtp
);
2990 extern void st_iolength_done (st_parameter_dt
*);
2991 export_proto(st_iolength_done
);
2994 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2997 if (dtp
->u
.p
.scratch
!= NULL
)
2998 free_mem (dtp
->u
.p
.scratch
);
3003 /* The READ statement. */
3005 extern void st_read (st_parameter_dt
*);
3006 export_proto(st_read
);
3009 st_read (st_parameter_dt
*dtp
)
3011 library_start (&dtp
->common
);
3013 data_transfer_init (dtp
, 1);
3015 /* Handle complications dealing with the endfile record. */
3017 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3018 switch (dtp
->u
.p
.current_unit
->endfile
)
3024 if (!is_internal_unit (dtp
))
3026 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3027 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3028 dtp
->u
.p
.current_unit
->current_record
= 0;
3033 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3034 dtp
->u
.p
.current_unit
->current_record
= 0;
3039 extern void st_read_done (st_parameter_dt
*);
3040 export_proto(st_read_done
);
3043 st_read_done (st_parameter_dt
*dtp
)
3045 finalize_transfer (dtp
);
3046 free_format_data (dtp
);
3048 if (dtp
->u
.p
.scratch
!= NULL
)
3049 free_mem (dtp
->u
.p
.scratch
);
3050 if (dtp
->u
.p
.current_unit
!= NULL
)
3051 unlock_unit (dtp
->u
.p
.current_unit
);
3053 free_internal_unit (dtp
);
3058 extern void st_write (st_parameter_dt
*);
3059 export_proto(st_write
);
3062 st_write (st_parameter_dt
*dtp
)
3064 library_start (&dtp
->common
);
3065 data_transfer_init (dtp
, 0);
3068 extern void st_write_done (st_parameter_dt
*);
3069 export_proto(st_write_done
);
3072 st_write_done (st_parameter_dt
*dtp
)
3074 finalize_transfer (dtp
);
3076 /* Deal with endfile conditions associated with sequential files. */
3078 if (dtp
->u
.p
.current_unit
!= NULL
3079 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3080 switch (dtp
->u
.p
.current_unit
->endfile
)
3082 case AT_ENDFILE
: /* Remain at the endfile record. */
3086 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3090 /* Get rid of whatever is after this record. */
3091 if (!is_internal_unit (dtp
))
3093 flush (dtp
->u
.p
.current_unit
->s
);
3094 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3095 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3097 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3101 free_format_data (dtp
);
3103 if (dtp
->u
.p
.scratch
!= NULL
)
3104 free_mem (dtp
->u
.p
.scratch
);
3105 if (dtp
->u
.p
.current_unit
!= NULL
)
3106 unlock_unit (dtp
->u
.p
.current_unit
);
3108 free_internal_unit (dtp
);
3114 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3116 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3121 /* Receives the scalar information for namelist objects and stores it
3122 in a linked list of namelist_info types. */
3124 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3125 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3126 export_proto(st_set_nml_var
);
3130 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3131 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3132 GFC_INTEGER_4 dtype
)
3134 namelist_info
*t1
= NULL
;
3136 size_t var_name_len
= strlen (var_name
);
3138 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3140 nml
->mem_pos
= var_addr
;
3142 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3143 memcpy (nml
->var_name
, var_name
, var_name_len
);
3144 nml
->var_name
[var_name_len
] = '\0';
3146 nml
->len
= (int) len
;
3147 nml
->string_length
= (index_type
) string_length
;
3149 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3150 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3151 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3153 if (nml
->var_rank
> 0)
3155 nml
->dim
= (descriptor_dimension
*)
3156 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3157 nml
->ls
= (array_loop_spec
*)
3158 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3168 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3170 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3171 dtp
->u
.p
.ionml
= nml
;
3175 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3180 /* Store the dimensional information for the namelist object. */
3181 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3182 index_type
, index_type
,
3184 export_proto(st_set_nml_var_dim
);
3187 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3188 index_type stride
, index_type lbound
,
3191 namelist_info
* nml
;
3196 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3198 nml
->dim
[n
].stride
= stride
;
3199 nml
->dim
[n
].lbound
= lbound
;
3200 nml
->dim
[n
].ubound
= ubound
;
3203 /* Reverse memcpy - used for byte swapping. */
3205 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3211 s
= (char *) src
+ n
- 1;
3213 /* Write with ascending order - this is likely faster
3214 on modern architectures because of write combining. */