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_offset
) *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_offset
) 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_offset
) 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 /* To maintain ABI, &transfer is the start of the private memory area in
1833 in st_parameter_dt. Memory from the beginning of the structure to this
1834 point is set by the front end and must not be touched. The number of
1835 bytes to clear must stay within the sizeof q to avoid over-writing. */
1836 memset (&dtp
->u
.p
.transfer
, 0, sizeof (dtp
->u
.q
));
1838 dtp
->u
.p
.ionml
= ionml
;
1839 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1841 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1844 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1845 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1847 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1848 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1849 { /* Open the unit with some default flags. */
1850 st_parameter_open opp
;
1853 if (dtp
->common
.unit
< 0)
1855 close_unit (dtp
->u
.p
.current_unit
);
1856 dtp
->u
.p
.current_unit
= NULL
;
1857 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1858 "Bad unit number in OPEN statement");
1861 memset (&u_flags
, '\0', sizeof (u_flags
));
1862 u_flags
.access
= ACCESS_SEQUENTIAL
;
1863 u_flags
.action
= ACTION_READWRITE
;
1865 /* Is it unformatted? */
1866 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1867 | IOPARM_DT_IONML_SET
)))
1868 u_flags
.form
= FORM_UNFORMATTED
;
1870 u_flags
.form
= FORM_UNSPECIFIED
;
1872 u_flags
.delim
= DELIM_UNSPECIFIED
;
1873 u_flags
.blank
= BLANK_UNSPECIFIED
;
1874 u_flags
.pad
= PAD_UNSPECIFIED
;
1875 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1876 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1877 u_flags
.async
= ASYNC_UNSPECIFIED
;
1878 u_flags
.round
= ROUND_UNSPECIFIED
;
1879 u_flags
.sign
= SIGN_UNSPECIFIED
;
1881 u_flags
.status
= STATUS_UNKNOWN
;
1883 conv
= get_unformatted_convert (dtp
->common
.unit
);
1885 if (conv
== GFC_CONVERT_NONE
)
1886 conv
= compile_options
.convert
;
1888 /* We use big_endian, which is 0 on little-endian machines
1889 and 1 on big-endian machines. */
1892 case GFC_CONVERT_NATIVE
:
1893 case GFC_CONVERT_SWAP
:
1896 case GFC_CONVERT_BIG
:
1897 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1900 case GFC_CONVERT_LITTLE
:
1901 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1905 internal_error (&opp
.common
, "Illegal value for CONVERT");
1909 u_flags
.convert
= conv
;
1911 opp
.common
= dtp
->common
;
1912 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1913 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1914 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1915 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1916 if (dtp
->u
.p
.current_unit
== NULL
)
1920 /* Check the action. */
1922 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1924 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1925 "Cannot read from file opened for WRITE");
1929 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1931 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1932 "Cannot write to file opened for READ");
1936 dtp
->u
.p
.first_item
= 1;
1938 /* Check the format. */
1940 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1943 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1944 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1947 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1948 "Format present for UNFORMATTED data transfer");
1952 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1954 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1955 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1956 "A format cannot be specified with a namelist");
1958 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1959 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1961 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1962 "Missing format for FORMATTED data transfer");
1965 if (is_internal_unit (dtp
)
1966 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1968 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1969 "Internal file cannot be accessed by UNFORMATTED "
1974 /* Check the record or position number. */
1976 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1977 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1979 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1980 "Direct access data transfer requires record number");
1984 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1985 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1987 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1988 "Record number not allowed for sequential access "
1993 /* Process the ADVANCE option. */
1995 dtp
->u
.p
.advance_status
1996 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1997 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1998 "Bad ADVANCE parameter in data transfer statement");
2000 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2002 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2004 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2005 "ADVANCE specification conflicts with sequential "
2010 if (is_internal_unit (dtp
))
2012 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2013 "ADVANCE specification conflicts with internal file");
2017 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2018 != IOPARM_DT_HAS_FORMAT
)
2020 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2021 "ADVANCE specification requires an explicit format");
2028 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2030 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2032 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2033 "EOR specification requires an ADVANCE specification "
2038 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2039 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2041 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2042 "SIZE specification requires an ADVANCE "
2043 "specification of NO");
2048 { /* Write constraints. */
2049 if ((cf
& IOPARM_END
) != 0)
2051 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2052 "END specification cannot appear in a write "
2057 if ((cf
& IOPARM_EOR
) != 0)
2059 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2060 "EOR specification cannot appear in a write "
2065 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2067 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2068 "SIZE specification cannot appear in a write "
2074 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2075 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2077 /* Check the decimal mode. */
2078 dtp
->u
.p
.current_unit
->decimal_status
2079 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2080 find_option (&dtp
->common
, dtp
->u
.p
.decimal
, dtp
->u
.p
.decimal_len
,
2081 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2084 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2085 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2087 /* Check the sign mode. */
2088 dtp
->u
.p
.sign_status
2089 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2090 find_option (&dtp
->common
, dtp
->u
.p
.sign
, dtp
->u
.p
.sign_len
, sign_opt
,
2091 "Bad SIGN parameter in data transfer statement");
2093 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2094 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2096 /* Check the blank mode. */
2097 dtp
->u
.p
.blank_status
2098 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2099 find_option (&dtp
->common
, dtp
->u
.p
.blank
, dtp
->u
.p
.blank_len
,
2101 "Bad BLANK parameter in data transfer statement");
2103 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2104 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2106 /* Check the delim mode. */
2107 dtp
->u
.p
.current_unit
->delim_status
2108 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2109 find_option (&dtp
->common
, dtp
->u
.p
.delim
, dtp
->u
.p
.delim_len
,
2110 delim_opt
, "Bad DELIM parameter in data transfer statement");
2112 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2113 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2115 /* Check the pad mode. */
2116 dtp
->u
.p
.current_unit
->pad_status
2117 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2118 find_option (&dtp
->common
, dtp
->u
.p
.pad
, dtp
->u
.p
.pad_len
, pad_opt
,
2119 "Bad PAD parameter in data transfer statement");
2121 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2122 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2124 /* Sanity checks on the record number. */
2125 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2129 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2130 "Record number must be positive");
2134 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2136 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2137 "Record number too large");
2141 /* Check to see if we might be reading what we wrote before */
2143 if (dtp
->u
.p
.mode
== READING
2144 && dtp
->u
.p
.current_unit
->mode
== WRITING
2145 && !is_internal_unit (dtp
))
2147 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2148 flush(dtp
->u
.p
.current_unit
->s
);
2151 /* Check whether the record exists to be read. Only
2152 a partial record needs to exist. */
2154 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2155 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2157 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2158 "Non-existing record number");
2162 /* Position the file. */
2163 if (!is_stream_io (dtp
))
2165 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2166 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2168 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2174 if (dtp
->u
.p
.current_unit
->strm_pos
!= dtp
->rec
)
2176 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2177 flush (dtp
->u
.p
.current_unit
->s
);
2178 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->rec
- 1) == FAILURE
)
2180 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2183 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2189 /* Overwriting an existing sequential file ?
2190 it is always safe to truncate the file on the first write */
2191 if (dtp
->u
.p
.mode
== WRITING
2192 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2193 && dtp
->u
.p
.current_unit
->last_record
== 0
2194 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2195 struncate(dtp
->u
.p
.current_unit
->s
);
2197 /* Bugware for badly written mixed C-Fortran I/O. */
2198 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2200 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2202 /* Set the maximum position reached from the previous I/O operation. This
2203 could be greater than zero from a previous non-advancing write. */
2204 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2209 /* Set up the subroutine that will handle the transfers. */
2213 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2214 dtp
->u
.p
.transfer
= unformatted_read
;
2217 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2218 dtp
->u
.p
.transfer
= list_formatted_read
;
2220 dtp
->u
.p
.transfer
= formatted_transfer
;
2225 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2226 dtp
->u
.p
.transfer
= unformatted_write
;
2229 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2230 dtp
->u
.p
.transfer
= list_formatted_write
;
2232 dtp
->u
.p
.transfer
= formatted_transfer
;
2236 /* Make sure that we don't do a read after a nonadvancing write. */
2240 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2242 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2243 "Cannot READ after a nonadvancing WRITE");
2249 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2250 dtp
->u
.p
.current_unit
->read_bad
= 1;
2253 /* Start the data transfer if we are doing a formatted transfer. */
2254 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2255 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2256 && dtp
->u
.p
.ionml
== NULL
)
2257 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2260 /* Initialize an array_loop_spec given the array descriptor. The function
2261 returns the index of the last element of the array, and also returns
2262 starting record, where the first I/O goes to (necessary in case of
2263 negative strides). */
2266 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2267 gfc_offset
*start_record
)
2269 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2278 for (i
=0; i
<rank
; i
++)
2280 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2281 ls
[i
].start
= desc
->dim
[i
].lbound
;
2282 ls
[i
].end
= desc
->dim
[i
].ubound
;
2283 ls
[i
].step
= desc
->dim
[i
].stride
;
2284 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2286 if (desc
->dim
[i
].stride
> 0)
2288 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2289 * desc
->dim
[i
].stride
;
2293 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2294 * desc
->dim
[i
].stride
;
2295 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2296 * desc
->dim
[i
].stride
;
2306 /* Determine the index to the next record in an internal unit array by
2307 by incrementing through the array_loop_spec. */
2310 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2318 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2323 if (ls
[i
].idx
> ls
[i
].end
)
2325 ls
[i
].idx
= ls
[i
].start
;
2331 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2341 /* Skip to the end of the current record, taking care of an optional
2342 record marker of size bytes. If the file is not seekable, we
2343 read chunks of size MAX_READ until we get to the right
2347 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2351 static const size_t MAX_READ
= 4096;
2354 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2355 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2358 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2360 new = file_position (dtp
->u
.p
.current_unit
->s
)
2361 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2363 /* Direct access files do not generate END conditions,
2365 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2366 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2369 { /* Seek by reading data. */
2370 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2373 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2374 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2376 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2378 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2382 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2389 /* Advance to the next record reading unformatted files, taking
2390 care of subrecords. If complete_record is nonzero, we loop
2391 until all subrecords are cleared. */
2394 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2398 bytes
= compile_options
.record_marker
== 0 ?
2399 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2404 /* Skip over tail */
2406 skip_record (dtp
, bytes
);
2408 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2416 static inline gfc_offset
2417 min_off (gfc_offset a
, gfc_offset b
)
2419 return (a
< b
? a
: b
);
2423 /* Space to the next record for read mode. */
2426 next_record_r (st_parameter_dt
*dtp
)
2433 switch (current_mode (dtp
))
2435 /* No records in unformatted STREAM I/O. */
2436 case UNFORMATTED_STREAM
:
2439 case UNFORMATTED_SEQUENTIAL
:
2440 next_record_r_unf (dtp
, 1);
2441 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2444 case FORMATTED_DIRECT
:
2445 case UNFORMATTED_DIRECT
:
2446 skip_record (dtp
, 0);
2449 case FORMATTED_STREAM
:
2450 case FORMATTED_SEQUENTIAL
:
2452 /* sf_read has already terminated input because of an '\n' */
2453 if (dtp
->u
.p
.sf_seen_eor
)
2455 dtp
->u
.p
.sf_seen_eor
= 0;
2459 if (is_internal_unit (dtp
))
2461 if (is_array_io (dtp
))
2465 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2468 /* Now seek to this record. */
2469 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2470 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2472 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2475 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2479 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2480 bytes_left
= min_off (bytes_left
,
2481 file_length (dtp
->u
.p
.current_unit
->s
)
2482 - file_position (dtp
->u
.p
.current_unit
->s
));
2483 if (sseek (dtp
->u
.p
.current_unit
->s
,
2484 file_position (dtp
->u
.p
.current_unit
->s
)
2485 + bytes_left
) == FAILURE
)
2487 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2490 dtp
->u
.p
.current_unit
->bytes_left
2491 = dtp
->u
.p
.current_unit
->recl
;
2497 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2499 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2505 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2509 if (is_stream_io (dtp
))
2510 dtp
->u
.p
.current_unit
->strm_pos
++;
2517 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2518 && !dtp
->u
.p
.namelist_mode
2519 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2520 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2521 file_position (dtp
->u
.p
.current_unit
->s
)))
2522 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2527 /* Small utility function to write a record marker, taking care of
2528 byte swapping and of choosing the correct size. */
2531 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2536 char p
[sizeof (GFC_INTEGER_8
)];
2538 if (compile_options
.record_marker
== 0)
2539 len
= sizeof (GFC_INTEGER_4
);
2541 len
= compile_options
.record_marker
;
2543 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2544 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2548 case sizeof (GFC_INTEGER_4
):
2550 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2553 case sizeof (GFC_INTEGER_8
):
2555 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2559 runtime_error ("Illegal value for record marker");
2567 case sizeof (GFC_INTEGER_4
):
2569 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2570 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2573 case sizeof (GFC_INTEGER_8
):
2575 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2576 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2580 runtime_error ("Illegal value for record marker");
2587 /* Position to the next (sub)record in write mode for
2588 unformatted sequential files. */
2591 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2593 gfc_offset c
, m
, m_write
;
2594 size_t record_marker
;
2596 /* Bytes written. */
2597 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2598 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2599 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2601 /* Write the length tail. If we finish a record containing
2602 subrecords, we write out the negative length. */
2604 if (dtp
->u
.p
.current_unit
->continued
)
2609 if (unlikely (write_us_marker (dtp
, m_write
) != 0))
2612 if (compile_options
.record_marker
== 0)
2613 record_marker
= sizeof (GFC_INTEGER_4
);
2615 record_marker
= compile_options
.record_marker
;
2617 /* Seek to the head and overwrite the bogus length with the real
2620 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2629 if (unlikely (write_us_marker (dtp
, m_write
) != 0))
2632 /* Seek past the end of the current record. */
2634 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
)
2641 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2646 /* Position to the next record in write mode. */
2649 next_record_w (st_parameter_dt
*dtp
, int done
)
2651 gfc_offset m
, record
, max_pos
;
2654 /* Flush and reset the format buffer. */
2655 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2657 /* Zero counters for X- and T-editing. */
2658 max_pos
= dtp
->u
.p
.max_pos
;
2659 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2661 switch (current_mode (dtp
))
2663 /* No records in unformatted STREAM I/O. */
2664 case UNFORMATTED_STREAM
:
2667 case FORMATTED_DIRECT
:
2668 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2671 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2672 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2677 case UNFORMATTED_DIRECT
:
2678 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2680 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2681 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2686 case UNFORMATTED_SEQUENTIAL
:
2687 next_record_w_unf (dtp
, 0);
2688 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2691 case FORMATTED_STREAM
:
2692 case FORMATTED_SEQUENTIAL
:
2694 if (is_internal_unit (dtp
))
2696 if (is_array_io (dtp
))
2700 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2702 /* If the farthest position reached is greater than current
2703 position, adjust the position and set length to pad out
2704 whats left. Otherwise just pad whats left.
2705 (for character array unit) */
2706 m
= dtp
->u
.p
.current_unit
->recl
2707 - dtp
->u
.p
.current_unit
->bytes_left
;
2710 length
= (int) (max_pos
- m
);
2711 if (sseek (dtp
->u
.p
.current_unit
->s
,
2712 file_position (dtp
->u
.p
.current_unit
->s
)
2713 + length
) == FAILURE
)
2715 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2718 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2721 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2723 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2727 /* Now that the current record has been padded out,
2728 determine where the next record in the array is. */
2729 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2732 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2734 /* Now seek to this record */
2735 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2737 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2739 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2743 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2749 /* If this is the last call to next_record move to the farthest
2750 position reached and set length to pad out the remainder
2751 of the record. (for character scaler 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 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2772 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2774 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2782 const char crlf
[] = "\r\n";
2789 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2792 if (is_stream_io (dtp
))
2794 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2795 if (dtp
->u
.p
.current_unit
->strm_pos
2796 < file_length (dtp
->u
.p
.current_unit
->s
))
2797 struncate (dtp
->u
.p
.current_unit
->s
);
2804 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2809 /* Position to the next record, which means moving to the end of the
2810 current record. This can happen under several different
2811 conditions. If the done flag is not set, we get ready to process
2815 next_record (st_parameter_dt
*dtp
, int done
)
2817 gfc_offset fp
; /* File position. */
2819 dtp
->u
.p
.current_unit
->read_bad
= 0;
2821 if (dtp
->u
.p
.mode
== READING
)
2822 next_record_r (dtp
);
2824 next_record_w (dtp
, done
);
2826 if (!is_stream_io (dtp
))
2828 /* Keep position up to date for INQUIRE */
2830 update_position (dtp
->u
.p
.current_unit
);
2832 dtp
->u
.p
.current_unit
->current_record
= 0;
2833 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2835 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2836 /* Calculate next record, rounding up partial records. */
2837 dtp
->u
.p
.current_unit
->last_record
=
2838 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2839 dtp
->u
.p
.current_unit
->recl
;
2842 dtp
->u
.p
.current_unit
->last_record
++;
2850 /* Finalize the current data transfer. For a nonadvancing transfer,
2851 this means advancing to the next record. For internal units close the
2852 stream associated with the unit. */
2855 finalize_transfer (st_parameter_dt
*dtp
)
2858 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2860 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2861 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2863 if (dtp
->u
.p
.eor_condition
)
2865 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2869 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2872 if ((dtp
->u
.p
.ionml
!= NULL
)
2873 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2875 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2876 namelist_read (dtp
);
2878 namelist_write (dtp
);
2881 dtp
->u
.p
.transfer
= NULL
;
2882 if (dtp
->u
.p
.current_unit
== NULL
)
2885 dtp
->u
.p
.eof_jump
= &eof_jump
;
2886 if (setjmp (eof_jump
))
2888 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2892 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2894 finish_list_read (dtp
);
2895 sfree (dtp
->u
.p
.current_unit
->s
);
2899 if (dtp
->u
.p
.mode
== WRITING
)
2900 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2901 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2903 if (is_stream_io (dtp
))
2905 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2906 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2907 next_record (dtp
, 1);
2909 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2910 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2912 flush (dtp
->u
.p
.current_unit
->s
);
2913 sfree (dtp
->u
.p
.current_unit
->s
);
2918 dtp
->u
.p
.current_unit
->current_record
= 0;
2920 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2922 dtp
->u
.p
.seen_dollar
= 0;
2923 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2924 sfree (dtp
->u
.p
.current_unit
->s
);
2928 /* For non-advancing I/O, save the current maximum position for use in the
2929 next I/O operation if needed. */
2930 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2932 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2933 - dtp
->u
.p
.current_unit
->bytes_left
);
2934 dtp
->u
.p
.current_unit
->saved_pos
=
2935 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2936 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2937 flush (dtp
->u
.p
.current_unit
->s
);
2941 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2943 next_record (dtp
, 1);
2944 sfree (dtp
->u
.p
.current_unit
->s
);
2947 /* Transfer function for IOLENGTH. It doesn't actually do any
2948 data transfer, it just updates the length counter. */
2951 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2952 void *dest
__attribute__ ((unused
)),
2953 int kind
__attribute__((unused
)),
2954 size_t size
, size_t nelems
)
2956 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2957 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2961 /* Initialize the IOLENGTH data transfer. This function is in essence
2962 a very much simplified version of data_transfer_init(), because it
2963 doesn't have to deal with units at all. */
2966 iolength_transfer_init (st_parameter_dt
*dtp
)
2968 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2971 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2973 /* Set up the subroutine that will handle the transfers. */
2975 dtp
->u
.p
.transfer
= iolength_transfer
;
2979 /* Library entry point for the IOLENGTH form of the INQUIRE
2980 statement. The IOLENGTH form requires no I/O to be performed, but
2981 it must still be a runtime library call so that we can determine
2982 the iolength for dynamic arrays and such. */
2984 extern void st_iolength (st_parameter_dt
*);
2985 export_proto(st_iolength
);
2988 st_iolength (st_parameter_dt
*dtp
)
2990 library_start (&dtp
->common
);
2991 iolength_transfer_init (dtp
);
2994 extern void st_iolength_done (st_parameter_dt
*);
2995 export_proto(st_iolength_done
);
2998 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3001 if (dtp
->u
.p
.scratch
!= NULL
)
3002 free_mem (dtp
->u
.p
.scratch
);
3007 /* The READ statement. */
3009 extern void st_read (st_parameter_dt
*);
3010 export_proto(st_read
);
3013 st_read (st_parameter_dt
*dtp
)
3015 library_start (&dtp
->common
);
3017 data_transfer_init (dtp
, 1);
3019 /* Handle complications dealing with the endfile record. */
3021 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3022 switch (dtp
->u
.p
.current_unit
->endfile
)
3028 if (!is_internal_unit (dtp
))
3030 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3031 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3032 dtp
->u
.p
.current_unit
->current_record
= 0;
3037 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3038 dtp
->u
.p
.current_unit
->current_record
= 0;
3043 extern void st_read_done (st_parameter_dt
*);
3044 export_proto(st_read_done
);
3047 st_read_done (st_parameter_dt
*dtp
)
3049 finalize_transfer (dtp
);
3050 free_format_data (dtp
);
3052 if (dtp
->u
.p
.scratch
!= NULL
)
3053 free_mem (dtp
->u
.p
.scratch
);
3054 if (dtp
->u
.p
.current_unit
!= NULL
)
3055 unlock_unit (dtp
->u
.p
.current_unit
);
3057 free_internal_unit (dtp
);
3062 extern void st_write (st_parameter_dt
*);
3063 export_proto(st_write
);
3066 st_write (st_parameter_dt
*dtp
)
3068 library_start (&dtp
->common
);
3069 data_transfer_init (dtp
, 0);
3072 extern void st_write_done (st_parameter_dt
*);
3073 export_proto(st_write_done
);
3076 st_write_done (st_parameter_dt
*dtp
)
3078 finalize_transfer (dtp
);
3080 /* Deal with endfile conditions associated with sequential files. */
3082 if (dtp
->u
.p
.current_unit
!= NULL
3083 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3084 switch (dtp
->u
.p
.current_unit
->endfile
)
3086 case AT_ENDFILE
: /* Remain at the endfile record. */
3090 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3094 /* Get rid of whatever is after this record. */
3095 if (!is_internal_unit (dtp
))
3097 flush (dtp
->u
.p
.current_unit
->s
);
3098 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3099 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3101 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3105 free_format_data (dtp
);
3107 if (dtp
->u
.p
.scratch
!= NULL
)
3108 free_mem (dtp
->u
.p
.scratch
);
3109 if (dtp
->u
.p
.current_unit
!= NULL
)
3110 unlock_unit (dtp
->u
.p
.current_unit
);
3112 free_internal_unit (dtp
);
3118 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3120 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3125 /* Receives the scalar information for namelist objects and stores it
3126 in a linked list of namelist_info types. */
3128 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3129 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3130 export_proto(st_set_nml_var
);
3134 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3135 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3136 GFC_INTEGER_4 dtype
)
3138 namelist_info
*t1
= NULL
;
3140 size_t var_name_len
= strlen (var_name
);
3142 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3144 nml
->mem_pos
= var_addr
;
3146 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3147 memcpy (nml
->var_name
, var_name
, var_name_len
);
3148 nml
->var_name
[var_name_len
] = '\0';
3150 nml
->len
= (int) len
;
3151 nml
->string_length
= (index_type
) string_length
;
3153 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3154 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3155 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3157 if (nml
->var_rank
> 0)
3159 nml
->dim
= (descriptor_dimension
*)
3160 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3161 nml
->ls
= (array_loop_spec
*)
3162 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3172 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3174 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3175 dtp
->u
.p
.ionml
= nml
;
3179 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3184 /* Store the dimensional information for the namelist object. */
3185 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3186 index_type
, index_type
,
3188 export_proto(st_set_nml_var_dim
);
3191 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3192 index_type stride
, index_type lbound
,
3195 namelist_info
* nml
;
3200 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3202 nml
->dim
[n
].stride
= stride
;
3203 nml
->dim
[n
].lbound
= lbound
;
3204 nml
->dim
[n
].ubound
= ubound
;
3207 /* Reverse memcpy - used for byte swapping. */
3209 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3215 s
= (char *) src
+ n
- 1;
3217 /* Write with ascending order - this is likely faster
3218 on modern architectures because of write combining. */