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. */
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
59 These subroutines do not return status.
61 The last call is a call to st_[read|write]_done(). While
62 something can easily go wrong with the initial st_read() or
63 st_write(), an error inhibits any data from actually being
66 extern void transfer_integer (st_parameter_dt
*, void *, int);
67 export_proto(transfer_integer
);
69 extern void transfer_real (st_parameter_dt
*, void *, int);
70 export_proto(transfer_real
);
72 extern void transfer_logical (st_parameter_dt
*, void *, int);
73 export_proto(transfer_logical
);
75 extern void transfer_character (st_parameter_dt
*, void *, int);
76 export_proto(transfer_character
);
78 extern void transfer_complex (st_parameter_dt
*, void *, int);
79 export_proto(transfer_complex
);
81 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
83 export_proto(transfer_array
);
85 static void us_read (st_parameter_dt
*, int);
86 static void us_write (st_parameter_dt
*, int);
87 static void next_record_r_unf (st_parameter_dt
*, int);
88 static void next_record_w_unf (st_parameter_dt
*, int);
90 static const st_option advance_opt
[] = {
97 static const st_option decimal_opt
[] = {
98 {"point", DECIMAL_POINT
},
99 {"comma", DECIMAL_COMMA
},
104 static const st_option sign_opt
[] = {
106 {"suppress", SIGN_SS
},
107 {"processor_defined", SIGN_S
},
111 static const st_option blank_opt
[] = {
112 {"null", BLANK_NULL
},
113 {"zero", BLANK_ZERO
},
117 static const st_option delim_opt
[] = {
118 {"apostrophe", DELIM_APOSTROPHE
},
119 {"quote", DELIM_QUOTE
},
120 {"none", DELIM_NONE
},
124 static const st_option pad_opt
[] = {
131 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
132 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
138 current_mode (st_parameter_dt
*dtp
)
142 m
= FORM_UNSPECIFIED
;
144 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
146 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
147 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
149 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
151 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
152 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
154 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
156 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
157 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
164 /* Mid level data transfer statements. These subroutines do reading
165 and writing in the style of salloc_r()/salloc_w() within the
168 /* When reading sequential formatted records we have a problem. We
169 don't know how long the line is until we read the trailing newline,
170 and we don't want to read too much. If we read too much, we might
171 have to do a physical seek backwards depending on how much data is
172 present, and devices like terminals aren't seekable and would cause
175 Given this, the solution is to read a byte at a time, stopping if
176 we hit the newline. For small allocations, we use a static buffer.
177 For larger allocations, we are forced to allocate memory on the
178 heap. Hopefully this won't happen very often. */
181 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
184 int n
, readlen
, crlf
;
187 if (*length
> SCRATCH_SIZE
)
188 dtp
->u
.p
.line_buffer
= get_mem (*length
);
189 p
= base
= dtp
->u
.p
.line_buffer
;
191 /* If we have seen an eor previously, return a length of 0. The
192 caller is responsible for correctly padding the input field. */
193 if (dtp
->u
.p
.sf_seen_eor
)
199 if (is_internal_unit (dtp
))
202 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
203 if (readlen
< *length
)
205 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
210 memcpy (p
, q
, readlen
);
219 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
223 /* If we have a line without a terminating \n, drop through to
225 if (readlen
< 1 && n
== 0)
229 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
233 if (readlen
< 1 || *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;
243 /* If we encounter a CR, it might be a CRLF. */
244 if (*q
== '\r') /* Probably a CRLF */
247 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
248 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
249 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
250 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
255 /* Without padding, terminate the I/O statement without assigning
256 the value. With padding, the value still needs to be assigned,
257 so we can just continue with a short read. */
258 if (dtp
->u
.p
.pad_status
== PAD_NO
)
262 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
267 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
270 /* Short circuit the read if a comma is found during numeric input.
271 The flag is set to zero during character reads so that commas in
272 strings are not ignored */
274 if (dtp
->u
.p
.sf_read_comma
== 1)
276 notify_std (&dtp
->common
, GFC_STD_GNU
,
277 "Comma in formatted numeric read.");
284 dtp
->u
.p
.sf_seen_eor
= 0;
289 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
291 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
292 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
298 /* Function for reading the next couple of bytes from the current
299 file, advancing the current position. We return a pointer to a
300 buffer containing the bytes. We return NULL on end of record or
303 If the read is short, then it is because the current record does not
304 have enough data to satisfy the read request and the file was
305 opened with PAD=YES. The caller must assume tailing spaces for
309 read_block (st_parameter_dt
*dtp
, int *length
)
314 if (is_stream_io (dtp
))
316 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
317 != file_position (dtp
->u
.p
.current_unit
->s
)
318 && sseek (dtp
->u
.p
.current_unit
->s
,
319 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
321 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
327 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
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
->u
.p
.pad_status
== PAD_NO
)
338 /* Not enough data left. */
339 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
344 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
346 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
347 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
351 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
355 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
356 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
357 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
359 source
= read_sf (dtp
, length
, 0);
360 dtp
->u
.p
.current_unit
->strm_pos
+=
361 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
364 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
367 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
369 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
370 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
372 if (nread
!= *length
)
373 { /* Short read, this shouldn't happen. */
374 if (dtp
->u
.p
.pad_status
== PAD_YES
)
378 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
383 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
389 /* Reads a block directly into application data space. This is for
390 unformatted files. */
393 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
395 size_t to_read_record
;
396 size_t have_read_record
;
397 size_t to_read_subrecord
;
398 size_t have_read_subrecord
;
401 if (is_stream_io (dtp
))
403 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
404 != file_position (dtp
->u
.p
.current_unit
->s
)
405 && sseek (dtp
->u
.p
.current_unit
->s
,
406 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
408 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
412 to_read_record
= *nbytes
;
413 have_read_record
= to_read_record
;
414 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
416 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
420 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
422 if (to_read_record
!= have_read_record
)
424 /* Short read, e.g. if we hit EOF. For stream files,
425 we have to set the end-of-file condition. */
426 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
432 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
434 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
437 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
438 *nbytes
= to_read_record
;
444 to_read_record
= *nbytes
;
447 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
449 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
451 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
455 if (to_read_record
!= *nbytes
)
457 /* Short read, e.g. if we hit EOF. Apparently, we read
458 more than was written to the last record. */
459 *nbytes
= to_read_record
;
465 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
471 /* Unformatted sequential. We loop over the subrecords, reading
472 until the request has been fulfilled or the record has run out
473 of continuation subrecords. */
475 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
477 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
481 /* Check whether we exceed the total record length. */
483 if (dtp
->u
.p
.current_unit
->flags
.has_recl
484 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
486 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
491 to_read_record
= *nbytes
;
494 have_read_record
= 0;
498 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
499 < (gfc_offset
) to_read_record
)
501 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
502 to_read_record
-= to_read_subrecord
;
506 to_read_subrecord
= to_read_record
;
510 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
512 have_read_subrecord
= to_read_subrecord
;
513 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
514 &have_read_subrecord
) != 0)
516 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
520 have_read_record
+= have_read_subrecord
;
522 if (to_read_subrecord
!= have_read_subrecord
)
525 /* Short read, e.g. if we hit EOF. This means the record
526 structure has been corrupted, or the trailing record
527 marker would still be present. */
529 *nbytes
= have_read_record
;
530 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
534 if (to_read_record
> 0)
536 if (dtp
->u
.p
.current_unit
->continued
)
538 next_record_r_unf (dtp
, 0);
543 /* Let's make sure the file position is correctly pre-positioned
544 for the next read statement. */
546 dtp
->u
.p
.current_unit
->current_record
= 0;
547 next_record_r_unf (dtp
, 0);
548 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
554 /* Normal exit, the read request has been fulfilled. */
559 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
562 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
569 /* Function for writing a block of bytes to the current file at the
570 current position, advancing the file pointer. We are given a length
571 and return a pointer to a buffer that the caller must (completely)
572 fill in. Returns NULL on error. */
575 write_block (st_parameter_dt
*dtp
, int length
)
579 if (is_stream_io (dtp
))
581 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
582 != file_position (dtp
->u
.p
.current_unit
->s
)
583 && sseek (dtp
->u
.p
.current_unit
->s
,
584 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
586 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
592 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
594 /* For preconnected units with default record length, set bytes left
595 to unit record length and proceed, otherwise error. */
596 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
597 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
598 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
599 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
602 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
607 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
610 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
614 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
618 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
619 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
621 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
622 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
624 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
630 /* High level interface to swrite(), taking care of errors. This is only
631 called for unformatted files. There are three cases to consider:
632 Stream I/O, unformatted direct, unformatted sequential. */
635 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
638 size_t have_written
, to_write_subrecord
;
643 if (is_stream_io (dtp
))
645 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
646 != file_position (dtp
->u
.p
.current_unit
->s
)
647 && sseek (dtp
->u
.p
.current_unit
->s
,
648 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
650 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
654 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
656 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
660 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
665 /* Unformatted direct access. */
667 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
669 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
671 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
675 if (buf
== NULL
&& nbytes
== 0)
678 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
680 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
684 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
685 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
690 /* Unformatted sequential. */
694 if (dtp
->u
.p
.current_unit
->flags
.has_recl
695 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
697 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
709 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
710 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
712 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
713 (gfc_offset
) to_write_subrecord
;
715 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
716 &to_write_subrecord
) != 0)
718 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
722 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
723 nbytes
-= to_write_subrecord
;
724 have_written
+= to_write_subrecord
;
729 next_record_w_unf (dtp
, 1);
732 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
735 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
742 /* Master function for unformatted reads. */
745 unformatted_read (st_parameter_dt
*dtp
, bt type
,
746 void *dest
, int kind
__attribute__((unused
)),
747 size_t size
, size_t nelems
)
751 /* Currently, character implies size=1. */
752 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
753 || size
== 1 || type
== BT_CHARACTER
)
756 read_block_direct (dtp
, dest
, &sz
);
763 /* Break up complex into its constituent reals. */
764 if (type
== BT_COMPLEX
)
771 /* By now, all complex variables have been split into their
772 constituent reals. */
774 for (i
=0; i
<nelems
; i
++)
776 read_block_direct (dtp
, buffer
, &size
);
777 reverse_memcpy (p
, buffer
, size
);
784 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
785 bytes on 64 bit machines. The unused bytes are not initialized and never
786 used, which can show an error with memory checking analyzers like
790 unformatted_write (st_parameter_dt
*dtp
, bt type
,
791 void *source
, int kind
__attribute__((unused
)),
792 size_t size
, size_t nelems
)
794 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
795 size
== 1 || type
== BT_CHARACTER
)
798 write_buf (dtp
, source
, size
);
806 /* Break up complex into its constituent reals. */
807 if (type
== BT_COMPLEX
)
815 /* By now, all complex variables have been split into their
816 constituent reals. */
819 for (i
=0; i
<nelems
; i
++)
821 reverse_memcpy(buffer
, p
, size
);
823 write_buf (dtp
, buffer
, size
);
829 /* Return a pointer to the name of a type. */
854 internal_error (NULL
, "type_name(): Bad type");
861 /* Write a constant string to the output.
862 This is complicated because the string can have doubled delimiters
863 in it. The length in the format node is the true length. */
866 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
868 char c
, delimiter
, *p
, *q
;
871 length
= f
->u
.string
.length
;
875 p
= write_block (dtp
, length
);
882 for (; length
> 0; length
--)
885 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
886 q
++; /* Skip the doubled delimiter. */
891 /* Given actual and expected types in a formatted data transfer, make
892 sure they agree. If not, an error message is generated. Returns
893 nonzero if something went wrong. */
896 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
900 if (actual
== expected
)
903 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
904 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
906 format_error (dtp
, f
, buffer
);
911 /* This subroutine is the main loop for a formatted data transfer
912 statement. It would be natural to implement this as a coroutine
913 with the user program, but C makes that awkward. We loop,
914 processing format elements. When we actually have to transfer
915 data instead of just setting flags, we return control to the user
916 program which calls a subroutine that supplies the address and type
917 of the next element, then comes back here to process it. */
920 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
923 char scratch
[SCRATCH_SIZE
];
928 int consume_data_flag
;
930 /* Change a complex data item into a pair of reals. */
932 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
933 if (type
== BT_COMPLEX
)
939 /* If there's an EOR condition, we simulate finalizing the transfer
941 if (dtp
->u
.p
.eor_condition
)
944 /* Set this flag so that commas in reads cause the read to complete before
945 the entire field has been read. The next read field will start right after
946 the comma in the stream. (Set to 0 for character reads). */
947 dtp
->u
.p
.sf_read_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
? 0 : 1;
948 dtp
->u
.p
.line_buffer
= scratch
;
952 /* If reversion has occurred and there is another real data item,
953 then we have to move to the next record. */
954 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
956 dtp
->u
.p
.reversion_flag
= 0;
957 next_record (dtp
, 0);
960 consume_data_flag
= 1;
961 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
964 f
= next_format (dtp
);
967 /* No data descriptors left. */
969 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
970 "Insufficient data descriptors in format after reversion");
974 /* Now discharge T, TR and X movements to the right. This is delayed
975 until a data producing format to suppress trailing spaces. */
978 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
979 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
980 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
981 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
982 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
985 if (dtp
->u
.p
.skips
> 0)
988 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
989 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
990 - dtp
->u
.p
.current_unit
->bytes_left
);
992 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
994 if (dtp
->u
.p
.skips
< 0)
996 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
997 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
999 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1002 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
1003 - dtp
->u
.p
.current_unit
->bytes_left
);
1005 if (is_stream_io(dtp
))
1013 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1016 if (dtp
->u
.p
.mode
== READING
)
1017 read_decimal (dtp
, f
, p
, len
);
1019 write_i (dtp
, f
, p
, len
);
1027 if (compile_options
.allow_std
< GFC_STD_GNU
1028 && require_type (dtp
, BT_INTEGER
, type
, f
))
1031 if (dtp
->u
.p
.mode
== READING
)
1032 read_radix (dtp
, f
, p
, len
, 2);
1034 write_b (dtp
, f
, p
, len
);
1042 if (compile_options
.allow_std
< GFC_STD_GNU
1043 && require_type (dtp
, BT_INTEGER
, type
, f
))
1046 if (dtp
->u
.p
.mode
== READING
)
1047 read_radix (dtp
, f
, p
, len
, 8);
1049 write_o (dtp
, f
, p
, len
);
1057 if (compile_options
.allow_std
< GFC_STD_GNU
1058 && require_type (dtp
, BT_INTEGER
, type
, f
))
1061 if (dtp
->u
.p
.mode
== READING
)
1062 read_radix (dtp
, f
, p
, len
, 16);
1064 write_z (dtp
, f
, p
, len
);
1072 if (dtp
->u
.p
.mode
== READING
)
1073 read_a (dtp
, f
, p
, len
);
1075 write_a (dtp
, f
, p
, len
);
1083 if (dtp
->u
.p
.mode
== READING
)
1084 read_l (dtp
, f
, p
, len
);
1086 write_l (dtp
, f
, p
, len
);
1093 if (require_type (dtp
, BT_REAL
, type
, f
))
1096 if (dtp
->u
.p
.mode
== READING
)
1097 read_f (dtp
, f
, p
, len
);
1099 write_d (dtp
, f
, p
, len
);
1106 if (require_type (dtp
, BT_REAL
, type
, f
))
1109 if (dtp
->u
.p
.mode
== READING
)
1110 read_f (dtp
, f
, p
, len
);
1112 write_e (dtp
, f
, p
, len
);
1118 if (require_type (dtp
, BT_REAL
, type
, f
))
1121 if (dtp
->u
.p
.mode
== READING
)
1122 read_f (dtp
, f
, p
, len
);
1124 write_en (dtp
, f
, p
, len
);
1131 if (require_type (dtp
, BT_REAL
, type
, f
))
1134 if (dtp
->u
.p
.mode
== READING
)
1135 read_f (dtp
, f
, p
, len
);
1137 write_es (dtp
, f
, p
, len
);
1144 if (require_type (dtp
, BT_REAL
, type
, f
))
1147 if (dtp
->u
.p
.mode
== READING
)
1148 read_f (dtp
, f
, p
, len
);
1150 write_f (dtp
, f
, p
, len
);
1157 if (dtp
->u
.p
.mode
== READING
)
1161 read_decimal (dtp
, f
, p
, len
);
1164 read_l (dtp
, f
, p
, len
);
1167 read_a (dtp
, f
, p
, len
);
1170 read_f (dtp
, f
, p
, len
);
1179 write_i (dtp
, f
, p
, len
);
1182 write_l (dtp
, f
, p
, len
);
1185 write_a (dtp
, f
, p
, len
);
1188 write_d (dtp
, f
, p
, len
);
1192 internal_error (&dtp
->common
,
1193 "formatted_transfer(): Bad type");
1199 consume_data_flag
= 0;
1200 if (dtp
->u
.p
.mode
== READING
)
1202 format_error (dtp
, f
, "Constant string in input format");
1205 write_constant_string (dtp
, f
);
1208 /* Format codes that don't transfer data. */
1211 consume_data_flag
= 0;
1213 dtp
->u
.p
.skips
+= f
->u
.n
;
1214 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1215 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1217 /* Writes occur just before the switch on f->format, above, so
1218 that trailing blanks are suppressed, unless we are doing a
1219 non-advancing write in which case we want to output the blanks
1221 if (dtp
->u
.p
.mode
== WRITING
1222 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1224 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1225 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1228 if (dtp
->u
.p
.mode
== READING
)
1229 read_x (dtp
, f
->u
.n
);
1235 consume_data_flag
= 0;
1237 if (f
->format
== FMT_TL
)
1240 /* Handle the special case when no bytes have been used yet.
1241 Cannot go below zero. */
1242 if (bytes_used
== 0)
1244 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1245 dtp
->u
.p
.skips
-= f
->u
.n
;
1246 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1249 pos
= bytes_used
- f
->u
.n
;
1253 if (dtp
->u
.p
.mode
== READING
)
1256 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1259 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1260 left tab limit. We do not check if the position has gone
1261 beyond the end of record because a subsequent tab could
1262 bring us back again. */
1263 pos
= pos
< 0 ? 0 : pos
;
1265 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1266 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1267 + pos
- dtp
->u
.p
.max_pos
;
1268 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1269 ? 0 : dtp
->u
.p
.pending_spaces
;
1271 if (dtp
->u
.p
.skips
== 0)
1274 /* Writes occur just before the switch on f->format, above, so that
1275 trailing blanks are suppressed. */
1276 if (dtp
->u
.p
.mode
== READING
)
1278 /* Adjust everything for end-of-record condition */
1279 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1281 if (dtp
->u
.p
.sf_seen_eor
== 2)
1283 /* The EOR was a CRLF (two bytes wide). */
1284 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1285 dtp
->u
.p
.skips
-= 2;
1289 /* The EOR marker was only one byte wide. */
1290 dtp
->u
.p
.current_unit
->bytes_left
--;
1294 dtp
->u
.p
.sf_seen_eor
= 0;
1296 if (dtp
->u
.p
.skips
< 0)
1298 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1299 dtp
->u
.p
.current_unit
->bytes_left
1300 -= (gfc_offset
) dtp
->u
.p
.skips
;
1301 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1304 read_x (dtp
, dtp
->u
.p
.skips
);
1308 if (dtp
->u
.p
.skips
< 0)
1309 flush (dtp
->u
.p
.current_unit
->s
);
1315 consume_data_flag
= 0;
1316 dtp
->u
.p
.sign_status
= SIGN_S
;
1320 consume_data_flag
= 0;
1321 dtp
->u
.p
.sign_status
= SIGN_SS
;
1325 consume_data_flag
= 0;
1326 dtp
->u
.p
.sign_status
= SIGN_SP
;
1330 consume_data_flag
= 0 ;
1331 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1335 consume_data_flag
= 0;
1336 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1340 consume_data_flag
= 0;
1341 dtp
->u
.p
.decimal_status
= DECIMAL_COMMA
;
1345 consume_data_flag
= 0;
1346 dtp
->u
.p
.decimal_status
= DECIMAL_POINT
;
1350 consume_data_flag
= 0;
1351 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1355 consume_data_flag
= 0;
1356 dtp
->u
.p
.seen_dollar
= 1;
1360 consume_data_flag
= 0;
1361 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1362 next_record (dtp
, 0);
1366 /* A colon descriptor causes us to exit this loop (in
1367 particular preventing another / descriptor from being
1368 processed) unless there is another data item to be
1370 consume_data_flag
= 0;
1376 internal_error (&dtp
->common
, "Bad format node");
1379 /* Free a buffer that we had to allocate during a sequential
1380 formatted read of a block that was larger than the static
1383 if (dtp
->u
.p
.line_buffer
!= scratch
)
1385 free_mem (dtp
->u
.p
.line_buffer
);
1386 dtp
->u
.p
.line_buffer
= scratch
;
1389 /* Adjust the item count and data pointer. */
1391 if ((consume_data_flag
> 0) && (n
> 0))
1394 p
= ((char *) p
) + size
;
1397 if (dtp
->u
.p
.mode
== READING
)
1400 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1401 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1407 /* Come here when we need a data descriptor but don't have one. We
1408 push the current format node back onto the input, then return and
1409 let the user program call us back with the data. */
1411 unget_format (dtp
, f
);
1415 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1416 size_t size
, size_t nelems
)
1423 /* Big loop over all the elements. */
1424 for (elem
= 0; elem
< nelems
; elem
++)
1426 dtp
->u
.p
.item_count
++;
1427 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1433 /* Data transfer entry points. The type of the data entity is
1434 implicit in the subroutine call. This prevents us from having to
1435 share a common enum with the compiler. */
1438 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1440 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1442 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1447 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1450 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1452 size
= size_from_real_kind (kind
);
1453 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1458 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1460 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1462 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1467 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1469 static char *empty_string
[0];
1471 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1474 /* Strings of zero length can have p == NULL, which confuses the
1475 transfer routines into thinking we need more data elements. To avoid
1476 this, we give them a nice pointer. */
1477 if (len
== 0 && p
== NULL
)
1480 /* Currently we support only 1 byte chars, and the library is a bit
1481 confused of character kind vs. length, so we kludge it by setting
1483 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1488 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1491 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1493 size
= size_from_complex_kind (kind
);
1494 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1499 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1500 gfc_charlen_type charlen
)
1502 index_type count
[GFC_MAX_DIMENSIONS
];
1503 index_type extent
[GFC_MAX_DIMENSIONS
];
1504 index_type stride
[GFC_MAX_DIMENSIONS
];
1505 index_type stride0
, rank
, size
, type
, n
;
1510 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1513 type
= GFC_DESCRIPTOR_TYPE (desc
);
1514 size
= GFC_DESCRIPTOR_SIZE (desc
);
1516 /* FIXME: What a kludge: Array descriptors and the IO library use
1517 different enums for types. */
1520 case GFC_DTYPE_UNKNOWN
:
1521 iotype
= BT_NULL
; /* Is this correct? */
1523 case GFC_DTYPE_INTEGER
:
1524 iotype
= BT_INTEGER
;
1526 case GFC_DTYPE_LOGICAL
:
1527 iotype
= BT_LOGICAL
;
1529 case GFC_DTYPE_REAL
:
1532 case GFC_DTYPE_COMPLEX
:
1533 iotype
= BT_COMPLEX
;
1535 case GFC_DTYPE_CHARACTER
:
1536 iotype
= BT_CHARACTER
;
1537 /* FIXME: Currently dtype contains the charlen, which is
1538 clobbered if charlen > 2**24. That's why we use a separate
1539 argument for the charlen. However, if we want to support
1540 non-8-bit charsets we need to fix dtype to contain
1541 sizeof(chartype) and fix the code below. */
1545 case GFC_DTYPE_DERIVED
:
1546 internal_error (&dtp
->common
,
1547 "Derived type I/O should have been handled via the frontend.");
1550 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1553 rank
= GFC_DESCRIPTOR_RANK (desc
);
1554 for (n
= 0; n
< rank
; n
++)
1557 stride
[n
] = desc
->dim
[n
].stride
;
1558 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1560 /* If the extent of even one dimension is zero, then the entire
1561 array section contains zero elements, so we return after writing
1562 a zero array record. */
1567 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1572 stride0
= stride
[0];
1574 /* If the innermost dimension has stride 1, we can do the transfer
1575 in contiguous chunks. */
1581 data
= GFC_DESCRIPTOR_DATA (desc
);
1585 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1586 data
+= stride0
* size
* tsize
;
1589 while (count
[n
] == extent
[n
])
1592 data
-= stride
[n
] * extent
[n
] * size
;
1602 data
+= stride
[n
] * size
;
1609 /* Preposition a sequential unformatted file while reading. */
1612 us_read (st_parameter_dt
*dtp
, int continued
)
1621 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1624 if (compile_options
.record_marker
== 0)
1625 n
= sizeof (GFC_INTEGER_4
);
1627 n
= compile_options
.record_marker
;
1631 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1635 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1636 return; /* end of file */
1639 if (p
== NULL
|| n
!= nr
)
1641 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1645 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1646 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1650 case sizeof(GFC_INTEGER_4
):
1651 memcpy (&i4
, p
, sizeof (i4
));
1655 case sizeof(GFC_INTEGER_8
):
1656 memcpy (&i8
, p
, sizeof (i8
));
1661 runtime_error ("Illegal value for record marker");
1668 case sizeof(GFC_INTEGER_4
):
1669 reverse_memcpy (&i4
, p
, sizeof (i4
));
1673 case sizeof(GFC_INTEGER_8
):
1674 reverse_memcpy (&i8
, p
, sizeof (i8
));
1679 runtime_error ("Illegal value for record marker");
1685 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1686 dtp
->u
.p
.current_unit
->continued
= 0;
1690 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1691 dtp
->u
.p
.current_unit
->continued
= 1;
1695 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1699 /* Preposition a sequential unformatted file while writing. This
1700 amount to writing a bogus length that will be filled in later. */
1703 us_write (st_parameter_dt
*dtp
, int continued
)
1710 if (compile_options
.record_marker
== 0)
1711 nbytes
= sizeof (GFC_INTEGER_4
);
1713 nbytes
= compile_options
.record_marker
;
1715 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1716 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1718 /* For sequential unformatted, if RECL= was not specified in the OPEN
1719 we write until we have more bytes than can fit in the subrecord
1720 markers, then we write a new subrecord. */
1722 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1723 dtp
->u
.p
.current_unit
->recl_subrecord
;
1724 dtp
->u
.p
.current_unit
->continued
= continued
;
1728 /* Position to the next record prior to transfer. We are assumed to
1729 be before the next record. We also calculate the bytes in the next
1733 pre_position (st_parameter_dt
*dtp
)
1735 if (dtp
->u
.p
.current_unit
->current_record
)
1736 return; /* Already positioned. */
1738 switch (current_mode (dtp
))
1740 case FORMATTED_STREAM
:
1741 case UNFORMATTED_STREAM
:
1742 /* There are no records with stream I/O. Set the default position
1743 to the beginning of the file if no position was specified. */
1744 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1745 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1748 case UNFORMATTED_SEQUENTIAL
:
1749 if (dtp
->u
.p
.mode
== READING
)
1756 case FORMATTED_SEQUENTIAL
:
1757 case FORMATTED_DIRECT
:
1758 case UNFORMATTED_DIRECT
:
1759 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1763 dtp
->u
.p
.current_unit
->current_record
= 1;
1767 /* Initialize things for a data transfer. This code is common for
1768 both reading and writing. */
1771 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1773 unit_flags u_flags
; /* Used for creating a unit if needed. */
1774 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1775 namelist_info
*ionml
;
1777 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1778 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1779 dtp
->u
.p
.ionml
= ionml
;
1780 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1782 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1785 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1786 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1788 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1789 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1790 { /* Open the unit with some default flags. */
1791 st_parameter_open opp
;
1794 if (dtp
->common
.unit
< 0)
1796 close_unit (dtp
->u
.p
.current_unit
);
1797 dtp
->u
.p
.current_unit
= NULL
;
1798 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1799 "Bad unit number in OPEN statement");
1802 memset (&u_flags
, '\0', sizeof (u_flags
));
1803 u_flags
.access
= ACCESS_SEQUENTIAL
;
1804 u_flags
.action
= ACTION_READWRITE
;
1806 /* Is it unformatted? */
1807 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1808 | IOPARM_DT_IONML_SET
)))
1809 u_flags
.form
= FORM_UNFORMATTED
;
1811 u_flags
.form
= FORM_UNSPECIFIED
;
1813 u_flags
.delim
= DELIM_UNSPECIFIED
;
1814 u_flags
.blank
= BLANK_UNSPECIFIED
;
1815 u_flags
.pad
= PAD_UNSPECIFIED
;
1816 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1817 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1818 u_flags
.async
= ASYNC_UNSPECIFIED
;
1819 u_flags
.round
= ROUND_UNSPECIFIED
;
1820 u_flags
.sign
= SIGN_UNSPECIFIED
;
1821 u_flags
.status
= STATUS_UNKNOWN
;
1823 conv
= get_unformatted_convert (dtp
->common
.unit
);
1825 if (conv
== GFC_CONVERT_NONE
)
1826 conv
= compile_options
.convert
;
1828 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1829 and 1 on big-endian machines. */
1832 case GFC_CONVERT_NATIVE
:
1833 case GFC_CONVERT_SWAP
:
1836 case GFC_CONVERT_BIG
:
1837 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1840 case GFC_CONVERT_LITTLE
:
1841 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1845 internal_error (&opp
.common
, "Illegal value for CONVERT");
1849 u_flags
.convert
= conv
;
1851 opp
.common
= dtp
->common
;
1852 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1853 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1854 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1855 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1856 if (dtp
->u
.p
.current_unit
== NULL
)
1860 /* Check the action. */
1862 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1864 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1865 "Cannot read from file opened for WRITE");
1869 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1871 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1872 "Cannot write to file opened for READ");
1876 dtp
->u
.p
.first_item
= 1;
1878 /* Check the format. */
1880 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1883 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1884 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1887 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1888 "Format present for UNFORMATTED data transfer");
1892 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1894 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1895 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1896 "A format cannot be specified with a namelist");
1898 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1899 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1901 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1902 "Missing format for FORMATTED data transfer");
1905 if (is_internal_unit (dtp
)
1906 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1908 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1909 "Internal file cannot be accessed by UNFORMATTED "
1914 /* Check the record or position number. */
1916 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1917 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1919 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1920 "Direct access data transfer requires record number");
1924 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1925 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1927 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1928 "Record number not allowed for sequential access data transfer");
1932 /* Process the ADVANCE option. */
1934 dtp
->u
.p
.advance_status
1935 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1936 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1937 "Bad ADVANCE parameter in data transfer statement");
1939 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1941 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1943 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1944 "ADVANCE specification conflicts with sequential access");
1948 if (is_internal_unit (dtp
))
1950 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1951 "ADVANCE specification conflicts with internal file");
1955 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1956 != IOPARM_DT_HAS_FORMAT
)
1958 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1959 "ADVANCE specification requires an explicit format");
1966 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1968 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1970 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1971 "EOR specification requires an ADVANCE specification "
1976 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1978 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1979 "SIZE specification requires an ADVANCE specification of NO");
1984 { /* Write constraints. */
1985 if ((cf
& IOPARM_END
) != 0)
1987 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1988 "END specification cannot appear in a write statement");
1992 if ((cf
& IOPARM_EOR
) != 0)
1994 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1995 "EOR specification cannot appear in a write statement");
1999 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
2001 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
2002 "SIZE specification cannot appear in a write statement");
2007 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
2008 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2010 /* Check the decimal mode. */
2012 dtp
->u
.p
.decimal_status
2013 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2014 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
, decimal_opt
,
2015 "Bad DECIMAL parameter in data transfer statement");
2017 if (dtp
->u
.p
.decimal_status
== DECIMAL_UNSPECIFIED
)
2018 dtp
->u
.p
.decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2020 /* Check the sign mode. */
2021 dtp
->u
.p
.sign_status
2022 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2023 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2024 "Bad SIGN parameter in data transfer statement");
2026 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2027 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2029 /* Check the blank mode. */
2030 dtp
->u
.p
.blank_status
2031 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2032 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
, blank_opt
,
2033 "Bad BLANK parameter in data transfer statement");
2035 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2036 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2038 /* Check the delim mode. */
2039 dtp
->u
.p
.delim_status
2040 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2041 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
, delim_opt
,
2042 "Bad DELIM parameter in data transfer statement");
2044 if (dtp
->u
.p
.delim_status
== DELIM_UNSPECIFIED
)
2045 dtp
->u
.p
.delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2047 /* Check the pad mode. */
2049 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2050 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2051 "Bad PAD parameter in data transfer statement");
2053 if (dtp
->u
.p
.pad_status
== PAD_UNSPECIFIED
)
2054 dtp
->u
.p
.pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2056 /* Sanity checks on the record number. */
2057 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2061 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2062 "Record number must be positive");
2066 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2068 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2069 "Record number too large");
2073 /* Check to see if we might be reading what we wrote before */
2075 if (dtp
->u
.p
.mode
== READING
2076 && dtp
->u
.p
.current_unit
->mode
== WRITING
2077 && !is_internal_unit (dtp
))
2078 flush(dtp
->u
.p
.current_unit
->s
);
2080 /* Check whether the record exists to be read. Only
2081 a partial record needs to exist. */
2083 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2084 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2086 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2087 "Non-existing record number");
2091 /* Position the file. */
2092 if (!is_stream_io (dtp
))
2094 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2095 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2097 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2102 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2108 /* Overwriting an existing sequential file ?
2109 it is always safe to truncate the file on the first write */
2110 if (dtp
->u
.p
.mode
== WRITING
2111 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2112 && dtp
->u
.p
.current_unit
->last_record
== 0
2113 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2114 struncate(dtp
->u
.p
.current_unit
->s
);
2116 /* Bugware for badly written mixed C-Fortran I/O. */
2117 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2119 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2121 /* Set the maximum position reached from the previous I/O operation. This
2122 could be greater than zero from a previous non-advancing write. */
2123 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2127 /* Set up the subroutine that will handle the transfers. */
2131 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2132 dtp
->u
.p
.transfer
= unformatted_read
;
2135 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2136 dtp
->u
.p
.transfer
= list_formatted_read
;
2138 dtp
->u
.p
.transfer
= formatted_transfer
;
2143 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2144 dtp
->u
.p
.transfer
= unformatted_write
;
2147 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2148 dtp
->u
.p
.transfer
= list_formatted_write
;
2150 dtp
->u
.p
.transfer
= formatted_transfer
;
2154 /* Make sure that we don't do a read after a nonadvancing write. */
2158 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2160 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2161 "Cannot READ after a nonadvancing WRITE");
2167 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2168 dtp
->u
.p
.current_unit
->read_bad
= 1;
2171 /* Start the data transfer if we are doing a formatted transfer. */
2172 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2173 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2174 && dtp
->u
.p
.ionml
== NULL
)
2175 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2178 /* Initialize an array_loop_spec given the array descriptor. The function
2179 returns the index of the last element of the array, and also returns
2180 starting record, where the first I/O goes to (necessary in case of
2181 negative strides). */
2184 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2185 gfc_offset
*start_record
)
2187 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2196 for (i
=0; i
<rank
; i
++)
2198 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2199 ls
[i
].start
= desc
->dim
[i
].lbound
;
2200 ls
[i
].end
= desc
->dim
[i
].ubound
;
2201 ls
[i
].step
= desc
->dim
[i
].stride
;
2202 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2204 if (desc
->dim
[i
].stride
> 0)
2206 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2207 * desc
->dim
[i
].stride
;
2211 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2212 * desc
->dim
[i
].stride
;
2213 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2214 * desc
->dim
[i
].stride
;
2224 /* Determine the index to the next record in an internal unit array by
2225 by incrementing through the array_loop_spec. */
2228 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2236 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2241 if (ls
[i
].idx
> ls
[i
].end
)
2243 ls
[i
].idx
= ls
[i
].start
;
2249 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2259 /* Skip to the end of the current record, taking care of an optional
2260 record marker of size bytes. If the file is not seekable, we
2261 read chunks of size MAX_READ until we get to the right
2264 #define MAX_READ 4096
2267 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2270 int rlength
, length
;
2273 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2274 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2277 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2279 new = file_position (dtp
->u
.p
.current_unit
->s
)
2280 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2282 /* Direct access files do not generate END conditions,
2284 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2285 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2288 { /* Seek by reading data. */
2289 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2292 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2293 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2295 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2298 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2302 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2310 /* Advance to the next record reading unformatted files, taking
2311 care of subrecords. If complete_record is nonzero, we loop
2312 until all subrecords are cleared. */
2315 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2319 bytes
= compile_options
.record_marker
== 0 ?
2320 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2325 /* Skip over tail */
2327 skip_record (dtp
, bytes
);
2329 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2336 /* Space to the next record for read mode. */
2339 next_record_r (st_parameter_dt
*dtp
)
2342 int length
, bytes_left
;
2345 switch (current_mode (dtp
))
2347 /* No records in unformatted STREAM I/O. */
2348 case UNFORMATTED_STREAM
:
2351 case UNFORMATTED_SEQUENTIAL
:
2352 next_record_r_unf (dtp
, 1);
2353 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2356 case FORMATTED_DIRECT
:
2357 case UNFORMATTED_DIRECT
:
2358 skip_record (dtp
, 0);
2361 case FORMATTED_STREAM
:
2362 case FORMATTED_SEQUENTIAL
:
2364 /* sf_read has already terminated input because of an '\n' */
2365 if (dtp
->u
.p
.sf_seen_eor
)
2367 dtp
->u
.p
.sf_seen_eor
= 0;
2371 if (is_internal_unit (dtp
))
2373 if (is_array_io (dtp
))
2377 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2380 /* Now seek to this record. */
2381 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2382 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2384 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2387 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2391 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2392 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2394 dtp
->u
.p
.current_unit
->bytes_left
2395 = dtp
->u
.p
.current_unit
->recl
;
2401 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2405 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2411 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2415 if (is_stream_io (dtp
))
2416 dtp
->u
.p
.current_unit
->strm_pos
++;
2423 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2424 && !dtp
->u
.p
.namelist_mode
2425 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2426 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2427 file_position (dtp
->u
.p
.current_unit
->s
)))
2428 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2433 /* Small utility function to write a record marker, taking care of
2434 byte swapping and of choosing the correct size. */
2437 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2442 char p
[sizeof (GFC_INTEGER_8
)];
2444 if (compile_options
.record_marker
== 0)
2445 len
= sizeof (GFC_INTEGER_4
);
2447 len
= compile_options
.record_marker
;
2449 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2450 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2454 case sizeof (GFC_INTEGER_4
):
2456 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2459 case sizeof (GFC_INTEGER_8
):
2461 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2465 runtime_error ("Illegal value for record marker");
2473 case sizeof (GFC_INTEGER_4
):
2475 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2476 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2479 case sizeof (GFC_INTEGER_8
):
2481 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2482 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2486 runtime_error ("Illegal value for record marker");
2493 /* Position to the next (sub)record in write mode for
2494 unformatted sequential files. */
2497 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2499 gfc_offset c
, m
, m_write
;
2500 size_t record_marker
;
2502 /* Bytes written. */
2503 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2504 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2505 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2507 /* Write the length tail. If we finish a record containing
2508 subrecords, we write out the negative length. */
2510 if (dtp
->u
.p
.current_unit
->continued
)
2515 if (write_us_marker (dtp
, m_write
) != 0)
2518 if (compile_options
.record_marker
== 0)
2519 record_marker
= sizeof (GFC_INTEGER_4
);
2521 record_marker
= compile_options
.record_marker
;
2523 /* Seek to the head and overwrite the bogus length with the real
2526 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2535 if (write_us_marker (dtp
, m_write
) != 0)
2538 /* Seek past the end of the current record. */
2540 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2546 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2551 /* Position to the next record in write mode. */
2554 next_record_w (st_parameter_dt
*dtp
, int done
)
2556 gfc_offset m
, record
, max_pos
;
2560 /* Zero counters for X- and T-editing. */
2561 max_pos
= dtp
->u
.p
.max_pos
;
2562 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2564 switch (current_mode (dtp
))
2566 /* No records in unformatted STREAM I/O. */
2567 case UNFORMATTED_STREAM
:
2570 case FORMATTED_DIRECT
:
2571 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2574 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2575 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2580 case UNFORMATTED_DIRECT
:
2581 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2583 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2584 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2585 memset (p
, 0, length
);
2588 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2592 case UNFORMATTED_SEQUENTIAL
:
2593 next_record_w_unf (dtp
, 0);
2594 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2597 case FORMATTED_STREAM
:
2598 case FORMATTED_SEQUENTIAL
:
2600 if (is_internal_unit (dtp
))
2602 if (is_array_io (dtp
))
2606 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2608 /* If the farthest position reached is greater than current
2609 position, adjust the position and set length to pad out
2610 whats left. Otherwise just pad whats left.
2611 (for character array unit) */
2612 m
= dtp
->u
.p
.current_unit
->recl
2613 - dtp
->u
.p
.current_unit
->bytes_left
;
2616 length
= (int) (max_pos
- m
);
2617 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2618 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2621 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2623 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2627 /* Now that the current record has been padded out,
2628 determine where the next record in the array is. */
2629 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2632 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2634 /* Now seek to this record */
2635 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2637 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2639 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2643 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2649 /* If this is the last call to next_record move to the farthest
2650 position reached and set length to pad out the remainder
2651 of the record. (for character scaler unit) */
2654 m
= dtp
->u
.p
.current_unit
->recl
2655 - dtp
->u
.p
.current_unit
->bytes_left
;
2658 length
= (int) (max_pos
- m
);
2659 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2660 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2663 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2666 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2668 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2676 const char crlf
[] = "\r\n";
2678 /* Move to the farthest position reached in preparation for
2679 completing the record. (for file unit) */
2680 m
= dtp
->u
.p
.current_unit
->recl
-
2681 dtp
->u
.p
.current_unit
->bytes_left
;
2684 length
= (int) (max_pos
- m
);
2685 sseek (dtp
->u
.p
.current_unit
->s
,
2686 file_position (dtp
->u
.p
.current_unit
->s
) + length
);
2693 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2696 if (is_stream_io (dtp
))
2698 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2699 if (dtp
->u
.p
.current_unit
->strm_pos
2700 < file_length (dtp
->u
.p
.current_unit
->s
))
2701 struncate (dtp
->u
.p
.current_unit
->s
);
2708 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2713 /* Position to the next record, which means moving to the end of the
2714 current record. This can happen under several different
2715 conditions. If the done flag is not set, we get ready to process
2719 next_record (st_parameter_dt
*dtp
, int done
)
2721 gfc_offset fp
; /* File position. */
2723 dtp
->u
.p
.current_unit
->read_bad
= 0;
2725 if (dtp
->u
.p
.mode
== READING
)
2726 next_record_r (dtp
);
2728 next_record_w (dtp
, done
);
2730 if (!is_stream_io (dtp
))
2732 /* Keep position up to date for INQUIRE */
2734 update_position (dtp
->u
.p
.current_unit
);
2736 dtp
->u
.p
.current_unit
->current_record
= 0;
2737 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2739 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2740 /* Calculate next record, rounding up partial records. */
2741 dtp
->u
.p
.current_unit
->last_record
=
2742 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2743 dtp
->u
.p
.current_unit
->recl
;
2746 dtp
->u
.p
.current_unit
->last_record
++;
2754 /* Finalize the current data transfer. For a nonadvancing transfer,
2755 this means advancing to the next record. For internal units close the
2756 stream associated with the unit. */
2759 finalize_transfer (st_parameter_dt
*dtp
)
2762 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2764 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2765 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2767 if (dtp
->u
.p
.eor_condition
)
2769 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2773 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2776 if ((dtp
->u
.p
.ionml
!= NULL
)
2777 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2779 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2780 namelist_read (dtp
);
2782 namelist_write (dtp
);
2785 dtp
->u
.p
.transfer
= NULL
;
2786 if (dtp
->u
.p
.current_unit
== NULL
)
2789 dtp
->u
.p
.eof_jump
= &eof_jump
;
2790 if (setjmp (eof_jump
))
2792 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2796 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2798 finish_list_read (dtp
);
2799 sfree (dtp
->u
.p
.current_unit
->s
);
2803 if (dtp
->u
.p
.mode
== WRITING
)
2804 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2805 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2807 if (is_stream_io (dtp
))
2809 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2810 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2811 next_record (dtp
, 1);
2813 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2814 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2816 flush (dtp
->u
.p
.current_unit
->s
);
2817 sfree (dtp
->u
.p
.current_unit
->s
);
2822 dtp
->u
.p
.current_unit
->current_record
= 0;
2824 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2826 dtp
->u
.p
.seen_dollar
= 0;
2827 sfree (dtp
->u
.p
.current_unit
->s
);
2831 /* For non-advancing I/O, save the current maximum position for use in the
2832 next I/O operation if needed. */
2833 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2835 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2836 - dtp
->u
.p
.current_unit
->bytes_left
);
2837 dtp
->u
.p
.current_unit
->saved_pos
=
2838 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2839 flush (dtp
->u
.p
.current_unit
->s
);
2843 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2845 next_record (dtp
, 1);
2846 sfree (dtp
->u
.p
.current_unit
->s
);
2849 /* Transfer function for IOLENGTH. It doesn't actually do any
2850 data transfer, it just updates the length counter. */
2853 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2854 void *dest
__attribute__ ((unused
)),
2855 int kind
__attribute__((unused
)),
2856 size_t size
, size_t nelems
)
2858 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2859 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2863 /* Initialize the IOLENGTH data transfer. This function is in essence
2864 a very much simplified version of data_transfer_init(), because it
2865 doesn't have to deal with units at all. */
2868 iolength_transfer_init (st_parameter_dt
*dtp
)
2870 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2873 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2875 /* Set up the subroutine that will handle the transfers. */
2877 dtp
->u
.p
.transfer
= iolength_transfer
;
2881 /* Library entry point for the IOLENGTH form of the INQUIRE
2882 statement. The IOLENGTH form requires no I/O to be performed, but
2883 it must still be a runtime library call so that we can determine
2884 the iolength for dynamic arrays and such. */
2886 extern void st_iolength (st_parameter_dt
*);
2887 export_proto(st_iolength
);
2890 st_iolength (st_parameter_dt
*dtp
)
2892 library_start (&dtp
->common
);
2893 iolength_transfer_init (dtp
);
2896 extern void st_iolength_done (st_parameter_dt
*);
2897 export_proto(st_iolength_done
);
2900 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2903 if (dtp
->u
.p
.scratch
!= NULL
)
2904 free_mem (dtp
->u
.p
.scratch
);
2909 /* The READ statement. */
2911 extern void st_read (st_parameter_dt
*);
2912 export_proto(st_read
);
2915 st_read (st_parameter_dt
*dtp
)
2917 library_start (&dtp
->common
);
2919 data_transfer_init (dtp
, 1);
2921 /* Handle complications dealing with the endfile record. */
2923 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2924 switch (dtp
->u
.p
.current_unit
->endfile
)
2930 if (!is_internal_unit (dtp
))
2932 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2933 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2934 dtp
->u
.p
.current_unit
->current_record
= 0;
2939 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2940 dtp
->u
.p
.current_unit
->current_record
= 0;
2945 extern void st_read_done (st_parameter_dt
*);
2946 export_proto(st_read_done
);
2949 st_read_done (st_parameter_dt
*dtp
)
2951 finalize_transfer (dtp
);
2952 free_format_data (dtp
);
2954 if (dtp
->u
.p
.scratch
!= NULL
)
2955 free_mem (dtp
->u
.p
.scratch
);
2956 if (dtp
->u
.p
.current_unit
!= NULL
)
2957 unlock_unit (dtp
->u
.p
.current_unit
);
2959 free_internal_unit (dtp
);
2964 extern void st_write (st_parameter_dt
*);
2965 export_proto(st_write
);
2968 st_write (st_parameter_dt
*dtp
)
2970 library_start (&dtp
->common
);
2971 data_transfer_init (dtp
, 0);
2974 extern void st_write_done (st_parameter_dt
*);
2975 export_proto(st_write_done
);
2978 st_write_done (st_parameter_dt
*dtp
)
2980 finalize_transfer (dtp
);
2982 /* Deal with endfile conditions associated with sequential files. */
2984 if (dtp
->u
.p
.current_unit
!= NULL
2985 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2986 switch (dtp
->u
.p
.current_unit
->endfile
)
2988 case AT_ENDFILE
: /* Remain at the endfile record. */
2992 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2996 /* Get rid of whatever is after this record. */
2997 if (!is_internal_unit (dtp
))
2999 flush (dtp
->u
.p
.current_unit
->s
);
3000 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3001 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3003 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3007 free_format_data (dtp
);
3009 if (dtp
->u
.p
.scratch
!= NULL
)
3010 free_mem (dtp
->u
.p
.scratch
);
3011 if (dtp
->u
.p
.current_unit
!= NULL
)
3012 unlock_unit (dtp
->u
.p
.current_unit
);
3014 free_internal_unit (dtp
);
3020 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3022 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3027 /* Receives the scalar information for namelist objects and stores it
3028 in a linked list of namelist_info types. */
3030 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3031 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3032 export_proto(st_set_nml_var
);
3036 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3037 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3038 GFC_INTEGER_4 dtype
)
3040 namelist_info
*t1
= NULL
;
3042 size_t var_name_len
= strlen (var_name
);
3044 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3046 nml
->mem_pos
= var_addr
;
3048 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3049 memcpy (nml
->var_name
, var_name
, var_name_len
);
3050 nml
->var_name
[var_name_len
] = '\0';
3052 nml
->len
= (int) len
;
3053 nml
->string_length
= (index_type
) string_length
;
3055 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3056 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3057 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3059 if (nml
->var_rank
> 0)
3061 nml
->dim
= (descriptor_dimension
*)
3062 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3063 nml
->ls
= (array_loop_spec
*)
3064 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3074 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3076 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3077 dtp
->u
.p
.ionml
= nml
;
3081 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3086 /* Store the dimensional information for the namelist object. */
3087 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3088 index_type
, index_type
,
3090 export_proto(st_set_nml_var_dim
);
3093 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3094 index_type stride
, index_type lbound
,
3097 namelist_info
* nml
;
3102 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3104 nml
->dim
[n
].stride
= stride
;
3105 nml
->dim
[n
].lbound
= lbound
;
3106 nml
->dim
[n
].ubound
= ubound
;
3109 /* Reverse memcpy - used for byte swapping. */
3111 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3117 s
= (char *) src
+ n
- 1;
3119 /* Write with ascending order - this is likely faster
3120 on modern architectures because of write combining. */