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
},
105 static const st_option sign_opt
[] = {
107 {"suppress", SIGN_SS
},
108 {"processor_defined", SIGN_S
},
112 static const st_option blank_opt
[] = {
113 {"null", BLANK_NULL
},
114 {"zero", BLANK_ZERO
},
118 static const st_option delim_opt
[] = {
119 {"apostrophe", DELIM_APOSTROPHE
},
120 {"quote", DELIM_QUOTE
},
121 {"none", DELIM_NONE
},
125 static const st_option pad_opt
[] = {
132 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
133 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
139 current_mode (st_parameter_dt
*dtp
)
143 m
= FORM_UNSPECIFIED
;
145 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
147 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
148 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
150 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
152 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
153 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
155 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
157 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
158 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
165 /* Mid level data transfer statements. These subroutines do reading
166 and writing in the style of salloc_r()/salloc_w() within the
169 /* When reading sequential formatted records we have a problem. We
170 don't know how long the line is until we read the trailing newline,
171 and we don't want to read too much. If we read too much, we might
172 have to do a physical seek backwards depending on how much data is
173 present, and devices like terminals aren't seekable and would cause
176 Given this, the solution is to read a byte at a time, stopping if
177 we hit the newline. For small allocations, we use a static buffer.
178 For larger allocations, we are forced to allocate memory on the
179 heap. Hopefully this won't happen very often. */
182 read_sf (st_parameter_dt
*dtp
, int * length
, int no_error
)
184 static char *empty_string
[0];
186 int n
, lorig
, memread
, seen_comma
;
188 /* If we hit EOF previously with the no_error flag set (i.e. X, T,
189 TR edit descriptors), and we now try to read again, this time
190 without setting no_error. */
191 if (!no_error
&& dtp
->u
.p
.at_eof
)
198 /* If we have seen an eor previously, return a length of 0. The
199 caller is responsible for correctly padding the input field. */
200 if (dtp
->u
.p
.sf_seen_eor
)
203 /* Just return something that isn't a NULL pointer, otherwise the
204 caller thinks an error occured. */
205 return (char*) empty_string
;
208 if (is_internal_unit (dtp
))
211 base
= mem_alloc_r (dtp
->u
.p
.current_unit
->s
, length
);
212 if (unlikely (memread
> *length
))
223 /* Read data into format buffer and scan through it. */
225 base
= p
= fbuf_read (dtp
->u
.p
.current_unit
, length
);
233 if (q
== '\n' || q
== '\r')
235 /* Unexpected end of line. Set the position. */
236 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ 1 ,SEEK_CUR
);
237 dtp
->u
.p
.sf_seen_eor
= 1;
239 /* If we see an EOR during non-advancing I/O, we need to skip
240 the rest of the I/O statement. Set the corresponding flag. */
241 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
242 dtp
->u
.p
.eor_condition
= 1;
244 /* If we encounter a CR, it might be a CRLF. */
245 if (q
== '\r') /* Probably a CRLF */
247 /* See if there is an LF. Use fbuf_read rather then fbuf_getc so
248 the position is not advanced unless it really is an LF. */
250 p
= fbuf_read (dtp
->u
.p
.current_unit
, &readlen
);
251 if (*p
== '\n' && readlen
== 1)
253 dtp
->u
.p
.sf_seen_eor
= 2;
254 fbuf_seek (dtp
->u
.p
.current_unit
, 1 ,SEEK_CUR
);
258 /* Without padding, terminate the I/O statement without assigning
259 the value. With padding, the value still needs to be assigned,
260 so we can just continue with a short read. */
261 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
263 if (likely (no_error
))
265 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
272 /* Short circuit the read if a comma is found during numeric input.
273 The flag is set to zero during character reads so that commas in
274 strings are not ignored */
276 if (dtp
->u
.p
.sf_read_comma
== 1)
279 notify_std (&dtp
->common
, GFC_STD_GNU
,
280 "Comma in formatted numeric read.");
288 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ seen_comma
, SEEK_CUR
);
290 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
291 some other stuff. Set the relevant flags. */
292 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
305 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
307 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
308 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
314 /* Function for reading the next couple of bytes from the current
315 file, advancing the current position. We return FAILURE on end of record or
316 end of file. This function is only for formatted I/O, unformatted uses
319 If the read is short, then it is because the current record does not
320 have enough data to satisfy the read request and the file was
321 opened with PAD=YES. The caller must assume tailing spaces for
325 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
330 if (!is_stream_io (dtp
))
332 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
334 /* For preconnected units with default record length, set bytes left
335 to unit record length and proceed, otherwise error. */
336 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
337 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
338 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
341 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
343 /* Not enough data left. */
344 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
349 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
355 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
359 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
360 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
361 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
363 source
= read_sf (dtp
, nbytes
, 0);
364 dtp
->u
.p
.current_unit
->strm_pos
+=
365 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
369 /* If we reach here, we can assume it's direct access. */
371 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
374 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
375 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
377 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
378 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
380 if (norig
!= *nbytes
)
382 /* Short read, this shouldn't happen. */
383 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
385 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
390 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
396 /* Reads a block directly into application data space. This is for
397 unformatted files. */
400 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
402 ssize_t to_read_record
;
403 ssize_t have_read_record
;
404 ssize_t to_read_subrecord
;
405 ssize_t have_read_subrecord
;
408 if (is_stream_io (dtp
))
410 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
412 if (unlikely (have_read_record
< 0))
414 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
418 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
420 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
422 /* Short read, e.g. if we hit EOF. For stream files,
423 we have to set the end-of-file condition. */
429 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
431 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
434 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
435 nbytes
= to_read_record
;
440 to_read_record
= nbytes
;
443 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
445 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
446 if (unlikely (to_read_record
< 0))
448 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
452 if (to_read_record
!= (ssize_t
) nbytes
)
454 /* Short read, e.g. if we hit EOF. Apparently, we read
455 more than was written to the last record. */
459 if (unlikely (short_record
))
461 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
466 /* Unformatted sequential. We loop over the subrecords, reading
467 until the request has been fulfilled or the record has run out
468 of continuation subrecords. */
470 /* Check whether we exceed the total record length. */
472 if (dtp
->u
.p
.current_unit
->flags
.has_recl
473 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
475 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
480 to_read_record
= nbytes
;
483 have_read_record
= 0;
487 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
488 < (gfc_offset
) to_read_record
)
490 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
491 to_read_record
-= to_read_subrecord
;
495 to_read_subrecord
= to_read_record
;
499 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
501 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
502 buf
+ have_read_record
, to_read_subrecord
);
503 if (unlikely (have_read_subrecord
) < 0)
505 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
509 have_read_record
+= have_read_subrecord
;
511 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
514 /* Short read, e.g. if we hit EOF. This means the record
515 structure has been corrupted, or the trailing record
516 marker would still be present. */
518 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
522 if (to_read_record
> 0)
524 if (likely (dtp
->u
.p
.current_unit
->continued
))
526 next_record_r_unf (dtp
, 0);
531 /* Let's make sure the file position is correctly pre-positioned
532 for the next read statement. */
534 dtp
->u
.p
.current_unit
->current_record
= 0;
535 next_record_r_unf (dtp
, 0);
536 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
542 /* Normal exit, the read request has been fulfilled. */
547 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
548 if (unlikely (short_record
))
550 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
557 /* Function for writing a block of bytes to the current file at the
558 current position, advancing the file pointer. We are given a length
559 and return a pointer to a buffer that the caller must (completely)
560 fill in. Returns NULL on error. */
563 write_block (st_parameter_dt
*dtp
, int length
)
567 if (!is_stream_io (dtp
))
569 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
571 /* For preconnected units with default record length, set bytes left
572 to unit record length and proceed, otherwise error. */
573 if (likely ((dtp
->u
.p
.current_unit
->unit_number
574 == options
.stdout_unit
575 || dtp
->u
.p
.current_unit
->unit_number
576 == options
.stderr_unit
)
577 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
578 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
581 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
586 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
589 if (is_internal_unit (dtp
))
591 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
595 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
599 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
600 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
604 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
607 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
612 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
613 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
615 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
621 /* High level interface to swrite(), taking care of errors. This is only
622 called for unformatted files. There are three cases to consider:
623 Stream I/O, unformatted direct, unformatted sequential. */
626 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
629 ssize_t have_written
;
630 ssize_t to_write_subrecord
;
635 if (is_stream_io (dtp
))
637 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
638 if (unlikely (have_written
< 0))
640 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
644 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
649 /* Unformatted direct access. */
651 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
653 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
655 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
659 if (buf
== NULL
&& nbytes
== 0)
662 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
663 if (unlikely (have_written
< 0))
665 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
669 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
670 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
675 /* Unformatted sequential. */
679 if (dtp
->u
.p
.current_unit
->flags
.has_recl
680 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
682 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
694 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
695 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
697 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
698 (gfc_offset
) to_write_subrecord
;
700 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
701 buf
+ have_written
, to_write_subrecord
);
702 if (unlikely (to_write_subrecord
< 0))
704 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
708 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
709 nbytes
-= to_write_subrecord
;
710 have_written
+= to_write_subrecord
;
715 next_record_w_unf (dtp
, 1);
718 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
719 if (unlikely (short_record
))
721 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
728 /* Master function for unformatted reads. */
731 unformatted_read (st_parameter_dt
*dtp
, bt type
,
732 void *dest
, int kind
, size_t size
, size_t nelems
)
734 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
737 if (type
== BT_CHARACTER
)
738 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
739 read_block_direct (dtp
, dest
, size
* nelems
);
749 /* Handle wide chracters. */
750 if (type
== BT_CHARACTER
&& kind
!= 1)
756 /* Break up complex into its constituent reals. */
757 if (type
== BT_COMPLEX
)
763 /* By now, all complex variables have been split into their
764 constituent reals. */
766 for (i
= 0; i
< nelems
; i
++)
768 read_block_direct (dtp
, buffer
, size
);
769 reverse_memcpy (p
, buffer
, size
);
776 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
777 bytes on 64 bit machines. The unused bytes are not initialized and never
778 used, which can show an error with memory checking analyzers like
782 unformatted_write (st_parameter_dt
*dtp
, bt type
,
783 void *source
, int kind
, size_t size
, size_t nelems
)
785 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
788 size_t stride
= type
== BT_CHARACTER
?
789 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
791 write_buf (dtp
, source
, stride
* nelems
);
801 /* Handle wide chracters. */
802 if (type
== BT_CHARACTER
&& kind
!= 1)
808 /* Break up complex into its constituent reals. */
809 if (type
== BT_COMPLEX
)
815 /* By now, all complex variables have been split into their
816 constituent reals. */
818 for (i
= 0; i
< nelems
; i
++)
820 reverse_memcpy(buffer
, p
, size
);
822 write_buf (dtp
, buffer
, size
);
828 /* Return a pointer to the name of a type. */
853 internal_error (NULL
, "type_name(): Bad type");
860 /* Write a constant string to the output.
861 This is complicated because the string can have doubled delimiters
862 in it. The length in the format node is the true length. */
865 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
867 char c
, delimiter
, *p
, *q
;
870 length
= f
->u
.string
.length
;
874 p
= write_block (dtp
, length
);
881 for (; length
> 0; length
--)
884 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
885 q
++; /* Skip the doubled delimiter. */
890 /* Given actual and expected types in a formatted data transfer, make
891 sure they agree. If not, an error message is generated. Returns
892 nonzero if something went wrong. */
895 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
899 if (actual
== expected
)
902 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
903 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
905 format_error (dtp
, f
, buffer
);
910 /* This function is in the main loop for a formatted data transfer
911 statement. It would be natural to implement this as a coroutine
912 with the user program, but C makes that awkward. We loop,
913 processing format elements. When we actually have to transfer
914 data instead of just setting flags, we return control to the user
915 program which calls a function that supplies the address and type
916 of the next element, then comes back here to process it. */
919 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
926 int consume_data_flag
;
928 /* Change a complex data item into a pair of reals. */
930 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
931 if (type
== BT_COMPLEX
)
937 /* If there's an EOR condition, we simulate finalizing the transfer
939 if (dtp
->u
.p
.eor_condition
)
942 /* Set this flag so that commas in reads cause the read to complete before
943 the entire field has been read. The next read field will start right after
944 the comma in the stream. (Set to 0 for character reads). */
945 dtp
->u
.p
.sf_read_comma
=
946 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
950 /* If reversion has occurred and there is another real data item,
951 then we have to move to the next record. */
952 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
954 dtp
->u
.p
.reversion_flag
= 0;
955 next_record (dtp
, 0);
958 consume_data_flag
= 1;
959 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
962 f
= next_format (dtp
);
965 /* No data descriptors left. */
966 if (unlikely (n
> 0))
967 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
968 "Insufficient data descriptors in format after reversion");
974 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
975 - dtp
->u
.p
.current_unit
->bytes_left
);
977 if (is_stream_io(dtp
))
985 if (require_type (dtp
, BT_INTEGER
, type
, f
))
987 read_decimal (dtp
, f
, p
, kind
);
993 if (compile_options
.allow_std
< GFC_STD_GNU
994 && require_type (dtp
, BT_INTEGER
, type
, f
))
996 read_radix (dtp
, f
, p
, kind
, 2);
1001 goto need_read_data
;
1002 if (compile_options
.allow_std
< GFC_STD_GNU
1003 && require_type (dtp
, BT_INTEGER
, type
, f
))
1005 read_radix (dtp
, f
, p
, kind
, 8);
1010 goto need_read_data
;
1011 if (compile_options
.allow_std
< GFC_STD_GNU
1012 && require_type (dtp
, BT_INTEGER
, type
, f
))
1014 read_radix (dtp
, f
, p
, kind
, 16);
1019 goto need_read_data
;
1021 /* It is possible to have FMT_A with something not BT_CHARACTER such
1022 as when writing out hollerith strings, so check both type
1023 and kind before calling wide character routines. */
1024 if (type
== BT_CHARACTER
&& kind
== 4)
1025 read_a_char4 (dtp
, f
, p
, size
);
1027 read_a (dtp
, f
, p
, size
);
1032 goto need_read_data
;
1033 read_l (dtp
, f
, p
, kind
);
1038 goto need_read_data
;
1039 if (require_type (dtp
, BT_REAL
, type
, f
))
1041 read_f (dtp
, f
, p
, kind
);
1046 goto need_read_data
;
1047 if (require_type (dtp
, BT_REAL
, type
, f
))
1049 read_f (dtp
, f
, p
, kind
);
1054 goto need_read_data
;
1055 if (require_type (dtp
, BT_REAL
, type
, f
))
1057 read_f (dtp
, f
, p
, kind
);
1062 goto need_read_data
;
1063 if (require_type (dtp
, BT_REAL
, type
, f
))
1065 read_f (dtp
, f
, p
, kind
);
1070 goto need_read_data
;
1071 if (require_type (dtp
, BT_REAL
, type
, f
))
1073 read_f (dtp
, f
, p
, kind
);
1078 goto need_read_data
;
1082 read_decimal (dtp
, f
, p
, kind
);
1085 read_l (dtp
, f
, p
, kind
);
1089 read_a_char4 (dtp
, f
, p
, size
);
1091 read_a (dtp
, f
, p
, size
);
1094 read_f (dtp
, f
, p
, kind
);
1097 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1102 consume_data_flag
= 0;
1103 format_error (dtp
, f
, "Constant string in input format");
1106 /* Format codes that don't transfer data. */
1109 consume_data_flag
= 0;
1110 dtp
->u
.p
.skips
+= f
->u
.n
;
1111 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1112 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1113 read_x (dtp
, f
->u
.n
);
1118 consume_data_flag
= 0;
1120 if (f
->format
== FMT_TL
)
1122 /* Handle the special case when no bytes have been used yet.
1123 Cannot go below zero. */
1124 if (bytes_used
== 0)
1126 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1127 dtp
->u
.p
.skips
-= f
->u
.n
;
1128 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1131 pos
= bytes_used
- f
->u
.n
;
1136 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1137 left tab limit. We do not check if the position has gone
1138 beyond the end of record because a subsequent tab could
1139 bring us back again. */
1140 pos
= pos
< 0 ? 0 : pos
;
1142 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1143 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1144 + pos
- dtp
->u
.p
.max_pos
;
1145 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1146 ? 0 : dtp
->u
.p
.pending_spaces
;
1147 if (dtp
->u
.p
.skips
== 0)
1150 /* Adjust everything for end-of-record condition */
1151 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1153 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1154 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1156 dtp
->u
.p
.sf_seen_eor
= 0;
1158 if (dtp
->u
.p
.skips
< 0)
1160 if (is_internal_unit (dtp
))
1161 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1163 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1164 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1165 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1168 read_x (dtp
, dtp
->u
.p
.skips
);
1172 consume_data_flag
= 0;
1173 dtp
->u
.p
.sign_status
= SIGN_S
;
1177 consume_data_flag
= 0;
1178 dtp
->u
.p
.sign_status
= SIGN_SS
;
1182 consume_data_flag
= 0;
1183 dtp
->u
.p
.sign_status
= SIGN_SP
;
1187 consume_data_flag
= 0 ;
1188 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1192 consume_data_flag
= 0;
1193 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1197 consume_data_flag
= 0;
1198 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1202 consume_data_flag
= 0;
1203 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1207 consume_data_flag
= 0;
1208 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1212 consume_data_flag
= 0;
1213 dtp
->u
.p
.seen_dollar
= 1;
1217 consume_data_flag
= 0;
1218 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1219 next_record (dtp
, 0);
1223 /* A colon descriptor causes us to exit this loop (in
1224 particular preventing another / descriptor from being
1225 processed) unless there is another data item to be
1227 consume_data_flag
= 0;
1233 internal_error (&dtp
->common
, "Bad format node");
1236 /* Adjust the item count and data pointer. */
1238 if ((consume_data_flag
> 0) && (n
> 0))
1241 p
= ((char *) p
) + size
;
1246 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1247 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1252 /* Come here when we need a data descriptor but don't have one. We
1253 push the current format node back onto the input, then return and
1254 let the user program call us back with the data. */
1256 unget_format (dtp
, f
);
1261 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1264 int pos
, bytes_used
;
1268 int consume_data_flag
;
1270 /* Change a complex data item into a pair of reals. */
1272 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1273 if (type
== BT_COMPLEX
)
1279 /* If there's an EOR condition, we simulate finalizing the transfer
1280 by doing nothing. */
1281 if (dtp
->u
.p
.eor_condition
)
1284 /* Set this flag so that commas in reads cause the read to complete before
1285 the entire field has been read. The next read field will start right after
1286 the comma in the stream. (Set to 0 for character reads). */
1287 dtp
->u
.p
.sf_read_comma
=
1288 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1292 /* If reversion has occurred and there is another real data item,
1293 then we have to move to the next record. */
1294 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1296 dtp
->u
.p
.reversion_flag
= 0;
1297 next_record (dtp
, 0);
1300 consume_data_flag
= 1;
1301 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1304 f
= next_format (dtp
);
1307 /* No data descriptors left. */
1308 if (unlikely (n
> 0))
1309 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1310 "Insufficient data descriptors in format after reversion");
1314 /* Now discharge T, TR and X movements to the right. This is delayed
1315 until a data producing format to suppress trailing spaces. */
1318 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1319 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1320 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1321 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1322 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1323 || t
== FMT_STRING
))
1325 if (dtp
->u
.p
.skips
> 0)
1328 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1329 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1330 - dtp
->u
.p
.current_unit
->bytes_left
);
1332 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1334 if (dtp
->u
.p
.skips
< 0)
1336 if (is_internal_unit (dtp
))
1337 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1339 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1340 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1342 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1345 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1346 - dtp
->u
.p
.current_unit
->bytes_left
);
1348 if (is_stream_io(dtp
))
1356 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1358 write_i (dtp
, f
, p
, kind
);
1364 if (compile_options
.allow_std
< GFC_STD_GNU
1365 && require_type (dtp
, BT_INTEGER
, type
, f
))
1367 write_b (dtp
, f
, p
, kind
);
1373 if (compile_options
.allow_std
< GFC_STD_GNU
1374 && require_type (dtp
, BT_INTEGER
, type
, f
))
1376 write_o (dtp
, f
, p
, kind
);
1382 if (compile_options
.allow_std
< GFC_STD_GNU
1383 && require_type (dtp
, BT_INTEGER
, type
, f
))
1385 write_z (dtp
, f
, p
, kind
);
1392 /* It is possible to have FMT_A with something not BT_CHARACTER such
1393 as when writing out hollerith strings, so check both type
1394 and kind before calling wide character routines. */
1395 if (type
== BT_CHARACTER
&& kind
== 4)
1396 write_a_char4 (dtp
, f
, p
, size
);
1398 write_a (dtp
, f
, p
, size
);
1404 write_l (dtp
, f
, p
, kind
);
1410 if (require_type (dtp
, BT_REAL
, type
, f
))
1412 write_d (dtp
, f
, p
, kind
);
1418 if (require_type (dtp
, BT_REAL
, type
, f
))
1420 write_e (dtp
, f
, p
, kind
);
1426 if (require_type (dtp
, BT_REAL
, type
, f
))
1428 write_en (dtp
, f
, p
, kind
);
1434 if (require_type (dtp
, BT_REAL
, type
, f
))
1436 write_es (dtp
, f
, p
, kind
);
1442 if (require_type (dtp
, BT_REAL
, type
, f
))
1444 write_f (dtp
, f
, p
, kind
);
1453 write_i (dtp
, f
, p
, kind
);
1456 write_l (dtp
, f
, p
, kind
);
1460 write_a_char4 (dtp
, f
, p
, size
);
1462 write_a (dtp
, f
, p
, size
);
1465 if (f
->u
.real
.w
== 0)
1466 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1468 write_d (dtp
, f
, p
, kind
);
1471 internal_error (&dtp
->common
,
1472 "formatted_transfer(): Bad type");
1477 consume_data_flag
= 0;
1478 write_constant_string (dtp
, f
);
1481 /* Format codes that don't transfer data. */
1484 consume_data_flag
= 0;
1486 dtp
->u
.p
.skips
+= f
->u
.n
;
1487 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1488 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1489 /* Writes occur just before the switch on f->format, above, so
1490 that trailing blanks are suppressed, unless we are doing a
1491 non-advancing write in which case we want to output the blanks
1493 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1495 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1496 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1502 consume_data_flag
= 0;
1504 if (f
->format
== FMT_TL
)
1507 /* Handle the special case when no bytes have been used yet.
1508 Cannot go below zero. */
1509 if (bytes_used
== 0)
1511 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1512 dtp
->u
.p
.skips
-= f
->u
.n
;
1513 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1516 pos
= bytes_used
- f
->u
.n
;
1519 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1521 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1522 left tab limit. We do not check if the position has gone
1523 beyond the end of record because a subsequent tab could
1524 bring us back again. */
1525 pos
= pos
< 0 ? 0 : pos
;
1527 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1528 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1529 + pos
- dtp
->u
.p
.max_pos
;
1530 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1531 ? 0 : dtp
->u
.p
.pending_spaces
;
1535 consume_data_flag
= 0;
1536 dtp
->u
.p
.sign_status
= SIGN_S
;
1540 consume_data_flag
= 0;
1541 dtp
->u
.p
.sign_status
= SIGN_SS
;
1545 consume_data_flag
= 0;
1546 dtp
->u
.p
.sign_status
= SIGN_SP
;
1550 consume_data_flag
= 0 ;
1551 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1555 consume_data_flag
= 0;
1556 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1560 consume_data_flag
= 0;
1561 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1565 consume_data_flag
= 0;
1566 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1570 consume_data_flag
= 0;
1571 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1575 consume_data_flag
= 0;
1576 dtp
->u
.p
.seen_dollar
= 1;
1580 consume_data_flag
= 0;
1581 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1582 next_record (dtp
, 0);
1586 /* A colon descriptor causes us to exit this loop (in
1587 particular preventing another / descriptor from being
1588 processed) unless there is another data item to be
1590 consume_data_flag
= 0;
1596 internal_error (&dtp
->common
, "Bad format node");
1599 /* Adjust the item count and data pointer. */
1601 if ((consume_data_flag
> 0) && (n
> 0))
1604 p
= ((char *) p
) + size
;
1607 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1608 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1613 /* Come here when we need a data descriptor but don't have one. We
1614 push the current format node back onto the input, then return and
1615 let the user program call us back with the data. */
1617 unget_format (dtp
, f
);
1622 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1623 size_t size
, size_t nelems
)
1629 size_t stride
= type
== BT_CHARACTER
?
1630 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1631 if (dtp
->u
.p
.mode
== READING
)
1633 /* Big loop over all the elements. */
1634 for (elem
= 0; elem
< nelems
; elem
++)
1636 dtp
->u
.p
.item_count
++;
1637 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1642 /* Big loop over all the elements. */
1643 for (elem
= 0; elem
< nelems
; elem
++)
1645 dtp
->u
.p
.item_count
++;
1646 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1652 /* Data transfer entry points. The type of the data entity is
1653 implicit in the subroutine call. This prevents us from having to
1654 share a common enum with the compiler. */
1657 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1659 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1661 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1666 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1669 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1671 size
= size_from_real_kind (kind
);
1672 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1677 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1679 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1681 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1686 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1688 static char *empty_string
[0];
1690 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1693 /* Strings of zero length can have p == NULL, which confuses the
1694 transfer routines into thinking we need more data elements. To avoid
1695 this, we give them a nice pointer. */
1696 if (len
== 0 && p
== NULL
)
1699 /* Set kind here to 1. */
1700 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1704 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1706 static char *empty_string
[0];
1708 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1711 /* Strings of zero length can have p == NULL, which confuses the
1712 transfer routines into thinking we need more data elements. To avoid
1713 this, we give them a nice pointer. */
1714 if (len
== 0 && p
== NULL
)
1717 /* Here we pass the actual kind value. */
1718 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1723 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1726 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1728 size
= size_from_complex_kind (kind
);
1729 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1734 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1735 gfc_charlen_type charlen
)
1737 index_type count
[GFC_MAX_DIMENSIONS
];
1738 index_type extent
[GFC_MAX_DIMENSIONS
];
1739 index_type stride
[GFC_MAX_DIMENSIONS
];
1740 index_type stride0
, rank
, size
, type
, n
;
1745 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1748 type
= GFC_DESCRIPTOR_TYPE (desc
);
1749 size
= GFC_DESCRIPTOR_SIZE (desc
);
1751 /* FIXME: What a kludge: Array descriptors and the IO library use
1752 different enums for types. */
1755 case GFC_DTYPE_UNKNOWN
:
1756 iotype
= BT_NULL
; /* Is this correct? */
1758 case GFC_DTYPE_INTEGER
:
1759 iotype
= BT_INTEGER
;
1761 case GFC_DTYPE_LOGICAL
:
1762 iotype
= BT_LOGICAL
;
1764 case GFC_DTYPE_REAL
:
1767 case GFC_DTYPE_COMPLEX
:
1768 iotype
= BT_COMPLEX
;
1770 case GFC_DTYPE_CHARACTER
:
1771 iotype
= BT_CHARACTER
;
1774 case GFC_DTYPE_DERIVED
:
1775 internal_error (&dtp
->common
,
1776 "Derived type I/O should have been handled via the frontend.");
1779 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1782 rank
= GFC_DESCRIPTOR_RANK (desc
);
1783 for (n
= 0; n
< rank
; n
++)
1786 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
1787 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
1789 /* If the extent of even one dimension is zero, then the entire
1790 array section contains zero elements, so we return after writing
1791 a zero array record. */
1796 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1801 stride0
= stride
[0];
1803 /* If the innermost dimension has a stride of 1, we can do the transfer
1804 in contiguous chunks. */
1805 if (stride0
== size
)
1810 data
= GFC_DESCRIPTOR_DATA (desc
);
1814 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1815 data
+= stride0
* tsize
;
1818 while (count
[n
] == extent
[n
])
1821 data
-= stride
[n
] * extent
[n
];
1838 /* Preposition a sequential unformatted file while reading. */
1841 us_read (st_parameter_dt
*dtp
, int continued
)
1848 if (compile_options
.record_marker
== 0)
1849 n
= sizeof (GFC_INTEGER_4
);
1851 n
= compile_options
.record_marker
;
1853 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1854 if (unlikely (nr
< 0))
1856 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1862 return; /* end of file */
1864 else if (unlikely (n
!= nr
))
1866 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1870 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1871 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1875 case sizeof(GFC_INTEGER_4
):
1876 memcpy (&i4
, &i
, sizeof (i4
));
1880 case sizeof(GFC_INTEGER_8
):
1881 memcpy (&i8
, &i
, sizeof (i8
));
1886 runtime_error ("Illegal value for record marker");
1893 case sizeof(GFC_INTEGER_4
):
1894 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1898 case sizeof(GFC_INTEGER_8
):
1899 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1904 runtime_error ("Illegal value for record marker");
1910 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1911 dtp
->u
.p
.current_unit
->continued
= 0;
1915 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1916 dtp
->u
.p
.current_unit
->continued
= 1;
1920 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1924 /* Preposition a sequential unformatted file while writing. This
1925 amount to writing a bogus length that will be filled in later. */
1928 us_write (st_parameter_dt
*dtp
, int continued
)
1935 if (compile_options
.record_marker
== 0)
1936 nbytes
= sizeof (GFC_INTEGER_4
);
1938 nbytes
= compile_options
.record_marker
;
1940 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
1941 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1943 /* For sequential unformatted, if RECL= was not specified in the OPEN
1944 we write until we have more bytes than can fit in the subrecord
1945 markers, then we write a new subrecord. */
1947 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1948 dtp
->u
.p
.current_unit
->recl_subrecord
;
1949 dtp
->u
.p
.current_unit
->continued
= continued
;
1953 /* Position to the next record prior to transfer. We are assumed to
1954 be before the next record. We also calculate the bytes in the next
1958 pre_position (st_parameter_dt
*dtp
)
1960 if (dtp
->u
.p
.current_unit
->current_record
)
1961 return; /* Already positioned. */
1963 switch (current_mode (dtp
))
1965 case FORMATTED_STREAM
:
1966 case UNFORMATTED_STREAM
:
1967 /* There are no records with stream I/O. If the position was specified
1968 data_transfer_init has already positioned the file. If no position
1969 was specified, we continue from where we last left off. I.e.
1970 there is nothing to do here. */
1973 case UNFORMATTED_SEQUENTIAL
:
1974 if (dtp
->u
.p
.mode
== READING
)
1981 case FORMATTED_SEQUENTIAL
:
1982 case FORMATTED_DIRECT
:
1983 case UNFORMATTED_DIRECT
:
1984 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1988 dtp
->u
.p
.current_unit
->current_record
= 1;
1992 /* Initialize things for a data transfer. This code is common for
1993 both reading and writing. */
1996 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1998 unit_flags u_flags
; /* Used for creating a unit if needed. */
1999 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2000 namelist_info
*ionml
;
2002 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2004 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2006 dtp
->u
.p
.ionml
= ionml
;
2007 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2009 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2012 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2013 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2015 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2016 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2017 { /* Open the unit with some default flags. */
2018 st_parameter_open opp
;
2021 if (dtp
->common
.unit
< 0)
2023 close_unit (dtp
->u
.p
.current_unit
);
2024 dtp
->u
.p
.current_unit
= NULL
;
2025 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2026 "Bad unit number in statement");
2029 memset (&u_flags
, '\0', sizeof (u_flags
));
2030 u_flags
.access
= ACCESS_SEQUENTIAL
;
2031 u_flags
.action
= ACTION_READWRITE
;
2033 /* Is it unformatted? */
2034 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2035 | IOPARM_DT_IONML_SET
)))
2036 u_flags
.form
= FORM_UNFORMATTED
;
2038 u_flags
.form
= FORM_UNSPECIFIED
;
2040 u_flags
.delim
= DELIM_UNSPECIFIED
;
2041 u_flags
.blank
= BLANK_UNSPECIFIED
;
2042 u_flags
.pad
= PAD_UNSPECIFIED
;
2043 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2044 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2045 u_flags
.async
= ASYNC_UNSPECIFIED
;
2046 u_flags
.round
= ROUND_UNSPECIFIED
;
2047 u_flags
.sign
= SIGN_UNSPECIFIED
;
2049 u_flags
.status
= STATUS_UNKNOWN
;
2051 conv
= get_unformatted_convert (dtp
->common
.unit
);
2053 if (conv
== GFC_CONVERT_NONE
)
2054 conv
= compile_options
.convert
;
2056 /* We use big_endian, which is 0 on little-endian machines
2057 and 1 on big-endian machines. */
2060 case GFC_CONVERT_NATIVE
:
2061 case GFC_CONVERT_SWAP
:
2064 case GFC_CONVERT_BIG
:
2065 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2068 case GFC_CONVERT_LITTLE
:
2069 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2073 internal_error (&opp
.common
, "Illegal value for CONVERT");
2077 u_flags
.convert
= conv
;
2079 opp
.common
= dtp
->common
;
2080 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2081 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2082 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2083 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2084 if (dtp
->u
.p
.current_unit
== NULL
)
2088 /* Check the action. */
2090 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2092 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2093 "Cannot read from file opened for WRITE");
2097 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2099 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2100 "Cannot write to file opened for READ");
2104 dtp
->u
.p
.first_item
= 1;
2106 /* Check the format. */
2108 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2111 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2112 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2115 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2116 "Format present for UNFORMATTED data transfer");
2120 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2122 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2123 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2124 "A format cannot be specified with a namelist");
2126 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2127 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2129 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2130 "Missing format for FORMATTED data transfer");
2133 if (is_internal_unit (dtp
)
2134 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2136 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2137 "Internal file cannot be accessed by UNFORMATTED "
2142 /* Check the record or position number. */
2144 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2145 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2147 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2148 "Direct access data transfer requires record number");
2152 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2153 && (cf
& IOPARM_DT_HAS_REC
) != 0)
2155 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2156 "Record number not allowed for sequential access "
2161 /* Process the ADVANCE option. */
2163 dtp
->u
.p
.advance_status
2164 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2165 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2166 "Bad ADVANCE parameter in data transfer statement");
2168 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2170 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2172 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2173 "ADVANCE specification conflicts with sequential "
2178 if (is_internal_unit (dtp
))
2180 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2181 "ADVANCE specification conflicts with internal file");
2185 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2186 != IOPARM_DT_HAS_FORMAT
)
2188 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2189 "ADVANCE specification requires an explicit format");
2196 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2198 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2200 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2201 "EOR specification requires an ADVANCE specification "
2206 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2207 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2209 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2210 "SIZE specification requires an ADVANCE "
2211 "specification of NO");
2216 { /* Write constraints. */
2217 if ((cf
& IOPARM_END
) != 0)
2219 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2220 "END specification cannot appear in a write "
2225 if ((cf
& IOPARM_EOR
) != 0)
2227 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2228 "EOR specification cannot appear in a write "
2233 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2235 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2236 "SIZE specification cannot appear in a write "
2242 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2243 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2245 /* Check the decimal mode. */
2246 dtp
->u
.p
.current_unit
->decimal_status
2247 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2248 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2249 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2252 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2253 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2255 /* Check the sign mode. */
2256 dtp
->u
.p
.sign_status
2257 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2258 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2259 "Bad SIGN parameter in data transfer statement");
2261 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2262 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2264 /* Check the blank mode. */
2265 dtp
->u
.p
.blank_status
2266 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2267 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2269 "Bad BLANK parameter in data transfer statement");
2271 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2272 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2274 /* Check the delim mode. */
2275 dtp
->u
.p
.current_unit
->delim_status
2276 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2277 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2278 delim_opt
, "Bad DELIM parameter in data transfer statement");
2280 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2281 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2283 /* Check the pad mode. */
2284 dtp
->u
.p
.current_unit
->pad_status
2285 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2286 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2287 "Bad PAD parameter in data transfer statement");
2289 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2290 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2292 /* Check to see if we might be reading what we wrote before */
2294 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2295 && !is_internal_unit (dtp
))
2297 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2299 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2300 sflush(dtp
->u
.p
.current_unit
->s
);
2303 /* Check the POS= specifier: that it is in range and that it is used with a
2304 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2306 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2308 if (is_stream_io (dtp
))
2313 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2314 "POS=specifier must be positive");
2318 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2320 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2321 "POS=specifier too large");
2325 dtp
->rec
= dtp
->pos
;
2327 if (dtp
->u
.p
.mode
== READING
)
2329 /* Reset the endfile flag; if we hit EOF during reading
2330 we'll set the flag and generate an error at that point
2331 rather than worrying about it here. */
2332 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2335 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2337 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2338 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2340 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2343 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2348 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2349 "POS=specifier not allowed, "
2350 "Try OPEN with ACCESS='stream'");
2356 /* Sanity checks on the record number. */
2357 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2361 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2362 "Record number must be positive");
2366 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2368 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2369 "Record number too large");
2373 /* Make sure format buffer is reset. */
2374 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2375 fbuf_reset (dtp
->u
.p
.current_unit
);
2378 /* Check whether the record exists to be read. Only
2379 a partial record needs to exist. */
2381 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2382 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2384 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2385 "Non-existing record number");
2389 /* Position the file. */
2390 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2391 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2393 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2397 /* TODO: This is required to maintain compatibility between
2398 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2400 if (is_stream_io (dtp
))
2401 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2403 /* TODO: Un-comment this code when ABI changes from 4.3.
2404 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2406 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2407 "Record number not allowed for stream access "
2413 /* Bugware for badly written mixed C-Fortran I/O. */
2414 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2416 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2418 /* Set the maximum position reached from the previous I/O operation. This
2419 could be greater than zero from a previous non-advancing write. */
2420 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2425 /* Set up the subroutine that will handle the transfers. */
2429 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2430 dtp
->u
.p
.transfer
= unformatted_read
;
2433 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2434 dtp
->u
.p
.transfer
= list_formatted_read
;
2436 dtp
->u
.p
.transfer
= formatted_transfer
;
2441 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2442 dtp
->u
.p
.transfer
= unformatted_write
;
2445 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2446 dtp
->u
.p
.transfer
= list_formatted_write
;
2448 dtp
->u
.p
.transfer
= formatted_transfer
;
2452 /* Make sure that we don't do a read after a nonadvancing write. */
2456 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2458 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2459 "Cannot READ after a nonadvancing WRITE");
2465 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2466 dtp
->u
.p
.current_unit
->read_bad
= 1;
2469 /* Start the data transfer if we are doing a formatted transfer. */
2470 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2471 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2472 && dtp
->u
.p
.ionml
== NULL
)
2473 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2476 /* Initialize an array_loop_spec given the array descriptor. The function
2477 returns the index of the last element of the array, and also returns
2478 starting record, where the first I/O goes to (necessary in case of
2479 negative strides). */
2482 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2483 gfc_offset
*start_record
)
2485 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2494 for (i
=0; i
<rank
; i
++)
2496 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2497 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2498 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2499 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2500 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2501 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2503 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2505 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2506 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2510 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2511 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2512 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2513 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2523 /* Determine the index to the next record in an internal unit array by
2524 by incrementing through the array_loop_spec. */
2527 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2535 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2540 if (ls
[i
].idx
> ls
[i
].end
)
2542 ls
[i
].idx
= ls
[i
].start
;
2548 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2558 /* Skip to the end of the current record, taking care of an optional
2559 record marker of size bytes. If the file is not seekable, we
2560 read chunks of size MAX_READ until we get to the right
2564 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2566 ssize_t rlength
, readb
;
2567 static const ssize_t MAX_READ
= 4096;
2570 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2571 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2574 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2576 /* Direct access files do not generate END conditions,
2578 if (sseek (dtp
->u
.p
.current_unit
->s
,
2579 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2580 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2583 { /* Seek by reading data. */
2584 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2587 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2588 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2590 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2593 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2597 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2604 /* Advance to the next record reading unformatted files, taking
2605 care of subrecords. If complete_record is nonzero, we loop
2606 until all subrecords are cleared. */
2609 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2613 bytes
= compile_options
.record_marker
== 0 ?
2614 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2619 /* Skip over tail */
2621 skip_record (dtp
, bytes
);
2623 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2631 static inline gfc_offset
2632 min_off (gfc_offset a
, gfc_offset b
)
2634 return (a
< b
? a
: b
);
2638 /* Space to the next record for read mode. */
2641 next_record_r (st_parameter_dt
*dtp
)
2648 switch (current_mode (dtp
))
2650 /* No records in unformatted STREAM I/O. */
2651 case UNFORMATTED_STREAM
:
2654 case UNFORMATTED_SEQUENTIAL
:
2655 next_record_r_unf (dtp
, 1);
2656 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2659 case FORMATTED_DIRECT
:
2660 case UNFORMATTED_DIRECT
:
2661 skip_record (dtp
, 0);
2664 case FORMATTED_STREAM
:
2665 case FORMATTED_SEQUENTIAL
:
2666 /* read_sf has already terminated input because of an '\n', or
2668 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2670 dtp
->u
.p
.sf_seen_eor
= 0;
2671 dtp
->u
.p
.at_eof
= 0;
2675 if (is_internal_unit (dtp
))
2677 if (is_array_io (dtp
))
2681 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2684 /* Now seek to this record. */
2685 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2686 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2688 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2691 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2695 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2696 bytes_left
= min_off (bytes_left
,
2697 file_length (dtp
->u
.p
.current_unit
->s
)
2698 - stell (dtp
->u
.p
.current_unit
->s
));
2699 if (sseek (dtp
->u
.p
.current_unit
->s
,
2700 bytes_left
, SEEK_CUR
) < 0)
2702 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2705 dtp
->u
.p
.current_unit
->bytes_left
2706 = dtp
->u
.p
.current_unit
->recl
;
2715 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2719 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2725 if (is_stream_io (dtp
))
2726 dtp
->u
.p
.current_unit
->strm_pos
++;
2737 /* Small utility function to write a record marker, taking care of
2738 byte swapping and of choosing the correct size. */
2741 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2746 char p
[sizeof (GFC_INTEGER_8
)];
2748 if (compile_options
.record_marker
== 0)
2749 len
= sizeof (GFC_INTEGER_4
);
2751 len
= compile_options
.record_marker
;
2753 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2754 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2758 case sizeof (GFC_INTEGER_4
):
2760 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2763 case sizeof (GFC_INTEGER_8
):
2765 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2769 runtime_error ("Illegal value for record marker");
2777 case sizeof (GFC_INTEGER_4
):
2779 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2780 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2783 case sizeof (GFC_INTEGER_8
):
2785 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2786 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2790 runtime_error ("Illegal value for record marker");
2797 /* Position to the next (sub)record in write mode for
2798 unformatted sequential files. */
2801 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2803 gfc_offset m
, m_write
, record_marker
;
2805 /* Bytes written. */
2806 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2807 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2809 /* Write the length tail. If we finish a record containing
2810 subrecords, we write out the negative length. */
2812 if (dtp
->u
.p
.current_unit
->continued
)
2817 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2820 if (compile_options
.record_marker
== 0)
2821 record_marker
= sizeof (GFC_INTEGER_4
);
2823 record_marker
= compile_options
.record_marker
;
2825 /* Seek to the head and overwrite the bogus length with the real
2828 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2837 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2840 /* Seek past the end of the current record. */
2842 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2849 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2855 /* Utility function like memset() but operating on streams. Return
2856 value is same as for POSIX write(). */
2859 sset (stream
* s
, int c
, ssize_t nbyte
)
2861 static const int WRITE_CHUNK
= 256;
2862 char p
[WRITE_CHUNK
];
2863 ssize_t bytes_left
, trans
;
2865 if (nbyte
< WRITE_CHUNK
)
2866 memset (p
, c
, nbyte
);
2868 memset (p
, c
, WRITE_CHUNK
);
2871 while (bytes_left
> 0)
2873 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2874 trans
= swrite (s
, p
, trans
);
2877 bytes_left
-= trans
;
2880 return nbyte
- bytes_left
;
2883 /* Position to the next record in write mode. */
2886 next_record_w (st_parameter_dt
*dtp
, int done
)
2888 gfc_offset m
, record
, max_pos
;
2891 /* Zero counters for X- and T-editing. */
2892 max_pos
= dtp
->u
.p
.max_pos
;
2893 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2895 switch (current_mode (dtp
))
2897 /* No records in unformatted STREAM I/O. */
2898 case UNFORMATTED_STREAM
:
2901 case FORMATTED_DIRECT
:
2902 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2905 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2906 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2907 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2908 dtp
->u
.p
.current_unit
->bytes_left
)
2909 != dtp
->u
.p
.current_unit
->bytes_left
)
2914 case UNFORMATTED_DIRECT
:
2915 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2917 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2918 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
2923 case UNFORMATTED_SEQUENTIAL
:
2924 next_record_w_unf (dtp
, 0);
2925 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2928 case FORMATTED_STREAM
:
2929 case FORMATTED_SEQUENTIAL
:
2931 if (is_internal_unit (dtp
))
2933 if (is_array_io (dtp
))
2937 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2939 /* If the farthest position reached is greater than current
2940 position, adjust the position and set length to pad out
2941 whats left. Otherwise just pad whats left.
2942 (for character array unit) */
2943 m
= dtp
->u
.p
.current_unit
->recl
2944 - dtp
->u
.p
.current_unit
->bytes_left
;
2947 length
= (int) (max_pos
- m
);
2948 if (sseek (dtp
->u
.p
.current_unit
->s
,
2949 length
, SEEK_CUR
) < 0)
2951 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2954 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2957 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
2959 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2963 /* Now that the current record has been padded out,
2964 determine where the next record in the array is. */
2965 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2968 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2970 /* Now seek to this record */
2971 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2973 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2975 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2979 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2985 /* If this is the last call to next_record move to the farthest
2986 position reached and set length to pad out the remainder
2987 of the record. (for character scaler unit) */
2990 m
= dtp
->u
.p
.current_unit
->recl
2991 - dtp
->u
.p
.current_unit
->bytes_left
;
2994 length
= (int) (max_pos
- m
);
2995 if (sseek (dtp
->u
.p
.current_unit
->s
,
2996 length
, SEEK_CUR
) < 0)
2998 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
3001 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3004 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3007 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3009 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3021 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3022 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3029 if (is_stream_io (dtp
))
3031 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3032 if (dtp
->u
.p
.current_unit
->strm_pos
3033 < file_length (dtp
->u
.p
.current_unit
->s
))
3034 unit_truncate (dtp
->u
.p
.current_unit
,
3035 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3043 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3048 /* Position to the next record, which means moving to the end of the
3049 current record. This can happen under several different
3050 conditions. If the done flag is not set, we get ready to process
3054 next_record (st_parameter_dt
*dtp
, int done
)
3056 gfc_offset fp
; /* File position. */
3058 dtp
->u
.p
.current_unit
->read_bad
= 0;
3060 if (dtp
->u
.p
.mode
== READING
)
3061 next_record_r (dtp
);
3063 next_record_w (dtp
, done
);
3065 if (!is_stream_io (dtp
))
3067 /* Keep position up to date for INQUIRE */
3069 update_position (dtp
->u
.p
.current_unit
);
3071 dtp
->u
.p
.current_unit
->current_record
= 0;
3072 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3074 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3075 /* Calculate next record, rounding up partial records. */
3076 dtp
->u
.p
.current_unit
->last_record
=
3077 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3078 dtp
->u
.p
.current_unit
->recl
;
3081 dtp
->u
.p
.current_unit
->last_record
++;
3087 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3091 /* Finalize the current data transfer. For a nonadvancing transfer,
3092 this means advancing to the next record. For internal units close the
3093 stream associated with the unit. */
3096 finalize_transfer (st_parameter_dt
*dtp
)
3099 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3101 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3102 *dtp
->size
= dtp
->u
.p
.size_used
;
3104 if (dtp
->u
.p
.eor_condition
)
3106 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3110 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3112 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3113 dtp
->u
.p
.current_unit
->current_record
= 0;
3117 if ((dtp
->u
.p
.ionml
!= NULL
)
3118 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3120 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3121 namelist_read (dtp
);
3123 namelist_write (dtp
);
3126 dtp
->u
.p
.transfer
= NULL
;
3127 if (dtp
->u
.p
.current_unit
== NULL
)
3130 dtp
->u
.p
.eof_jump
= &eof_jump
;
3131 if (setjmp (eof_jump
))
3133 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3137 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3139 finish_list_read (dtp
);
3143 if (dtp
->u
.p
.mode
== WRITING
)
3144 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3145 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3147 if (is_stream_io (dtp
))
3149 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3150 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3151 next_record (dtp
, 1);
3156 dtp
->u
.p
.current_unit
->current_record
= 0;
3158 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3160 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3161 dtp
->u
.p
.seen_dollar
= 0;
3165 /* For non-advancing I/O, save the current maximum position for use in the
3166 next I/O operation if needed. */
3167 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3169 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3170 - dtp
->u
.p
.current_unit
->bytes_left
);
3171 dtp
->u
.p
.current_unit
->saved_pos
=
3172 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3173 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3176 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3177 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3178 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3180 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3182 next_record (dtp
, 1);
3185 /* Transfer function for IOLENGTH. It doesn't actually do any
3186 data transfer, it just updates the length counter. */
3189 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3190 void *dest
__attribute__ ((unused
)),
3191 int kind
__attribute__((unused
)),
3192 size_t size
, size_t nelems
)
3194 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3195 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3199 /* Initialize the IOLENGTH data transfer. This function is in essence
3200 a very much simplified version of data_transfer_init(), because it
3201 doesn't have to deal with units at all. */
3204 iolength_transfer_init (st_parameter_dt
*dtp
)
3206 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3209 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3211 /* Set up the subroutine that will handle the transfers. */
3213 dtp
->u
.p
.transfer
= iolength_transfer
;
3217 /* Library entry point for the IOLENGTH form of the INQUIRE
3218 statement. The IOLENGTH form requires no I/O to be performed, but
3219 it must still be a runtime library call so that we can determine
3220 the iolength for dynamic arrays and such. */
3222 extern void st_iolength (st_parameter_dt
*);
3223 export_proto(st_iolength
);
3226 st_iolength (st_parameter_dt
*dtp
)
3228 library_start (&dtp
->common
);
3229 iolength_transfer_init (dtp
);
3232 extern void st_iolength_done (st_parameter_dt
*);
3233 export_proto(st_iolength_done
);
3236 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3243 /* The READ statement. */
3245 extern void st_read (st_parameter_dt
*);
3246 export_proto(st_read
);
3249 st_read (st_parameter_dt
*dtp
)
3251 library_start (&dtp
->common
);
3253 data_transfer_init (dtp
, 1);
3256 extern void st_read_done (st_parameter_dt
*);
3257 export_proto(st_read_done
);
3260 st_read_done (st_parameter_dt
*dtp
)
3262 finalize_transfer (dtp
);
3263 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3264 free_format_data (dtp
->u
.p
.fmt
);
3266 if (dtp
->u
.p
.current_unit
!= NULL
)
3267 unlock_unit (dtp
->u
.p
.current_unit
);
3269 free_internal_unit (dtp
);
3274 extern void st_write (st_parameter_dt
*);
3275 export_proto(st_write
);
3278 st_write (st_parameter_dt
*dtp
)
3280 library_start (&dtp
->common
);
3281 data_transfer_init (dtp
, 0);
3284 extern void st_write_done (st_parameter_dt
*);
3285 export_proto(st_write_done
);
3288 st_write_done (st_parameter_dt
*dtp
)
3290 finalize_transfer (dtp
);
3292 /* Deal with endfile conditions associated with sequential files. */
3294 if (dtp
->u
.p
.current_unit
!= NULL
3295 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3296 switch (dtp
->u
.p
.current_unit
->endfile
)
3298 case AT_ENDFILE
: /* Remain at the endfile record. */
3302 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3306 /* Get rid of whatever is after this record. */
3307 if (!is_internal_unit (dtp
))
3308 unit_truncate (dtp
->u
.p
.current_unit
,
3309 stell (dtp
->u
.p
.current_unit
->s
),
3311 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3315 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3316 free_format_data (dtp
->u
.p
.fmt
);
3318 if (dtp
->u
.p
.current_unit
!= NULL
)
3319 unlock_unit (dtp
->u
.p
.current_unit
);
3321 free_internal_unit (dtp
);
3327 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3329 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3334 /* Receives the scalar information for namelist objects and stores it
3335 in a linked list of namelist_info types. */
3337 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3338 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3339 export_proto(st_set_nml_var
);
3343 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3344 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3345 GFC_INTEGER_4 dtype
)
3347 namelist_info
*t1
= NULL
;
3349 size_t var_name_len
= strlen (var_name
);
3351 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3353 nml
->mem_pos
= var_addr
;
3355 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3356 memcpy (nml
->var_name
, var_name
, var_name_len
);
3357 nml
->var_name
[var_name_len
] = '\0';
3359 nml
->len
= (int) len
;
3360 nml
->string_length
= (index_type
) string_length
;
3362 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3363 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3364 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3366 if (nml
->var_rank
> 0)
3368 nml
->dim
= (descriptor_dimension
*)
3369 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3370 nml
->ls
= (array_loop_spec
*)
3371 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3381 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3383 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3384 dtp
->u
.p
.ionml
= nml
;
3388 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3393 /* Store the dimensional information for the namelist object. */
3394 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3395 index_type
, index_type
,
3397 export_proto(st_set_nml_var_dim
);
3400 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3401 index_type stride
, index_type lbound
,
3404 namelist_info
* nml
;
3409 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3411 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3414 /* Reverse memcpy - used for byte swapping. */
3416 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3422 s
= (char *) src
+ n
- 1;
3424 /* Write with ascending order - this is likely faster
3425 on modern architectures because of write combining. */
3431 /* Once upon a time, a poor innocent Fortran program was reading a
3432 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3433 the OS doesn't tell whether we're at the EOF or whether we already
3434 went past it. Luckily our hero, libgfortran, keeps track of this.
3435 Call this function when you detect an EOF condition. See Section
3439 hit_eof (st_parameter_dt
* dtp
)
3441 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3443 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3444 switch (dtp
->u
.p
.current_unit
->endfile
)
3448 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3449 if (!is_internal_unit (dtp
))
3451 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3452 dtp
->u
.p
.current_unit
->current_record
= 0;
3455 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3459 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3460 dtp
->u
.p
.current_unit
->current_record
= 0;
3465 /* Non-sequential files don't have an ENDFILE record, so we
3466 can't be at AFTER_ENDFILE. */
3467 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3468 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3469 dtp
->u
.p
.current_unit
->current_record
= 0;