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. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
58 These subroutines do not return status.
60 The last call is a call to st_[read|write]_done(). While
61 something can easily go wrong with the initial st_read() or
62 st_write(), an error inhibits any data from actually being
65 extern void transfer_integer (st_parameter_dt
*, void *, int);
66 export_proto(transfer_integer
);
68 extern void transfer_real (st_parameter_dt
*, void *, int);
69 export_proto(transfer_real
);
71 extern void transfer_logical (st_parameter_dt
*, void *, int);
72 export_proto(transfer_logical
);
74 extern void transfer_character (st_parameter_dt
*, void *, int);
75 export_proto(transfer_character
);
77 extern void transfer_complex (st_parameter_dt
*, void *, int);
78 export_proto(transfer_complex
);
80 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
82 export_proto(transfer_array
);
84 static void us_read (st_parameter_dt
*, int);
85 static void us_write (st_parameter_dt
*, int);
86 static void next_record_r_unf (st_parameter_dt
*, int);
87 static void next_record_w_unf (st_parameter_dt
*, int);
89 static const st_option advance_opt
[] = {
97 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
98 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
104 current_mode (st_parameter_dt
*dtp
)
108 m
= FORM_UNSPECIFIED
;
110 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
112 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
113 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
115 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
117 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
118 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
120 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
122 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
123 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
130 /* Mid level data transfer statements. These subroutines do reading
131 and writing in the style of salloc_r()/salloc_w() within the
134 /* When reading sequential formatted records we have a problem. We
135 don't know how long the line is until we read the trailing newline,
136 and we don't want to read too much. If we read too much, we might
137 have to do a physical seek backwards depending on how much data is
138 present, and devices like terminals aren't seekable and would cause
141 Given this, the solution is to read a byte at a time, stopping if
142 we hit the newline. For small allocations, we use a static buffer.
143 For larger allocations, we are forced to allocate memory on the
144 heap. Hopefully this won't happen very often. */
147 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
150 int n
, readlen
, crlf
;
153 if (*length
> SCRATCH_SIZE
)
154 dtp
->u
.p
.line_buffer
= get_mem (*length
);
155 p
= base
= dtp
->u
.p
.line_buffer
;
157 /* If we have seen an eor previously, return a length of 0. The
158 caller is responsible for correctly padding the input field. */
159 if (dtp
->u
.p
.sf_seen_eor
)
165 if (is_internal_unit (dtp
))
168 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
169 memcpy (p
, q
, readlen
);
178 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
182 /* If we have a line without a terminating \n, drop through to
184 if (readlen
< 1 && n
== 0)
188 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
192 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
194 /* Unexpected end of line. */
196 /* If we see an EOR during non-advancing I/O, we need to skip
197 the rest of the I/O statement. Set the corresponding flag. */
198 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
199 dtp
->u
.p
.eor_condition
= 1;
202 /* If we encounter a CR, it might be a CRLF. */
203 if (*q
== '\r') /* Probably a CRLF */
206 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
207 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
208 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
209 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
214 /* Without padding, terminate the I/O statement without assigning
215 the value. With padding, the value still needs to be assigned,
216 so we can just continue with a short read. */
217 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
221 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
226 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
229 /* Short circuit the read if a comma is found during numeric input.
230 The flag is set to zero during character reads so that commas in
231 strings are not ignored */
233 if (dtp
->u
.p
.sf_read_comma
== 1)
235 notify_std (&dtp
->common
, GFC_STD_GNU
,
236 "Comma in formatted numeric read.");
243 dtp
->u
.p
.sf_seen_eor
= 0;
248 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
250 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
251 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
257 /* Function for reading the next couple of bytes from the current
258 file, advancing the current position. We return a pointer to a
259 buffer containing the bytes. We return NULL on end of record or
262 If the read is short, then it is because the current record does not
263 have enough data to satisfy the read request and the file was
264 opened with PAD=YES. The caller must assume tailing spaces for
268 read_block (st_parameter_dt
*dtp
, int *length
)
273 if (is_stream_io (dtp
))
275 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
276 != file_position (dtp
->u
.p
.current_unit
->s
)
277 && sseek (dtp
->u
.p
.current_unit
->s
,
278 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
280 generate_error (&dtp
->common
, LIBERROR_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
, LIBERROR_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
, LIBERROR_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
, LIBERROR_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 (dtp
->u
.p
.current_unit
->strm_pos
- 1
363 != file_position (dtp
->u
.p
.current_unit
->s
)
364 && sseek (dtp
->u
.p
.current_unit
->s
,
365 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
367 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
371 to_read_record
= *nbytes
;
372 have_read_record
= to_read_record
;
373 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
375 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
379 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
381 if (to_read_record
!= have_read_record
)
383 /* Short read, e.g. if we hit EOF. For stream files,
384 we have to set the end-of-file condition. */
385 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
391 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
393 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
396 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
397 *nbytes
= to_read_record
;
403 to_read_record
= *nbytes
;
406 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
408 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
410 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
414 if (to_read_record
!= *nbytes
)
416 /* Short read, e.g. if we hit EOF. Apparently, we read
417 more than was written to the last record. */
418 *nbytes
= to_read_record
;
424 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
430 /* Unformatted sequential. We loop over the subrecords, reading
431 until the request has been fulfilled or the record has run out
432 of continuation subrecords. */
434 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
436 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
440 /* Check whether we exceed the total record length. */
442 if (dtp
->u
.p
.current_unit
->flags
.has_recl
443 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
445 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
450 to_read_record
= *nbytes
;
453 have_read_record
= 0;
457 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
458 < (gfc_offset
) to_read_record
)
460 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
461 to_read_record
-= to_read_subrecord
;
465 to_read_subrecord
= to_read_record
;
469 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
471 have_read_subrecord
= to_read_subrecord
;
472 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
473 &have_read_subrecord
) != 0)
475 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
479 have_read_record
+= have_read_subrecord
;
481 if (to_read_subrecord
!= have_read_subrecord
)
484 /* Short read, e.g. if we hit EOF. This means the record
485 structure has been corrupted, or the trailing record
486 marker would still be present. */
488 *nbytes
= have_read_record
;
489 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
493 if (to_read_record
> 0)
495 if (dtp
->u
.p
.current_unit
->continued
)
497 next_record_r_unf (dtp
, 0);
502 /* Let's make sure the file position is correctly pre-positioned
503 for the next read statement. */
505 dtp
->u
.p
.current_unit
->current_record
= 0;
506 next_record_r_unf (dtp
, 0);
507 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
513 /* Normal exit, the read request has been fulfilled. */
518 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
521 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
528 /* Function for writing a block of bytes to the current file at the
529 current position, advancing the file pointer. We are given a length
530 and return a pointer to a buffer that the caller must (completely)
531 fill in. Returns NULL on error. */
534 write_block (st_parameter_dt
*dtp
, int length
)
538 if (is_stream_io (dtp
))
540 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
541 != file_position (dtp
->u
.p
.current_unit
->s
)
542 && sseek (dtp
->u
.p
.current_unit
->s
,
543 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
545 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
551 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
553 /* For preconnected units with default record length, set bytes left
554 to unit record length and proceed, otherwise error. */
555 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
556 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
557 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
558 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
561 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
566 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
569 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
573 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
577 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
578 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
580 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
581 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
583 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
589 /* High level interface to swrite(), taking care of errors. This is only
590 called for unformatted files. There are three cases to consider:
591 Stream I/O, unformatted direct, unformatted sequential. */
594 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
597 size_t have_written
, to_write_subrecord
;
602 if (is_stream_io (dtp
))
604 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
605 != file_position (dtp
->u
.p
.current_unit
->s
)
606 && sseek (dtp
->u
.p
.current_unit
->s
,
607 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
609 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
613 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
615 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
619 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
624 /* Unformatted direct access. */
626 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
628 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
630 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
634 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
636 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
640 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
641 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
647 /* Unformatted sequential. */
651 if (dtp
->u
.p
.current_unit
->flags
.has_recl
652 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
654 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
666 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
667 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
669 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
670 (gfc_offset
) to_write_subrecord
;
672 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
673 &to_write_subrecord
) != 0)
675 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
679 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
680 nbytes
-= to_write_subrecord
;
681 have_written
+= to_write_subrecord
;
686 next_record_w_unf (dtp
, 1);
689 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
692 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
699 /* Master function for unformatted reads. */
702 unformatted_read (st_parameter_dt
*dtp
, bt type
,
703 void *dest
, int kind
__attribute__((unused
)),
704 size_t size
, size_t nelems
)
708 /* Currently, character implies size=1. */
709 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
710 || size
== 1 || type
== BT_CHARACTER
)
713 read_block_direct (dtp
, dest
, &sz
);
720 /* Break up complex into its constituent reals. */
721 if (type
== BT_COMPLEX
)
728 /* By now, all complex variables have been split into their
729 constituent reals. */
731 for (i
=0; i
<nelems
; i
++)
733 read_block_direct (dtp
, buffer
, &size
);
734 reverse_memcpy (p
, buffer
, size
);
741 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
742 bytes on 64 bit machines. The unused bytes are not initialized and never
743 used, which can show an error with memory checking analyzers like
747 unformatted_write (st_parameter_dt
*dtp
, bt type
,
748 void *source
, int kind
__attribute__((unused
)),
749 size_t size
, size_t nelems
)
751 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
752 size
== 1 || type
== BT_CHARACTER
)
755 write_buf (dtp
, source
, size
);
763 /* Break up complex into its constituent reals. */
764 if (type
== BT_COMPLEX
)
772 /* By now, all complex variables have been split into their
773 constituent reals. */
776 for (i
=0; i
<nelems
; i
++)
778 reverse_memcpy(buffer
, p
, size
);
780 write_buf (dtp
, buffer
, size
);
786 /* Return a pointer to the name of a type. */
811 internal_error (NULL
, "type_name(): Bad type");
818 /* Write a constant string to the output.
819 This is complicated because the string can have doubled delimiters
820 in it. The length in the format node is the true length. */
823 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
825 char c
, delimiter
, *p
, *q
;
828 length
= f
->u
.string
.length
;
832 p
= write_block (dtp
, length
);
839 for (; length
> 0; length
--)
842 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
843 q
++; /* Skip the doubled delimiter. */
848 /* Given actual and expected types in a formatted data transfer, make
849 sure they agree. If not, an error message is generated. Returns
850 nonzero if something went wrong. */
853 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
857 if (actual
== expected
)
860 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
861 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
863 format_error (dtp
, f
, buffer
);
868 /* This subroutine is the main loop for a formatted data transfer
869 statement. It would be natural to implement this as a coroutine
870 with the user program, but C makes that awkward. We loop,
871 processing format elements. When we actually have to transfer
872 data instead of just setting flags, we return control to the user
873 program which calls a subroutine that supplies the address and type
874 of the next element, then comes back here to process it. */
877 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
880 char scratch
[SCRATCH_SIZE
];
885 int consume_data_flag
;
887 /* Change a complex data item into a pair of reals. */
889 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
890 if (type
== BT_COMPLEX
)
896 /* If there's an EOR condition, we simulate finalizing the transfer
898 if (dtp
->u
.p
.eor_condition
)
901 /* Set this flag so that commas in reads cause the read to complete before
902 the entire field has been read. The next read field will start right after
903 the comma in the stream. (Set to 0 for character reads). */
904 dtp
->u
.p
.sf_read_comma
= 1;
906 dtp
->u
.p
.line_buffer
= scratch
;
909 /* If reversion has occurred and there is another real data item,
910 then we have to move to the next record. */
911 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
913 dtp
->u
.p
.reversion_flag
= 0;
914 next_record (dtp
, 0);
917 consume_data_flag
= 1 ;
918 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
921 f
= next_format (dtp
);
924 /* No data descriptors left. */
926 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
927 "Insufficient data descriptors in format after reversion");
931 /* Now discharge T, TR and X movements to the right. This is delayed
932 until a data producing format to suppress trailing spaces. */
935 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
936 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
937 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
938 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
939 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
942 if (dtp
->u
.p
.skips
> 0)
944 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
945 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
946 - dtp
->u
.p
.current_unit
->bytes_left
);
948 if (dtp
->u
.p
.skips
< 0)
950 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
951 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
953 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
956 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
957 - dtp
->u
.p
.current_unit
->bytes_left
);
959 if (is_stream_io(dtp
))
967 if (require_type (dtp
, BT_INTEGER
, type
, f
))
970 if (dtp
->u
.p
.mode
== READING
)
971 read_decimal (dtp
, f
, p
, len
);
973 write_i (dtp
, f
, p
, len
);
981 if (compile_options
.allow_std
< GFC_STD_GNU
982 && require_type (dtp
, BT_INTEGER
, type
, f
))
985 if (dtp
->u
.p
.mode
== READING
)
986 read_radix (dtp
, f
, p
, len
, 2);
988 write_b (dtp
, f
, p
, len
);
996 if (compile_options
.allow_std
< GFC_STD_GNU
997 && require_type (dtp
, BT_INTEGER
, type
, f
))
1000 if (dtp
->u
.p
.mode
== READING
)
1001 read_radix (dtp
, f
, p
, len
, 8);
1003 write_o (dtp
, f
, p
, len
);
1011 if (compile_options
.allow_std
< GFC_STD_GNU
1012 && require_type (dtp
, BT_INTEGER
, type
, f
))
1015 if (dtp
->u
.p
.mode
== READING
)
1016 read_radix (dtp
, f
, p
, len
, 16);
1018 write_z (dtp
, f
, p
, len
);
1026 if (dtp
->u
.p
.mode
== READING
)
1027 read_a (dtp
, f
, p
, len
);
1029 write_a (dtp
, f
, p
, len
);
1037 if (dtp
->u
.p
.mode
== READING
)
1038 read_l (dtp
, f
, p
, len
);
1040 write_l (dtp
, f
, p
, len
);
1047 if (require_type (dtp
, BT_REAL
, type
, f
))
1050 if (dtp
->u
.p
.mode
== READING
)
1051 read_f (dtp
, f
, p
, len
);
1053 write_d (dtp
, f
, p
, len
);
1060 if (require_type (dtp
, BT_REAL
, type
, f
))
1063 if (dtp
->u
.p
.mode
== READING
)
1064 read_f (dtp
, f
, p
, len
);
1066 write_e (dtp
, f
, p
, len
);
1072 if (require_type (dtp
, BT_REAL
, type
, f
))
1075 if (dtp
->u
.p
.mode
== READING
)
1076 read_f (dtp
, f
, p
, len
);
1078 write_en (dtp
, f
, p
, len
);
1085 if (require_type (dtp
, BT_REAL
, type
, f
))
1088 if (dtp
->u
.p
.mode
== READING
)
1089 read_f (dtp
, f
, p
, len
);
1091 write_es (dtp
, f
, p
, len
);
1098 if (require_type (dtp
, BT_REAL
, type
, f
))
1101 if (dtp
->u
.p
.mode
== READING
)
1102 read_f (dtp
, f
, p
, len
);
1104 write_f (dtp
, f
, p
, len
);
1111 if (dtp
->u
.p
.mode
== READING
)
1115 read_decimal (dtp
, f
, p
, len
);
1118 read_l (dtp
, f
, p
, len
);
1121 read_a (dtp
, f
, p
, len
);
1124 read_f (dtp
, f
, p
, len
);
1133 write_i (dtp
, f
, p
, len
);
1136 write_l (dtp
, f
, p
, len
);
1139 write_a (dtp
, f
, p
, len
);
1142 write_d (dtp
, f
, p
, len
);
1146 internal_error (&dtp
->common
,
1147 "formatted_transfer(): Bad type");
1153 consume_data_flag
= 0 ;
1154 if (dtp
->u
.p
.mode
== READING
)
1156 format_error (dtp
, f
, "Constant string in input format");
1159 write_constant_string (dtp
, f
);
1162 /* Format codes that don't transfer data. */
1165 consume_data_flag
= 0;
1167 dtp
->u
.p
.skips
+= f
->u
.n
;
1168 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1169 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1171 /* Writes occur just before the switch on f->format, above, so
1172 that trailing blanks are suppressed, unless we are doing a
1173 non-advancing write in which case we want to output the blanks
1175 if (dtp
->u
.p
.mode
== WRITING
1176 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1178 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1179 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1182 if (dtp
->u
.p
.mode
== READING
)
1183 read_x (dtp
, f
->u
.n
);
1189 consume_data_flag
= 0;
1191 if (f
->format
== FMT_TL
)
1194 /* Handle the special case when no bytes have been used yet.
1195 Cannot go below zero. */
1196 if (bytes_used
== 0)
1198 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1199 dtp
->u
.p
.skips
-= f
->u
.n
;
1200 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1203 pos
= bytes_used
- f
->u
.n
;
1207 if (dtp
->u
.p
.mode
== READING
)
1210 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1213 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1214 left tab limit. We do not check if the position has gone
1215 beyond the end of record because a subsequent tab could
1216 bring us back again. */
1217 pos
= pos
< 0 ? 0 : pos
;
1219 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1220 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1221 + pos
- dtp
->u
.p
.max_pos
;
1222 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1223 ? 0 : dtp
->u
.p
.pending_spaces
;
1225 if (dtp
->u
.p
.skips
== 0)
1228 /* Writes occur just before the switch on f->format, above, so that
1229 trailing blanks are suppressed. */
1230 if (dtp
->u
.p
.mode
== READING
)
1232 /* Adjust everything for end-of-record condition */
1233 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1235 if (dtp
->u
.p
.sf_seen_eor
== 2)
1237 /* The EOR was a CRLF (two bytes wide). */
1238 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1239 dtp
->u
.p
.skips
-= 2;
1243 /* The EOR marker was only one byte wide. */
1244 dtp
->u
.p
.current_unit
->bytes_left
--;
1248 dtp
->u
.p
.sf_seen_eor
= 0;
1250 if (dtp
->u
.p
.skips
< 0)
1252 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1253 dtp
->u
.p
.current_unit
->bytes_left
1254 -= (gfc_offset
) dtp
->u
.p
.skips
;
1255 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1258 read_x (dtp
, dtp
->u
.p
.skips
);
1264 consume_data_flag
= 0 ;
1265 dtp
->u
.p
.sign_status
= SIGN_S
;
1269 consume_data_flag
= 0 ;
1270 dtp
->u
.p
.sign_status
= SIGN_SS
;
1274 consume_data_flag
= 0 ;
1275 dtp
->u
.p
.sign_status
= SIGN_SP
;
1279 consume_data_flag
= 0 ;
1280 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1284 consume_data_flag
= 0 ;
1285 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1289 consume_data_flag
= 0 ;
1290 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1294 consume_data_flag
= 0 ;
1295 dtp
->u
.p
.seen_dollar
= 1;
1299 consume_data_flag
= 0 ;
1300 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1301 next_record (dtp
, 0);
1305 /* A colon descriptor causes us to exit this loop (in
1306 particular preventing another / descriptor from being
1307 processed) unless there is another data item to be
1309 consume_data_flag
= 0 ;
1315 internal_error (&dtp
->common
, "Bad format node");
1318 /* Free a buffer that we had to allocate during a sequential
1319 formatted read of a block that was larger than the static
1322 if (dtp
->u
.p
.line_buffer
!= scratch
)
1324 free_mem (dtp
->u
.p
.line_buffer
);
1325 dtp
->u
.p
.line_buffer
= scratch
;
1328 /* Adjust the item count and data pointer. */
1330 if ((consume_data_flag
> 0) && (n
> 0))
1333 p
= ((char *) p
) + size
;
1336 if (dtp
->u
.p
.mode
== READING
)
1339 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1340 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1346 /* Come here when we need a data descriptor but don't have one. We
1347 push the current format node back onto the input, then return and
1348 let the user program call us back with the data. */
1350 unget_format (dtp
, f
);
1354 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1355 size_t size
, size_t nelems
)
1362 /* Big loop over all the elements. */
1363 for (elem
= 0; elem
< nelems
; elem
++)
1365 dtp
->u
.p
.item_count
++;
1366 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1372 /* Data transfer entry points. The type of the data entity is
1373 implicit in the subroutine call. This prevents us from having to
1374 share a common enum with the compiler. */
1377 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1379 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1381 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1386 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1389 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1391 size
= size_from_real_kind (kind
);
1392 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1397 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1399 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1401 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1406 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1408 static char *empty_string
[0];
1410 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1413 /* Strings of zero length can have p == NULL, which confuses the
1414 transfer routines into thinking we need more data elements. To avoid
1415 this, we give them a nice pointer. */
1416 if (len
== 0 && p
== NULL
)
1419 /* Currently we support only 1 byte chars, and the library is a bit
1420 confused of character kind vs. length, so we kludge it by setting
1422 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1427 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1430 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1432 size
= size_from_complex_kind (kind
);
1433 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1438 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1439 gfc_charlen_type charlen
)
1441 index_type count
[GFC_MAX_DIMENSIONS
];
1442 index_type extent
[GFC_MAX_DIMENSIONS
];
1443 index_type stride
[GFC_MAX_DIMENSIONS
];
1444 index_type stride0
, rank
, size
, type
, n
;
1449 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1452 type
= GFC_DESCRIPTOR_TYPE (desc
);
1453 size
= GFC_DESCRIPTOR_SIZE (desc
);
1455 /* FIXME: What a kludge: Array descriptors and the IO library use
1456 different enums for types. */
1459 case GFC_DTYPE_UNKNOWN
:
1460 iotype
= BT_NULL
; /* Is this correct? */
1462 case GFC_DTYPE_INTEGER
:
1463 iotype
= BT_INTEGER
;
1465 case GFC_DTYPE_LOGICAL
:
1466 iotype
= BT_LOGICAL
;
1468 case GFC_DTYPE_REAL
:
1471 case GFC_DTYPE_COMPLEX
:
1472 iotype
= BT_COMPLEX
;
1474 case GFC_DTYPE_CHARACTER
:
1475 iotype
= BT_CHARACTER
;
1476 /* FIXME: Currently dtype contains the charlen, which is
1477 clobbered if charlen > 2**24. That's why we use a separate
1478 argument for the charlen. However, if we want to support
1479 non-8-bit charsets we need to fix dtype to contain
1480 sizeof(chartype) and fix the code below. */
1484 case GFC_DTYPE_DERIVED
:
1485 internal_error (&dtp
->common
,
1486 "Derived type I/O should have been handled via the frontend.");
1489 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1492 rank
= GFC_DESCRIPTOR_RANK (desc
);
1493 for (n
= 0; n
< rank
; n
++)
1496 stride
[n
] = desc
->dim
[n
].stride
;
1497 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1499 /* If the extent of even one dimension is zero, then the entire
1500 array section contains zero elements, so we return. */
1505 stride0
= stride
[0];
1507 /* If the innermost dimension has stride 1, we can do the transfer
1508 in contiguous chunks. */
1514 data
= GFC_DESCRIPTOR_DATA (desc
);
1518 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1519 data
+= stride0
* size
* tsize
;
1522 while (count
[n
] == extent
[n
])
1525 data
-= stride
[n
] * extent
[n
] * size
;
1535 data
+= stride
[n
] * size
;
1542 /* Preposition a sequential unformatted file while reading. */
1545 us_read (st_parameter_dt
*dtp
, int continued
)
1554 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1557 if (compile_options
.record_marker
== 0)
1558 n
= sizeof (GFC_INTEGER_4
);
1560 n
= compile_options
.record_marker
;
1564 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1568 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1569 return; /* end of file */
1572 if (p
== NULL
|| n
!= nr
)
1574 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1578 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1579 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1583 case sizeof(GFC_INTEGER_4
):
1584 memcpy (&i4
, p
, sizeof (i4
));
1588 case sizeof(GFC_INTEGER_8
):
1589 memcpy (&i8
, p
, sizeof (i8
));
1594 runtime_error ("Illegal value for record marker");
1601 case sizeof(GFC_INTEGER_4
):
1602 reverse_memcpy (&i4
, p
, sizeof (i4
));
1606 case sizeof(GFC_INTEGER_8
):
1607 reverse_memcpy (&i8
, p
, sizeof (i8
));
1612 runtime_error ("Illegal value for record marker");
1618 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1619 dtp
->u
.p
.current_unit
->continued
= 0;
1623 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1624 dtp
->u
.p
.current_unit
->continued
= 1;
1628 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1632 /* Preposition a sequential unformatted file while writing. This
1633 amount to writing a bogus length that will be filled in later. */
1636 us_write (st_parameter_dt
*dtp
, int continued
)
1643 if (compile_options
.record_marker
== 0)
1644 nbytes
= sizeof (GFC_INTEGER_4
);
1646 nbytes
= compile_options
.record_marker
;
1648 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1649 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1651 /* For sequential unformatted, if RECL= was not specified in the OPEN
1652 we write until we have more bytes than can fit in the subrecord
1653 markers, then we write a new subrecord. */
1655 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1656 dtp
->u
.p
.current_unit
->recl_subrecord
;
1657 dtp
->u
.p
.current_unit
->continued
= continued
;
1661 /* Position to the next record prior to transfer. We are assumed to
1662 be before the next record. We also calculate the bytes in the next
1666 pre_position (st_parameter_dt
*dtp
)
1668 if (dtp
->u
.p
.current_unit
->current_record
)
1669 return; /* Already positioned. */
1671 switch (current_mode (dtp
))
1673 case FORMATTED_STREAM
:
1674 case UNFORMATTED_STREAM
:
1675 /* There are no records with stream I/O. Set the default position
1676 to the beginning of the file if no position was specified. */
1677 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1678 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1681 case UNFORMATTED_SEQUENTIAL
:
1682 if (dtp
->u
.p
.mode
== READING
)
1689 case FORMATTED_SEQUENTIAL
:
1690 case FORMATTED_DIRECT
:
1691 case UNFORMATTED_DIRECT
:
1692 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1696 dtp
->u
.p
.current_unit
->current_record
= 1;
1700 /* Initialize things for a data transfer. This code is common for
1701 both reading and writing. */
1704 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1706 unit_flags u_flags
; /* Used for creating a unit if needed. */
1707 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1708 namelist_info
*ionml
;
1710 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1711 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1712 dtp
->u
.p
.ionml
= ionml
;
1713 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1715 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1718 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1719 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1721 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1722 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1723 { /* Open the unit with some default flags. */
1724 st_parameter_open opp
;
1727 if (dtp
->common
.unit
< 0)
1729 close_unit (dtp
->u
.p
.current_unit
);
1730 dtp
->u
.p
.current_unit
= NULL
;
1731 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1732 "Bad unit number in OPEN statement");
1735 memset (&u_flags
, '\0', sizeof (u_flags
));
1736 u_flags
.access
= ACCESS_SEQUENTIAL
;
1737 u_flags
.action
= ACTION_READWRITE
;
1739 /* Is it unformatted? */
1740 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1741 | IOPARM_DT_IONML_SET
)))
1742 u_flags
.form
= FORM_UNFORMATTED
;
1744 u_flags
.form
= FORM_UNSPECIFIED
;
1746 u_flags
.delim
= DELIM_UNSPECIFIED
;
1747 u_flags
.blank
= BLANK_UNSPECIFIED
;
1748 u_flags
.pad
= PAD_UNSPECIFIED
;
1749 u_flags
.status
= STATUS_UNKNOWN
;
1751 conv
= get_unformatted_convert (dtp
->common
.unit
);
1753 if (conv
== GFC_CONVERT_NONE
)
1754 conv
= compile_options
.convert
;
1756 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1757 and 1 on big-endian machines. */
1760 case GFC_CONVERT_NATIVE
:
1761 case GFC_CONVERT_SWAP
:
1764 case GFC_CONVERT_BIG
:
1765 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1768 case GFC_CONVERT_LITTLE
:
1769 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1773 internal_error (&opp
.common
, "Illegal value for CONVERT");
1777 u_flags
.convert
= conv
;
1779 opp
.common
= dtp
->common
;
1780 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1781 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1782 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1783 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1784 if (dtp
->u
.p
.current_unit
== NULL
)
1788 /* Check the action. */
1790 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1792 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1793 "Cannot read from file opened for WRITE");
1797 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1799 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1800 "Cannot write to file opened for READ");
1804 dtp
->u
.p
.first_item
= 1;
1806 /* Check the format. */
1808 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1811 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1812 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1815 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1816 "Format present for UNFORMATTED data transfer");
1820 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1822 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1823 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1824 "A format cannot be specified with a namelist");
1826 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1827 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1829 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1830 "Missing format for FORMATTED data transfer");
1833 if (is_internal_unit (dtp
)
1834 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1836 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1837 "Internal file cannot be accessed by UNFORMATTED "
1842 /* Check the record or position number. */
1844 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1845 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1847 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1848 "Direct access data transfer requires record number");
1852 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1853 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1855 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1856 "Record number not allowed for sequential access data transfer");
1860 /* Process the ADVANCE option. */
1862 dtp
->u
.p
.advance_status
1863 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1864 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1865 "Bad ADVANCE parameter in data transfer statement");
1867 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1869 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1871 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1872 "ADVANCE specification conflicts with sequential access");
1876 if (is_internal_unit (dtp
))
1878 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1879 "ADVANCE specification conflicts with internal file");
1883 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1884 != IOPARM_DT_HAS_FORMAT
)
1886 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1887 "ADVANCE specification requires an explicit format");
1894 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1896 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1898 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1899 "EOR specification requires an ADVANCE specification "
1904 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1906 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1907 "SIZE specification requires an ADVANCE specification of NO");
1912 { /* Write constraints. */
1913 if ((cf
& IOPARM_END
) != 0)
1915 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1916 "END specification cannot appear in a write statement");
1920 if ((cf
& IOPARM_EOR
) != 0)
1922 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1923 "EOR specification cannot appear in a write statement");
1927 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1929 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1930 "SIZE specification cannot appear in a write statement");
1935 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1936 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1938 /* Sanity checks on the record number. */
1939 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1943 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1944 "Record number must be positive");
1948 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1950 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1951 "Record number too large");
1955 /* Check to see if we might be reading what we wrote before */
1957 if (dtp
->u
.p
.mode
== READING
1958 && dtp
->u
.p
.current_unit
->mode
== WRITING
1959 && !is_internal_unit (dtp
))
1960 flush(dtp
->u
.p
.current_unit
->s
);
1962 /* Check whether the record exists to be read. Only
1963 a partial record needs to exist. */
1965 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1966 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1968 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1969 "Non-existing record number");
1973 /* Position the file. */
1974 if (!is_stream_io (dtp
))
1976 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1977 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1979 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1984 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1988 /* Overwriting an existing sequential file ?
1989 it is always safe to truncate the file on the first write */
1990 if (dtp
->u
.p
.mode
== WRITING
1991 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1992 && dtp
->u
.p
.current_unit
->last_record
== 0
1993 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1994 struncate(dtp
->u
.p
.current_unit
->s
);
1996 /* Bugware for badly written mixed C-Fortran I/O. */
1997 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1999 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2001 /* Set the initial value of flags. */
2003 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2004 dtp
->u
.p
.sign_status
= SIGN_S
;
2006 /* Set the maximum position reached from the previous I/O operation. This
2007 could be greater than zero from a previous non-advancing write. */
2008 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2012 /* Set up the subroutine that will handle the transfers. */
2016 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2017 dtp
->u
.p
.transfer
= unformatted_read
;
2020 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2021 dtp
->u
.p
.transfer
= list_formatted_read
;
2023 dtp
->u
.p
.transfer
= formatted_transfer
;
2028 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2029 dtp
->u
.p
.transfer
= unformatted_write
;
2032 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2033 dtp
->u
.p
.transfer
= list_formatted_write
;
2035 dtp
->u
.p
.transfer
= formatted_transfer
;
2039 /* Make sure that we don't do a read after a nonadvancing write. */
2043 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2045 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2046 "Cannot READ after a nonadvancing WRITE");
2052 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2053 dtp
->u
.p
.current_unit
->read_bad
= 1;
2056 /* Start the data transfer if we are doing a formatted transfer. */
2057 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2058 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2059 && dtp
->u
.p
.ionml
== NULL
)
2060 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2063 /* Initialize an array_loop_spec given the array descriptor. The function
2064 returns the index of the last element of the array. */
2067 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2069 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2074 for (i
=0; i
<rank
; i
++)
2076 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2077 ls
[i
].start
= desc
->dim
[i
].lbound
;
2078 ls
[i
].end
= desc
->dim
[i
].ubound
;
2079 ls
[i
].step
= desc
->dim
[i
].stride
;
2081 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2082 * desc
->dim
[i
].stride
;
2087 /* Determine the index to the next record in an internal unit array by
2088 by incrementing through the array_loop_spec. TODO: Implement handling
2089 negative strides. */
2092 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2100 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2105 if (ls
[i
].idx
> ls
[i
].end
)
2107 ls
[i
].idx
= ls
[i
].start
;
2113 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2121 /* Skip to the end of the current record, taking care of an optional
2122 record marker of size bytes. If the file is not seekable, we
2123 read chunks of size MAX_READ until we get to the right
2126 #define MAX_READ 4096
2129 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2132 int rlength
, length
;
2135 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2136 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2139 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2141 new = file_position (dtp
->u
.p
.current_unit
->s
)
2142 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2144 /* Direct access files do not generate END conditions,
2146 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2147 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2150 { /* Seek by reading data. */
2151 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2154 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2155 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2157 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2160 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2164 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2172 /* Advance to the next record reading unformatted files, taking
2173 care of subrecords. If complete_record is nonzero, we loop
2174 until all subrecords are cleared. */
2177 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2181 bytes
= compile_options
.record_marker
== 0 ?
2182 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2187 /* Skip over tail */
2189 skip_record (dtp
, bytes
);
2191 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2198 /* Space to the next record for read mode. */
2201 next_record_r (st_parameter_dt
*dtp
)
2204 int length
, bytes_left
;
2207 switch (current_mode (dtp
))
2209 /* No records in unformatted STREAM I/O. */
2210 case UNFORMATTED_STREAM
:
2213 case UNFORMATTED_SEQUENTIAL
:
2214 next_record_r_unf (dtp
, 1);
2215 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2218 case FORMATTED_DIRECT
:
2219 case UNFORMATTED_DIRECT
:
2220 skip_record (dtp
, 0);
2223 case FORMATTED_STREAM
:
2224 case FORMATTED_SEQUENTIAL
:
2226 /* sf_read has already terminated input because of an '\n' */
2227 if (dtp
->u
.p
.sf_seen_eor
)
2229 dtp
->u
.p
.sf_seen_eor
= 0;
2233 if (is_internal_unit (dtp
))
2235 if (is_array_io (dtp
))
2237 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2239 /* Now seek to this record. */
2240 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2241 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2243 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2246 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2250 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2251 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2253 dtp
->u
.p
.current_unit
->bytes_left
2254 = dtp
->u
.p
.current_unit
->recl
;
2260 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2264 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2270 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2274 if (is_stream_io (dtp
))
2275 dtp
->u
.p
.current_unit
->strm_pos
++;
2282 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2283 && !dtp
->u
.p
.namelist_mode
2284 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2285 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2286 file_position (dtp
->u
.p
.current_unit
->s
)))
2287 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2292 /* Small utility function to write a record marker, taking care of
2293 byte swapping and of choosing the correct size. */
2296 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2301 char p
[sizeof (GFC_INTEGER_8
)];
2303 if (compile_options
.record_marker
== 0)
2304 len
= sizeof (GFC_INTEGER_4
);
2306 len
= compile_options
.record_marker
;
2308 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2309 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2313 case sizeof (GFC_INTEGER_4
):
2315 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2318 case sizeof (GFC_INTEGER_8
):
2320 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2324 runtime_error ("Illegal value for record marker");
2332 case sizeof (GFC_INTEGER_4
):
2334 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2335 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2338 case sizeof (GFC_INTEGER_8
):
2340 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2341 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2345 runtime_error ("Illegal value for record marker");
2352 /* Position to the next (sub)record in write mode for
2353 unformatted sequential files. */
2356 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2358 gfc_offset c
, m
, m_write
;
2359 size_t record_marker
;
2361 /* Bytes written. */
2362 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2363 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2364 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2366 /* Write the length tail. If we finish a record containing
2367 subrecords, we write out the negative length. */
2369 if (dtp
->u
.p
.current_unit
->continued
)
2374 if (write_us_marker (dtp
, m_write
) != 0)
2377 if (compile_options
.record_marker
== 0)
2378 record_marker
= sizeof (GFC_INTEGER_4
);
2380 record_marker
= compile_options
.record_marker
;
2382 /* Seek to the head and overwrite the bogus length with the real
2385 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2394 if (write_us_marker (dtp
, m_write
) != 0)
2397 /* Seek past the end of the current record. */
2399 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2405 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2410 /* Position to the next record in write mode. */
2413 next_record_w (st_parameter_dt
*dtp
, int done
)
2415 gfc_offset m
, record
, max_pos
;
2419 /* Zero counters for X- and T-editing. */
2420 max_pos
= dtp
->u
.p
.max_pos
;
2421 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2423 switch (current_mode (dtp
))
2425 /* No records in unformatted STREAM I/O. */
2426 case UNFORMATTED_STREAM
:
2429 case FORMATTED_DIRECT
:
2430 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2433 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2434 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2439 case UNFORMATTED_DIRECT
:
2440 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2444 case UNFORMATTED_SEQUENTIAL
:
2445 next_record_w_unf (dtp
, 0);
2446 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2449 case FORMATTED_STREAM
:
2450 case FORMATTED_SEQUENTIAL
:
2452 if (is_internal_unit (dtp
))
2454 if (is_array_io (dtp
))
2456 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2458 /* If the farthest position reached is greater than current
2459 position, adjust the position and set length to pad out
2460 whats left. Otherwise just pad whats left.
2461 (for character array unit) */
2462 m
= dtp
->u
.p
.current_unit
->recl
2463 - dtp
->u
.p
.current_unit
->bytes_left
;
2466 length
= (int) (max_pos
- m
);
2467 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2468 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2471 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2473 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2477 /* Now that the current record has been padded out,
2478 determine where the next record in the array is. */
2479 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2481 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2483 /* Now seek to this record */
2484 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2486 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2488 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2492 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2498 /* If this is the last call to next_record move to the farthest
2499 position reached and set length to pad out the remainder
2500 of the record. (for character scaler unit) */
2503 m
= dtp
->u
.p
.current_unit
->recl
2504 - dtp
->u
.p
.current_unit
->bytes_left
;
2507 length
= (int) (max_pos
- m
);
2508 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2509 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2512 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2515 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2517 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2524 /* If this is the last call to next_record move to the farthest
2525 position reached in preparation for completing the record.
2529 m
= dtp
->u
.p
.current_unit
->recl
-
2530 dtp
->u
.p
.current_unit
->bytes_left
;
2533 length
= (int) (max_pos
- m
);
2534 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2538 const char crlf
[] = "\r\n";
2544 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2547 if (is_stream_io (dtp
))
2548 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2554 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2559 /* Position to the next record, which means moving to the end of the
2560 current record. This can happen under several different
2561 conditions. If the done flag is not set, we get ready to process
2565 next_record (st_parameter_dt
*dtp
, int done
)
2567 gfc_offset fp
; /* File position. */
2569 dtp
->u
.p
.current_unit
->read_bad
= 0;
2571 if (dtp
->u
.p
.mode
== READING
)
2572 next_record_r (dtp
);
2574 next_record_w (dtp
, done
);
2576 if (!is_stream_io (dtp
))
2578 /* Keep position up to date for INQUIRE */
2580 update_position (dtp
->u
.p
.current_unit
);
2582 dtp
->u
.p
.current_unit
->current_record
= 0;
2583 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2585 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2586 /* Calculate next record, rounding up partial records. */
2587 dtp
->u
.p
.current_unit
->last_record
=
2588 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2589 dtp
->u
.p
.current_unit
->recl
;
2592 dtp
->u
.p
.current_unit
->last_record
++;
2600 /* Finalize the current data transfer. For a nonadvancing transfer,
2601 this means advancing to the next record. For internal units close the
2602 stream associated with the unit. */
2605 finalize_transfer (st_parameter_dt
*dtp
)
2608 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2610 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2611 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2613 if (dtp
->u
.p
.eor_condition
)
2615 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2619 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2622 if ((dtp
->u
.p
.ionml
!= NULL
)
2623 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2625 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2626 namelist_read (dtp
);
2628 namelist_write (dtp
);
2631 dtp
->u
.p
.transfer
= NULL
;
2632 if (dtp
->u
.p
.current_unit
== NULL
)
2635 dtp
->u
.p
.eof_jump
= &eof_jump
;
2636 if (setjmp (eof_jump
))
2638 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2642 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2644 finish_list_read (dtp
);
2645 sfree (dtp
->u
.p
.current_unit
->s
);
2649 if (dtp
->u
.p
.mode
== WRITING
)
2650 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2651 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2653 if (is_stream_io (dtp
))
2655 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2656 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2657 next_record (dtp
, 1);
2659 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2660 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2662 flush (dtp
->u
.p
.current_unit
->s
);
2663 sfree (dtp
->u
.p
.current_unit
->s
);
2668 dtp
->u
.p
.current_unit
->current_record
= 0;
2670 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2672 dtp
->u
.p
.seen_dollar
= 0;
2673 sfree (dtp
->u
.p
.current_unit
->s
);
2677 /* For non-advancing I/O, save the current maximum position for use in the
2678 next I/O operation if needed. */
2679 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2681 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2682 - dtp
->u
.p
.current_unit
->bytes_left
);
2683 dtp
->u
.p
.current_unit
->saved_pos
=
2684 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2685 flush (dtp
->u
.p
.current_unit
->s
);
2689 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2691 next_record (dtp
, 1);
2692 sfree (dtp
->u
.p
.current_unit
->s
);
2695 /* Transfer function for IOLENGTH. It doesn't actually do any
2696 data transfer, it just updates the length counter. */
2699 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2700 void *dest
__attribute__ ((unused
)),
2701 int kind
__attribute__((unused
)),
2702 size_t size
, size_t nelems
)
2704 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2705 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2709 /* Initialize the IOLENGTH data transfer. This function is in essence
2710 a very much simplified version of data_transfer_init(), because it
2711 doesn't have to deal with units at all. */
2714 iolength_transfer_init (st_parameter_dt
*dtp
)
2716 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2719 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2721 /* Set up the subroutine that will handle the transfers. */
2723 dtp
->u
.p
.transfer
= iolength_transfer
;
2727 /* Library entry point for the IOLENGTH form of the INQUIRE
2728 statement. The IOLENGTH form requires no I/O to be performed, but
2729 it must still be a runtime library call so that we can determine
2730 the iolength for dynamic arrays and such. */
2732 extern void st_iolength (st_parameter_dt
*);
2733 export_proto(st_iolength
);
2736 st_iolength (st_parameter_dt
*dtp
)
2738 library_start (&dtp
->common
);
2739 iolength_transfer_init (dtp
);
2742 extern void st_iolength_done (st_parameter_dt
*);
2743 export_proto(st_iolength_done
);
2746 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2749 if (dtp
->u
.p
.scratch
!= NULL
)
2750 free_mem (dtp
->u
.p
.scratch
);
2755 /* The READ statement. */
2757 extern void st_read (st_parameter_dt
*);
2758 export_proto(st_read
);
2761 st_read (st_parameter_dt
*dtp
)
2763 library_start (&dtp
->common
);
2765 data_transfer_init (dtp
, 1);
2767 /* Handle complications dealing with the endfile record. */
2769 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2770 switch (dtp
->u
.p
.current_unit
->endfile
)
2776 if (!is_internal_unit (dtp
))
2778 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2779 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2780 dtp
->u
.p
.current_unit
->current_record
= 0;
2785 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2786 dtp
->u
.p
.current_unit
->current_record
= 0;
2791 extern void st_read_done (st_parameter_dt
*);
2792 export_proto(st_read_done
);
2795 st_read_done (st_parameter_dt
*dtp
)
2797 finalize_transfer (dtp
);
2798 free_format_data (dtp
);
2800 if (dtp
->u
.p
.scratch
!= NULL
)
2801 free_mem (dtp
->u
.p
.scratch
);
2802 if (dtp
->u
.p
.current_unit
!= NULL
)
2803 unlock_unit (dtp
->u
.p
.current_unit
);
2805 free_internal_unit (dtp
);
2810 extern void st_write (st_parameter_dt
*);
2811 export_proto(st_write
);
2814 st_write (st_parameter_dt
*dtp
)
2816 library_start (&dtp
->common
);
2817 data_transfer_init (dtp
, 0);
2820 extern void st_write_done (st_parameter_dt
*);
2821 export_proto(st_write_done
);
2824 st_write_done (st_parameter_dt
*dtp
)
2826 finalize_transfer (dtp
);
2828 /* Deal with endfile conditions associated with sequential files. */
2830 if (dtp
->u
.p
.current_unit
!= NULL
2831 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2832 switch (dtp
->u
.p
.current_unit
->endfile
)
2834 case AT_ENDFILE
: /* Remain at the endfile record. */
2838 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2842 /* Get rid of whatever is after this record. */
2843 if (!is_internal_unit (dtp
))
2845 flush (dtp
->u
.p
.current_unit
->s
);
2846 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2847 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2849 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2853 free_format_data (dtp
);
2855 if (dtp
->u
.p
.scratch
!= NULL
)
2856 free_mem (dtp
->u
.p
.scratch
);
2857 if (dtp
->u
.p
.current_unit
!= NULL
)
2858 unlock_unit (dtp
->u
.p
.current_unit
);
2860 free_internal_unit (dtp
);
2865 /* Receives the scalar information for namelist objects and stores it
2866 in a linked list of namelist_info types. */
2868 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2869 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2870 export_proto(st_set_nml_var
);
2874 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2875 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2876 GFC_INTEGER_4 dtype
)
2878 namelist_info
*t1
= NULL
;
2880 size_t var_name_len
= strlen (var_name
);
2882 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2884 nml
->mem_pos
= var_addr
;
2886 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2887 memcpy (nml
->var_name
, var_name
, var_name_len
);
2888 nml
->var_name
[var_name_len
] = '\0';
2890 nml
->len
= (int) len
;
2891 nml
->string_length
= (index_type
) string_length
;
2893 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2894 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2895 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2897 if (nml
->var_rank
> 0)
2899 nml
->dim
= (descriptor_dimension
*)
2900 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2901 nml
->ls
= (array_loop_spec
*)
2902 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2912 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2914 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2915 dtp
->u
.p
.ionml
= nml
;
2919 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2924 /* Store the dimensional information for the namelist object. */
2925 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2926 index_type
, index_type
,
2928 export_proto(st_set_nml_var_dim
);
2931 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2932 index_type stride
, index_type lbound
,
2935 namelist_info
* nml
;
2940 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2942 nml
->dim
[n
].stride
= stride
;
2943 nml
->dim
[n
].lbound
= lbound
;
2944 nml
->dim
[n
].ubound
= ubound
;
2947 /* Reverse memcpy - used for byte swapping. */
2949 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2955 s
= (char *) src
+ n
- 1;
2957 /* Write with ascending order - this is likely faster
2958 on modern architectures because of write combining. */