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. */
43 /* Calling conventions: Data transfer statements are unlike other
44 library calls in that they extend over several calls.
46 The first call is always a call to st_read() or st_write(). These
47 subroutines return no status unless a namelist read or write is
48 being done, in which case there is the usual status. No further
49 calls are necessary in this case.
51 For other sorts of data transfer, there are zero or more data
52 transfer statement that depend on the format of the data transfer
58 transfer_character_wide
62 These subroutines do not return status.
64 The last call is a call to st_[read|write]_done(). While
65 something can easily go wrong with the initial st_read() or
66 st_write(), an error inhibits any data from actually being
69 extern void transfer_integer (st_parameter_dt
*, void *, int);
70 export_proto(transfer_integer
);
72 extern void transfer_real (st_parameter_dt
*, void *, int);
73 export_proto(transfer_real
);
75 extern void transfer_logical (st_parameter_dt
*, void *, int);
76 export_proto(transfer_logical
);
78 extern void transfer_character (st_parameter_dt
*, void *, int);
79 export_proto(transfer_character
);
81 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
82 export_proto(transfer_character_wide
);
84 extern void transfer_complex (st_parameter_dt
*, void *, int);
85 export_proto(transfer_complex
);
87 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
89 export_proto(transfer_array
);
91 static void us_read (st_parameter_dt
*, int);
92 static void us_write (st_parameter_dt
*, int);
93 static void next_record_r_unf (st_parameter_dt
*, int);
94 static void next_record_w_unf (st_parameter_dt
*, int);
96 static const st_option advance_opt
[] = {
103 static const st_option decimal_opt
[] = {
104 {"point", DECIMAL_POINT
},
105 {"comma", DECIMAL_COMMA
},
110 static const st_option sign_opt
[] = {
112 {"suppress", SIGN_SS
},
113 {"processor_defined", SIGN_S
},
117 static const st_option blank_opt
[] = {
118 {"null", BLANK_NULL
},
119 {"zero", BLANK_ZERO
},
123 static const st_option delim_opt
[] = {
124 {"apostrophe", DELIM_APOSTROPHE
},
125 {"quote", DELIM_QUOTE
},
126 {"none", DELIM_NONE
},
130 static const st_option pad_opt
[] = {
137 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
138 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
144 current_mode (st_parameter_dt
*dtp
)
148 m
= FORM_UNSPECIFIED
;
150 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
152 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
153 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
155 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
157 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
158 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
160 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
162 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
163 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
170 /* Mid level data transfer statements. These subroutines do reading
171 and writing in the style of salloc_r()/salloc_w() within the
174 /* When reading sequential formatted records we have a problem. We
175 don't know how long the line is until we read the trailing newline,
176 and we don't want to read too much. If we read too much, we might
177 have to do a physical seek backwards depending on how much data is
178 present, and devices like terminals aren't seekable and would cause
181 Given this, the solution is to read a byte at a time, stopping if
182 we hit the newline. For small allocations, we use a static buffer.
183 For larger allocations, we are forced to allocate memory on the
184 heap. Hopefully this won't happen very often. */
187 read_sf (st_parameter_dt
*dtp
, int * length
, int no_error
)
189 static char *empty_string
[0];
191 int n
, lorig
, memread
, seen_comma
;
193 /* If we hit EOF previously with the no_error flag set (i.e. X, T,
194 TR edit descriptors), and we now try to read again, this time
195 without setting no_error. */
196 if (!no_error
&& dtp
->u
.p
.at_eof
)
203 /* If we have seen an eor previously, return a length of 0. The
204 caller is responsible for correctly padding the input field. */
205 if (dtp
->u
.p
.sf_seen_eor
)
208 /* Just return something that isn't a NULL pointer, otherwise the
209 caller thinks an error occured. */
210 return (char*) empty_string
;
213 if (is_internal_unit (dtp
))
216 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
217 if (unlikely (memread
> *length
))
228 /* Read data into format buffer and scan through it. */
230 base
= p
= fbuf_read (dtp
->u
.p
.current_unit
, length
);
238 if (q
== '\n' || q
== '\r')
240 /* Unexpected end of line. */
242 /* If we see an EOR during non-advancing I/O, we need to skip
243 the rest of the I/O statement. Set the corresponding flag. */
244 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
245 dtp
->u
.p
.eor_condition
= 1;
247 /* If we encounter a CR, it might be a CRLF. */
248 if (q
== '\r') /* Probably a CRLF */
250 if (n
< *length
&& *(p
+ 1) == '\n')
251 dtp
->u
.p
.sf_seen_eor
= 2;
254 dtp
->u
.p
.sf_seen_eor
= 1;
256 /* Without padding, terminate the I/O statement without assigning
257 the value. With padding, the value still needs to be assigned,
258 so we can just continue with a short read. */
259 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
261 if (likely (no_error
))
263 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
270 /* Short circuit the read if a comma is found during numeric input.
271 The flag is set to zero during character reads so that commas in
272 strings are not ignored */
274 if (dtp
->u
.p
.sf_read_comma
== 1)
277 notify_std (&dtp
->common
, GFC_STD_GNU
,
278 "Comma in formatted numeric read.");
287 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ dtp
->u
.p
.sf_seen_eor
+ seen_comma
,
290 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
291 some other stuff. Set the relevant flags. */
292 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
305 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
307 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
308 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
314 /* Function for reading the next couple of bytes from the current
315 file, advancing the current position. We return FAILURE on end of record or
316 end of file. This function is only for formatted I/O, unformatted uses
319 If the read is short, then it is because the current record does not
320 have enough data to satisfy the read request and the file was
321 opened with PAD=YES. The caller must assume tailing spaces for
325 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
330 if (!is_stream_io (dtp
))
332 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
334 /* For preconnected units with default record length, set bytes left
335 to unit record length and proceed, otherwise error. */
336 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
337 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
338 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
341 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
343 /* Not enough data left. */
344 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
349 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
355 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
359 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
360 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
361 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
363 source
= read_sf (dtp
, nbytes
, 0);
364 dtp
->u
.p
.current_unit
->strm_pos
+=
365 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
369 /* If we reach here, we can assume it's direct access. */
371 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
374 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
375 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
377 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
378 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
380 if (norig
!= *nbytes
)
382 /* Short read, this shouldn't happen. */
383 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
385 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
390 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
396 /* Reads a block directly into application data space. This is for
397 unformatted files. */
400 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
402 ssize_t to_read_record
;
403 ssize_t have_read_record
;
404 ssize_t to_read_subrecord
;
405 ssize_t have_read_subrecord
;
408 if (is_stream_io (dtp
))
410 to_read_record
= *nbytes
;
411 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
413 if (unlikely (have_read_record
< 0))
415 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
419 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
421 if (unlikely (to_read_record
!= have_read_record
))
423 /* Short read, e.g. if we hit EOF. For stream files,
424 we have to set the end-of-file condition. */
431 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
433 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
436 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
437 *nbytes
= to_read_record
;
443 to_read_record
= *nbytes
;
446 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
448 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
449 if (unlikely (to_read_record
< 0))
451 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
455 if (to_read_record
!= (ssize_t
) *nbytes
)
457 /* Short read, e.g. if we hit EOF. Apparently, we read
458 more than was written to the last record. */
459 *nbytes
= to_read_record
;
463 if (unlikely (short_record
))
465 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
471 /* Unformatted sequential. We loop over the subrecords, reading
472 until the request has been fulfilled or the record has run out
473 of continuation subrecords. */
475 /* Check whether we exceed the total record length. */
477 if (dtp
->u
.p
.current_unit
->flags
.has_recl
478 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
480 to_read_record
= (ssize_t
) dtp
->u
.p
.current_unit
->bytes_left
;
485 to_read_record
= *nbytes
;
488 have_read_record
= 0;
492 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
493 < (gfc_offset
) to_read_record
)
495 to_read_subrecord
= (ssize_t
) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
496 to_read_record
-= to_read_subrecord
;
500 to_read_subrecord
= to_read_record
;
504 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
506 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
507 buf
+ have_read_record
, to_read_subrecord
);
508 if (unlikely (have_read_subrecord
) < 0)
510 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
514 have_read_record
+= have_read_subrecord
;
516 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
519 /* Short read, e.g. if we hit EOF. This means the record
520 structure has been corrupted, or the trailing record
521 marker would still be present. */
523 *nbytes
= have_read_record
;
524 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
528 if (to_read_record
> 0)
530 if (likely (dtp
->u
.p
.current_unit
->continued
))
532 next_record_r_unf (dtp
, 0);
537 /* Let's make sure the file position is correctly pre-positioned
538 for the next read statement. */
540 dtp
->u
.p
.current_unit
->current_record
= 0;
541 next_record_r_unf (dtp
, 0);
542 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
548 /* Normal exit, the read request has been fulfilled. */
553 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
554 if (unlikely (short_record
))
556 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
563 /* Function for writing a block of bytes to the current file at the
564 current position, advancing the file pointer. We are given a length
565 and return a pointer to a buffer that the caller must (completely)
566 fill in. Returns NULL on error. */
569 write_block (st_parameter_dt
*dtp
, int length
)
573 if (!is_stream_io (dtp
))
575 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
577 /* For preconnected units with default record length, set bytes left
578 to unit record length and proceed, otherwise error. */
579 if (likely ((dtp
->u
.p
.current_unit
->unit_number
580 == options
.stdout_unit
581 || dtp
->u
.p
.current_unit
->unit_number
582 == options
.stderr_unit
)
583 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
584 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
587 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
592 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
595 if (is_internal_unit (dtp
))
597 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
601 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
605 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
606 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
610 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
613 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
618 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
619 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
621 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
627 /* High level interface to swrite(), taking care of errors. This is only
628 called for unformatted files. There are three cases to consider:
629 Stream I/O, unformatted direct, unformatted sequential. */
632 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
635 ssize_t have_written
;
636 ssize_t to_write_subrecord
;
641 if (is_stream_io (dtp
))
643 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
644 if (unlikely (have_written
< 0))
646 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
650 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
655 /* Unformatted direct access. */
657 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
659 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
661 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
665 if (buf
== NULL
&& nbytes
== 0)
668 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
669 if (unlikely (have_written
< 0))
671 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
675 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
676 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
681 /* Unformatted sequential. */
685 if (dtp
->u
.p
.current_unit
->flags
.has_recl
686 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
688 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
700 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
701 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
703 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
704 (gfc_offset
) to_write_subrecord
;
706 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
707 buf
+ have_written
, to_write_subrecord
);
708 if (unlikely (to_write_subrecord
< 0))
710 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
714 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
715 nbytes
-= to_write_subrecord
;
716 have_written
+= to_write_subrecord
;
721 next_record_w_unf (dtp
, 1);
724 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
725 if (unlikely (short_record
))
727 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
734 /* Master function for unformatted reads. */
737 unformatted_read (st_parameter_dt
*dtp
, bt type
,
738 void *dest
, int kind
, size_t size
, size_t nelems
)
742 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
746 if (type
== BT_CHARACTER
)
747 sz
*= GFC_SIZE_OF_CHAR_KIND(kind
);
748 read_block_direct (dtp
, dest
, &sz
);
757 /* Handle wide chracters. */
758 if (type
== BT_CHARACTER
&& kind
!= 1)
764 /* Break up complex into its constituent reals. */
765 if (type
== BT_COMPLEX
)
771 /* By now, all complex variables have been split into their
772 constituent reals. */
774 for (i
= 0; i
< nelems
; i
++)
776 read_block_direct (dtp
, buffer
, &size
);
777 reverse_memcpy (p
, buffer
, size
);
784 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
785 bytes on 64 bit machines. The unused bytes are not initialized and never
786 used, which can show an error with memory checking analyzers like
790 unformatted_write (st_parameter_dt
*dtp
, bt type
,
791 void *source
, int kind
, size_t size
, size_t nelems
)
793 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
796 size_t stride
= type
== BT_CHARACTER
?
797 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
799 write_buf (dtp
, source
, stride
* nelems
);
809 /* Handle wide chracters. */
810 if (type
== BT_CHARACTER
&& kind
!= 1)
816 /* Break up complex into its constituent reals. */
817 if (type
== BT_COMPLEX
)
823 /* By now, all complex variables have been split into their
824 constituent reals. */
826 for (i
= 0; i
< nelems
; i
++)
828 reverse_memcpy(buffer
, p
, size
);
830 write_buf (dtp
, buffer
, size
);
836 /* Return a pointer to the name of a type. */
861 internal_error (NULL
, "type_name(): Bad type");
868 /* Write a constant string to the output.
869 This is complicated because the string can have doubled delimiters
870 in it. The length in the format node is the true length. */
873 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
875 char c
, delimiter
, *p
, *q
;
878 length
= f
->u
.string
.length
;
882 p
= write_block (dtp
, length
);
889 for (; length
> 0; length
--)
892 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
893 q
++; /* Skip the doubled delimiter. */
898 /* Given actual and expected types in a formatted data transfer, make
899 sure they agree. If not, an error message is generated. Returns
900 nonzero if something went wrong. */
903 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
907 if (actual
== expected
)
910 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
911 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
913 format_error (dtp
, f
, buffer
);
918 /* This subroutine is the main loop for a formatted data transfer
919 statement. It would be natural to implement this as a coroutine
920 with the user program, but C makes that awkward. We loop,
921 processing format elements. When we actually have to transfer
922 data instead of just setting flags, we return control to the user
923 program which calls a subroutine that supplies the address and type
924 of the next element, then comes back here to process it. */
927 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
934 int consume_data_flag
;
936 /* Change a complex data item into a pair of reals. */
938 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
939 if (type
== BT_COMPLEX
)
945 /* If there's an EOR condition, we simulate finalizing the transfer
947 if (dtp
->u
.p
.eor_condition
)
950 /* Set this flag so that commas in reads cause the read to complete before
951 the entire field has been read. The next read field will start right after
952 the comma in the stream. (Set to 0 for character reads). */
953 dtp
->u
.p
.sf_read_comma
=
954 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
958 /* If reversion has occurred and there is another real data item,
959 then we have to move to the next record. */
960 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
962 dtp
->u
.p
.reversion_flag
= 0;
963 next_record (dtp
, 0);
966 consume_data_flag
= 1;
967 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
970 f
= next_format (dtp
);
973 /* No data descriptors left. */
974 if (unlikely (n
> 0))
975 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
976 "Insufficient data descriptors in format after reversion");
980 /* Now discharge T, TR and X movements to the right. This is delayed
981 until a data producing format to suppress trailing spaces. */
984 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
985 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
986 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
987 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
988 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
991 if (dtp
->u
.p
.skips
> 0)
994 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
995 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
996 - dtp
->u
.p
.current_unit
->bytes_left
);
998 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1000 if (dtp
->u
.p
.skips
< 0)
1002 if (is_internal_unit (dtp
))
1003 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1005 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1006 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1008 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1011 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1012 - dtp
->u
.p
.current_unit
->bytes_left
);
1014 if (is_stream_io(dtp
))
1022 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1025 if (dtp
->u
.p
.mode
== READING
)
1026 read_decimal (dtp
, f
, p
, kind
);
1028 write_i (dtp
, f
, p
, kind
);
1036 if (compile_options
.allow_std
< GFC_STD_GNU
1037 && require_type (dtp
, BT_INTEGER
, type
, f
))
1040 if (dtp
->u
.p
.mode
== READING
)
1041 read_radix (dtp
, f
, p
, kind
, 2);
1043 write_b (dtp
, f
, p
, kind
);
1051 if (compile_options
.allow_std
< GFC_STD_GNU
1052 && require_type (dtp
, BT_INTEGER
, type
, f
))
1055 if (dtp
->u
.p
.mode
== READING
)
1056 read_radix (dtp
, f
, p
, kind
, 8);
1058 write_o (dtp
, f
, p
, kind
);
1066 if (compile_options
.allow_std
< GFC_STD_GNU
1067 && require_type (dtp
, BT_INTEGER
, type
, f
))
1070 if (dtp
->u
.p
.mode
== READING
)
1071 read_radix (dtp
, f
, p
, kind
, 16);
1073 write_z (dtp
, f
, p
, kind
);
1081 /* It is possible to have FMT_A with something not BT_CHARACTER such
1082 as when writing out hollerith strings, so check both type
1083 and kind before calling wide character routines. */
1084 if (dtp
->u
.p
.mode
== READING
)
1086 if (type
== BT_CHARACTER
&& kind
== 4)
1087 read_a_char4 (dtp
, f
, p
, size
);
1089 read_a (dtp
, f
, p
, size
);
1093 if (type
== BT_CHARACTER
&& kind
== 4)
1094 write_a_char4 (dtp
, f
, p
, size
);
1096 write_a (dtp
, f
, p
, size
);
1104 if (dtp
->u
.p
.mode
== READING
)
1105 read_l (dtp
, f
, p
, kind
);
1107 write_l (dtp
, f
, p
, kind
);
1114 if (require_type (dtp
, BT_REAL
, type
, f
))
1117 if (dtp
->u
.p
.mode
== READING
)
1118 read_f (dtp
, f
, p
, kind
);
1120 write_d (dtp
, f
, p
, kind
);
1127 if (require_type (dtp
, BT_REAL
, type
, f
))
1130 if (dtp
->u
.p
.mode
== READING
)
1131 read_f (dtp
, f
, p
, kind
);
1133 write_e (dtp
, f
, p
, kind
);
1139 if (require_type (dtp
, BT_REAL
, type
, f
))
1142 if (dtp
->u
.p
.mode
== READING
)
1143 read_f (dtp
, f
, p
, kind
);
1145 write_en (dtp
, f
, p
, kind
);
1152 if (require_type (dtp
, BT_REAL
, type
, f
))
1155 if (dtp
->u
.p
.mode
== READING
)
1156 read_f (dtp
, f
, p
, kind
);
1158 write_es (dtp
, f
, p
, kind
);
1165 if (require_type (dtp
, BT_REAL
, type
, f
))
1168 if (dtp
->u
.p
.mode
== READING
)
1169 read_f (dtp
, f
, p
, kind
);
1171 write_f (dtp
, f
, p
, kind
);
1178 if (dtp
->u
.p
.mode
== READING
)
1182 read_decimal (dtp
, f
, p
, kind
);
1185 read_l (dtp
, f
, p
, kind
);
1189 read_a_char4 (dtp
, f
, p
, size
);
1191 read_a (dtp
, f
, p
, size
);
1194 read_f (dtp
, f
, p
, kind
);
1203 write_i (dtp
, f
, p
, kind
);
1206 write_l (dtp
, f
, p
, kind
);
1210 write_a_char4 (dtp
, f
, p
, size
);
1212 write_a (dtp
, f
, p
, size
);
1215 if (f
->u
.real
.w
== 0)
1216 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1218 write_d (dtp
, f
, p
, kind
);
1222 internal_error (&dtp
->common
,
1223 "formatted_transfer(): Bad type");
1229 consume_data_flag
= 0;
1230 if (dtp
->u
.p
.mode
== READING
)
1232 format_error (dtp
, f
, "Constant string in input format");
1235 write_constant_string (dtp
, f
);
1238 /* Format codes that don't transfer data. */
1241 consume_data_flag
= 0;
1243 dtp
->u
.p
.skips
+= f
->u
.n
;
1244 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1245 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1246 /* Writes occur just before the switch on f->format, above, so
1247 that trailing blanks are suppressed, unless we are doing a
1248 non-advancing write in which case we want to output the blanks
1250 if (dtp
->u
.p
.mode
== WRITING
1251 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1253 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1254 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1257 if (dtp
->u
.p
.mode
== READING
)
1258 read_x (dtp
, f
->u
.n
);
1264 consume_data_flag
= 0;
1266 if (f
->format
== FMT_TL
)
1269 /* Handle the special case when no bytes have been used yet.
1270 Cannot go below zero. */
1271 if (bytes_used
== 0)
1273 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1274 dtp
->u
.p
.skips
-= f
->u
.n
;
1275 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1278 pos
= bytes_used
- f
->u
.n
;
1282 if (dtp
->u
.p
.mode
== READING
)
1285 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1288 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1289 left tab limit. We do not check if the position has gone
1290 beyond the end of record because a subsequent tab could
1291 bring us back again. */
1292 pos
= pos
< 0 ? 0 : pos
;
1294 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1295 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1296 + pos
- dtp
->u
.p
.max_pos
;
1297 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1298 ? 0 : dtp
->u
.p
.pending_spaces
;
1300 if (dtp
->u
.p
.skips
== 0)
1303 /* Writes occur just before the switch on f->format, above, so that
1304 trailing blanks are suppressed. */
1305 if (dtp
->u
.p
.mode
== READING
)
1307 /* Adjust everything for end-of-record condition */
1308 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1310 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1311 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1313 dtp
->u
.p
.sf_seen_eor
= 0;
1315 if (dtp
->u
.p
.skips
< 0)
1317 if (is_internal_unit (dtp
))
1318 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1320 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1321 dtp
->u
.p
.current_unit
->bytes_left
1322 -= (gfc_offset
) dtp
->u
.p
.skips
;
1323 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1326 read_x (dtp
, dtp
->u
.p
.skips
);
1332 consume_data_flag
= 0;
1333 dtp
->u
.p
.sign_status
= SIGN_S
;
1337 consume_data_flag
= 0;
1338 dtp
->u
.p
.sign_status
= SIGN_SS
;
1342 consume_data_flag
= 0;
1343 dtp
->u
.p
.sign_status
= SIGN_SP
;
1347 consume_data_flag
= 0 ;
1348 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1352 consume_data_flag
= 0;
1353 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1357 consume_data_flag
= 0;
1358 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1362 consume_data_flag
= 0;
1363 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1367 consume_data_flag
= 0;
1368 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1372 consume_data_flag
= 0;
1373 dtp
->u
.p
.seen_dollar
= 1;
1377 consume_data_flag
= 0;
1378 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1379 next_record (dtp
, 0);
1383 /* A colon descriptor causes us to exit this loop (in
1384 particular preventing another / descriptor from being
1385 processed) unless there is another data item to be
1387 consume_data_flag
= 0;
1393 internal_error (&dtp
->common
, "Bad format node");
1396 /* Adjust the item count and data pointer. */
1398 if ((consume_data_flag
> 0) && (n
> 0))
1401 p
= ((char *) p
) + size
;
1404 if (dtp
->u
.p
.mode
== READING
)
1407 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1408 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1414 /* Come here when we need a data descriptor but don't have one. We
1415 push the current format node back onto the input, then return and
1416 let the user program call us back with the data. */
1418 unget_format (dtp
, f
);
1422 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1423 size_t size
, size_t nelems
)
1429 size_t stride
= type
== BT_CHARACTER
?
1430 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1431 /* Big loop over all the elements. */
1432 for (elem
= 0; elem
< nelems
; elem
++)
1434 dtp
->u
.p
.item_count
++;
1435 formatted_transfer_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1441 /* Data transfer entry points. The type of the data entity is
1442 implicit in the subroutine call. This prevents us from having to
1443 share a common enum with the compiler. */
1446 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1448 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1450 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1455 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1458 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1460 size
= size_from_real_kind (kind
);
1461 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1466 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1468 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1470 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1475 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1477 static char *empty_string
[0];
1479 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1482 /* Strings of zero length can have p == NULL, which confuses the
1483 transfer routines into thinking we need more data elements. To avoid
1484 this, we give them a nice pointer. */
1485 if (len
== 0 && p
== NULL
)
1488 /* Set kind here to 1. */
1489 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1493 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1495 static char *empty_string
[0];
1497 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1500 /* Strings of zero length can have p == NULL, which confuses the
1501 transfer routines into thinking we need more data elements. To avoid
1502 this, we give them a nice pointer. */
1503 if (len
== 0 && p
== NULL
)
1506 /* Here we pass the actual kind value. */
1507 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1512 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1515 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1517 size
= size_from_complex_kind (kind
);
1518 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1523 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1524 gfc_charlen_type charlen
)
1526 index_type count
[GFC_MAX_DIMENSIONS
];
1527 index_type extent
[GFC_MAX_DIMENSIONS
];
1528 index_type stride
[GFC_MAX_DIMENSIONS
];
1529 index_type stride0
, rank
, size
, type
, n
;
1534 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1537 type
= GFC_DESCRIPTOR_TYPE (desc
);
1538 size
= GFC_DESCRIPTOR_SIZE (desc
);
1540 /* FIXME: What a kludge: Array descriptors and the IO library use
1541 different enums for types. */
1544 case GFC_DTYPE_UNKNOWN
:
1545 iotype
= BT_NULL
; /* Is this correct? */
1547 case GFC_DTYPE_INTEGER
:
1548 iotype
= BT_INTEGER
;
1550 case GFC_DTYPE_LOGICAL
:
1551 iotype
= BT_LOGICAL
;
1553 case GFC_DTYPE_REAL
:
1556 case GFC_DTYPE_COMPLEX
:
1557 iotype
= BT_COMPLEX
;
1559 case GFC_DTYPE_CHARACTER
:
1560 iotype
= BT_CHARACTER
;
1563 case GFC_DTYPE_DERIVED
:
1564 internal_error (&dtp
->common
,
1565 "Derived type I/O should have been handled via the frontend.");
1568 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1571 rank
= GFC_DESCRIPTOR_RANK (desc
);
1572 for (n
= 0; n
< rank
; n
++)
1575 stride
[n
] = iotype
== BT_CHARACTER
?
1576 desc
->dim
[n
].stride
* GFC_SIZE_OF_CHAR_KIND(kind
) :
1577 desc
->dim
[n
].stride
;
1578 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1580 /* If the extent of even one dimension is zero, then the entire
1581 array section contains zero elements, so we return after writing
1582 a zero array record. */
1587 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1592 stride0
= stride
[0];
1594 /* If the innermost dimension has stride 1, we can do the transfer
1595 in contiguous chunks. */
1601 data
= GFC_DESCRIPTOR_DATA (desc
);
1605 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1606 data
+= stride0
* size
* tsize
;
1609 while (count
[n
] == extent
[n
])
1612 data
-= stride
[n
] * extent
[n
] * size
;
1622 data
+= stride
[n
] * size
;
1629 /* Preposition a sequential unformatted file while reading. */
1632 us_read (st_parameter_dt
*dtp
, int continued
)
1639 if (compile_options
.record_marker
== 0)
1640 n
= sizeof (GFC_INTEGER_4
);
1642 n
= compile_options
.record_marker
;
1644 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1645 if (unlikely (nr
< 0))
1647 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1653 return; /* end of file */
1655 else if (unlikely (n
!= nr
))
1657 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1661 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1662 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1666 case sizeof(GFC_INTEGER_4
):
1667 memcpy (&i4
, &i
, sizeof (i4
));
1671 case sizeof(GFC_INTEGER_8
):
1672 memcpy (&i8
, &i
, sizeof (i8
));
1677 runtime_error ("Illegal value for record marker");
1684 case sizeof(GFC_INTEGER_4
):
1685 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1689 case sizeof(GFC_INTEGER_8
):
1690 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1695 runtime_error ("Illegal value for record marker");
1701 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1702 dtp
->u
.p
.current_unit
->continued
= 0;
1706 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1707 dtp
->u
.p
.current_unit
->continued
= 1;
1711 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1715 /* Preposition a sequential unformatted file while writing. This
1716 amount to writing a bogus length that will be filled in later. */
1719 us_write (st_parameter_dt
*dtp
, int continued
)
1726 if (compile_options
.record_marker
== 0)
1727 nbytes
= sizeof (GFC_INTEGER_4
);
1729 nbytes
= compile_options
.record_marker
;
1731 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
1732 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1734 /* For sequential unformatted, if RECL= was not specified in the OPEN
1735 we write until we have more bytes than can fit in the subrecord
1736 markers, then we write a new subrecord. */
1738 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1739 dtp
->u
.p
.current_unit
->recl_subrecord
;
1740 dtp
->u
.p
.current_unit
->continued
= continued
;
1744 /* Position to the next record prior to transfer. We are assumed to
1745 be before the next record. We also calculate the bytes in the next
1749 pre_position (st_parameter_dt
*dtp
)
1751 if (dtp
->u
.p
.current_unit
->current_record
)
1752 return; /* Already positioned. */
1754 switch (current_mode (dtp
))
1756 case FORMATTED_STREAM
:
1757 case UNFORMATTED_STREAM
:
1758 /* There are no records with stream I/O. If the position was specified
1759 data_transfer_init has already positioned the file. If no position
1760 was specified, we continue from where we last left off. I.e.
1761 there is nothing to do here. */
1764 case UNFORMATTED_SEQUENTIAL
:
1765 if (dtp
->u
.p
.mode
== READING
)
1772 case FORMATTED_SEQUENTIAL
:
1773 case FORMATTED_DIRECT
:
1774 case UNFORMATTED_DIRECT
:
1775 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1779 dtp
->u
.p
.current_unit
->current_record
= 1;
1783 /* Initialize things for a data transfer. This code is common for
1784 both reading and writing. */
1787 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1789 unit_flags u_flags
; /* Used for creating a unit if needed. */
1790 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1791 namelist_info
*ionml
;
1793 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1795 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1797 dtp
->u
.p
.ionml
= ionml
;
1798 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1800 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1803 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1804 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1806 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1807 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1808 { /* Open the unit with some default flags. */
1809 st_parameter_open opp
;
1812 if (dtp
->common
.unit
< 0)
1814 close_unit (dtp
->u
.p
.current_unit
);
1815 dtp
->u
.p
.current_unit
= NULL
;
1816 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1817 "Bad unit number in OPEN statement");
1820 memset (&u_flags
, '\0', sizeof (u_flags
));
1821 u_flags
.access
= ACCESS_SEQUENTIAL
;
1822 u_flags
.action
= ACTION_READWRITE
;
1824 /* Is it unformatted? */
1825 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1826 | IOPARM_DT_IONML_SET
)))
1827 u_flags
.form
= FORM_UNFORMATTED
;
1829 u_flags
.form
= FORM_UNSPECIFIED
;
1831 u_flags
.delim
= DELIM_UNSPECIFIED
;
1832 u_flags
.blank
= BLANK_UNSPECIFIED
;
1833 u_flags
.pad
= PAD_UNSPECIFIED
;
1834 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1835 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1836 u_flags
.async
= ASYNC_UNSPECIFIED
;
1837 u_flags
.round
= ROUND_UNSPECIFIED
;
1838 u_flags
.sign
= SIGN_UNSPECIFIED
;
1840 u_flags
.status
= STATUS_UNKNOWN
;
1842 conv
= get_unformatted_convert (dtp
->common
.unit
);
1844 if (conv
== GFC_CONVERT_NONE
)
1845 conv
= compile_options
.convert
;
1847 /* We use big_endian, which is 0 on little-endian machines
1848 and 1 on big-endian machines. */
1851 case GFC_CONVERT_NATIVE
:
1852 case GFC_CONVERT_SWAP
:
1855 case GFC_CONVERT_BIG
:
1856 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1859 case GFC_CONVERT_LITTLE
:
1860 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1864 internal_error (&opp
.common
, "Illegal value for CONVERT");
1868 u_flags
.convert
= conv
;
1870 opp
.common
= dtp
->common
;
1871 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1872 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1873 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1874 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1875 if (dtp
->u
.p
.current_unit
== NULL
)
1879 /* Check the action. */
1881 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1883 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1884 "Cannot read from file opened for WRITE");
1888 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1890 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1891 "Cannot write to file opened for READ");
1895 dtp
->u
.p
.first_item
= 1;
1897 /* Check the format. */
1899 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1902 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1903 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1906 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1907 "Format present for UNFORMATTED data transfer");
1911 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1913 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1914 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1915 "A format cannot be specified with a namelist");
1917 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1918 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1920 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1921 "Missing format for FORMATTED data transfer");
1924 if (is_internal_unit (dtp
)
1925 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1927 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1928 "Internal file cannot be accessed by UNFORMATTED "
1933 /* Check the record or position number. */
1935 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1936 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1938 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1939 "Direct access data transfer requires record number");
1943 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1944 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1946 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1947 "Record number not allowed for sequential access "
1952 /* Process the ADVANCE option. */
1954 dtp
->u
.p
.advance_status
1955 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1956 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1957 "Bad ADVANCE parameter in data transfer statement");
1959 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1961 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1963 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1964 "ADVANCE specification conflicts with sequential "
1969 if (is_internal_unit (dtp
))
1971 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1972 "ADVANCE specification conflicts with internal file");
1976 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1977 != IOPARM_DT_HAS_FORMAT
)
1979 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1980 "ADVANCE specification requires an explicit format");
1987 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1989 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1991 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1992 "EOR specification requires an ADVANCE specification "
1997 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
1998 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2000 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2001 "SIZE specification requires an ADVANCE "
2002 "specification of NO");
2007 { /* Write constraints. */
2008 if ((cf
& IOPARM_END
) != 0)
2010 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2011 "END specification cannot appear in a write "
2016 if ((cf
& IOPARM_EOR
) != 0)
2018 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2019 "EOR specification cannot appear in a write "
2024 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2026 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2027 "SIZE specification cannot appear in a write "
2033 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2034 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2036 /* Check the decimal mode. */
2037 dtp
->u
.p
.current_unit
->decimal_status
2038 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2039 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2040 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2043 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2044 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2046 /* Check the sign mode. */
2047 dtp
->u
.p
.sign_status
2048 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2049 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2050 "Bad SIGN parameter in data transfer statement");
2052 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2053 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2055 /* Check the blank mode. */
2056 dtp
->u
.p
.blank_status
2057 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2058 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2060 "Bad BLANK parameter in data transfer statement");
2062 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2063 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2065 /* Check the delim mode. */
2066 dtp
->u
.p
.current_unit
->delim_status
2067 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2068 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2069 delim_opt
, "Bad DELIM parameter in data transfer statement");
2071 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2072 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2074 /* Check the pad mode. */
2075 dtp
->u
.p
.current_unit
->pad_status
2076 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2077 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2078 "Bad PAD parameter in data transfer statement");
2080 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2081 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2083 /* Check to see if we might be reading what we wrote before */
2085 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2086 && !is_internal_unit (dtp
))
2088 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2090 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2091 sflush(dtp
->u
.p
.current_unit
->s
);
2094 /* Check the POS= specifier: that it is in range and that it is used with a
2095 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2097 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2099 if (is_stream_io (dtp
))
2104 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2105 "POS=specifier must be positive");
2109 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2111 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2112 "POS=specifier too large");
2116 dtp
->rec
= dtp
->pos
;
2118 if (dtp
->u
.p
.mode
== READING
)
2120 /* Reset the endfile flag; if we hit EOF during reading
2121 we'll set the flag and generate an error at that point
2122 rather than worrying about it here. */
2123 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2126 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2128 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2129 sflush (dtp
->u
.p
.current_unit
->s
);
2130 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2132 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2135 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2140 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2141 "POS=specifier not allowed, "
2142 "Try OPEN with ACCESS='stream'");
2148 /* Sanity checks on the record number. */
2149 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2153 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2154 "Record number must be positive");
2158 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2160 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2161 "Record number too large");
2165 /* Make sure format buffer is reset. */
2166 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2167 fbuf_reset (dtp
->u
.p
.current_unit
);
2170 /* Check whether the record exists to be read. Only
2171 a partial record needs to exist. */
2173 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2174 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2176 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2177 "Non-existing record number");
2181 /* Position the file. */
2182 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2183 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2185 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2189 /* TODO: This is required to maintain compatibility between
2190 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2192 if (is_stream_io (dtp
))
2193 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2195 /* TODO: Un-comment this code when ABI changes from 4.3.
2196 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2198 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2199 "Record number not allowed for stream access "
2205 /* Bugware for badly written mixed C-Fortran I/O. */
2206 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2208 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2210 /* Set the maximum position reached from the previous I/O operation. This
2211 could be greater than zero from a previous non-advancing write. */
2212 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2217 /* Set up the subroutine that will handle the transfers. */
2221 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2222 dtp
->u
.p
.transfer
= unformatted_read
;
2225 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2226 dtp
->u
.p
.transfer
= list_formatted_read
;
2228 dtp
->u
.p
.transfer
= formatted_transfer
;
2233 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2234 dtp
->u
.p
.transfer
= unformatted_write
;
2237 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2238 dtp
->u
.p
.transfer
= list_formatted_write
;
2240 dtp
->u
.p
.transfer
= formatted_transfer
;
2244 /* Make sure that we don't do a read after a nonadvancing write. */
2248 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2250 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2251 "Cannot READ after a nonadvancing WRITE");
2257 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2258 dtp
->u
.p
.current_unit
->read_bad
= 1;
2261 /* Start the data transfer if we are doing a formatted transfer. */
2262 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2263 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2264 && dtp
->u
.p
.ionml
== NULL
)
2265 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2268 /* Initialize an array_loop_spec given the array descriptor. The function
2269 returns the index of the last element of the array, and also returns
2270 starting record, where the first I/O goes to (necessary in case of
2271 negative strides). */
2274 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2275 gfc_offset
*start_record
)
2277 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2286 for (i
=0; i
<rank
; i
++)
2288 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2289 ls
[i
].start
= desc
->dim
[i
].lbound
;
2290 ls
[i
].end
= desc
->dim
[i
].ubound
;
2291 ls
[i
].step
= desc
->dim
[i
].stride
;
2292 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2294 if (desc
->dim
[i
].stride
> 0)
2296 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2297 * desc
->dim
[i
].stride
;
2301 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2302 * desc
->dim
[i
].stride
;
2303 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2304 * desc
->dim
[i
].stride
;
2314 /* Determine the index to the next record in an internal unit array by
2315 by incrementing through the array_loop_spec. */
2318 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2326 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2331 if (ls
[i
].idx
> ls
[i
].end
)
2333 ls
[i
].idx
= ls
[i
].start
;
2339 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2349 /* Skip to the end of the current record, taking care of an optional
2350 record marker of size bytes. If the file is not seekable, we
2351 read chunks of size MAX_READ until we get to the right
2355 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2359 static const size_t MAX_READ
= 4096;
2362 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2363 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2366 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2368 /* Direct access files do not generate END conditions,
2370 if (sseek (dtp
->u
.p
.current_unit
->s
,
2371 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2372 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2375 { /* Seek by reading data. */
2376 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2379 (MAX_READ
< (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2380 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2382 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2385 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2389 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2396 /* Advance to the next record reading unformatted files, taking
2397 care of subrecords. If complete_record is nonzero, we loop
2398 until all subrecords are cleared. */
2401 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2405 bytes
= compile_options
.record_marker
== 0 ?
2406 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2411 /* Skip over tail */
2413 skip_record (dtp
, bytes
);
2415 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2423 static inline gfc_offset
2424 min_off (gfc_offset a
, gfc_offset b
)
2426 return (a
< b
? a
: b
);
2430 /* Space to the next record for read mode. */
2433 next_record_r (st_parameter_dt
*dtp
)
2440 switch (current_mode (dtp
))
2442 /* No records in unformatted STREAM I/O. */
2443 case UNFORMATTED_STREAM
:
2446 case UNFORMATTED_SEQUENTIAL
:
2447 next_record_r_unf (dtp
, 1);
2448 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2451 case FORMATTED_DIRECT
:
2452 case UNFORMATTED_DIRECT
:
2453 skip_record (dtp
, 0);
2456 case FORMATTED_STREAM
:
2457 case FORMATTED_SEQUENTIAL
:
2458 /* read_sf has already terminated input because of an '\n', or
2460 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2462 dtp
->u
.p
.sf_seen_eor
= 0;
2463 dtp
->u
.p
.at_eof
= 0;
2467 if (is_internal_unit (dtp
))
2469 if (is_array_io (dtp
))
2473 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2476 /* Now seek to this record. */
2477 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2478 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2480 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2483 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2487 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2488 bytes_left
= min_off (bytes_left
,
2489 file_length (dtp
->u
.p
.current_unit
->s
)
2490 - stell (dtp
->u
.p
.current_unit
->s
));
2491 if (sseek (dtp
->u
.p
.current_unit
->s
,
2492 bytes_left
, SEEK_CUR
) < 0)
2494 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2497 dtp
->u
.p
.current_unit
->bytes_left
2498 = dtp
->u
.p
.current_unit
->recl
;
2507 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2511 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2517 if (is_stream_io (dtp
))
2518 dtp
->u
.p
.current_unit
->strm_pos
++;
2529 /* Small utility function to write a record marker, taking care of
2530 byte swapping and of choosing the correct size. */
2533 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2538 char p
[sizeof (GFC_INTEGER_8
)];
2540 if (compile_options
.record_marker
== 0)
2541 len
= sizeof (GFC_INTEGER_4
);
2543 len
= compile_options
.record_marker
;
2545 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2546 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2550 case sizeof (GFC_INTEGER_4
):
2552 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2555 case sizeof (GFC_INTEGER_8
):
2557 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2561 runtime_error ("Illegal value for record marker");
2569 case sizeof (GFC_INTEGER_4
):
2571 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2572 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2575 case sizeof (GFC_INTEGER_8
):
2577 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2578 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2582 runtime_error ("Illegal value for record marker");
2589 /* Position to the next (sub)record in write mode for
2590 unformatted sequential files. */
2593 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2595 gfc_offset c
, m
, m_write
;
2596 size_t record_marker
;
2598 /* Bytes written. */
2599 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2600 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2601 c
= stell (dtp
->u
.p
.current_unit
->s
);
2603 /* Write the length tail. If we finish a record containing
2604 subrecords, we write out the negative length. */
2606 if (dtp
->u
.p
.current_unit
->continued
)
2611 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2614 if (compile_options
.record_marker
== 0)
2615 record_marker
= sizeof (GFC_INTEGER_4
);
2617 record_marker
= compile_options
.record_marker
;
2619 /* Seek to the head and overwrite the bogus length with the real
2622 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
,
2631 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2634 /* Seek past the end of the current record. */
2636 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
,
2643 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2649 /* Utility function like memset() but operating on streams. Return
2650 value is same as for POSIX write(). */
2653 sset (stream
* s
, int c
, ssize_t nbyte
)
2655 static const int WRITE_CHUNK
= 256;
2656 char p
[WRITE_CHUNK
];
2657 ssize_t bytes_left
, trans
;
2659 if (nbyte
< WRITE_CHUNK
)
2660 memset (p
, c
, nbyte
);
2662 memset (p
, c
, WRITE_CHUNK
);
2665 while (bytes_left
> 0)
2667 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2668 trans
= swrite (s
, p
, trans
);
2671 bytes_left
-= trans
;
2674 return nbyte
- bytes_left
;
2677 /* Position to the next record in write mode. */
2680 next_record_w (st_parameter_dt
*dtp
, int done
)
2682 gfc_offset m
, record
, max_pos
;
2685 /* Zero counters for X- and T-editing. */
2686 max_pos
= dtp
->u
.p
.max_pos
;
2687 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2689 switch (current_mode (dtp
))
2691 /* No records in unformatted STREAM I/O. */
2692 case UNFORMATTED_STREAM
:
2695 case FORMATTED_DIRECT
:
2696 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2699 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2700 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2701 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2702 dtp
->u
.p
.current_unit
->bytes_left
)
2703 != dtp
->u
.p
.current_unit
->bytes_left
)
2708 case UNFORMATTED_DIRECT
:
2709 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2711 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2712 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
2717 case UNFORMATTED_SEQUENTIAL
:
2718 next_record_w_unf (dtp
, 0);
2719 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2722 case FORMATTED_STREAM
:
2723 case FORMATTED_SEQUENTIAL
:
2725 if (is_internal_unit (dtp
))
2727 if (is_array_io (dtp
))
2731 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2733 /* If the farthest position reached is greater than current
2734 position, adjust the position and set length to pad out
2735 whats left. Otherwise just pad whats left.
2736 (for character array unit) */
2737 m
= dtp
->u
.p
.current_unit
->recl
2738 - dtp
->u
.p
.current_unit
->bytes_left
;
2741 length
= (int) (max_pos
- m
);
2742 if (sseek (dtp
->u
.p
.current_unit
->s
,
2743 length
, SEEK_CUR
) < 0)
2745 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2748 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2751 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
2753 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2757 /* Now that the current record has been padded out,
2758 determine where the next record in the array is. */
2759 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2762 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2764 /* Now seek to this record */
2765 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2767 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2769 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2773 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2779 /* If this is the last call to next_record move to the farthest
2780 position reached and set length to pad out the remainder
2781 of the record. (for character scaler unit) */
2784 m
= dtp
->u
.p
.current_unit
->recl
2785 - dtp
->u
.p
.current_unit
->bytes_left
;
2788 length
= (int) (max_pos
- m
);
2789 if (sseek (dtp
->u
.p
.current_unit
->s
,
2790 length
, SEEK_CUR
) < 0)
2792 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2795 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2798 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2801 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
2803 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2815 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2816 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
2823 if (is_stream_io (dtp
))
2825 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2826 if (dtp
->u
.p
.current_unit
->strm_pos
2827 < file_length (dtp
->u
.p
.current_unit
->s
))
2828 unit_truncate (dtp
->u
.p
.current_unit
,
2829 dtp
->u
.p
.current_unit
->strm_pos
- 1,
2837 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2842 /* Position to the next record, which means moving to the end of the
2843 current record. This can happen under several different
2844 conditions. If the done flag is not set, we get ready to process
2848 next_record (st_parameter_dt
*dtp
, int done
)
2850 gfc_offset fp
; /* File position. */
2852 dtp
->u
.p
.current_unit
->read_bad
= 0;
2854 if (dtp
->u
.p
.mode
== READING
)
2855 next_record_r (dtp
);
2857 next_record_w (dtp
, done
);
2859 if (!is_stream_io (dtp
))
2861 /* Keep position up to date for INQUIRE */
2863 update_position (dtp
->u
.p
.current_unit
);
2865 dtp
->u
.p
.current_unit
->current_record
= 0;
2866 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2868 fp
= stell (dtp
->u
.p
.current_unit
->s
);
2869 /* Calculate next record, rounding up partial records. */
2870 dtp
->u
.p
.current_unit
->last_record
=
2871 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2872 dtp
->u
.p
.current_unit
->recl
;
2875 dtp
->u
.p
.current_unit
->last_record
++;
2881 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2885 /* Finalize the current data transfer. For a nonadvancing transfer,
2886 this means advancing to the next record. For internal units close the
2887 stream associated with the unit. */
2890 finalize_transfer (st_parameter_dt
*dtp
)
2893 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2895 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2896 *dtp
->size
= dtp
->u
.p
.size_used
;
2898 if (dtp
->u
.p
.eor_condition
)
2900 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2904 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2907 if ((dtp
->u
.p
.ionml
!= NULL
)
2908 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2910 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2911 namelist_read (dtp
);
2913 namelist_write (dtp
);
2916 dtp
->u
.p
.transfer
= NULL
;
2917 if (dtp
->u
.p
.current_unit
== NULL
)
2920 dtp
->u
.p
.eof_jump
= &eof_jump
;
2921 if (setjmp (eof_jump
))
2923 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2927 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2929 finish_list_read (dtp
);
2933 if (dtp
->u
.p
.mode
== WRITING
)
2934 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2935 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2937 if (is_stream_io (dtp
))
2939 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2940 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2941 next_record (dtp
, 1);
2943 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2944 && stell (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2946 sflush (dtp
->u
.p
.current_unit
->s
);
2951 dtp
->u
.p
.current_unit
->current_record
= 0;
2953 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2955 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2956 dtp
->u
.p
.seen_dollar
= 0;
2960 /* For non-advancing I/O, save the current maximum position for use in the
2961 next I/O operation if needed. */
2962 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2964 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2965 - dtp
->u
.p
.current_unit
->bytes_left
);
2966 dtp
->u
.p
.current_unit
->saved_pos
=
2967 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2968 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2969 sflush (dtp
->u
.p
.current_unit
->s
);
2972 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2973 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
2974 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2976 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2978 next_record (dtp
, 1);
2981 /* Transfer function for IOLENGTH. It doesn't actually do any
2982 data transfer, it just updates the length counter. */
2985 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2986 void *dest
__attribute__ ((unused
)),
2987 int kind
__attribute__((unused
)),
2988 size_t size
, size_t nelems
)
2990 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2991 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2995 /* Initialize the IOLENGTH data transfer. This function is in essence
2996 a very much simplified version of data_transfer_init(), because it
2997 doesn't have to deal with units at all. */
3000 iolength_transfer_init (st_parameter_dt
*dtp
)
3002 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3005 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3007 /* Set up the subroutine that will handle the transfers. */
3009 dtp
->u
.p
.transfer
= iolength_transfer
;
3013 /* Library entry point for the IOLENGTH form of the INQUIRE
3014 statement. The IOLENGTH form requires no I/O to be performed, but
3015 it must still be a runtime library call so that we can determine
3016 the iolength for dynamic arrays and such. */
3018 extern void st_iolength (st_parameter_dt
*);
3019 export_proto(st_iolength
);
3022 st_iolength (st_parameter_dt
*dtp
)
3024 library_start (&dtp
->common
);
3025 iolength_transfer_init (dtp
);
3028 extern void st_iolength_done (st_parameter_dt
*);
3029 export_proto(st_iolength_done
);
3032 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3039 /* The READ statement. */
3041 extern void st_read (st_parameter_dt
*);
3042 export_proto(st_read
);
3045 st_read (st_parameter_dt
*dtp
)
3047 library_start (&dtp
->common
);
3049 data_transfer_init (dtp
, 1);
3052 extern void st_read_done (st_parameter_dt
*);
3053 export_proto(st_read_done
);
3056 st_read_done (st_parameter_dt
*dtp
)
3058 finalize_transfer (dtp
);
3059 free_format_data (dtp
);
3061 if (dtp
->u
.p
.current_unit
!= NULL
)
3062 unlock_unit (dtp
->u
.p
.current_unit
);
3064 free_internal_unit (dtp
);
3069 extern void st_write (st_parameter_dt
*);
3070 export_proto(st_write
);
3073 st_write (st_parameter_dt
*dtp
)
3075 library_start (&dtp
->common
);
3076 data_transfer_init (dtp
, 0);
3079 extern void st_write_done (st_parameter_dt
*);
3080 export_proto(st_write_done
);
3083 st_write_done (st_parameter_dt
*dtp
)
3085 finalize_transfer (dtp
);
3087 /* Deal with endfile conditions associated with sequential files. */
3089 if (dtp
->u
.p
.current_unit
!= NULL
3090 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3091 switch (dtp
->u
.p
.current_unit
->endfile
)
3093 case AT_ENDFILE
: /* Remain at the endfile record. */
3097 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3101 /* Get rid of whatever is after this record. */
3102 if (!is_internal_unit (dtp
))
3103 unit_truncate (dtp
->u
.p
.current_unit
,
3104 stell (dtp
->u
.p
.current_unit
->s
),
3106 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3110 free_format_data (dtp
);
3112 if (dtp
->u
.p
.current_unit
!= NULL
)
3113 unlock_unit (dtp
->u
.p
.current_unit
);
3115 free_internal_unit (dtp
);
3121 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3123 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3128 /* Receives the scalar information for namelist objects and stores it
3129 in a linked list of namelist_info types. */
3131 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3132 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3133 export_proto(st_set_nml_var
);
3137 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3138 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3139 GFC_INTEGER_4 dtype
)
3141 namelist_info
*t1
= NULL
;
3143 size_t var_name_len
= strlen (var_name
);
3145 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3147 nml
->mem_pos
= var_addr
;
3149 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3150 memcpy (nml
->var_name
, var_name
, var_name_len
);
3151 nml
->var_name
[var_name_len
] = '\0';
3153 nml
->len
= (int) len
;
3154 nml
->string_length
= (index_type
) string_length
;
3156 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3157 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3158 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3160 if (nml
->var_rank
> 0)
3162 nml
->dim
= (descriptor_dimension
*)
3163 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3164 nml
->ls
= (array_loop_spec
*)
3165 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3175 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3177 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3178 dtp
->u
.p
.ionml
= nml
;
3182 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3187 /* Store the dimensional information for the namelist object. */
3188 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3189 index_type
, index_type
,
3191 export_proto(st_set_nml_var_dim
);
3194 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3195 index_type stride
, index_type lbound
,
3198 namelist_info
* nml
;
3203 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3205 nml
->dim
[n
].stride
= stride
;
3206 nml
->dim
[n
].lbound
= lbound
;
3207 nml
->dim
[n
].ubound
= ubound
;
3210 /* Reverse memcpy - used for byte swapping. */
3212 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3218 s
= (char *) src
+ n
- 1;
3220 /* Write with ascending order - this is likely faster
3221 on modern architectures because of write combining. */
3227 /* Once upon a time, a poor innocent Fortran program was reading a
3228 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3229 the OS doesn't tell whether we're at the EOF or whether we already
3230 went past it. Luckily our hero, libgfortran, keeps track of this.
3231 Call this function when you detect an EOF condition. See Section
3235 hit_eof (st_parameter_dt
* dtp
)
3237 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3239 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3240 switch (dtp
->u
.p
.current_unit
->endfile
)
3244 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3245 if (!is_internal_unit (dtp
))
3247 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3248 dtp
->u
.p
.current_unit
->current_record
= 0;
3251 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3255 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3256 dtp
->u
.p
.current_unit
->current_record
= 0;
3261 /* Non-sequential files don't have an ENDFILE record, so we
3262 can't be at AFTER_ENDFILE. */
3263 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3264 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3265 dtp
->u
.p
.current_unit
->current_record
= 0;