1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran 95 runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
34 /* transfer.c -- Top level handling of data transfer statements. */
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
[] = {
98 static const st_option decimal_opt
[] = {
99 {"point", DECIMAL_POINT
},
100 {"comma", DECIMAL_COMMA
},
105 static const st_option sign_opt
[] = {
107 {"suppress", SIGN_SS
},
108 {"processor_defined", SIGN_S
},
112 static const st_option blank_opt
[] = {
113 {"null", BLANK_NULL
},
114 {"zero", BLANK_ZERO
},
118 static const st_option delim_opt
[] = {
119 {"apostrophe", DELIM_APOSTROPHE
},
120 {"quote", DELIM_QUOTE
},
121 {"none", DELIM_NONE
},
125 static const st_option pad_opt
[] = {
132 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
133 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
139 current_mode (st_parameter_dt
*dtp
)
143 m
= FORM_UNSPECIFIED
;
145 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
147 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
148 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
150 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
152 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
153 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
155 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
157 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
158 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
165 /* Mid level data transfer statements. These subroutines do reading
166 and writing in the style of salloc_r()/salloc_w() within the
169 /* When reading sequential formatted records we have a problem. We
170 don't know how long the line is until we read the trailing newline,
171 and we don't want to read too much. If we read too much, we might
172 have to do a physical seek backwards depending on how much data is
173 present, and devices like terminals aren't seekable and would cause
176 Given this, the solution is to read a byte at a time, stopping if
177 we hit the newline. For small allocations, we use a static buffer.
178 For larger allocations, we are forced to allocate memory on the
179 heap. Hopefully this won't happen very often. */
182 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
189 if (*length
> SCRATCH_SIZE
)
190 dtp
->u
.p
.line_buffer
= get_mem (*length
);
191 p
= base
= dtp
->u
.p
.line_buffer
;
193 /* If we have seen an eor previously, return a length of 0. The
194 caller is responsible for correctly padding the input field. */
195 if (dtp
->u
.p
.sf_seen_eor
)
201 if (is_internal_unit (dtp
))
204 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &readlen
) != 0 || readlen
< (size_t) *length
)
206 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
218 if (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0)
220 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
224 /* If we have a line without a terminating \n, drop through to
226 if (readlen
< 1 && n
== 0)
230 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
234 if (readlen
< 1 || q
== '\n' || q
== '\r')
236 /* Unexpected end of line. */
238 /* If we see an EOR during non-advancing I/O, we need to skip
239 the rest of the I/O statement. Set the corresponding flag. */
240 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
241 dtp
->u
.p
.eor_condition
= 1;
244 /* If we encounter a CR, it might be a CRLF. */
245 if (q
== '\r') /* Probably a CRLF */
248 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
249 if (sread (dtp
->u
.p
.current_unit
->s
, &q
, &readlen
) != 0)
251 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
254 if (q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
255 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
260 /* Without padding, terminate the I/O statement without assigning
261 the value. With padding, the value still needs to be assigned,
262 so we can just continue with a short read. */
263 if (dtp
->u
.p
.pad_status
== PAD_NO
)
267 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
272 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
275 /* Short circuit the read if a comma is found during numeric input.
276 The flag is set to zero during character reads so that commas in
277 strings are not ignored */
279 if (dtp
->u
.p
.sf_read_comma
== 1)
281 notify_std (&dtp
->common
, GFC_STD_GNU
,
282 "Comma in formatted numeric read.");
289 dtp
->u
.p
.sf_seen_eor
= 0;
294 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
296 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
297 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
303 /* Function for reading the next couple of bytes from the current
304 file, advancing the current position. We return FAILURE on end of record or
305 end of file. This function is only for formatted I/O, unformatted uses
308 If the read is short, then it is because the current record does not
309 have enough data to satisfy the read request and the file was
310 opened with PAD=YES. The caller must assume tailing spaces for
314 read_block_form (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
320 if (!is_stream_io (dtp
))
322 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
324 /* For preconnected units with default record length, set bytes left
325 to unit record length and proceed, otherwise error. */
326 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
327 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
328 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
331 if (dtp
->u
.p
.pad_status
== PAD_NO
)
333 /* Not enough data left. */
334 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
339 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
341 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
342 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
346 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
350 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
351 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
352 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
355 source
= read_sf (dtp
, &nb
, 0);
357 dtp
->u
.p
.current_unit
->strm_pos
+=
358 (gfc_offset
) (*nbytes
+ dtp
->u
.p
.sf_seen_eor
);
361 memcpy (buf
, source
, *nbytes
);
364 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
367 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
369 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
373 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
374 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
376 if (nread
!= *nbytes
)
377 { /* Short read, this shouldn't happen. */
378 if (dtp
->u
.p
.pad_status
== PAD_YES
)
382 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
387 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
393 /* Reads a block directly into application data space. This is for
394 unformatted files. */
397 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
399 size_t to_read_record
;
400 size_t have_read_record
;
401 size_t to_read_subrecord
;
402 size_t have_read_subrecord
;
405 if (is_stream_io (dtp
))
407 to_read_record
= *nbytes
;
408 have_read_record
= to_read_record
;
409 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
411 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
415 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
417 if (to_read_record
!= have_read_record
)
419 /* Short read, e.g. if we hit EOF. For stream files,
420 we have to set the end-of-file condition. */
421 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
427 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
429 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
432 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
433 *nbytes
= to_read_record
;
439 to_read_record
= *nbytes
;
442 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
444 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
446 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
450 if (to_read_record
!= *nbytes
)
452 /* Short read, e.g. if we hit EOF. Apparently, we read
453 more than was written to the last record. */
454 *nbytes
= to_read_record
;
460 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
466 /* Unformatted sequential. We loop over the subrecords, reading
467 until the request has been fulfilled or the record has run out
468 of continuation subrecords. */
470 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
472 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
476 /* Check whether we exceed the total record length. */
478 if (dtp
->u
.p
.current_unit
->flags
.has_recl
479 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
481 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
486 to_read_record
= *nbytes
;
489 have_read_record
= 0;
493 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
494 < (gfc_offset
) to_read_record
)
496 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
497 to_read_record
-= to_read_subrecord
;
501 to_read_subrecord
= to_read_record
;
505 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
507 have_read_subrecord
= to_read_subrecord
;
508 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
509 &have_read_subrecord
) != 0)
511 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
515 have_read_record
+= have_read_subrecord
;
517 if (to_read_subrecord
!= have_read_subrecord
)
520 /* Short read, e.g. if we hit EOF. This means the record
521 structure has been corrupted, or the trailing record
522 marker would still be present. */
524 *nbytes
= have_read_record
;
525 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
529 if (to_read_record
> 0)
531 if (dtp
->u
.p
.current_unit
->continued
)
533 next_record_r_unf (dtp
, 0);
538 /* Let's make sure the file position is correctly pre-positioned
539 for the next read statement. */
541 dtp
->u
.p
.current_unit
->current_record
= 0;
542 next_record_r_unf (dtp
, 0);
543 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
549 /* Normal exit, the read request has been fulfilled. */
554 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
557 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
564 /* Function for writing a block of bytes to the current file at the
565 current position, advancing the file pointer. We are given a length
566 and return a pointer to a buffer that the caller must (completely)
567 fill in. Returns NULL on error. */
570 write_block (st_parameter_dt
*dtp
, int length
)
574 if (!is_stream_io (dtp
))
576 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
578 /* For preconnected units with default record length, set bytes left
579 to unit record length and proceed, otherwise error. */
580 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
581 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
582 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
583 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
586 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
591 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
594 if (is_internal_unit (dtp
))
596 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
600 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
604 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
605 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
609 dest
= fbuf_alloc (dtp
->u
.p
.current_unit
, length
);
612 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
617 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
618 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
620 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
626 /* High level interface to swrite(), taking care of errors. This is only
627 called for unformatted files. There are three cases to consider:
628 Stream I/O, unformatted direct, unformatted sequential. */
631 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
634 size_t have_written
, to_write_subrecord
;
639 if (is_stream_io (dtp
))
641 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
643 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
647 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
652 /* Unformatted direct access. */
654 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
656 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
658 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
662 if (buf
== NULL
&& nbytes
== 0)
665 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
667 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
671 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
672 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
677 /* Unformatted sequential. */
681 if (dtp
->u
.p
.current_unit
->flags
.has_recl
682 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
684 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
696 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
697 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
699 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
700 (gfc_offset
) to_write_subrecord
;
702 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
703 &to_write_subrecord
) != 0)
705 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
709 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
710 nbytes
-= to_write_subrecord
;
711 have_written
+= to_write_subrecord
;
716 next_record_w_unf (dtp
, 1);
719 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
722 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
729 /* Master function for unformatted reads. */
732 unformatted_read (st_parameter_dt
*dtp
, bt type
,
733 void *dest
, int kind
__attribute__((unused
)),
734 size_t size
, size_t nelems
)
738 /* Currently, character implies size=1. */
739 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
740 || size
== 1 || type
== BT_CHARACTER
)
743 read_block_direct (dtp
, dest
, &sz
);
750 /* Break up complex into its constituent reals. */
751 if (type
== BT_COMPLEX
)
758 /* By now, all complex variables have been split into their
759 constituent reals. */
761 for (i
=0; i
<nelems
; i
++)
763 read_block_direct (dtp
, buffer
, &size
);
764 reverse_memcpy (p
, buffer
, size
);
771 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
772 bytes on 64 bit machines. The unused bytes are not initialized and never
773 used, which can show an error with memory checking analyzers like
777 unformatted_write (st_parameter_dt
*dtp
, bt type
,
778 void *source
, int kind
__attribute__((unused
)),
779 size_t size
, size_t nelems
)
781 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
782 size
== 1 || type
== BT_CHARACTER
)
785 write_buf (dtp
, source
, size
);
793 /* Break up complex into its constituent reals. */
794 if (type
== BT_COMPLEX
)
802 /* By now, all complex variables have been split into their
803 constituent reals. */
806 for (i
=0; i
<nelems
; i
++)
808 reverse_memcpy(buffer
, p
, size
);
810 write_buf (dtp
, buffer
, size
);
816 /* Return a pointer to the name of a type. */
841 internal_error (NULL
, "type_name(): Bad type");
848 /* Write a constant string to the output.
849 This is complicated because the string can have doubled delimiters
850 in it. The length in the format node is the true length. */
853 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
855 char c
, delimiter
, *p
, *q
;
858 length
= f
->u
.string
.length
;
862 p
= write_block (dtp
, length
);
869 for (; length
> 0; length
--)
872 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
873 q
++; /* Skip the doubled delimiter. */
878 /* Given actual and expected types in a formatted data transfer, make
879 sure they agree. If not, an error message is generated. Returns
880 nonzero if something went wrong. */
883 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
887 if (actual
== expected
)
890 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
891 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
893 format_error (dtp
, f
, buffer
);
898 /* This subroutine is the main loop for a formatted data transfer
899 statement. It would be natural to implement this as a coroutine
900 with the user program, but C makes that awkward. We loop,
901 processing format elements. When we actually have to transfer
902 data instead of just setting flags, we return control to the user
903 program which calls a subroutine that supplies the address and type
904 of the next element, then comes back here to process it. */
907 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
910 char scratch
[SCRATCH_SIZE
];
915 int consume_data_flag
;
917 /* Change a complex data item into a pair of reals. */
919 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
920 if (type
== BT_COMPLEX
)
926 /* If there's an EOR condition, we simulate finalizing the transfer
928 if (dtp
->u
.p
.eor_condition
)
931 /* Set this flag so that commas in reads cause the read to complete before
932 the entire field has been read. The next read field will start right after
933 the comma in the stream. (Set to 0 for character reads). */
934 dtp
->u
.p
.sf_read_comma
= dtp
->u
.p
.decimal_status
== DECIMAL_COMMA
? 0 : 1;
935 dtp
->u
.p
.line_buffer
= scratch
;
939 /* If reversion has occurred and there is another real data item,
940 then we have to move to the next record. */
941 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
943 dtp
->u
.p
.reversion_flag
= 0;
944 next_record (dtp
, 0);
947 consume_data_flag
= 1;
948 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
951 f
= next_format (dtp
);
954 /* No data descriptors left. */
956 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
957 "Insufficient data descriptors in format after reversion");
961 /* Now discharge T, TR and X movements to the right. This is delayed
962 until a data producing format to suppress trailing spaces. */
965 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
966 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
967 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
968 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
969 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
972 if (dtp
->u
.p
.skips
> 0)
975 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
976 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
977 - dtp
->u
.p
.current_unit
->bytes_left
);
979 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
981 if (dtp
->u
.p
.skips
< 0)
983 if (is_internal_unit (dtp
))
984 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
986 fbuf_seek (dtp
->u
.p
.current_unit
, dtp
->u
.p
.skips
);
987 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
989 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
992 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
993 - dtp
->u
.p
.current_unit
->bytes_left
);
995 if (is_stream_io(dtp
))
1003 if (require_type (dtp
, BT_INTEGER
, type
, f
))
1006 if (dtp
->u
.p
.mode
== READING
)
1007 read_decimal (dtp
, f
, p
, len
);
1009 write_i (dtp
, f
, p
, len
);
1017 if (compile_options
.allow_std
< GFC_STD_GNU
1018 && require_type (dtp
, BT_INTEGER
, type
, f
))
1021 if (dtp
->u
.p
.mode
== READING
)
1022 read_radix (dtp
, f
, p
, len
, 2);
1024 write_b (dtp
, f
, p
, len
);
1032 if (compile_options
.allow_std
< GFC_STD_GNU
1033 && require_type (dtp
, BT_INTEGER
, type
, f
))
1036 if (dtp
->u
.p
.mode
== READING
)
1037 read_radix (dtp
, f
, p
, len
, 8);
1039 write_o (dtp
, f
, p
, len
);
1047 if (compile_options
.allow_std
< GFC_STD_GNU
1048 && require_type (dtp
, BT_INTEGER
, type
, f
))
1051 if (dtp
->u
.p
.mode
== READING
)
1052 read_radix (dtp
, f
, p
, len
, 16);
1054 write_z (dtp
, f
, p
, len
);
1062 if (dtp
->u
.p
.mode
== READING
)
1063 read_a (dtp
, f
, p
, len
);
1065 write_a (dtp
, f
, p
, len
);
1073 if (dtp
->u
.p
.mode
== READING
)
1074 read_l (dtp
, f
, p
, len
);
1076 write_l (dtp
, f
, p
, len
);
1083 if (require_type (dtp
, BT_REAL
, type
, f
))
1086 if (dtp
->u
.p
.mode
== READING
)
1087 read_f (dtp
, f
, p
, len
);
1089 write_d (dtp
, f
, p
, len
);
1096 if (require_type (dtp
, BT_REAL
, type
, f
))
1099 if (dtp
->u
.p
.mode
== READING
)
1100 read_f (dtp
, f
, p
, len
);
1102 write_e (dtp
, f
, p
, len
);
1108 if (require_type (dtp
, BT_REAL
, type
, f
))
1111 if (dtp
->u
.p
.mode
== READING
)
1112 read_f (dtp
, f
, p
, len
);
1114 write_en (dtp
, f
, p
, len
);
1121 if (require_type (dtp
, BT_REAL
, type
, f
))
1124 if (dtp
->u
.p
.mode
== READING
)
1125 read_f (dtp
, f
, p
, len
);
1127 write_es (dtp
, f
, p
, len
);
1134 if (require_type (dtp
, BT_REAL
, type
, f
))
1137 if (dtp
->u
.p
.mode
== READING
)
1138 read_f (dtp
, f
, p
, len
);
1140 write_f (dtp
, f
, p
, len
);
1147 if (dtp
->u
.p
.mode
== READING
)
1151 read_decimal (dtp
, f
, p
, len
);
1154 read_l (dtp
, f
, p
, len
);
1157 read_a (dtp
, f
, p
, len
);
1160 read_f (dtp
, f
, p
, len
);
1169 write_i (dtp
, f
, p
, len
);
1172 write_l (dtp
, f
, p
, len
);
1175 write_a (dtp
, f
, p
, len
);
1178 write_d (dtp
, f
, p
, len
);
1182 internal_error (&dtp
->common
,
1183 "formatted_transfer(): Bad type");
1189 consume_data_flag
= 0;
1190 if (dtp
->u
.p
.mode
== READING
)
1192 format_error (dtp
, f
, "Constant string in input format");
1195 write_constant_string (dtp
, f
);
1198 /* Format codes that don't transfer data. */
1201 consume_data_flag
= 0;
1203 dtp
->u
.p
.skips
+= f
->u
.n
;
1204 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1205 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1207 /* Writes occur just before the switch on f->format, above, so
1208 that trailing blanks are suppressed, unless we are doing a
1209 non-advancing write in which case we want to output the blanks
1211 if (dtp
->u
.p
.mode
== WRITING
1212 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1214 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1215 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1218 if (dtp
->u
.p
.mode
== READING
)
1219 read_x (dtp
, f
->u
.n
);
1225 consume_data_flag
= 0;
1227 if (f
->format
== FMT_TL
)
1230 /* Handle the special case when no bytes have been used yet.
1231 Cannot go below zero. */
1232 if (bytes_used
== 0)
1234 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1235 dtp
->u
.p
.skips
-= f
->u
.n
;
1236 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1239 pos
= bytes_used
- f
->u
.n
;
1243 if (dtp
->u
.p
.mode
== READING
)
1246 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1249 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1250 left tab limit. We do not check if the position has gone
1251 beyond the end of record because a subsequent tab could
1252 bring us back again. */
1253 pos
= pos
< 0 ? 0 : pos
;
1255 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1256 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1257 + pos
- dtp
->u
.p
.max_pos
;
1258 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1259 ? 0 : dtp
->u
.p
.pending_spaces
;
1261 if (dtp
->u
.p
.skips
== 0)
1264 /* Writes occur just before the switch on f->format, above, so that
1265 trailing blanks are suppressed. */
1266 if (dtp
->u
.p
.mode
== READING
)
1268 /* Adjust everything for end-of-record condition */
1269 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1271 if (dtp
->u
.p
.sf_seen_eor
== 2)
1273 /* The EOR was a CRLF (two bytes wide). */
1274 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1275 dtp
->u
.p
.skips
-= 2;
1279 /* The EOR marker was only one byte wide. */
1280 dtp
->u
.p
.current_unit
->bytes_left
--;
1284 dtp
->u
.p
.sf_seen_eor
= 0;
1286 if (dtp
->u
.p
.skips
< 0)
1288 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1289 dtp
->u
.p
.current_unit
->bytes_left
1290 -= (gfc_offset
) dtp
->u
.p
.skips
;
1291 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1294 read_x (dtp
, dtp
->u
.p
.skips
);
1300 consume_data_flag
= 0;
1301 dtp
->u
.p
.sign_status
= SIGN_S
;
1305 consume_data_flag
= 0;
1306 dtp
->u
.p
.sign_status
= SIGN_SS
;
1310 consume_data_flag
= 0;
1311 dtp
->u
.p
.sign_status
= SIGN_SP
;
1315 consume_data_flag
= 0 ;
1316 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1320 consume_data_flag
= 0;
1321 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1325 consume_data_flag
= 0;
1326 dtp
->u
.p
.decimal_status
= DECIMAL_COMMA
;
1330 consume_data_flag
= 0;
1331 dtp
->u
.p
.decimal_status
= DECIMAL_POINT
;
1335 consume_data_flag
= 0;
1336 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1340 consume_data_flag
= 0;
1341 dtp
->u
.p
.seen_dollar
= 1;
1345 consume_data_flag
= 0;
1346 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1347 next_record (dtp
, 0);
1351 /* A colon descriptor causes us to exit this loop (in
1352 particular preventing another / descriptor from being
1353 processed) unless there is another data item to be
1355 consume_data_flag
= 0;
1361 internal_error (&dtp
->common
, "Bad format node");
1364 /* Free a buffer that we had to allocate during a sequential
1365 formatted read of a block that was larger than the static
1368 if (dtp
->u
.p
.line_buffer
!= scratch
)
1370 free_mem (dtp
->u
.p
.line_buffer
);
1371 dtp
->u
.p
.line_buffer
= scratch
;
1374 /* Adjust the item count and data pointer. */
1376 if ((consume_data_flag
> 0) && (n
> 0))
1379 p
= ((char *) p
) + size
;
1382 if (dtp
->u
.p
.mode
== READING
)
1385 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1386 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1392 /* Come here when we need a data descriptor but don't have one. We
1393 push the current format node back onto the input, then return and
1394 let the user program call us back with the data. */
1396 unget_format (dtp
, f
);
1400 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1401 size_t size
, size_t nelems
)
1408 /* Big loop over all the elements. */
1409 for (elem
= 0; elem
< nelems
; elem
++)
1411 dtp
->u
.p
.item_count
++;
1412 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1418 /* Data transfer entry points. The type of the data entity is
1419 implicit in the subroutine call. This prevents us from having to
1420 share a common enum with the compiler. */
1423 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1425 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1427 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1432 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1435 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1437 size
= size_from_real_kind (kind
);
1438 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1443 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1445 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1447 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1452 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1454 static char *empty_string
[0];
1456 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1459 /* Strings of zero length can have p == NULL, which confuses the
1460 transfer routines into thinking we need more data elements. To avoid
1461 this, we give them a nice pointer. */
1462 if (len
== 0 && p
== NULL
)
1465 /* Currently we support only 1 byte chars, and the library is a bit
1466 confused of character kind vs. length, so we kludge it by setting
1468 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1473 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1476 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1478 size
= size_from_complex_kind (kind
);
1479 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1484 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1485 gfc_charlen_type charlen
)
1487 index_type count
[GFC_MAX_DIMENSIONS
];
1488 index_type extent
[GFC_MAX_DIMENSIONS
];
1489 index_type stride
[GFC_MAX_DIMENSIONS
];
1490 index_type stride0
, rank
, size
, type
, n
;
1495 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1498 type
= GFC_DESCRIPTOR_TYPE (desc
);
1499 size
= GFC_DESCRIPTOR_SIZE (desc
);
1501 /* FIXME: What a kludge: Array descriptors and the IO library use
1502 different enums for types. */
1505 case GFC_DTYPE_UNKNOWN
:
1506 iotype
= BT_NULL
; /* Is this correct? */
1508 case GFC_DTYPE_INTEGER
:
1509 iotype
= BT_INTEGER
;
1511 case GFC_DTYPE_LOGICAL
:
1512 iotype
= BT_LOGICAL
;
1514 case GFC_DTYPE_REAL
:
1517 case GFC_DTYPE_COMPLEX
:
1518 iotype
= BT_COMPLEX
;
1520 case GFC_DTYPE_CHARACTER
:
1521 iotype
= BT_CHARACTER
;
1522 /* FIXME: Currently dtype contains the charlen, which is
1523 clobbered if charlen > 2**24. That's why we use a separate
1524 argument for the charlen. However, if we want to support
1525 non-8-bit charsets we need to fix dtype to contain
1526 sizeof(chartype) and fix the code below. */
1530 case GFC_DTYPE_DERIVED
:
1531 internal_error (&dtp
->common
,
1532 "Derived type I/O should have been handled via the frontend.");
1535 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1538 rank
= GFC_DESCRIPTOR_RANK (desc
);
1539 for (n
= 0; n
< rank
; n
++)
1542 stride
[n
] = desc
->dim
[n
].stride
;
1543 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1545 /* If the extent of even one dimension is zero, then the entire
1546 array section contains zero elements, so we return after writing
1547 a zero array record. */
1552 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1557 stride0
= stride
[0];
1559 /* If the innermost dimension has stride 1, we can do the transfer
1560 in contiguous chunks. */
1566 data
= GFC_DESCRIPTOR_DATA (desc
);
1570 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1571 data
+= stride0
* size
* tsize
;
1574 while (count
[n
] == extent
[n
])
1577 data
-= stride
[n
] * extent
[n
] * size
;
1587 data
+= stride
[n
] * size
;
1594 /* Preposition a sequential unformatted file while reading. */
1597 us_read (st_parameter_dt
*dtp
, int continued
)
1604 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1607 if (compile_options
.record_marker
== 0)
1608 n
= sizeof (GFC_INTEGER_4
);
1610 n
= compile_options
.record_marker
;
1614 if (sread (dtp
->u
.p
.current_unit
->s
, &i
, &n
) != 0)
1616 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1622 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1623 return; /* end of file */
1628 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1632 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1633 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1637 case sizeof(GFC_INTEGER_4
):
1638 memcpy (&i4
, &i
, sizeof (i4
));
1642 case sizeof(GFC_INTEGER_8
):
1643 memcpy (&i8
, &i
, sizeof (i8
));
1648 runtime_error ("Illegal value for record marker");
1655 case sizeof(GFC_INTEGER_4
):
1656 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1660 case sizeof(GFC_INTEGER_8
):
1661 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1666 runtime_error ("Illegal value for record marker");
1672 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1673 dtp
->u
.p
.current_unit
->continued
= 0;
1677 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1678 dtp
->u
.p
.current_unit
->continued
= 1;
1682 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1686 /* Preposition a sequential unformatted file while writing. This
1687 amount to writing a bogus length that will be filled in later. */
1690 us_write (st_parameter_dt
*dtp
, int continued
)
1697 if (compile_options
.record_marker
== 0)
1698 nbytes
= sizeof (GFC_INTEGER_4
);
1700 nbytes
= compile_options
.record_marker
;
1702 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1703 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1705 /* For sequential unformatted, if RECL= was not specified in the OPEN
1706 we write until we have more bytes than can fit in the subrecord
1707 markers, then we write a new subrecord. */
1709 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1710 dtp
->u
.p
.current_unit
->recl_subrecord
;
1711 dtp
->u
.p
.current_unit
->continued
= continued
;
1715 /* Position to the next record prior to transfer. We are assumed to
1716 be before the next record. We also calculate the bytes in the next
1720 pre_position (st_parameter_dt
*dtp
)
1722 if (dtp
->u
.p
.current_unit
->current_record
)
1723 return; /* Already positioned. */
1725 switch (current_mode (dtp
))
1727 case FORMATTED_STREAM
:
1728 case UNFORMATTED_STREAM
:
1729 /* There are no records with stream I/O. If the position was specified
1730 data_transfer_init has already positioned the file. If no position
1731 was specified, we continue from where we last left off. I.e.
1732 there is nothing to do here. */
1735 case UNFORMATTED_SEQUENTIAL
:
1736 if (dtp
->u
.p
.mode
== READING
)
1743 case FORMATTED_SEQUENTIAL
:
1744 case FORMATTED_DIRECT
:
1745 case UNFORMATTED_DIRECT
:
1746 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1750 dtp
->u
.p
.current_unit
->current_record
= 1;
1754 /* Initialize things for a data transfer. This code is common for
1755 both reading and writing. */
1758 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1760 unit_flags u_flags
; /* Used for creating a unit if needed. */
1761 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1762 namelist_info
*ionml
;
1764 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1765 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1766 dtp
->u
.p
.ionml
= ionml
;
1767 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1769 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1772 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1773 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1775 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1776 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1777 { /* Open the unit with some default flags. */
1778 st_parameter_open opp
;
1781 if (dtp
->common
.unit
< 0)
1783 close_unit (dtp
->u
.p
.current_unit
);
1784 dtp
->u
.p
.current_unit
= NULL
;
1785 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1786 "Bad unit number in OPEN statement");
1789 memset (&u_flags
, '\0', sizeof (u_flags
));
1790 u_flags
.access
= ACCESS_SEQUENTIAL
;
1791 u_flags
.action
= ACTION_READWRITE
;
1793 /* Is it unformatted? */
1794 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1795 | IOPARM_DT_IONML_SET
)))
1796 u_flags
.form
= FORM_UNFORMATTED
;
1798 u_flags
.form
= FORM_UNSPECIFIED
;
1800 u_flags
.delim
= DELIM_UNSPECIFIED
;
1801 u_flags
.blank
= BLANK_UNSPECIFIED
;
1802 u_flags
.pad
= PAD_UNSPECIFIED
;
1803 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1804 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1805 u_flags
.async
= ASYNC_UNSPECIFIED
;
1806 u_flags
.round
= ROUND_UNSPECIFIED
;
1807 u_flags
.sign
= SIGN_UNSPECIFIED
;
1808 u_flags
.status
= STATUS_UNKNOWN
;
1810 conv
= get_unformatted_convert (dtp
->common
.unit
);
1812 if (conv
== GFC_CONVERT_NONE
)
1813 conv
= compile_options
.convert
;
1815 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1816 and 1 on big-endian machines. */
1819 case GFC_CONVERT_NATIVE
:
1820 case GFC_CONVERT_SWAP
:
1823 case GFC_CONVERT_BIG
:
1824 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1827 case GFC_CONVERT_LITTLE
:
1828 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1832 internal_error (&opp
.common
, "Illegal value for CONVERT");
1836 u_flags
.convert
= conv
;
1838 opp
.common
= dtp
->common
;
1839 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1840 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1841 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1842 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1843 if (dtp
->u
.p
.current_unit
== NULL
)
1847 /* Check the action. */
1849 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1851 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1852 "Cannot read from file opened for WRITE");
1856 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1858 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1859 "Cannot write to file opened for READ");
1863 dtp
->u
.p
.first_item
= 1;
1865 /* Check the format. */
1867 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1870 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1871 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1874 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1875 "Format present for UNFORMATTED data transfer");
1879 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1881 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1882 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1883 "A format cannot be specified with a namelist");
1885 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1886 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1888 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1889 "Missing format for FORMATTED data transfer");
1892 if (is_internal_unit (dtp
)
1893 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1895 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1896 "Internal file cannot be accessed by UNFORMATTED "
1901 /* Check the record or position number. */
1903 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1904 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1906 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1907 "Direct access data transfer requires record number");
1911 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1912 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1914 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1915 "Record number not allowed for sequential access data transfer");
1919 /* Process the ADVANCE option. */
1921 dtp
->u
.p
.advance_status
1922 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1923 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1924 "Bad ADVANCE parameter in data transfer statement");
1926 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1928 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1930 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1931 "ADVANCE specification conflicts with sequential access");
1935 if (is_internal_unit (dtp
))
1937 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1938 "ADVANCE specification conflicts with internal file");
1942 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1943 != IOPARM_DT_HAS_FORMAT
)
1945 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1946 "ADVANCE specification requires an explicit format");
1953 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1955 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1957 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1958 "EOR specification requires an ADVANCE specification "
1963 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1965 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1966 "SIZE specification requires an ADVANCE specification of NO");
1971 { /* Write constraints. */
1972 if ((cf
& IOPARM_END
) != 0)
1974 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1975 "END specification cannot appear in a write statement");
1979 if ((cf
& IOPARM_EOR
) != 0)
1981 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1982 "EOR specification cannot appear in a write statement");
1986 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1988 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1989 "SIZE specification cannot appear in a write statement");
1994 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1995 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1997 /* Check the decimal mode. */
1999 dtp
->u
.p
.decimal_status
2000 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2001 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
, decimal_opt
,
2002 "Bad DECIMAL parameter in data transfer statement");
2004 if (dtp
->u
.p
.decimal_status
== DECIMAL_UNSPECIFIED
)
2005 dtp
->u
.p
.decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2007 /* Check the sign mode. */
2008 dtp
->u
.p
.sign_status
2009 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2010 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2011 "Bad SIGN parameter in data transfer statement");
2013 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2014 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2016 /* Check the blank mode. */
2017 dtp
->u
.p
.blank_status
2018 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2019 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
, blank_opt
,
2020 "Bad BLANK parameter in data transfer statement");
2022 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2023 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2025 /* Check the delim mode. */
2026 dtp
->u
.p
.delim_status
2027 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2028 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
, delim_opt
,
2029 "Bad DELIM parameter in data transfer statement");
2031 if (dtp
->u
.p
.delim_status
== DELIM_UNSPECIFIED
)
2032 dtp
->u
.p
.delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2034 /* Check the pad mode. */
2036 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2037 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2038 "Bad PAD parameter in data transfer statement");
2040 if (dtp
->u
.p
.pad_status
== PAD_UNSPECIFIED
)
2041 dtp
->u
.p
.pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2043 /* Sanity checks on the record number. */
2044 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2048 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2049 "Record number must be positive");
2053 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2055 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2056 "Record number too large");
2060 /* Check to see if we might be reading what we wrote before */
2062 if (dtp
->u
.p
.mode
== READING
2063 && dtp
->u
.p
.current_unit
->mode
== WRITING
2064 && !is_internal_unit (dtp
))
2066 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2067 flush(dtp
->u
.p
.current_unit
->s
);
2070 /* Check whether the record exists to be read. Only
2071 a partial record needs to exist. */
2073 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2074 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2076 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2077 "Non-existing record number");
2081 /* Position the file. */
2082 if (!is_stream_io (dtp
))
2084 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2085 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2087 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2093 if (dtp
->u
.p
.current_unit
->strm_pos
!= dtp
->rec
)
2095 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2096 flush (dtp
->u
.p
.current_unit
->s
);
2097 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->rec
- 1) == FAILURE
)
2099 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2102 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2108 /* Overwriting an existing sequential file ?
2109 it is always safe to truncate the file on the first write */
2110 if (dtp
->u
.p
.mode
== WRITING
2111 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2112 && dtp
->u
.p
.current_unit
->last_record
== 0
2113 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2114 struncate(dtp
->u
.p
.current_unit
->s
);
2116 /* Bugware for badly written mixed C-Fortran I/O. */
2117 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2119 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2121 /* Set the maximum position reached from the previous I/O operation. This
2122 could be greater than zero from a previous non-advancing write. */
2123 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2128 /* Set up the subroutine that will handle the transfers. */
2132 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2133 dtp
->u
.p
.transfer
= unformatted_read
;
2136 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2137 dtp
->u
.p
.transfer
= list_formatted_read
;
2139 dtp
->u
.p
.transfer
= formatted_transfer
;
2144 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2145 dtp
->u
.p
.transfer
= unformatted_write
;
2148 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2149 dtp
->u
.p
.transfer
= list_formatted_write
;
2151 dtp
->u
.p
.transfer
= formatted_transfer
;
2155 /* Make sure that we don't do a read after a nonadvancing write. */
2159 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2161 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2162 "Cannot READ after a nonadvancing WRITE");
2168 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2169 dtp
->u
.p
.current_unit
->read_bad
= 1;
2172 /* Start the data transfer if we are doing a formatted transfer. */
2173 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2174 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2175 && dtp
->u
.p
.ionml
== NULL
)
2176 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2179 /* Initialize an array_loop_spec given the array descriptor. The function
2180 returns the index of the last element of the array, and also returns
2181 starting record, where the first I/O goes to (necessary in case of
2182 negative strides). */
2185 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2186 gfc_offset
*start_record
)
2188 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2197 for (i
=0; i
<rank
; i
++)
2199 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2200 ls
[i
].start
= desc
->dim
[i
].lbound
;
2201 ls
[i
].end
= desc
->dim
[i
].ubound
;
2202 ls
[i
].step
= desc
->dim
[i
].stride
;
2203 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2205 if (desc
->dim
[i
].stride
> 0)
2207 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2208 * desc
->dim
[i
].stride
;
2212 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2213 * desc
->dim
[i
].stride
;
2214 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2215 * desc
->dim
[i
].stride
;
2225 /* Determine the index to the next record in an internal unit array by
2226 by incrementing through the array_loop_spec. */
2229 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2237 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2242 if (ls
[i
].idx
> ls
[i
].end
)
2244 ls
[i
].idx
= ls
[i
].start
;
2250 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2260 /* Skip to the end of the current record, taking care of an optional
2261 record marker of size bytes. If the file is not seekable, we
2262 read chunks of size MAX_READ until we get to the right
2266 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2270 static const size_t MAX_READ
= 4096;
2273 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2274 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2277 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2279 new = file_position (dtp
->u
.p
.current_unit
->s
)
2280 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2282 /* Direct access files do not generate END conditions,
2284 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2285 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2288 { /* Seek by reading data. */
2289 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2292 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2293 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2295 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2297 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2301 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2308 /* Advance to the next record reading unformatted files, taking
2309 care of subrecords. If complete_record is nonzero, we loop
2310 until all subrecords are cleared. */
2313 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2317 bytes
= compile_options
.record_marker
== 0 ?
2318 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2323 /* Skip over tail */
2325 skip_record (dtp
, bytes
);
2327 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2335 static inline gfc_offset
2336 min_off (gfc_offset a
, gfc_offset b
)
2338 return (a
< b
? a
: b
);
2342 /* Space to the next record for read mode. */
2345 next_record_r (st_parameter_dt
*dtp
)
2352 switch (current_mode (dtp
))
2354 /* No records in unformatted STREAM I/O. */
2355 case UNFORMATTED_STREAM
:
2358 case UNFORMATTED_SEQUENTIAL
:
2359 next_record_r_unf (dtp
, 1);
2360 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2363 case FORMATTED_DIRECT
:
2364 case UNFORMATTED_DIRECT
:
2365 skip_record (dtp
, 0);
2368 case FORMATTED_STREAM
:
2369 case FORMATTED_SEQUENTIAL
:
2371 /* sf_read has already terminated input because of an '\n' */
2372 if (dtp
->u
.p
.sf_seen_eor
)
2374 dtp
->u
.p
.sf_seen_eor
= 0;
2378 if (is_internal_unit (dtp
))
2380 if (is_array_io (dtp
))
2384 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2387 /* Now seek to this record. */
2388 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2389 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2391 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2394 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2398 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2399 bytes_left
= min_off (bytes_left
,
2400 file_length (dtp
->u
.p
.current_unit
->s
)
2401 - file_position (dtp
->u
.p
.current_unit
->s
));
2402 if (sseek (dtp
->u
.p
.current_unit
->s
,
2403 file_position (dtp
->u
.p
.current_unit
->s
)
2404 + bytes_left
) == FAILURE
)
2406 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2409 dtp
->u
.p
.current_unit
->bytes_left
2410 = dtp
->u
.p
.current_unit
->recl
;
2416 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2418 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2424 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2428 if (is_stream_io (dtp
))
2429 dtp
->u
.p
.current_unit
->strm_pos
++;
2436 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2437 && !dtp
->u
.p
.namelist_mode
2438 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2439 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2440 file_position (dtp
->u
.p
.current_unit
->s
)))
2441 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2446 /* Small utility function to write a record marker, taking care of
2447 byte swapping and of choosing the correct size. */
2450 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2455 char p
[sizeof (GFC_INTEGER_8
)];
2457 if (compile_options
.record_marker
== 0)
2458 len
= sizeof (GFC_INTEGER_4
);
2460 len
= compile_options
.record_marker
;
2462 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2463 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2467 case sizeof (GFC_INTEGER_4
):
2469 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2472 case sizeof (GFC_INTEGER_8
):
2474 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2478 runtime_error ("Illegal value for record marker");
2486 case sizeof (GFC_INTEGER_4
):
2488 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2489 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2492 case sizeof (GFC_INTEGER_8
):
2494 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2495 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2499 runtime_error ("Illegal value for record marker");
2506 /* Position to the next (sub)record in write mode for
2507 unformatted sequential files. */
2510 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2512 gfc_offset c
, m
, m_write
;
2513 size_t record_marker
;
2515 /* Bytes written. */
2516 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2517 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2518 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2520 /* Write the length tail. If we finish a record containing
2521 subrecords, we write out the negative length. */
2523 if (dtp
->u
.p
.current_unit
->continued
)
2528 if (write_us_marker (dtp
, m_write
) != 0)
2531 if (compile_options
.record_marker
== 0)
2532 record_marker
= sizeof (GFC_INTEGER_4
);
2534 record_marker
= compile_options
.record_marker
;
2536 /* Seek to the head and overwrite the bogus length with the real
2539 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2548 if (write_us_marker (dtp
, m_write
) != 0)
2551 /* Seek past the end of the current record. */
2553 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2559 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2564 /* Position to the next record in write mode. */
2567 next_record_w (st_parameter_dt
*dtp
, int done
)
2569 gfc_offset m
, record
, max_pos
;
2572 /* Flush and reset the format buffer. */
2573 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2575 /* Zero counters for X- and T-editing. */
2576 max_pos
= dtp
->u
.p
.max_pos
;
2577 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2579 switch (current_mode (dtp
))
2581 /* No records in unformatted STREAM I/O. */
2582 case UNFORMATTED_STREAM
:
2585 case FORMATTED_DIRECT
:
2586 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2589 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2590 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2595 case UNFORMATTED_DIRECT
:
2596 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2598 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2599 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2604 case UNFORMATTED_SEQUENTIAL
:
2605 next_record_w_unf (dtp
, 0);
2606 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2609 case FORMATTED_STREAM
:
2610 case FORMATTED_SEQUENTIAL
:
2612 if (is_internal_unit (dtp
))
2614 if (is_array_io (dtp
))
2618 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2620 /* If the farthest position reached is greater than current
2621 position, adjust the position and set length to pad out
2622 whats left. Otherwise just pad whats left.
2623 (for character array unit) */
2624 m
= dtp
->u
.p
.current_unit
->recl
2625 - dtp
->u
.p
.current_unit
->bytes_left
;
2628 length
= (int) (max_pos
- m
);
2629 if (sseek (dtp
->u
.p
.current_unit
->s
,
2630 file_position (dtp
->u
.p
.current_unit
->s
)
2631 + length
) == FAILURE
)
2633 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2636 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2639 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2641 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2645 /* Now that the current record has been padded out,
2646 determine where the next record in the array is. */
2647 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2650 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2652 /* Now seek to this record */
2653 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2655 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2657 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2661 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2667 /* If this is the last call to next_record move to the farthest
2668 position reached and set length to pad out the remainder
2669 of the record. (for character scaler unit) */
2672 m
= dtp
->u
.p
.current_unit
->recl
2673 - dtp
->u
.p
.current_unit
->bytes_left
;
2676 length
= (int) (max_pos
- m
);
2677 if (sseek (dtp
->u
.p
.current_unit
->s
,
2678 file_position (dtp
->u
.p
.current_unit
->s
)
2679 + length
) == FAILURE
)
2681 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2684 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2687 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2690 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2692 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2700 const char crlf
[] = "\r\n";
2707 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2710 if (is_stream_io (dtp
))
2712 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2713 if (dtp
->u
.p
.current_unit
->strm_pos
2714 < file_length (dtp
->u
.p
.current_unit
->s
))
2715 struncate (dtp
->u
.p
.current_unit
->s
);
2722 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2727 /* Position to the next record, which means moving to the end of the
2728 current record. This can happen under several different
2729 conditions. If the done flag is not set, we get ready to process
2733 next_record (st_parameter_dt
*dtp
, int done
)
2735 gfc_offset fp
; /* File position. */
2737 dtp
->u
.p
.current_unit
->read_bad
= 0;
2739 if (dtp
->u
.p
.mode
== READING
)
2740 next_record_r (dtp
);
2742 next_record_w (dtp
, done
);
2744 if (!is_stream_io (dtp
))
2746 /* Keep position up to date for INQUIRE */
2748 update_position (dtp
->u
.p
.current_unit
);
2750 dtp
->u
.p
.current_unit
->current_record
= 0;
2751 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2753 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2754 /* Calculate next record, rounding up partial records. */
2755 dtp
->u
.p
.current_unit
->last_record
=
2756 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2757 dtp
->u
.p
.current_unit
->recl
;
2760 dtp
->u
.p
.current_unit
->last_record
++;
2768 /* Finalize the current data transfer. For a nonadvancing transfer,
2769 this means advancing to the next record. For internal units close the
2770 stream associated with the unit. */
2773 finalize_transfer (st_parameter_dt
*dtp
)
2776 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2778 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2779 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2781 if (dtp
->u
.p
.eor_condition
)
2783 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2787 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2790 if ((dtp
->u
.p
.ionml
!= NULL
)
2791 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2793 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2794 namelist_read (dtp
);
2796 namelist_write (dtp
);
2799 dtp
->u
.p
.transfer
= NULL
;
2800 if (dtp
->u
.p
.current_unit
== NULL
)
2803 dtp
->u
.p
.eof_jump
= &eof_jump
;
2804 if (setjmp (eof_jump
))
2806 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2810 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2812 finish_list_read (dtp
);
2813 sfree (dtp
->u
.p
.current_unit
->s
);
2817 if (dtp
->u
.p
.mode
== WRITING
)
2818 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2819 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2821 if (is_stream_io (dtp
))
2823 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2824 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2825 next_record (dtp
, 1);
2827 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2828 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2830 flush (dtp
->u
.p
.current_unit
->s
);
2831 sfree (dtp
->u
.p
.current_unit
->s
);
2836 dtp
->u
.p
.current_unit
->current_record
= 0;
2838 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2840 dtp
->u
.p
.seen_dollar
= 0;
2841 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2842 sfree (dtp
->u
.p
.current_unit
->s
);
2846 /* For non-advancing I/O, save the current maximum position for use in the
2847 next I/O operation if needed. */
2848 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2850 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2851 - dtp
->u
.p
.current_unit
->bytes_left
);
2852 dtp
->u
.p
.current_unit
->saved_pos
=
2853 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2854 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2855 flush (dtp
->u
.p
.current_unit
->s
);
2859 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2861 next_record (dtp
, 1);
2862 sfree (dtp
->u
.p
.current_unit
->s
);
2865 /* Transfer function for IOLENGTH. It doesn't actually do any
2866 data transfer, it just updates the length counter. */
2869 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2870 void *dest
__attribute__ ((unused
)),
2871 int kind
__attribute__((unused
)),
2872 size_t size
, size_t nelems
)
2874 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2875 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2879 /* Initialize the IOLENGTH data transfer. This function is in essence
2880 a very much simplified version of data_transfer_init(), because it
2881 doesn't have to deal with units at all. */
2884 iolength_transfer_init (st_parameter_dt
*dtp
)
2886 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2889 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2891 /* Set up the subroutine that will handle the transfers. */
2893 dtp
->u
.p
.transfer
= iolength_transfer
;
2897 /* Library entry point for the IOLENGTH form of the INQUIRE
2898 statement. The IOLENGTH form requires no I/O to be performed, but
2899 it must still be a runtime library call so that we can determine
2900 the iolength for dynamic arrays and such. */
2902 extern void st_iolength (st_parameter_dt
*);
2903 export_proto(st_iolength
);
2906 st_iolength (st_parameter_dt
*dtp
)
2908 library_start (&dtp
->common
);
2909 iolength_transfer_init (dtp
);
2912 extern void st_iolength_done (st_parameter_dt
*);
2913 export_proto(st_iolength_done
);
2916 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2919 if (dtp
->u
.p
.scratch
!= NULL
)
2920 free_mem (dtp
->u
.p
.scratch
);
2925 /* The READ statement. */
2927 extern void st_read (st_parameter_dt
*);
2928 export_proto(st_read
);
2931 st_read (st_parameter_dt
*dtp
)
2933 library_start (&dtp
->common
);
2935 data_transfer_init (dtp
, 1);
2937 /* Handle complications dealing with the endfile record. */
2939 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2940 switch (dtp
->u
.p
.current_unit
->endfile
)
2946 if (!is_internal_unit (dtp
))
2948 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2949 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2950 dtp
->u
.p
.current_unit
->current_record
= 0;
2955 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2956 dtp
->u
.p
.current_unit
->current_record
= 0;
2961 extern void st_read_done (st_parameter_dt
*);
2962 export_proto(st_read_done
);
2965 st_read_done (st_parameter_dt
*dtp
)
2967 finalize_transfer (dtp
);
2968 free_format_data (dtp
);
2970 if (dtp
->u
.p
.scratch
!= NULL
)
2971 free_mem (dtp
->u
.p
.scratch
);
2972 if (dtp
->u
.p
.current_unit
!= NULL
)
2973 unlock_unit (dtp
->u
.p
.current_unit
);
2975 free_internal_unit (dtp
);
2980 extern void st_write (st_parameter_dt
*);
2981 export_proto(st_write
);
2984 st_write (st_parameter_dt
*dtp
)
2986 library_start (&dtp
->common
);
2987 data_transfer_init (dtp
, 0);
2990 extern void st_write_done (st_parameter_dt
*);
2991 export_proto(st_write_done
);
2994 st_write_done (st_parameter_dt
*dtp
)
2996 finalize_transfer (dtp
);
2998 /* Deal with endfile conditions associated with sequential files. */
3000 if (dtp
->u
.p
.current_unit
!= NULL
3001 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3002 switch (dtp
->u
.p
.current_unit
->endfile
)
3004 case AT_ENDFILE
: /* Remain at the endfile record. */
3008 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3012 /* Get rid of whatever is after this record. */
3013 if (!is_internal_unit (dtp
))
3015 flush (dtp
->u
.p
.current_unit
->s
);
3016 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3017 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3019 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3023 free_format_data (dtp
);
3025 if (dtp
->u
.p
.scratch
!= NULL
)
3026 free_mem (dtp
->u
.p
.scratch
);
3027 if (dtp
->u
.p
.current_unit
!= NULL
)
3028 unlock_unit (dtp
->u
.p
.current_unit
);
3030 free_internal_unit (dtp
);
3036 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3038 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3043 /* Receives the scalar information for namelist objects and stores it
3044 in a linked list of namelist_info types. */
3046 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3047 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3048 export_proto(st_set_nml_var
);
3052 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3053 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3054 GFC_INTEGER_4 dtype
)
3056 namelist_info
*t1
= NULL
;
3058 size_t var_name_len
= strlen (var_name
);
3060 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3062 nml
->mem_pos
= var_addr
;
3064 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3065 memcpy (nml
->var_name
, var_name
, var_name_len
);
3066 nml
->var_name
[var_name_len
] = '\0';
3068 nml
->len
= (int) len
;
3069 nml
->string_length
= (index_type
) string_length
;
3071 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3072 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3073 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3075 if (nml
->var_rank
> 0)
3077 nml
->dim
= (descriptor_dimension
*)
3078 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3079 nml
->ls
= (array_loop_spec
*)
3080 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3090 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3092 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3093 dtp
->u
.p
.ionml
= nml
;
3097 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3102 /* Store the dimensional information for the namelist object. */
3103 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3104 index_type
, index_type
,
3106 export_proto(st_set_nml_var_dim
);
3109 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3110 index_type stride
, index_type lbound
,
3113 namelist_info
* nml
;
3118 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3120 nml
->dim
[n
].stride
= stride
;
3121 nml
->dim
[n
].lbound
= lbound
;
3122 nml
->dim
[n
].ubound
= ubound
;
3125 /* Reverse memcpy - used for byte swapping. */
3127 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3133 s
= (char *) src
+ n
- 1;
3135 /* Write with ascending order - this is likely faster
3136 on modern architectures because of write combining. */