1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
33 /* transfer.c -- Top level handling of data transfer statements. */
38 #include "libgfortran.h"
42 /* Calling conventions: Data transfer statements are unlike other
43 library calls in that they extend over several calls.
45 The first call is always a call to st_read() or st_write(). These
46 subroutines return no status unless a namelist read or write is
47 being done, in which case there is the usual status. No further
48 calls are necessary in this case.
50 For other sorts of data transfer, there are zero or more data
51 transfer statement that depend on the format of the data transfer
60 These subroutines do not return status.
62 The last call is a call to st_[read|write]_done(). While
63 something can easily go wrong with the initial st_read() or
64 st_write(), an error inhibits any data from actually being
67 extern void transfer_integer (st_parameter_dt
*, void *, int);
68 export_proto(transfer_integer
);
70 extern void transfer_real (st_parameter_dt
*, void *, int);
71 export_proto(transfer_real
);
73 extern void transfer_logical (st_parameter_dt
*, void *, int);
74 export_proto(transfer_logical
);
76 extern void transfer_character (st_parameter_dt
*, void *, int);
77 export_proto(transfer_character
);
79 extern void transfer_complex (st_parameter_dt
*, void *, int);
80 export_proto(transfer_complex
);
82 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
84 export_proto(transfer_array
);
86 static void us_read (st_parameter_dt
*, int);
87 static void us_write (st_parameter_dt
*, int);
88 static void next_record_r_unf (st_parameter_dt
*, int);
89 static void next_record_w_unf (st_parameter_dt
*, int);
91 static const st_option advance_opt
[] = {
99 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
100 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
106 current_mode (st_parameter_dt
*dtp
)
110 m
= FORM_UNSPECIFIED
;
112 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
114 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
115 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
117 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
119 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
120 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
122 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
124 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
125 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
132 /* Mid level data transfer statements. These subroutines do reading
133 and writing in the style of salloc_r()/salloc_w() within the
136 /* When reading sequential formatted records we have a problem. We
137 don't know how long the line is until we read the trailing newline,
138 and we don't want to read too much. If we read too much, we might
139 have to do a physical seek backwards depending on how much data is
140 present, and devices like terminals aren't seekable and would cause
143 Given this, the solution is to read a byte at a time, stopping if
144 we hit the newline. For small allocations, we use a static buffer.
145 For larger allocations, we are forced to allocate memory on the
146 heap. Hopefully this won't happen very often. */
149 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
152 int n
, readlen
, crlf
;
155 if (*length
> SCRATCH_SIZE
)
156 dtp
->u
.p
.line_buffer
= get_mem (*length
);
157 p
= base
= dtp
->u
.p
.line_buffer
;
159 /* If we have seen an eor previously, return a length of 0. The
160 caller is responsible for correctly padding the input field. */
161 if (dtp
->u
.p
.sf_seen_eor
)
167 if (is_internal_unit (dtp
))
170 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
171 memcpy (p
, q
, readlen
);
180 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
184 /* If we have a line without a terminating \n, drop through to
186 if (readlen
< 1 && n
== 0)
190 generate_error (&dtp
->common
, ERROR_END
, NULL
);
194 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
196 /* Unexpected end of line. */
198 /* If we see an EOR during non-advancing I/O, we need to skip
199 the rest of the I/O statement. Set the corresponding flag. */
200 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
201 dtp
->u
.p
.eor_condition
= 1;
204 /* If we encounter a CR, it might be a CRLF. */
205 if (*q
== '\r') /* Probably a CRLF */
208 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
209 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
210 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
211 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
216 /* Without padding, terminate the I/O statement without assigning
217 the value. With padding, the value still needs to be assigned,
218 so we can just continue with a short read. */
219 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
223 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
228 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
231 /* Short circuit the read if a comma is found during numeric input.
232 The flag is set to zero during character reads so that commas in
233 strings are not ignored */
235 if (dtp
->u
.p
.sf_read_comma
== 1)
237 notify_std (&dtp
->common
, GFC_STD_GNU
,
238 "Comma in formatted numeric read.");
245 dtp
->u
.p
.sf_seen_eor
= 0;
250 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
252 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
253 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
259 /* Function for reading the next couple of bytes from the current
260 file, advancing the current position. We return a pointer to a
261 buffer containing the bytes. We return NULL on end of record or
264 If the read is short, then it is because the current record does not
265 have enough data to satisfy the read request and the file was
266 opened with PAD=YES. The caller must assume tailing spaces for
270 read_block (st_parameter_dt
*dtp
, int *length
)
275 if (is_stream_io (dtp
))
277 if (sseek (dtp
->u
.p
.current_unit
->s
,
278 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
280 generate_error (&dtp
->common
, ERROR_END
, NULL
);
286 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
288 /* For preconnected units with default record length, set bytes left
289 to unit record length and proceed, otherwise error. */
290 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
291 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
292 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
295 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
297 /* Not enough data left. */
298 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
303 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
305 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
306 generate_error (&dtp
->common
, ERROR_END
, NULL
);
310 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
314 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
315 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
316 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
318 source
= read_sf (dtp
, length
, 0);
319 dtp
->u
.p
.current_unit
->strm_pos
+=
320 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
323 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
326 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
328 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
329 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
331 if (nread
!= *length
)
332 { /* Short read, this shouldn't happen. */
333 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
337 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
342 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
348 /* Reads a block directly into application data space. This is for
349 unformatted files. */
352 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
354 size_t to_read_record
;
355 size_t have_read_record
;
356 size_t to_read_subrecord
;
357 size_t have_read_subrecord
;
360 if (is_stream_io (dtp
))
362 if (sseek (dtp
->u
.p
.current_unit
->s
,
363 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
365 generate_error (&dtp
->common
, ERROR_END
, NULL
);
369 to_read_record
= *nbytes
;
370 have_read_record
= to_read_record
;
371 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
373 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
377 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
379 if (to_read_record
!= have_read_record
)
381 /* Short read, e.g. if we hit EOF. For stream files,
382 we have to set the end-of-file condition. */
383 generate_error (&dtp
->common
, ERROR_END
, NULL
);
389 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
391 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
394 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
395 *nbytes
= to_read_record
;
401 to_read_record
= *nbytes
;
404 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
406 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
408 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
412 if (to_read_record
!= *nbytes
)
414 /* Short read, e.g. if we hit EOF. Apparently, we read
415 more than was written to the last record. */
416 *nbytes
= to_read_record
;
422 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
428 /* Unformatted sequential. We loop over the subrecords, reading
429 until the request has been fulfilled or the record has run out
430 of continuation subrecords. */
432 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
434 generate_error (&dtp
->common
, ERROR_END
, NULL
);
438 /* Check whether we exceed the total record length. */
440 if (dtp
->u
.p
.current_unit
->flags
.has_recl
441 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
443 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
448 to_read_record
= *nbytes
;
451 have_read_record
= 0;
455 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
456 < (gfc_offset
) to_read_record
)
458 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
459 to_read_record
-= to_read_subrecord
;
463 to_read_subrecord
= to_read_record
;
467 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
469 have_read_subrecord
= to_read_subrecord
;
470 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
471 &have_read_subrecord
) != 0)
473 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
477 have_read_record
+= have_read_subrecord
;
479 if (to_read_subrecord
!= have_read_subrecord
)
482 /* Short read, e.g. if we hit EOF. This means the record
483 structure has been corrupted, or the trailing record
484 marker would still be present. */
486 *nbytes
= have_read_record
;
487 generate_error (&dtp
->common
, ERROR_CORRUPT_FILE
, NULL
);
491 if (to_read_record
> 0)
493 if (dtp
->u
.p
.current_unit
->continued
)
495 next_record_r_unf (dtp
, 0);
500 /* Let's make sure the file position is correctly pre-positioned
501 for the next read statement. */
503 dtp
->u
.p
.current_unit
->current_record
= 0;
504 next_record_r_unf (dtp
, 0);
505 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
511 /* Normal exit, the read request has been fulfilled. */
516 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
519 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
526 /* Function for writing a block of bytes to the current file at the
527 current position, advancing the file pointer. We are given a length
528 and return a pointer to a buffer that the caller must (completely)
529 fill in. Returns NULL on error. */
532 write_block (st_parameter_dt
*dtp
, int length
)
536 if (is_stream_io (dtp
))
538 if (sseek (dtp
->u
.p
.current_unit
->s
,
539 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
541 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
547 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
549 /* For preconnected units with default record length, set bytes left
550 to unit record length and proceed, otherwise error. */
551 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
552 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
553 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
554 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
557 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
562 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
565 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
569 generate_error (&dtp
->common
, ERROR_END
, NULL
);
573 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
574 generate_error (&dtp
->common
, ERROR_END
, NULL
);
576 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
577 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
579 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
585 /* High level interface to swrite(), taking care of errors. This is only
586 called for unformatted files. There are three cases to consider:
587 Stream I/O, unformatted direct, unformatted sequential. */
590 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
593 size_t have_written
, to_write_subrecord
;
599 if (is_stream_io (dtp
))
601 if (sseek (dtp
->u
.p
.current_unit
->s
,
602 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
604 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
608 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
610 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
614 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
619 /* Unformatted direct access. */
621 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
623 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
625 generate_error (&dtp
->common
, ERROR_DIRECT_EOR
, NULL
);
629 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
631 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
635 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
636 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
642 /* Unformatted sequential. */
646 if (dtp
->u
.p
.current_unit
->flags
.has_recl
647 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
649 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
661 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
662 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
664 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
665 (gfc_offset
) to_write_subrecord
;
667 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
668 &to_write_subrecord
) != 0)
670 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
674 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
675 nbytes
-= to_write_subrecord
;
676 have_written
+= to_write_subrecord
;
681 next_record_w_unf (dtp
, 1);
684 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
687 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
694 /* Master function for unformatted reads. */
697 unformatted_read (st_parameter_dt
*dtp
, bt type
,
698 void *dest
, int kind
,
699 size_t size
, size_t nelems
)
703 /* Currently, character implies size=1. */
704 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
705 || size
== 1 || type
== BT_CHARACTER
)
708 read_block_direct (dtp
, dest
, &sz
);
715 /* Break up complex into its constituent reals. */
716 if (type
== BT_COMPLEX
)
723 /* By now, all complex variables have been split into their
724 constituent reals. For types with padding, we only need to
725 read kind bytes. We don't care about the contents
726 of the padding. If we hit a short record, then sz is
727 adjusted accordingly, making later reads no-ops. */
730 for (i
=0; i
<nelems
; i
++)
732 read_block_direct (dtp
, buffer
, &sz
);
733 reverse_memcpy (p
, buffer
, sz
);
740 /* Master function for unformatted writes. */
743 unformatted_write (st_parameter_dt
*dtp
, bt type
,
744 void *source
, int kind
,
745 size_t size
, size_t nelems
)
747 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
748 size
== 1 || type
== BT_CHARACTER
)
752 write_buf (dtp
, source
, size
);
760 /* Break up complex into its constituent reals. */
761 if (type
== BT_COMPLEX
)
769 /* By now, all complex variables have been split into their
770 constituent reals. For types with padding, we only need to
771 read kind bytes. We don't care about the contents
775 for (i
=0; i
<nelems
; i
++)
777 reverse_memcpy(buffer
, p
, size
);
779 write_buf (dtp
, buffer
, sz
);
785 /* Return a pointer to the name of a type. */
810 internal_error (NULL
, "type_name(): Bad type");
817 /* Write a constant string to the output.
818 This is complicated because the string can have doubled delimiters
819 in it. The length in the format node is the true length. */
822 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
824 char c
, delimiter
, *p
, *q
;
827 length
= f
->u
.string
.length
;
831 p
= write_block (dtp
, length
);
838 for (; length
> 0; length
--)
841 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
842 q
++; /* Skip the doubled delimiter. */
847 /* Given actual and expected types in a formatted data transfer, make
848 sure they agree. If not, an error message is generated. Returns
849 nonzero if something went wrong. */
852 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
856 if (actual
== expected
)
859 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
860 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
862 format_error (dtp
, f
, buffer
);
867 /* This subroutine is the main loop for a formatted data transfer
868 statement. It would be natural to implement this as a coroutine
869 with the user program, but C makes that awkward. We loop,
870 processing format elements. When we actually have to transfer
871 data instead of just setting flags, we return control to the user
872 program which calls a subroutine that supplies the address and type
873 of the next element, then comes back here to process it. */
876 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
879 char scratch
[SCRATCH_SIZE
];
884 int consume_data_flag
;
886 /* Change a complex data item into a pair of reals. */
888 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
889 if (type
== BT_COMPLEX
)
895 /* If there's an EOR condition, we simulate finalizing the transfer
897 if (dtp
->u
.p
.eor_condition
)
900 /* Set this flag so that commas in reads cause the read to complete before
901 the entire field has been read. The next read field will start right after
902 the comma in the stream. (Set to 0 for character reads). */
903 dtp
->u
.p
.sf_read_comma
= 1;
905 dtp
->u
.p
.line_buffer
= scratch
;
908 /* If reversion has occurred and there is another real data item,
909 then we have to move to the next record. */
910 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
912 dtp
->u
.p
.reversion_flag
= 0;
913 next_record (dtp
, 0);
916 consume_data_flag
= 1 ;
917 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
920 f
= next_format (dtp
);
923 /* No data descriptors left. */
925 generate_error (&dtp
->common
, ERROR_FORMAT
,
926 "Insufficient data descriptors in format after reversion");
930 /* Now discharge T, TR and X movements to the right. This is delayed
931 until a data producing format to suppress trailing spaces. */
934 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
935 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
936 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
937 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
938 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
941 if (dtp
->u
.p
.skips
> 0)
943 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
944 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
945 - dtp
->u
.p
.current_unit
->bytes_left
);
947 if (dtp
->u
.p
.skips
< 0)
949 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
950 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
952 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
955 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
956 - dtp
->u
.p
.current_unit
->bytes_left
);
963 if (require_type (dtp
, BT_INTEGER
, type
, f
))
966 if (dtp
->u
.p
.mode
== READING
)
967 read_decimal (dtp
, f
, p
, len
);
969 write_i (dtp
, f
, p
, len
);
977 if (compile_options
.allow_std
< GFC_STD_GNU
978 && require_type (dtp
, BT_INTEGER
, type
, f
))
981 if (dtp
->u
.p
.mode
== READING
)
982 read_radix (dtp
, f
, p
, len
, 2);
984 write_b (dtp
, f
, p
, len
);
992 if (compile_options
.allow_std
< GFC_STD_GNU
993 && require_type (dtp
, BT_INTEGER
, type
, f
))
996 if (dtp
->u
.p
.mode
== READING
)
997 read_radix (dtp
, f
, p
, len
, 8);
999 write_o (dtp
, f
, p
, len
);
1007 if (compile_options
.allow_std
< GFC_STD_GNU
1008 && require_type (dtp
, BT_INTEGER
, type
, f
))
1011 if (dtp
->u
.p
.mode
== READING
)
1012 read_radix (dtp
, f
, p
, len
, 16);
1014 write_z (dtp
, f
, p
, len
);
1022 if (dtp
->u
.p
.mode
== READING
)
1023 read_a (dtp
, f
, p
, len
);
1025 write_a (dtp
, f
, p
, len
);
1033 if (dtp
->u
.p
.mode
== READING
)
1034 read_l (dtp
, f
, p
, len
);
1036 write_l (dtp
, f
, p
, len
);
1043 if (require_type (dtp
, BT_REAL
, type
, f
))
1046 if (dtp
->u
.p
.mode
== READING
)
1047 read_f (dtp
, f
, p
, len
);
1049 write_d (dtp
, f
, p
, len
);
1056 if (require_type (dtp
, BT_REAL
, type
, f
))
1059 if (dtp
->u
.p
.mode
== READING
)
1060 read_f (dtp
, f
, p
, len
);
1062 write_e (dtp
, f
, p
, len
);
1068 if (require_type (dtp
, BT_REAL
, type
, f
))
1071 if (dtp
->u
.p
.mode
== READING
)
1072 read_f (dtp
, f
, p
, len
);
1074 write_en (dtp
, f
, p
, len
);
1081 if (require_type (dtp
, BT_REAL
, type
, f
))
1084 if (dtp
->u
.p
.mode
== READING
)
1085 read_f (dtp
, f
, p
, len
);
1087 write_es (dtp
, f
, p
, len
);
1094 if (require_type (dtp
, BT_REAL
, type
, f
))
1097 if (dtp
->u
.p
.mode
== READING
)
1098 read_f (dtp
, f
, p
, len
);
1100 write_f (dtp
, f
, p
, len
);
1107 if (dtp
->u
.p
.mode
== READING
)
1111 read_decimal (dtp
, f
, p
, len
);
1114 read_l (dtp
, f
, p
, len
);
1117 read_a (dtp
, f
, p
, len
);
1120 read_f (dtp
, f
, p
, len
);
1129 write_i (dtp
, f
, p
, len
);
1132 write_l (dtp
, f
, p
, len
);
1135 write_a (dtp
, f
, p
, len
);
1138 write_d (dtp
, f
, p
, len
);
1142 internal_error (&dtp
->common
,
1143 "formatted_transfer(): Bad type");
1149 consume_data_flag
= 0 ;
1150 if (dtp
->u
.p
.mode
== READING
)
1152 format_error (dtp
, f
, "Constant string in input format");
1155 write_constant_string (dtp
, f
);
1158 /* Format codes that don't transfer data. */
1161 consume_data_flag
= 0;
1163 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
1164 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
1165 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
1167 /* Writes occur just before the switch on f->format, above, so
1168 that trailing blanks are suppressed, unless we are doing a
1169 non-advancing write in which case we want to output the blanks
1171 if (dtp
->u
.p
.mode
== WRITING
1172 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1174 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1175 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1178 if (dtp
->u
.p
.mode
== READING
)
1179 read_x (dtp
, f
->u
.n
);
1185 consume_data_flag
= 0;
1187 if (f
->format
== FMT_TL
)
1190 /* Handle the special case when no bytes have been used yet.
1191 Cannot go below zero. */
1192 if (bytes_used
== 0)
1194 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1195 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
1196 : dtp
->u
.p
.pending_spaces
;
1197 dtp
->u
.p
.skips
-= f
->u
.n
;
1198 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1201 pos
= bytes_used
- f
->u
.n
;
1205 if (dtp
->u
.p
.mode
== READING
)
1208 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1211 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1212 left tab limit. We do not check if the position has gone
1213 beyond the end of record because a subsequent tab could
1214 bring us back again. */
1215 pos
= pos
< 0 ? 0 : pos
;
1217 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1218 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1219 + pos
- dtp
->u
.p
.max_pos
;
1221 if (dtp
->u
.p
.skips
== 0)
1224 /* Writes occur just before the switch on f->format, above, so that
1225 trailing blanks are suppressed. */
1226 if (dtp
->u
.p
.mode
== READING
)
1228 /* Adjust everything for end-of-record condition */
1229 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1231 if (dtp
->u
.p
.sf_seen_eor
== 2)
1233 /* The EOR was a CRLF (two bytes wide). */
1234 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1235 dtp
->u
.p
.skips
-= 2;
1239 /* The EOR marker was only one byte wide. */
1240 dtp
->u
.p
.current_unit
->bytes_left
--;
1244 dtp
->u
.p
.sf_seen_eor
= 0;
1246 if (dtp
->u
.p
.skips
< 0)
1248 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1249 dtp
->u
.p
.current_unit
->bytes_left
1250 -= (gfc_offset
) dtp
->u
.p
.skips
;
1251 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1254 read_x (dtp
, dtp
->u
.p
.skips
);
1260 consume_data_flag
= 0 ;
1261 dtp
->u
.p
.sign_status
= SIGN_S
;
1265 consume_data_flag
= 0 ;
1266 dtp
->u
.p
.sign_status
= SIGN_SS
;
1270 consume_data_flag
= 0 ;
1271 dtp
->u
.p
.sign_status
= SIGN_SP
;
1275 consume_data_flag
= 0 ;
1276 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1280 consume_data_flag
= 0 ;
1281 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1285 consume_data_flag
= 0 ;
1286 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1290 consume_data_flag
= 0 ;
1291 dtp
->u
.p
.seen_dollar
= 1;
1295 consume_data_flag
= 0 ;
1296 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1297 next_record (dtp
, 0);
1301 /* A colon descriptor causes us to exit this loop (in
1302 particular preventing another / descriptor from being
1303 processed) unless there is another data item to be
1305 consume_data_flag
= 0 ;
1311 internal_error (&dtp
->common
, "Bad format node");
1314 /* Free a buffer that we had to allocate during a sequential
1315 formatted read of a block that was larger than the static
1318 if (dtp
->u
.p
.line_buffer
!= scratch
)
1320 free_mem (dtp
->u
.p
.line_buffer
);
1321 dtp
->u
.p
.line_buffer
= scratch
;
1324 /* Adjust the item count and data pointer. */
1326 if ((consume_data_flag
> 0) && (n
> 0))
1329 p
= ((char *) p
) + size
;
1332 if (dtp
->u
.p
.mode
== READING
)
1335 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1336 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1342 /* Come here when we need a data descriptor but don't have one. We
1343 push the current format node back onto the input, then return and
1344 let the user program call us back with the data. */
1346 unget_format (dtp
, f
);
1350 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1351 size_t size
, size_t nelems
)
1358 /* Big loop over all the elements. */
1359 for (elem
= 0; elem
< nelems
; elem
++)
1361 dtp
->u
.p
.item_count
++;
1362 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1368 /* Data transfer entry points. The type of the data entity is
1369 implicit in the subroutine call. This prevents us from having to
1370 share a common enum with the compiler. */
1373 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1375 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1377 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1382 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1385 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1387 size
= size_from_real_kind (kind
);
1388 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1393 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1395 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1397 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1402 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1404 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1406 /* Currently we support only 1 byte chars, and the library is a bit
1407 confused of character kind vs. length, so we kludge it by setting
1409 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1414 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1417 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1419 size
= size_from_complex_kind (kind
);
1420 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1425 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1426 gfc_charlen_type charlen
)
1428 index_type count
[GFC_MAX_DIMENSIONS
];
1429 index_type extent
[GFC_MAX_DIMENSIONS
];
1430 index_type stride
[GFC_MAX_DIMENSIONS
];
1431 index_type stride0
, rank
, size
, type
, n
;
1436 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1439 type
= GFC_DESCRIPTOR_TYPE (desc
);
1440 size
= GFC_DESCRIPTOR_SIZE (desc
);
1442 /* FIXME: What a kludge: Array descriptors and the IO library use
1443 different enums for types. */
1446 case GFC_DTYPE_UNKNOWN
:
1447 iotype
= BT_NULL
; /* Is this correct? */
1449 case GFC_DTYPE_INTEGER
:
1450 iotype
= BT_INTEGER
;
1452 case GFC_DTYPE_LOGICAL
:
1453 iotype
= BT_LOGICAL
;
1455 case GFC_DTYPE_REAL
:
1458 case GFC_DTYPE_COMPLEX
:
1459 iotype
= BT_COMPLEX
;
1461 case GFC_DTYPE_CHARACTER
:
1462 iotype
= BT_CHARACTER
;
1463 /* FIXME: Currently dtype contains the charlen, which is
1464 clobbered if charlen > 2**24. That's why we use a separate
1465 argument for the charlen. However, if we want to support
1466 non-8-bit charsets we need to fix dtype to contain
1467 sizeof(chartype) and fix the code below. */
1471 case GFC_DTYPE_DERIVED
:
1472 internal_error (&dtp
->common
,
1473 "Derived type I/O should have been handled via the frontend.");
1476 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1479 rank
= GFC_DESCRIPTOR_RANK (desc
);
1480 for (n
= 0; n
< rank
; n
++)
1483 stride
[n
] = desc
->dim
[n
].stride
;
1484 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1486 /* If the extent of even one dimension is zero, then the entire
1487 array section contains zero elements, so we return. */
1492 stride0
= stride
[0];
1494 /* If the innermost dimension has stride 1, we can do the transfer
1495 in contiguous chunks. */
1501 data
= GFC_DESCRIPTOR_DATA (desc
);
1505 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1506 data
+= stride0
* size
* tsize
;
1509 while (count
[n
] == extent
[n
])
1512 data
-= stride
[n
] * extent
[n
] * size
;
1522 data
+= stride
[n
] * size
;
1529 /* Preposition a sequential unformatted file while reading. */
1532 us_read (st_parameter_dt
*dtp
, int continued
)
1541 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1544 if (compile_options
.record_marker
== 0)
1545 n
= sizeof (GFC_INTEGER_4
);
1547 n
= compile_options
.record_marker
;
1551 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1555 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1556 return; /* end of file */
1559 if (p
== NULL
|| n
!= nr
)
1561 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1565 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1566 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1570 case sizeof(GFC_INTEGER_4
):
1571 memcpy (&i4
, p
, sizeof (i4
));
1575 case sizeof(GFC_INTEGER_8
):
1576 memcpy (&i8
, p
, sizeof (i8
));
1581 runtime_error ("Illegal value for record marker");
1588 case sizeof(GFC_INTEGER_4
):
1589 reverse_memcpy (&i4
, p
, sizeof (i4
));
1593 case sizeof(GFC_INTEGER_8
):
1594 reverse_memcpy (&i8
, p
, sizeof (i8
));
1599 runtime_error ("Illegal value for record marker");
1605 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1606 dtp
->u
.p
.current_unit
->continued
= 0;
1610 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1611 dtp
->u
.p
.current_unit
->continued
= 1;
1615 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1619 /* Preposition a sequential unformatted file while writing. This
1620 amount to writing a bogus length that will be filled in later. */
1623 us_write (st_parameter_dt
*dtp
, int continued
)
1630 if (compile_options
.record_marker
== 0)
1631 nbytes
= sizeof (GFC_INTEGER_4
);
1633 nbytes
= compile_options
.record_marker
;
1635 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1636 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1638 /* For sequential unformatted, if RECL= was not specified in the OPEN
1639 we write until we have more bytes than can fit in the subrecord
1640 markers, then we write a new subrecord. */
1642 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1643 dtp
->u
.p
.current_unit
->recl_subrecord
;
1644 dtp
->u
.p
.current_unit
->continued
= continued
;
1648 /* Position to the next record prior to transfer. We are assumed to
1649 be before the next record. We also calculate the bytes in the next
1653 pre_position (st_parameter_dt
*dtp
)
1655 if (dtp
->u
.p
.current_unit
->current_record
)
1656 return; /* Already positioned. */
1658 switch (current_mode (dtp
))
1660 case FORMATTED_STREAM
:
1661 case UNFORMATTED_STREAM
:
1662 /* There are no records with stream I/O. Set the default position
1663 to the beginning of the file if no position was specified. */
1664 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1665 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1668 case UNFORMATTED_SEQUENTIAL
:
1669 if (dtp
->u
.p
.mode
== READING
)
1676 case FORMATTED_SEQUENTIAL
:
1677 case FORMATTED_DIRECT
:
1678 case UNFORMATTED_DIRECT
:
1679 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1683 dtp
->u
.p
.current_unit
->current_record
= 1;
1687 /* Initialize things for a data transfer. This code is common for
1688 both reading and writing. */
1691 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1693 unit_flags u_flags
; /* Used for creating a unit if needed. */
1694 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1695 namelist_info
*ionml
;
1697 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1698 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1699 dtp
->u
.p
.ionml
= ionml
;
1700 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1702 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1703 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1705 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1706 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1707 { /* Open the unit with some default flags. */
1708 st_parameter_open opp
;
1711 if (dtp
->common
.unit
< 0)
1713 close_unit (dtp
->u
.p
.current_unit
);
1714 dtp
->u
.p
.current_unit
= NULL
;
1715 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1716 "Bad unit number in OPEN statement");
1719 memset (&u_flags
, '\0', sizeof (u_flags
));
1720 u_flags
.access
= ACCESS_SEQUENTIAL
;
1721 u_flags
.action
= ACTION_READWRITE
;
1723 /* Is it unformatted? */
1724 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1725 | IOPARM_DT_IONML_SET
)))
1726 u_flags
.form
= FORM_UNFORMATTED
;
1728 u_flags
.form
= FORM_UNSPECIFIED
;
1730 u_flags
.delim
= DELIM_UNSPECIFIED
;
1731 u_flags
.blank
= BLANK_UNSPECIFIED
;
1732 u_flags
.pad
= PAD_UNSPECIFIED
;
1733 u_flags
.status
= STATUS_UNKNOWN
;
1735 conv
= get_unformatted_convert (dtp
->common
.unit
);
1737 if (conv
== CONVERT_NONE
)
1738 conv
= compile_options
.convert
;
1740 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1741 and 1 on big-endian machines. */
1744 case CONVERT_NATIVE
:
1749 conv
= l8_to_l4_offset
? CONVERT_NATIVE
: CONVERT_SWAP
;
1752 case CONVERT_LITTLE
:
1753 conv
= l8_to_l4_offset
? CONVERT_SWAP
: CONVERT_NATIVE
;
1757 internal_error (&opp
.common
, "Illegal value for CONVERT");
1761 u_flags
.convert
= conv
;
1763 opp
.common
= dtp
->common
;
1764 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1765 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1766 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1767 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1768 if (dtp
->u
.p
.current_unit
== NULL
)
1772 /* Check the action. */
1774 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1776 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1777 "Cannot read from file opened for WRITE");
1781 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1783 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1784 "Cannot write to file opened for READ");
1788 dtp
->u
.p
.first_item
= 1;
1790 /* Check the format. */
1792 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1795 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1796 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1799 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1800 "Format present for UNFORMATTED data transfer");
1804 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1806 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1807 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1808 "A format cannot be specified with a namelist");
1810 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1811 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1813 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1814 "Missing format for FORMATTED data transfer");
1817 if (is_internal_unit (dtp
)
1818 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1820 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1821 "Internal file cannot be accessed by UNFORMATTED "
1826 /* Check the record or position number. */
1828 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1829 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1831 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1832 "Direct access data transfer requires record number");
1836 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1837 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1839 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1840 "Record number not allowed for sequential access data transfer");
1844 /* Process the ADVANCE option. */
1846 dtp
->u
.p
.advance_status
1847 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1848 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1849 "Bad ADVANCE parameter in data transfer statement");
1851 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1853 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1855 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1856 "ADVANCE specification conflicts with sequential access");
1860 if (is_internal_unit (dtp
))
1862 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1863 "ADVANCE specification conflicts with internal file");
1867 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1868 != IOPARM_DT_HAS_FORMAT
)
1870 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1871 "ADVANCE specification requires an explicit format");
1878 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1880 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1881 "EOR specification requires an ADVANCE specification "
1886 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1888 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1889 "SIZE specification requires an ADVANCE specification of NO");
1894 { /* Write constraints. */
1895 if ((cf
& IOPARM_END
) != 0)
1897 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1898 "END specification cannot appear in a write statement");
1902 if ((cf
& IOPARM_EOR
) != 0)
1904 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1905 "EOR specification cannot appear in a write statement");
1909 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1911 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1912 "SIZE specification cannot appear in a write statement");
1917 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1918 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1920 /* Sanity checks on the record number. */
1921 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1925 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1926 "Record number must be positive");
1930 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1932 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1933 "Record number too large");
1937 /* Check to see if we might be reading what we wrote before */
1939 if (dtp
->u
.p
.mode
== READING
1940 && dtp
->u
.p
.current_unit
->mode
== WRITING
1941 && !is_internal_unit (dtp
))
1942 flush(dtp
->u
.p
.current_unit
->s
);
1944 /* Check whether the record exists to be read. Only
1945 a partial record needs to exist. */
1947 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1948 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1950 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1951 "Non-existing record number");
1955 /* Position the file. */
1956 if (!is_stream_io (dtp
))
1958 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1959 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1961 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1966 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1970 /* Overwriting an existing sequential file ?
1971 it is always safe to truncate the file on the first write */
1972 if (dtp
->u
.p
.mode
== WRITING
1973 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1974 && dtp
->u
.p
.current_unit
->last_record
== 0
1975 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1976 struncate(dtp
->u
.p
.current_unit
->s
);
1978 /* Bugware for badly written mixed C-Fortran I/O. */
1979 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1981 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1983 /* Set the initial value of flags. */
1985 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1986 dtp
->u
.p
.sign_status
= SIGN_S
;
1988 /* Set the maximum position reached from the previous I/O operation. This
1989 could be greater than zero from a previous non-advancing write. */
1990 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
1994 /* Set up the subroutine that will handle the transfers. */
1998 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1999 dtp
->u
.p
.transfer
= unformatted_read
;
2002 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2003 dtp
->u
.p
.transfer
= list_formatted_read
;
2005 dtp
->u
.p
.transfer
= formatted_transfer
;
2010 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2011 dtp
->u
.p
.transfer
= unformatted_write
;
2014 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2015 dtp
->u
.p
.transfer
= list_formatted_write
;
2017 dtp
->u
.p
.transfer
= formatted_transfer
;
2021 /* Make sure that we don't do a read after a nonadvancing write. */
2025 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2027 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
2028 "Cannot READ after a nonadvancing WRITE");
2034 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2035 dtp
->u
.p
.current_unit
->read_bad
= 1;
2038 /* Start the data transfer if we are doing a formatted transfer. */
2039 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2040 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2041 && dtp
->u
.p
.ionml
== NULL
)
2042 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2045 /* Initialize an array_loop_spec given the array descriptor. The function
2046 returns the index of the last element of the array. */
2049 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2051 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2056 for (i
=0; i
<rank
; i
++)
2058 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2059 ls
[i
].start
= desc
->dim
[i
].lbound
;
2060 ls
[i
].end
= desc
->dim
[i
].ubound
;
2061 ls
[i
].step
= desc
->dim
[i
].stride
;
2063 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2064 * desc
->dim
[i
].stride
;
2069 /* Determine the index to the next record in an internal unit array by
2070 by incrementing through the array_loop_spec. TODO: Implement handling
2071 negative strides. */
2074 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2082 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2087 if (ls
[i
].idx
> ls
[i
].end
)
2089 ls
[i
].idx
= ls
[i
].start
;
2095 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2103 /* Skip to the end of the current record, taking care of an optional
2104 record marker of size bytes. If the file is not seekable, we
2105 read chunks of size MAX_READ until we get to the right
2108 #define MAX_READ 4096
2111 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2114 int rlength
, length
;
2117 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2118 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2121 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2123 new = file_position (dtp
->u
.p
.current_unit
->s
)
2124 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2126 /* Direct access files do not generate END conditions,
2128 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2129 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2132 { /* Seek by reading data. */
2133 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2136 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2137 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2139 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2142 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2146 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2154 /* Advance to the next record reading unformatted files, taking
2155 care of subrecords. If complete_record is nonzero, we loop
2156 until all subrecords are cleared. */
2159 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2163 bytes
= compile_options
.record_marker
== 0 ?
2164 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2169 /* Skip over tail */
2171 skip_record (dtp
, bytes
);
2173 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2180 /* Space to the next record for read mode. */
2183 next_record_r (st_parameter_dt
*dtp
)
2186 int length
, bytes_left
;
2189 switch (current_mode (dtp
))
2191 /* No records in unformatted STREAM I/O. */
2192 case UNFORMATTED_STREAM
:
2195 case UNFORMATTED_SEQUENTIAL
:
2196 next_record_r_unf (dtp
, 1);
2197 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2200 case FORMATTED_DIRECT
:
2201 case UNFORMATTED_DIRECT
:
2202 skip_record (dtp
, 0);
2205 case FORMATTED_STREAM
:
2206 case FORMATTED_SEQUENTIAL
:
2208 /* sf_read has already terminated input because of an '\n' */
2209 if (dtp
->u
.p
.sf_seen_eor
)
2211 dtp
->u
.p
.sf_seen_eor
= 0;
2215 if (is_internal_unit (dtp
))
2217 if (is_array_io (dtp
))
2219 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2221 /* Now seek to this record. */
2222 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2223 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2225 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2228 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2232 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2233 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2235 dtp
->u
.p
.current_unit
->bytes_left
2236 = dtp
->u
.p
.current_unit
->recl
;
2242 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2246 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2252 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2256 if (is_stream_io (dtp
))
2257 dtp
->u
.p
.current_unit
->strm_pos
++;
2266 /* Small utility function to write a record marker, taking care of
2267 byte swapping and of choosing the correct size. */
2270 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2275 char p
[sizeof (GFC_INTEGER_8
)];
2277 if (compile_options
.record_marker
== 0)
2278 len
= sizeof (GFC_INTEGER_4
);
2280 len
= compile_options
.record_marker
;
2282 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2283 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
2287 case sizeof (GFC_INTEGER_4
):
2289 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2292 case sizeof (GFC_INTEGER_8
):
2294 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2298 runtime_error ("Illegal value for record marker");
2306 case sizeof (GFC_INTEGER_4
):
2308 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2309 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2312 case sizeof (GFC_INTEGER_8
):
2314 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2315 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2319 runtime_error ("Illegal value for record marker");
2326 /* Position to the next (sub)record in write mode for
2327 unformatted sequential files. */
2330 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2332 gfc_offset c
, m
, m_write
;
2333 size_t record_marker
;
2335 /* Bytes written. */
2336 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2337 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2338 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2340 /* Write the length tail. If we finish a record containing
2341 subrecords, we write out the negative length. */
2343 if (dtp
->u
.p
.current_unit
->continued
)
2348 if (write_us_marker (dtp
, m_write
) != 0)
2351 if (compile_options
.record_marker
== 0)
2352 record_marker
= sizeof (GFC_INTEGER_4
);
2354 record_marker
= compile_options
.record_marker
;
2356 /* Seek to the head and overwrite the bogus length with the real
2359 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2368 if (write_us_marker (dtp
, m_write
) != 0)
2371 /* Seek past the end of the current record. */
2373 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2379 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2384 /* Position to the next record in write mode. */
2387 next_record_w (st_parameter_dt
*dtp
, int done
)
2389 gfc_offset m
, record
, max_pos
;
2393 /* Zero counters for X- and T-editing. */
2394 max_pos
= dtp
->u
.p
.max_pos
;
2395 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2397 switch (current_mode (dtp
))
2399 /* No records in unformatted STREAM I/O. */
2400 case UNFORMATTED_STREAM
:
2403 case FORMATTED_DIRECT
:
2404 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2407 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2408 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2413 case UNFORMATTED_DIRECT
:
2414 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2418 case UNFORMATTED_SEQUENTIAL
:
2419 next_record_w_unf (dtp
, 0);
2420 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2423 case FORMATTED_STREAM
:
2424 case FORMATTED_SEQUENTIAL
:
2426 if (is_internal_unit (dtp
))
2428 if (is_array_io (dtp
))
2430 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2432 /* If the farthest position reached is greater than current
2433 position, adjust the position and set length to pad out
2434 whats left. Otherwise just pad whats left.
2435 (for character array unit) */
2436 m
= dtp
->u
.p
.current_unit
->recl
2437 - dtp
->u
.p
.current_unit
->bytes_left
;
2440 length
= (int) (max_pos
- m
);
2441 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2442 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2445 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2447 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2451 /* Now that the current record has been padded out,
2452 determine where the next record in the array is. */
2453 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2455 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2457 /* Now seek to this record */
2458 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2460 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2462 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2466 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2472 /* If this is the last call to next_record move to the farthest
2473 position reached and set length to pad out the remainder
2474 of the record. (for character scaler unit) */
2477 m
= dtp
->u
.p
.current_unit
->recl
2478 - dtp
->u
.p
.current_unit
->bytes_left
;
2481 length
= (int) (max_pos
- m
);
2482 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2483 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2486 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2489 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2491 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2498 /* If this is the last call to next_record move to the farthest
2499 position reached in preparation for completing the record.
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
);
2512 const char crlf
[] = "\r\n";
2518 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2521 if (is_stream_io (dtp
))
2522 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2528 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2533 /* Position to the next record, which means moving to the end of the
2534 current record. This can happen under several different
2535 conditions. If the done flag is not set, we get ready to process
2539 next_record (st_parameter_dt
*dtp
, int done
)
2541 gfc_offset fp
; /* File position. */
2543 dtp
->u
.p
.current_unit
->read_bad
= 0;
2545 if (dtp
->u
.p
.mode
== READING
)
2546 next_record_r (dtp
);
2548 next_record_w (dtp
, done
);
2550 if (!is_stream_io (dtp
))
2552 /* Keep position up to date for INQUIRE */
2554 update_position (dtp
->u
.p
.current_unit
);
2556 dtp
->u
.p
.current_unit
->current_record
= 0;
2557 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2559 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2560 /* Calculate next record, rounding up partial records. */
2561 dtp
->u
.p
.current_unit
->last_record
=
2562 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2563 dtp
->u
.p
.current_unit
->recl
;
2566 dtp
->u
.p
.current_unit
->last_record
++;
2574 /* Finalize the current data transfer. For a nonadvancing transfer,
2575 this means advancing to the next record. For internal units close the
2576 stream associated with the unit. */
2579 finalize_transfer (st_parameter_dt
*dtp
)
2582 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2584 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2585 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2587 if (dtp
->u
.p
.eor_condition
)
2589 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2593 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2596 if ((dtp
->u
.p
.ionml
!= NULL
)
2597 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2599 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2600 namelist_read (dtp
);
2602 namelist_write (dtp
);
2605 dtp
->u
.p
.transfer
= NULL
;
2606 if (dtp
->u
.p
.current_unit
== NULL
)
2609 dtp
->u
.p
.eof_jump
= &eof_jump
;
2610 if (setjmp (eof_jump
))
2612 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2616 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2618 finish_list_read (dtp
);
2619 sfree (dtp
->u
.p
.current_unit
->s
);
2623 if (is_stream_io (dtp
))
2625 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2626 next_record (dtp
, 1);
2627 flush (dtp
->u
.p
.current_unit
->s
);
2628 sfree (dtp
->u
.p
.current_unit
->s
);
2632 dtp
->u
.p
.current_unit
->current_record
= 0;
2634 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2636 dtp
->u
.p
.seen_dollar
= 0;
2637 sfree (dtp
->u
.p
.current_unit
->s
);
2641 /* For non-advancing I/O, save the current maximum position for use in the
2642 next I/O operation if needed. */
2643 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2645 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2646 - dtp
->u
.p
.current_unit
->bytes_left
);
2647 dtp
->u
.p
.current_unit
->saved_pos
=
2648 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2649 flush (dtp
->u
.p
.current_unit
->s
);
2653 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2655 next_record (dtp
, 1);
2656 sfree (dtp
->u
.p
.current_unit
->s
);
2659 /* Transfer function for IOLENGTH. It doesn't actually do any
2660 data transfer, it just updates the length counter. */
2663 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2664 void *dest
__attribute__ ((unused
)),
2665 int kind
__attribute__((unused
)),
2666 size_t size
, size_t nelems
)
2668 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2669 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2673 /* Initialize the IOLENGTH data transfer. This function is in essence
2674 a very much simplified version of data_transfer_init(), because it
2675 doesn't have to deal with units at all. */
2678 iolength_transfer_init (st_parameter_dt
*dtp
)
2680 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2683 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2685 /* Set up the subroutine that will handle the transfers. */
2687 dtp
->u
.p
.transfer
= iolength_transfer
;
2691 /* Library entry point for the IOLENGTH form of the INQUIRE
2692 statement. The IOLENGTH form requires no I/O to be performed, but
2693 it must still be a runtime library call so that we can determine
2694 the iolength for dynamic arrays and such. */
2696 extern void st_iolength (st_parameter_dt
*);
2697 export_proto(st_iolength
);
2700 st_iolength (st_parameter_dt
*dtp
)
2702 library_start (&dtp
->common
);
2703 iolength_transfer_init (dtp
);
2706 extern void st_iolength_done (st_parameter_dt
*);
2707 export_proto(st_iolength_done
);
2710 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2713 if (dtp
->u
.p
.scratch
!= NULL
)
2714 free_mem (dtp
->u
.p
.scratch
);
2719 /* The READ statement. */
2721 extern void st_read (st_parameter_dt
*);
2722 export_proto(st_read
);
2725 st_read (st_parameter_dt
*dtp
)
2727 library_start (&dtp
->common
);
2729 data_transfer_init (dtp
, 1);
2731 /* Handle complications dealing with the endfile record. */
2733 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2734 switch (dtp
->u
.p
.current_unit
->endfile
)
2737 if (file_length (dtp
->u
.p
.current_unit
->s
)
2738 == file_position (dtp
->u
.p
.current_unit
->s
))
2739 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2743 if (!is_internal_unit (dtp
))
2745 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2746 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2747 dtp
->u
.p
.current_unit
->current_record
= 0;
2752 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2753 dtp
->u
.p
.current_unit
->current_record
= 0;
2758 extern void st_read_done (st_parameter_dt
*);
2759 export_proto(st_read_done
);
2762 st_read_done (st_parameter_dt
*dtp
)
2764 finalize_transfer (dtp
);
2765 free_format_data (dtp
);
2767 if (dtp
->u
.p
.scratch
!= NULL
)
2768 free_mem (dtp
->u
.p
.scratch
);
2769 if (dtp
->u
.p
.current_unit
!= NULL
)
2770 unlock_unit (dtp
->u
.p
.current_unit
);
2772 free_internal_unit (dtp
);
2777 extern void st_write (st_parameter_dt
*);
2778 export_proto(st_write
);
2781 st_write (st_parameter_dt
*dtp
)
2783 library_start (&dtp
->common
);
2784 data_transfer_init (dtp
, 0);
2787 extern void st_write_done (st_parameter_dt
*);
2788 export_proto(st_write_done
);
2791 st_write_done (st_parameter_dt
*dtp
)
2793 finalize_transfer (dtp
);
2795 /* Deal with endfile conditions associated with sequential files. */
2797 if (dtp
->u
.p
.current_unit
!= NULL
2798 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2799 switch (dtp
->u
.p
.current_unit
->endfile
)
2801 case AT_ENDFILE
: /* Remain at the endfile record. */
2805 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2809 /* Get rid of whatever is after this record. */
2810 if (!is_internal_unit (dtp
))
2812 flush (dtp
->u
.p
.current_unit
->s
);
2813 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2814 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2816 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2820 free_format_data (dtp
);
2822 if (dtp
->u
.p
.scratch
!= NULL
)
2823 free_mem (dtp
->u
.p
.scratch
);
2824 if (dtp
->u
.p
.current_unit
!= NULL
)
2825 unlock_unit (dtp
->u
.p
.current_unit
);
2827 free_internal_unit (dtp
);
2832 /* Receives the scalar information for namelist objects and stores it
2833 in a linked list of namelist_info types. */
2835 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2836 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2837 export_proto(st_set_nml_var
);
2841 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2842 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2843 GFC_INTEGER_4 dtype
)
2845 namelist_info
*t1
= NULL
;
2848 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2850 nml
->mem_pos
= var_addr
;
2852 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2853 strcpy (nml
->var_name
, var_name
);
2855 nml
->len
= (int) len
;
2856 nml
->string_length
= (index_type
) string_length
;
2858 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2859 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2860 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2862 if (nml
->var_rank
> 0)
2864 nml
->dim
= (descriptor_dimension
*)
2865 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2866 nml
->ls
= (array_loop_spec
*)
2867 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2877 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2879 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2880 dtp
->u
.p
.ionml
= nml
;
2884 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2889 /* Store the dimensional information for the namelist object. */
2890 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2891 GFC_INTEGER_4
, GFC_INTEGER_4
,
2893 export_proto(st_set_nml_var_dim
);
2896 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2897 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2898 GFC_INTEGER_4 ubound
)
2900 namelist_info
* nml
;
2905 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2907 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2908 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2909 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2912 /* Reverse memcpy - used for byte swapping. */
2914 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2920 s
= (char *) src
+ n
- 1;
2922 /* Write with ascending order - this is likely faster
2923 on modern architectures because of write combining. */