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
)
172 if (is_internal_unit (dtp
))
174 /* readlen may be modified inside salloc_r if
175 is_internal_unit (dtp) is true. */
179 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
183 /* If we have a line without a terminating \n, drop through to
185 if (readlen
< 1 && n
== 0)
189 generate_error (&dtp
->common
, ERROR_END
, NULL
);
193 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
195 /* Unexpected end of line. */
197 /* If we see an EOR during non-advancing I/O, we need to skip
198 the rest of the I/O statement. Set the corresponding flag. */
199 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
200 dtp
->u
.p
.eor_condition
= 1;
203 /* If we encounter a CR, it might be a CRLF. */
204 if (*q
== '\r') /* Probably a CRLF */
207 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
208 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
209 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
210 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
215 /* Without padding, terminate the I/O statement without assigning
216 the value. With padding, the value still needs to be assigned,
217 so we can just continue with a short read. */
218 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
222 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
227 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
230 /* Short circuit the read if a comma is found during numeric input.
231 The flag is set to zero during character reads so that commas in
232 strings are not ignored */
234 if (dtp
->u
.p
.sf_read_comma
== 1)
236 notify_std (&dtp
->common
, GFC_STD_GNU
,
237 "Comma in formatted numeric read.");
244 dtp
->u
.p
.sf_seen_eor
= 0;
247 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
249 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
250 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
256 /* Function for reading the next couple of bytes from the current
257 file, advancing the current position. We return a pointer to a
258 buffer containing the bytes. We return NULL on end of record or
261 If the read is short, then it is because the current record does not
262 have enough data to satisfy the read request and the file was
263 opened with PAD=YES. The caller must assume tailing spaces for
267 read_block (st_parameter_dt
*dtp
, int *length
)
272 if (is_stream_io (dtp
))
274 if (sseek (dtp
->u
.p
.current_unit
->s
,
275 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
277 generate_error (&dtp
->common
, ERROR_END
, NULL
);
283 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
285 /* For preconnected units with default record length, set bytes left
286 to unit record length and proceed, otherwise error. */
287 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
288 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
289 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
292 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
294 /* Not enough data left. */
295 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
300 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
302 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
303 generate_error (&dtp
->common
, ERROR_END
, NULL
);
307 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
311 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
312 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
313 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
315 source
= read_sf (dtp
, length
, 0);
316 dtp
->u
.p
.current_unit
->strm_pos
+=
317 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
320 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
323 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
325 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
326 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
328 if (nread
!= *length
)
329 { /* Short read, this shouldn't happen. */
330 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
334 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
339 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
345 /* Reads a block directly into application data space. This is for
346 unformatted files. */
349 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
351 size_t to_read_record
;
352 size_t have_read_record
;
353 size_t to_read_subrecord
;
354 size_t have_read_subrecord
;
357 if (is_stream_io (dtp
))
359 if (sseek (dtp
->u
.p
.current_unit
->s
,
360 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
362 generate_error (&dtp
->common
, ERROR_END
, NULL
);
366 to_read_record
= *nbytes
;
367 have_read_record
= to_read_record
;
368 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
370 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
374 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
376 if (to_read_record
!= have_read_record
)
378 /* Short read, e.g. if we hit EOF. For stream files,
379 we have to set the end-of-file condition. */
380 generate_error (&dtp
->common
, ERROR_END
, NULL
);
386 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
388 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
391 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
392 *nbytes
= to_read_record
;
398 to_read_record
= *nbytes
;
401 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
403 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
405 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
409 if (to_read_record
!= *nbytes
)
411 /* Short read, e.g. if we hit EOF. Apparently, we read
412 more than was written to the last record. */
413 *nbytes
= to_read_record
;
419 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
425 /* Unformatted sequential. We loop over the subrecords, reading
426 until the request has been fulfilled or the record has run out
427 of continuation subrecords. */
429 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
431 generate_error (&dtp
->common
, ERROR_END
, NULL
);
435 /* Check whether we exceed the total record length. */
437 if (dtp
->u
.p
.current_unit
->flags
.has_recl
438 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
440 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
445 to_read_record
= *nbytes
;
448 have_read_record
= 0;
452 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
453 < (gfc_offset
) to_read_record
)
455 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
456 to_read_record
-= to_read_subrecord
;
460 to_read_subrecord
= to_read_record
;
464 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
466 have_read_subrecord
= to_read_subrecord
;
467 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
468 &have_read_subrecord
) != 0)
470 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
474 have_read_record
+= have_read_subrecord
;
476 if (to_read_subrecord
!= have_read_subrecord
)
479 /* Short read, e.g. if we hit EOF. This means the record
480 structure has been corrupted, or the trailing record
481 marker would still be present. */
483 *nbytes
= have_read_record
;
484 generate_error (&dtp
->common
, ERROR_CORRUPT_FILE
, NULL
);
488 if (to_read_record
> 0)
490 if (dtp
->u
.p
.current_unit
->continued
)
492 next_record_r_unf (dtp
, 0);
497 /* Let's make sure the file position is correctly pre-positioned
498 for the next read statement. */
500 dtp
->u
.p
.current_unit
->current_record
= 0;
501 next_record_r_unf (dtp
, 0);
502 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
508 /* Normal exit, the read request has been fulfilled. */
513 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
516 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
523 /* Function for writing a block of bytes to the current file at the
524 current position, advancing the file pointer. We are given a length
525 and return a pointer to a buffer that the caller must (completely)
526 fill in. Returns NULL on error. */
529 write_block (st_parameter_dt
*dtp
, int length
)
533 if (is_stream_io (dtp
))
535 if (sseek (dtp
->u
.p
.current_unit
->s
,
536 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
538 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
544 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
546 /* For preconnected units with default record length, set bytes left
547 to unit record length and proceed, otherwise error. */
548 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
549 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
550 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
551 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
554 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
559 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
562 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
566 generate_error (&dtp
->common
, ERROR_END
, NULL
);
570 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
571 generate_error (&dtp
->common
, ERROR_END
, NULL
);
573 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
574 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
576 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
582 /* High level interface to swrite(), taking care of errors. This is only
583 called for unformatted files. There are three cases to consider:
584 Stream I/O, unformatted direct, unformatted sequential. */
587 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
590 size_t have_written
, to_write_subrecord
;
596 if (is_stream_io (dtp
))
598 if (sseek (dtp
->u
.p
.current_unit
->s
,
599 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
601 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
605 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
607 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
611 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
616 /* Unformatted direct access. */
618 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
620 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
622 generate_error (&dtp
->common
, ERROR_DIRECT_EOR
, NULL
);
626 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
628 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
632 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
633 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
639 /* Unformatted sequential. */
643 if (dtp
->u
.p
.current_unit
->flags
.has_recl
644 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
646 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
658 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
659 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
661 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
662 (gfc_offset
) to_write_subrecord
;
664 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
665 &to_write_subrecord
) != 0)
667 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
671 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
672 nbytes
-= to_write_subrecord
;
673 have_written
+= to_write_subrecord
;
678 next_record_w_unf (dtp
, 1);
681 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
684 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
691 /* Master function for unformatted reads. */
694 unformatted_read (st_parameter_dt
*dtp
, bt type
,
695 void *dest
, int kind
,
696 size_t size
, size_t nelems
)
700 /* Currently, character implies size=1. */
701 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
702 || size
== 1 || type
== BT_CHARACTER
)
705 read_block_direct (dtp
, dest
, &sz
);
712 /* Break up complex into its constituent reals. */
713 if (type
== BT_COMPLEX
)
720 /* By now, all complex variables have been split into their
721 constituent reals. For types with padding, we only need to
722 read kind bytes. We don't care about the contents
723 of the padding. If we hit a short record, then sz is
724 adjusted accordingly, making later reads no-ops. */
727 for (i
=0; i
<nelems
; i
++)
729 read_block_direct (dtp
, buffer
, &sz
);
730 reverse_memcpy (p
, buffer
, sz
);
737 /* Master function for unformatted writes. */
740 unformatted_write (st_parameter_dt
*dtp
, bt type
,
741 void *source
, int kind
,
742 size_t size
, size_t nelems
)
744 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
745 size
== 1 || type
== BT_CHARACTER
)
749 write_buf (dtp
, source
, size
);
757 /* Break up complex into its constituent reals. */
758 if (type
== BT_COMPLEX
)
766 /* By now, all complex variables have been split into their
767 constituent reals. For types with padding, we only need to
768 read kind bytes. We don't care about the contents
772 for (i
=0; i
<nelems
; i
++)
774 reverse_memcpy(buffer
, p
, size
);
776 write_buf (dtp
, buffer
, sz
);
782 /* Return a pointer to the name of a type. */
807 internal_error (NULL
, "type_name(): Bad type");
814 /* Write a constant string to the output.
815 This is complicated because the string can have doubled delimiters
816 in it. The length in the format node is the true length. */
819 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
821 char c
, delimiter
, *p
, *q
;
824 length
= f
->u
.string
.length
;
828 p
= write_block (dtp
, length
);
835 for (; length
> 0; length
--)
838 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
839 q
++; /* Skip the doubled delimiter. */
844 /* Given actual and expected types in a formatted data transfer, make
845 sure they agree. If not, an error message is generated. Returns
846 nonzero if something went wrong. */
849 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
853 if (actual
== expected
)
856 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
857 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
859 format_error (dtp
, f
, buffer
);
864 /* This subroutine is the main loop for a formatted data transfer
865 statement. It would be natural to implement this as a coroutine
866 with the user program, but C makes that awkward. We loop,
867 processing format elements. When we actually have to transfer
868 data instead of just setting flags, we return control to the user
869 program which calls a subroutine that supplies the address and type
870 of the next element, then comes back here to process it. */
873 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
876 char scratch
[SCRATCH_SIZE
];
881 int consume_data_flag
;
883 /* Change a complex data item into a pair of reals. */
885 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
886 if (type
== BT_COMPLEX
)
892 /* If there's an EOR condition, we simulate finalizing the transfer
894 if (dtp
->u
.p
.eor_condition
)
897 /* Set this flag so that commas in reads cause the read to complete before
898 the entire field has been read. The next read field will start right after
899 the comma in the stream. (Set to 0 for character reads). */
900 dtp
->u
.p
.sf_read_comma
= 1;
902 dtp
->u
.p
.line_buffer
= scratch
;
905 /* If reversion has occurred and there is another real data item,
906 then we have to move to the next record. */
907 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
909 dtp
->u
.p
.reversion_flag
= 0;
910 next_record (dtp
, 0);
913 consume_data_flag
= 1 ;
914 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
917 f
= next_format (dtp
);
920 /* No data descriptors left. */
922 generate_error (&dtp
->common
, ERROR_FORMAT
,
923 "Insufficient data descriptors in format after reversion");
927 /* Now discharge T, TR and X movements to the right. This is delayed
928 until a data producing format to suppress trailing spaces. */
931 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
932 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
933 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
934 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
935 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
938 if (dtp
->u
.p
.skips
> 0)
940 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
941 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
942 - dtp
->u
.p
.current_unit
->bytes_left
);
944 if (dtp
->u
.p
.skips
< 0)
946 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
947 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
949 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
952 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
953 - dtp
->u
.p
.current_unit
->bytes_left
);
960 if (require_type (dtp
, BT_INTEGER
, type
, f
))
963 if (dtp
->u
.p
.mode
== READING
)
964 read_decimal (dtp
, f
, p
, len
);
966 write_i (dtp
, f
, p
, len
);
974 if (compile_options
.allow_std
< GFC_STD_GNU
975 && require_type (dtp
, BT_INTEGER
, type
, f
))
978 if (dtp
->u
.p
.mode
== READING
)
979 read_radix (dtp
, f
, p
, len
, 2);
981 write_b (dtp
, f
, p
, len
);
989 if (compile_options
.allow_std
< GFC_STD_GNU
990 && require_type (dtp
, BT_INTEGER
, type
, f
))
993 if (dtp
->u
.p
.mode
== READING
)
994 read_radix (dtp
, f
, p
, len
, 8);
996 write_o (dtp
, f
, p
, len
);
1004 if (compile_options
.allow_std
< GFC_STD_GNU
1005 && require_type (dtp
, BT_INTEGER
, type
, f
))
1008 if (dtp
->u
.p
.mode
== READING
)
1009 read_radix (dtp
, f
, p
, len
, 16);
1011 write_z (dtp
, f
, p
, len
);
1019 if (dtp
->u
.p
.mode
== READING
)
1020 read_a (dtp
, f
, p
, len
);
1022 write_a (dtp
, f
, p
, len
);
1030 if (dtp
->u
.p
.mode
== READING
)
1031 read_l (dtp
, f
, p
, len
);
1033 write_l (dtp
, f
, p
, len
);
1040 if (require_type (dtp
, BT_REAL
, type
, f
))
1043 if (dtp
->u
.p
.mode
== READING
)
1044 read_f (dtp
, f
, p
, len
);
1046 write_d (dtp
, f
, p
, len
);
1053 if (require_type (dtp
, BT_REAL
, type
, f
))
1056 if (dtp
->u
.p
.mode
== READING
)
1057 read_f (dtp
, f
, p
, len
);
1059 write_e (dtp
, f
, p
, len
);
1065 if (require_type (dtp
, BT_REAL
, type
, f
))
1068 if (dtp
->u
.p
.mode
== READING
)
1069 read_f (dtp
, f
, p
, len
);
1071 write_en (dtp
, f
, p
, len
);
1078 if (require_type (dtp
, BT_REAL
, type
, f
))
1081 if (dtp
->u
.p
.mode
== READING
)
1082 read_f (dtp
, f
, p
, len
);
1084 write_es (dtp
, f
, p
, len
);
1091 if (require_type (dtp
, BT_REAL
, type
, f
))
1094 if (dtp
->u
.p
.mode
== READING
)
1095 read_f (dtp
, f
, p
, len
);
1097 write_f (dtp
, f
, p
, len
);
1104 if (dtp
->u
.p
.mode
== READING
)
1108 read_decimal (dtp
, f
, p
, len
);
1111 read_l (dtp
, f
, p
, len
);
1114 read_a (dtp
, f
, p
, len
);
1117 read_f (dtp
, f
, p
, len
);
1126 write_i (dtp
, f
, p
, len
);
1129 write_l (dtp
, f
, p
, len
);
1132 write_a (dtp
, f
, p
, len
);
1135 write_d (dtp
, f
, p
, len
);
1139 internal_error (&dtp
->common
,
1140 "formatted_transfer(): Bad type");
1146 consume_data_flag
= 0 ;
1147 if (dtp
->u
.p
.mode
== READING
)
1149 format_error (dtp
, f
, "Constant string in input format");
1152 write_constant_string (dtp
, f
);
1155 /* Format codes that don't transfer data. */
1158 consume_data_flag
= 0;
1160 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
1161 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
1162 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
1164 /* Writes occur just before the switch on f->format, above, so
1165 that trailing blanks are suppressed, unless we are doing a
1166 non-advancing write in which case we want to output the blanks
1168 if (dtp
->u
.p
.mode
== WRITING
1169 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1171 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1172 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1175 if (dtp
->u
.p
.mode
== READING
)
1176 read_x (dtp
, f
->u
.n
);
1182 consume_data_flag
= 0;
1184 if (f
->format
== FMT_TL
)
1187 /* Handle the special case when no bytes have been used yet.
1188 Cannot go below zero. */
1189 if (bytes_used
== 0)
1191 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1192 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
1193 : dtp
->u
.p
.pending_spaces
;
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
;
1218 if (dtp
->u
.p
.skips
== 0)
1221 /* Writes occur just before the switch on f->format, above, so that
1222 trailing blanks are suppressed. */
1223 if (dtp
->u
.p
.mode
== READING
)
1225 /* Adjust everything for end-of-record condition */
1226 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1228 if (dtp
->u
.p
.sf_seen_eor
== 2)
1230 /* The EOR was a CRLF (two bytes wide). */
1231 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1232 dtp
->u
.p
.skips
-= 2;
1236 /* The EOR marker was only one byte wide. */
1237 dtp
->u
.p
.current_unit
->bytes_left
--;
1241 dtp
->u
.p
.sf_seen_eor
= 0;
1243 if (dtp
->u
.p
.skips
< 0)
1245 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1246 dtp
->u
.p
.current_unit
->bytes_left
1247 -= (gfc_offset
) dtp
->u
.p
.skips
;
1248 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1251 read_x (dtp
, dtp
->u
.p
.skips
);
1257 consume_data_flag
= 0 ;
1258 dtp
->u
.p
.sign_status
= SIGN_S
;
1262 consume_data_flag
= 0 ;
1263 dtp
->u
.p
.sign_status
= SIGN_SS
;
1267 consume_data_flag
= 0 ;
1268 dtp
->u
.p
.sign_status
= SIGN_SP
;
1272 consume_data_flag
= 0 ;
1273 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1277 consume_data_flag
= 0 ;
1278 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1282 consume_data_flag
= 0 ;
1283 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1287 consume_data_flag
= 0 ;
1288 dtp
->u
.p
.seen_dollar
= 1;
1292 consume_data_flag
= 0 ;
1293 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1294 next_record (dtp
, 0);
1298 /* A colon descriptor causes us to exit this loop (in
1299 particular preventing another / descriptor from being
1300 processed) unless there is another data item to be
1302 consume_data_flag
= 0 ;
1308 internal_error (&dtp
->common
, "Bad format node");
1311 /* Free a buffer that we had to allocate during a sequential
1312 formatted read of a block that was larger than the static
1315 if (dtp
->u
.p
.line_buffer
!= scratch
)
1317 free_mem (dtp
->u
.p
.line_buffer
);
1318 dtp
->u
.p
.line_buffer
= scratch
;
1321 /* Adjust the item count and data pointer. */
1323 if ((consume_data_flag
> 0) && (n
> 0))
1326 p
= ((char *) p
) + size
;
1329 if (dtp
->u
.p
.mode
== READING
)
1332 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1333 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1339 /* Come here when we need a data descriptor but don't have one. We
1340 push the current format node back onto the input, then return and
1341 let the user program call us back with the data. */
1343 unget_format (dtp
, f
);
1347 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1348 size_t size
, size_t nelems
)
1355 /* Big loop over all the elements. */
1356 for (elem
= 0; elem
< nelems
; elem
++)
1358 dtp
->u
.p
.item_count
++;
1359 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1365 /* Data transfer entry points. The type of the data entity is
1366 implicit in the subroutine call. This prevents us from having to
1367 share a common enum with the compiler. */
1370 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1372 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1374 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1379 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1382 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1384 size
= size_from_real_kind (kind
);
1385 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1390 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1392 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1394 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1399 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1401 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1403 /* Currently we support only 1 byte chars, and the library is a bit
1404 confused of character kind vs. length, so we kludge it by setting
1406 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1411 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1414 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1416 size
= size_from_complex_kind (kind
);
1417 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1422 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1423 gfc_charlen_type charlen
)
1425 index_type count
[GFC_MAX_DIMENSIONS
];
1426 index_type extent
[GFC_MAX_DIMENSIONS
];
1427 index_type stride
[GFC_MAX_DIMENSIONS
];
1428 index_type stride0
, rank
, size
, type
, n
;
1433 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1436 type
= GFC_DESCRIPTOR_TYPE (desc
);
1437 size
= GFC_DESCRIPTOR_SIZE (desc
);
1439 /* FIXME: What a kludge: Array descriptors and the IO library use
1440 different enums for types. */
1443 case GFC_DTYPE_UNKNOWN
:
1444 iotype
= BT_NULL
; /* Is this correct? */
1446 case GFC_DTYPE_INTEGER
:
1447 iotype
= BT_INTEGER
;
1449 case GFC_DTYPE_LOGICAL
:
1450 iotype
= BT_LOGICAL
;
1452 case GFC_DTYPE_REAL
:
1455 case GFC_DTYPE_COMPLEX
:
1456 iotype
= BT_COMPLEX
;
1458 case GFC_DTYPE_CHARACTER
:
1459 iotype
= BT_CHARACTER
;
1460 /* FIXME: Currently dtype contains the charlen, which is
1461 clobbered if charlen > 2**24. That's why we use a separate
1462 argument for the charlen. However, if we want to support
1463 non-8-bit charsets we need to fix dtype to contain
1464 sizeof(chartype) and fix the code below. */
1468 case GFC_DTYPE_DERIVED
:
1469 internal_error (&dtp
->common
,
1470 "Derived type I/O should have been handled via the frontend.");
1473 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1476 rank
= GFC_DESCRIPTOR_RANK (desc
);
1477 for (n
= 0; n
< rank
; n
++)
1480 stride
[n
] = desc
->dim
[n
].stride
;
1481 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1483 /* If the extent of even one dimension is zero, then the entire
1484 array section contains zero elements, so we return. */
1489 stride0
= stride
[0];
1491 /* If the innermost dimension has stride 1, we can do the transfer
1492 in contiguous chunks. */
1498 data
= GFC_DESCRIPTOR_DATA (desc
);
1502 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1503 data
+= stride0
* size
* tsize
;
1506 while (count
[n
] == extent
[n
])
1509 data
-= stride
[n
] * extent
[n
] * size
;
1519 data
+= stride
[n
] * size
;
1526 /* Preposition a sequential unformatted file while reading. */
1529 us_read (st_parameter_dt
*dtp
, int continued
)
1538 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1541 if (compile_options
.record_marker
== 0)
1542 n
= sizeof (GFC_INTEGER_4
);
1544 n
= compile_options
.record_marker
;
1548 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1552 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1553 return; /* end of file */
1556 if (p
== NULL
|| n
!= nr
)
1558 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1562 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1563 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1567 case sizeof(GFC_INTEGER_4
):
1568 memcpy (&i4
, p
, sizeof (i4
));
1572 case sizeof(GFC_INTEGER_8
):
1573 memcpy (&i8
, p
, sizeof (i8
));
1578 runtime_error ("Illegal value for record marker");
1585 case sizeof(GFC_INTEGER_4
):
1586 reverse_memcpy (&i4
, p
, sizeof (i4
));
1590 case sizeof(GFC_INTEGER_8
):
1591 reverse_memcpy (&i8
, p
, sizeof (i8
));
1596 runtime_error ("Illegal value for record marker");
1602 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1603 dtp
->u
.p
.current_unit
->continued
= 0;
1607 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1608 dtp
->u
.p
.current_unit
->continued
= 1;
1612 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1616 /* Preposition a sequential unformatted file while writing. This
1617 amount to writing a bogus length that will be filled in later. */
1620 us_write (st_parameter_dt
*dtp
, int continued
)
1627 if (compile_options
.record_marker
== 0)
1628 nbytes
= sizeof (GFC_INTEGER_4
);
1630 nbytes
= compile_options
.record_marker
;
1632 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1633 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1635 /* For sequential unformatted, if RECL= was not specified in the OPEN
1636 we write until we have more bytes than can fit in the subrecord
1637 markers, then we write a new subrecord. */
1639 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1640 dtp
->u
.p
.current_unit
->recl_subrecord
;
1641 dtp
->u
.p
.current_unit
->continued
= continued
;
1645 /* Position to the next record prior to transfer. We are assumed to
1646 be before the next record. We also calculate the bytes in the next
1650 pre_position (st_parameter_dt
*dtp
)
1652 if (dtp
->u
.p
.current_unit
->current_record
)
1653 return; /* Already positioned. */
1655 switch (current_mode (dtp
))
1657 case FORMATTED_STREAM
:
1658 case UNFORMATTED_STREAM
:
1659 /* There are no records with stream I/O. Set the default position
1660 to the beginning of the file if no position was specified. */
1661 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1662 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1665 case UNFORMATTED_SEQUENTIAL
:
1666 if (dtp
->u
.p
.mode
== READING
)
1673 case FORMATTED_SEQUENTIAL
:
1674 case FORMATTED_DIRECT
:
1675 case UNFORMATTED_DIRECT
:
1676 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1680 dtp
->u
.p
.current_unit
->current_record
= 1;
1684 /* Initialize things for a data transfer. This code is common for
1685 both reading and writing. */
1688 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1690 unit_flags u_flags
; /* Used for creating a unit if needed. */
1691 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1692 namelist_info
*ionml
;
1694 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1695 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1696 dtp
->u
.p
.ionml
= ionml
;
1697 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1699 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1700 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1702 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1703 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1704 { /* Open the unit with some default flags. */
1705 st_parameter_open opp
;
1708 if (dtp
->common
.unit
< 0)
1710 close_unit (dtp
->u
.p
.current_unit
);
1711 dtp
->u
.p
.current_unit
= NULL
;
1712 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1713 "Bad unit number in OPEN statement");
1716 memset (&u_flags
, '\0', sizeof (u_flags
));
1717 u_flags
.access
= ACCESS_SEQUENTIAL
;
1718 u_flags
.action
= ACTION_READWRITE
;
1720 /* Is it unformatted? */
1721 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1722 | IOPARM_DT_IONML_SET
)))
1723 u_flags
.form
= FORM_UNFORMATTED
;
1725 u_flags
.form
= FORM_UNSPECIFIED
;
1727 u_flags
.delim
= DELIM_UNSPECIFIED
;
1728 u_flags
.blank
= BLANK_UNSPECIFIED
;
1729 u_flags
.pad
= PAD_UNSPECIFIED
;
1730 u_flags
.status
= STATUS_UNKNOWN
;
1732 conv
= get_unformatted_convert (dtp
->common
.unit
);
1734 if (conv
== CONVERT_NONE
)
1735 conv
= compile_options
.convert
;
1737 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1738 and 1 on big-endian machines. */
1741 case CONVERT_NATIVE
:
1746 conv
= l8_to_l4_offset
? CONVERT_NATIVE
: CONVERT_SWAP
;
1749 case CONVERT_LITTLE
:
1750 conv
= l8_to_l4_offset
? CONVERT_SWAP
: CONVERT_NATIVE
;
1754 internal_error (&opp
.common
, "Illegal value for CONVERT");
1758 u_flags
.convert
= conv
;
1760 opp
.common
= dtp
->common
;
1761 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1762 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1763 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1764 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1765 if (dtp
->u
.p
.current_unit
== NULL
)
1769 /* Check the action. */
1771 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1773 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1774 "Cannot read from file opened for WRITE");
1778 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1780 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1781 "Cannot write to file opened for READ");
1785 dtp
->u
.p
.first_item
= 1;
1787 /* Check the format. */
1789 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1792 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1793 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1796 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1797 "Format present for UNFORMATTED data transfer");
1801 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1803 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1804 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1805 "A format cannot be specified with a namelist");
1807 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1808 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1810 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1811 "Missing format for FORMATTED data transfer");
1814 if (is_internal_unit (dtp
)
1815 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1817 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1818 "Internal file cannot be accessed by UNFORMATTED "
1823 /* Check the record or position number. */
1825 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1826 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1828 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1829 "Direct access data transfer requires record number");
1833 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1834 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1836 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1837 "Record number not allowed for sequential access data transfer");
1841 /* Process the ADVANCE option. */
1843 dtp
->u
.p
.advance_status
1844 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1845 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1846 "Bad ADVANCE parameter in data transfer statement");
1848 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1850 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1852 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1853 "ADVANCE specification conflicts with sequential access");
1857 if (is_internal_unit (dtp
))
1859 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1860 "ADVANCE specification conflicts with internal file");
1864 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1865 != IOPARM_DT_HAS_FORMAT
)
1867 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1868 "ADVANCE specification requires an explicit format");
1875 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1877 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1878 "EOR specification requires an ADVANCE specification "
1883 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1885 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1886 "SIZE specification requires an ADVANCE specification of NO");
1891 { /* Write constraints. */
1892 if ((cf
& IOPARM_END
) != 0)
1894 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1895 "END specification cannot appear in a write statement");
1899 if ((cf
& IOPARM_EOR
) != 0)
1901 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1902 "EOR specification cannot appear in a write statement");
1906 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1908 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1909 "SIZE specification cannot appear in a write statement");
1914 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1915 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1917 /* Sanity checks on the record number. */
1918 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1922 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1923 "Record number must be positive");
1927 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1929 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1930 "Record number too large");
1934 /* Check to see if we might be reading what we wrote before */
1936 if (dtp
->u
.p
.mode
== READING
1937 && dtp
->u
.p
.current_unit
->mode
== WRITING
1938 && !is_internal_unit (dtp
))
1939 flush(dtp
->u
.p
.current_unit
->s
);
1941 /* Check whether the record exists to be read. Only
1942 a partial record needs to exist. */
1944 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1945 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1947 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1948 "Non-existing record number");
1952 /* Position the file. */
1953 if (!is_stream_io (dtp
))
1955 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1956 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1958 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1963 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1967 /* Overwriting an existing sequential file ?
1968 it is always safe to truncate the file on the first write */
1969 if (dtp
->u
.p
.mode
== WRITING
1970 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1971 && dtp
->u
.p
.current_unit
->last_record
== 0
1972 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1973 struncate(dtp
->u
.p
.current_unit
->s
);
1975 /* Bugware for badly written mixed C-Fortran I/O. */
1976 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1978 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1980 /* Set the initial value of flags. */
1982 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1983 dtp
->u
.p
.sign_status
= SIGN_S
;
1985 /* Set the maximum position reached from the previous I/O operation. This
1986 could be greater than zero from a previous non-advancing write. */
1987 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
1991 /* Set up the subroutine that will handle the transfers. */
1995 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1996 dtp
->u
.p
.transfer
= unformatted_read
;
1999 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2000 dtp
->u
.p
.transfer
= list_formatted_read
;
2002 dtp
->u
.p
.transfer
= formatted_transfer
;
2007 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2008 dtp
->u
.p
.transfer
= unformatted_write
;
2011 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2012 dtp
->u
.p
.transfer
= list_formatted_write
;
2014 dtp
->u
.p
.transfer
= formatted_transfer
;
2018 /* Make sure that we don't do a read after a nonadvancing write. */
2022 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2024 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
2025 "Cannot READ after a nonadvancing WRITE");
2031 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2032 dtp
->u
.p
.current_unit
->read_bad
= 1;
2035 /* Start the data transfer if we are doing a formatted transfer. */
2036 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2037 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2038 && dtp
->u
.p
.ionml
== NULL
)
2039 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2042 /* Initialize an array_loop_spec given the array descriptor. The function
2043 returns the index of the last element of the array. */
2046 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2048 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2053 for (i
=0; i
<rank
; i
++)
2055 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2056 ls
[i
].start
= desc
->dim
[i
].lbound
;
2057 ls
[i
].end
= desc
->dim
[i
].ubound
;
2058 ls
[i
].step
= desc
->dim
[i
].stride
;
2060 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2061 * desc
->dim
[i
].stride
;
2066 /* Determine the index to the next record in an internal unit array by
2067 by incrementing through the array_loop_spec. TODO: Implement handling
2068 negative strides. */
2071 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2079 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2084 if (ls
[i
].idx
> ls
[i
].end
)
2086 ls
[i
].idx
= ls
[i
].start
;
2092 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2100 /* Skip to the end of the current record, taking care of an optional
2101 record marker of size bytes. If the file is not seekable, we
2102 read chunks of size MAX_READ until we get to the right
2105 #define MAX_READ 4096
2108 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2111 int rlength
, length
;
2114 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2115 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2118 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2120 new = file_position (dtp
->u
.p
.current_unit
->s
)
2121 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2123 /* Direct access files do not generate END conditions,
2125 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2126 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2129 { /* Seek by reading data. */
2130 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2133 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2134 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2136 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2139 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2143 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2151 /* Advance to the next record reading unformatted files, taking
2152 care of subrecords. If complete_record is nonzero, we loop
2153 until all subrecords are cleared. */
2156 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2160 bytes
= compile_options
.record_marker
== 0 ?
2161 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2166 /* Skip over tail */
2168 skip_record (dtp
, bytes
);
2170 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2177 /* Space to the next record for read mode. */
2180 next_record_r (st_parameter_dt
*dtp
)
2183 int length
, bytes_left
;
2186 switch (current_mode (dtp
))
2188 /* No records in unformatted STREAM I/O. */
2189 case UNFORMATTED_STREAM
:
2192 case UNFORMATTED_SEQUENTIAL
:
2193 next_record_r_unf (dtp
, 1);
2194 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2197 case FORMATTED_DIRECT
:
2198 case UNFORMATTED_DIRECT
:
2199 skip_record (dtp
, 0);
2202 case FORMATTED_STREAM
:
2203 case FORMATTED_SEQUENTIAL
:
2205 /* sf_read has already terminated input because of an '\n' */
2206 if (dtp
->u
.p
.sf_seen_eor
)
2208 dtp
->u
.p
.sf_seen_eor
= 0;
2212 if (is_internal_unit (dtp
))
2214 if (is_array_io (dtp
))
2216 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2218 /* Now seek to this record. */
2219 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2220 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2222 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2225 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2229 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2230 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2232 dtp
->u
.p
.current_unit
->bytes_left
2233 = dtp
->u
.p
.current_unit
->recl
;
2239 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2243 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2249 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2253 if (is_stream_io (dtp
))
2254 dtp
->u
.p
.current_unit
->strm_pos
++;
2263 /* Small utility function to write a record marker, taking care of
2264 byte swapping and of choosing the correct size. */
2267 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2272 char p
[sizeof (GFC_INTEGER_8
)];
2274 if (compile_options
.record_marker
== 0)
2275 len
= sizeof (GFC_INTEGER_4
);
2277 len
= compile_options
.record_marker
;
2279 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2280 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
2284 case sizeof (GFC_INTEGER_4
):
2286 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2289 case sizeof (GFC_INTEGER_8
):
2291 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2295 runtime_error ("Illegal value for record marker");
2303 case sizeof (GFC_INTEGER_4
):
2305 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2306 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2309 case sizeof (GFC_INTEGER_8
):
2311 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2312 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2316 runtime_error ("Illegal value for record marker");
2323 /* Position to the next (sub)record in write mode for
2324 unformatted sequential files. */
2327 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2329 gfc_offset c
, m
, m_write
;
2330 size_t record_marker
;
2332 /* Bytes written. */
2333 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2334 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2335 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2337 /* Write the length tail. If we finish a record containing
2338 subrecords, we write out the negative length. */
2340 if (dtp
->u
.p
.current_unit
->continued
)
2345 if (write_us_marker (dtp
, m_write
) != 0)
2348 if (compile_options
.record_marker
== 0)
2349 record_marker
= sizeof (GFC_INTEGER_4
);
2351 record_marker
= compile_options
.record_marker
;
2353 /* Seek to the head and overwrite the bogus length with the real
2356 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2365 if (write_us_marker (dtp
, m_write
) != 0)
2368 /* Seek past the end of the current record. */
2370 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2376 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2381 /* Position to the next record in write mode. */
2384 next_record_w (st_parameter_dt
*dtp
, int done
)
2386 gfc_offset m
, record
, max_pos
;
2390 /* Zero counters for X- and T-editing. */
2391 max_pos
= dtp
->u
.p
.max_pos
;
2392 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2394 switch (current_mode (dtp
))
2396 /* No records in unformatted STREAM I/O. */
2397 case UNFORMATTED_STREAM
:
2400 case FORMATTED_DIRECT
:
2401 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2404 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2405 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2410 case UNFORMATTED_DIRECT
:
2411 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2415 case UNFORMATTED_SEQUENTIAL
:
2416 next_record_w_unf (dtp
, 0);
2417 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2420 case FORMATTED_STREAM
:
2421 case FORMATTED_SEQUENTIAL
:
2423 if (is_internal_unit (dtp
))
2425 if (is_array_io (dtp
))
2427 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2429 /* If the farthest position reached is greater than current
2430 position, adjust the position and set length to pad out
2431 whats left. Otherwise just pad whats left.
2432 (for character array unit) */
2433 m
= dtp
->u
.p
.current_unit
->recl
2434 - dtp
->u
.p
.current_unit
->bytes_left
;
2437 length
= (int) (max_pos
- m
);
2438 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2439 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2442 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2444 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2448 /* Now that the current record has been padded out,
2449 determine where the next record in the array is. */
2450 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2452 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2454 /* Now seek to this record */
2455 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2457 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2459 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2463 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2469 /* If this is the last call to next_record move to the farthest
2470 position reached and set length to pad out the remainder
2471 of the record. (for character scaler unit) */
2474 m
= dtp
->u
.p
.current_unit
->recl
2475 - dtp
->u
.p
.current_unit
->bytes_left
;
2478 length
= (int) (max_pos
- m
);
2479 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2480 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2483 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2486 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2488 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2495 /* If this is the last call to next_record move to the farthest
2496 position reached in preparation for completing the record.
2500 m
= dtp
->u
.p
.current_unit
->recl
-
2501 dtp
->u
.p
.current_unit
->bytes_left
;
2504 length
= (int) (max_pos
- m
);
2505 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2509 const char crlf
[] = "\r\n";
2515 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2518 if (is_stream_io (dtp
))
2519 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2525 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2530 /* Position to the next record, which means moving to the end of the
2531 current record. This can happen under several different
2532 conditions. If the done flag is not set, we get ready to process
2536 next_record (st_parameter_dt
*dtp
, int done
)
2538 gfc_offset fp
; /* File position. */
2540 dtp
->u
.p
.current_unit
->read_bad
= 0;
2542 if (dtp
->u
.p
.mode
== READING
)
2543 next_record_r (dtp
);
2545 next_record_w (dtp
, done
);
2547 if (!is_stream_io (dtp
))
2549 /* keep position up to date for INQUIRE */
2550 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
2551 dtp
->u
.p
.current_unit
->current_record
= 0;
2552 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2554 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2555 /* Calculate next record, rounding up partial records. */
2556 dtp
->u
.p
.current_unit
->last_record
=
2557 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2558 dtp
->u
.p
.current_unit
->recl
;
2561 dtp
->u
.p
.current_unit
->last_record
++;
2569 /* Finalize the current data transfer. For a nonadvancing transfer,
2570 this means advancing to the next record. For internal units close the
2571 stream associated with the unit. */
2574 finalize_transfer (st_parameter_dt
*dtp
)
2577 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2579 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2580 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2582 if (dtp
->u
.p
.eor_condition
)
2584 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2588 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2591 if ((dtp
->u
.p
.ionml
!= NULL
)
2592 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2594 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2595 namelist_read (dtp
);
2597 namelist_write (dtp
);
2600 dtp
->u
.p
.transfer
= NULL
;
2601 if (dtp
->u
.p
.current_unit
== NULL
)
2604 dtp
->u
.p
.eof_jump
= &eof_jump
;
2605 if (setjmp (eof_jump
))
2607 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2611 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2613 finish_list_read (dtp
);
2614 sfree (dtp
->u
.p
.current_unit
->s
);
2618 if (is_stream_io (dtp
))
2620 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2621 next_record (dtp
, 1);
2622 flush (dtp
->u
.p
.current_unit
->s
);
2623 sfree (dtp
->u
.p
.current_unit
->s
);
2627 dtp
->u
.p
.current_unit
->current_record
= 0;
2629 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2631 dtp
->u
.p
.seen_dollar
= 0;
2632 sfree (dtp
->u
.p
.current_unit
->s
);
2636 /* For non-advancing I/O, save the current maximum position for use in the
2637 next I/O operation if needed. */
2638 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2640 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2641 - dtp
->u
.p
.current_unit
->bytes_left
);
2642 dtp
->u
.p
.current_unit
->saved_pos
=
2643 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2644 flush (dtp
->u
.p
.current_unit
->s
);
2648 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2650 next_record (dtp
, 1);
2651 sfree (dtp
->u
.p
.current_unit
->s
);
2654 /* Transfer function for IOLENGTH. It doesn't actually do any
2655 data transfer, it just updates the length counter. */
2658 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2659 void *dest
__attribute__ ((unused
)),
2660 int kind
__attribute__((unused
)),
2661 size_t size
, size_t nelems
)
2663 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2664 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2668 /* Initialize the IOLENGTH data transfer. This function is in essence
2669 a very much simplified version of data_transfer_init(), because it
2670 doesn't have to deal with units at all. */
2673 iolength_transfer_init (st_parameter_dt
*dtp
)
2675 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2678 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2680 /* Set up the subroutine that will handle the transfers. */
2682 dtp
->u
.p
.transfer
= iolength_transfer
;
2686 /* Library entry point for the IOLENGTH form of the INQUIRE
2687 statement. The IOLENGTH form requires no I/O to be performed, but
2688 it must still be a runtime library call so that we can determine
2689 the iolength for dynamic arrays and such. */
2691 extern void st_iolength (st_parameter_dt
*);
2692 export_proto(st_iolength
);
2695 st_iolength (st_parameter_dt
*dtp
)
2697 library_start (&dtp
->common
);
2698 iolength_transfer_init (dtp
);
2701 extern void st_iolength_done (st_parameter_dt
*);
2702 export_proto(st_iolength_done
);
2705 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2708 if (dtp
->u
.p
.scratch
!= NULL
)
2709 free_mem (dtp
->u
.p
.scratch
);
2714 /* The READ statement. */
2716 extern void st_read (st_parameter_dt
*);
2717 export_proto(st_read
);
2720 st_read (st_parameter_dt
*dtp
)
2722 library_start (&dtp
->common
);
2724 data_transfer_init (dtp
, 1);
2726 /* Handle complications dealing with the endfile record. */
2728 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2729 switch (dtp
->u
.p
.current_unit
->endfile
)
2732 if (file_length (dtp
->u
.p
.current_unit
->s
)
2733 == file_position (dtp
->u
.p
.current_unit
->s
))
2734 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2738 if (!is_internal_unit (dtp
))
2740 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2741 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2742 dtp
->u
.p
.current_unit
->current_record
= 0;
2747 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2748 dtp
->u
.p
.current_unit
->current_record
= 0;
2753 extern void st_read_done (st_parameter_dt
*);
2754 export_proto(st_read_done
);
2757 st_read_done (st_parameter_dt
*dtp
)
2759 finalize_transfer (dtp
);
2760 free_format_data (dtp
);
2762 if (dtp
->u
.p
.scratch
!= NULL
)
2763 free_mem (dtp
->u
.p
.scratch
);
2764 if (dtp
->u
.p
.current_unit
!= NULL
)
2765 unlock_unit (dtp
->u
.p
.current_unit
);
2767 free_internal_unit (dtp
);
2772 extern void st_write (st_parameter_dt
*);
2773 export_proto(st_write
);
2776 st_write (st_parameter_dt
*dtp
)
2778 library_start (&dtp
->common
);
2779 data_transfer_init (dtp
, 0);
2782 extern void st_write_done (st_parameter_dt
*);
2783 export_proto(st_write_done
);
2786 st_write_done (st_parameter_dt
*dtp
)
2788 finalize_transfer (dtp
);
2790 /* Deal with endfile conditions associated with sequential files. */
2792 if (dtp
->u
.p
.current_unit
!= NULL
2793 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2794 switch (dtp
->u
.p
.current_unit
->endfile
)
2796 case AT_ENDFILE
: /* Remain at the endfile record. */
2800 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2804 /* Get rid of whatever is after this record. */
2805 if (!is_internal_unit (dtp
))
2807 flush (dtp
->u
.p
.current_unit
->s
);
2808 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2809 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2811 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2815 free_format_data (dtp
);
2817 if (dtp
->u
.p
.scratch
!= NULL
)
2818 free_mem (dtp
->u
.p
.scratch
);
2819 if (dtp
->u
.p
.current_unit
!= NULL
)
2820 unlock_unit (dtp
->u
.p
.current_unit
);
2822 free_internal_unit (dtp
);
2827 /* Receives the scalar information for namelist objects and stores it
2828 in a linked list of namelist_info types. */
2830 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2831 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2832 export_proto(st_set_nml_var
);
2836 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2837 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2838 GFC_INTEGER_4 dtype
)
2840 namelist_info
*t1
= NULL
;
2843 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2845 nml
->mem_pos
= var_addr
;
2847 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2848 strcpy (nml
->var_name
, var_name
);
2850 nml
->len
= (int) len
;
2851 nml
->string_length
= (index_type
) string_length
;
2853 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2854 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2855 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2857 if (nml
->var_rank
> 0)
2859 nml
->dim
= (descriptor_dimension
*)
2860 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2861 nml
->ls
= (array_loop_spec
*)
2862 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2872 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2874 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2875 dtp
->u
.p
.ionml
= nml
;
2879 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2884 /* Store the dimensional information for the namelist object. */
2885 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2886 GFC_INTEGER_4
, GFC_INTEGER_4
,
2888 export_proto(st_set_nml_var_dim
);
2891 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2892 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2893 GFC_INTEGER_4 ubound
)
2895 namelist_info
* nml
;
2900 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2902 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2903 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2904 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2907 /* Reverse memcpy - used for byte swapping. */
2909 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2915 s
= (char *) src
+ n
- 1;
2917 /* Write with ascending order - this is likely faster
2918 on modern architectures because of write combining. */