1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran 95 runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
34 /* transfer.c -- Top level handling of data transfer statements. */
42 /* Calling conventions: Data transfer statements are unlike other
43 library calls in that they extend over several calls.
45 The first call is always a call to st_read() or st_write(). These
46 subroutines return no status unless a namelist read or write is
47 being done, in which case there is the usual status. No further
48 calls are necessary in this case.
50 For other sorts of data transfer, there are zero or more data
51 transfer statement that depend on the format of the data transfer
57 transfer_character_wide
61 These subroutines do not return status.
63 The last call is a call to st_[read|write]_done(). While
64 something can easily go wrong with the initial st_read() or
65 st_write(), an error inhibits any data from actually being
68 extern void transfer_integer (st_parameter_dt
*, void *, int);
69 export_proto(transfer_integer
);
71 extern void transfer_real (st_parameter_dt
*, void *, int);
72 export_proto(transfer_real
);
74 extern void transfer_logical (st_parameter_dt
*, void *, int);
75 export_proto(transfer_logical
);
77 extern void transfer_character (st_parameter_dt
*, void *, int);
78 export_proto(transfer_character
);
80 extern void transfer_character_wide (st_parameter_dt
*, void *, int, int);
81 export_proto(transfer_character_wide
);
83 extern void transfer_complex (st_parameter_dt
*, void *, int);
84 export_proto(transfer_complex
);
86 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
88 export_proto(transfer_array
);
90 static void us_read (st_parameter_dt
*, int);
91 static void us_write (st_parameter_dt
*, int);
92 static void next_record_r_unf (st_parameter_dt
*, int);
93 static void next_record_w_unf (st_parameter_dt
*, int);
95 static const st_option advance_opt
[] = {
102 static const st_option decimal_opt
[] = {
103 {"point", DECIMAL_POINT
},
104 {"comma", DECIMAL_COMMA
},
109 static const st_option sign_opt
[] = {
111 {"suppress", SIGN_SS
},
112 {"processor_defined", SIGN_S
},
116 static const st_option blank_opt
[] = {
117 {"null", BLANK_NULL
},
118 {"zero", BLANK_ZERO
},
122 static const st_option delim_opt
[] = {
123 {"apostrophe", DELIM_APOSTROPHE
},
124 {"quote", DELIM_QUOTE
},
125 {"none", DELIM_NONE
},
129 static const st_option pad_opt
[] = {
136 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
137 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
143 current_mode (st_parameter_dt
*dtp
)
147 m
= FORM_UNSPECIFIED
;
149 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
151 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
152 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
154 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
156 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
157 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
159 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
161 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
162 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
169 /* Mid level data transfer statements. These subroutines do reading
170 and writing in the style of salloc_r()/salloc_w() within the
173 /* When reading sequential formatted records we have a problem. We
174 don't know how long the line is until we read the trailing newline,
175 and we don't want to read too much. If we read too much, we might
176 have to do a physical seek backwards depending on how much data is
177 present, and devices like terminals aren't seekable and would cause
180 Given this, the solution is to read a byte at a time, stopping if
181 we hit the newline. For small allocations, we use a static buffer.
182 For larger allocations, we are forced to allocate memory on the
183 heap. Hopefully this won't happen very often. */
186 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
193 if (*length
> SCRATCH_SIZE
)
194 dtp
->u
.p
.line_buffer
= get_mem (*length
);
195 p
= base
= dtp
->u
.p
.line_buffer
;
197 /* If we have seen an eor previously, return a length of 0. The
198 caller is responsible for correctly padding the input field. */
199 if (dtp
->u
.p
.sf_seen_eor
)
205 if (is_internal_unit (dtp
))
208 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &readlen
) != 0 || readlen
< (size_t) *length
)
210 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
222 if (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0)
224 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
228 /* If we have a line without a terminating \n, drop through to
230 if (readlen
< 1 && n
== 0)
234 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
238 if (readlen
< 1 || q
== '\n' || q
== '\r')
240 /* Unexpected end of line. */
242 /* If we see an EOR during non-advancing I/O, we need to skip
243 the rest of the I/O statement. Set the corresponding flag. */
244 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
245 dtp
->u
.p
.eor_condition
= 1;
248 /* If we encounter a CR, it might be a CRLF. */
249 if (q
== '\r') /* Probably a CRLF */
252 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
253 if (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0)
255 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
258 if (q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
259 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
264 /* Without padding, terminate the I/O statement without assigning
265 the value. With padding, the value still needs to be assigned,
266 so we can just continue with a short read. */
267 if ((dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
268 && dtp
->u
.p
.pad_status
== PAD_NO
)
272 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
277 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
280 /* Short circuit the read if a comma is found during numeric input.
281 The flag is set to zero during character reads so that commas in
282 strings are not ignored */
284 if (dtp
->u
.p
.sf_read_comma
== 1)
286 notify_std (&dtp
->common
, GFC_STD_GNU
,
287 "Comma in formatted numeric read.");
294 dtp
->u
.p
.sf_seen_eor
= 0;
299 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
301 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
302 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
308 /* Function for reading the next couple of bytes from the current
309 file, advancing the current position. We return FAILURE on end of record or
310 end of file. This function is only for formatted I/O, unformatted uses
313 If the read is short, then it is because the current record does not
314 have enough data to satisfy the read request and the file was
315 opened with PAD=YES. The caller must assume tailing spaces for
319 read_block_form (st_parameter_dt
*dtp
, void *buf
, size_t *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 ((dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
337 && dtp
->u
.p
.pad_status
== PAD_NO
)
339 /* Not enough data left. */
340 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
345 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
347 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
348 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
352 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
356 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
357 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
358 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
361 source
= read_sf (dtp
, &nb
, 0);
363 dtp
->u
.p
.current_unit
->strm_pos
+=
364 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
367 memcpy (buf
, source
, *nbytes
);
370 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
373 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
375 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
379 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
380 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
382 if (nread
!= *nbytes
)
383 { /* Short read, this shouldn't happen. */
384 if ((dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
385 && dtp
->u
.p
.pad_status
== PAD_YES
)
389 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
394 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
400 /* Reads a block directly into application data space. This is for
401 unformatted files. */
404 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
406 size_t to_read_record
;
407 size_t have_read_record
;
408 size_t to_read_subrecord
;
409 size_t have_read_subrecord
;
412 if (is_stream_io (dtp
))
414 to_read_record
= *nbytes
;
415 have_read_record
= to_read_record
;
416 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
418 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
422 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
424 if (to_read_record
!= have_read_record
)
426 /* Short read, e.g. if we hit EOF. For stream files,
427 we have to set the end-of-file condition. */
428 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
434 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
436 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
439 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
440 *nbytes
= to_read_record
;
446 to_read_record
= *nbytes
;
449 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
451 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
453 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
457 if (to_read_record
!= *nbytes
)
459 /* Short read, e.g. if we hit EOF. Apparently, we read
460 more than was written to the last record. */
461 *nbytes
= to_read_record
;
467 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
473 /* Unformatted sequential. We loop over the subrecords, reading
474 until the request has been fulfilled or the record has run out
475 of continuation subrecords. */
477 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
479 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
483 /* Check whether we exceed the total record length. */
485 if (dtp
->u
.p
.current_unit
->flags
.has_recl
486 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
488 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
493 to_read_record
= *nbytes
;
496 have_read_record
= 0;
500 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
501 < (gfc_offset
) to_read_record
)
503 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
504 to_read_record
-= to_read_subrecord
;
508 to_read_subrecord
= to_read_record
;
512 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
514 have_read_subrecord
= to_read_subrecord
;
515 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
516 &have_read_subrecord
) != 0)
518 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
522 have_read_record
+= have_read_subrecord
;
524 if (to_read_subrecord
!= have_read_subrecord
)
527 /* Short read, e.g. if we hit EOF. This means the record
528 structure has been corrupted, or the trailing record
529 marker would still be present. */
531 *nbytes
= have_read_record
;
532 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
536 if (to_read_record
> 0)
538 if (dtp
->u
.p
.current_unit
->continued
)
540 next_record_r_unf (dtp
, 0);
545 /* Let's make sure the file position is correctly pre-positioned
546 for the next read statement. */
548 dtp
->u
.p
.current_unit
->current_record
= 0;
549 next_record_r_unf (dtp
, 0);
550 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
556 /* Normal exit, the read request has been fulfilled. */
561 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
564 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
571 /* Function for writing a block of bytes to the current file at the
572 current position, advancing the file pointer. We are given a length
573 and return a pointer to a buffer that the caller must (completely)
574 fill in. Returns NULL on error. */
577 write_block (st_parameter_dt
*dtp
, int length
)
581 if (!is_stream_io (dtp
))
583 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
585 /* For preconnected units with default record length, set bytes left
586 to unit record length and proceed, otherwise error. */
587 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
588 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
589 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
590 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
593 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
598 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
601 if (is_internal_unit (dtp
))
603 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
607 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
611 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
612 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
616 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
619 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
624 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
625 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
627 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
633 /* High level interface to swrite(), taking care of errors. This is only
634 called for unformatted files. There are three cases to consider:
635 Stream I/O, unformatted direct, unformatted sequential. */
638 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
641 size_t have_written
, to_write_subrecord
;
646 if (is_stream_io (dtp
))
648 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
650 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
654 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
659 /* Unformatted direct access. */
661 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
663 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
665 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
669 if (buf
== NULL
&& nbytes
== 0)
672 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
674 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
678 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
679 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
684 /* Unformatted sequential. */
688 if (dtp
->u
.p
.current_unit
->flags
.has_recl
689 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
691 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
703 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
704 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
706 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
707 (gfc_offset
) to_write_subrecord
;
709 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
710 &to_write_subrecord
) != 0)
712 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
716 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
717 nbytes
-= to_write_subrecord
;
718 have_written
+= to_write_subrecord
;
723 next_record_w_unf (dtp
, 1);
726 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
729 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
736 /* Master function for unformatted reads. */
739 unformatted_read (st_parameter_dt
*dtp
, bt type
,
740 void *dest
, int kind
, size_t size
, size_t nelems
)
744 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
748 if (type
== BT_CHARACTER
)
749 sz
*= GFC_SIZE_OF_CHAR_KIND(kind
);
750 read_block_direct (dtp
, dest
, &sz
);
759 /* Handle wide chracters. */
760 if (type
== BT_CHARACTER
&& kind
!= 1)
766 /* Break up complex into its constituent reals. */
767 if (type
== BT_COMPLEX
)
773 /* By now, all complex variables have been split into their
774 constituent reals. */
776 for (i
= 0; i
< nelems
; i
++)
778 read_block_direct (dtp
, buffer
, &size
);
779 reverse_memcpy (p
, buffer
, size
);
786 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
787 bytes on 64 bit machines. The unused bytes are not initialized and never
788 used, which can show an error with memory checking analyzers like
792 unformatted_write (st_parameter_dt
*dtp
, bt type
,
793 void *source
, int kind
, size_t size
, size_t nelems
)
795 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
798 size_t stride
= type
== BT_CHARACTER
?
799 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
801 write_buf (dtp
, source
, stride
* nelems
);
811 /* Handle wide chracters. */
812 if (type
== BT_CHARACTER
&& kind
!= 1)
818 /* Break up complex into its constituent reals. */
819 if (type
== BT_COMPLEX
)
825 /* By now, all complex variables have been split into their
826 constituent reals. */
828 for (i
= 0; i
< nelems
; i
++)
830 reverse_memcpy(buffer
, p
, size
);
832 write_buf (dtp
, buffer
, size
);
838 /* Return a pointer to the name of a type. */
863 internal_error (NULL
, "type_name(): Bad type");
870 /* Write a constant string to the output.
871 This is complicated because the string can have doubled delimiters
872 in it. The length in the format node is the true length. */
875 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
877 char c
, delimiter
, *p
, *q
;
880 length
= f
->u
.string
.length
;
884 p
= write_block (dtp
, length
);
891 for (; length
> 0; length
--)
894 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
895 q
++; /* Skip the doubled delimiter. */
900 /* Given actual and expected types in a formatted data transfer, make
901 sure they agree. If not, an error message is generated. Returns
902 nonzero if something went wrong. */
905 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
909 if (actual
== expected
)
912 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
913 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
915 format_error (dtp
, f
, buffer
);
920 /* This subroutine is the main loop for a formatted data transfer
921 statement. It would be natural to implement this as a coroutine
922 with the user program, but C makes that awkward. We loop,
923 processing format elements. When we actually have to transfer
924 data instead of just setting flags, we return control to the user
925 program which calls a subroutine that supplies the address and type
926 of the next element, then comes back here to process it. */
929 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
932 char scratch
[SCRATCH_SIZE
];
937 int consume_data_flag
;
939 /* Change a complex data item into a pair of reals. */
941 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
942 if (type
== BT_COMPLEX
)
948 /* If there's an EOR condition, we simulate finalizing the transfer
950 if (dtp
->u
.p
.eor_condition
)
953 /* Set this flag so that commas in reads cause the read to complete before
954 the entire field has been read. The next read field will start right after
955 the comma in the stream. (Set to 0 for character reads). */
956 dtp
->u
.p
.sf_read_comma
= 1;
958 if (dtp
->common
.flags
& IOPARM_DT_HAS_F2003
)
959 dtp
->u
.p
.sf_read_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
? 0 : 1;
961 dtp
->u
.p
.line_buffer
= scratch
;
965 /* If reversion has occurred and there is another real data item,
966 then we have to move to the next record. */
967 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
969 dtp
->u
.p
.reversion_flag
= 0;
970 next_record (dtp
, 0);
973 consume_data_flag
= 1;
974 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
977 f
= next_format (dtp
);
980 /* No data descriptors left. */
982 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
983 "Insufficient data descriptors in format after reversion");
987 /* Now discharge T, TR and X movements to the right. This is delayed
988 until a data producing format to suppress trailing spaces. */
991 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
992 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
993 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
994 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
995 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
998 if (dtp
->u
.p
.skips
> 0)
1001 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1002 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
1003 - dtp
->u
.p
.current_unit
->bytes_left
);
1005 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
1007 if (dtp
->u
.p
.skips
< 0)
1009 if (is_internal_unit (dtp
))
1010 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1012 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
);
1013 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
1015 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1018 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1019 - dtp
->u
.p
.current_unit
->bytes_left
);
1021 if (is_stream_io(dtp
))
1029 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1032 if (dtp
->u
.p
.mode
== READING
)
1033 read_decimal (dtp
, f
, p
, kind
);
1035 write_i (dtp
, f
, p
, kind
);
1043 if (compile_options
.allow_std
< GFC_STD_GNU
1044 && require_type (dtp
, BT_INTEGER
, type
, f
))
1047 if (dtp
->u
.p
.mode
== READING
)
1048 read_radix (dtp
, f
, p
, kind
, 2);
1050 write_b (dtp
, f
, p
, kind
);
1058 if (compile_options
.allow_std
< GFC_STD_GNU
1059 && require_type (dtp
, BT_INTEGER
, type
, f
))
1062 if (dtp
->u
.p
.mode
== READING
)
1063 read_radix (dtp
, f
, p
, kind
, 8);
1065 write_o (dtp
, f
, p
, kind
);
1073 if (compile_options
.allow_std
< GFC_STD_GNU
1074 && require_type (dtp
, BT_INTEGER
, type
, f
))
1077 if (dtp
->u
.p
.mode
== READING
)
1078 read_radix (dtp
, f
, p
, kind
, 16);
1080 write_z (dtp
, f
, p
, kind
);
1088 /* It is possible to have FMT_A with something not BT_CHARACTER such
1089 as when writing out hollerith strings, so check both type
1090 and kind before calling wide character routines. */
1091 if (dtp
->u
.p
.mode
== READING
)
1093 if (type
== BT_CHARACTER
&& kind
== 4)
1094 read_a_char4 (dtp
, f
, p
, size
);
1096 read_a (dtp
, f
, p
, size
);
1100 if (type
== BT_CHARACTER
&& kind
== 4)
1101 write_a_char4 (dtp
, f
, p
, size
);
1103 write_a (dtp
, f
, p
, size
);
1111 if (dtp
->u
.p
.mode
== READING
)
1112 read_l (dtp
, f
, p
, kind
);
1114 write_l (dtp
, f
, p
, kind
);
1121 if (require_type (dtp
, BT_REAL
, type
, f
))
1124 if (dtp
->u
.p
.mode
== READING
)
1125 read_f (dtp
, f
, p
, kind
);
1127 write_d (dtp
, f
, p
, kind
);
1134 if (require_type (dtp
, BT_REAL
, type
, f
))
1137 if (dtp
->u
.p
.mode
== READING
)
1138 read_f (dtp
, f
, p
, kind
);
1140 write_e (dtp
, f
, p
, kind
);
1146 if (require_type (dtp
, BT_REAL
, type
, f
))
1149 if (dtp
->u
.p
.mode
== READING
)
1150 read_f (dtp
, f
, p
, kind
);
1152 write_en (dtp
, f
, p
, kind
);
1159 if (require_type (dtp
, BT_REAL
, type
, f
))
1162 if (dtp
->u
.p
.mode
== READING
)
1163 read_f (dtp
, f
, p
, kind
);
1165 write_es (dtp
, f
, p
, kind
);
1172 if (require_type (dtp
, BT_REAL
, type
, f
))
1175 if (dtp
->u
.p
.mode
== READING
)
1176 read_f (dtp
, f
, p
, kind
);
1178 write_f (dtp
, f
, p
, kind
);
1185 if (dtp
->u
.p
.mode
== READING
)
1189 read_decimal (dtp
, f
, p
, kind
);
1192 read_l (dtp
, f
, p
, kind
);
1196 read_a_char4 (dtp
, f
, p
, size
);
1198 read_a (dtp
, f
, p
, size
);
1201 read_f (dtp
, f
, p
, kind
);
1210 write_i (dtp
, f
, p
, kind
);
1213 write_l (dtp
, f
, p
, kind
);
1217 write_a_char4 (dtp
, f
, p
, size
);
1219 write_a (dtp
, f
, p
, size
);
1222 if (f
->u
.real
.w
== 0)
1224 if (f
->u
.real
.d
== 0)
1225 write_real (dtp
, p
, kind
);
1227 write_real_g0 (dtp
, p
, kind
, f
->u
.real
.d
);
1230 write_d (dtp
, f
, p
, kind
);
1234 internal_error (&dtp
->common
,
1235 "formatted_transfer(): Bad type");
1241 consume_data_flag
= 0;
1242 if (dtp
->u
.p
.mode
== READING
)
1244 format_error (dtp
, f
, "Constant string in input format");
1247 write_constant_string (dtp
, f
);
1250 /* Format codes that don't transfer data. */
1253 consume_data_flag
= 0;
1255 dtp
->u
.p
.skips
+= f
->u
.n
;
1256 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1257 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1259 /* Writes occur just before the switch on f->format, above, so
1260 that trailing blanks are suppressed, unless we are doing a
1261 non-advancing write in which case we want to output the blanks
1263 if (dtp
->u
.p
.mode
== WRITING
1264 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1266 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1267 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1270 if (dtp
->u
.p
.mode
== READING
)
1271 read_x (dtp
, f
->u
.n
);
1277 consume_data_flag
= 0;
1279 if (f
->format
== FMT_TL
)
1282 /* Handle the special case when no bytes have been used yet.
1283 Cannot go below zero. */
1284 if (bytes_used
== 0)
1286 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1287 dtp
->u
.p
.skips
-= f
->u
.n
;
1288 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1291 pos
= bytes_used
- f
->u
.n
;
1295 if (dtp
->u
.p
.mode
== READING
)
1298 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1301 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1302 left tab limit. We do not check if the position has gone
1303 beyond the end of record because a subsequent tab could
1304 bring us back again. */
1305 pos
= pos
< 0 ? 0 : pos
;
1307 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1308 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1309 + pos
- dtp
->u
.p
.max_pos
;
1310 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1311 ? 0 : dtp
->u
.p
.pending_spaces
;
1313 if (dtp
->u
.p
.skips
== 0)
1316 /* Writes occur just before the switch on f->format, above, so that
1317 trailing blanks are suppressed. */
1318 if (dtp
->u
.p
.mode
== READING
)
1320 /* Adjust everything for end-of-record condition */
1321 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1323 if (dtp
->u
.p
.sf_seen_eor
== 2)
1325 /* The EOR was a CRLF (two bytes wide). */
1326 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1327 dtp
->u
.p
.skips
-= 2;
1331 /* The EOR marker was only one byte wide. */
1332 dtp
->u
.p
.current_unit
->bytes_left
--;
1336 dtp
->u
.p
.sf_seen_eor
= 0;
1338 if (dtp
->u
.p
.skips
< 0)
1340 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1341 dtp
->u
.p
.current_unit
->bytes_left
1342 -= (gfc_offset
) dtp
->u
.p
.skips
;
1343 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1346 read_x (dtp
, dtp
->u
.p
.skips
);
1352 consume_data_flag
= 0;
1353 dtp
->u
.p
.sign_status
= SIGN_S
;
1357 consume_data_flag
= 0;
1358 dtp
->u
.p
.sign_status
= SIGN_SS
;
1362 consume_data_flag
= 0;
1363 dtp
->u
.p
.sign_status
= SIGN_SP
;
1367 consume_data_flag
= 0 ;
1368 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1372 consume_data_flag
= 0;
1373 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1377 consume_data_flag
= 0;
1378 dtp
->u
.p
.decimal_status
= DECIMAL_COMMA
;
1382 consume_data_flag
= 0;
1383 dtp
->u
.p
.decimal_status
= DECIMAL_POINT
;
1387 consume_data_flag
= 0;
1388 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1392 consume_data_flag
= 0;
1393 dtp
->u
.p
.seen_dollar
= 1;
1397 consume_data_flag
= 0;
1398 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1399 next_record (dtp
, 0);
1403 /* A colon descriptor causes us to exit this loop (in
1404 particular preventing another / descriptor from being
1405 processed) unless there is another data item to be
1407 consume_data_flag
= 0;
1413 internal_error (&dtp
->common
, "Bad format node");
1416 /* Free a buffer that we had to allocate during a sequential
1417 formatted read of a block that was larger than the static
1420 if (dtp
->u
.p
.line_buffer
!= scratch
)
1422 free_mem (dtp
->u
.p
.line_buffer
);
1423 dtp
->u
.p
.line_buffer
= scratch
;
1426 /* Adjust the item count and data pointer. */
1428 if ((consume_data_flag
> 0) && (n
> 0))
1431 p
= ((char *) p
) + size
;
1434 if (dtp
->u
.p
.mode
== READING
)
1437 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1438 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1444 /* Come here when we need a data descriptor but don't have one. We
1445 push the current format node back onto the input, then return and
1446 let the user program call us back with the data. */
1448 unget_format (dtp
, f
);
1452 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1453 size_t size
, size_t nelems
)
1459 size_t stride
= type
== BT_CHARACTER
?
1460 size
* GFC_SIZE_OF_CHAR_KIND(kind
) : size
;
1461 /* Big loop over all the elements. */
1462 for (elem
= 0; elem
< nelems
; elem
++)
1464 dtp
->u
.p
.item_count
++;
1465 formatted_transfer_scalar (dtp
, type
, tmp
+ stride
*elem
, kind
, size
);
1471 /* Data transfer entry points. The type of the data entity is
1472 implicit in the subroutine call. This prevents us from having to
1473 share a common enum with the compiler. */
1476 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1478 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1480 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1485 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1488 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1490 size
= size_from_real_kind (kind
);
1491 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1496 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1498 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1500 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1505 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1507 static char *empty_string
[0];
1509 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1512 /* Strings of zero length can have p == NULL, which confuses the
1513 transfer routines into thinking we need more data elements. To avoid
1514 this, we give them a nice pointer. */
1515 if (len
== 0 && p
== NULL
)
1518 /* Set kind here to 1. */
1519 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, 1, len
, 1);
1523 transfer_character_wide (st_parameter_dt
*dtp
, void *p
, int len
, int kind
)
1525 static char *empty_string
[0];
1527 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1530 /* Strings of zero length can have p == NULL, which confuses the
1531 transfer routines into thinking we need more data elements. To avoid
1532 this, we give them a nice pointer. */
1533 if (len
== 0 && p
== NULL
)
1536 /* Here we pass the actual kind value. */
1537 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, kind
, len
, 1);
1542 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1545 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1547 size
= size_from_complex_kind (kind
);
1548 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1553 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1554 gfc_charlen_type charlen
)
1556 index_type count
[GFC_MAX_DIMENSIONS
];
1557 index_type extent
[GFC_MAX_DIMENSIONS
];
1558 index_type stride
[GFC_MAX_DIMENSIONS
];
1559 index_type stride0
, rank
, size
, type
, n
;
1564 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1567 type
= GFC_DESCRIPTOR_TYPE (desc
);
1568 size
= GFC_DESCRIPTOR_SIZE (desc
);
1570 /* FIXME: What a kludge: Array descriptors and the IO library use
1571 different enums for types. */
1574 case GFC_DTYPE_UNKNOWN
:
1575 iotype
= BT_NULL
; /* Is this correct? */
1577 case GFC_DTYPE_INTEGER
:
1578 iotype
= BT_INTEGER
;
1580 case GFC_DTYPE_LOGICAL
:
1581 iotype
= BT_LOGICAL
;
1583 case GFC_DTYPE_REAL
:
1586 case GFC_DTYPE_COMPLEX
:
1587 iotype
= BT_COMPLEX
;
1589 case GFC_DTYPE_CHARACTER
:
1590 iotype
= BT_CHARACTER
;
1593 case GFC_DTYPE_DERIVED
:
1594 internal_error (&dtp
->common
,
1595 "Derived type I/O should have been handled via the frontend.");
1598 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1601 rank
= GFC_DESCRIPTOR_RANK (desc
);
1602 for (n
= 0; n
< rank
; n
++)
1605 stride
[n
] = iotype
== BT_CHARACTER
?
1606 desc
->dim
[n
].stride
* GFC_SIZE_OF_CHAR_KIND(kind
) :
1607 desc
->dim
[n
].stride
;
1608 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1610 /* If the extent of even one dimension is zero, then the entire
1611 array section contains zero elements, so we return after writing
1612 a zero array record. */
1617 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1622 stride0
= stride
[0];
1624 /* If the innermost dimension has stride 1, we can do the transfer
1625 in contiguous chunks. */
1631 data
= GFC_DESCRIPTOR_DATA (desc
);
1635 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1636 data
+= stride0
* size
* tsize
;
1639 while (count
[n
] == extent
[n
])
1642 data
-= stride
[n
] * extent
[n
] * size
;
1652 data
+= stride
[n
] * size
;
1659 /* Preposition a sequential unformatted file while reading. */
1662 us_read (st_parameter_dt
*dtp
, int continued
)
1669 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1672 if (compile_options
.record_marker
== 0)
1673 n
= sizeof (GFC_INTEGER_4
);
1675 n
= compile_options
.record_marker
;
1679 if (sread (dtp
->u
.p
.current_unit
->s
, &i
, &n
) != 0)
1681 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1687 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1688 return; /* end of file */
1693 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1697 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1698 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1702 case sizeof(GFC_INTEGER_4
):
1703 memcpy (&i4
, &i
, sizeof (i4
));
1707 case sizeof(GFC_INTEGER_8
):
1708 memcpy (&i8
, &i
, sizeof (i8
));
1713 runtime_error ("Illegal value for record marker");
1720 case sizeof(GFC_INTEGER_4
):
1721 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1725 case sizeof(GFC_INTEGER_8
):
1726 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1731 runtime_error ("Illegal value for record marker");
1737 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1738 dtp
->u
.p
.current_unit
->continued
= 0;
1742 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1743 dtp
->u
.p
.current_unit
->continued
= 1;
1747 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1751 /* Preposition a sequential unformatted file while writing. This
1752 amount to writing a bogus length that will be filled in later. */
1755 us_write (st_parameter_dt
*dtp
, int continued
)
1762 if (compile_options
.record_marker
== 0)
1763 nbytes
= sizeof (GFC_INTEGER_4
);
1765 nbytes
= compile_options
.record_marker
;
1767 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1768 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1770 /* For sequential unformatted, if RECL= was not specified in the OPEN
1771 we write until we have more bytes than can fit in the subrecord
1772 markers, then we write a new subrecord. */
1774 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1775 dtp
->u
.p
.current_unit
->recl_subrecord
;
1776 dtp
->u
.p
.current_unit
->continued
= continued
;
1780 /* Position to the next record prior to transfer. We are assumed to
1781 be before the next record. We also calculate the bytes in the next
1785 pre_position (st_parameter_dt
*dtp
)
1787 if (dtp
->u
.p
.current_unit
->current_record
)
1788 return; /* Already positioned. */
1790 switch (current_mode (dtp
))
1792 case FORMATTED_STREAM
:
1793 case UNFORMATTED_STREAM
:
1794 /* There are no records with stream I/O. If the position was specified
1795 data_transfer_init has already positioned the file. If no position
1796 was specified, we continue from where we last left off. I.e.
1797 there is nothing to do here. */
1800 case UNFORMATTED_SEQUENTIAL
:
1801 if (dtp
->u
.p
.mode
== READING
)
1808 case FORMATTED_SEQUENTIAL
:
1809 case FORMATTED_DIRECT
:
1810 case UNFORMATTED_DIRECT
:
1811 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1815 dtp
->u
.p
.current_unit
->current_record
= 1;
1819 /* Initialize things for a data transfer. This code is common for
1820 both reading and writing. */
1823 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1825 unit_flags u_flags
; /* Used for creating a unit if needed. */
1826 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1827 namelist_info
*ionml
;
1829 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1831 /* To maintain ABI, &transfer is the start of the private memory area in
1832 in st_parameter_dt. Memory from the beginning of the structure to this
1833 point is set by the front end and must not be touched. The number of
1834 bytes to clear must stay within the sizeof q to avoid over-writing. */
1835 memset (&dtp
->u
.p
.transfer
, 0, sizeof (dtp
->u
.q
));
1837 dtp
->u
.p
.ionml
= ionml
;
1838 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1840 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1843 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1844 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1846 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1847 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1848 { /* Open the unit with some default flags. */
1849 st_parameter_open opp
;
1852 if (dtp
->common
.unit
< 0)
1854 close_unit (dtp
->u
.p
.current_unit
);
1855 dtp
->u
.p
.current_unit
= NULL
;
1856 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1857 "Bad unit number in OPEN statement");
1860 memset (&u_flags
, '\0', sizeof (u_flags
));
1861 u_flags
.access
= ACCESS_SEQUENTIAL
;
1862 u_flags
.action
= ACTION_READWRITE
;
1864 /* Is it unformatted? */
1865 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1866 | IOPARM_DT_IONML_SET
)))
1867 u_flags
.form
= FORM_UNFORMATTED
;
1869 u_flags
.form
= FORM_UNSPECIFIED
;
1871 u_flags
.delim
= DELIM_UNSPECIFIED
;
1872 u_flags
.blank
= BLANK_UNSPECIFIED
;
1873 u_flags
.pad
= PAD_UNSPECIFIED
;
1874 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1875 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1876 u_flags
.async
= ASYNC_UNSPECIFIED
;
1877 u_flags
.round
= ROUND_UNSPECIFIED
;
1878 u_flags
.sign
= SIGN_UNSPECIFIED
;
1880 u_flags
.status
= STATUS_UNKNOWN
;
1882 conv
= get_unformatted_convert (dtp
->common
.unit
);
1884 if (conv
== GFC_CONVERT_NONE
)
1885 conv
= compile_options
.convert
;
1887 /* We use big_endian, which is 0 on little-endian machines
1888 and 1 on big-endian machines. */
1891 case GFC_CONVERT_NATIVE
:
1892 case GFC_CONVERT_SWAP
:
1895 case GFC_CONVERT_BIG
:
1896 conv
= big_endian
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1899 case GFC_CONVERT_LITTLE
:
1900 conv
= big_endian
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1904 internal_error (&opp
.common
, "Illegal value for CONVERT");
1908 u_flags
.convert
= conv
;
1910 opp
.common
= dtp
->common
;
1911 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1912 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1913 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1914 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1915 if (dtp
->u
.p
.current_unit
== NULL
)
1919 /* Check the action. */
1921 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1923 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1924 "Cannot read from file opened for WRITE");
1928 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1930 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1931 "Cannot write to file opened for READ");
1935 dtp
->u
.p
.first_item
= 1;
1937 /* Check the format. */
1939 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1942 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1943 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1946 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1947 "Format present for UNFORMATTED data transfer");
1951 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1953 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1954 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1955 "A format cannot be specified with a namelist");
1957 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1958 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1960 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1961 "Missing format for FORMATTED data transfer");
1964 if (is_internal_unit (dtp
)
1965 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1967 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1968 "Internal file cannot be accessed by UNFORMATTED "
1973 /* Check the record or position number. */
1975 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1976 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1978 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1979 "Direct access data transfer requires record number");
1983 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1984 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1986 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1987 "Record number not allowed for sequential access "
1992 /* Process the ADVANCE option. */
1994 dtp
->u
.p
.advance_status
1995 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1996 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1997 "Bad ADVANCE parameter in data transfer statement");
1999 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
2001 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2003 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2004 "ADVANCE specification conflicts with sequential "
2009 if (is_internal_unit (dtp
))
2011 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2012 "ADVANCE specification conflicts with internal file");
2016 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
2017 != IOPARM_DT_HAS_FORMAT
)
2019 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2020 "ADVANCE specification requires an explicit format");
2027 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
2029 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2031 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2032 "EOR specification requires an ADVANCE specification "
2037 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0
2038 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2040 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
2041 "SIZE specification requires an ADVANCE "
2042 "specification of NO");
2047 { /* Write constraints. */
2048 if ((cf
& IOPARM_END
) != 0)
2050 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2051 "END specification cannot appear in a write "
2056 if ((cf
& IOPARM_EOR
) != 0)
2058 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2059 "EOR specification cannot appear in a write "
2064 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2066 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2067 "SIZE specification cannot appear in a write "
2073 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2074 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2076 /* To maintain ABI check these only if we have the F2003 flag set. */
2077 if(cf
& IOPARM_DT_HAS_F2003
)
2079 /* Check the decimal mode. */
2080 dtp
->u
.p
.decimal_status
2081 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2082 find_option (&dtp
->common
, dtp
->u
.p
.decimal
, dtp
->u
.p
.decimal_len
,
2083 decimal_opt
, "Bad DECIMAL parameter in data transfer "
2086 if (dtp
->u
.p
.decimal_status
== DECIMAL_UNSPECIFIED
)
2087 dtp
->u
.p
.decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2089 /* Check the sign mode. */
2090 dtp
->u
.p
.sign_status
2091 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2092 find_option (&dtp
->common
, dtp
->u
.p
.sign
, dtp
->u
.p
.sign_len
, sign_opt
,
2093 "Bad SIGN parameter in data transfer statement");
2095 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2096 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2098 /* Check the blank mode. */
2099 dtp
->u
.p
.blank_status
2100 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2101 find_option (&dtp
->common
, dtp
->u
.p
.blank
, dtp
->u
.p
.blank_len
,
2103 "Bad BLANK parameter in data transfer statement");
2105 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2106 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2108 /* Check the delim mode. */
2109 dtp
->u
.p
.delim_status
2110 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2111 find_option (&dtp
->common
, dtp
->u
.p
.delim
, dtp
->u
.p
.delim_len
,
2113 "Bad DELIM parameter in data transfer statement");
2115 if (dtp
->u
.p
.delim_status
== DELIM_UNSPECIFIED
)
2116 dtp
->u
.p
.delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2118 /* Check the pad mode. */
2120 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2121 find_option (&dtp
->common
, dtp
->u
.p
.pad
, dtp
->u
.p
.pad_len
, pad_opt
,
2122 "Bad PAD parameter in data transfer statement");
2124 if (dtp
->u
.p
.pad_status
== PAD_UNSPECIFIED
)
2125 dtp
->u
.p
.pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2128 /* Sanity checks on the record number. */
2129 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2133 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2134 "Record number must be positive");
2138 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2140 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2141 "Record number too large");
2145 /* Check to see if we might be reading what we wrote before */
2147 if (dtp
->u
.p
.mode
== READING
2148 && dtp
->u
.p
.current_unit
->mode
== WRITING
2149 && !is_internal_unit (dtp
))
2151 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2152 flush(dtp
->u
.p
.current_unit
->s
);
2155 /* Check whether the record exists to be read. Only
2156 a partial record needs to exist. */
2158 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2159 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2161 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2162 "Non-existing record number");
2166 /* Position the file. */
2167 if (!is_stream_io (dtp
))
2169 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2170 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2172 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2178 if (dtp
->u
.p
.current_unit
->strm_pos
!= dtp
->rec
)
2180 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2181 flush (dtp
->u
.p
.current_unit
->s
);
2182 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->rec
- 1) == FAILURE
)
2184 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2187 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2193 /* Overwriting an existing sequential file ?
2194 it is always safe to truncate the file on the first write */
2195 if (dtp
->u
.p
.mode
== WRITING
2196 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2197 && dtp
->u
.p
.current_unit
->last_record
== 0
2198 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2199 struncate(dtp
->u
.p
.current_unit
->s
);
2201 /* Bugware for badly written mixed C-Fortran I/O. */
2202 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2204 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2206 /* Set the maximum position reached from the previous I/O operation. This
2207 could be greater than zero from a previous non-advancing write. */
2208 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2213 /* Set up the subroutine that will handle the transfers. */
2217 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2218 dtp
->u
.p
.transfer
= unformatted_read
;
2221 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2222 dtp
->u
.p
.transfer
= list_formatted_read
;
2224 dtp
->u
.p
.transfer
= formatted_transfer
;
2229 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2230 dtp
->u
.p
.transfer
= unformatted_write
;
2233 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2234 dtp
->u
.p
.transfer
= list_formatted_write
;
2236 dtp
->u
.p
.transfer
= formatted_transfer
;
2240 /* Make sure that we don't do a read after a nonadvancing write. */
2244 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2246 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2247 "Cannot READ after a nonadvancing WRITE");
2253 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2254 dtp
->u
.p
.current_unit
->read_bad
= 1;
2257 /* Start the data transfer if we are doing a formatted transfer. */
2258 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2259 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2260 && dtp
->u
.p
.ionml
== NULL
)
2261 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2264 /* Initialize an array_loop_spec given the array descriptor. The function
2265 returns the index of the last element of the array, and also returns
2266 starting record, where the first I/O goes to (necessary in case of
2267 negative strides). */
2270 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2271 gfc_offset
*start_record
)
2273 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2282 for (i
=0; i
<rank
; i
++)
2284 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2285 ls
[i
].start
= desc
->dim
[i
].lbound
;
2286 ls
[i
].end
= desc
->dim
[i
].ubound
;
2287 ls
[i
].step
= desc
->dim
[i
].stride
;
2288 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2290 if (desc
->dim
[i
].stride
> 0)
2292 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2293 * desc
->dim
[i
].stride
;
2297 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2298 * desc
->dim
[i
].stride
;
2299 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2300 * desc
->dim
[i
].stride
;
2310 /* Determine the index to the next record in an internal unit array by
2311 by incrementing through the array_loop_spec. */
2314 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2322 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2327 if (ls
[i
].idx
> ls
[i
].end
)
2329 ls
[i
].idx
= ls
[i
].start
;
2335 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2345 /* Skip to the end of the current record, taking care of an optional
2346 record marker of size bytes. If the file is not seekable, we
2347 read chunks of size MAX_READ until we get to the right
2351 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2355 static const size_t MAX_READ
= 4096;
2358 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2359 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2362 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2364 new = file_position (dtp
->u
.p
.current_unit
->s
)
2365 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2367 /* Direct access files do not generate END conditions,
2369 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2370 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2373 { /* Seek by reading data. */
2374 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2377 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2378 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2380 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2382 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2386 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2393 /* Advance to the next record reading unformatted files, taking
2394 care of subrecords. If complete_record is nonzero, we loop
2395 until all subrecords are cleared. */
2398 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2402 bytes
= compile_options
.record_marker
== 0 ?
2403 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2408 /* Skip over tail */
2410 skip_record (dtp
, bytes
);
2412 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2420 static inline gfc_offset
2421 min_off (gfc_offset a
, gfc_offset b
)
2423 return (a
< b
? a
: b
);
2427 /* Space to the next record for read mode. */
2430 next_record_r (st_parameter_dt
*dtp
)
2437 switch (current_mode (dtp
))
2439 /* No records in unformatted STREAM I/O. */
2440 case UNFORMATTED_STREAM
:
2443 case UNFORMATTED_SEQUENTIAL
:
2444 next_record_r_unf (dtp
, 1);
2445 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2448 case FORMATTED_DIRECT
:
2449 case UNFORMATTED_DIRECT
:
2450 skip_record (dtp
, 0);
2453 case FORMATTED_STREAM
:
2454 case FORMATTED_SEQUENTIAL
:
2456 /* sf_read has already terminated input because of an '\n' */
2457 if (dtp
->u
.p
.sf_seen_eor
)
2459 dtp
->u
.p
.sf_seen_eor
= 0;
2463 if (is_internal_unit (dtp
))
2465 if (is_array_io (dtp
))
2469 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2472 /* Now seek to this record. */
2473 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2474 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2476 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2479 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2483 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2484 bytes_left
= min_off (bytes_left
,
2485 file_length (dtp
->u
.p
.current_unit
->s
)
2486 - file_position (dtp
->u
.p
.current_unit
->s
));
2487 if (sseek (dtp
->u
.p
.current_unit
->s
,
2488 file_position (dtp
->u
.p
.current_unit
->s
)
2489 + bytes_left
) == FAILURE
)
2491 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2494 dtp
->u
.p
.current_unit
->bytes_left
2495 = dtp
->u
.p
.current_unit
->recl
;
2501 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2503 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2509 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2513 if (is_stream_io (dtp
))
2514 dtp
->u
.p
.current_unit
->strm_pos
++;
2521 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2522 && !dtp
->u
.p
.namelist_mode
2523 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2524 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2525 file_position (dtp
->u
.p
.current_unit
->s
)))
2526 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2531 /* Small utility function to write a record marker, taking care of
2532 byte swapping and of choosing the correct size. */
2535 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2540 char p
[sizeof (GFC_INTEGER_8
)];
2542 if (compile_options
.record_marker
== 0)
2543 len
= sizeof (GFC_INTEGER_4
);
2545 len
= compile_options
.record_marker
;
2547 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2548 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2552 case sizeof (GFC_INTEGER_4
):
2554 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2557 case sizeof (GFC_INTEGER_8
):
2559 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2563 runtime_error ("Illegal value for record marker");
2571 case sizeof (GFC_INTEGER_4
):
2573 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2574 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2577 case sizeof (GFC_INTEGER_8
):
2579 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2580 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2584 runtime_error ("Illegal value for record marker");
2591 /* Position to the next (sub)record in write mode for
2592 unformatted sequential files. */
2595 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2597 gfc_offset c
, m
, m_write
;
2598 size_t record_marker
;
2600 /* Bytes written. */
2601 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2602 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2603 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2605 /* Write the length tail. If we finish a record containing
2606 subrecords, we write out the negative length. */
2608 if (dtp
->u
.p
.current_unit
->continued
)
2613 if (write_us_marker (dtp
, m_write
) != 0)
2616 if (compile_options
.record_marker
== 0)
2617 record_marker
= sizeof (GFC_INTEGER_4
);
2619 record_marker
= compile_options
.record_marker
;
2621 /* Seek to the head and overwrite the bogus length with the real
2624 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2633 if (write_us_marker (dtp
, m_write
) != 0)
2636 /* Seek past the end of the current record. */
2638 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2644 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2649 /* Position to the next record in write mode. */
2652 next_record_w (st_parameter_dt
*dtp
, int done
)
2654 gfc_offset m
, record
, max_pos
;
2657 /* Flush and reset the format buffer. */
2658 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2660 /* Zero counters for X- and T-editing. */
2661 max_pos
= dtp
->u
.p
.max_pos
;
2662 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2664 switch (current_mode (dtp
))
2666 /* No records in unformatted STREAM I/O. */
2667 case UNFORMATTED_STREAM
:
2670 case FORMATTED_DIRECT
:
2671 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2674 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2675 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2680 case UNFORMATTED_DIRECT
:
2681 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2683 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2684 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2689 case UNFORMATTED_SEQUENTIAL
:
2690 next_record_w_unf (dtp
, 0);
2691 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2694 case FORMATTED_STREAM
:
2695 case FORMATTED_SEQUENTIAL
:
2697 if (is_internal_unit (dtp
))
2699 if (is_array_io (dtp
))
2703 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2705 /* If the farthest position reached is greater than current
2706 position, adjust the position and set length to pad out
2707 whats left. Otherwise just pad whats left.
2708 (for character array unit) */
2709 m
= dtp
->u
.p
.current_unit
->recl
2710 - dtp
->u
.p
.current_unit
->bytes_left
;
2713 length
= (int) (max_pos
- m
);
2714 if (sseek (dtp
->u
.p
.current_unit
->s
,
2715 file_position (dtp
->u
.p
.current_unit
->s
)
2716 + length
) == FAILURE
)
2718 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2721 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2724 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2726 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2730 /* Now that the current record has been padded out,
2731 determine where the next record in the array is. */
2732 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2735 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2737 /* Now seek to this record */
2738 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2740 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2742 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2746 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2752 /* If this is the last call to next_record move to the farthest
2753 position reached and set length to pad out the remainder
2754 of the record. (for character scaler unit) */
2757 m
= dtp
->u
.p
.current_unit
->recl
2758 - dtp
->u
.p
.current_unit
->bytes_left
;
2761 length
= (int) (max_pos
- m
);
2762 if (sseek (dtp
->u
.p
.current_unit
->s
,
2763 file_position (dtp
->u
.p
.current_unit
->s
)
2764 + length
) == FAILURE
)
2766 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2769 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2772 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2775 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2777 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2785 const char crlf
[] = "\r\n";
2792 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2795 if (is_stream_io (dtp
))
2797 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2798 if (dtp
->u
.p
.current_unit
->strm_pos
2799 < file_length (dtp
->u
.p
.current_unit
->s
))
2800 struncate (dtp
->u
.p
.current_unit
->s
);
2807 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2812 /* Position to the next record, which means moving to the end of the
2813 current record. This can happen under several different
2814 conditions. If the done flag is not set, we get ready to process
2818 next_record (st_parameter_dt
*dtp
, int done
)
2820 gfc_offset fp
; /* File position. */
2822 dtp
->u
.p
.current_unit
->read_bad
= 0;
2824 if (dtp
->u
.p
.mode
== READING
)
2825 next_record_r (dtp
);
2827 next_record_w (dtp
, done
);
2829 if (!is_stream_io (dtp
))
2831 /* Keep position up to date for INQUIRE */
2833 update_position (dtp
->u
.p
.current_unit
);
2835 dtp
->u
.p
.current_unit
->current_record
= 0;
2836 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2838 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2839 /* Calculate next record, rounding up partial records. */
2840 dtp
->u
.p
.current_unit
->last_record
=
2841 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2842 dtp
->u
.p
.current_unit
->recl
;
2845 dtp
->u
.p
.current_unit
->last_record
++;
2853 /* Finalize the current data transfer. For a nonadvancing transfer,
2854 this means advancing to the next record. For internal units close the
2855 stream associated with the unit. */
2858 finalize_transfer (st_parameter_dt
*dtp
)
2861 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2863 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2864 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2866 if (dtp
->u
.p
.eor_condition
)
2868 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2872 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2875 if ((dtp
->u
.p
.ionml
!= NULL
)
2876 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2878 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2879 namelist_read (dtp
);
2881 namelist_write (dtp
);
2884 dtp
->u
.p
.transfer
= NULL
;
2885 if (dtp
->u
.p
.current_unit
== NULL
)
2888 dtp
->u
.p
.eof_jump
= &eof_jump
;
2889 if (setjmp (eof_jump
))
2891 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2895 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2897 finish_list_read (dtp
);
2898 sfree (dtp
->u
.p
.current_unit
->s
);
2902 if (dtp
->u
.p
.mode
== WRITING
)
2903 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2904 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2906 if (is_stream_io (dtp
))
2908 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2909 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2910 next_record (dtp
, 1);
2912 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2913 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2915 flush (dtp
->u
.p
.current_unit
->s
);
2916 sfree (dtp
->u
.p
.current_unit
->s
);
2921 dtp
->u
.p
.current_unit
->current_record
= 0;
2923 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2925 dtp
->u
.p
.seen_dollar
= 0;
2926 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2927 sfree (dtp
->u
.p
.current_unit
->s
);
2931 /* For non-advancing I/O, save the current maximum position for use in the
2932 next I/O operation if needed. */
2933 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2935 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2936 - dtp
->u
.p
.current_unit
->bytes_left
);
2937 dtp
->u
.p
.current_unit
->saved_pos
=
2938 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2939 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2940 flush (dtp
->u
.p
.current_unit
->s
);
2944 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2946 next_record (dtp
, 1);
2947 sfree (dtp
->u
.p
.current_unit
->s
);
2950 /* Transfer function for IOLENGTH. It doesn't actually do any
2951 data transfer, it just updates the length counter. */
2954 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2955 void *dest
__attribute__ ((unused
)),
2956 int kind
__attribute__((unused
)),
2957 size_t size
, size_t nelems
)
2959 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2960 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2964 /* Initialize the IOLENGTH data transfer. This function is in essence
2965 a very much simplified version of data_transfer_init(), because it
2966 doesn't have to deal with units at all. */
2969 iolength_transfer_init (st_parameter_dt
*dtp
)
2971 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2974 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2976 /* Set up the subroutine that will handle the transfers. */
2978 dtp
->u
.p
.transfer
= iolength_transfer
;
2982 /* Library entry point for the IOLENGTH form of the INQUIRE
2983 statement. The IOLENGTH form requires no I/O to be performed, but
2984 it must still be a runtime library call so that we can determine
2985 the iolength for dynamic arrays and such. */
2987 extern void st_iolength (st_parameter_dt
*);
2988 export_proto(st_iolength
);
2991 st_iolength (st_parameter_dt
*dtp
)
2993 library_start (&dtp
->common
);
2994 iolength_transfer_init (dtp
);
2997 extern void st_iolength_done (st_parameter_dt
*);
2998 export_proto(st_iolength_done
);
3001 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
3004 if (dtp
->u
.p
.scratch
!= NULL
)
3005 free_mem (dtp
->u
.p
.scratch
);
3010 /* The READ statement. */
3012 extern void st_read (st_parameter_dt
*);
3013 export_proto(st_read
);
3016 st_read (st_parameter_dt
*dtp
)
3018 library_start (&dtp
->common
);
3020 data_transfer_init (dtp
, 1);
3022 /* Handle complications dealing with the endfile record. */
3024 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3025 switch (dtp
->u
.p
.current_unit
->endfile
)
3031 if (!is_internal_unit (dtp
))
3033 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
3034 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
3035 dtp
->u
.p
.current_unit
->current_record
= 0;
3040 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
3041 dtp
->u
.p
.current_unit
->current_record
= 0;
3046 extern void st_read_done (st_parameter_dt
*);
3047 export_proto(st_read_done
);
3050 st_read_done (st_parameter_dt
*dtp
)
3052 finalize_transfer (dtp
);
3053 free_format_data (dtp
);
3055 if (dtp
->u
.p
.scratch
!= NULL
)
3056 free_mem (dtp
->u
.p
.scratch
);
3057 if (dtp
->u
.p
.current_unit
!= NULL
)
3058 unlock_unit (dtp
->u
.p
.current_unit
);
3060 free_internal_unit (dtp
);
3065 extern void st_write (st_parameter_dt
*);
3066 export_proto(st_write
);
3069 st_write (st_parameter_dt
*dtp
)
3071 library_start (&dtp
->common
);
3072 data_transfer_init (dtp
, 0);
3075 extern void st_write_done (st_parameter_dt
*);
3076 export_proto(st_write_done
);
3079 st_write_done (st_parameter_dt
*dtp
)
3081 finalize_transfer (dtp
);
3083 /* Deal with endfile conditions associated with sequential files. */
3085 if (dtp
->u
.p
.current_unit
!= NULL
3086 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3087 switch (dtp
->u
.p
.current_unit
->endfile
)
3089 case AT_ENDFILE
: /* Remain at the endfile record. */
3093 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3097 /* Get rid of whatever is after this record. */
3098 if (!is_internal_unit (dtp
))
3100 flush (dtp
->u
.p
.current_unit
->s
);
3101 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3102 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3104 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3108 free_format_data (dtp
);
3110 if (dtp
->u
.p
.scratch
!= NULL
)
3111 free_mem (dtp
->u
.p
.scratch
);
3112 if (dtp
->u
.p
.current_unit
!= NULL
)
3113 unlock_unit (dtp
->u
.p
.current_unit
);
3115 free_internal_unit (dtp
);
3121 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3123 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3128 /* Receives the scalar information for namelist objects and stores it
3129 in a linked list of namelist_info types. */
3131 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3132 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3133 export_proto(st_set_nml_var
);
3137 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3138 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3139 GFC_INTEGER_4 dtype
)
3141 namelist_info
*t1
= NULL
;
3143 size_t var_name_len
= strlen (var_name
);
3145 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3147 nml
->mem_pos
= var_addr
;
3149 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3150 memcpy (nml
->var_name
, var_name
, var_name_len
);
3151 nml
->var_name
[var_name_len
] = '\0';
3153 nml
->len
= (int) len
;
3154 nml
->string_length
= (index_type
) string_length
;
3156 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3157 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3158 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3160 if (nml
->var_rank
> 0)
3162 nml
->dim
= (descriptor_dimension
*)
3163 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3164 nml
->ls
= (array_loop_spec
*)
3165 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3175 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3177 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3178 dtp
->u
.p
.ionml
= nml
;
3182 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3187 /* Store the dimensional information for the namelist object. */
3188 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3189 index_type
, index_type
,
3191 export_proto(st_set_nml_var_dim
);
3194 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3195 index_type stride
, index_type lbound
,
3198 namelist_info
* nml
;
3203 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3205 nml
->dim
[n
].stride
= stride
;
3206 nml
->dim
[n
].lbound
= lbound
;
3207 nml
->dim
[n
].ubound
= ubound
;
3210 /* Reverse memcpy - used for byte swapping. */
3212 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3218 s
= (char *) src
+ n
- 1;
3220 /* Write with ascending order - this is likely faster
3221 on modern architectures because of write combining. */