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
] = iotype
== BT_CHARACTER
?
1782 desc
->dim
[n
].stride
* GFC_SIZE_OF_CHAR_KIND(kind
) :
1783 desc
->dim
[n
].stride
;
1784 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1786 /* If the extent of even one dimension is zero, then the entire
1787 array section contains zero elements, so we return after writing
1788 a zero array record. */
1793 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1798 stride0
= stride
[0];
1800 /* If the innermost dimension has stride 1, we can do the transfer
1801 in contiguous chunks. */
1807 data
= GFC_DESCRIPTOR_DATA (desc
);
1811 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1812 data
+= stride0
* size
* tsize
;
1815 while (count
[n
] == extent
[n
])
1818 data
-= stride
[n
] * extent
[n
] * size
;
1828 data
+= stride
[n
] * size
;
1835 /* Preposition a sequential unformatted file while reading. */
1838 us_read (st_parameter_dt
*dtp
, int continued
)
1845 if (compile_options
.record_marker
== 0)
1846 n
= sizeof (GFC_INTEGER_4
);
1848 n
= compile_options
.record_marker
;
1850 nr
= sread (dtp
->u
.p
.current_unit
->s
, &i
, n
);
1851 if (unlikely (nr
< 0))
1853 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1859 return; /* end of file */
1861 else if (unlikely (n
!= nr
))
1863 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1867 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1868 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
1872 case sizeof(GFC_INTEGER_4
):
1873 memcpy (&i4
, &i
, sizeof (i4
));
1877 case sizeof(GFC_INTEGER_8
):
1878 memcpy (&i8
, &i
, sizeof (i8
));
1883 runtime_error ("Illegal value for record marker");
1890 case sizeof(GFC_INTEGER_4
):
1891 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1895 case sizeof(GFC_INTEGER_8
):
1896 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1901 runtime_error ("Illegal value for record marker");
1907 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1908 dtp
->u
.p
.current_unit
->continued
= 0;
1912 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1913 dtp
->u
.p
.current_unit
->continued
= 1;
1917 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1921 /* Preposition a sequential unformatted file while writing. This
1922 amount to writing a bogus length that will be filled in later. */
1925 us_write (st_parameter_dt
*dtp
, int continued
)
1932 if (compile_options
.record_marker
== 0)
1933 nbytes
= sizeof (GFC_INTEGER_4
);
1935 nbytes
= compile_options
.record_marker
;
1937 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, nbytes
) != nbytes
)
1938 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1940 /* For sequential unformatted, if RECL= was not specified in the OPEN
1941 we write until we have more bytes than can fit in the subrecord
1942 markers, then we write a new subrecord. */
1944 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1945 dtp
->u
.p
.current_unit
->recl_subrecord
;
1946 dtp
->u
.p
.current_unit
->continued
= continued
;
1950 /* Position to the next record prior to transfer. We are assumed to
1951 be before the next record. We also calculate the bytes in the next
1955 pre_position (st_parameter_dt
*dtp
)
1957 if (dtp
->u
.p
.current_unit
->current_record
)
1958 return; /* Already positioned. */
1960 switch (current_mode (dtp
))
1962 case FORMATTED_STREAM
:
1963 case UNFORMATTED_STREAM
:
1964 /* There are no records with stream I/O. If the position was specified
1965 data_transfer_init has already positioned the file. If no position
1966 was specified, we continue from where we last left off. I.e.
1967 there is nothing to do here. */
1970 case UNFORMATTED_SEQUENTIAL
:
1971 if (dtp
->u
.p
.mode
== READING
)
1978 case FORMATTED_SEQUENTIAL
:
1979 case FORMATTED_DIRECT
:
1980 case UNFORMATTED_DIRECT
:
1981 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1985 dtp
->u
.p
.current_unit
->current_record
= 1;
1989 /* Initialize things for a data transfer. This code is common for
1990 both reading and writing. */
1993 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1995 unit_flags u_flags
; /* Used for creating a unit if needed. */
1996 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1997 namelist_info
*ionml
;
1999 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
2001 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2003 dtp
->u
.p
.ionml
= ionml
;
2004 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
2006 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2009 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2010 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
2012 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
2013 if (dtp
->u
.p
.current_unit
->s
== NULL
)
2014 { /* Open the unit with some default flags. */
2015 st_parameter_open opp
;
2018 if (dtp
->common
.unit
< 0)
2020 close_unit (dtp
->u
.p
.current_unit
);
2021 dtp
->u
.p
.current_unit
= NULL
;
2022 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2023 "Bad unit number in statement");
2026 memset (&u_flags
, '\0', sizeof (u_flags
));
2027 u_flags
.access
= ACCESS_SEQUENTIAL
;
2028 u_flags
.action
= ACTION_READWRITE
;
2030 /* Is it unformatted? */
2031 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
2032 | IOPARM_DT_IONML_SET
)))
2033 u_flags
.form
= FORM_UNFORMATTED
;
2035 u_flags
.form
= FORM_UNSPECIFIED
;
2037 u_flags
.delim
= DELIM_UNSPECIFIED
;
2038 u_flags
.blank
= BLANK_UNSPECIFIED
;
2039 u_flags
.pad
= PAD_UNSPECIFIED
;
2040 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
2041 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
2042 u_flags
.async
= ASYNC_UNSPECIFIED
;
2043 u_flags
.round
= ROUND_UNSPECIFIED
;
2044 u_flags
.sign
= SIGN_UNSPECIFIED
;
2046 u_flags
.status
= STATUS_UNKNOWN
;
2048 conv
= get_unformatted_convert (dtp
->common
.unit
);
2050 if (conv
== GFC_CONVERT_NONE
)
2051 conv
= compile_options
.convert
;
2053 /* We use big_endian, which is 0 on little-endian machines
2054 and 1 on big-endian machines. */
2057 case GFC_CONVERT_NATIVE
:
2058 case GFC_CONVERT_SWAP
:
2061 case GFC_CONVERT_BIG
:
2062 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
2065 case GFC_CONVERT_LITTLE
:
2066 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
2070 internal_error (&opp
.common
, "Illegal value for CONVERT");
2074 u_flags
.convert
= conv
;
2076 opp
.common
= dtp
->common
;
2077 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
2078 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
2079 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
2080 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
2081 if (dtp
->u
.p
.current_unit
== NULL
)
2085 /* Check the action. */
2087 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
2089 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2090 "Cannot read from file opened for WRITE");
2094 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
2096 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
2097 "Cannot write to file opened for READ");
2101 dtp
->u
.p
.first_item
= 1;
2103 /* Check the format. */
2105 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2108 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2109 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2112 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2113 "Format present for UNFORMATTED data transfer");
2117 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
2119 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
2120 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2121 "A format cannot be specified with a namelist");
2123 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
2124 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
2126 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2127 "Missing format for FORMATTED data transfer");
2130 if (is_internal_unit (dtp
)
2131 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2133 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2134 "Internal file cannot be accessed by UNFORMATTED "
2139 /* Check the record or position number. */
2141 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
2142 && (cf
& IOPARM_DT_HAS_REC
) == 0)
2144 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2145 "Direct access data transfer requires record number");
2149 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2150 && (cf
& IOPARM_DT_HAS_REC
) != 0)
2152 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2153 "Record number not allowed for sequential access "
2158 /* Process the ADVANCE option. */
2160 dtp
->u
.p
.advance_status
2161 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
2162 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
2163 "Bad ADVANCE parameter in data transfer statement");
2165 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2167 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2169 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2170 "ADVANCE specification conflicts with sequential "
2175 if (is_internal_unit (dtp
))
2177 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2178 "ADVANCE specification conflicts with internal file");
2182 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2183 != IOPARM_DT_HAS_FORMAT
)
2185 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2186 "ADVANCE specification requires an explicit format");
2193 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2195 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2197 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2198 "EOR specification requires an ADVANCE specification "
2203 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2204 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2206 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2207 "SIZE specification requires an ADVANCE "
2208 "specification of NO");
2213 { /* Write constraints. */
2214 if ((cf
& IOPARM_END
) != 0)
2216 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2217 "END specification cannot appear in a write "
2222 if ((cf
& IOPARM_EOR
) != 0)
2224 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2225 "EOR specification cannot appear in a write "
2230 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2232 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2233 "SIZE specification cannot appear in a write "
2239 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2240 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2242 /* Check the decimal mode. */
2243 dtp
->u
.p
.current_unit
->decimal_status
2244 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2245 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
,
2246 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2249 if (dtp
->u
.p
.current_unit
->decimal_status
== DECIMAL_UNSPECIFIED
)
2250 dtp
->u
.p
.current_unit
->decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2252 /* Check the sign mode. */
2253 dtp
->u
.p
.sign_status
2254 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2255 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2256 "Bad SIGN parameter in data transfer statement");
2258 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2259 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2261 /* Check the blank mode. */
2262 dtp
->u
.p
.blank_status
2263 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2264 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
,
2266 "Bad BLANK parameter in data transfer statement");
2268 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2269 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2271 /* Check the delim mode. */
2272 dtp
->u
.p
.current_unit
->delim_status
2273 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2274 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
,
2275 delim_opt
, "Bad DELIM parameter in data transfer statement");
2277 if (dtp
->u
.p
.current_unit
->delim_status
== DELIM_UNSPECIFIED
)
2278 dtp
->u
.p
.current_unit
->delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2280 /* Check the pad mode. */
2281 dtp
->u
.p
.current_unit
->pad_status
2282 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2283 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2284 "Bad PAD parameter in data transfer statement");
2286 if (dtp
->u
.p
.current_unit
->pad_status
== PAD_UNSPECIFIED
)
2287 dtp
->u
.p
.current_unit
->pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2289 /* Check to see if we might be reading what we wrote before */
2291 if (dtp
->u
.p
.mode
!= dtp
->u
.p
.current_unit
->mode
2292 && !is_internal_unit (dtp
))
2294 int pos
= fbuf_reset (dtp
->u
.p
.current_unit
);
2296 sseek (dtp
->u
.p
.current_unit
->s
, pos
, SEEK_CUR
);
2297 sflush(dtp
->u
.p
.current_unit
->s
);
2300 /* Check the POS= specifier: that it is in range and that it is used with a
2301 unit that has been connected for STREAM access. F2003 9.5.1.10. */
2303 if (((cf
& IOPARM_DT_HAS_POS
) != 0))
2305 if (is_stream_io (dtp
))
2310 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2311 "POS=specifier must be positive");
2315 if (dtp
->pos
>= dtp
->u
.p
.current_unit
->maxrec
)
2317 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2318 "POS=specifier too large");
2322 dtp
->rec
= dtp
->pos
;
2324 if (dtp
->u
.p
.mode
== READING
)
2326 /* Reset the endfile flag; if we hit EOF during reading
2327 we'll set the flag and generate an error at that point
2328 rather than worrying about it here. */
2329 dtp
->u
.p
.current_unit
->endfile
= NO_ENDFILE
;
2332 if (dtp
->pos
!= dtp
->u
.p
.current_unit
->strm_pos
)
2334 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
2335 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->pos
- 1, SEEK_SET
) < 0)
2337 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2340 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->pos
;
2345 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2346 "POS=specifier not allowed, "
2347 "Try OPEN with ACCESS='stream'");
2353 /* Sanity checks on the record number. */
2354 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2358 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2359 "Record number must be positive");
2363 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2365 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2366 "Record number too large");
2370 /* Make sure format buffer is reset. */
2371 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2372 fbuf_reset (dtp
->u
.p
.current_unit
);
2375 /* Check whether the record exists to be read. Only
2376 a partial record needs to exist. */
2378 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2379 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2381 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2382 "Non-existing record number");
2386 /* Position the file. */
2387 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2388 * dtp
->u
.p
.current_unit
->recl
, SEEK_SET
) < 0)
2390 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2394 /* TODO: This is required to maintain compatibility between
2395 4.3 and 4.4 runtime. Remove when ABI changes from 4.3 */
2397 if (is_stream_io (dtp
))
2398 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2400 /* TODO: Un-comment this code when ABI changes from 4.3.
2401 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
2403 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2404 "Record number not allowed for stream access "
2410 /* Bugware for badly written mixed C-Fortran I/O. */
2411 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2413 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2415 /* Set the maximum position reached from the previous I/O operation. This
2416 could be greater than zero from a previous non-advancing write. */
2417 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2422 /* Set up the subroutine that will handle the transfers. */
2426 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2427 dtp
->u
.p
.transfer
= unformatted_read
;
2430 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2431 dtp
->u
.p
.transfer
= list_formatted_read
;
2433 dtp
->u
.p
.transfer
= formatted_transfer
;
2438 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2439 dtp
->u
.p
.transfer
= unformatted_write
;
2442 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2443 dtp
->u
.p
.transfer
= list_formatted_write
;
2445 dtp
->u
.p
.transfer
= formatted_transfer
;
2449 /* Make sure that we don't do a read after a nonadvancing write. */
2453 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2455 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2456 "Cannot READ after a nonadvancing WRITE");
2462 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2463 dtp
->u
.p
.current_unit
->read_bad
= 1;
2466 /* Start the data transfer if we are doing a formatted transfer. */
2467 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2468 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2469 && dtp
->u
.p
.ionml
== NULL
)
2470 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2473 /* Initialize an array_loop_spec given the array descriptor. The function
2474 returns the index of the last element of the array, and also returns
2475 starting record, where the first I/O goes to (necessary in case of
2476 negative strides). */
2479 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2480 gfc_offset
*start_record
)
2482 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2491 for (i
=0; i
<rank
; i
++)
2493 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2494 ls
[i
].start
= desc
->dim
[i
].lbound
;
2495 ls
[i
].end
= desc
->dim
[i
].ubound
;
2496 ls
[i
].step
= desc
->dim
[i
].stride
;
2497 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2499 if (desc
->dim
[i
].stride
> 0)
2501 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2502 * desc
->dim
[i
].stride
;
2506 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2507 * desc
->dim
[i
].stride
;
2508 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2509 * desc
->dim
[i
].stride
;
2519 /* Determine the index to the next record in an internal unit array by
2520 by incrementing through the array_loop_spec. */
2523 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2531 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2536 if (ls
[i
].idx
> ls
[i
].end
)
2538 ls
[i
].idx
= ls
[i
].start
;
2544 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2554 /* Skip to the end of the current record, taking care of an optional
2555 record marker of size bytes. If the file is not seekable, we
2556 read chunks of size MAX_READ until we get to the right
2560 skip_record (st_parameter_dt
*dtp
, ssize_t bytes
)
2562 ssize_t rlength
, readb
;
2563 static const ssize_t MAX_READ
= 4096;
2566 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2567 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2570 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2572 /* Direct access files do not generate END conditions,
2574 if (sseek (dtp
->u
.p
.current_unit
->s
,
2575 dtp
->u
.p
.current_unit
->bytes_left_subrecord
, SEEK_CUR
) < 0)
2576 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2579 { /* Seek by reading data. */
2580 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2583 (MAX_READ
< dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2584 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2586 readb
= sread (dtp
->u
.p
.current_unit
->s
, p
, rlength
);
2589 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2593 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= readb
;
2600 /* Advance to the next record reading unformatted files, taking
2601 care of subrecords. If complete_record is nonzero, we loop
2602 until all subrecords are cleared. */
2605 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2609 bytes
= compile_options
.record_marker
== 0 ?
2610 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2615 /* Skip over tail */
2617 skip_record (dtp
, bytes
);
2619 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2627 static inline gfc_offset
2628 min_off (gfc_offset a
, gfc_offset b
)
2630 return (a
< b
? a
: b
);
2634 /* Space to the next record for read mode. */
2637 next_record_r (st_parameter_dt
*dtp
)
2644 switch (current_mode (dtp
))
2646 /* No records in unformatted STREAM I/O. */
2647 case UNFORMATTED_STREAM
:
2650 case UNFORMATTED_SEQUENTIAL
:
2651 next_record_r_unf (dtp
, 1);
2652 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2655 case FORMATTED_DIRECT
:
2656 case UNFORMATTED_DIRECT
:
2657 skip_record (dtp
, 0);
2660 case FORMATTED_STREAM
:
2661 case FORMATTED_SEQUENTIAL
:
2662 /* read_sf has already terminated input because of an '\n', or
2664 if (dtp
->u
.p
.sf_seen_eor
|| dtp
->u
.p
.at_eof
)
2666 dtp
->u
.p
.sf_seen_eor
= 0;
2667 dtp
->u
.p
.at_eof
= 0;
2671 if (is_internal_unit (dtp
))
2673 if (is_array_io (dtp
))
2677 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2680 /* Now seek to this record. */
2681 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2682 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2684 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2687 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2691 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2692 bytes_left
= min_off (bytes_left
,
2693 file_length (dtp
->u
.p
.current_unit
->s
)
2694 - stell (dtp
->u
.p
.current_unit
->s
));
2695 if (sseek (dtp
->u
.p
.current_unit
->s
,
2696 bytes_left
, SEEK_CUR
) < 0)
2698 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2701 dtp
->u
.p
.current_unit
->bytes_left
2702 = dtp
->u
.p
.current_unit
->recl
;
2711 cc
= fbuf_getc (dtp
->u
.p
.current_unit
);
2715 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2721 if (is_stream_io (dtp
))
2722 dtp
->u
.p
.current_unit
->strm_pos
++;
2733 /* Small utility function to write a record marker, taking care of
2734 byte swapping and of choosing the correct size. */
2737 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2742 char p
[sizeof (GFC_INTEGER_8
)];
2744 if (compile_options
.record_marker
== 0)
2745 len
= sizeof (GFC_INTEGER_4
);
2747 len
= compile_options
.record_marker
;
2749 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2750 if (likely (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
))
2754 case sizeof (GFC_INTEGER_4
):
2756 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, len
);
2759 case sizeof (GFC_INTEGER_8
):
2761 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, len
);
2765 runtime_error ("Illegal value for record marker");
2773 case sizeof (GFC_INTEGER_4
):
2775 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2776 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2779 case sizeof (GFC_INTEGER_8
):
2781 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2782 return swrite (dtp
->u
.p
.current_unit
->s
, p
, len
);
2786 runtime_error ("Illegal value for record marker");
2793 /* Position to the next (sub)record in write mode for
2794 unformatted sequential files. */
2797 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2799 gfc_offset m
, m_write
, record_marker
;
2801 /* Bytes written. */
2802 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2803 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2805 /* Write the length tail. If we finish a record containing
2806 subrecords, we write out the negative length. */
2808 if (dtp
->u
.p
.current_unit
->continued
)
2813 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2816 if (compile_options
.record_marker
== 0)
2817 record_marker
= sizeof (GFC_INTEGER_4
);
2819 record_marker
= compile_options
.record_marker
;
2821 /* Seek to the head and overwrite the bogus length with the real
2824 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, - m
- 2 * record_marker
,
2833 if (unlikely (write_us_marker (dtp
, m_write
) < 0))
2836 /* Seek past the end of the current record. */
2838 if (unlikely (sseek (dtp
->u
.p
.current_unit
->s
, m
+ record_marker
,
2845 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2851 /* Utility function like memset() but operating on streams. Return
2852 value is same as for POSIX write(). */
2855 sset (stream
* s
, int c
, ssize_t nbyte
)
2857 static const int WRITE_CHUNK
= 256;
2858 char p
[WRITE_CHUNK
];
2859 ssize_t bytes_left
, trans
;
2861 if (nbyte
< WRITE_CHUNK
)
2862 memset (p
, c
, nbyte
);
2864 memset (p
, c
, WRITE_CHUNK
);
2867 while (bytes_left
> 0)
2869 trans
= (bytes_left
< WRITE_CHUNK
) ? bytes_left
: WRITE_CHUNK
;
2870 trans
= swrite (s
, p
, trans
);
2873 bytes_left
-= trans
;
2876 return nbyte
- bytes_left
;
2879 /* Position to the next record in write mode. */
2882 next_record_w (st_parameter_dt
*dtp
, int done
)
2884 gfc_offset m
, record
, max_pos
;
2887 /* Zero counters for X- and T-editing. */
2888 max_pos
= dtp
->u
.p
.max_pos
;
2889 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2891 switch (current_mode (dtp
))
2893 /* No records in unformatted STREAM I/O. */
2894 case UNFORMATTED_STREAM
:
2897 case FORMATTED_DIRECT
:
2898 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2901 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
2902 fbuf_flush (dtp
->u
.p
.current_unit
, WRITING
);
2903 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2904 dtp
->u
.p
.current_unit
->bytes_left
)
2905 != dtp
->u
.p
.current_unit
->bytes_left
)
2910 case UNFORMATTED_DIRECT
:
2911 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2913 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2914 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) != length
)
2919 case UNFORMATTED_SEQUENTIAL
:
2920 next_record_w_unf (dtp
, 0);
2921 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2924 case FORMATTED_STREAM
:
2925 case FORMATTED_SEQUENTIAL
:
2927 if (is_internal_unit (dtp
))
2929 if (is_array_io (dtp
))
2933 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2935 /* If the farthest position reached is greater than current
2936 position, adjust the position and set length to pad out
2937 whats left. Otherwise just pad whats left.
2938 (for character array unit) */
2939 m
= dtp
->u
.p
.current_unit
->recl
2940 - dtp
->u
.p
.current_unit
->bytes_left
;
2943 length
= (int) (max_pos
- m
);
2944 if (sseek (dtp
->u
.p
.current_unit
->s
,
2945 length
, SEEK_CUR
) < 0)
2947 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2950 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2953 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
2955 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2959 /* Now that the current record has been padded out,
2960 determine where the next record in the array is. */
2961 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2964 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2966 /* Now seek to this record */
2967 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2969 if (sseek (dtp
->u
.p
.current_unit
->s
, record
, SEEK_SET
) < 0)
2971 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2975 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2981 /* If this is the last call to next_record move to the farthest
2982 position reached and set length to pad out the remainder
2983 of the record. (for character scaler unit) */
2986 m
= dtp
->u
.p
.current_unit
->recl
2987 - dtp
->u
.p
.current_unit
->bytes_left
;
2990 length
= (int) (max_pos
- m
);
2991 if (sseek (dtp
->u
.p
.current_unit
->s
,
2992 length
, SEEK_CUR
) < 0)
2994 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2997 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
3000 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
3003 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) != length
)
3005 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3017 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3018 char * p
= fbuf_alloc (dtp
->u
.p
.current_unit
, len
);
3025 if (is_stream_io (dtp
))
3027 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
3028 if (dtp
->u
.p
.current_unit
->strm_pos
3029 < file_length (dtp
->u
.p
.current_unit
->s
))
3030 unit_truncate (dtp
->u
.p
.current_unit
,
3031 dtp
->u
.p
.current_unit
->strm_pos
- 1,
3039 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3044 /* Position to the next record, which means moving to the end of the
3045 current record. This can happen under several different
3046 conditions. If the done flag is not set, we get ready to process
3050 next_record (st_parameter_dt
*dtp
, int done
)
3052 gfc_offset fp
; /* File position. */
3054 dtp
->u
.p
.current_unit
->read_bad
= 0;
3056 if (dtp
->u
.p
.mode
== READING
)
3057 next_record_r (dtp
);
3059 next_record_w (dtp
, done
);
3061 if (!is_stream_io (dtp
))
3063 /* Keep position up to date for INQUIRE */
3065 update_position (dtp
->u
.p
.current_unit
);
3067 dtp
->u
.p
.current_unit
->current_record
= 0;
3068 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
3070 fp
= stell (dtp
->u
.p
.current_unit
->s
);
3071 /* Calculate next record, rounding up partial records. */
3072 dtp
->u
.p
.current_unit
->last_record
=
3073 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
3074 dtp
->u
.p
.current_unit
->recl
;
3077 dtp
->u
.p
.current_unit
->last_record
++;
3083 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3087 /* Finalize the current data transfer. For a nonadvancing transfer,
3088 this means advancing to the next record. For internal units close the
3089 stream associated with the unit. */
3092 finalize_transfer (st_parameter_dt
*dtp
)
3095 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
3097 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
3098 *dtp
->size
= dtp
->u
.p
.size_used
;
3100 if (dtp
->u
.p
.eor_condition
)
3102 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
3106 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
3109 if ((dtp
->u
.p
.ionml
!= NULL
)
3110 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
3112 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
3113 namelist_read (dtp
);
3115 namelist_write (dtp
);
3118 dtp
->u
.p
.transfer
= NULL
;
3119 if (dtp
->u
.p
.current_unit
== NULL
)
3122 dtp
->u
.p
.eof_jump
= &eof_jump
;
3123 if (setjmp (eof_jump
))
3125 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3129 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
3131 finish_list_read (dtp
);
3135 if (dtp
->u
.p
.mode
== WRITING
)
3136 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
3137 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
3139 if (is_stream_io (dtp
))
3141 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3142 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
3143 next_record (dtp
, 1);
3148 dtp
->u
.p
.current_unit
->current_record
= 0;
3150 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
3152 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3153 dtp
->u
.p
.seen_dollar
= 0;
3157 /* For non-advancing I/O, save the current maximum position for use in the
3158 next I/O operation if needed. */
3159 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
3161 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
3162 - dtp
->u
.p
.current_unit
->bytes_left
);
3163 dtp
->u
.p
.current_unit
->saved_pos
=
3164 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
3165 fbuf_flush (dtp
->u
.p
.current_unit
, dtp
->u
.p
.mode
);
3168 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
3169 && dtp
->u
.p
.mode
== WRITING
&& !is_internal_unit (dtp
))
3170 fbuf_seek (dtp
->u
.p
.current_unit
, 0, SEEK_END
);
3172 dtp
->u
.p
.current_unit
->saved_pos
= 0;
3174 next_record (dtp
, 1);
3177 /* Transfer function for IOLENGTH. It doesn't actually do any
3178 data transfer, it just updates the length counter. */
3181 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
3182 void *dest
__attribute__ ((unused
)),
3183 int kind
__attribute__((unused
)),
3184 size_t size
, size_t nelems
)
3186 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3187 *dtp
->iolength
+= (GFC_IO_INT
) (size
* nelems
);
3191 /* Initialize the IOLENGTH data transfer. This function is in essence
3192 a very much simplified version of data_transfer_init(), because it
3193 doesn't have to deal with units at all. */
3196 iolength_transfer_init (st_parameter_dt
*dtp
)
3198 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
3201 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
3203 /* Set up the subroutine that will handle the transfers. */
3205 dtp
->u
.p
.transfer
= iolength_transfer
;
3209 /* Library entry point for the IOLENGTH form of the INQUIRE
3210 statement. The IOLENGTH form requires no I/O to be performed, but
3211 it must still be a runtime library call so that we can determine
3212 the iolength for dynamic arrays and such. */
3214 extern void st_iolength (st_parameter_dt
*);
3215 export_proto(st_iolength
);
3218 st_iolength (st_parameter_dt
*dtp
)
3220 library_start (&dtp
->common
);
3221 iolength_transfer_init (dtp
);
3224 extern void st_iolength_done (st_parameter_dt
*);
3225 export_proto(st_iolength_done
);
3228 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3235 /* The READ statement. */
3237 extern void st_read (st_parameter_dt
*);
3238 export_proto(st_read
);
3241 st_read (st_parameter_dt
*dtp
)
3243 library_start (&dtp
->common
);
3245 data_transfer_init (dtp
, 1);
3248 extern void st_read_done (st_parameter_dt
*);
3249 export_proto(st_read_done
);
3252 st_read_done (st_parameter_dt
*dtp
)
3254 finalize_transfer (dtp
);
3255 if (is_internal_unit (dtp
))
3256 free_format_data (dtp
->u
.p
.fmt
);
3258 if (dtp
->u
.p
.current_unit
!= NULL
)
3259 unlock_unit (dtp
->u
.p
.current_unit
);
3261 free_internal_unit (dtp
);
3266 extern void st_write (st_parameter_dt
*);
3267 export_proto(st_write
);
3270 st_write (st_parameter_dt
*dtp
)
3272 library_start (&dtp
->common
);
3273 data_transfer_init (dtp
, 0);
3276 extern void st_write_done (st_parameter_dt
*);
3277 export_proto(st_write_done
);
3280 st_write_done (st_parameter_dt
*dtp
)
3282 finalize_transfer (dtp
);
3284 /* Deal with endfile conditions associated with sequential files. */
3286 if (dtp
->u
.p
.current_unit
!= NULL
3287 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3288 switch (dtp
->u
.p
.current_unit
->endfile
)
3290 case AT_ENDFILE
: /* Remain at the endfile record. */
3294 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3298 /* Get rid of whatever is after this record. */
3299 if (!is_internal_unit (dtp
))
3300 unit_truncate (dtp
->u
.p
.current_unit
,
3301 stell (dtp
->u
.p
.current_unit
->s
),
3303 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3307 if (is_internal_unit (dtp
))
3308 free_format_data (dtp
->u
.p
.fmt
);
3310 if (dtp
->u
.p
.current_unit
!= NULL
)
3311 unlock_unit (dtp
->u
.p
.current_unit
);
3313 free_internal_unit (dtp
);
3319 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3321 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3326 /* Receives the scalar information for namelist objects and stores it
3327 in a linked list of namelist_info types. */
3329 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3330 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3331 export_proto(st_set_nml_var
);
3335 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3336 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3337 GFC_INTEGER_4 dtype
)
3339 namelist_info
*t1
= NULL
;
3341 size_t var_name_len
= strlen (var_name
);
3343 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3345 nml
->mem_pos
= var_addr
;
3347 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3348 memcpy (nml
->var_name
, var_name
, var_name_len
);
3349 nml
->var_name
[var_name_len
] = '\0';
3351 nml
->len
= (int) len
;
3352 nml
->string_length
= (index_type
) string_length
;
3354 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3355 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3356 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3358 if (nml
->var_rank
> 0)
3360 nml
->dim
= (descriptor_dimension
*)
3361 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3362 nml
->ls
= (array_loop_spec
*)
3363 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3373 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3375 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3376 dtp
->u
.p
.ionml
= nml
;
3380 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3385 /* Store the dimensional information for the namelist object. */
3386 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3387 index_type
, index_type
,
3389 export_proto(st_set_nml_var_dim
);
3392 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3393 index_type stride
, index_type lbound
,
3396 namelist_info
* nml
;
3401 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3403 nml
->dim
[n
].stride
= stride
;
3404 nml
->dim
[n
].lbound
= lbound
;
3405 nml
->dim
[n
].ubound
= ubound
;
3408 /* Reverse memcpy - used for byte swapping. */
3410 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3416 s
= (char *) src
+ n
- 1;
3418 /* Write with ascending order - this is likely faster
3419 on modern architectures because of write combining. */
3425 /* Once upon a time, a poor innocent Fortran program was reading a
3426 file, when suddenly it hit the end-of-file (EOF). Unfortunately
3427 the OS doesn't tell whether we're at the EOF or whether we already
3428 went past it. Luckily our hero, libgfortran, keeps track of this.
3429 Call this function when you detect an EOF condition. See Section
3433 hit_eof (st_parameter_dt
* dtp
)
3435 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_APPEND
;
3437 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3438 switch (dtp
->u
.p
.current_unit
->endfile
)
3442 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3443 if (!is_internal_unit (dtp
))
3445 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3446 dtp
->u
.p
.current_unit
->current_record
= 0;
3449 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3453 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3454 dtp
->u
.p
.current_unit
->current_record
= 0;
3459 /* Non-sequential files don't have an ENDFILE record, so we
3460 can't be at AFTER_ENDFILE. */
3461 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3462 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3463 dtp
->u
.p
.current_unit
->current_record
= 0;