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 (sread (dtp
->u
.p
.current_unit
->s
, p
, &readlen
) != 0 || readlen
< (size_t) *length
)
210 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
222 if (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0)
224 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
228 /* If we have a line without a terminating \n, drop through to
230 if (readlen
< 1 && n
== 0)
234 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
238 if (readlen
< 1 || 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;
248 /* If we encounter a CR, it might be a CRLF. */
249 if (q
== '\r') /* Probably a CRLF */
252 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
253 if (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0)
255 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
258 if (q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
259 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
264 /* Without padding, terminate the I/O statement without assigning
265 the value. With padding, the value still needs to be assigned,
266 so we can just continue with a short read. */
267 if (dtp
->u
.p
.pad_status
== PAD_NO
)
271 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
276 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
279 /* Short circuit the read if a comma is found during numeric input.
280 The flag is set to zero during character reads so that commas in
281 strings are not ignored */
283 if (dtp
->u
.p
.sf_read_comma
== 1)
285 notify_std (&dtp
->common
, GFC_STD_GNU
,
286 "Comma in formatted numeric read.");
293 dtp
->u
.p
.sf_seen_eor
= 0;
298 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
300 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
301 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
307 /* Function for reading the next couple of bytes from the current
308 file, advancing the current position. We return FAILURE on end of record or
309 end of file. This function is only for formatted I/O, unformatted uses
312 If the read is short, then it is because the current record does not
313 have enough data to satisfy the read request and the file was
314 opened with PAD=YES. The caller must assume tailing spaces for
318 read_block_form (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
324 if (!is_stream_io (dtp
))
326 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
328 /* For preconnected units with default record length, set bytes left
329 to unit record length and proceed, otherwise error. */
330 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
331 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
332 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
335 if (dtp
->u
.p
.pad_status
== PAD_NO
)
337 /* Not enough data left. */
338 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
343 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
345 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
346 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
350 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
354 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
355 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
356 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
359 source
= read_sf (dtp
, &nb
, 0);
361 dtp
->u
.p
.current_unit
->strm_pos
+=
362 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
365 memcpy (buf
, source
, *nbytes
);
368 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
371 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
373 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
377 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
378 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
380 if (nread
!= *nbytes
)
381 { /* Short read, this shouldn't happen. */
382 if (dtp
->u
.p
.pad_status
== PAD_YES
)
386 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
391 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
397 /* Reads a block directly into application data space. This is for
398 unformatted files. */
401 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
403 size_t to_read_record
;
404 size_t have_read_record
;
405 size_t to_read_subrecord
;
406 size_t have_read_subrecord
;
409 if (is_stream_io (dtp
))
411 to_read_record
= *nbytes
;
412 have_read_record
= to_read_record
;
413 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &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 (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. */
425 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
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 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
450 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
454 if (to_read_record
!= *nbytes
)
456 /* Short read, e.g. if we hit EOF. Apparently, we read
457 more than was written to the last record. */
458 *nbytes
= to_read_record
;
464 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
470 /* Unformatted sequential. We loop over the subrecords, reading
471 until the request has been fulfilled or the record has run out
472 of continuation subrecords. */
474 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
476 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
480 /* Check whether we exceed the total record length. */
482 if (dtp
->u
.p
.current_unit
->flags
.has_recl
483 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
485 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
490 to_read_record
= *nbytes
;
493 have_read_record
= 0;
497 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
498 < (gfc_offset
) to_read_record
)
500 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
501 to_read_record
-= to_read_subrecord
;
505 to_read_subrecord
= to_read_record
;
509 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
511 have_read_subrecord
= to_read_subrecord
;
512 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
513 &have_read_subrecord
) != 0)
515 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
519 have_read_record
+= have_read_subrecord
;
521 if (to_read_subrecord
!= have_read_subrecord
)
524 /* Short read, e.g. if we hit EOF. This means the record
525 structure has been corrupted, or the trailing record
526 marker would still be present. */
528 *nbytes
= have_read_record
;
529 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
533 if (to_read_record
> 0)
535 if (dtp
->u
.p
.current_unit
->continued
)
537 next_record_r_unf (dtp
, 0);
542 /* Let's make sure the file position is correctly pre-positioned
543 for the next read statement. */
545 dtp
->u
.p
.current_unit
->current_record
= 0;
546 next_record_r_unf (dtp
, 0);
547 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
553 /* Normal exit, the read request has been fulfilled. */
558 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
561 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
568 /* Function for writing a block of bytes to the current file at the
569 current position, advancing the file pointer. We are given a length
570 and return a pointer to a buffer that the caller must (completely)
571 fill in. Returns NULL on error. */
574 write_block (st_parameter_dt
*dtp
, int length
)
578 if (!is_stream_io (dtp
))
580 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
582 /* For preconnected units with default record length, set bytes left
583 to unit record length and proceed, otherwise error. */
584 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
585 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
586 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
587 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
590 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
595 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
598 if (is_internal_unit (dtp
))
600 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
604 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
608 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
609 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
613 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
616 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
621 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
622 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
624 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
630 /* High level interface to swrite(), taking care of errors. This is only
631 called for unformatted files. There are three cases to consider:
632 Stream I/O, unformatted direct, unformatted sequential. */
635 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
638 size_t have_written
, to_write_subrecord
;
643 if (is_stream_io (dtp
))
645 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
647 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
651 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
656 /* Unformatted direct access. */
658 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
660 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
662 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
666 if (buf
== NULL
&& nbytes
== 0)
669 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
671 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
675 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
676 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
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 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
707 &to_write_subrecord
) != 0)
709 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
713 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
714 nbytes
-= to_write_subrecord
;
715 have_written
+= to_write_subrecord
;
720 next_record_w_unf (dtp
, 1);
723 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
726 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
733 /* Master function for unformatted reads. */
736 unformatted_read (st_parameter_dt
*dtp
, bt type
,
737 void *dest
, int kind
, size_t size
, size_t nelems
)
741 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
745 if (type
== BT_CHARACTER
)
746 sz
*= GFC_SIZE_OF_CHAR_KIND(kind
);
747 read_block_direct (dtp
, dest
, &sz
);
756 /* Handle wide chracters. */
757 if (type
== BT_CHARACTER
&& kind
!= 1)
763 /* Break up complex into its constituent reals. */
764 if (type
== BT_COMPLEX
)
770 /* By now, all complex variables have been split into their
771 constituent reals. */
773 for (i
= 0; i
< nelems
; i
++)
775 read_block_direct (dtp
, buffer
, &size
);
776 reverse_memcpy (p
, buffer
, size
);
783 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
784 bytes on 64 bit machines. The unused bytes are not initialized and never
785 used, which can show an error with memory checking analyzers like
789 unformatted_write (st_parameter_dt
*dtp
, bt type
,
790 void *source
, int kind
, size_t size
, size_t nelems
)
792 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
795 size_t stride
= type
== BT_CHARACTER
?
796 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
798 write_buf (dtp
, source
, stride
* nelems
);
808 /* Handle wide chracters. */
809 if (type
== BT_CHARACTER
&& kind
!= 1)
815 /* Break up complex into its constituent reals. */
816 if (type
== BT_COMPLEX
)
822 /* By now, all complex variables have been split into their
823 constituent reals. */
825 for (i
= 0; i
< nelems
; i
++)
827 reverse_memcpy(buffer
, p
, size
);
829 write_buf (dtp
, buffer
, size
);
835 /* Return a pointer to the name of a type. */
860 internal_error (NULL
, "type_name(): Bad type");
867 /* Write a constant string to the output.
868 This is complicated because the string can have doubled delimiters
869 in it. The length in the format node is the true length. */
872 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
874 char c
, delimiter
, *p
, *q
;
877 length
= f
->u
.string
.length
;
881 p
= write_block (dtp
, length
);
888 for (; length
> 0; length
--)
891 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
892 q
++; /* Skip the doubled delimiter. */
897 /* Given actual and expected types in a formatted data transfer, make
898 sure they agree. If not, an error message is generated. Returns
899 nonzero if something went wrong. */
902 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
906 if (actual
== expected
)
909 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
910 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
912 format_error (dtp
, f
, buffer
);
917 /* This subroutine is the main loop for a formatted data transfer
918 statement. It would be natural to implement this as a coroutine
919 with the user program, but C makes that awkward. We loop,
920 processing format elements. When we actually have to transfer
921 data instead of just setting flags, we return control to the user
922 program which calls a subroutine that supplies the address and type
923 of the next element, then comes back here to process it. */
926 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
929 char scratch
[SCRATCH_SIZE
];
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
= dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
? 0 : 1;
954 dtp
->u
.p
.line_buffer
= scratch
;
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. */
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
);
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)
1217 if (f
->u
.real
.d
== 0)
1218 write_real (dtp
, p
, kind
);
1220 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1223 write_d (dtp
, f
, p
, kind
);
1227 internal_error (&dtp
->common
,
1228 "formatted_transfer(): Bad type");
1234 consume_data_flag
= 0;
1235 if (dtp
->u
.p
.mode
== READING
)
1237 format_error (dtp
, f
, "Constant string in input format");
1240 write_constant_string (dtp
, f
);
1243 /* Format codes that don't transfer data. */
1246 consume_data_flag
= 0;
1248 dtp
->u
.p
.skips
+= f
->u
.n
;
1249 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1250 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1252 /* Writes occur just before the switch on f->format, above, so
1253 that trailing blanks are suppressed, unless we are doing a
1254 non-advancing write in which case we want to output the blanks
1256 if (dtp
->u
.p
.mode
== WRITING
1257 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1259 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1260 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1263 if (dtp
->u
.p
.mode
== READING
)
1264 read_x (dtp
, f
->u
.n
);
1270 consume_data_flag
= 0;
1272 if (f
->format
== FMT_TL
)
1275 /* Handle the special case when no bytes have been used yet.
1276 Cannot go below zero. */
1277 if (bytes_used
== 0)
1279 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1280 dtp
->u
.p
.skips
-= f
->u
.n
;
1281 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1284 pos
= bytes_used
- f
->u
.n
;
1288 if (dtp
->u
.p
.mode
== READING
)
1291 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1294 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1295 left tab limit. We do not check if the position has gone
1296 beyond the end of record because a subsequent tab could
1297 bring us back again. */
1298 pos
= pos
< 0 ? 0 : pos
;
1300 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1301 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1302 + pos
- dtp
->u
.p
.max_pos
;
1303 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1304 ? 0 : dtp
->u
.p
.pending_spaces
;
1306 if (dtp
->u
.p
.skips
== 0)
1309 /* Writes occur just before the switch on f->format, above, so that
1310 trailing blanks are suppressed. */
1311 if (dtp
->u
.p
.mode
== READING
)
1313 /* Adjust everything for end-of-record condition */
1314 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1316 if (dtp
->u
.p
.sf_seen_eor
== 2)
1318 /* The EOR was a CRLF (two bytes wide). */
1319 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1320 dtp
->u
.p
.skips
-= 2;
1324 /* The EOR marker was only one byte wide. */
1325 dtp
->u
.p
.current_unit
->bytes_left
--;
1329 dtp
->u
.p
.sf_seen_eor
= 0;
1331 if (dtp
->u
.p
.skips
< 0)
1333 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1334 dtp
->u
.p
.current_unit
->bytes_left
1335 -= (gfc_offset
) dtp
->u
.p
.skips
;
1336 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1339 read_x (dtp
, dtp
->u
.p
.skips
);
1345 consume_data_flag
= 0;
1346 dtp
->u
.p
.sign_status
= SIGN_S
;
1350 consume_data_flag
= 0;
1351 dtp
->u
.p
.sign_status
= SIGN_SS
;
1355 consume_data_flag
= 0;
1356 dtp
->u
.p
.sign_status
= SIGN_SP
;
1360 consume_data_flag
= 0 ;
1361 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1365 consume_data_flag
= 0;
1366 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1370 consume_data_flag
= 0;
1371 dtp
->u
.p
.decimal_status
= DECIMAL_COMMA
;
1375 consume_data_flag
= 0;
1376 dtp
->u
.p
.decimal_status
= DECIMAL_POINT
;
1380 consume_data_flag
= 0;
1381 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1385 consume_data_flag
= 0;
1386 dtp
->u
.p
.seen_dollar
= 1;
1390 consume_data_flag
= 0;
1391 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1392 next_record (dtp
, 0);
1396 /* A colon descriptor causes us to exit this loop (in
1397 particular preventing another / descriptor from being
1398 processed) unless there is another data item to be
1400 consume_data_flag
= 0;
1406 internal_error (&dtp
->common
, "Bad format node");
1409 /* Free a buffer that we had to allocate during a sequential
1410 formatted read of a block that was larger than the static
1413 if (dtp
->u
.p
.line_buffer
!= scratch
)
1415 free_mem (dtp
->u
.p
.line_buffer
);
1416 dtp
->u
.p
.line_buffer
= scratch
;
1419 /* Adjust the item count and data pointer. */
1421 if ((consume_data_flag
> 0) && (n
> 0))
1424 p
= ((char *) p
) + size
;
1427 if (dtp
->u
.p
.mode
== READING
)
1430 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1431 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1437 /* Come here when we need a data descriptor but don't have one. We
1438 push the current format node back onto the input, then return and
1439 let the user program call us back with the data. */
1441 unget_format (dtp
, f
);
1445 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1446 size_t size
, size_t nelems
)
1452 size_t stride
= type
== BT_CHARACTER
?
1453 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1454 /* Big loop over all the elements. */
1455 for (elem
= 0; elem
< nelems
; elem
++)
1457 dtp
->u
.p
.item_count
++;
1458 formatted_transfer_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1464 /* Data transfer entry points. The type of the data entity is
1465 implicit in the subroutine call. This prevents us from having to
1466 share a common enum with the compiler. */
1469 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1471 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1473 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1478 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1481 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1483 size
= size_from_real_kind (kind
);
1484 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1489 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1491 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1493 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1498 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1500 static char *empty_string
[0];
1502 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1505 /* Strings of zero length can have p == NULL, which confuses the
1506 transfer routines into thinking we need more data elements. To avoid
1507 this, we give them a nice pointer. */
1508 if (len
== 0 && p
== NULL
)
1511 /* Set kind here to 1. */
1512 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1516 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1518 static char *empty_string
[0];
1520 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1523 /* Strings of zero length can have p == NULL, which confuses the
1524 transfer routines into thinking we need more data elements. To avoid
1525 this, we give them a nice pointer. */
1526 if (len
== 0 && p
== NULL
)
1529 /* Here we pass the actual kind value. */
1530 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1535 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1538 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1540 size
= size_from_complex_kind (kind
);
1541 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1546 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1547 gfc_charlen_type charlen
)
1549 index_type count
[GFC_MAX_DIMENSIONS
];
1550 index_type extent
[GFC_MAX_DIMENSIONS
];
1551 index_type stride
[GFC_MAX_DIMENSIONS
];
1552 index_type stride0
, rank
, size
, type
, n
;
1557 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1560 type
= GFC_DESCRIPTOR_TYPE (desc
);
1561 size
= GFC_DESCRIPTOR_SIZE (desc
);
1563 /* FIXME: What a kludge: Array descriptors and the IO library use
1564 different enums for types. */
1567 case GFC_DTYPE_UNKNOWN
:
1568 iotype
= BT_NULL
; /* Is this correct? */
1570 case GFC_DTYPE_INTEGER
:
1571 iotype
= BT_INTEGER
;
1573 case GFC_DTYPE_LOGICAL
:
1574 iotype
= BT_LOGICAL
;
1576 case GFC_DTYPE_REAL
:
1579 case GFC_DTYPE_COMPLEX
:
1580 iotype
= BT_COMPLEX
;
1582 case GFC_DTYPE_CHARACTER
:
1583 iotype
= BT_CHARACTER
;
1586 case GFC_DTYPE_DERIVED
:
1587 internal_error (&dtp
->common
,
1588 "Derived type I/O should have been handled via the frontend.");
1591 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1594 rank
= GFC_DESCRIPTOR_RANK (desc
);
1595 for (n
= 0; n
< rank
; n
++)
1598 stride
[n
] = iotype
== BT_CHARACTER
?
1599 desc
->dim
[n
].stride
* GFC_SIZE_OF_CHAR_KIND(kind
) :
1600 desc
->dim
[n
].stride
;
1601 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1603 /* If the extent of even one dimension is zero, then the entire
1604 array section contains zero elements, so we return after writing
1605 a zero array record. */
1610 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1615 stride0
= stride
[0];
1617 /* If the innermost dimension has stride 1, we can do the transfer
1618 in contiguous chunks. */
1624 data
= GFC_DESCRIPTOR_DATA (desc
);
1628 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1629 data
+= stride0
* size
* tsize
;
1632 while (count
[n
] == extent
[n
])
1635 data
-= stride
[n
] * extent
[n
] * size
;
1645 data
+= stride
[n
] * size
;
1652 /* Preposition a sequential unformatted file while reading. */
1655 us_read (st_parameter_dt
*dtp
, int continued
)
1662 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1665 if (compile_options
.record_marker
== 0)
1666 n
= sizeof (GFC_INTEGER_4
);
1668 n
= compile_options
.record_marker
;
1672 if (sread (dtp
->u
.p
.current_unit
->s
, &i
, &n
) != 0)
1674 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1680 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1681 return; /* end of file */
1686 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1690 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1691 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1695 case sizeof(GFC_INTEGER_4
):
1696 memcpy (&i4
, &i
, sizeof (i4
));
1700 case sizeof(GFC_INTEGER_8
):
1701 memcpy (&i8
, &i
, sizeof (i8
));
1706 runtime_error ("Illegal value for record marker");
1713 case sizeof(GFC_INTEGER_4
):
1714 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1718 case sizeof(GFC_INTEGER_8
):
1719 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1724 runtime_error ("Illegal value for record marker");
1730 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1731 dtp
->u
.p
.current_unit
->continued
= 0;
1735 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1736 dtp
->u
.p
.current_unit
->continued
= 1;
1740 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1744 /* Preposition a sequential unformatted file while writing. This
1745 amount to writing a bogus length that will be filled in later. */
1748 us_write (st_parameter_dt
*dtp
, int continued
)
1755 if (compile_options
.record_marker
== 0)
1756 nbytes
= sizeof (GFC_INTEGER_4
);
1758 nbytes
= compile_options
.record_marker
;
1760 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1761 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1763 /* For sequential unformatted, if RECL= was not specified in the OPEN
1764 we write until we have more bytes than can fit in the subrecord
1765 markers, then we write a new subrecord. */
1767 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1768 dtp
->u
.p
.current_unit
->recl_subrecord
;
1769 dtp
->u
.p
.current_unit
->continued
= continued
;
1773 /* Position to the next record prior to transfer. We are assumed to
1774 be before the next record. We also calculate the bytes in the next
1778 pre_position (st_parameter_dt
*dtp
)
1780 if (dtp
->u
.p
.current_unit
->current_record
)
1781 return; /* Already positioned. */
1783 switch (current_mode (dtp
))
1785 case FORMATTED_STREAM
:
1786 case UNFORMATTED_STREAM
:
1787 /* There are no records with stream I/O. If the position was specified
1788 data_transfer_init has already positioned the file. If no position
1789 was specified, we continue from where we last left off. I.e.
1790 there is nothing to do here. */
1793 case UNFORMATTED_SEQUENTIAL
:
1794 if (dtp
->u
.p
.mode
== READING
)
1801 case FORMATTED_SEQUENTIAL
:
1802 case FORMATTED_DIRECT
:
1803 case UNFORMATTED_DIRECT
:
1804 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1808 dtp
->u
.p
.current_unit
->current_record
= 1;
1812 /* Initialize things for a data transfer. This code is common for
1813 both reading and writing. */
1816 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1818 unit_flags u_flags
; /* Used for creating a unit if needed. */
1819 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1820 namelist_info
*ionml
;
1822 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1823 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1824 dtp
->u
.p
.ionml
= ionml
;
1825 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1827 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1830 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1831 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1833 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1834 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1835 { /* Open the unit with some default flags. */
1836 st_parameter_open opp
;
1839 if (dtp
->common
.unit
< 0)
1841 close_unit (dtp
->u
.p
.current_unit
);
1842 dtp
->u
.p
.current_unit
= NULL
;
1843 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1844 "Bad unit number in OPEN statement");
1847 memset (&u_flags
, '\0', sizeof (u_flags
));
1848 u_flags
.access
= ACCESS_SEQUENTIAL
;
1849 u_flags
.action
= ACTION_READWRITE
;
1851 /* Is it unformatted? */
1852 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1853 | IOPARM_DT_IONML_SET
)))
1854 u_flags
.form
= FORM_UNFORMATTED
;
1856 u_flags
.form
= FORM_UNSPECIFIED
;
1858 u_flags
.delim
= DELIM_UNSPECIFIED
;
1859 u_flags
.blank
= BLANK_UNSPECIFIED
;
1860 u_flags
.pad
= PAD_UNSPECIFIED
;
1861 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1862 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1863 u_flags
.async
= ASYNC_UNSPECIFIED
;
1864 u_flags
.round
= ROUND_UNSPECIFIED
;
1865 u_flags
.sign
= SIGN_UNSPECIFIED
;
1866 u_flags
.status
= STATUS_UNKNOWN
;
1868 conv
= get_unformatted_convert (dtp
->common
.unit
);
1870 if (conv
== GFC_CONVERT_NONE
)
1871 conv
= compile_options
.convert
;
1873 /* We use big_endian, which is 0 on little-endian machines
1874 and 1 on big-endian machines. */
1877 case GFC_CONVERT_NATIVE
:
1878 case GFC_CONVERT_SWAP
:
1881 case GFC_CONVERT_BIG
:
1882 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1885 case GFC_CONVERT_LITTLE
:
1886 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1890 internal_error (&opp
.common
, "Illegal value for CONVERT");
1894 u_flags
.convert
= conv
;
1896 opp
.common
= dtp
->common
;
1897 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1898 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1899 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1900 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1901 if (dtp
->u
.p
.current_unit
== NULL
)
1905 /* Check the action. */
1907 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1909 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1910 "Cannot read from file opened for WRITE");
1914 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1916 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1917 "Cannot write to file opened for READ");
1921 dtp
->u
.p
.first_item
= 1;
1923 /* Check the format. */
1925 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1928 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1929 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1932 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1933 "Format present for UNFORMATTED data transfer");
1937 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1939 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1940 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1941 "A format cannot be specified with a namelist");
1943 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1944 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1946 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1947 "Missing format for FORMATTED data transfer");
1950 if (is_internal_unit (dtp
)
1951 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1953 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1954 "Internal file cannot be accessed by UNFORMATTED "
1959 /* Check the record or position number. */
1961 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1962 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1964 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1965 "Direct access data transfer requires record number");
1969 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1970 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1972 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1973 "Record number not allowed for sequential access data transfer");
1977 /* Process the ADVANCE option. */
1979 dtp
->u
.p
.advance_status
1980 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1981 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1982 "Bad ADVANCE parameter in data transfer statement");
1984 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1986 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1988 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1989 "ADVANCE specification conflicts with sequential access");
1993 if (is_internal_unit (dtp
))
1995 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1996 "ADVANCE specification conflicts with internal file");
2000 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2001 != IOPARM_DT_HAS_FORMAT
)
2003 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2004 "ADVANCE specification requires an explicit format");
2011 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2013 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2015 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2016 "EOR specification requires an ADVANCE specification "
2021 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2023 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2024 "SIZE specification requires an ADVANCE specification of NO");
2029 { /* Write constraints. */
2030 if ((cf
& IOPARM_END
) != 0)
2032 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2033 "END specification cannot appear in a write statement");
2037 if ((cf
& IOPARM_EOR
) != 0)
2039 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2040 "EOR specification cannot appear in a write statement");
2044 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2046 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2047 "SIZE specification cannot appear in a write statement");
2052 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2053 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2055 /* Check the decimal mode. */
2057 dtp
->u
.p
.decimal_status
2058 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2059 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
, decimal_opt
,
2060 "Bad DECIMAL parameter in data transfer statement");
2062 if (dtp
->u
.p
.decimal_status
== DECIMAL_UNSPECIFIED
)
2063 dtp
->u
.p
.decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2065 /* Check the sign mode. */
2066 dtp
->u
.p
.sign_status
2067 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2068 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2069 "Bad SIGN parameter in data transfer statement");
2071 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2072 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2074 /* Check the blank mode. */
2075 dtp
->u
.p
.blank_status
2076 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2077 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
, blank_opt
,
2078 "Bad BLANK parameter in data transfer statement");
2080 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2081 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2083 /* Check the delim mode. */
2084 dtp
->u
.p
.delim_status
2085 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2086 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
, delim_opt
,
2087 "Bad DELIM parameter in data transfer statement");
2089 if (dtp
->u
.p
.delim_status
== DELIM_UNSPECIFIED
)
2090 dtp
->u
.p
.delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2092 /* Check the pad mode. */
2094 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2095 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2096 "Bad PAD parameter in data transfer statement");
2098 if (dtp
->u
.p
.pad_status
== PAD_UNSPECIFIED
)
2099 dtp
->u
.p
.pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2101 /* Sanity checks on the record number. */
2102 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2106 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2107 "Record number must be positive");
2111 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2113 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2114 "Record number too large");
2118 /* Check to see if we might be reading what we wrote before */
2120 if (dtp
->u
.p
.mode
== READING
2121 && dtp
->u
.p
.current_unit
->mode
== WRITING
2122 && !is_internal_unit (dtp
))
2124 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2125 flush(dtp
->u
.p
.current_unit
->s
);
2128 /* Check whether the record exists to be read. Only
2129 a partial record needs to exist. */
2131 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2132 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2134 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2135 "Non-existing record number");
2139 /* Position the file. */
2140 if (!is_stream_io (dtp
))
2142 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2143 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2145 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2151 if (dtp
->u
.p
.current_unit
->strm_pos
!= dtp
->rec
)
2153 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2154 flush (dtp
->u
.p
.current_unit
->s
);
2155 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->rec
- 1) == FAILURE
)
2157 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2160 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2166 /* Overwriting an existing sequential file ?
2167 it is always safe to truncate the file on the first write */
2168 if (dtp
->u
.p
.mode
== WRITING
2169 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2170 && dtp
->u
.p
.current_unit
->last_record
== 0
2171 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2172 struncate(dtp
->u
.p
.current_unit
->s
);
2174 /* Bugware for badly written mixed C-Fortran I/O. */
2175 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2177 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2179 /* Set the maximum position reached from the previous I/O operation. This
2180 could be greater than zero from a previous non-advancing write. */
2181 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2186 /* Set up the subroutine that will handle the transfers. */
2190 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2191 dtp
->u
.p
.transfer
= unformatted_read
;
2194 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2195 dtp
->u
.p
.transfer
= list_formatted_read
;
2197 dtp
->u
.p
.transfer
= formatted_transfer
;
2202 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2203 dtp
->u
.p
.transfer
= unformatted_write
;
2206 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2207 dtp
->u
.p
.transfer
= list_formatted_write
;
2209 dtp
->u
.p
.transfer
= formatted_transfer
;
2213 /* Make sure that we don't do a read after a nonadvancing write. */
2217 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2219 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2220 "Cannot READ after a nonadvancing WRITE");
2226 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2227 dtp
->u
.p
.current_unit
->read_bad
= 1;
2230 /* Start the data transfer if we are doing a formatted transfer. */
2231 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2232 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2233 && dtp
->u
.p
.ionml
== NULL
)
2234 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2237 /* Initialize an array_loop_spec given the array descriptor. The function
2238 returns the index of the last element of the array, and also returns
2239 starting record, where the first I/O goes to (necessary in case of
2240 negative strides). */
2243 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2244 gfc_offset
*start_record
)
2246 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2255 for (i
=0; i
<rank
; i
++)
2257 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2258 ls
[i
].start
= desc
->dim
[i
].lbound
;
2259 ls
[i
].end
= desc
->dim
[i
].ubound
;
2260 ls
[i
].step
= desc
->dim
[i
].stride
;
2261 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2263 if (desc
->dim
[i
].stride
> 0)
2265 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2266 * desc
->dim
[i
].stride
;
2270 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2271 * desc
->dim
[i
].stride
;
2272 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2273 * desc
->dim
[i
].stride
;
2283 /* Determine the index to the next record in an internal unit array by
2284 by incrementing through the array_loop_spec. */
2287 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2295 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2300 if (ls
[i
].idx
> ls
[i
].end
)
2302 ls
[i
].idx
= ls
[i
].start
;
2308 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2318 /* Skip to the end of the current record, taking care of an optional
2319 record marker of size bytes. If the file is not seekable, we
2320 read chunks of size MAX_READ until we get to the right
2324 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2328 static const size_t MAX_READ
= 4096;
2331 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2332 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2335 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2337 new = file_position (dtp
->u
.p
.current_unit
->s
)
2338 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2340 /* Direct access files do not generate END conditions,
2342 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2343 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2346 { /* Seek by reading data. */
2347 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2350 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2351 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2353 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2355 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2359 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2366 /* Advance to the next record reading unformatted files, taking
2367 care of subrecords. If complete_record is nonzero, we loop
2368 until all subrecords are cleared. */
2371 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2375 bytes
= compile_options
.record_marker
== 0 ?
2376 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2381 /* Skip over tail */
2383 skip_record (dtp
, bytes
);
2385 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2393 static inline gfc_offset
2394 min_off (gfc_offset a
, gfc_offset b
)
2396 return (a
< b
? a
: b
);
2400 /* Space to the next record for read mode. */
2403 next_record_r (st_parameter_dt
*dtp
)
2410 switch (current_mode (dtp
))
2412 /* No records in unformatted STREAM I/O. */
2413 case UNFORMATTED_STREAM
:
2416 case UNFORMATTED_SEQUENTIAL
:
2417 next_record_r_unf (dtp
, 1);
2418 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2421 case FORMATTED_DIRECT
:
2422 case UNFORMATTED_DIRECT
:
2423 skip_record (dtp
, 0);
2426 case FORMATTED_STREAM
:
2427 case FORMATTED_SEQUENTIAL
:
2429 /* sf_read has already terminated input because of an '\n' */
2430 if (dtp
->u
.p
.sf_seen_eor
)
2432 dtp
->u
.p
.sf_seen_eor
= 0;
2436 if (is_internal_unit (dtp
))
2438 if (is_array_io (dtp
))
2442 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2445 /* Now seek to this record. */
2446 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2447 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2449 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2452 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2456 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2457 bytes_left
= min_off (bytes_left
,
2458 file_length (dtp
->u
.p
.current_unit
->s
)
2459 - file_position (dtp
->u
.p
.current_unit
->s
));
2460 if (sseek (dtp
->u
.p
.current_unit
->s
,
2461 file_position (dtp
->u
.p
.current_unit
->s
)
2462 + bytes_left
) == FAILURE
)
2464 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2467 dtp
->u
.p
.current_unit
->bytes_left
2468 = dtp
->u
.p
.current_unit
->recl
;
2474 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2476 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2482 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2486 if (is_stream_io (dtp
))
2487 dtp
->u
.p
.current_unit
->strm_pos
++;
2494 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2495 && !dtp
->u
.p
.namelist_mode
2496 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2497 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2498 file_position (dtp
->u
.p
.current_unit
->s
)))
2499 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2504 /* Small utility function to write a record marker, taking care of
2505 byte swapping and of choosing the correct size. */
2508 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2513 char p
[sizeof (GFC_INTEGER_8
)];
2515 if (compile_options
.record_marker
== 0)
2516 len
= sizeof (GFC_INTEGER_4
);
2518 len
= compile_options
.record_marker
;
2520 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2521 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2525 case sizeof (GFC_INTEGER_4
):
2527 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2530 case sizeof (GFC_INTEGER_8
):
2532 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2536 runtime_error ("Illegal value for record marker");
2544 case sizeof (GFC_INTEGER_4
):
2546 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2547 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2550 case sizeof (GFC_INTEGER_8
):
2552 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2553 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2557 runtime_error ("Illegal value for record marker");
2564 /* Position to the next (sub)record in write mode for
2565 unformatted sequential files. */
2568 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2570 gfc_offset c
, m
, m_write
;
2571 size_t record_marker
;
2573 /* Bytes written. */
2574 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2575 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2576 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2578 /* Write the length tail. If we finish a record containing
2579 subrecords, we write out the negative length. */
2581 if (dtp
->u
.p
.current_unit
->continued
)
2586 if (write_us_marker (dtp
, m_write
) != 0)
2589 if (compile_options
.record_marker
== 0)
2590 record_marker
= sizeof (GFC_INTEGER_4
);
2592 record_marker
= compile_options
.record_marker
;
2594 /* Seek to the head and overwrite the bogus length with the real
2597 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2606 if (write_us_marker (dtp
, m_write
) != 0)
2609 /* Seek past the end of the current record. */
2611 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2617 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2622 /* Position to the next record in write mode. */
2625 next_record_w (st_parameter_dt
*dtp
, int done
)
2627 gfc_offset m
, record
, max_pos
;
2630 /* Flush and reset the format buffer. */
2631 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2633 /* Zero counters for X- and T-editing. */
2634 max_pos
= dtp
->u
.p
.max_pos
;
2635 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2637 switch (current_mode (dtp
))
2639 /* No records in unformatted STREAM I/O. */
2640 case UNFORMATTED_STREAM
:
2643 case FORMATTED_DIRECT
:
2644 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2647 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2648 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2653 case UNFORMATTED_DIRECT
:
2654 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2656 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2657 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2662 case UNFORMATTED_SEQUENTIAL
:
2663 next_record_w_unf (dtp
, 0);
2664 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2667 case FORMATTED_STREAM
:
2668 case FORMATTED_SEQUENTIAL
:
2670 if (is_internal_unit (dtp
))
2672 if (is_array_io (dtp
))
2676 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2678 /* If the farthest position reached is greater than current
2679 position, adjust the position and set length to pad out
2680 whats left. Otherwise just pad whats left.
2681 (for character array unit) */
2682 m
= dtp
->u
.p
.current_unit
->recl
2683 - dtp
->u
.p
.current_unit
->bytes_left
;
2686 length
= (int) (max_pos
- m
);
2687 if (sseek (dtp
->u
.p
.current_unit
->s
,
2688 file_position (dtp
->u
.p
.current_unit
->s
)
2689 + length
) == FAILURE
)
2691 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2694 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2697 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2699 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2703 /* Now that the current record has been padded out,
2704 determine where the next record in the array is. */
2705 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2708 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2710 /* Now seek to this record */
2711 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2713 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2715 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2719 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2725 /* If this is the last call to next_record move to the farthest
2726 position reached and set length to pad out the remainder
2727 of the record. (for character scaler unit) */
2730 m
= dtp
->u
.p
.current_unit
->recl
2731 - dtp
->u
.p
.current_unit
->bytes_left
;
2734 length
= (int) (max_pos
- m
);
2735 if (sseek (dtp
->u
.p
.current_unit
->s
,
2736 file_position (dtp
->u
.p
.current_unit
->s
)
2737 + length
) == FAILURE
)
2739 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2742 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2745 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2748 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2750 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2758 const char crlf
[] = "\r\n";
2765 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2768 if (is_stream_io (dtp
))
2770 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2771 if (dtp
->u
.p
.current_unit
->strm_pos
2772 < file_length (dtp
->u
.p
.current_unit
->s
))
2773 struncate (dtp
->u
.p
.current_unit
->s
);
2780 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2785 /* Position to the next record, which means moving to the end of the
2786 current record. This can happen under several different
2787 conditions. If the done flag is not set, we get ready to process
2791 next_record (st_parameter_dt
*dtp
, int done
)
2793 gfc_offset fp
; /* File position. */
2795 dtp
->u
.p
.current_unit
->read_bad
= 0;
2797 if (dtp
->u
.p
.mode
== READING
)
2798 next_record_r (dtp
);
2800 next_record_w (dtp
, done
);
2802 if (!is_stream_io (dtp
))
2804 /* Keep position up to date for INQUIRE */
2806 update_position (dtp
->u
.p
.current_unit
);
2808 dtp
->u
.p
.current_unit
->current_record
= 0;
2809 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2811 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2812 /* Calculate next record, rounding up partial records. */
2813 dtp
->u
.p
.current_unit
->last_record
=
2814 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2815 dtp
->u
.p
.current_unit
->recl
;
2818 dtp
->u
.p
.current_unit
->last_record
++;
2826 /* Finalize the current data transfer. For a nonadvancing transfer,
2827 this means advancing to the next record. For internal units close the
2828 stream associated with the unit. */
2831 finalize_transfer (st_parameter_dt
*dtp
)
2834 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2836 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2837 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2839 if (dtp
->u
.p
.eor_condition
)
2841 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2845 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2848 if ((dtp
->u
.p
.ionml
!= NULL
)
2849 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2851 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2852 namelist_read (dtp
);
2854 namelist_write (dtp
);
2857 dtp
->u
.p
.transfer
= NULL
;
2858 if (dtp
->u
.p
.current_unit
== NULL
)
2861 dtp
->u
.p
.eof_jump
= &eof_jump
;
2862 if (setjmp (eof_jump
))
2864 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2868 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2870 finish_list_read (dtp
);
2871 sfree (dtp
->u
.p
.current_unit
->s
);
2875 if (dtp
->u
.p
.mode
== WRITING
)
2876 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2877 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2879 if (is_stream_io (dtp
))
2881 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2882 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2883 next_record (dtp
, 1);
2885 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2886 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2888 flush (dtp
->u
.p
.current_unit
->s
);
2889 sfree (dtp
->u
.p
.current_unit
->s
);
2894 dtp
->u
.p
.current_unit
->current_record
= 0;
2896 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2898 dtp
->u
.p
.seen_dollar
= 0;
2899 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2900 sfree (dtp
->u
.p
.current_unit
->s
);
2904 /* For non-advancing I/O, save the current maximum position for use in the
2905 next I/O operation if needed. */
2906 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2908 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2909 - dtp
->u
.p
.current_unit
->bytes_left
);
2910 dtp
->u
.p
.current_unit
->saved_pos
=
2911 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2912 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2913 flush (dtp
->u
.p
.current_unit
->s
);
2917 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2919 next_record (dtp
, 1);
2920 sfree (dtp
->u
.p
.current_unit
->s
);
2923 /* Transfer function for IOLENGTH. It doesn't actually do any
2924 data transfer, it just updates the length counter. */
2927 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2928 void *dest
__attribute__ ((unused
)),
2929 int kind
__attribute__((unused
)),
2930 size_t size
, size_t nelems
)
2932 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2933 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2937 /* Initialize the IOLENGTH data transfer. This function is in essence
2938 a very much simplified version of data_transfer_init(), because it
2939 doesn't have to deal with units at all. */
2942 iolength_transfer_init (st_parameter_dt
*dtp
)
2944 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2947 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2949 /* Set up the subroutine that will handle the transfers. */
2951 dtp
->u
.p
.transfer
= iolength_transfer
;
2955 /* Library entry point for the IOLENGTH form of the INQUIRE
2956 statement. The IOLENGTH form requires no I/O to be performed, but
2957 it must still be a runtime library call so that we can determine
2958 the iolength for dynamic arrays and such. */
2960 extern void st_iolength (st_parameter_dt
*);
2961 export_proto(st_iolength
);
2964 st_iolength (st_parameter_dt
*dtp
)
2966 library_start (&dtp
->common
);
2967 iolength_transfer_init (dtp
);
2970 extern void st_iolength_done (st_parameter_dt
*);
2971 export_proto(st_iolength_done
);
2974 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2977 if (dtp
->u
.p
.scratch
!= NULL
)
2978 free_mem (dtp
->u
.p
.scratch
);
2983 /* The READ statement. */
2985 extern void st_read (st_parameter_dt
*);
2986 export_proto(st_read
);
2989 st_read (st_parameter_dt
*dtp
)
2991 library_start (&dtp
->common
);
2993 data_transfer_init (dtp
, 1);
2995 /* Handle complications dealing with the endfile record. */
2997 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2998 switch (dtp
->u
.p
.current_unit
->endfile
)
3004 if (!is_internal_unit (dtp
))
3006 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3007 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3008 dtp
->u
.p
.current_unit
->current_record
= 0;
3013 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3014 dtp
->u
.p
.current_unit
->current_record
= 0;
3019 extern void st_read_done (st_parameter_dt
*);
3020 export_proto(st_read_done
);
3023 st_read_done (st_parameter_dt
*dtp
)
3025 finalize_transfer (dtp
);
3026 free_format_data (dtp
);
3028 if (dtp
->u
.p
.scratch
!= NULL
)
3029 free_mem (dtp
->u
.p
.scratch
);
3030 if (dtp
->u
.p
.current_unit
!= NULL
)
3031 unlock_unit (dtp
->u
.p
.current_unit
);
3033 free_internal_unit (dtp
);
3038 extern void st_write (st_parameter_dt
*);
3039 export_proto(st_write
);
3042 st_write (st_parameter_dt
*dtp
)
3044 library_start (&dtp
->common
);
3045 data_transfer_init (dtp
, 0);
3048 extern void st_write_done (st_parameter_dt
*);
3049 export_proto(st_write_done
);
3052 st_write_done (st_parameter_dt
*dtp
)
3054 finalize_transfer (dtp
);
3056 /* Deal with endfile conditions associated with sequential files. */
3058 if (dtp
->u
.p
.current_unit
!= NULL
3059 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3060 switch (dtp
->u
.p
.current_unit
->endfile
)
3062 case AT_ENDFILE
: /* Remain at the endfile record. */
3066 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3070 /* Get rid of whatever is after this record. */
3071 if (!is_internal_unit (dtp
))
3073 flush (dtp
->u
.p
.current_unit
->s
);
3074 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3075 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3077 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3081 free_format_data (dtp
);
3083 if (dtp
->u
.p
.scratch
!= NULL
)
3084 free_mem (dtp
->u
.p
.scratch
);
3085 if (dtp
->u
.p
.current_unit
!= NULL
)
3086 unlock_unit (dtp
->u
.p
.current_unit
);
3088 free_internal_unit (dtp
);
3094 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3096 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3101 /* Receives the scalar information for namelist objects and stores it
3102 in a linked list of namelist_info types. */
3104 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3105 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3106 export_proto(st_set_nml_var
);
3110 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3111 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3112 GFC_INTEGER_4 dtype
)
3114 namelist_info
*t1
= NULL
;
3116 size_t var_name_len
= strlen (var_name
);
3118 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3120 nml
->mem_pos
= var_addr
;
3122 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3123 memcpy (nml
->var_name
, var_name
, var_name_len
);
3124 nml
->var_name
[var_name_len
] = '\0';
3126 nml
->len
= (int) len
;
3127 nml
->string_length
= (index_type
) string_length
;
3129 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3130 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3131 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3133 if (nml
->var_rank
> 0)
3135 nml
->dim
= (descriptor_dimension
*)
3136 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3137 nml
->ls
= (array_loop_spec
*)
3138 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3148 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3150 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3151 dtp
->u
.p
.ionml
= nml
;
3155 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3160 /* Store the dimensional information for the namelist object. */
3161 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3162 index_type
, index_type
,
3164 export_proto(st_set_nml_var_dim
);
3167 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3168 index_type stride
, index_type lbound
,
3171 namelist_info
* nml
;
3176 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3178 nml
->dim
[n
].stride
= stride
;
3179 nml
->dim
[n
].lbound
= lbound
;
3180 nml
->dim
[n
].ubound
= ubound
;
3183 /* Reverse memcpy - used for byte swapping. */
3185 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3191 s
= (char *) src
+ n
- 1;
3193 /* Write with ascending order - this is likely faster
3194 on modern architectures because of write combining. */