1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
33 /* transfer.c -- Top level handling of data transfer statements. */
38 #include "libgfortran.h"
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
60 These subroutines do not return status.
62 The last call is a call to st_[read|write]_done(). While
63 something can easily go wrong with the initial st_read() or
64 st_write(), an error inhibits any data from actually being
67 extern void transfer_integer (st_parameter_dt
*, void *, int);
68 export_proto(transfer_integer
);
70 extern void transfer_real (st_parameter_dt
*, void *, int);
71 export_proto(transfer_real
);
73 extern void transfer_logical (st_parameter_dt
*, void *, int);
74 export_proto(transfer_logical
);
76 extern void transfer_character (st_parameter_dt
*, void *, int);
77 export_proto(transfer_character
);
79 extern void transfer_complex (st_parameter_dt
*, void *, int);
80 export_proto(transfer_complex
);
82 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
84 export_proto(transfer_array
);
86 static void us_read (st_parameter_dt
*, int);
87 static void us_write (st_parameter_dt
*, int);
88 static void next_record_r_unf (st_parameter_dt
*, int);
89 static void next_record_w_unf (st_parameter_dt
*, int);
91 static const st_option advance_opt
[] = {
99 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
100 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
106 current_mode (st_parameter_dt
*dtp
)
110 m
= FORM_UNSPECIFIED
;
112 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
114 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
115 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
117 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
119 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
120 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
122 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
124 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
125 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
132 /* Mid level data transfer statements. These subroutines do reading
133 and writing in the style of salloc_r()/salloc_w() within the
136 /* When reading sequential formatted records we have a problem. We
137 don't know how long the line is until we read the trailing newline,
138 and we don't want to read too much. If we read too much, we might
139 have to do a physical seek backwards depending on how much data is
140 present, and devices like terminals aren't seekable and would cause
143 Given this, the solution is to read a byte at a time, stopping if
144 we hit the newline. For small allocations, we use a static buffer.
145 For larger allocations, we are forced to allocate memory on the
146 heap. Hopefully this won't happen very often. */
149 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
152 int n
, readlen
, crlf
;
155 if (*length
> SCRATCH_SIZE
)
156 dtp
->u
.p
.line_buffer
= get_mem (*length
);
157 p
= base
= dtp
->u
.p
.line_buffer
;
159 /* If we have seen an eor previously, return a length of 0. The
160 caller is responsible for correctly padding the input field. */
161 if (dtp
->u
.p
.sf_seen_eor
)
167 if (is_internal_unit (dtp
))
170 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
171 memcpy (p
, q
, readlen
);
180 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
184 /* If we have a line without a terminating \n, drop through to
186 if (readlen
< 1 && n
== 0)
190 generate_error (&dtp
->common
, ERROR_END
, NULL
);
194 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
196 /* Unexpected end of line. */
198 /* If we see an EOR during non-advancing I/O, we need to skip
199 the rest of the I/O statement. Set the corresponding flag. */
200 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
201 dtp
->u
.p
.eor_condition
= 1;
204 /* If we encounter a CR, it might be a CRLF. */
205 if (*q
== '\r') /* Probably a CRLF */
208 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
209 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
210 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
211 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
216 /* Without padding, terminate the I/O statement without assigning
217 the value. With padding, the value still needs to be assigned,
218 so we can just continue with a short read. */
219 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
223 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
228 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
231 /* Short circuit the read if a comma is found during numeric input.
232 The flag is set to zero during character reads so that commas in
233 strings are not ignored */
235 if (dtp
->u
.p
.sf_read_comma
== 1)
237 notify_std (&dtp
->common
, GFC_STD_GNU
,
238 "Comma in formatted numeric read.");
245 dtp
->u
.p
.sf_seen_eor
= 0;
250 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
252 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
253 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
259 /* Function for reading the next couple of bytes from the current
260 file, advancing the current position. We return a pointer to a
261 buffer containing the bytes. We return NULL on end of record or
264 If the read is short, then it is because the current record does not
265 have enough data to satisfy the read request and the file was
266 opened with PAD=YES. The caller must assume tailing spaces for
270 read_block (st_parameter_dt
*dtp
, int *length
)
275 if (is_stream_io (dtp
))
277 if (sseek (dtp
->u
.p
.current_unit
->s
,
278 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
280 generate_error (&dtp
->common
, ERROR_END
, NULL
);
286 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
288 /* For preconnected units with default record length, set bytes left
289 to unit record length and proceed, otherwise error. */
290 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
291 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
292 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
295 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
297 /* Not enough data left. */
298 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
303 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
305 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
306 generate_error (&dtp
->common
, ERROR_END
, NULL
);
310 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
314 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
315 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
316 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
318 source
= read_sf (dtp
, length
, 0);
319 dtp
->u
.p
.current_unit
->strm_pos
+=
320 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
323 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
326 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
328 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
329 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
331 if (nread
!= *length
)
332 { /* Short read, this shouldn't happen. */
333 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
337 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
342 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
348 /* Reads a block directly into application data space. This is for
349 unformatted files. */
352 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
354 size_t to_read_record
;
355 size_t have_read_record
;
356 size_t to_read_subrecord
;
357 size_t have_read_subrecord
;
360 if (is_stream_io (dtp
))
362 if (sseek (dtp
->u
.p
.current_unit
->s
,
363 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
365 generate_error (&dtp
->common
, ERROR_END
, NULL
);
369 to_read_record
= *nbytes
;
370 have_read_record
= to_read_record
;
371 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
373 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
377 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
379 if (to_read_record
!= have_read_record
)
381 /* Short read, e.g. if we hit EOF. For stream files,
382 we have to set the end-of-file condition. */
383 generate_error (&dtp
->common
, ERROR_END
, NULL
);
389 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
391 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
394 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
395 *nbytes
= to_read_record
;
401 to_read_record
= *nbytes
;
404 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
406 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
408 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
412 if (to_read_record
!= *nbytes
)
414 /* Short read, e.g. if we hit EOF. Apparently, we read
415 more than was written to the last record. */
416 *nbytes
= to_read_record
;
422 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
428 /* Unformatted sequential. We loop over the subrecords, reading
429 until the request has been fulfilled or the record has run out
430 of continuation subrecords. */
432 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
434 generate_error (&dtp
->common
, ERROR_END
, NULL
);
438 /* Check whether we exceed the total record length. */
440 if (dtp
->u
.p
.current_unit
->flags
.has_recl
441 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
443 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
448 to_read_record
= *nbytes
;
451 have_read_record
= 0;
455 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
456 < (gfc_offset
) to_read_record
)
458 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
459 to_read_record
-= to_read_subrecord
;
463 to_read_subrecord
= to_read_record
;
467 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
469 have_read_subrecord
= to_read_subrecord
;
470 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
471 &have_read_subrecord
) != 0)
473 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
477 have_read_record
+= have_read_subrecord
;
479 if (to_read_subrecord
!= have_read_subrecord
)
482 /* Short read, e.g. if we hit EOF. This means the record
483 structure has been corrupted, or the trailing record
484 marker would still be present. */
486 *nbytes
= have_read_record
;
487 generate_error (&dtp
->common
, ERROR_CORRUPT_FILE
, NULL
);
491 if (to_read_record
> 0)
493 if (dtp
->u
.p
.current_unit
->continued
)
495 next_record_r_unf (dtp
, 0);
500 /* Let's make sure the file position is correctly pre-positioned
501 for the next read statement. */
503 dtp
->u
.p
.current_unit
->current_record
= 0;
504 next_record_r_unf (dtp
, 0);
505 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
511 /* Normal exit, the read request has been fulfilled. */
516 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
519 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
526 /* Function for writing a block of bytes to the current file at the
527 current position, advancing the file pointer. We are given a length
528 and return a pointer to a buffer that the caller must (completely)
529 fill in. Returns NULL on error. */
532 write_block (st_parameter_dt
*dtp
, int length
)
536 if (is_stream_io (dtp
))
538 if (sseek (dtp
->u
.p
.current_unit
->s
,
539 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
541 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
547 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
549 /* For preconnected units with default record length, set bytes left
550 to unit record length and proceed, otherwise error. */
551 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
552 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
553 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
554 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
557 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
562 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
565 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
569 generate_error (&dtp
->common
, ERROR_END
, NULL
);
573 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
574 generate_error (&dtp
->common
, ERROR_END
, NULL
);
576 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
577 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
579 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
585 /* High level interface to swrite(), taking care of errors. This is only
586 called for unformatted files. There are three cases to consider:
587 Stream I/O, unformatted direct, unformatted sequential. */
590 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
593 size_t have_written
, to_write_subrecord
;
599 if (is_stream_io (dtp
))
601 if (sseek (dtp
->u
.p
.current_unit
->s
,
602 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
604 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
608 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
610 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
614 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
619 /* Unformatted direct access. */
621 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
623 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
625 generate_error (&dtp
->common
, ERROR_DIRECT_EOR
, NULL
);
629 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
631 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
635 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
636 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
642 /* Unformatted sequential. */
646 if (dtp
->u
.p
.current_unit
->flags
.has_recl
647 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
649 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
661 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
662 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
664 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
665 (gfc_offset
) to_write_subrecord
;
667 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
668 &to_write_subrecord
) != 0)
670 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
674 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
675 nbytes
-= to_write_subrecord
;
676 have_written
+= to_write_subrecord
;
681 next_record_w_unf (dtp
, 1);
684 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
687 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
694 /* Master function for unformatted reads. */
697 unformatted_read (st_parameter_dt
*dtp
, bt type
,
698 void *dest
, int kind
__attribute__((unused
)),
699 size_t size
, size_t nelems
)
703 /* Currently, character implies size=1. */
704 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
705 || size
== 1 || type
== BT_CHARACTER
)
708 read_block_direct (dtp
, dest
, &sz
);
715 /* Break up complex into its constituent reals. */
716 if (type
== BT_COMPLEX
)
723 /* By now, all complex variables have been split into their
724 constituent reals. */
726 for (i
=0; i
<nelems
; i
++)
728 read_block_direct (dtp
, buffer
, &size
);
729 reverse_memcpy (p
, buffer
, size
);
736 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
737 bytes on 64 bit machines. The unused bytes are not initialized and never
738 used, which can show an error with memory checking analyzers like
742 unformatted_write (st_parameter_dt
*dtp
, bt type
,
743 void *source
, int kind
__attribute__((unused
)),
744 size_t size
, size_t nelems
)
746 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
747 size
== 1 || type
== BT_CHARACTER
)
750 write_buf (dtp
, source
, size
);
758 /* Break up complex into its constituent reals. */
759 if (type
== BT_COMPLEX
)
767 /* By now, all complex variables have been split into their
768 constituent reals. */
771 for (i
=0; i
<nelems
; i
++)
773 reverse_memcpy(buffer
, p
, size
);
775 write_buf (dtp
, buffer
, size
);
781 /* Return a pointer to the name of a type. */
806 internal_error (NULL
, "type_name(): Bad type");
813 /* Write a constant string to the output.
814 This is complicated because the string can have doubled delimiters
815 in it. The length in the format node is the true length. */
818 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
820 char c
, delimiter
, *p
, *q
;
823 length
= f
->u
.string
.length
;
827 p
= write_block (dtp
, length
);
834 for (; length
> 0; length
--)
837 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
838 q
++; /* Skip the doubled delimiter. */
843 /* Given actual and expected types in a formatted data transfer, make
844 sure they agree. If not, an error message is generated. Returns
845 nonzero if something went wrong. */
848 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
852 if (actual
== expected
)
855 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
856 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
858 format_error (dtp
, f
, buffer
);
863 /* This subroutine is the main loop for a formatted data transfer
864 statement. It would be natural to implement this as a coroutine
865 with the user program, but C makes that awkward. We loop,
866 processing format elements. When we actually have to transfer
867 data instead of just setting flags, we return control to the user
868 program which calls a subroutine that supplies the address and type
869 of the next element, then comes back here to process it. */
872 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
875 char scratch
[SCRATCH_SIZE
];
880 int consume_data_flag
;
882 /* Change a complex data item into a pair of reals. */
884 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
885 if (type
== BT_COMPLEX
)
891 /* If there's an EOR condition, we simulate finalizing the transfer
893 if (dtp
->u
.p
.eor_condition
)
896 /* Set this flag so that commas in reads cause the read to complete before
897 the entire field has been read. The next read field will start right after
898 the comma in the stream. (Set to 0 for character reads). */
899 dtp
->u
.p
.sf_read_comma
= 1;
901 dtp
->u
.p
.line_buffer
= scratch
;
904 /* If reversion has occurred and there is another real data item,
905 then we have to move to the next record. */
906 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
908 dtp
->u
.p
.reversion_flag
= 0;
909 next_record (dtp
, 0);
912 consume_data_flag
= 1 ;
913 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
916 f
= next_format (dtp
);
919 /* No data descriptors left. */
921 generate_error (&dtp
->common
, ERROR_FORMAT
,
922 "Insufficient data descriptors in format after reversion");
926 /* Now discharge T, TR and X movements to the right. This is delayed
927 until a data producing format to suppress trailing spaces. */
930 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
931 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
932 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
933 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
934 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
937 if (dtp
->u
.p
.skips
> 0)
939 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
940 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
941 - dtp
->u
.p
.current_unit
->bytes_left
);
943 if (dtp
->u
.p
.skips
< 0)
945 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
946 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
948 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
951 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
952 - dtp
->u
.p
.current_unit
->bytes_left
);
954 if (is_stream_io(dtp
))
962 if (require_type (dtp
, BT_INTEGER
, type
, f
))
965 if (dtp
->u
.p
.mode
== READING
)
966 read_decimal (dtp
, f
, p
, len
);
968 write_i (dtp
, f
, p
, len
);
976 if (compile_options
.allow_std
< GFC_STD_GNU
977 && require_type (dtp
, BT_INTEGER
, type
, f
))
980 if (dtp
->u
.p
.mode
== READING
)
981 read_radix (dtp
, f
, p
, len
, 2);
983 write_b (dtp
, f
, p
, len
);
991 if (compile_options
.allow_std
< GFC_STD_GNU
992 && require_type (dtp
, BT_INTEGER
, type
, f
))
995 if (dtp
->u
.p
.mode
== READING
)
996 read_radix (dtp
, f
, p
, len
, 8);
998 write_o (dtp
, f
, p
, len
);
1006 if (compile_options
.allow_std
< GFC_STD_GNU
1007 && require_type (dtp
, BT_INTEGER
, type
, f
))
1010 if (dtp
->u
.p
.mode
== READING
)
1011 read_radix (dtp
, f
, p
, len
, 16);
1013 write_z (dtp
, f
, p
, len
);
1021 if (dtp
->u
.p
.mode
== READING
)
1022 read_a (dtp
, f
, p
, len
);
1024 write_a (dtp
, f
, p
, len
);
1032 if (dtp
->u
.p
.mode
== READING
)
1033 read_l (dtp
, f
, p
, len
);
1035 write_l (dtp
, f
, p
, len
);
1042 if (require_type (dtp
, BT_REAL
, type
, f
))
1045 if (dtp
->u
.p
.mode
== READING
)
1046 read_f (dtp
, f
, p
, len
);
1048 write_d (dtp
, f
, p
, len
);
1055 if (require_type (dtp
, BT_REAL
, type
, f
))
1058 if (dtp
->u
.p
.mode
== READING
)
1059 read_f (dtp
, f
, p
, len
);
1061 write_e (dtp
, f
, p
, len
);
1067 if (require_type (dtp
, BT_REAL
, type
, f
))
1070 if (dtp
->u
.p
.mode
== READING
)
1071 read_f (dtp
, f
, p
, len
);
1073 write_en (dtp
, f
, p
, len
);
1080 if (require_type (dtp
, BT_REAL
, type
, f
))
1083 if (dtp
->u
.p
.mode
== READING
)
1084 read_f (dtp
, f
, p
, len
);
1086 write_es (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_f (dtp
, f
, p
, len
);
1106 if (dtp
->u
.p
.mode
== READING
)
1110 read_decimal (dtp
, f
, p
, len
);
1113 read_l (dtp
, f
, p
, len
);
1116 read_a (dtp
, f
, p
, len
);
1119 read_f (dtp
, f
, p
, len
);
1128 write_i (dtp
, f
, p
, len
);
1131 write_l (dtp
, f
, p
, len
);
1134 write_a (dtp
, f
, p
, len
);
1137 write_d (dtp
, f
, p
, len
);
1141 internal_error (&dtp
->common
,
1142 "formatted_transfer(): Bad type");
1148 consume_data_flag
= 0 ;
1149 if (dtp
->u
.p
.mode
== READING
)
1151 format_error (dtp
, f
, "Constant string in input format");
1154 write_constant_string (dtp
, f
);
1157 /* Format codes that don't transfer data. */
1160 consume_data_flag
= 0;
1162 dtp
->u
.p
.skips
+= f
->u
.n
;
1163 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1164 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1166 /* Writes occur just before the switch on f->format, above, so
1167 that trailing blanks are suppressed, unless we are doing a
1168 non-advancing write in which case we want to output the blanks
1170 if (dtp
->u
.p
.mode
== WRITING
1171 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1173 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1174 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1177 if (dtp
->u
.p
.mode
== READING
)
1178 read_x (dtp
, f
->u
.n
);
1184 consume_data_flag
= 0;
1186 if (f
->format
== FMT_TL
)
1189 /* Handle the special case when no bytes have been used yet.
1190 Cannot go below zero. */
1191 if (bytes_used
== 0)
1193 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1194 dtp
->u
.p
.skips
-= f
->u
.n
;
1195 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1198 pos
= bytes_used
- f
->u
.n
;
1202 if (dtp
->u
.p
.mode
== READING
)
1205 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1208 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1209 left tab limit. We do not check if the position has gone
1210 beyond the end of record because a subsequent tab could
1211 bring us back again. */
1212 pos
= pos
< 0 ? 0 : pos
;
1214 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1215 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1216 + pos
- dtp
->u
.p
.max_pos
;
1217 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1218 ? 0 : dtp
->u
.p
.pending_spaces
;
1220 if (dtp
->u
.p
.skips
== 0)
1223 /* Writes occur just before the switch on f->format, above, so that
1224 trailing blanks are suppressed. */
1225 if (dtp
->u
.p
.mode
== READING
)
1227 /* Adjust everything for end-of-record condition */
1228 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1230 if (dtp
->u
.p
.sf_seen_eor
== 2)
1232 /* The EOR was a CRLF (two bytes wide). */
1233 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1234 dtp
->u
.p
.skips
-= 2;
1238 /* The EOR marker was only one byte wide. */
1239 dtp
->u
.p
.current_unit
->bytes_left
--;
1243 dtp
->u
.p
.sf_seen_eor
= 0;
1245 if (dtp
->u
.p
.skips
< 0)
1247 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1248 dtp
->u
.p
.current_unit
->bytes_left
1249 -= (gfc_offset
) dtp
->u
.p
.skips
;
1250 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1253 read_x (dtp
, dtp
->u
.p
.skips
);
1259 consume_data_flag
= 0 ;
1260 dtp
->u
.p
.sign_status
= SIGN_S
;
1264 consume_data_flag
= 0 ;
1265 dtp
->u
.p
.sign_status
= SIGN_SS
;
1269 consume_data_flag
= 0 ;
1270 dtp
->u
.p
.sign_status
= SIGN_SP
;
1274 consume_data_flag
= 0 ;
1275 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1279 consume_data_flag
= 0 ;
1280 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1284 consume_data_flag
= 0 ;
1285 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1289 consume_data_flag
= 0 ;
1290 dtp
->u
.p
.seen_dollar
= 1;
1294 consume_data_flag
= 0 ;
1295 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1296 next_record (dtp
, 0);
1300 /* A colon descriptor causes us to exit this loop (in
1301 particular preventing another / descriptor from being
1302 processed) unless there is another data item to be
1304 consume_data_flag
= 0 ;
1310 internal_error (&dtp
->common
, "Bad format node");
1313 /* Free a buffer that we had to allocate during a sequential
1314 formatted read of a block that was larger than the static
1317 if (dtp
->u
.p
.line_buffer
!= scratch
)
1319 free_mem (dtp
->u
.p
.line_buffer
);
1320 dtp
->u
.p
.line_buffer
= scratch
;
1323 /* Adjust the item count and data pointer. */
1325 if ((consume_data_flag
> 0) && (n
> 0))
1328 p
= ((char *) p
) + size
;
1331 if (dtp
->u
.p
.mode
== READING
)
1334 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1335 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1341 /* Come here when we need a data descriptor but don't have one. We
1342 push the current format node back onto the input, then return and
1343 let the user program call us back with the data. */
1345 unget_format (dtp
, f
);
1349 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1350 size_t size
, size_t nelems
)
1357 /* Big loop over all the elements. */
1358 for (elem
= 0; elem
< nelems
; elem
++)
1360 dtp
->u
.p
.item_count
++;
1361 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1367 /* Data transfer entry points. The type of the data entity is
1368 implicit in the subroutine call. This prevents us from having to
1369 share a common enum with the compiler. */
1372 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1374 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1376 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1381 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1384 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1386 size
= size_from_real_kind (kind
);
1387 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1392 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1394 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1396 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1401 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1403 static char *empty_string
[0];
1405 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1408 /* Strings of zero length can have p == NULL, which confuses the
1409 transfer routines into thinking we need more data elements. To avoid
1410 this, we give them a nice pointer. */
1411 if (len
== 0 && p
== NULL
)
1414 /* Currently we support only 1 byte chars, and the library is a bit
1415 confused of character kind vs. length, so we kludge it by setting
1417 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1422 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1425 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1427 size
= size_from_complex_kind (kind
);
1428 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1433 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1434 gfc_charlen_type charlen
)
1436 index_type count
[GFC_MAX_DIMENSIONS
];
1437 index_type extent
[GFC_MAX_DIMENSIONS
];
1438 index_type stride
[GFC_MAX_DIMENSIONS
];
1439 index_type stride0
, rank
, size
, type
, n
;
1444 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1447 type
= GFC_DESCRIPTOR_TYPE (desc
);
1448 size
= GFC_DESCRIPTOR_SIZE (desc
);
1450 /* FIXME: What a kludge: Array descriptors and the IO library use
1451 different enums for types. */
1454 case GFC_DTYPE_UNKNOWN
:
1455 iotype
= BT_NULL
; /* Is this correct? */
1457 case GFC_DTYPE_INTEGER
:
1458 iotype
= BT_INTEGER
;
1460 case GFC_DTYPE_LOGICAL
:
1461 iotype
= BT_LOGICAL
;
1463 case GFC_DTYPE_REAL
:
1466 case GFC_DTYPE_COMPLEX
:
1467 iotype
= BT_COMPLEX
;
1469 case GFC_DTYPE_CHARACTER
:
1470 iotype
= BT_CHARACTER
;
1471 /* FIXME: Currently dtype contains the charlen, which is
1472 clobbered if charlen > 2**24. That's why we use a separate
1473 argument for the charlen. However, if we want to support
1474 non-8-bit charsets we need to fix dtype to contain
1475 sizeof(chartype) and fix the code below. */
1479 case GFC_DTYPE_DERIVED
:
1480 internal_error (&dtp
->common
,
1481 "Derived type I/O should have been handled via the frontend.");
1484 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1487 rank
= GFC_DESCRIPTOR_RANK (desc
);
1488 for (n
= 0; n
< rank
; n
++)
1491 stride
[n
] = desc
->dim
[n
].stride
;
1492 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1494 /* If the extent of even one dimension is zero, then the entire
1495 array section contains zero elements, so we return. */
1500 stride0
= stride
[0];
1502 /* If the innermost dimension has stride 1, we can do the transfer
1503 in contiguous chunks. */
1509 data
= GFC_DESCRIPTOR_DATA (desc
);
1513 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1514 data
+= stride0
* size
* tsize
;
1517 while (count
[n
] == extent
[n
])
1520 data
-= stride
[n
] * extent
[n
] * size
;
1530 data
+= stride
[n
] * size
;
1537 /* Preposition a sequential unformatted file while reading. */
1540 us_read (st_parameter_dt
*dtp
, int continued
)
1549 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1552 if (compile_options
.record_marker
== 0)
1553 n
= sizeof (GFC_INTEGER_4
);
1555 n
= compile_options
.record_marker
;
1559 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1563 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1564 return; /* end of file */
1567 if (p
== NULL
|| n
!= nr
)
1569 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1573 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1574 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1578 case sizeof(GFC_INTEGER_4
):
1579 memcpy (&i4
, p
, sizeof (i4
));
1583 case sizeof(GFC_INTEGER_8
):
1584 memcpy (&i8
, p
, sizeof (i8
));
1589 runtime_error ("Illegal value for record marker");
1596 case sizeof(GFC_INTEGER_4
):
1597 reverse_memcpy (&i4
, p
, sizeof (i4
));
1601 case sizeof(GFC_INTEGER_8
):
1602 reverse_memcpy (&i8
, p
, sizeof (i8
));
1607 runtime_error ("Illegal value for record marker");
1613 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1614 dtp
->u
.p
.current_unit
->continued
= 0;
1618 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1619 dtp
->u
.p
.current_unit
->continued
= 1;
1623 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1627 /* Preposition a sequential unformatted file while writing. This
1628 amount to writing a bogus length that will be filled in later. */
1631 us_write (st_parameter_dt
*dtp
, int continued
)
1638 if (compile_options
.record_marker
== 0)
1639 nbytes
= sizeof (GFC_INTEGER_4
);
1641 nbytes
= compile_options
.record_marker
;
1643 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1644 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1646 /* For sequential unformatted, if RECL= was not specified in the OPEN
1647 we write until we have more bytes than can fit in the subrecord
1648 markers, then we write a new subrecord. */
1650 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1651 dtp
->u
.p
.current_unit
->recl_subrecord
;
1652 dtp
->u
.p
.current_unit
->continued
= continued
;
1656 /* Position to the next record prior to transfer. We are assumed to
1657 be before the next record. We also calculate the bytes in the next
1661 pre_position (st_parameter_dt
*dtp
)
1663 if (dtp
->u
.p
.current_unit
->current_record
)
1664 return; /* Already positioned. */
1666 switch (current_mode (dtp
))
1668 case FORMATTED_STREAM
:
1669 case UNFORMATTED_STREAM
:
1670 /* There are no records with stream I/O. Set the default position
1671 to the beginning of the file if no position was specified. */
1672 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1673 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1676 case UNFORMATTED_SEQUENTIAL
:
1677 if (dtp
->u
.p
.mode
== READING
)
1684 case FORMATTED_SEQUENTIAL
:
1685 case FORMATTED_DIRECT
:
1686 case UNFORMATTED_DIRECT
:
1687 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1691 dtp
->u
.p
.current_unit
->current_record
= 1;
1695 /* Initialize things for a data transfer. This code is common for
1696 both reading and writing. */
1699 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1701 unit_flags u_flags
; /* Used for creating a unit if needed. */
1702 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1703 namelist_info
*ionml
;
1705 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1706 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1707 dtp
->u
.p
.ionml
= ionml
;
1708 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1710 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1713 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1714 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1716 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1717 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1718 { /* Open the unit with some default flags. */
1719 st_parameter_open opp
;
1722 if (dtp
->common
.unit
< 0)
1724 close_unit (dtp
->u
.p
.current_unit
);
1725 dtp
->u
.p
.current_unit
= NULL
;
1726 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1727 "Bad unit number in OPEN statement");
1730 memset (&u_flags
, '\0', sizeof (u_flags
));
1731 u_flags
.access
= ACCESS_SEQUENTIAL
;
1732 u_flags
.action
= ACTION_READWRITE
;
1734 /* Is it unformatted? */
1735 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1736 | IOPARM_DT_IONML_SET
)))
1737 u_flags
.form
= FORM_UNFORMATTED
;
1739 u_flags
.form
= FORM_UNSPECIFIED
;
1741 u_flags
.delim
= DELIM_UNSPECIFIED
;
1742 u_flags
.blank
= BLANK_UNSPECIFIED
;
1743 u_flags
.pad
= PAD_UNSPECIFIED
;
1744 u_flags
.status
= STATUS_UNKNOWN
;
1746 conv
= get_unformatted_convert (dtp
->common
.unit
);
1748 if (conv
== CONVERT_NONE
)
1749 conv
= compile_options
.convert
;
1751 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1752 and 1 on big-endian machines. */
1755 case CONVERT_NATIVE
:
1760 conv
= l8_to_l4_offset
? CONVERT_NATIVE
: CONVERT_SWAP
;
1763 case CONVERT_LITTLE
:
1764 conv
= l8_to_l4_offset
? CONVERT_SWAP
: CONVERT_NATIVE
;
1768 internal_error (&opp
.common
, "Illegal value for CONVERT");
1772 u_flags
.convert
= conv
;
1774 opp
.common
= dtp
->common
;
1775 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1776 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1777 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1778 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1779 if (dtp
->u
.p
.current_unit
== NULL
)
1783 /* Check the action. */
1785 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1787 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1788 "Cannot read from file opened for WRITE");
1792 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1794 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1795 "Cannot write to file opened for READ");
1799 dtp
->u
.p
.first_item
= 1;
1801 /* Check the format. */
1803 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1806 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1807 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1810 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1811 "Format present for UNFORMATTED data transfer");
1815 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1817 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1818 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1819 "A format cannot be specified with a namelist");
1821 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1822 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1824 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1825 "Missing format for FORMATTED data transfer");
1828 if (is_internal_unit (dtp
)
1829 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1831 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1832 "Internal file cannot be accessed by UNFORMATTED "
1837 /* Check the record or position number. */
1839 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1840 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1842 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1843 "Direct access data transfer requires record number");
1847 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1848 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1850 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1851 "Record number not allowed for sequential access data transfer");
1855 /* Process the ADVANCE option. */
1857 dtp
->u
.p
.advance_status
1858 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1859 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1860 "Bad ADVANCE parameter in data transfer statement");
1862 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1864 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1866 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1867 "ADVANCE specification conflicts with sequential access");
1871 if (is_internal_unit (dtp
))
1873 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1874 "ADVANCE specification conflicts with internal file");
1878 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1879 != IOPARM_DT_HAS_FORMAT
)
1881 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1882 "ADVANCE specification requires an explicit format");
1889 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1891 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1892 "EOR specification requires an ADVANCE specification "
1897 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1899 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1900 "SIZE specification requires an ADVANCE specification of NO");
1905 { /* Write constraints. */
1906 if ((cf
& IOPARM_END
) != 0)
1908 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1909 "END specification cannot appear in a write statement");
1913 if ((cf
& IOPARM_EOR
) != 0)
1915 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1916 "EOR specification cannot appear in a write statement");
1920 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1922 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1923 "SIZE specification cannot appear in a write statement");
1928 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1929 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1931 /* Sanity checks on the record number. */
1932 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1936 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1937 "Record number must be positive");
1941 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1943 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1944 "Record number too large");
1948 /* Check to see if we might be reading what we wrote before */
1950 if (dtp
->u
.p
.mode
== READING
1951 && dtp
->u
.p
.current_unit
->mode
== WRITING
1952 && !is_internal_unit (dtp
))
1953 flush(dtp
->u
.p
.current_unit
->s
);
1955 /* Check whether the record exists to be read. Only
1956 a partial record needs to exist. */
1958 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1959 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1961 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1962 "Non-existing record number");
1966 /* Position the file. */
1967 if (!is_stream_io (dtp
))
1969 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1970 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1972 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1977 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1981 /* Overwriting an existing sequential file ?
1982 it is always safe to truncate the file on the first write */
1983 if (dtp
->u
.p
.mode
== WRITING
1984 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1985 && dtp
->u
.p
.current_unit
->last_record
== 0
1986 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1987 struncate(dtp
->u
.p
.current_unit
->s
);
1989 /* Bugware for badly written mixed C-Fortran I/O. */
1990 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1992 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1994 /* Set the initial value of flags. */
1996 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1997 dtp
->u
.p
.sign_status
= SIGN_S
;
1999 /* Set the maximum position reached from the previous I/O operation. This
2000 could be greater than zero from a previous non-advancing write. */
2001 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2005 /* Set up the subroutine that will handle the transfers. */
2009 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2010 dtp
->u
.p
.transfer
= unformatted_read
;
2013 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2014 dtp
->u
.p
.transfer
= list_formatted_read
;
2016 dtp
->u
.p
.transfer
= formatted_transfer
;
2021 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2022 dtp
->u
.p
.transfer
= unformatted_write
;
2025 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2026 dtp
->u
.p
.transfer
= list_formatted_write
;
2028 dtp
->u
.p
.transfer
= formatted_transfer
;
2032 /* Make sure that we don't do a read after a nonadvancing write. */
2036 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2038 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
2039 "Cannot READ after a nonadvancing WRITE");
2045 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2046 dtp
->u
.p
.current_unit
->read_bad
= 1;
2049 /* Start the data transfer if we are doing a formatted transfer. */
2050 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2051 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2052 && dtp
->u
.p
.ionml
== NULL
)
2053 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2056 /* Initialize an array_loop_spec given the array descriptor. The function
2057 returns the index of the last element of the array. */
2060 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2062 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2067 for (i
=0; i
<rank
; i
++)
2069 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2070 ls
[i
].start
= desc
->dim
[i
].lbound
;
2071 ls
[i
].end
= desc
->dim
[i
].ubound
;
2072 ls
[i
].step
= desc
->dim
[i
].stride
;
2074 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2075 * desc
->dim
[i
].stride
;
2080 /* Determine the index to the next record in an internal unit array by
2081 by incrementing through the array_loop_spec. TODO: Implement handling
2082 negative strides. */
2085 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2093 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2098 if (ls
[i
].idx
> ls
[i
].end
)
2100 ls
[i
].idx
= ls
[i
].start
;
2106 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2114 /* Skip to the end of the current record, taking care of an optional
2115 record marker of size bytes. If the file is not seekable, we
2116 read chunks of size MAX_READ until we get to the right
2119 #define MAX_READ 4096
2122 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2125 int rlength
, length
;
2128 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2129 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2132 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2134 new = file_position (dtp
->u
.p
.current_unit
->s
)
2135 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2137 /* Direct access files do not generate END conditions,
2139 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2140 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2143 { /* Seek by reading data. */
2144 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2147 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2148 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2150 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2153 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2157 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2165 /* Advance to the next record reading unformatted files, taking
2166 care of subrecords. If complete_record is nonzero, we loop
2167 until all subrecords are cleared. */
2170 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2174 bytes
= compile_options
.record_marker
== 0 ?
2175 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2180 /* Skip over tail */
2182 skip_record (dtp
, bytes
);
2184 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2191 /* Space to the next record for read mode. */
2194 next_record_r (st_parameter_dt
*dtp
)
2197 int length
, bytes_left
;
2200 switch (current_mode (dtp
))
2202 /* No records in unformatted STREAM I/O. */
2203 case UNFORMATTED_STREAM
:
2206 case UNFORMATTED_SEQUENTIAL
:
2207 next_record_r_unf (dtp
, 1);
2208 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2211 case FORMATTED_DIRECT
:
2212 case UNFORMATTED_DIRECT
:
2213 skip_record (dtp
, 0);
2216 case FORMATTED_STREAM
:
2217 case FORMATTED_SEQUENTIAL
:
2219 /* sf_read has already terminated input because of an '\n' */
2220 if (dtp
->u
.p
.sf_seen_eor
)
2222 dtp
->u
.p
.sf_seen_eor
= 0;
2226 if (is_internal_unit (dtp
))
2228 if (is_array_io (dtp
))
2230 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2232 /* Now seek to this record. */
2233 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2234 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2236 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2239 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2243 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2244 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2246 dtp
->u
.p
.current_unit
->bytes_left
2247 = dtp
->u
.p
.current_unit
->recl
;
2253 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2257 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2263 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2267 if (is_stream_io (dtp
))
2268 dtp
->u
.p
.current_unit
->strm_pos
++;
2275 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2276 && !dtp
->u
.p
.namelist_mode
2277 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2278 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2279 file_position (dtp
->u
.p
.current_unit
->s
)))
2280 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2285 /* Small utility function to write a record marker, taking care of
2286 byte swapping and of choosing the correct size. */
2289 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2294 char p
[sizeof (GFC_INTEGER_8
)];
2296 if (compile_options
.record_marker
== 0)
2297 len
= sizeof (GFC_INTEGER_4
);
2299 len
= compile_options
.record_marker
;
2301 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2302 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
2306 case sizeof (GFC_INTEGER_4
):
2308 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2311 case sizeof (GFC_INTEGER_8
):
2313 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2317 runtime_error ("Illegal value for record marker");
2325 case sizeof (GFC_INTEGER_4
):
2327 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2328 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2331 case sizeof (GFC_INTEGER_8
):
2333 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2334 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2338 runtime_error ("Illegal value for record marker");
2345 /* Position to the next (sub)record in write mode for
2346 unformatted sequential files. */
2349 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2351 gfc_offset c
, m
, m_write
;
2352 size_t record_marker
;
2354 /* Bytes written. */
2355 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2356 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2357 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2359 /* Write the length tail. If we finish a record containing
2360 subrecords, we write out the negative length. */
2362 if (dtp
->u
.p
.current_unit
->continued
)
2367 if (write_us_marker (dtp
, m_write
) != 0)
2370 if (compile_options
.record_marker
== 0)
2371 record_marker
= sizeof (GFC_INTEGER_4
);
2373 record_marker
= compile_options
.record_marker
;
2375 /* Seek to the head and overwrite the bogus length with the real
2378 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2387 if (write_us_marker (dtp
, m_write
) != 0)
2390 /* Seek past the end of the current record. */
2392 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2398 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2403 /* Position to the next record in write mode. */
2406 next_record_w (st_parameter_dt
*dtp
, int done
)
2408 gfc_offset m
, record
, max_pos
;
2412 /* Zero counters for X- and T-editing. */
2413 max_pos
= dtp
->u
.p
.max_pos
;
2414 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2416 switch (current_mode (dtp
))
2418 /* No records in unformatted STREAM I/O. */
2419 case UNFORMATTED_STREAM
:
2422 case FORMATTED_DIRECT
:
2423 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2426 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2427 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2432 case UNFORMATTED_DIRECT
:
2433 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2437 case UNFORMATTED_SEQUENTIAL
:
2438 next_record_w_unf (dtp
, 0);
2439 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2442 case FORMATTED_STREAM
:
2443 case FORMATTED_SEQUENTIAL
:
2445 if (is_internal_unit (dtp
))
2447 if (is_array_io (dtp
))
2449 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2451 /* If the farthest position reached is greater than current
2452 position, adjust the position and set length to pad out
2453 whats left. Otherwise just pad whats left.
2454 (for character array unit) */
2455 m
= dtp
->u
.p
.current_unit
->recl
2456 - dtp
->u
.p
.current_unit
->bytes_left
;
2459 length
= (int) (max_pos
- m
);
2460 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2461 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2464 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2466 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2470 /* Now that the current record has been padded out,
2471 determine where the next record in the array is. */
2472 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2474 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2476 /* Now seek to this record */
2477 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2479 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2481 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2485 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2491 /* If this is the last call to next_record move to the farthest
2492 position reached and set length to pad out the remainder
2493 of the record. (for character scaler unit) */
2496 m
= dtp
->u
.p
.current_unit
->recl
2497 - dtp
->u
.p
.current_unit
->bytes_left
;
2500 length
= (int) (max_pos
- m
);
2501 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2502 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2505 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2508 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2510 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2517 /* If this is the last call to next_record move to the farthest
2518 position reached in preparation for completing the record.
2522 m
= dtp
->u
.p
.current_unit
->recl
-
2523 dtp
->u
.p
.current_unit
->bytes_left
;
2526 length
= (int) (max_pos
- m
);
2527 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2531 const char crlf
[] = "\r\n";
2537 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2540 if (is_stream_io (dtp
))
2541 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2547 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2552 /* Position to the next record, which means moving to the end of the
2553 current record. This can happen under several different
2554 conditions. If the done flag is not set, we get ready to process
2558 next_record (st_parameter_dt
*dtp
, int done
)
2560 gfc_offset fp
; /* File position. */
2562 dtp
->u
.p
.current_unit
->read_bad
= 0;
2564 if (dtp
->u
.p
.mode
== READING
)
2565 next_record_r (dtp
);
2567 next_record_w (dtp
, done
);
2569 if (!is_stream_io (dtp
))
2571 /* Keep position up to date for INQUIRE */
2573 update_position (dtp
->u
.p
.current_unit
);
2575 dtp
->u
.p
.current_unit
->current_record
= 0;
2576 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2578 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2579 /* Calculate next record, rounding up partial records. */
2580 dtp
->u
.p
.current_unit
->last_record
=
2581 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2582 dtp
->u
.p
.current_unit
->recl
;
2585 dtp
->u
.p
.current_unit
->last_record
++;
2593 /* Finalize the current data transfer. For a nonadvancing transfer,
2594 this means advancing to the next record. For internal units close the
2595 stream associated with the unit. */
2598 finalize_transfer (st_parameter_dt
*dtp
)
2601 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2603 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2604 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2606 if (dtp
->u
.p
.eor_condition
)
2608 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2612 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2615 if ((dtp
->u
.p
.ionml
!= NULL
)
2616 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2618 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2619 namelist_read (dtp
);
2621 namelist_write (dtp
);
2624 dtp
->u
.p
.transfer
= NULL
;
2625 if (dtp
->u
.p
.current_unit
== NULL
)
2628 dtp
->u
.p
.eof_jump
= &eof_jump
;
2629 if (setjmp (eof_jump
))
2631 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2635 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2637 finish_list_read (dtp
);
2638 sfree (dtp
->u
.p
.current_unit
->s
);
2642 if (is_stream_io (dtp
))
2644 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2645 next_record (dtp
, 1);
2646 flush (dtp
->u
.p
.current_unit
->s
);
2647 sfree (dtp
->u
.p
.current_unit
->s
);
2651 dtp
->u
.p
.current_unit
->current_record
= 0;
2653 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2655 dtp
->u
.p
.seen_dollar
= 0;
2656 sfree (dtp
->u
.p
.current_unit
->s
);
2660 /* For non-advancing I/O, save the current maximum position for use in the
2661 next I/O operation if needed. */
2662 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2664 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2665 - dtp
->u
.p
.current_unit
->bytes_left
);
2666 dtp
->u
.p
.current_unit
->saved_pos
=
2667 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2668 flush (dtp
->u
.p
.current_unit
->s
);
2672 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2674 next_record (dtp
, 1);
2675 sfree (dtp
->u
.p
.current_unit
->s
);
2678 /* Transfer function for IOLENGTH. It doesn't actually do any
2679 data transfer, it just updates the length counter. */
2682 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2683 void *dest
__attribute__ ((unused
)),
2684 int kind
__attribute__((unused
)),
2685 size_t size
, size_t nelems
)
2687 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2688 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2692 /* Initialize the IOLENGTH data transfer. This function is in essence
2693 a very much simplified version of data_transfer_init(), because it
2694 doesn't have to deal with units at all. */
2697 iolength_transfer_init (st_parameter_dt
*dtp
)
2699 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2702 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2704 /* Set up the subroutine that will handle the transfers. */
2706 dtp
->u
.p
.transfer
= iolength_transfer
;
2710 /* Library entry point for the IOLENGTH form of the INQUIRE
2711 statement. The IOLENGTH form requires no I/O to be performed, but
2712 it must still be a runtime library call so that we can determine
2713 the iolength for dynamic arrays and such. */
2715 extern void st_iolength (st_parameter_dt
*);
2716 export_proto(st_iolength
);
2719 st_iolength (st_parameter_dt
*dtp
)
2721 library_start (&dtp
->common
);
2722 iolength_transfer_init (dtp
);
2725 extern void st_iolength_done (st_parameter_dt
*);
2726 export_proto(st_iolength_done
);
2729 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2732 if (dtp
->u
.p
.scratch
!= NULL
)
2733 free_mem (dtp
->u
.p
.scratch
);
2738 /* The READ statement. */
2740 extern void st_read (st_parameter_dt
*);
2741 export_proto(st_read
);
2744 st_read (st_parameter_dt
*dtp
)
2746 library_start (&dtp
->common
);
2748 data_transfer_init (dtp
, 1);
2750 /* Handle complications dealing with the endfile record. */
2752 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2753 switch (dtp
->u
.p
.current_unit
->endfile
)
2759 if (!is_internal_unit (dtp
))
2761 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2762 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2763 dtp
->u
.p
.current_unit
->current_record
= 0;
2768 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2769 dtp
->u
.p
.current_unit
->current_record
= 0;
2774 extern void st_read_done (st_parameter_dt
*);
2775 export_proto(st_read_done
);
2778 st_read_done (st_parameter_dt
*dtp
)
2780 finalize_transfer (dtp
);
2781 free_format_data (dtp
);
2783 if (dtp
->u
.p
.scratch
!= NULL
)
2784 free_mem (dtp
->u
.p
.scratch
);
2785 if (dtp
->u
.p
.current_unit
!= NULL
)
2786 unlock_unit (dtp
->u
.p
.current_unit
);
2788 free_internal_unit (dtp
);
2793 extern void st_write (st_parameter_dt
*);
2794 export_proto(st_write
);
2797 st_write (st_parameter_dt
*dtp
)
2799 library_start (&dtp
->common
);
2800 data_transfer_init (dtp
, 0);
2803 extern void st_write_done (st_parameter_dt
*);
2804 export_proto(st_write_done
);
2807 st_write_done (st_parameter_dt
*dtp
)
2809 finalize_transfer (dtp
);
2811 /* Deal with endfile conditions associated with sequential files. */
2813 if (dtp
->u
.p
.current_unit
!= NULL
2814 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2815 switch (dtp
->u
.p
.current_unit
->endfile
)
2817 case AT_ENDFILE
: /* Remain at the endfile record. */
2821 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2825 /* Get rid of whatever is after this record. */
2826 if (!is_internal_unit (dtp
))
2828 flush (dtp
->u
.p
.current_unit
->s
);
2829 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2830 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2832 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2836 free_format_data (dtp
);
2838 if (dtp
->u
.p
.scratch
!= NULL
)
2839 free_mem (dtp
->u
.p
.scratch
);
2840 if (dtp
->u
.p
.current_unit
!= NULL
)
2841 unlock_unit (dtp
->u
.p
.current_unit
);
2843 free_internal_unit (dtp
);
2848 /* Receives the scalar information for namelist objects and stores it
2849 in a linked list of namelist_info types. */
2851 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2852 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2853 export_proto(st_set_nml_var
);
2857 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2858 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2859 GFC_INTEGER_4 dtype
)
2861 namelist_info
*t1
= NULL
;
2863 size_t var_name_len
= strlen (var_name
);
2865 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2867 nml
->mem_pos
= var_addr
;
2869 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2870 memcpy (nml
->var_name
, var_name
, var_name_len
);
2871 nml
->var_name
[var_name_len
] = '\0';
2873 nml
->len
= (int) len
;
2874 nml
->string_length
= (index_type
) string_length
;
2876 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2877 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2878 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2880 if (nml
->var_rank
> 0)
2882 nml
->dim
= (descriptor_dimension
*)
2883 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2884 nml
->ls
= (array_loop_spec
*)
2885 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2895 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2897 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2898 dtp
->u
.p
.ionml
= nml
;
2902 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2907 /* Store the dimensional information for the namelist object. */
2908 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2909 index_type
, index_type
,
2911 export_proto(st_set_nml_var_dim
);
2914 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2915 index_type stride
, index_type lbound
,
2918 namelist_info
* nml
;
2923 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2925 nml
->dim
[n
].stride
= stride
;
2926 nml
->dim
[n
].lbound
= lbound
;
2927 nml
->dim
[n
].ubound
= ubound
;
2930 /* Reverse memcpy - used for byte swapping. */
2932 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2938 s
= (char *) src
+ n
- 1;
2940 /* Write with ascending order - this is likely faster
2941 on modern architectures because of write combining. */