1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
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 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
29 /* transfer.c -- Top level handling of data transfer statements. */
38 /* Calling conventions: Data transfer statements are unlike other
39 library calls in that they extend over several calls.
41 The first call is always a call to st_read() or st_write(). These
42 subroutines return no status unless a namelist read or write is
43 being done, in which case there is the usual status. No further
44 calls are necessary in this case.
46 For other sorts of data transfer, there are zero or more data
47 transfer statement that depend on the format of the data transfer
53 transfer_character_wide
57 These subroutines do not return status.
59 The last call is a call to st_[read|write]_done(). While
60 something can easily go wrong with the initial st_read() or
61 st_write(), an error inhibits any data from actually being
64 extern void transfer_integer (st_parameter_dt
*, void *, int);
65 export_proto(transfer_integer
);
67 extern void transfer_real (st_parameter_dt
*, void *, int);
68 export_proto(transfer_real
);
70 extern void transfer_logical (st_parameter_dt
*, void *, int);
71 export_proto(transfer_logical
);
73 extern void transfer_character (st_parameter_dt
*, void *, int);
74 export_proto(transfer_character
);
76 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
77 export_proto(transfer_character_wide
);
79 extern void transfer_complex (st_parameter_dt
*, void *, int);
80 export_proto(transfer_complex
);
82 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
84 export_proto(transfer_array
);
86 static void us_read (st_parameter_dt
*, int);
87 static void us_write (st_parameter_dt
*, int);
88 static void next_record_r_unf (st_parameter_dt
*, int);
89 static void next_record_w_unf (st_parameter_dt
*, int);
91 static const st_option advance_opt
[] = {
98 static const st_option decimal_opt
[] = {
99 {"point", DECIMAL_POINT
},
100 {"comma", DECIMAL_COMMA
},
104 static const st_option round_opt
[] = {
106 {"down", ROUND_DOWN
},
107 {"zero", ROUND_ZERO
},
108 {"nearest", ROUND_NEAREST
},
109 {"compatible", ROUND_COMPATIBLE
},
110 {"processor_defined", ROUND_PROCDEFINED
},
115 static const st_option sign_opt
[] = {
117 {"suppress", SIGN_SS
},
118 {"processor_defined", SIGN_S
},
122 static const st_option blank_opt
[] = {
123 {"null", BLANK_NULL
},
124 {"zero", BLANK_ZERO
},
128 static const st_option delim_opt
[] = {
129 {"apostrophe", DELIM_APOSTROPHE
},
130 {"quote", DELIM_QUOTE
},
131 {"none", DELIM_NONE
},
135 static const st_option pad_opt
[] = {
142 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
143 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
149 current_mode (st_parameter_dt
*dtp
)
153 m
= FORM_UNSPECIFIED
;
155 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
157 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
158 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
160 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
162 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
163 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
165 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
167 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
168 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
175 /* Mid level data transfer statements. These subroutines do reading
176 and writing in the style of salloc_r()/salloc_w() within the
179 /* When reading sequential formatted records we have a problem. We
180 don't know how long the line is until we read the trailing newline,
181 and we don't want to read too much. If we read too much, we might
182 have to do a physical seek backwards depending on how much data is
183 present, and devices like terminals aren't seekable and would cause
186 Given this, the solution is to read a byte at a time, stopping if
187 we hit the newline. For small allocations, we use a static buffer.
188 For larger allocations, we are forced to allocate memory on the
189 heap. Hopefully this won't happen very often. */
192 read_sf (st_parameter_dt
*dtp
, int * length
, int no_error
)
194 static char *empty_string
[0];
196 int n
, lorig
, memread
, seen_comma
;
198 /* If we hit EOF previously with the no_error flag set (i.e. X, T,
199 TR edit descriptors), and we now try to read again, this time
200 without setting no_error. */
201 if (!no_error
&& dtp
->u
.p
.at_eof
)
208 /* If we have seen an eor previously, return a length of 0. The
209 caller is responsible for correctly padding the input field. */
210 if (dtp
->u
.p
.sf_seen_eor
)
213 /* Just return something that isn't a NULL pointer, otherwise the
214 caller thinks an error occured. */
215 return (char*) empty_string
;
218 if (is_internal_unit (dtp
))
221 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
222 if (unlikely (memread
> *length
))
233 /* Read data into format buffer and scan through it. */
235 base
= p
= fbuf_read (dtp
->u
.p
.current_unit
, length
);
243 if (q
== '\n' || q
== '\r')
245 /* Unexpected end of line. Set the position. */
246 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ 1 ,SEEK_CUR
);
247 dtp
->u
.p
.sf_seen_eor
= 1;
249 /* If we see an EOR during non-advancing I/O, we need to skip
250 the rest of the I/O statement. Set the corresponding flag. */
251 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
252 dtp
->u
.p
.eor_condition
= 1;
254 /* If we encounter a CR, it might be a CRLF. */
255 if (q
== '\r') /* Probably a CRLF */
257 /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
258 the position is not advanced unless it really is an LF. */
260 p
= fbuf_read (dtp
->u
.p
.current_unit
, &readlen
);
261 if (*p
== '\n' && readlen
== 1)
263 dtp
->u
.p
.sf_seen_eor
= 2;
264 fbuf_seek (dtp
->u
.p
.current_unit
, 1 ,SEEK_CUR
);
268 /* Without padding, terminate the I/O statement without assigning
269 the value. With padding, the value still needs to be assigned,
270 so we can just continue with a short read. */
271 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
273 if (likely (no_error
))
275 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
282 /* Short circuit the read if a comma is found during numeric input.
283 The flag is set to zero during character reads so that commas in
284 strings are not ignored */
286 if (dtp
->u
.p
.sf_read_comma
== 1)
289 notify_std (&dtp
->common
, GFC_STD_GNU
,
290 "Comma in formatted numeric read.");
298 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ seen_comma
, SEEK_CUR
);
300 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
301 some other stuff. Set the relevant flags. */
302 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
304 if (n
> 0 || no_error
)
315 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
317 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
318 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
324 /* Function for reading the next couple of bytes from the current
325 file, advancing the current position. We return FAILURE on end of record or
326 end of file. This function is only for formatted I/O, unformatted uses
329 If the read is short, then it is because the current record does not
330 have enough data to satisfy the read request and the file was
331 opened with PAD=YES. The caller must assume tailing spaces for
335 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
340 if (!is_stream_io (dtp
))
342 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
344 /* For preconnected units with default record length, set bytes left
345 to unit record length and proceed, otherwise error. */
346 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
347 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
348 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
351 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
353 /* Not enough data left. */
354 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
359 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
365 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
369 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
370 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
371 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
373 source
= read_sf (dtp
, nbytes
, 0);
374 dtp
->u
.p
.current_unit
->strm_pos
+=
375 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
379 /* If we reach here, we can assume it's direct access. */
381 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
384 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
385 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
387 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
388 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
390 if (norig
!= *nbytes
)
392 /* Short read, this shouldn't happen. */
393 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
395 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
400 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
406 /* Reads a block directly into application data space. This is for
407 unformatted files. */
410 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
412 ssize_t to_read_record
;
413 ssize_t have_read_record
;
414 ssize_t to_read_subrecord
;
415 ssize_t have_read_subrecord
;
418 if (is_stream_io (dtp
))
420 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
422 if (unlikely (have_read_record
< 0))
424 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
428 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
430 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
432 /* Short read, e.g. if we hit EOF. For stream files,
433 we have to set the end-of-file condition. */
439 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
441 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
444 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
445 nbytes
= to_read_record
;
450 to_read_record
= nbytes
;
453 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
455 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
456 if (unlikely (to_read_record
< 0))
458 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
462 if (to_read_record
!= (ssize_t
) nbytes
)
464 /* Short read, e.g. if we hit EOF. Apparently, we read
465 more than was written to the last record. */
469 if (unlikely (short_record
))
471 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
476 /* Unformatted sequential. We loop over the subrecords, reading
477 until the request has been fulfilled or the record has run out
478 of continuation subrecords. */
480 /* Check whether we exceed the total record length. */
482 if (dtp
->u
.p
.current_unit
->flags
.has_recl
483 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
485 to_read_record
= 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
= 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
= sread (dtp
->u
.p
.current_unit
->s
,
512 buf
+ have_read_record
, to_read_subrecord
);
513 if (unlikely (have_read_subrecord
) < 0)
515 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
519 have_read_record
+= have_read_subrecord
;
521 if (unlikely (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 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
532 if (to_read_record
> 0)
534 if (likely (dtp
->u
.p
.current_unit
->continued
))
536 next_record_r_unf (dtp
, 0);
541 /* Let's make sure the file position is correctly pre-positioned
542 for the next read statement. */
544 dtp
->u
.p
.current_unit
->current_record
= 0;
545 next_record_r_unf (dtp
, 0);
546 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
552 /* Normal exit, the read request has been fulfilled. */
557 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
558 if (unlikely (short_record
))
560 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
567 /* Function for writing a block of bytes to the current file at the
568 current position, advancing the file pointer. We are given a length
569 and return a pointer to a buffer that the caller must (completely)
570 fill in. Returns NULL on error. */
573 write_block (st_parameter_dt
*dtp
, int length
)
577 if (!is_stream_io (dtp
))
579 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
581 /* For preconnected units with default record length, set bytes left
582 to unit record length and proceed, otherwise error. */
583 if (likely ((dtp
->u
.p
.current_unit
->unit_number
584 == options
.stdout_unit
585 || dtp
->u
.p
.current_unit
->unit_number
586 == options
.stderr_unit
)
587 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
588 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
591 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
596 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
599 if (is_internal_unit (dtp
))
601 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
605 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
609 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
610 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
614 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
617 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
622 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
623 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
625 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
631 /* High level interface to swrite(), taking care of errors. This is only
632 called for unformatted files. There are three cases to consider:
633 Stream I/O, unformatted direct, unformatted sequential. */
636 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
639 ssize_t have_written
;
640 ssize_t to_write_subrecord
;
645 if (is_stream_io (dtp
))
647 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
648 if (unlikely (have_written
< 0))
650 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
654 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
659 /* Unformatted direct access. */
661 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
663 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
665 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
669 if (buf
== NULL
&& nbytes
== 0)
672 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
673 if (unlikely (have_written
< 0))
675 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
679 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
680 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
685 /* Unformatted sequential. */
689 if (dtp
->u
.p
.current_unit
->flags
.has_recl
690 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
692 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
704 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
705 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
707 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
708 (gfc_offset
) to_write_subrecord
;
710 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
711 buf
+ have_written
, to_write_subrecord
);
712 if (unlikely (to_write_subrecord
< 0))
714 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
718 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
719 nbytes
-= to_write_subrecord
;
720 have_written
+= to_write_subrecord
;
725 next_record_w_unf (dtp
, 1);
728 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
729 if (unlikely (short_record
))
731 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
738 /* Master function for unformatted reads. */
741 unformatted_read (st_parameter_dt
*dtp
, bt type
,
742 void *dest
, int kind
, size_t size
, size_t nelems
)
744 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
747 if (type
== BT_CHARACTER
)
748 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
749 read_block_direct (dtp
, dest
, size
* nelems
);
759 /* Handle wide chracters. */
760 if (type
== BT_CHARACTER
&& kind
!= 1)
766 /* Break up complex into its constituent reals. */
767 if (type
== BT_COMPLEX
)
773 /* By now, all complex variables have been split into their
774 constituent reals. */
776 for (i
= 0; i
< nelems
; i
++)
778 read_block_direct (dtp
, buffer
, size
);
779 reverse_memcpy (p
, buffer
, size
);
786 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
787 bytes on 64 bit machines. The unused bytes are not initialized and never
788 used, which can show an error with memory checking analyzers like
792 unformatted_write (st_parameter_dt
*dtp
, bt type
,
793 void *source
, int kind
, size_t size
, size_t nelems
)
795 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
798 size_t stride
= type
== BT_CHARACTER
?
799 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
801 write_buf (dtp
, source
, stride
* nelems
);
811 /* Handle wide chracters. */
812 if (type
== BT_CHARACTER
&& kind
!= 1)
818 /* Break up complex into its constituent reals. */
819 if (type
== BT_COMPLEX
)
825 /* By now, all complex variables have been split into their
826 constituent reals. */
828 for (i
= 0; i
< nelems
; i
++)
830 reverse_memcpy(buffer
, p
, size
);
832 write_buf (dtp
, buffer
, size
);
838 /* Return a pointer to the name of a type. */
863 internal_error (NULL
, "type_name(): Bad type");
870 /* Write a constant string to the output.
871 This is complicated because the string can have doubled delimiters
872 in it. The length in the format node is the true length. */
875 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
877 char c
, delimiter
, *p
, *q
;
880 length
= f
->u
.string
.length
;
884 p
= write_block (dtp
, length
);
891 for (; length
> 0; length
--)
894 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
895 q
++; /* Skip the doubled delimiter. */
900 /* Given actual and expected types in a formatted data transfer, make
901 sure they agree. If not, an error message is generated. Returns
902 nonzero if something went wrong. */
905 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
909 if (actual
== expected
)
912 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
913 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
915 format_error (dtp
, f
, buffer
);
920 /* This function is in the main loop for a formatted data transfer
921 statement. It would be natural to implement this as a coroutine
922 with the user program, but C makes that awkward. We loop,
923 processing format elements. When we actually have to transfer
924 data instead of just setting flags, we return control to the user
925 program which calls a function that supplies the address and type
926 of the next element, then comes back here to process it. */
929 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
936 int consume_data_flag
;
938 /* Change a complex data item into a pair of reals. */
940 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
941 if (type
== BT_COMPLEX
)
947 /* If there's an EOR condition, we simulate finalizing the transfer
949 if (dtp
->u
.p
.eor_condition
)
952 /* Set this flag so that commas in reads cause the read to complete before
953 the entire field has been read. The next read field will start right after
954 the comma in the stream. (Set to 0 for character reads). */
955 dtp
->u
.p
.sf_read_comma
=
956 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
960 /* If reversion has occurred and there is another real data item,
961 then we have to move to the next record. */
962 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
964 dtp
->u
.p
.reversion_flag
= 0;
965 next_record (dtp
, 0);
968 consume_data_flag
= 1;
969 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
972 f
= next_format (dtp
);
975 /* No data descriptors left. */
976 if (unlikely (n
> 0))
977 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
978 "Insufficient data descriptors in format after reversion");
984 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
985 - dtp
->u
.p
.current_unit
->bytes_left
);
987 if (is_stream_io(dtp
))
995 if (require_type (dtp
, BT_INTEGER
, type
, f
))
997 read_decimal (dtp
, f
, p
, kind
);
1002 goto need_read_data
;
1003 if (compile_options
.allow_std
< GFC_STD_GNU
1004 && require_type (dtp
, BT_INTEGER
, type
, f
))
1006 read_radix (dtp
, f
, p
, kind
, 2);
1011 goto need_read_data
;
1012 if (compile_options
.allow_std
< GFC_STD_GNU
1013 && require_type (dtp
, BT_INTEGER
, type
, f
))
1015 read_radix (dtp
, f
, p
, kind
, 8);
1020 goto need_read_data
;
1021 if (compile_options
.allow_std
< GFC_STD_GNU
1022 && require_type (dtp
, BT_INTEGER
, type
, f
))
1024 read_radix (dtp
, f
, p
, kind
, 16);
1029 goto need_read_data
;
1031 /* It is possible to have FMT_A with something not BT_CHARACTER such
1032 as when writing out hollerith strings, so check both type
1033 and kind before calling wide character routines. */
1034 if (type
== BT_CHARACTER
&& kind
== 4)
1035 read_a_char4 (dtp
, f
, p
, size
);
1037 read_a (dtp
, f
, p
, size
);
1042 goto need_read_data
;
1043 read_l (dtp
, f
, p
, kind
);
1048 goto need_read_data
;
1049 if (require_type (dtp
, BT_REAL
, type
, f
))
1051 read_f (dtp
, f
, p
, kind
);
1056 goto need_read_data
;
1057 if (require_type (dtp
, BT_REAL
, type
, f
))
1059 read_f (dtp
, f
, p
, kind
);
1064 goto need_read_data
;
1065 if (require_type (dtp
, BT_REAL
, type
, f
))
1067 read_f (dtp
, f
, p
, kind
);
1072 goto need_read_data
;
1073 if (require_type (dtp
, BT_REAL
, type
, f
))
1075 read_f (dtp
, f
, p
, kind
);
1080 goto need_read_data
;
1081 if (require_type (dtp
, BT_REAL
, type
, f
))
1083 read_f (dtp
, f
, p
, kind
);
1088 goto need_read_data
;
1092 read_decimal (dtp
, f
, p
, kind
);
1095 read_l (dtp
, f
, p
, kind
);
1099 read_a_char4 (dtp
, f
, p
, size
);
1101 read_a (dtp
, f
, p
, size
);
1104 read_f (dtp
, f
, p
, kind
);
1107 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1112 consume_data_flag
= 0;
1113 format_error (dtp
, f
, "Constant string in input format");
1116 /* Format codes that don't transfer data. */
1119 consume_data_flag
= 0;
1120 dtp
->u
.p
.skips
+= f
->u
.n
;
1121 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1122 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1123 read_x (dtp
, f
->u
.n
);
1128 consume_data_flag
= 0;
1130 if (f
->format
== FMT_TL
)
1132 /* Handle the special case when no bytes have been used yet.
1133 Cannot go below zero. */
1134 if (bytes_used
== 0)
1136 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1137 dtp
->u
.p
.skips
-= f
->u
.n
;
1138 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1141 pos
= bytes_used
- f
->u
.n
;
1146 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1147 left tab limit. We do not check if the position has gone
1148 beyond the end of record because a subsequent tab could
1149 bring us back again. */
1150 pos
= pos
< 0 ? 0 : pos
;
1152 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1153 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1154 + pos
- dtp
->u
.p
.max_pos
;
1155 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1156 ? 0 : dtp
->u
.p
.pending_spaces
;
1157 if (dtp
->u
.p
.skips
== 0)
1160 /* Adjust everything for end-of-record condition */
1161 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1163 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1164 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1166 dtp
->u
.p
.sf_seen_eor
= 0;
1168 if (dtp
->u
.p
.skips
< 0)
1170 if (is_internal_unit (dtp
))
1171 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1173 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1174 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1175 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1178 read_x (dtp
, dtp
->u
.p
.skips
);
1182 consume_data_flag
= 0;
1183 dtp
->u
.p
.sign_status
= SIGN_S
;
1187 consume_data_flag
= 0;
1188 dtp
->u
.p
.sign_status
= SIGN_SS
;
1192 consume_data_flag
= 0;
1193 dtp
->u
.p
.sign_status
= SIGN_SP
;
1197 consume_data_flag
= 0 ;
1198 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1202 consume_data_flag
= 0;
1203 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1207 consume_data_flag
= 0;
1208 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1212 consume_data_flag
= 0;
1213 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1217 consume_data_flag
= 0;
1218 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1222 consume_data_flag
= 0;
1223 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1227 consume_data_flag
= 0;
1228 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1232 consume_data_flag
= 0;
1233 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1237 consume_data_flag
= 0;
1238 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1242 consume_data_flag
= 0;
1243 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1247 consume_data_flag
= 0;
1248 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1252 consume_data_flag
= 0;
1253 dtp
->u
.p
.seen_dollar
= 1;
1257 consume_data_flag
= 0;
1258 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1259 next_record (dtp
, 0);
1263 /* A colon descriptor causes us to exit this loop (in
1264 particular preventing another / descriptor from being
1265 processed) unless there is another data item to be
1267 consume_data_flag
= 0;
1273 internal_error (&dtp
->common
, "Bad format node");
1276 /* Adjust the item count and data pointer. */
1278 if ((consume_data_flag
> 0) && (n
> 0))
1281 p
= ((char *) p
) + size
;
1286 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1287 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1292 /* Come here when we need a data descriptor but don't have one. We
1293 push the current format node back onto the input, then return and
1294 let the user program call us back with the data. */
1296 unget_format (dtp
, f
);
1301 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1304 int pos
, bytes_used
;
1308 int consume_data_flag
;
1310 /* Change a complex data item into a pair of reals. */
1312 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1313 if (type
== BT_COMPLEX
)
1319 /* If there's an EOR condition, we simulate finalizing the transfer
1320 by doing nothing. */
1321 if (dtp
->u
.p
.eor_condition
)
1324 /* Set this flag so that commas in reads cause the read to complete before
1325 the entire field has been read. The next read field will start right after
1326 the comma in the stream. (Set to 0 for character reads). */
1327 dtp
->u
.p
.sf_read_comma
=
1328 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1332 /* If reversion has occurred and there is another real data item,
1333 then we have to move to the next record. */
1334 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1336 dtp
->u
.p
.reversion_flag
= 0;
1337 next_record (dtp
, 0);
1340 consume_data_flag
= 1;
1341 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1344 f
= next_format (dtp
);
1347 /* No data descriptors left. */
1348 if (unlikely (n
> 0))
1349 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1350 "Insufficient data descriptors in format after reversion");
1354 /* Now discharge T, TR and X movements to the right. This is delayed
1355 until a data producing format to suppress trailing spaces. */
1358 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1359 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1360 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1361 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1362 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1363 || t
== FMT_STRING
))
1365 if (dtp
->u
.p
.skips
> 0)
1368 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1369 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1370 - dtp
->u
.p
.current_unit
->bytes_left
);
1372 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1374 if (dtp
->u
.p
.skips
< 0)
1376 if (is_internal_unit (dtp
))
1377 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1379 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1380 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1382 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1385 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1386 - dtp
->u
.p
.current_unit
->bytes_left
);
1388 if (is_stream_io(dtp
))
1396 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1398 write_i (dtp
, f
, p
, kind
);
1404 if (compile_options
.allow_std
< GFC_STD_GNU
1405 && require_type (dtp
, BT_INTEGER
, type
, f
))
1407 write_b (dtp
, f
, p
, kind
);
1413 if (compile_options
.allow_std
< GFC_STD_GNU
1414 && require_type (dtp
, BT_INTEGER
, type
, f
))
1416 write_o (dtp
, f
, p
, kind
);
1422 if (compile_options
.allow_std
< GFC_STD_GNU
1423 && require_type (dtp
, BT_INTEGER
, type
, f
))
1425 write_z (dtp
, f
, p
, kind
);
1432 /* It is possible to have FMT_A with something not BT_CHARACTER such
1433 as when writing out hollerith strings, so check both type
1434 and kind before calling wide character routines. */
1435 if (type
== BT_CHARACTER
&& kind
== 4)
1436 write_a_char4 (dtp
, f
, p
, size
);
1438 write_a (dtp
, f
, p
, size
);
1444 write_l (dtp
, f
, p
, kind
);
1450 if (require_type (dtp
, BT_REAL
, type
, f
))
1452 write_d (dtp
, f
, p
, kind
);
1458 if (require_type (dtp
, BT_REAL
, type
, f
))
1460 write_e (dtp
, f
, p
, kind
);
1466 if (require_type (dtp
, BT_REAL
, type
, f
))
1468 write_en (dtp
, f
, p
, kind
);
1474 if (require_type (dtp
, BT_REAL
, type
, f
))
1476 write_es (dtp
, f
, p
, kind
);
1482 if (require_type (dtp
, BT_REAL
, type
, f
))
1484 write_f (dtp
, f
, p
, kind
);
1493 write_i (dtp
, f
, p
, kind
);
1496 write_l (dtp
, f
, p
, kind
);
1500 write_a_char4 (dtp
, f
, p
, size
);
1502 write_a (dtp
, f
, p
, size
);
1505 if (f
->u
.real
.w
== 0)
1506 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1508 write_d (dtp
, f
, p
, kind
);
1511 internal_error (&dtp
->common
,
1512 "formatted_transfer(): Bad type");
1517 consume_data_flag
= 0;
1518 write_constant_string (dtp
, f
);
1521 /* Format codes that don't transfer data. */
1524 consume_data_flag
= 0;
1526 dtp
->u
.p
.skips
+= f
->u
.n
;
1527 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1528 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1529 /* Writes occur just before the switch on f->format, above, so
1530 that trailing blanks are suppressed, unless we are doing a
1531 non-advancing write in which case we want to output the blanks
1533 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1535 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1536 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1542 consume_data_flag
= 0;
1544 if (f
->format
== FMT_TL
)
1547 /* Handle the special case when no bytes have been used yet.
1548 Cannot go below zero. */
1549 if (bytes_used
== 0)
1551 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1552 dtp
->u
.p
.skips
-= f
->u
.n
;
1553 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1556 pos
= bytes_used
- f
->u
.n
;
1559 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1561 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1562 left tab limit. We do not check if the position has gone
1563 beyond the end of record because a subsequent tab could
1564 bring us back again. */
1565 pos
= pos
< 0 ? 0 : pos
;
1567 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1568 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1569 + pos
- dtp
->u
.p
.max_pos
;
1570 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1571 ? 0 : dtp
->u
.p
.pending_spaces
;
1575 consume_data_flag
= 0;
1576 dtp
->u
.p
.sign_status
= SIGN_S
;
1580 consume_data_flag
= 0;
1581 dtp
->u
.p
.sign_status
= SIGN_SS
;
1585 consume_data_flag
= 0;
1586 dtp
->u
.p
.sign_status
= SIGN_SP
;
1590 consume_data_flag
= 0 ;
1591 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1595 consume_data_flag
= 0;
1596 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1600 consume_data_flag
= 0;
1601 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1605 consume_data_flag
= 0;
1606 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1610 consume_data_flag
= 0;
1611 dtp
->u
.p
.current_unit
->round_status
= ROUND_COMPATIBLE
;
1615 consume_data_flag
= 0;
1616 dtp
->u
.p
.current_unit
->round_status
= ROUND_DOWN
;
1620 consume_data_flag
= 0;
1621 dtp
->u
.p
.current_unit
->round_status
= ROUND_NEAREST
;
1625 consume_data_flag
= 0;
1626 dtp
->u
.p
.current_unit
->round_status
= ROUND_PROCDEFINED
;
1630 consume_data_flag
= 0;
1631 dtp
->u
.p
.current_unit
->round_status
= ROUND_UP
;
1635 consume_data_flag
= 0;
1636 dtp
->u
.p
.current_unit
->round_status
= ROUND_ZERO
;
1640 consume_data_flag
= 0;
1641 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1645 consume_data_flag
= 0;
1646 dtp
->u
.p
.seen_dollar
= 1;
1650 consume_data_flag
= 0;
1651 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1652 next_record (dtp
, 0);
1656 /* A colon descriptor causes us to exit this loop (in
1657 particular preventing another / descriptor from being
1658 processed) unless there is another data item to be
1660 consume_data_flag
= 0;
1666 internal_error (&dtp
->common
, "Bad format node");
1669 /* Adjust the item count and data pointer. */
1671 if ((consume_data_flag
> 0) && (n
> 0))
1674 p
= ((char *) p
) + size
;
1677 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1678 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1683 /* Come here when we need a data descriptor but don't have one. We
1684 push the current format node back onto the input, then return and
1685 let the user program call us back with the data. */
1687 unget_format (dtp
, f
);
1692 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1693 size_t size
, size_t nelems
)
1699 size_t stride
= type
== BT_CHARACTER
?
1700 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1701 if (dtp
->u
.p
.mode
== READING
)
1703 /* Big loop over all the elements. */
1704 for (elem
= 0; elem
< nelems
; elem
++)
1706 dtp
->u
.p
.item_count
++;
1707 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1712 /* Big loop over all the elements. */
1713 for (elem
= 0; elem
< nelems
; elem
++)
1715 dtp
->u
.p
.item_count
++;
1716 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1722 /* Data transfer entry points. The type of the data entity is
1723 implicit in the subroutine call. This prevents us from having to
1724 share a common enum with the compiler. */
1727 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1729 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1731 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1736 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1739 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1741 size
= size_from_real_kind (kind
);
1742 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1747 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1749 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1751 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1756 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1758 static char *empty_string
[0];
1760 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1763 /* Strings of zero length can have p == NULL, which confuses the
1764 transfer routines into thinking we need more data elements. To avoid
1765 this, we give them a nice pointer. */
1766 if (len
== 0 && p
== NULL
)
1769 /* Set kind here to 1. */
1770 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1774 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1776 static char *empty_string
[0];
1778 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1781 /* Strings of zero length can have p == NULL, which confuses the
1782 transfer routines into thinking we need more data elements. To avoid
1783 this, we give them a nice pointer. */
1784 if (len
== 0 && p
== NULL
)
1787 /* Here we pass the actual kind value. */
1788 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1793 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1796 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1798 size
= size_from_complex_kind (kind
);
1799 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1804 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1805 gfc_charlen_type charlen
)
1807 index_type count
[GFC_MAX_DIMENSIONS
];
1808 index_type extent
[GFC_MAX_DIMENSIONS
];
1809 index_type stride
[GFC_MAX_DIMENSIONS
];
1810 index_type stride0
, rank
, size
, type
, n
;
1815 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1818 type
= GFC_DESCRIPTOR_TYPE (desc
);
1819 size
= GFC_DESCRIPTOR_SIZE (desc
);
1821 /* FIXME: What a kludge: Array descriptors and the IO library use
1822 different enums for types. */
1825 case GFC_DTYPE_UNKNOWN
:
1826 iotype
= BT_NULL
; /* Is this correct? */
1828 case GFC_DTYPE_INTEGER
:
1829 iotype
= BT_INTEGER
;
1831 case GFC_DTYPE_LOGICAL
:
1832 iotype
= BT_LOGICAL
;
1834 case GFC_DTYPE_REAL
:
1837 case GFC_DTYPE_COMPLEX
:
1838 iotype
= BT_COMPLEX
;
1840 case GFC_DTYPE_CHARACTER
:
1841 iotype
= BT_CHARACTER
;
1844 case GFC_DTYPE_DERIVED
:
1845 internal_error (&dtp
->common
,
1846 "Derived type I/O should have been handled via the frontend.");
1849 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1852 rank
= GFC_DESCRIPTOR_RANK (desc
);
1853 for (n
= 0; n
< rank
; n
++)
1856 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
1857 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
1859 /* If the extent of even one dimension is zero, then the entire
1860 array section contains zero elements, so we return after writing
1861 a zero array record. */
1866 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1871 stride0
= stride
[0];
1873 /* If the innermost dimension has a stride of 1, we can do the transfer
1874 in contiguous chunks. */
1875 if (stride0
== size
)
1880 data
= GFC_DESCRIPTOR_DATA (desc
);
1884 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1885 data
+= stride0
* tsize
;
1888 while (count
[n
] == extent
[n
])
1891 data
-= stride
[n
] * extent
[n
];
1908 /* Preposition a sequential unformatted file while reading. */
1911 us_read (st_parameter_dt
*dtp
, int continued
)
1918 if (compile_options
.record_marker
== 0)
1919 n
= sizeof (GFC_INTEGER_4
);
1921 n
= compile_options
.record_marker
;
1923 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1924 if (unlikely (nr
< 0))
1926 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1932 return; /* end of file */
1934 else if (unlikely (n
!= nr
))
1936 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1940 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1941 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1945 case sizeof(GFC_INTEGER_4
):
1946 memcpy (&i4
, &i
, sizeof (i4
));
1950 case sizeof(GFC_INTEGER_8
):
1951 memcpy (&i8
, &i
, sizeof (i8
));
1956 runtime_error ("Illegal value for record marker");
1963 case sizeof(GFC_INTEGER_4
):
1964 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1968 case sizeof(GFC_INTEGER_8
):
1969 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1974 runtime_error ("Illegal value for record marker");
1980 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1981 dtp
->u
.p
.current_unit
->continued
= 0;
1985 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1986 dtp
->u
.p
.current_unit
->continued
= 1;
1990 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1994 /* Preposition a sequential unformatted file while writing. This
1995 amount to writing a bogus length that will be filled in later. */
1998 us_write (st_parameter_dt
*dtp
, int continued
)
2005 if (compile_options
.record_marker
== 0)
2006 nbytes
= sizeof (GFC_INTEGER_4
);
2008 nbytes
= compile_options
.record_marker
;
2010 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
2011 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2013 /* For sequential unformatted, if RECL= was not specified in the OPEN
2014 we write until we have more bytes than can fit in the subrecord
2015 markers, then we write a new subrecord. */
2017 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
2018 dtp
->u
.p
.current_unit
->recl_subrecord
;
2019 dtp
->u
.p
.current_unit
->continued
= continued
;
2023 /* Position to the next record prior to transfer. We are assumed to
2024 be before the next record. We also calculate the bytes in the next
2028 pre_position (st_parameter_dt
*dtp
)
2030 if (dtp
->u
.p
.current_unit
->current_record
)
2031 return; /* Already positioned. */
2033 switch (current_mode (dtp
))
2035 case FORMATTED_STREAM
:
2036 case UNFORMATTED_STREAM
:
2037 /* There are no records with stream I/O. If the position was specified
2038 data_transfer_init has already positioned the file. If no position
2039 was specified, we continue from where we last left off. I.e.
2040 there is nothing to do here. */
2043 case UNFORMATTED_SEQUENTIAL
:
2044 if (dtp
->u
.p
.mode
== READING
)
2051 case FORMATTED_SEQUENTIAL
:
2052 case FORMATTED_DIRECT
:
2053 case UNFORMATTED_DIRECT
:
2054 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2058 dtp
->u
.p
.current_unit
->current_record
= 1;
2062 /* Initialize things for a data transfer. This code is common for
2063 both reading and writing. */
2066 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
2068 unit_flags u_flags
; /* Used for creating a unit if needed. */
2069 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2070 namelist_info
*ionml
;
2072 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2074 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2076 dtp
->u
.p
.ionml
= ionml
;
2077 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2079 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2082 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2083 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2085 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2086 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2087 { /* Open the unit with some default flags. */
2088 st_parameter_open opp
;
2091 if (dtp
->common
.unit
< 0)
2093 close_unit (dtp
->u
.p
.current_unit
);
2094 dtp
->u
.p
.current_unit
= NULL
;
2095 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2096 "Bad unit number in statement");
2099 memset (&u_flags
, '\0', sizeof (u_flags
));
2100 u_flags
.access
= ACCESS_SEQUENTIAL
;
2101 u_flags
.action
= ACTION_READWRITE
;
2103 /* Is it unformatted? */
2104 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2105 | IOPARM_DT_IONML_SET
)))
2106 u_flags
.form
= FORM_UNFORMATTED
;
2108 u_flags
.form
= FORM_UNSPECIFIED
;
2110 u_flags
.delim
= DELIM_UNSPECIFIED
;
2111 u_flags
.blank
= BLANK_UNSPECIFIED
;
2112 u_flags
.pad
= PAD_UNSPECIFIED
;
2113 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2114 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2115 u_flags
.async
= ASYNC_UNSPECIFIED
;
2116 u_flags
.round
= ROUND_UNSPECIFIED
;
2117 u_flags
.sign
= SIGN_UNSPECIFIED
;
2119 u_flags
.status
= STATUS_UNKNOWN
;
2121 conv
= get_unformatted_convert (dtp
->common
.unit
);
2123 if (conv
== GFC_CONVERT_NONE
)
2124 conv
= compile_options
.convert
;
2126 /* We use big_endian, which is 0 on little-endian machines
2127 and 1 on big-endian machines. */
2130 case GFC_CONVERT_NATIVE
:
2131 case GFC_CONVERT_SWAP
:
2134 case GFC_CONVERT_BIG
:
2135 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2138 case GFC_CONVERT_LITTLE
:
2139 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2143 internal_error (&opp
.common
, "Illegal value for CONVERT");
2147 u_flags
.convert
= conv
;
2149 opp
.common
= dtp
->common
;
2150 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2151 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2152 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2153 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2154 if (dtp
->u
.p
.current_unit
== NULL
)
2158 /* Check the action. */
2160 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2162 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2163 "Cannot read from file opened for WRITE");
2167 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2169 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2170 "Cannot write to file opened for READ");
2174 dtp
->u
.p
.first_item
= 1;
2176 /* Check the format. */
2178 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2181 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2182 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2185 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2186 "Format present for UNFORMATTED data transfer");
2190 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2192 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2193 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2194 "A format cannot be specified with a namelist");
2196 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2197 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2199 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2200 "Missing format for FORMATTED data transfer");
2203 if (is_internal_unit (dtp
)
2204 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2206 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2207 "Internal file cannot be accessed by UNFORMATTED "
2212 /* Check the record or position number. */
2214 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2215 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2217 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2218 "Direct access data transfer requires record number");
2222 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2223 && (cf
& IOPARM_DT_HAS_REC
) != 0)
2225 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2226 "Record number not allowed for sequential access "
2231 /* Process the ADVANCE option. */
2233 dtp
->u
.p
.advance_status
2234 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2235 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2236 "Bad ADVANCE parameter in data transfer statement");
2238 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2240 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2242 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2243 "ADVANCE specification conflicts with sequential "
2248 if (is_internal_unit (dtp
))
2250 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2251 "ADVANCE specification conflicts with internal file");
2255 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2256 != IOPARM_DT_HAS_FORMAT
)
2258 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2259 "ADVANCE specification requires an explicit format");
2266 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2268 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2270 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2271 "EOR specification requires an ADVANCE specification "
2276 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2277 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2279 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2280 "SIZE specification requires an ADVANCE "
2281 "specification of NO");
2286 { /* Write constraints. */
2287 if ((cf
& IOPARM_END
) != 0)
2289 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2290 "END specification cannot appear in a write "
2295 if ((cf
& IOPARM_EOR
) != 0)
2297 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2298 "EOR specification cannot appear in a write "
2303 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2305 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2306 "SIZE specification cannot appear in a write "
2312 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2313 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2315 /* Check the decimal mode. */
2316 dtp
->u
.p
.current_unit
->decimal_status
2317 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2318 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2319 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2322 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2323 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2325 /* Check the round mode. */
2326 dtp
->u
.p
.current_unit
->round_status
2327 = !(cf
& IOPARM_DT_HAS_ROUND
) ? ROUND_UNSPECIFIED
:
2328 find_option (&dtp
->common
, dtp
->round
, dtp
->round_len
,
2329 round_opt
, "Bad ROUND parameter in data transfer "
2332 if (dtp
->u
.p
.current_unit
->round_status
== ROUND_UNSPECIFIED
)
2333 dtp
->u
.p
.current_unit
->round_status
= dtp
->u
.p
.current_unit
->flags
.round
;
2335 /* Check the sign mode. */
2336 dtp
->u
.p
.sign_status
2337 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2338 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2339 "Bad SIGN parameter in data transfer statement");
2341 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2342 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2344 /* Check the blank mode. */
2345 dtp
->u
.p
.blank_status
2346 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2347 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2349 "Bad BLANK parameter in data transfer statement");
2351 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2352 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2354 /* Check the delim mode. */
2355 dtp
->u
.p
.current_unit
->delim_status
2356 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2357 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2358 delim_opt
, "Bad DELIM parameter in data transfer statement");
2360 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2361 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2363 /* Check the pad mode. */
2364 dtp
->u
.p
.current_unit
->pad_status
2365 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2366 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2367 "Bad PAD parameter in data transfer statement");
2369 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2370 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2372 /* Check to see if we might be reading what we wrote before */
2374 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2375 && !is_internal_unit (dtp
))
2377 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2379 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2380 sflush(dtp
->u
.p
.current_unit
->s
);
2383 /* Check the POS= specifier: that it is in range and that it is used with a
2384 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2386 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2388 if (is_stream_io (dtp
))
2393 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2394 "POS=specifier must be positive");
2398 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2400 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2401 "POS=specifier too large");
2405 dtp
->rec
= dtp
->pos
;
2407 if (dtp
->u
.p
.mode
== READING
)
2409 /* Reset the endfile flag; if we hit EOF during reading
2410 we'll set the flag and generate an error at that point
2411 rather than worrying about it here. */
2412 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2415 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2417 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2418 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2420 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2423 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2428 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2429 "POS=specifier not allowed, "
2430 "Try OPEN with ACCESS='stream'");
2436 /* Sanity checks on the record number. */
2437 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2441 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2442 "Record number must be positive");
2446 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2448 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2449 "Record number too large");
2453 /* Make sure format buffer is reset. */
2454 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2455 fbuf_reset (dtp
->u
.p
.current_unit
);
2458 /* Check whether the record exists to be read. Only
2459 a partial record needs to exist. */
2461 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2462 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2464 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2465 "Non-existing record number");
2469 /* Position the file. */
2470 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2471 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2473 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2477 /* TODO: This is required to maintain compatibility between
2478 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2480 if (is_stream_io (dtp
))
2481 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2483 /* TODO: Un-comment this code when ABI changes from 4.3.
2484 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2486 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2487 "Record number not allowed for stream access "
2493 /* Bugware for badly written mixed C-Fortran I/O. */
2494 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2496 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2498 /* Set the maximum position reached from the previous I/O operation. This
2499 could be greater than zero from a previous non-advancing write. */
2500 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2505 /* Set up the subroutine that will handle the transfers. */
2509 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2510 dtp
->u
.p
.transfer
= unformatted_read
;
2513 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2514 dtp
->u
.p
.transfer
= list_formatted_read
;
2516 dtp
->u
.p
.transfer
= formatted_transfer
;
2521 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2522 dtp
->u
.p
.transfer
= unformatted_write
;
2525 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2526 dtp
->u
.p
.transfer
= list_formatted_write
;
2528 dtp
->u
.p
.transfer
= formatted_transfer
;
2532 /* Make sure that we don't do a read after a nonadvancing write. */
2536 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2538 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2539 "Cannot READ after a nonadvancing WRITE");
2545 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2546 dtp
->u
.p
.current_unit
->read_bad
= 1;
2549 /* Start the data transfer if we are doing a formatted transfer. */
2550 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2551 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2552 && dtp
->u
.p
.ionml
== NULL
)
2553 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2556 /* Initialize an array_loop_spec given the array descriptor. The function
2557 returns the index of the last element of the array, and also returns
2558 starting record, where the first I/O goes to (necessary in case of
2559 negative strides). */
2562 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2563 gfc_offset
*start_record
)
2565 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2574 for (i
=0; i
<rank
; i
++)
2576 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2577 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2578 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2579 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2580 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2581 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2583 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2585 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2586 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2590 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2591 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2592 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2593 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2603 /* Determine the index to the next record in an internal unit array by
2604 by incrementing through the array_loop_spec. */
2607 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2615 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2620 if (ls
[i
].idx
> ls
[i
].end
)
2622 ls
[i
].idx
= ls
[i
].start
;
2628 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2638 /* Skip to the end of the current record, taking care of an optional
2639 record marker of size bytes. If the file is not seekable, we
2640 read chunks of size MAX_READ until we get to the right
2644 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2646 ssize_t rlength
, readb
;
2647 static const ssize_t MAX_READ
= 4096;
2650 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2651 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2654 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2656 /* Direct access files do not generate END conditions,
2658 if (sseek (dtp
->u
.p
.current_unit
->s
,
2659 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2660 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2663 { /* Seek by reading data. */
2664 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2667 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2668 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2670 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2673 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2677 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2684 /* Advance to the next record reading unformatted files, taking
2685 care of subrecords. If complete_record is nonzero, we loop
2686 until all subrecords are cleared. */
2689 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2693 bytes
= compile_options
.record_marker
== 0 ?
2694 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2699 /* Skip over tail */
2701 skip_record (dtp
, bytes
);
2703 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2711 static inline gfc_offset
2712 min_off (gfc_offset a
, gfc_offset b
)
2714 return (a
< b
? a
: b
);
2718 /* Space to the next record for read mode. */
2721 next_record_r (st_parameter_dt
*dtp
)
2728 switch (current_mode (dtp
))
2730 /* No records in unformatted STREAM I/O. */
2731 case UNFORMATTED_STREAM
:
2734 case UNFORMATTED_SEQUENTIAL
:
2735 next_record_r_unf (dtp
, 1);
2736 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2739 case FORMATTED_DIRECT
:
2740 case UNFORMATTED_DIRECT
:
2741 skip_record (dtp
, 0);
2744 case FORMATTED_STREAM
:
2745 case FORMATTED_SEQUENTIAL
:
2746 /* read_sf has already terminated input because of an '\n', or
2748 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2750 dtp
->u
.p
.sf_seen_eor
= 0;
2751 dtp
->u
.p
.at_eof
= 0;
2755 if (is_internal_unit (dtp
))
2757 if (is_array_io (dtp
))
2761 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2764 /* Now seek to this record. */
2765 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2766 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2768 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2771 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2775 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2776 bytes_left
= min_off (bytes_left
,
2777 file_length (dtp
->u
.p
.current_unit
->s
)
2778 - stell (dtp
->u
.p
.current_unit
->s
));
2779 if (sseek (dtp
->u
.p
.current_unit
->s
,
2780 bytes_left
, SEEK_CUR
) < 0)
2782 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2785 dtp
->u
.p
.current_unit
->bytes_left
2786 = dtp
->u
.p
.current_unit
->recl
;
2795 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2799 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2805 if (is_stream_io (dtp
))
2806 dtp
->u
.p
.current_unit
->strm_pos
++;
2817 /* Small utility function to write a record marker, taking care of
2818 byte swapping and of choosing the correct size. */
2821 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2826 char p
[sizeof (GFC_INTEGER_8
)];
2828 if (compile_options
.record_marker
== 0)
2829 len
= sizeof (GFC_INTEGER_4
);
2831 len
= compile_options
.record_marker
;
2833 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2834 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2838 case sizeof (GFC_INTEGER_4
):
2840 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2843 case sizeof (GFC_INTEGER_8
):
2845 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2849 runtime_error ("Illegal value for record marker");
2857 case sizeof (GFC_INTEGER_4
):
2859 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2860 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2863 case sizeof (GFC_INTEGER_8
):
2865 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2866 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2870 runtime_error ("Illegal value for record marker");
2877 /* Position to the next (sub)record in write mode for
2878 unformatted sequential files. */
2881 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2883 gfc_offset m
, m_write
, record_marker
;
2885 /* Bytes written. */
2886 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2887 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2889 /* Write the length tail. If we finish a record containing
2890 subrecords, we write out the negative length. */
2892 if (dtp
->u
.p
.current_unit
->continued
)
2897 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2900 if (compile_options
.record_marker
== 0)
2901 record_marker
= sizeof (GFC_INTEGER_4
);
2903 record_marker
= compile_options
.record_marker
;
2905 /* Seek to the head and overwrite the bogus length with the real
2908 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2917 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2920 /* Seek past the end of the current record. */
2922 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2929 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2935 /* Utility function like memset() but operating on streams. Return
2936 value is same as for POSIX write(). */
2939 sset (stream
* s
, int c
, ssize_t nbyte
)
2941 static const int WRITE_CHUNK
= 256;
2942 char p
[WRITE_CHUNK
];
2943 ssize_t bytes_left
, trans
;
2945 if (nbyte
< WRITE_CHUNK
)
2946 memset (p
, c
, nbyte
);
2948 memset (p
, c
, WRITE_CHUNK
);
2951 while (bytes_left
> 0)
2953 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2954 trans
= swrite (s
, p
, trans
);
2957 bytes_left
-= trans
;
2960 return nbyte
- bytes_left
;
2963 /* Position to the next record in write mode. */
2966 next_record_w (st_parameter_dt
*dtp
, int done
)
2968 gfc_offset m
, record
, max_pos
;
2971 /* Zero counters for X- and T-editing. */
2972 max_pos
= dtp
->u
.p
.max_pos
;
2973 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2975 switch (current_mode (dtp
))
2977 /* No records in unformatted STREAM I/O. */
2978 case UNFORMATTED_STREAM
:
2981 case FORMATTED_DIRECT
:
2982 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2985 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2986 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2987 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2988 dtp
->u
.p
.current_unit
->bytes_left
)
2989 != dtp
->u
.p
.current_unit
->bytes_left
)
2994 case UNFORMATTED_DIRECT
:
2995 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2997 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2998 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
3003 case UNFORMATTED_SEQUENTIAL
:
3004 next_record_w_unf (dtp
, 0);
3005 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3008 case FORMATTED_STREAM
:
3009 case FORMATTED_SEQUENTIAL
:
3011 if (is_internal_unit (dtp
))
3013 if (is_array_io (dtp
))
3017 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3019 /* If the farthest position reached is greater than current
3020 position, adjust the position and set length to pad out
3021 whats left. Otherwise just pad whats left.
3022 (for character array unit) */
3023 m
= dtp
->u
.p
.current_unit
->recl
3024 - dtp
->u
.p
.current_unit
->bytes_left
;
3027 length
= (int) (max_pos
- m
);
3028 if (sseek (dtp
->u
.p
.current_unit
->s
,
3029 length
, SEEK_CUR
) < 0)
3031 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3034 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3037 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3039 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3043 /* Now that the current record has been padded out,
3044 determine where the next record in the array is. */
3045 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
3048 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3050 /* Now seek to this record */
3051 record
= record
* dtp
->u
.p
.current_unit
->recl
;
3053 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
3055 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3059 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
3065 /* If this is the last call to next_record move to the farthest
3066 position reached and set length to pad out the remainder
3067 of the record. (for character scaler unit) */
3070 m
= dtp
->u
.p
.current_unit
->recl
3071 - dtp
->u
.p
.current_unit
->bytes_left
;
3074 length
= (int) (max_pos
- m
);
3075 if (sseek (dtp
->u
.p
.current_unit
->s
,
3076 length
, SEEK_CUR
) < 0)
3078 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3081 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3084 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3087 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3089 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3101 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3102 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3109 if (is_stream_io (dtp
))
3111 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3112 if (dtp
->u
.p
.current_unit
->strm_pos
3113 < file_length (dtp
->u
.p
.current_unit
->s
))
3114 unit_truncate (dtp
->u
.p
.current_unit
,
3115 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3123 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3128 /* Position to the next record, which means moving to the end of the
3129 current record. This can happen under several different
3130 conditions. If the done flag is not set, we get ready to process
3134 next_record (st_parameter_dt
*dtp
, int done
)
3136 gfc_offset fp
; /* File position. */
3138 dtp
->u
.p
.current_unit
->read_bad
= 0;
3140 if (dtp
->u
.p
.mode
== READING
)
3141 next_record_r (dtp
);
3143 next_record_w (dtp
, done
);
3145 if (!is_stream_io (dtp
))
3147 /* Keep position up to date for INQUIRE */
3149 update_position (dtp
->u
.p
.current_unit
);
3151 dtp
->u
.p
.current_unit
->current_record
= 0;
3152 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3154 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3155 /* Calculate next record, rounding up partial records. */
3156 dtp
->u
.p
.current_unit
->last_record
=
3157 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3158 dtp
->u
.p
.current_unit
->recl
;
3161 dtp
->u
.p
.current_unit
->last_record
++;
3167 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3171 /* Finalize the current data transfer. For a nonadvancing transfer,
3172 this means advancing to the next record. For internal units close the
3173 stream associated with the unit. */
3176 finalize_transfer (st_parameter_dt
*dtp
)
3179 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3181 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3182 *dtp
->size
= dtp
->u
.p
.size_used
;
3184 if (dtp
->u
.p
.eor_condition
)
3186 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3190 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3192 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3193 dtp
->u
.p
.current_unit
->current_record
= 0;
3197 if ((dtp
->u
.p
.ionml
!= NULL
)
3198 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3200 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3201 namelist_read (dtp
);
3203 namelist_write (dtp
);
3206 dtp
->u
.p
.transfer
= NULL
;
3207 if (dtp
->u
.p
.current_unit
== NULL
)
3210 dtp
->u
.p
.eof_jump
= &eof_jump
;
3211 if (setjmp (eof_jump
))
3213 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3217 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3219 finish_list_read (dtp
);
3223 if (dtp
->u
.p
.mode
== WRITING
)
3224 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3225 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3227 if (is_stream_io (dtp
))
3229 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3230 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3231 next_record (dtp
, 1);
3236 dtp
->u
.p
.current_unit
->current_record
= 0;
3238 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3240 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3241 dtp
->u
.p
.seen_dollar
= 0;
3245 /* For non-advancing I/O, save the current maximum position for use in the
3246 next I/O operation if needed. */
3247 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3249 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3250 - dtp
->u
.p
.current_unit
->bytes_left
);
3251 dtp
->u
.p
.current_unit
->saved_pos
=
3252 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3253 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3256 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3257 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3258 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3260 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3262 next_record (dtp
, 1);
3265 /* Transfer function for IOLENGTH. It doesn't actually do any
3266 data transfer, it just updates the length counter. */
3269 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3270 void *dest
__attribute__ ((unused
)),
3271 int kind
__attribute__((unused
)),
3272 size_t size
, size_t nelems
)
3274 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3275 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3279 /* Initialize the IOLENGTH data transfer. This function is in essence
3280 a very much simplified version of data_transfer_init(), because it
3281 doesn't have to deal with units at all. */
3284 iolength_transfer_init (st_parameter_dt
*dtp
)
3286 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3289 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3291 /* Set up the subroutine that will handle the transfers. */
3293 dtp
->u
.p
.transfer
= iolength_transfer
;
3297 /* Library entry point for the IOLENGTH form of the INQUIRE
3298 statement. The IOLENGTH form requires no I/O to be performed, but
3299 it must still be a runtime library call so that we can determine
3300 the iolength for dynamic arrays and such. */
3302 extern void st_iolength (st_parameter_dt
*);
3303 export_proto(st_iolength
);
3306 st_iolength (st_parameter_dt
*dtp
)
3308 library_start (&dtp
->common
);
3309 iolength_transfer_init (dtp
);
3312 extern void st_iolength_done (st_parameter_dt
*);
3313 export_proto(st_iolength_done
);
3316 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3323 /* The READ statement. */
3325 extern void st_read (st_parameter_dt
*);
3326 export_proto(st_read
);
3329 st_read (st_parameter_dt
*dtp
)
3331 library_start (&dtp
->common
);
3333 data_transfer_init (dtp
, 1);
3336 extern void st_read_done (st_parameter_dt
*);
3337 export_proto(st_read_done
);
3340 st_read_done (st_parameter_dt
*dtp
)
3342 finalize_transfer (dtp
);
3343 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3344 free_format_data (dtp
->u
.p
.fmt
);
3346 if (dtp
->u
.p
.current_unit
!= NULL
)
3347 unlock_unit (dtp
->u
.p
.current_unit
);
3349 free_internal_unit (dtp
);
3354 extern void st_write (st_parameter_dt
*);
3355 export_proto(st_write
);
3358 st_write (st_parameter_dt
*dtp
)
3360 library_start (&dtp
->common
);
3361 data_transfer_init (dtp
, 0);
3364 extern void st_write_done (st_parameter_dt
*);
3365 export_proto(st_write_done
);
3368 st_write_done (st_parameter_dt
*dtp
)
3370 finalize_transfer (dtp
);
3372 /* Deal with endfile conditions associated with sequential files. */
3374 if (dtp
->u
.p
.current_unit
!= NULL
3375 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3376 switch (dtp
->u
.p
.current_unit
->endfile
)
3378 case AT_ENDFILE
: /* Remain at the endfile record. */
3382 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3386 /* Get rid of whatever is after this record. */
3387 if (!is_internal_unit (dtp
))
3388 unit_truncate (dtp
->u
.p
.current_unit
,
3389 stell (dtp
->u
.p
.current_unit
->s
),
3391 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3395 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3396 free_format_data (dtp
->u
.p
.fmt
);
3398 if (dtp
->u
.p
.current_unit
!= NULL
)
3399 unlock_unit (dtp
->u
.p
.current_unit
);
3401 free_internal_unit (dtp
);
3407 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3409 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3414 /* Receives the scalar information for namelist objects and stores it
3415 in a linked list of namelist_info types. */
3417 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3418 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3419 export_proto(st_set_nml_var
);
3423 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3424 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3425 GFC_INTEGER_4 dtype
)
3427 namelist_info
*t1
= NULL
;
3429 size_t var_name_len
= strlen (var_name
);
3431 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3433 nml
->mem_pos
= var_addr
;
3435 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3436 memcpy (nml
->var_name
, var_name
, var_name_len
);
3437 nml
->var_name
[var_name_len
] = '\0';
3439 nml
->len
= (int) len
;
3440 nml
->string_length
= (index_type
) string_length
;
3442 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3443 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3444 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3446 if (nml
->var_rank
> 0)
3448 nml
->dim
= (descriptor_dimension
*)
3449 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3450 nml
->ls
= (array_loop_spec
*)
3451 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3461 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3463 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3464 dtp
->u
.p
.ionml
= nml
;
3468 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3473 /* Store the dimensional information for the namelist object. */
3474 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3475 index_type
, index_type
,
3477 export_proto(st_set_nml_var_dim
);
3480 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3481 index_type stride
, index_type lbound
,
3484 namelist_info
* nml
;
3489 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3491 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3494 /* Reverse memcpy - used for byte swapping. */
3496 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3502 s
= (char *) src
+ n
- 1;
3504 /* Write with ascending order - this is likely faster
3505 on modern architectures because of write combining. */
3511 /* Once upon a time, a poor innocent Fortran program was reading a
3512 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3513 the OS doesn't tell whether we're at the EOF or whether we already
3514 went past it. Luckily our hero, libgfortran, keeps track of this.
3515 Call this function when you detect an EOF condition. See Section
3519 hit_eof (st_parameter_dt
* dtp
)
3521 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3523 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3524 switch (dtp
->u
.p
.current_unit
->endfile
)
3528 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3529 if (!is_internal_unit (dtp
))
3531 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3532 dtp
->u
.p
.current_unit
->current_record
= 0;
3535 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3539 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3540 dtp
->u
.p
.current_unit
->current_record
= 0;
3545 /* Non-sequential files don't have an ENDFILE record, so we
3546 can't be at AFTER_ENDFILE. */
3547 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3548 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3549 dtp
->u
.p
.current_unit
->current_record
= 0;