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. */
237 /* If we see an EOR during non-advancing I/O, we need to skip
238 the rest of the I/O statement. Set the corresponding flag. */
239 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
240 dtp
->u
.p
.eor_condition
= 1;
242 /* If we encounter a CR, it might be a CRLF. */
243 if (q
== '\r') /* Probably a CRLF */
245 if (n
< *length
&& *(p
+ 1) == '\n')
246 dtp
->u
.p
.sf_seen_eor
= 2;
249 dtp
->u
.p
.sf_seen_eor
= 1;
251 /* Without padding, terminate the I/O statement without assigning
252 the value. With padding, the value still needs to be assigned,
253 so we can just continue with a short read. */
254 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
)
256 if (likely (no_error
))
258 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
265 /* Short circuit the read if a comma is found during numeric input.
266 The flag is set to zero during character reads so that commas in
267 strings are not ignored */
269 if (dtp
->u
.p
.sf_read_comma
== 1)
272 notify_std (&dtp
->common
, GFC_STD_GNU
,
273 "Comma in formatted numeric read.");
282 fbuf_seek (dtp
->u
.p
.current_unit
, n
+ dtp
->u
.p
.sf_seen_eor
+ seen_comma
,
285 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
286 some other stuff. Set the relevant flags. */
287 if (lorig
> *length
&& !dtp
->u
.p
.sf_seen_eor
&& !seen_comma
)
300 dtp
->u
.p
.current_unit
->bytes_left
-= n
;
302 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
303 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) n
;
309 /* Function for reading the next couple of bytes from the current
310 file, advancing the current position. We return FAILURE on end of record or
311 end of file. This function is only for formatted I/O, unformatted uses
314 If the read is short, then it is because the current record does not
315 have enough data to satisfy the read request and the file was
316 opened with PAD=YES. The caller must assume tailing spaces for
320 read_block_form (st_parameter_dt
*dtp
, int * nbytes
)
325 if (!is_stream_io (dtp
))
327 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
329 /* For preconnected units with default record length, set bytes left
330 to unit record length and proceed, otherwise error. */
331 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
332 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
333 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
336 if (unlikely (dtp
->u
.p
.current_unit
->pad_status
== PAD_NO
))
338 /* Not enough data left. */
339 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
344 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
== 0))
350 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
354 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
355 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
356 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
358 source
= read_sf (dtp
, nbytes
, 0);
359 dtp
->u
.p
.current_unit
->strm_pos
+=
360 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
364 /* If we reach here, we can assume it's direct access. */
366 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
369 source
= fbuf_read (dtp
->u
.p
.current_unit
, nbytes
);
370 fbuf_seek (dtp
->u
.p
.current_unit
, *nbytes
, SEEK_CUR
);
372 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
373 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) *nbytes
;
375 if (norig
!= *nbytes
)
377 /* Short read, this shouldn't happen. */
378 if (!dtp
->u
.p
.current_unit
->pad_status
== PAD_YES
)
380 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
385 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) *nbytes
;
391 /* Reads a block directly into application data space. This is for
392 unformatted files. */
395 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
397 ssize_t to_read_record
;
398 ssize_t have_read_record
;
399 ssize_t to_read_subrecord
;
400 ssize_t have_read_subrecord
;
403 if (is_stream_io (dtp
))
405 have_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
,
407 if (unlikely (have_read_record
< 0))
409 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
413 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
415 if (unlikely ((ssize_t
) nbytes
!= have_read_record
))
417 /* Short read, e.g. if we hit EOF. For stream files,
418 we have to set the end-of-file condition. */
424 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
426 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
429 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
430 nbytes
= to_read_record
;
435 to_read_record
= nbytes
;
438 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
440 to_read_record
= sread (dtp
->u
.p
.current_unit
->s
, buf
, to_read_record
);
441 if (unlikely (to_read_record
< 0))
443 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
447 if (to_read_record
!= (ssize_t
) nbytes
)
449 /* Short read, e.g. if we hit EOF. Apparently, we read
450 more than was written to the last record. */
454 if (unlikely (short_record
))
456 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
461 /* Unformatted sequential. We loop over the subrecords, reading
462 until the request has been fulfilled or the record has run out
463 of continuation subrecords. */
465 /* Check whether we exceed the total record length. */
467 if (dtp
->u
.p
.current_unit
->flags
.has_recl
468 && ((gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
))
470 to_read_record
= dtp
->u
.p
.current_unit
->bytes_left
;
475 to_read_record
= nbytes
;
478 have_read_record
= 0;
482 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
483 < (gfc_offset
) to_read_record
)
485 to_read_subrecord
= dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
486 to_read_record
-= to_read_subrecord
;
490 to_read_subrecord
= to_read_record
;
494 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
496 have_read_subrecord
= sread (dtp
->u
.p
.current_unit
->s
,
497 buf
+ have_read_record
, to_read_subrecord
);
498 if (unlikely (have_read_subrecord
) < 0)
500 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
504 have_read_record
+= have_read_subrecord
;
506 if (unlikely (to_read_subrecord
!= have_read_subrecord
))
509 /* Short read, e.g. if we hit EOF. This means the record
510 structure has been corrupted, or the trailing record
511 marker would still be present. */
513 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
517 if (to_read_record
> 0)
519 if (likely (dtp
->u
.p
.current_unit
->continued
))
521 next_record_r_unf (dtp
, 0);
526 /* Let's make sure the file position is correctly pre-positioned
527 for the next read statement. */
529 dtp
->u
.p
.current_unit
->current_record
= 0;
530 next_record_r_unf (dtp
, 0);
531 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
537 /* Normal exit, the read request has been fulfilled. */
542 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
543 if (unlikely (short_record
))
545 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
552 /* Function for writing a block of bytes to the current file at the
553 current position, advancing the file pointer. We are given a length
554 and return a pointer to a buffer that the caller must (completely)
555 fill in. Returns NULL on error. */
558 write_block (st_parameter_dt
*dtp
, int length
)
562 if (!is_stream_io (dtp
))
564 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
566 /* For preconnected units with default record length, set bytes left
567 to unit record length and proceed, otherwise error. */
568 if (likely ((dtp
->u
.p
.current_unit
->unit_number
569 == options
.stdout_unit
570 || dtp
->u
.p
.current_unit
->unit_number
571 == options
.stderr_unit
)
572 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
))
573 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
576 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
581 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
584 if (is_internal_unit (dtp
))
586 dest
= mem_alloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
590 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
594 if (unlikely (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
))
595 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
599 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
602 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
607 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
608 dtp
->u
.p
.size_used
+= (GFC_IO_INT
) length
;
610 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
616 /* High level interface to swrite(), taking care of errors. This is only
617 called for unformatted files. There are three cases to consider:
618 Stream I/O, unformatted direct, unformatted sequential. */
621 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
624 ssize_t have_written
;
625 ssize_t to_write_subrecord
;
630 if (is_stream_io (dtp
))
632 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
633 if (unlikely (have_written
< 0))
635 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
639 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
644 /* Unformatted direct access. */
646 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
648 if (unlikely (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
))
650 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
654 if (buf
== NULL
&& nbytes
== 0)
657 have_written
= swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
);
658 if (unlikely (have_written
< 0))
660 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
664 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_written
;
665 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) have_written
;
670 /* Unformatted sequential. */
674 if (dtp
->u
.p
.current_unit
->flags
.has_recl
675 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
677 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
689 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
690 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
692 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
693 (gfc_offset
) to_write_subrecord
;
695 to_write_subrecord
= swrite (dtp
->u
.p
.current_unit
->s
,
696 buf
+ have_written
, to_write_subrecord
);
697 if (unlikely (to_write_subrecord
< 0))
699 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
703 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
704 nbytes
-= to_write_subrecord
;
705 have_written
+= to_write_subrecord
;
710 next_record_w_unf (dtp
, 1);
713 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
714 if (unlikely (short_record
))
716 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
723 /* Master function for unformatted reads. */
726 unformatted_read (st_parameter_dt
*dtp
, bt type
,
727 void *dest
, int kind
, size_t size
, size_t nelems
)
729 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
732 if (type
== BT_CHARACTER
)
733 size
*= GFC_SIZE_OF_CHAR_KIND(kind
);
734 read_block_direct (dtp
, dest
, size
* nelems
);
744 /* Handle wide chracters. */
745 if (type
== BT_CHARACTER
&& kind
!= 1)
751 /* Break up complex into its constituent reals. */
752 if (type
== BT_COMPLEX
)
758 /* By now, all complex variables have been split into their
759 constituent reals. */
761 for (i
= 0; i
< nelems
; i
++)
763 read_block_direct (dtp
, buffer
, size
);
764 reverse_memcpy (p
, buffer
, size
);
771 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
772 bytes on 64 bit machines. The unused bytes are not initialized and never
773 used, which can show an error with memory checking analyzers like
777 unformatted_write (st_parameter_dt
*dtp
, bt type
,
778 void *source
, int kind
, size_t size
, size_t nelems
)
780 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
783 size_t stride
= type
== BT_CHARACTER
?
784 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
786 write_buf (dtp
, source
, stride
* nelems
);
796 /* Handle wide chracters. */
797 if (type
== BT_CHARACTER
&& kind
!= 1)
803 /* Break up complex into its constituent reals. */
804 if (type
== BT_COMPLEX
)
810 /* By now, all complex variables have been split into their
811 constituent reals. */
813 for (i
= 0; i
< nelems
; i
++)
815 reverse_memcpy(buffer
, p
, size
);
817 write_buf (dtp
, buffer
, size
);
823 /* Return a pointer to the name of a type. */
848 internal_error (NULL
, "type_name(): Bad type");
855 /* Write a constant string to the output.
856 This is complicated because the string can have doubled delimiters
857 in it. The length in the format node is the true length. */
860 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
862 char c
, delimiter
, *p
, *q
;
865 length
= f
->u
.string
.length
;
869 p
= write_block (dtp
, length
);
876 for (; length
> 0; length
--)
879 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
880 q
++; /* Skip the doubled delimiter. */
885 /* Given actual and expected types in a formatted data transfer, make
886 sure they agree. If not, an error message is generated. Returns
887 nonzero if something went wrong. */
890 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
894 if (actual
== expected
)
897 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
898 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
900 format_error (dtp
, f
, buffer
);
905 /* This function is in the main loop for a formatted data transfer
906 statement. It would be natural to implement this as a coroutine
907 with the user program, but C makes that awkward. We loop,
908 processing format elements. When we actually have to transfer
909 data instead of just setting flags, we return control to the user
910 program which calls a function that supplies the address and type
911 of the next element, then comes back here to process it. */
914 formatted_transfer_scalar_read (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
921 int consume_data_flag
;
923 /* Change a complex data item into a pair of reals. */
925 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
926 if (type
== BT_COMPLEX
)
932 /* If there's an EOR condition, we simulate finalizing the transfer
934 if (dtp
->u
.p
.eor_condition
)
937 /* Set this flag so that commas in reads cause the read to complete before
938 the entire field has been read. The next read field will start right after
939 the comma in the stream. (Set to 0 for character reads). */
940 dtp
->u
.p
.sf_read_comma
=
941 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
945 /* If reversion has occurred and there is another real data item,
946 then we have to move to the next record. */
947 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
949 dtp
->u
.p
.reversion_flag
= 0;
950 next_record (dtp
, 0);
953 consume_data_flag
= 1;
954 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
957 f
= next_format (dtp
);
960 /* No data descriptors left. */
961 if (unlikely (n
> 0))
962 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
963 "Insufficient data descriptors in format after reversion");
969 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
970 - dtp
->u
.p
.current_unit
->bytes_left
);
972 if (is_stream_io(dtp
))
980 if (require_type (dtp
, BT_INTEGER
, type
, f
))
982 read_decimal (dtp
, f
, p
, kind
);
988 if (compile_options
.allow_std
< GFC_STD_GNU
989 && require_type (dtp
, BT_INTEGER
, type
, f
))
991 read_radix (dtp
, f
, p
, kind
, 2);
997 if (compile_options
.allow_std
< GFC_STD_GNU
998 && require_type (dtp
, BT_INTEGER
, type
, f
))
1000 read_radix (dtp
, f
, p
, kind
, 8);
1005 goto need_read_data
;
1006 if (compile_options
.allow_std
< GFC_STD_GNU
1007 && require_type (dtp
, BT_INTEGER
, type
, f
))
1009 read_radix (dtp
, f
, p
, kind
, 16);
1014 goto need_read_data
;
1016 /* It is possible to have FMT_A with something not BT_CHARACTER such
1017 as when writing out hollerith strings, so check both type
1018 and kind before calling wide character routines. */
1019 if (type
== BT_CHARACTER
&& kind
== 4)
1020 read_a_char4 (dtp
, f
, p
, size
);
1022 read_a (dtp
, f
, p
, size
);
1027 goto need_read_data
;
1028 read_l (dtp
, f
, p
, kind
);
1033 goto need_read_data
;
1034 if (require_type (dtp
, BT_REAL
, type
, f
))
1036 read_f (dtp
, f
, p
, kind
);
1041 goto need_read_data
;
1042 if (require_type (dtp
, BT_REAL
, type
, f
))
1044 read_f (dtp
, f
, p
, kind
);
1049 goto need_read_data
;
1050 if (require_type (dtp
, BT_REAL
, type
, f
))
1052 read_f (dtp
, f
, p
, kind
);
1057 goto need_read_data
;
1058 if (require_type (dtp
, BT_REAL
, type
, f
))
1060 read_f (dtp
, f
, p
, kind
);
1065 goto need_read_data
;
1066 if (require_type (dtp
, BT_REAL
, type
, f
))
1068 read_f (dtp
, f
, p
, kind
);
1073 goto need_read_data
;
1077 read_decimal (dtp
, f
, p
, kind
);
1080 read_l (dtp
, f
, p
, kind
);
1084 read_a_char4 (dtp
, f
, p
, size
);
1086 read_a (dtp
, f
, p
, size
);
1089 read_f (dtp
, f
, p
, kind
);
1092 internal_error (&dtp
->common
, "formatted_transfer(): Bad type");
1097 consume_data_flag
= 0;
1098 format_error (dtp
, f
, "Constant string in input format");
1101 /* Format codes that don't transfer data. */
1104 consume_data_flag
= 0;
1105 dtp
->u
.p
.skips
+= f
->u
.n
;
1106 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1107 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1108 read_x (dtp
, f
->u
.n
);
1113 consume_data_flag
= 0;
1115 if (f
->format
== FMT_TL
)
1117 /* Handle the special case when no bytes have been used yet.
1118 Cannot go below zero. */
1119 if (bytes_used
== 0)
1121 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1122 dtp
->u
.p
.skips
-= f
->u
.n
;
1123 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1126 pos
= bytes_used
- f
->u
.n
;
1131 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1132 left tab limit. We do not check if the position has gone
1133 beyond the end of record because a subsequent tab could
1134 bring us back again. */
1135 pos
= pos
< 0 ? 0 : pos
;
1137 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1138 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1139 + pos
- dtp
->u
.p
.max_pos
;
1140 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1141 ? 0 : dtp
->u
.p
.pending_spaces
;
1142 if (dtp
->u
.p
.skips
== 0)
1145 /* Adjust everything for end-of-record condition */
1146 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1148 dtp
->u
.p
.current_unit
->bytes_left
-= dtp
->u
.p
.sf_seen_eor
;
1149 dtp
->u
.p
.skips
-= dtp
->u
.p
.sf_seen_eor
;
1151 dtp
->u
.p
.sf_seen_eor
= 0;
1153 if (dtp
->u
.p
.skips
< 0)
1155 if (is_internal_unit (dtp
))
1156 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1158 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1159 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1160 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1163 read_x (dtp
, dtp
->u
.p
.skips
);
1167 consume_data_flag
= 0;
1168 dtp
->u
.p
.sign_status
= SIGN_S
;
1172 consume_data_flag
= 0;
1173 dtp
->u
.p
.sign_status
= SIGN_SS
;
1177 consume_data_flag
= 0;
1178 dtp
->u
.p
.sign_status
= SIGN_SP
;
1182 consume_data_flag
= 0 ;
1183 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1187 consume_data_flag
= 0;
1188 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1192 consume_data_flag
= 0;
1193 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1197 consume_data_flag
= 0;
1198 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1202 consume_data_flag
= 0;
1203 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1207 consume_data_flag
= 0;
1208 dtp
->u
.p
.seen_dollar
= 1;
1212 consume_data_flag
= 0;
1213 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1214 next_record (dtp
, 0);
1218 /* A colon descriptor causes us to exit this loop (in
1219 particular preventing another / descriptor from being
1220 processed) unless there is another data item to be
1222 consume_data_flag
= 0;
1228 internal_error (&dtp
->common
, "Bad format node");
1231 /* Adjust the item count and data pointer. */
1233 if ((consume_data_flag
> 0) && (n
> 0))
1236 p
= ((char *) p
) + size
;
1241 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1242 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1247 /* Come here when we need a data descriptor but don't have one. We
1248 push the current format node back onto the input, then return and
1249 let the user program call us back with the data. */
1251 unget_format (dtp
, f
);
1256 formatted_transfer_scalar_write (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1259 int pos
, bytes_used
;
1263 int consume_data_flag
;
1265 /* Change a complex data item into a pair of reals. */
1267 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
1268 if (type
== BT_COMPLEX
)
1274 /* If there's an EOR condition, we simulate finalizing the transfer
1275 by doing nothing. */
1276 if (dtp
->u
.p
.eor_condition
)
1279 /* Set this flag so that commas in reads cause the read to complete before
1280 the entire field has been read. The next read field will start right after
1281 the comma in the stream. (Set to 0 for character reads). */
1282 dtp
->u
.p
.sf_read_comma
=
1283 dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_COMMA
? 0 : 1;
1287 /* If reversion has occurred and there is another real data item,
1288 then we have to move to the next record. */
1289 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
1291 dtp
->u
.p
.reversion_flag
= 0;
1292 next_record (dtp
, 0);
1295 consume_data_flag
= 1;
1296 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1299 f
= next_format (dtp
);
1302 /* No data descriptors left. */
1303 if (unlikely (n
> 0))
1304 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
1305 "Insufficient data descriptors in format after reversion");
1309 /* Now discharge T, TR and X movements to the right. This is delayed
1310 until a data producing format to suppress trailing spaces. */
1313 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
1314 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
1315 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
1316 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
1317 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
1318 || t
== FMT_STRING
))
1320 if (dtp
->u
.p
.skips
> 0)
1323 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1324 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1325 - dtp
->u
.p
.current_unit
->bytes_left
);
1327 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1329 if (dtp
->u
.p
.skips
< 0)
1331 if (is_internal_unit (dtp
))
1332 sseek (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
, SEEK_CUR
);
1334 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
, SEEK_CUR
);
1335 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1337 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1340 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1341 - dtp
->u
.p
.current_unit
->bytes_left
);
1343 if (is_stream_io(dtp
))
1351 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1353 write_i (dtp
, f
, p
, kind
);
1359 if (compile_options
.allow_std
< GFC_STD_GNU
1360 && require_type (dtp
, BT_INTEGER
, type
, f
))
1362 write_b (dtp
, f
, p
, kind
);
1368 if (compile_options
.allow_std
< GFC_STD_GNU
1369 && require_type (dtp
, BT_INTEGER
, type
, f
))
1371 write_o (dtp
, f
, p
, kind
);
1377 if (compile_options
.allow_std
< GFC_STD_GNU
1378 && require_type (dtp
, BT_INTEGER
, type
, f
))
1380 write_z (dtp
, f
, p
, kind
);
1387 /* It is possible to have FMT_A with something not BT_CHARACTER such
1388 as when writing out hollerith strings, so check both type
1389 and kind before calling wide character routines. */
1390 if (type
== BT_CHARACTER
&& kind
== 4)
1391 write_a_char4 (dtp
, f
, p
, size
);
1393 write_a (dtp
, f
, p
, size
);
1399 write_l (dtp
, f
, p
, kind
);
1405 if (require_type (dtp
, BT_REAL
, type
, f
))
1407 write_d (dtp
, f
, p
, kind
);
1413 if (require_type (dtp
, BT_REAL
, type
, f
))
1415 write_e (dtp
, f
, p
, kind
);
1421 if (require_type (dtp
, BT_REAL
, type
, f
))
1423 write_en (dtp
, f
, p
, kind
);
1429 if (require_type (dtp
, BT_REAL
, type
, f
))
1431 write_es (dtp
, f
, p
, kind
);
1437 if (require_type (dtp
, BT_REAL
, type
, f
))
1439 write_f (dtp
, f
, p
, kind
);
1448 write_i (dtp
, f
, p
, kind
);
1451 write_l (dtp
, f
, p
, kind
);
1455 write_a_char4 (dtp
, f
, p
, size
);
1457 write_a (dtp
, f
, p
, size
);
1460 if (f
->u
.real
.w
== 0)
1461 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1463 write_d (dtp
, f
, p
, kind
);
1466 internal_error (&dtp
->common
,
1467 "formatted_transfer(): Bad type");
1472 consume_data_flag
= 0;
1473 write_constant_string (dtp
, f
);
1476 /* Format codes that don't transfer data. */
1479 consume_data_flag
= 0;
1481 dtp
->u
.p
.skips
+= f
->u
.n
;
1482 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1483 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1484 /* Writes occur just before the switch on f->format, above, so
1485 that trailing blanks are suppressed, unless we are doing a
1486 non-advancing write in which case we want to output the blanks
1488 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1490 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1491 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1497 consume_data_flag
= 0;
1499 if (f
->format
== FMT_TL
)
1502 /* Handle the special case when no bytes have been used yet.
1503 Cannot go below zero. */
1504 if (bytes_used
== 0)
1506 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1507 dtp
->u
.p
.skips
-= f
->u
.n
;
1508 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1511 pos
= bytes_used
- f
->u
.n
;
1514 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1516 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1517 left tab limit. We do not check if the position has gone
1518 beyond the end of record because a subsequent tab could
1519 bring us back again. */
1520 pos
= pos
< 0 ? 0 : pos
;
1522 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1523 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1524 + pos
- dtp
->u
.p
.max_pos
;
1525 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1526 ? 0 : dtp
->u
.p
.pending_spaces
;
1530 consume_data_flag
= 0;
1531 dtp
->u
.p
.sign_status
= SIGN_S
;
1535 consume_data_flag
= 0;
1536 dtp
->u
.p
.sign_status
= SIGN_SS
;
1540 consume_data_flag
= 0;
1541 dtp
->u
.p
.sign_status
= SIGN_SP
;
1545 consume_data_flag
= 0 ;
1546 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1550 consume_data_flag
= 0;
1551 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1555 consume_data_flag
= 0;
1556 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_COMMA
;
1560 consume_data_flag
= 0;
1561 dtp
->u
.p
.current_unit
->decimal_status
= DECIMAL_POINT
;
1565 consume_data_flag
= 0;
1566 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1570 consume_data_flag
= 0;
1571 dtp
->u
.p
.seen_dollar
= 1;
1575 consume_data_flag
= 0;
1576 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1577 next_record (dtp
, 0);
1581 /* A colon descriptor causes us to exit this loop (in
1582 particular preventing another / descriptor from being
1583 processed) unless there is another data item to be
1585 consume_data_flag
= 0;
1591 internal_error (&dtp
->common
, "Bad format node");
1594 /* Adjust the item count and data pointer. */
1596 if ((consume_data_flag
> 0) && (n
> 0))
1599 p
= ((char *) p
) + size
;
1602 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1603 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1608 /* Come here when we need a data descriptor but don't have one. We
1609 push the current format node back onto the input, then return and
1610 let the user program call us back with the data. */
1612 unget_format (dtp
, f
);
1617 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1618 size_t size
, size_t nelems
)
1624 size_t stride
= type
== BT_CHARACTER
?
1625 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1626 if (dtp
->u
.p
.mode
== READING
)
1628 /* Big loop over all the elements. */
1629 for (elem
= 0; elem
< nelems
; elem
++)
1631 dtp
->u
.p
.item_count
++;
1632 formatted_transfer_scalar_read (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1637 /* Big loop over all the elements. */
1638 for (elem
= 0; elem
< nelems
; elem
++)
1640 dtp
->u
.p
.item_count
++;
1641 formatted_transfer_scalar_write (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1647 /* Data transfer entry points. The type of the data entity is
1648 implicit in the subroutine call. This prevents us from having to
1649 share a common enum with the compiler. */
1652 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1654 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1656 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1661 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1664 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1666 size
= size_from_real_kind (kind
);
1667 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1672 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1674 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1676 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1681 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1683 static char *empty_string
[0];
1685 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1688 /* Strings of zero length can have p == NULL, which confuses the
1689 transfer routines into thinking we need more data elements. To avoid
1690 this, we give them a nice pointer. */
1691 if (len
== 0 && p
== NULL
)
1694 /* Set kind here to 1. */
1695 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1699 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1701 static char *empty_string
[0];
1703 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1706 /* Strings of zero length can have p == NULL, which confuses the
1707 transfer routines into thinking we need more data elements. To avoid
1708 this, we give them a nice pointer. */
1709 if (len
== 0 && p
== NULL
)
1712 /* Here we pass the actual kind value. */
1713 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1718 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1721 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1723 size
= size_from_complex_kind (kind
);
1724 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1729 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1730 gfc_charlen_type charlen
)
1732 index_type count
[GFC_MAX_DIMENSIONS
];
1733 index_type extent
[GFC_MAX_DIMENSIONS
];
1734 index_type stride
[GFC_MAX_DIMENSIONS
];
1735 index_type stride0
, rank
, size
, type
, n
;
1740 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1743 type
= GFC_DESCRIPTOR_TYPE (desc
);
1744 size
= GFC_DESCRIPTOR_SIZE (desc
);
1746 /* FIXME: What a kludge: Array descriptors and the IO library use
1747 different enums for types. */
1750 case GFC_DTYPE_UNKNOWN
:
1751 iotype
= BT_NULL
; /* Is this correct? */
1753 case GFC_DTYPE_INTEGER
:
1754 iotype
= BT_INTEGER
;
1756 case GFC_DTYPE_LOGICAL
:
1757 iotype
= BT_LOGICAL
;
1759 case GFC_DTYPE_REAL
:
1762 case GFC_DTYPE_COMPLEX
:
1763 iotype
= BT_COMPLEX
;
1765 case GFC_DTYPE_CHARACTER
:
1766 iotype
= BT_CHARACTER
;
1769 case GFC_DTYPE_DERIVED
:
1770 internal_error (&dtp
->common
,
1771 "Derived type I/O should have been handled via the frontend.");
1774 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1777 rank
= GFC_DESCRIPTOR_RANK (desc
);
1778 for (n
= 0; n
< rank
; n
++)
1781 stride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(desc
,n
);
1782 extent
[n
] = GFC_DESCRIPTOR_EXTENT(desc
,n
);
1784 /* If the extent of even one dimension is zero, then the entire
1785 array section contains zero elements, so we return after writing
1786 a zero array record. */
1791 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1796 stride0
= stride
[0];
1798 /* If the innermost dimension has a stride of 1, we can do the transfer
1799 in contiguous chunks. */
1800 if (stride0
== size
)
1805 data
= GFC_DESCRIPTOR_DATA (desc
);
1809 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1810 data
+= stride0
* tsize
;
1813 while (count
[n
] == extent
[n
])
1816 data
-= stride
[n
] * extent
[n
];
1833 /* Preposition a sequential unformatted file while reading. */
1836 us_read (st_parameter_dt
*dtp
, int continued
)
1843 if (compile_options
.record_marker
== 0)
1844 n
= sizeof (GFC_INTEGER_4
);
1846 n
= compile_options
.record_marker
;
1848 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1849 if (unlikely (nr
< 0))
1851 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1857 return; /* end of file */
1859 else if (unlikely (n
!= nr
))
1861 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1865 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1866 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1870 case sizeof(GFC_INTEGER_4
):
1871 memcpy (&i4
, &i
, sizeof (i4
));
1875 case sizeof(GFC_INTEGER_8
):
1876 memcpy (&i8
, &i
, sizeof (i8
));
1881 runtime_error ("Illegal value for record marker");
1888 case sizeof(GFC_INTEGER_4
):
1889 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1893 case sizeof(GFC_INTEGER_8
):
1894 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1899 runtime_error ("Illegal value for record marker");
1905 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1906 dtp
->u
.p
.current_unit
->continued
= 0;
1910 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1911 dtp
->u
.p
.current_unit
->continued
= 1;
1915 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1919 /* Preposition a sequential unformatted file while writing. This
1920 amount to writing a bogus length that will be filled in later. */
1923 us_write (st_parameter_dt
*dtp
, int continued
)
1930 if (compile_options
.record_marker
== 0)
1931 nbytes
= sizeof (GFC_INTEGER_4
);
1933 nbytes
= compile_options
.record_marker
;
1935 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
1936 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1938 /* For sequential unformatted, if RECL= was not specified in the OPEN
1939 we write until we have more bytes than can fit in the subrecord
1940 markers, then we write a new subrecord. */
1942 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1943 dtp
->u
.p
.current_unit
->recl_subrecord
;
1944 dtp
->u
.p
.current_unit
->continued
= continued
;
1948 /* Position to the next record prior to transfer. We are assumed to
1949 be before the next record. We also calculate the bytes in the next
1953 pre_position (st_parameter_dt
*dtp
)
1955 if (dtp
->u
.p
.current_unit
->current_record
)
1956 return; /* Already positioned. */
1958 switch (current_mode (dtp
))
1960 case FORMATTED_STREAM
:
1961 case UNFORMATTED_STREAM
:
1962 /* There are no records with stream I/O. If the position was specified
1963 data_transfer_init has already positioned the file. If no position
1964 was specified, we continue from where we last left off. I.e.
1965 there is nothing to do here. */
1968 case UNFORMATTED_SEQUENTIAL
:
1969 if (dtp
->u
.p
.mode
== READING
)
1976 case FORMATTED_SEQUENTIAL
:
1977 case FORMATTED_DIRECT
:
1978 case UNFORMATTED_DIRECT
:
1979 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1983 dtp
->u
.p
.current_unit
->current_record
= 1;
1987 /* Initialize things for a data transfer. This code is common for
1988 both reading and writing. */
1991 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1993 unit_flags u_flags
; /* Used for creating a unit if needed. */
1994 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1995 namelist_info
*ionml
;
1997 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1999 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2001 dtp
->u
.p
.ionml
= ionml
;
2002 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2004 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2007 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2008 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2010 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2011 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2012 { /* Open the unit with some default flags. */
2013 st_parameter_open opp
;
2016 if (dtp
->common
.unit
< 0)
2018 close_unit (dtp
->u
.p
.current_unit
);
2019 dtp
->u
.p
.current_unit
= NULL
;
2020 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2021 "Bad unit number in statement");
2024 memset (&u_flags
, '\0', sizeof (u_flags
));
2025 u_flags
.access
= ACCESS_SEQUENTIAL
;
2026 u_flags
.action
= ACTION_READWRITE
;
2028 /* Is it unformatted? */
2029 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2030 | IOPARM_DT_IONML_SET
)))
2031 u_flags
.form
= FORM_UNFORMATTED
;
2033 u_flags
.form
= FORM_UNSPECIFIED
;
2035 u_flags
.delim
= DELIM_UNSPECIFIED
;
2036 u_flags
.blank
= BLANK_UNSPECIFIED
;
2037 u_flags
.pad
= PAD_UNSPECIFIED
;
2038 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2039 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2040 u_flags
.async
= ASYNC_UNSPECIFIED
;
2041 u_flags
.round
= ROUND_UNSPECIFIED
;
2042 u_flags
.sign
= SIGN_UNSPECIFIED
;
2044 u_flags
.status
= STATUS_UNKNOWN
;
2046 conv
= get_unformatted_convert (dtp
->common
.unit
);
2048 if (conv
== GFC_CONVERT_NONE
)
2049 conv
= compile_options
.convert
;
2051 /* We use big_endian, which is 0 on little-endian machines
2052 and 1 on big-endian machines. */
2055 case GFC_CONVERT_NATIVE
:
2056 case GFC_CONVERT_SWAP
:
2059 case GFC_CONVERT_BIG
:
2060 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2063 case GFC_CONVERT_LITTLE
:
2064 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2068 internal_error (&opp
.common
, "Illegal value for CONVERT");
2072 u_flags
.convert
= conv
;
2074 opp
.common
= dtp
->common
;
2075 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2076 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2077 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2078 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2079 if (dtp
->u
.p
.current_unit
== NULL
)
2083 /* Check the action. */
2085 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2087 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2088 "Cannot read from file opened for WRITE");
2092 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2094 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2095 "Cannot write to file opened for READ");
2099 dtp
->u
.p
.first_item
= 1;
2101 /* Check the format. */
2103 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2106 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2107 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2110 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2111 "Format present for UNFORMATTED data transfer");
2115 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2117 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2118 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2119 "A format cannot be specified with a namelist");
2121 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2122 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2124 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2125 "Missing format for FORMATTED data transfer");
2128 if (is_internal_unit (dtp
)
2129 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2131 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2132 "Internal file cannot be accessed by UNFORMATTED "
2137 /* Check the record or position number. */
2139 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2140 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2142 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2143 "Direct access data transfer requires record number");
2147 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2148 && (cf
& IOPARM_DT_HAS_REC
) != 0)
2150 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2151 "Record number not allowed for sequential access "
2156 /* Process the ADVANCE option. */
2158 dtp
->u
.p
.advance_status
2159 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2160 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2161 "Bad ADVANCE parameter in data transfer statement");
2163 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2165 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2167 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2168 "ADVANCE specification conflicts with sequential "
2173 if (is_internal_unit (dtp
))
2175 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2176 "ADVANCE specification conflicts with internal file");
2180 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2181 != IOPARM_DT_HAS_FORMAT
)
2183 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2184 "ADVANCE specification requires an explicit format");
2191 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2193 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2195 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2196 "EOR specification requires an ADVANCE specification "
2201 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2202 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2204 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2205 "SIZE specification requires an ADVANCE "
2206 "specification of NO");
2211 { /* Write constraints. */
2212 if ((cf
& IOPARM_END
) != 0)
2214 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2215 "END specification cannot appear in a write "
2220 if ((cf
& IOPARM_EOR
) != 0)
2222 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2223 "EOR specification cannot appear in a write "
2228 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2230 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2231 "SIZE specification cannot appear in a write "
2237 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2238 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2240 /* Check the decimal mode. */
2241 dtp
->u
.p
.current_unit
->decimal_status
2242 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2243 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2244 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2247 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2248 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2250 /* Check the sign mode. */
2251 dtp
->u
.p
.sign_status
2252 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2253 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2254 "Bad SIGN parameter in data transfer statement");
2256 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2257 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2259 /* Check the blank mode. */
2260 dtp
->u
.p
.blank_status
2261 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2262 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2264 "Bad BLANK parameter in data transfer statement");
2266 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2267 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2269 /* Check the delim mode. */
2270 dtp
->u
.p
.current_unit
->delim_status
2271 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2272 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2273 delim_opt
, "Bad DELIM parameter in data transfer statement");
2275 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2276 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2278 /* Check the pad mode. */
2279 dtp
->u
.p
.current_unit
->pad_status
2280 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2281 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2282 "Bad PAD parameter in data transfer statement");
2284 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2285 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2287 /* Check to see if we might be reading what we wrote before */
2289 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2290 && !is_internal_unit (dtp
))
2292 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2294 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2295 sflush(dtp
->u
.p
.current_unit
->s
);
2298 /* Check the POS= specifier: that it is in range and that it is used with a
2299 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2301 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2303 if (is_stream_io (dtp
))
2308 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2309 "POS=specifier must be positive");
2313 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2315 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2316 "POS=specifier too large");
2320 dtp
->rec
= dtp
->pos
;
2322 if (dtp
->u
.p
.mode
== READING
)
2324 /* Reset the endfile flag; if we hit EOF during reading
2325 we'll set the flag and generate an error at that point
2326 rather than worrying about it here. */
2327 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2330 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2332 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2333 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2335 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2338 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2343 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2344 "POS=specifier not allowed, "
2345 "Try OPEN with ACCESS='stream'");
2351 /* Sanity checks on the record number. */
2352 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2356 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2357 "Record number must be positive");
2361 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2363 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2364 "Record number too large");
2368 /* Make sure format buffer is reset. */
2369 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2370 fbuf_reset (dtp
->u
.p
.current_unit
);
2373 /* Check whether the record exists to be read. Only
2374 a partial record needs to exist. */
2376 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2377 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2379 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2380 "Non-existing record number");
2384 /* Position the file. */
2385 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2386 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2388 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2392 /* TODO: This is required to maintain compatibility between
2393 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2395 if (is_stream_io (dtp
))
2396 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2398 /* TODO: Un-comment this code when ABI changes from 4.3.
2399 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2401 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2402 "Record number not allowed for stream access "
2408 /* Bugware for badly written mixed C-Fortran I/O. */
2409 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2411 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2413 /* Set the maximum position reached from the previous I/O operation. This
2414 could be greater than zero from a previous non-advancing write. */
2415 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2420 /* Set up the subroutine that will handle the transfers. */
2424 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2425 dtp
->u
.p
.transfer
= unformatted_read
;
2428 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2429 dtp
->u
.p
.transfer
= list_formatted_read
;
2431 dtp
->u
.p
.transfer
= formatted_transfer
;
2436 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2437 dtp
->u
.p
.transfer
= unformatted_write
;
2440 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2441 dtp
->u
.p
.transfer
= list_formatted_write
;
2443 dtp
->u
.p
.transfer
= formatted_transfer
;
2447 /* Make sure that we don't do a read after a nonadvancing write. */
2451 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2453 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2454 "Cannot READ after a nonadvancing WRITE");
2460 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2461 dtp
->u
.p
.current_unit
->read_bad
= 1;
2464 /* Start the data transfer if we are doing a formatted transfer. */
2465 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2466 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2467 && dtp
->u
.p
.ionml
== NULL
)
2468 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2471 /* Initialize an array_loop_spec given the array descriptor. The function
2472 returns the index of the last element of the array, and also returns
2473 starting record, where the first I/O goes to (necessary in case of
2474 negative strides). */
2477 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2478 gfc_offset
*start_record
)
2480 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2489 for (i
=0; i
<rank
; i
++)
2491 ls
[i
].idx
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2492 ls
[i
].start
= GFC_DESCRIPTOR_LBOUND(desc
,i
);
2493 ls
[i
].end
= GFC_DESCRIPTOR_UBOUND(desc
,i
);
2494 ls
[i
].step
= GFC_DESCRIPTOR_STRIDE(desc
,i
);
2495 empty
= empty
|| (GFC_DESCRIPTOR_UBOUND(desc
,i
)
2496 < GFC_DESCRIPTOR_LBOUND(desc
,i
));
2498 if (GFC_DESCRIPTOR_STRIDE(desc
,i
) > 0)
2500 index
+= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2501 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2505 index
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2506 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2507 *start_record
-= (GFC_DESCRIPTOR_EXTENT(desc
,i
) - 1)
2508 * GFC_DESCRIPTOR_STRIDE(desc
,i
);
2518 /* Determine the index to the next record in an internal unit array by
2519 by incrementing through the array_loop_spec. */
2522 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2530 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2535 if (ls
[i
].idx
> ls
[i
].end
)
2537 ls
[i
].idx
= ls
[i
].start
;
2543 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2553 /* Skip to the end of the current record, taking care of an optional
2554 record marker of size bytes. If the file is not seekable, we
2555 read chunks of size MAX_READ until we get to the right
2559 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2561 ssize_t rlength
, readb
;
2562 static const ssize_t MAX_READ
= 4096;
2565 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2566 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2569 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2571 /* Direct access files do not generate END conditions,
2573 if (sseek (dtp
->u
.p
.current_unit
->s
,
2574 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2575 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2578 { /* Seek by reading data. */
2579 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2582 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2583 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2585 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2588 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2592 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2599 /* Advance to the next record reading unformatted files, taking
2600 care of subrecords. If complete_record is nonzero, we loop
2601 until all subrecords are cleared. */
2604 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2608 bytes
= compile_options
.record_marker
== 0 ?
2609 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2614 /* Skip over tail */
2616 skip_record (dtp
, bytes
);
2618 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2626 static inline gfc_offset
2627 min_off (gfc_offset a
, gfc_offset b
)
2629 return (a
< b
? a
: b
);
2633 /* Space to the next record for read mode. */
2636 next_record_r (st_parameter_dt
*dtp
)
2643 switch (current_mode (dtp
))
2645 /* No records in unformatted STREAM I/O. */
2646 case UNFORMATTED_STREAM
:
2649 case UNFORMATTED_SEQUENTIAL
:
2650 next_record_r_unf (dtp
, 1);
2651 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2654 case FORMATTED_DIRECT
:
2655 case UNFORMATTED_DIRECT
:
2656 skip_record (dtp
, 0);
2659 case FORMATTED_STREAM
:
2660 case FORMATTED_SEQUENTIAL
:
2661 /* read_sf has already terminated input because of an '\n', or
2663 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2665 dtp
->u
.p
.sf_seen_eor
= 0;
2666 dtp
->u
.p
.at_eof
= 0;
2670 if (is_internal_unit (dtp
))
2672 if (is_array_io (dtp
))
2676 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2679 /* Now seek to this record. */
2680 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2681 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2683 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2686 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2690 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2691 bytes_left
= min_off (bytes_left
,
2692 file_length (dtp
->u
.p
.current_unit
->s
)
2693 - stell (dtp
->u
.p
.current_unit
->s
));
2694 if (sseek (dtp
->u
.p
.current_unit
->s
,
2695 bytes_left
, SEEK_CUR
) < 0)
2697 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2700 dtp
->u
.p
.current_unit
->bytes_left
2701 = dtp
->u
.p
.current_unit
->recl
;
2710 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2714 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2720 if (is_stream_io (dtp
))
2721 dtp
->u
.p
.current_unit
->strm_pos
++;
2732 /* Small utility function to write a record marker, taking care of
2733 byte swapping and of choosing the correct size. */
2736 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2741 char p
[sizeof (GFC_INTEGER_8
)];
2743 if (compile_options
.record_marker
== 0)
2744 len
= sizeof (GFC_INTEGER_4
);
2746 len
= compile_options
.record_marker
;
2748 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2749 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2753 case sizeof (GFC_INTEGER_4
):
2755 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2758 case sizeof (GFC_INTEGER_8
):
2760 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2764 runtime_error ("Illegal value for record marker");
2772 case sizeof (GFC_INTEGER_4
):
2774 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2775 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2778 case sizeof (GFC_INTEGER_8
):
2780 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2781 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2785 runtime_error ("Illegal value for record marker");
2792 /* Position to the next (sub)record in write mode for
2793 unformatted sequential files. */
2796 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2798 gfc_offset m
, m_write
, record_marker
;
2800 /* Bytes written. */
2801 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2802 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2804 /* Write the length tail. If we finish a record containing
2805 subrecords, we write out the negative length. */
2807 if (dtp
->u
.p
.current_unit
->continued
)
2812 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2815 if (compile_options
.record_marker
== 0)
2816 record_marker
= sizeof (GFC_INTEGER_4
);
2818 record_marker
= compile_options
.record_marker
;
2820 /* Seek to the head and overwrite the bogus length with the real
2823 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2832 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2835 /* Seek past the end of the current record. */
2837 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2844 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2850 /* Utility function like memset() but operating on streams. Return
2851 value is same as for POSIX write(). */
2854 sset (stream
* s
, int c
, ssize_t nbyte
)
2856 static const int WRITE_CHUNK
= 256;
2857 char p
[WRITE_CHUNK
];
2858 ssize_t bytes_left
, trans
;
2860 if (nbyte
< WRITE_CHUNK
)
2861 memset (p
, c
, nbyte
);
2863 memset (p
, c
, WRITE_CHUNK
);
2866 while (bytes_left
> 0)
2868 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2869 trans
= swrite (s
, p
, trans
);
2872 bytes_left
-= trans
;
2875 return nbyte
- bytes_left
;
2878 /* Position to the next record in write mode. */
2881 next_record_w (st_parameter_dt
*dtp
, int done
)
2883 gfc_offset m
, record
, max_pos
;
2886 /* Zero counters for X- and T-editing. */
2887 max_pos
= dtp
->u
.p
.max_pos
;
2888 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2890 switch (current_mode (dtp
))
2892 /* No records in unformatted STREAM I/O. */
2893 case UNFORMATTED_STREAM
:
2896 case FORMATTED_DIRECT
:
2897 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2900 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2901 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2902 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2903 dtp
->u
.p
.current_unit
->bytes_left
)
2904 != dtp
->u
.p
.current_unit
->bytes_left
)
2909 case UNFORMATTED_DIRECT
:
2910 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2912 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2913 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
2918 case UNFORMATTED_SEQUENTIAL
:
2919 next_record_w_unf (dtp
, 0);
2920 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2923 case FORMATTED_STREAM
:
2924 case FORMATTED_SEQUENTIAL
:
2926 if (is_internal_unit (dtp
))
2928 if (is_array_io (dtp
))
2932 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2934 /* If the farthest position reached is greater than current
2935 position, adjust the position and set length to pad out
2936 whats left. Otherwise just pad whats left.
2937 (for character array unit) */
2938 m
= dtp
->u
.p
.current_unit
->recl
2939 - dtp
->u
.p
.current_unit
->bytes_left
;
2942 length
= (int) (max_pos
- m
);
2943 if (sseek (dtp
->u
.p
.current_unit
->s
,
2944 length
, SEEK_CUR
) < 0)
2946 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2949 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2952 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
2954 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2958 /* Now that the current record has been padded out,
2959 determine where the next record in the array is. */
2960 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2963 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2965 /* Now seek to this record */
2966 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2968 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2970 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2974 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2980 /* If this is the last call to next_record move to the farthest
2981 position reached and set length to pad out the remainder
2982 of the record. (for character scaler unit) */
2985 m
= dtp
->u
.p
.current_unit
->recl
2986 - dtp
->u
.p
.current_unit
->bytes_left
;
2989 length
= (int) (max_pos
- m
);
2990 if (sseek (dtp
->u
.p
.current_unit
->s
,
2991 length
, SEEK_CUR
) < 0)
2993 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2996 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2999 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3002 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3004 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3016 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3017 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3024 if (is_stream_io (dtp
))
3026 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3027 if (dtp
->u
.p
.current_unit
->strm_pos
3028 < file_length (dtp
->u
.p
.current_unit
->s
))
3029 unit_truncate (dtp
->u
.p
.current_unit
,
3030 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3038 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3043 /* Position to the next record, which means moving to the end of the
3044 current record. This can happen under several different
3045 conditions. If the done flag is not set, we get ready to process
3049 next_record (st_parameter_dt
*dtp
, int done
)
3051 gfc_offset fp
; /* File position. */
3053 dtp
->u
.p
.current_unit
->read_bad
= 0;
3055 if (dtp
->u
.p
.mode
== READING
)
3056 next_record_r (dtp
);
3058 next_record_w (dtp
, done
);
3060 if (!is_stream_io (dtp
))
3062 /* Keep position up to date for INQUIRE */
3064 update_position (dtp
->u
.p
.current_unit
);
3066 dtp
->u
.p
.current_unit
->current_record
= 0;
3067 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3069 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3070 /* Calculate next record, rounding up partial records. */
3071 dtp
->u
.p
.current_unit
->last_record
=
3072 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3073 dtp
->u
.p
.current_unit
->recl
;
3076 dtp
->u
.p
.current_unit
->last_record
++;
3082 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3086 /* Finalize the current data transfer. For a nonadvancing transfer,
3087 this means advancing to the next record. For internal units close the
3088 stream associated with the unit. */
3091 finalize_transfer (st_parameter_dt
*dtp
)
3094 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3096 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3097 *dtp
->size
= dtp
->u
.p
.size_used
;
3099 if (dtp
->u
.p
.eor_condition
)
3101 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3105 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3107 if (dtp
->u
.p
.current_unit
&& current_mode (dtp
) == UNFORMATTED_SEQUENTIAL
)
3108 dtp
->u
.p
.current_unit
->current_record
= 0;
3112 if ((dtp
->u
.p
.ionml
!= NULL
)
3113 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3115 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3116 namelist_read (dtp
);
3118 namelist_write (dtp
);
3121 dtp
->u
.p
.transfer
= NULL
;
3122 if (dtp
->u
.p
.current_unit
== NULL
)
3125 dtp
->u
.p
.eof_jump
= &eof_jump
;
3126 if (setjmp (eof_jump
))
3128 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3132 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3134 finish_list_read (dtp
);
3138 if (dtp
->u
.p
.mode
== WRITING
)
3139 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3140 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3142 if (is_stream_io (dtp
))
3144 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3145 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3146 next_record (dtp
, 1);
3151 dtp
->u
.p
.current_unit
->current_record
= 0;
3153 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3155 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3156 dtp
->u
.p
.seen_dollar
= 0;
3160 /* For non-advancing I/O, save the current maximum position for use in the
3161 next I/O operation if needed. */
3162 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3164 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3165 - dtp
->u
.p
.current_unit
->bytes_left
);
3166 dtp
->u
.p
.current_unit
->saved_pos
=
3167 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3168 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3171 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3172 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3173 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3175 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3177 next_record (dtp
, 1);
3180 /* Transfer function for IOLENGTH. It doesn't actually do any
3181 data transfer, it just updates the length counter. */
3184 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3185 void *dest
__attribute__ ((unused
)),
3186 int kind
__attribute__((unused
)),
3187 size_t size
, size_t nelems
)
3189 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3190 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3194 /* Initialize the IOLENGTH data transfer. This function is in essence
3195 a very much simplified version of data_transfer_init(), because it
3196 doesn't have to deal with units at all. */
3199 iolength_transfer_init (st_parameter_dt
*dtp
)
3201 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3204 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3206 /* Set up the subroutine that will handle the transfers. */
3208 dtp
->u
.p
.transfer
= iolength_transfer
;
3212 /* Library entry point for the IOLENGTH form of the INQUIRE
3213 statement. The IOLENGTH form requires no I/O to be performed, but
3214 it must still be a runtime library call so that we can determine
3215 the iolength for dynamic arrays and such. */
3217 extern void st_iolength (st_parameter_dt
*);
3218 export_proto(st_iolength
);
3221 st_iolength (st_parameter_dt
*dtp
)
3223 library_start (&dtp
->common
);
3224 iolength_transfer_init (dtp
);
3227 extern void st_iolength_done (st_parameter_dt
*);
3228 export_proto(st_iolength_done
);
3231 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3238 /* The READ statement. */
3240 extern void st_read (st_parameter_dt
*);
3241 export_proto(st_read
);
3244 st_read (st_parameter_dt
*dtp
)
3246 library_start (&dtp
->common
);
3248 data_transfer_init (dtp
, 1);
3251 extern void st_read_done (st_parameter_dt
*);
3252 export_proto(st_read_done
);
3255 st_read_done (st_parameter_dt
*dtp
)
3257 finalize_transfer (dtp
);
3258 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3259 free_format_data (dtp
->u
.p
.fmt
);
3261 if (dtp
->u
.p
.current_unit
!= NULL
)
3262 unlock_unit (dtp
->u
.p
.current_unit
);
3264 free_internal_unit (dtp
);
3269 extern void st_write (st_parameter_dt
*);
3270 export_proto(st_write
);
3273 st_write (st_parameter_dt
*dtp
)
3275 library_start (&dtp
->common
);
3276 data_transfer_init (dtp
, 0);
3279 extern void st_write_done (st_parameter_dt
*);
3280 export_proto(st_write_done
);
3283 st_write_done (st_parameter_dt
*dtp
)
3285 finalize_transfer (dtp
);
3287 /* Deal with endfile conditions associated with sequential files. */
3289 if (dtp
->u
.p
.current_unit
!= NULL
3290 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3291 switch (dtp
->u
.p
.current_unit
->endfile
)
3293 case AT_ENDFILE
: /* Remain at the endfile record. */
3297 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3301 /* Get rid of whatever is after this record. */
3302 if (!is_internal_unit (dtp
))
3303 unit_truncate (dtp
->u
.p
.current_unit
,
3304 stell (dtp
->u
.p
.current_unit
->s
),
3306 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3310 if (is_internal_unit (dtp
) || dtp
->u
.p
.format_not_saved
)
3311 free_format_data (dtp
->u
.p
.fmt
);
3313 if (dtp
->u
.p
.current_unit
!= NULL
)
3314 unlock_unit (dtp
->u
.p
.current_unit
);
3316 free_internal_unit (dtp
);
3322 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3324 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3329 /* Receives the scalar information for namelist objects and stores it
3330 in a linked list of namelist_info types. */
3332 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3333 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3334 export_proto(st_set_nml_var
);
3338 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3339 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3340 GFC_INTEGER_4 dtype
)
3342 namelist_info
*t1
= NULL
;
3344 size_t var_name_len
= strlen (var_name
);
3346 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3348 nml
->mem_pos
= var_addr
;
3350 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3351 memcpy (nml
->var_name
, var_name
, var_name_len
);
3352 nml
->var_name
[var_name_len
] = '\0';
3354 nml
->len
= (int) len
;
3355 nml
->string_length
= (index_type
) string_length
;
3357 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3358 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3359 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3361 if (nml
->var_rank
> 0)
3363 nml
->dim
= (descriptor_dimension
*)
3364 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3365 nml
->ls
= (array_loop_spec
*)
3366 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3376 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3378 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3379 dtp
->u
.p
.ionml
= nml
;
3383 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3388 /* Store the dimensional information for the namelist object. */
3389 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3390 index_type
, index_type
,
3392 export_proto(st_set_nml_var_dim
);
3395 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3396 index_type stride
, index_type lbound
,
3399 namelist_info
* nml
;
3404 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3406 GFC_DIMENSION_SET(nml
->dim
[n
],lbound
,ubound
,stride
);
3409 /* Reverse memcpy - used for byte swapping. */
3411 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3417 s
= (char *) src
+ n
- 1;
3419 /* Write with ascending order - this is likely faster
3420 on modern architectures because of write combining. */
3426 /* Once upon a time, a poor innocent Fortran program was reading a
3427 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3428 the OS doesn't tell whether we're at the EOF or whether we already
3429 went past it. Luckily our hero, libgfortran, keeps track of this.
3430 Call this function when you detect an EOF condition. See Section
3434 hit_eof (st_parameter_dt
* dtp
)
3436 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3438 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3439 switch (dtp
->u
.p
.current_unit
->endfile
)
3443 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3444 if (!is_internal_unit (dtp
))
3446 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3447 dtp
->u
.p
.current_unit
->current_record
= 0;
3450 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3454 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3455 dtp
->u
.p
.current_unit
->current_record
= 0;
3460 /* Non-sequential files don't have an ENDFILE record, so we
3461 can't be at AFTER_ENDFILE. */
3462 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3463 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3464 dtp
->u
.p
.current_unit
->current_record
= 0;