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 if (f
->u
.real
.w
== 0)
1179 write_real (dtp
, p
, len
);
1181 write_d (dtp
, f
, p
, len
);
1185 internal_error (&dtp
->common
,
1186 "formatted_transfer(): Bad type");
1192 consume_data_flag
= 0;
1193 if (dtp
->u
.p
.mode
== READING
)
1195 format_error (dtp
, f
, "Constant string in input format");
1198 write_constant_string (dtp
, f
);
1201 /* Format codes that don't transfer data. */
1204 consume_data_flag
= 0;
1206 dtp
->u
.p
.skips
+= f
->u
.n
;
1207 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1208 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1210 /* Writes occur just before the switch on f->format, above, so
1211 that trailing blanks are suppressed, unless we are doing a
1212 non-advancing write in which case we want to output the blanks
1214 if (dtp
->u
.p
.mode
== WRITING
1215 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1217 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1218 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1221 if (dtp
->u
.p
.mode
== READING
)
1222 read_x (dtp
, f
->u
.n
);
1228 consume_data_flag
= 0;
1230 if (f
->format
== FMT_TL
)
1233 /* Handle the special case when no bytes have been used yet.
1234 Cannot go below zero. */
1235 if (bytes_used
== 0)
1237 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1238 dtp
->u
.p
.skips
-= f
->u
.n
;
1239 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1242 pos
= bytes_used
- f
->u
.n
;
1246 if (dtp
->u
.p
.mode
== READING
)
1249 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1252 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1253 left tab limit. We do not check if the position has gone
1254 beyond the end of record because a subsequent tab could
1255 bring us back again. */
1256 pos
= pos
< 0 ? 0 : pos
;
1258 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1259 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1260 + pos
- dtp
->u
.p
.max_pos
;
1261 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1262 ? 0 : dtp
->u
.p
.pending_spaces
;
1264 if (dtp
->u
.p
.skips
== 0)
1267 /* Writes occur just before the switch on f->format, above, so that
1268 trailing blanks are suppressed. */
1269 if (dtp
->u
.p
.mode
== READING
)
1271 /* Adjust everything for end-of-record condition */
1272 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1274 if (dtp
->u
.p
.sf_seen_eor
== 2)
1276 /* The EOR was a CRLF (two bytes wide). */
1277 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1278 dtp
->u
.p
.skips
-= 2;
1282 /* The EOR marker was only one byte wide. */
1283 dtp
->u
.p
.current_unit
->bytes_left
--;
1287 dtp
->u
.p
.sf_seen_eor
= 0;
1289 if (dtp
->u
.p
.skips
< 0)
1291 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1292 dtp
->u
.p
.current_unit
->bytes_left
1293 -= (gfc_offset
) dtp
->u
.p
.skips
;
1294 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1297 read_x (dtp
, dtp
->u
.p
.skips
);
1303 consume_data_flag
= 0;
1304 dtp
->u
.p
.sign_status
= SIGN_S
;
1308 consume_data_flag
= 0;
1309 dtp
->u
.p
.sign_status
= SIGN_SS
;
1313 consume_data_flag
= 0;
1314 dtp
->u
.p
.sign_status
= SIGN_SP
;
1318 consume_data_flag
= 0 ;
1319 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1323 consume_data_flag
= 0;
1324 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1328 consume_data_flag
= 0;
1329 dtp
->u
.p
.decimal_status
= DECIMAL_COMMA
;
1333 consume_data_flag
= 0;
1334 dtp
->u
.p
.decimal_status
= DECIMAL_POINT
;
1338 consume_data_flag
= 0;
1339 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1343 consume_data_flag
= 0;
1344 dtp
->u
.p
.seen_dollar
= 1;
1348 consume_data_flag
= 0;
1349 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1350 next_record (dtp
, 0);
1354 /* A colon descriptor causes us to exit this loop (in
1355 particular preventing another / descriptor from being
1356 processed) unless there is another data item to be
1358 consume_data_flag
= 0;
1364 internal_error (&dtp
->common
, "Bad format node");
1367 /* Free a buffer that we had to allocate during a sequential
1368 formatted read of a block that was larger than the static
1371 if (dtp
->u
.p
.line_buffer
!= scratch
)
1373 free_mem (dtp
->u
.p
.line_buffer
);
1374 dtp
->u
.p
.line_buffer
= scratch
;
1377 /* Adjust the item count and data pointer. */
1379 if ((consume_data_flag
> 0) && (n
> 0))
1382 p
= ((char *) p
) + size
;
1385 if (dtp
->u
.p
.mode
== READING
)
1388 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1389 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1395 /* Come here when we need a data descriptor but don't have one. We
1396 push the current format node back onto the input, then return and
1397 let the user program call us back with the data. */
1399 unget_format (dtp
, f
);
1403 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1404 size_t size
, size_t nelems
)
1411 /* Big loop over all the elements. */
1412 for (elem
= 0; elem
< nelems
; elem
++)
1414 dtp
->u
.p
.item_count
++;
1415 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1421 /* Data transfer entry points. The type of the data entity is
1422 implicit in the subroutine call. This prevents us from having to
1423 share a common enum with the compiler. */
1426 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1428 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1430 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1435 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1438 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1440 size
= size_from_real_kind (kind
);
1441 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1446 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1448 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1450 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1455 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1457 static char *empty_string
[0];
1459 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1462 /* Strings of zero length can have p == NULL, which confuses the
1463 transfer routines into thinking we need more data elements. To avoid
1464 this, we give them a nice pointer. */
1465 if (len
== 0 && p
== NULL
)
1468 /* Currently we support only 1 byte chars, and the library is a bit
1469 confused of character kind vs. length, so we kludge it by setting
1471 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1476 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1479 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1481 size
= size_from_complex_kind (kind
);
1482 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1487 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1488 gfc_charlen_type charlen
)
1490 index_type count
[GFC_MAX_DIMENSIONS
];
1491 index_type extent
[GFC_MAX_DIMENSIONS
];
1492 index_type stride
[GFC_MAX_DIMENSIONS
];
1493 index_type stride0
, rank
, size
, type
, n
;
1498 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1501 type
= GFC_DESCRIPTOR_TYPE (desc
);
1502 size
= GFC_DESCRIPTOR_SIZE (desc
);
1504 /* FIXME: What a kludge: Array descriptors and the IO library use
1505 different enums for types. */
1508 case GFC_DTYPE_UNKNOWN
:
1509 iotype
= BT_NULL
; /* Is this correct? */
1511 case GFC_DTYPE_INTEGER
:
1512 iotype
= BT_INTEGER
;
1514 case GFC_DTYPE_LOGICAL
:
1515 iotype
= BT_LOGICAL
;
1517 case GFC_DTYPE_REAL
:
1520 case GFC_DTYPE_COMPLEX
:
1521 iotype
= BT_COMPLEX
;
1523 case GFC_DTYPE_CHARACTER
:
1524 iotype
= BT_CHARACTER
;
1525 /* FIXME: Currently dtype contains the charlen, which is
1526 clobbered if charlen > 2**24. That's why we use a separate
1527 argument for the charlen. However, if we want to support
1528 non-8-bit charsets we need to fix dtype to contain
1529 sizeof(chartype) and fix the code below. */
1533 case GFC_DTYPE_DERIVED
:
1534 internal_error (&dtp
->common
,
1535 "Derived type I/O should have been handled via the frontend.");
1538 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1541 rank
= GFC_DESCRIPTOR_RANK (desc
);
1542 for (n
= 0; n
< rank
; n
++)
1545 stride
[n
] = desc
->dim
[n
].stride
;
1546 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1548 /* If the extent of even one dimension is zero, then the entire
1549 array section contains zero elements, so we return after writing
1550 a zero array record. */
1555 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1560 stride0
= stride
[0];
1562 /* If the innermost dimension has stride 1, we can do the transfer
1563 in contiguous chunks. */
1569 data
= GFC_DESCRIPTOR_DATA (desc
);
1573 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1574 data
+= stride0
* size
* tsize
;
1577 while (count
[n
] == extent
[n
])
1580 data
-= stride
[n
] * extent
[n
] * size
;
1590 data
+= stride
[n
] * size
;
1597 /* Preposition a sequential unformatted file while reading. */
1600 us_read (st_parameter_dt
*dtp
, int continued
)
1607 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1610 if (compile_options
.record_marker
== 0)
1611 n
= sizeof (GFC_INTEGER_4
);
1613 n
= compile_options
.record_marker
;
1617 if (sread (dtp
->u
.p
.current_unit
->s
, &i
, &n
) != 0)
1619 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1625 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1626 return; /* end of file */
1631 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1635 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1636 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1640 case sizeof(GFC_INTEGER_4
):
1641 memcpy (&i4
, &i
, sizeof (i4
));
1645 case sizeof(GFC_INTEGER_8
):
1646 memcpy (&i8
, &i
, sizeof (i8
));
1651 runtime_error ("Illegal value for record marker");
1658 case sizeof(GFC_INTEGER_4
):
1659 reverse_memcpy (&i4
, &i
, sizeof (i4
));
1663 case sizeof(GFC_INTEGER_8
):
1664 reverse_memcpy (&i8
, &i
, sizeof (i8
));
1669 runtime_error ("Illegal value for record marker");
1675 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1676 dtp
->u
.p
.current_unit
->continued
= 0;
1680 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1681 dtp
->u
.p
.current_unit
->continued
= 1;
1685 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1689 /* Preposition a sequential unformatted file while writing. This
1690 amount to writing a bogus length that will be filled in later. */
1693 us_write (st_parameter_dt
*dtp
, int continued
)
1700 if (compile_options
.record_marker
== 0)
1701 nbytes
= sizeof (GFC_INTEGER_4
);
1703 nbytes
= compile_options
.record_marker
;
1705 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1706 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1708 /* For sequential unformatted, if RECL= was not specified in the OPEN
1709 we write until we have more bytes than can fit in the subrecord
1710 markers, then we write a new subrecord. */
1712 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1713 dtp
->u
.p
.current_unit
->recl_subrecord
;
1714 dtp
->u
.p
.current_unit
->continued
= continued
;
1718 /* Position to the next record prior to transfer. We are assumed to
1719 be before the next record. We also calculate the bytes in the next
1723 pre_position (st_parameter_dt
*dtp
)
1725 if (dtp
->u
.p
.current_unit
->current_record
)
1726 return; /* Already positioned. */
1728 switch (current_mode (dtp
))
1730 case FORMATTED_STREAM
:
1731 case UNFORMATTED_STREAM
:
1732 /* There are no records with stream I/O. If the position was specified
1733 data_transfer_init has already positioned the file. If no position
1734 was specified, we continue from where we last left off. I.e.
1735 there is nothing to do here. */
1738 case UNFORMATTED_SEQUENTIAL
:
1739 if (dtp
->u
.p
.mode
== READING
)
1746 case FORMATTED_SEQUENTIAL
:
1747 case FORMATTED_DIRECT
:
1748 case UNFORMATTED_DIRECT
:
1749 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1753 dtp
->u
.p
.current_unit
->current_record
= 1;
1757 /* Initialize things for a data transfer. This code is common for
1758 both reading and writing. */
1761 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1763 unit_flags u_flags
; /* Used for creating a unit if needed. */
1764 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1765 namelist_info
*ionml
;
1767 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1768 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1769 dtp
->u
.p
.ionml
= ionml
;
1770 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1772 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1775 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1776 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1778 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1779 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1780 { /* Open the unit with some default flags. */
1781 st_parameter_open opp
;
1784 if (dtp
->common
.unit
< 0)
1786 close_unit (dtp
->u
.p
.current_unit
);
1787 dtp
->u
.p
.current_unit
= NULL
;
1788 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1789 "Bad unit number in OPEN statement");
1792 memset (&u_flags
, '\0', sizeof (u_flags
));
1793 u_flags
.access
= ACCESS_SEQUENTIAL
;
1794 u_flags
.action
= ACTION_READWRITE
;
1796 /* Is it unformatted? */
1797 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1798 | IOPARM_DT_IONML_SET
)))
1799 u_flags
.form
= FORM_UNFORMATTED
;
1801 u_flags
.form
= FORM_UNSPECIFIED
;
1803 u_flags
.delim
= DELIM_UNSPECIFIED
;
1804 u_flags
.blank
= BLANK_UNSPECIFIED
;
1805 u_flags
.pad
= PAD_UNSPECIFIED
;
1806 u_flags
.decimal
= DECIMAL_UNSPECIFIED
;
1807 u_flags
.encoding
= ENCODING_UNSPECIFIED
;
1808 u_flags
.async
= ASYNC_UNSPECIFIED
;
1809 u_flags
.round
= ROUND_UNSPECIFIED
;
1810 u_flags
.sign
= SIGN_UNSPECIFIED
;
1811 u_flags
.status
= STATUS_UNKNOWN
;
1813 conv
= get_unformatted_convert (dtp
->common
.unit
);
1815 if (conv
== GFC_CONVERT_NONE
)
1816 conv
= compile_options
.convert
;
1818 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1819 and 1 on big-endian machines. */
1822 case GFC_CONVERT_NATIVE
:
1823 case GFC_CONVERT_SWAP
:
1826 case GFC_CONVERT_BIG
:
1827 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1830 case GFC_CONVERT_LITTLE
:
1831 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1835 internal_error (&opp
.common
, "Illegal value for CONVERT");
1839 u_flags
.convert
= conv
;
1841 opp
.common
= dtp
->common
;
1842 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1843 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1844 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1845 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1846 if (dtp
->u
.p
.current_unit
== NULL
)
1850 /* Check the action. */
1852 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1854 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1855 "Cannot read from file opened for WRITE");
1859 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1861 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1862 "Cannot write to file opened for READ");
1866 dtp
->u
.p
.first_item
= 1;
1868 /* Check the format. */
1870 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1873 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1874 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1877 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1878 "Format present for UNFORMATTED data transfer");
1882 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1884 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1885 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1886 "A format cannot be specified with a namelist");
1888 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1889 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1891 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1892 "Missing format for FORMATTED data transfer");
1895 if (is_internal_unit (dtp
)
1896 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1898 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1899 "Internal file cannot be accessed by UNFORMATTED "
1904 /* Check the record or position number. */
1906 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1907 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1909 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1910 "Direct access data transfer requires record number");
1914 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1915 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1917 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1918 "Record number not allowed for sequential access data transfer");
1922 /* Process the ADVANCE option. */
1924 dtp
->u
.p
.advance_status
1925 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1926 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1927 "Bad ADVANCE parameter in data transfer statement");
1929 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1931 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1933 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1934 "ADVANCE specification conflicts with sequential access");
1938 if (is_internal_unit (dtp
))
1940 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1941 "ADVANCE specification conflicts with internal file");
1945 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1946 != IOPARM_DT_HAS_FORMAT
)
1948 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1949 "ADVANCE specification requires an explicit format");
1956 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1958 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1960 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1961 "EOR specification requires an ADVANCE specification "
1966 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1968 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1969 "SIZE specification requires an ADVANCE specification of NO");
1974 { /* Write constraints. */
1975 if ((cf
& IOPARM_END
) != 0)
1977 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1978 "END specification cannot appear in a write statement");
1982 if ((cf
& IOPARM_EOR
) != 0)
1984 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1985 "EOR specification cannot appear in a write statement");
1989 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1991 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1992 "SIZE specification cannot appear in a write statement");
1997 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1998 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
2000 /* Check the decimal mode. */
2002 dtp
->u
.p
.decimal_status
2003 = !(cf
& IOPARM_DT_HAS_DECIMAL
) ? DECIMAL_UNSPECIFIED
:
2004 find_option (&dtp
->common
, dtp
->decimal
, dtp
->decimal_len
, decimal_opt
,
2005 "Bad DECIMAL parameter in data transfer statement");
2007 if (dtp
->u
.p
.decimal_status
== DECIMAL_UNSPECIFIED
)
2008 dtp
->u
.p
.decimal_status
= dtp
->u
.p
.current_unit
->flags
.decimal
;
2010 /* Check the sign mode. */
2011 dtp
->u
.p
.sign_status
2012 = !(cf
& IOPARM_DT_HAS_SIGN
) ? SIGN_UNSPECIFIED
:
2013 find_option (&dtp
->common
, dtp
->sign
, dtp
->sign_len
, sign_opt
,
2014 "Bad SIGN parameter in data transfer statement");
2016 if (dtp
->u
.p
.sign_status
== SIGN_UNSPECIFIED
)
2017 dtp
->u
.p
.sign_status
= dtp
->u
.p
.current_unit
->flags
.sign
;
2019 /* Check the blank mode. */
2020 dtp
->u
.p
.blank_status
2021 = !(cf
& IOPARM_DT_HAS_BLANK
) ? BLANK_UNSPECIFIED
:
2022 find_option (&dtp
->common
, dtp
->blank
, dtp
->blank_len
, blank_opt
,
2023 "Bad BLANK parameter in data transfer statement");
2025 if (dtp
->u
.p
.blank_status
== BLANK_UNSPECIFIED
)
2026 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2028 /* Check the delim mode. */
2029 dtp
->u
.p
.delim_status
2030 = !(cf
& IOPARM_DT_HAS_DELIM
) ? DELIM_UNSPECIFIED
:
2031 find_option (&dtp
->common
, dtp
->delim
, dtp
->delim_len
, delim_opt
,
2032 "Bad DELIM parameter in data transfer statement");
2034 if (dtp
->u
.p
.delim_status
== DELIM_UNSPECIFIED
)
2035 dtp
->u
.p
.delim_status
= dtp
->u
.p
.current_unit
->flags
.delim
;
2037 /* Check the pad mode. */
2039 = !(cf
& IOPARM_DT_HAS_PAD
) ? PAD_UNSPECIFIED
:
2040 find_option (&dtp
->common
, dtp
->pad
, dtp
->pad_len
, pad_opt
,
2041 "Bad PAD parameter in data transfer statement");
2043 if (dtp
->u
.p
.pad_status
== PAD_UNSPECIFIED
)
2044 dtp
->u
.p
.pad_status
= dtp
->u
.p
.current_unit
->flags
.pad
;
2046 /* Sanity checks on the record number. */
2047 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
2051 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2052 "Record number must be positive");
2056 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
2058 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2059 "Record number too large");
2063 /* Check to see if we might be reading what we wrote before */
2065 if (dtp
->u
.p
.mode
== READING
2066 && dtp
->u
.p
.current_unit
->mode
== WRITING
2067 && !is_internal_unit (dtp
))
2069 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2070 flush(dtp
->u
.p
.current_unit
->s
);
2073 /* Check whether the record exists to be read. Only
2074 a partial record needs to exist. */
2076 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
2077 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
2079 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2080 "Non-existing record number");
2084 /* Position the file. */
2085 if (!is_stream_io (dtp
))
2087 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2088 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2090 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2096 if (dtp
->u
.p
.current_unit
->strm_pos
!= dtp
->rec
)
2098 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2099 flush (dtp
->u
.p
.current_unit
->s
);
2100 if (sseek (dtp
->u
.p
.current_unit
->s
, dtp
->rec
- 1) == FAILURE
)
2102 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2105 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2111 /* Overwriting an existing sequential file ?
2112 it is always safe to truncate the file on the first write */
2113 if (dtp
->u
.p
.mode
== WRITING
2114 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2115 && dtp
->u
.p
.current_unit
->last_record
== 0
2116 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2117 struncate(dtp
->u
.p
.current_unit
->s
);
2119 /* Bugware for badly written mixed C-Fortran I/O. */
2120 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2122 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2124 /* Set the maximum position reached from the previous I/O operation. This
2125 could be greater than zero from a previous non-advancing write. */
2126 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2131 /* Set up the subroutine that will handle the transfers. */
2135 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2136 dtp
->u
.p
.transfer
= unformatted_read
;
2139 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2140 dtp
->u
.p
.transfer
= list_formatted_read
;
2142 dtp
->u
.p
.transfer
= formatted_transfer
;
2147 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2148 dtp
->u
.p
.transfer
= unformatted_write
;
2151 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2152 dtp
->u
.p
.transfer
= list_formatted_write
;
2154 dtp
->u
.p
.transfer
= formatted_transfer
;
2158 /* Make sure that we don't do a read after a nonadvancing write. */
2162 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2164 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2165 "Cannot READ after a nonadvancing WRITE");
2171 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2172 dtp
->u
.p
.current_unit
->read_bad
= 1;
2175 /* Start the data transfer if we are doing a formatted transfer. */
2176 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2177 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2178 && dtp
->u
.p
.ionml
== NULL
)
2179 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2182 /* Initialize an array_loop_spec given the array descriptor. The function
2183 returns the index of the last element of the array, and also returns
2184 starting record, where the first I/O goes to (necessary in case of
2185 negative strides). */
2188 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2189 gfc_offset
*start_record
)
2191 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2200 for (i
=0; i
<rank
; i
++)
2202 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2203 ls
[i
].start
= desc
->dim
[i
].lbound
;
2204 ls
[i
].end
= desc
->dim
[i
].ubound
;
2205 ls
[i
].step
= desc
->dim
[i
].stride
;
2206 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2208 if (desc
->dim
[i
].stride
> 0)
2210 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2211 * desc
->dim
[i
].stride
;
2215 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2216 * desc
->dim
[i
].stride
;
2217 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2218 * desc
->dim
[i
].stride
;
2228 /* Determine the index to the next record in an internal unit array by
2229 by incrementing through the array_loop_spec. */
2232 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2240 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2245 if (ls
[i
].idx
> ls
[i
].end
)
2247 ls
[i
].idx
= ls
[i
].start
;
2253 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2263 /* Skip to the end of the current record, taking care of an optional
2264 record marker of size bytes. If the file is not seekable, we
2265 read chunks of size MAX_READ until we get to the right
2269 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2273 static const size_t MAX_READ
= 4096;
2276 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2277 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2280 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2282 new = file_position (dtp
->u
.p
.current_unit
->s
)
2283 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2285 /* Direct access files do not generate END conditions,
2287 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2288 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2291 { /* Seek by reading data. */
2292 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2295 (MAX_READ
> (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2296 MAX_READ
: (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2298 if (sread (dtp
->u
.p
.current_unit
->s
, p
, &rlength
) != 0)
2300 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2304 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= rlength
;
2311 /* Advance to the next record reading unformatted files, taking
2312 care of subrecords. If complete_record is nonzero, we loop
2313 until all subrecords are cleared. */
2316 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2320 bytes
= compile_options
.record_marker
== 0 ?
2321 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2326 /* Skip over tail */
2328 skip_record (dtp
, bytes
);
2330 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2338 static inline gfc_offset
2339 min_off (gfc_offset a
, gfc_offset b
)
2341 return (a
< b
? a
: b
);
2345 /* Space to the next record for read mode. */
2348 next_record_r (st_parameter_dt
*dtp
)
2355 switch (current_mode (dtp
))
2357 /* No records in unformatted STREAM I/O. */
2358 case UNFORMATTED_STREAM
:
2361 case UNFORMATTED_SEQUENTIAL
:
2362 next_record_r_unf (dtp
, 1);
2363 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2366 case FORMATTED_DIRECT
:
2367 case UNFORMATTED_DIRECT
:
2368 skip_record (dtp
, 0);
2371 case FORMATTED_STREAM
:
2372 case FORMATTED_SEQUENTIAL
:
2374 /* sf_read has already terminated input because of an '\n' */
2375 if (dtp
->u
.p
.sf_seen_eor
)
2377 dtp
->u
.p
.sf_seen_eor
= 0;
2381 if (is_internal_unit (dtp
))
2383 if (is_array_io (dtp
))
2387 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2390 /* Now seek to this record. */
2391 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2392 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2394 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2397 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2401 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2402 bytes_left
= min_off (bytes_left
,
2403 file_length (dtp
->u
.p
.current_unit
->s
)
2404 - file_position (dtp
->u
.p
.current_unit
->s
));
2405 if (sseek (dtp
->u
.p
.current_unit
->s
,
2406 file_position (dtp
->u
.p
.current_unit
->s
)
2407 + bytes_left
) == FAILURE
)
2409 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2412 dtp
->u
.p
.current_unit
->bytes_left
2413 = dtp
->u
.p
.current_unit
->recl
;
2419 if (sread (dtp
->u
.p
.current_unit
->s
, &p
, &length
) != 0)
2421 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2427 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2431 if (is_stream_io (dtp
))
2432 dtp
->u
.p
.current_unit
->strm_pos
++;
2439 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2440 && !dtp
->u
.p
.namelist_mode
2441 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2442 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2443 file_position (dtp
->u
.p
.current_unit
->s
)))
2444 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2449 /* Small utility function to write a record marker, taking care of
2450 byte swapping and of choosing the correct size. */
2453 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2458 char p
[sizeof (GFC_INTEGER_8
)];
2460 if (compile_options
.record_marker
== 0)
2461 len
= sizeof (GFC_INTEGER_4
);
2463 len
= compile_options
.record_marker
;
2465 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2466 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2470 case sizeof (GFC_INTEGER_4
):
2472 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2475 case sizeof (GFC_INTEGER_8
):
2477 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2481 runtime_error ("Illegal value for record marker");
2489 case sizeof (GFC_INTEGER_4
):
2491 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2492 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2495 case sizeof (GFC_INTEGER_8
):
2497 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2498 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2502 runtime_error ("Illegal value for record marker");
2509 /* Position to the next (sub)record in write mode for
2510 unformatted sequential files. */
2513 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2515 gfc_offset c
, m
, m_write
;
2516 size_t record_marker
;
2518 /* Bytes written. */
2519 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2520 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2521 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2523 /* Write the length tail. If we finish a record containing
2524 subrecords, we write out the negative length. */
2526 if (dtp
->u
.p
.current_unit
->continued
)
2531 if (write_us_marker (dtp
, m_write
) != 0)
2534 if (compile_options
.record_marker
== 0)
2535 record_marker
= sizeof (GFC_INTEGER_4
);
2537 record_marker
= compile_options
.record_marker
;
2539 /* Seek to the head and overwrite the bogus length with the real
2542 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2551 if (write_us_marker (dtp
, m_write
) != 0)
2554 /* Seek past the end of the current record. */
2556 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2562 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2567 /* Position to the next record in write mode. */
2570 next_record_w (st_parameter_dt
*dtp
, int done
)
2572 gfc_offset m
, record
, max_pos
;
2575 /* Flush and reset the format buffer. */
2576 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2578 /* Zero counters for X- and T-editing. */
2579 max_pos
= dtp
->u
.p
.max_pos
;
2580 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2582 switch (current_mode (dtp
))
2584 /* No records in unformatted STREAM I/O. */
2585 case UNFORMATTED_STREAM
:
2588 case FORMATTED_DIRECT
:
2589 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2592 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2593 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2598 case UNFORMATTED_DIRECT
:
2599 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2601 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2602 if (sset (dtp
->u
.p
.current_unit
->s
, 0, length
) == FAILURE
)
2607 case UNFORMATTED_SEQUENTIAL
:
2608 next_record_w_unf (dtp
, 0);
2609 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2612 case FORMATTED_STREAM
:
2613 case FORMATTED_SEQUENTIAL
:
2615 if (is_internal_unit (dtp
))
2617 if (is_array_io (dtp
))
2621 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2623 /* If the farthest position reached is greater than current
2624 position, adjust the position and set length to pad out
2625 whats left. Otherwise just pad whats left.
2626 (for character array unit) */
2627 m
= dtp
->u
.p
.current_unit
->recl
2628 - dtp
->u
.p
.current_unit
->bytes_left
;
2631 length
= (int) (max_pos
- m
);
2632 if (sseek (dtp
->u
.p
.current_unit
->s
,
2633 file_position (dtp
->u
.p
.current_unit
->s
)
2634 + length
) == FAILURE
)
2636 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2639 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2642 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2644 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2648 /* Now that the current record has been padded out,
2649 determine where the next record in the array is. */
2650 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2653 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2655 /* Now seek to this record */
2656 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2658 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2660 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2664 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2670 /* If this is the last call to next_record move to the farthest
2671 position reached and set length to pad out the remainder
2672 of the record. (for character scaler unit) */
2675 m
= dtp
->u
.p
.current_unit
->recl
2676 - dtp
->u
.p
.current_unit
->bytes_left
;
2679 length
= (int) (max_pos
- m
);
2680 if (sseek (dtp
->u
.p
.current_unit
->s
,
2681 file_position (dtp
->u
.p
.current_unit
->s
)
2682 + length
) == FAILURE
)
2684 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2687 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2690 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2693 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2695 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2703 const char crlf
[] = "\r\n";
2710 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2713 if (is_stream_io (dtp
))
2715 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2716 if (dtp
->u
.p
.current_unit
->strm_pos
2717 < file_length (dtp
->u
.p
.current_unit
->s
))
2718 struncate (dtp
->u
.p
.current_unit
->s
);
2725 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2730 /* Position to the next record, which means moving to the end of the
2731 current record. This can happen under several different
2732 conditions. If the done flag is not set, we get ready to process
2736 next_record (st_parameter_dt
*dtp
, int done
)
2738 gfc_offset fp
; /* File position. */
2740 dtp
->u
.p
.current_unit
->read_bad
= 0;
2742 if (dtp
->u
.p
.mode
== READING
)
2743 next_record_r (dtp
);
2745 next_record_w (dtp
, done
);
2747 if (!is_stream_io (dtp
))
2749 /* Keep position up to date for INQUIRE */
2751 update_position (dtp
->u
.p
.current_unit
);
2753 dtp
->u
.p
.current_unit
->current_record
= 0;
2754 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2756 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2757 /* Calculate next record, rounding up partial records. */
2758 dtp
->u
.p
.current_unit
->last_record
=
2759 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2760 dtp
->u
.p
.current_unit
->recl
;
2763 dtp
->u
.p
.current_unit
->last_record
++;
2771 /* Finalize the current data transfer. For a nonadvancing transfer,
2772 this means advancing to the next record. For internal units close the
2773 stream associated with the unit. */
2776 finalize_transfer (st_parameter_dt
*dtp
)
2779 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2781 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2782 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2784 if (dtp
->u
.p
.eor_condition
)
2786 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2790 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2793 if ((dtp
->u
.p
.ionml
!= NULL
)
2794 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2796 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2797 namelist_read (dtp
);
2799 namelist_write (dtp
);
2802 dtp
->u
.p
.transfer
= NULL
;
2803 if (dtp
->u
.p
.current_unit
== NULL
)
2806 dtp
->u
.p
.eof_jump
= &eof_jump
;
2807 if (setjmp (eof_jump
))
2809 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2813 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2815 finish_list_read (dtp
);
2816 sfree (dtp
->u
.p
.current_unit
->s
);
2820 if (dtp
->u
.p
.mode
== WRITING
)
2821 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2822 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2824 if (is_stream_io (dtp
))
2826 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2827 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2828 next_record (dtp
, 1);
2830 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2831 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2833 flush (dtp
->u
.p
.current_unit
->s
);
2834 sfree (dtp
->u
.p
.current_unit
->s
);
2839 dtp
->u
.p
.current_unit
->current_record
= 0;
2841 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2843 dtp
->u
.p
.seen_dollar
= 0;
2844 fbuf_flush (dtp
->u
.p
.current_unit
, 1);
2845 sfree (dtp
->u
.p
.current_unit
->s
);
2849 /* For non-advancing I/O, save the current maximum position for use in the
2850 next I/O operation if needed. */
2851 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2853 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2854 - dtp
->u
.p
.current_unit
->bytes_left
);
2855 dtp
->u
.p
.current_unit
->saved_pos
=
2856 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2857 fbuf_flush (dtp
->u
.p
.current_unit
, 0);
2858 flush (dtp
->u
.p
.current_unit
->s
);
2862 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2864 next_record (dtp
, 1);
2865 sfree (dtp
->u
.p
.current_unit
->s
);
2868 /* Transfer function for IOLENGTH. It doesn't actually do any
2869 data transfer, it just updates the length counter. */
2872 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2873 void *dest
__attribute__ ((unused
)),
2874 int kind
__attribute__((unused
)),
2875 size_t size
, size_t nelems
)
2877 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2878 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2882 /* Initialize the IOLENGTH data transfer. This function is in essence
2883 a very much simplified version of data_transfer_init(), because it
2884 doesn't have to deal with units at all. */
2887 iolength_transfer_init (st_parameter_dt
*dtp
)
2889 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2892 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2894 /* Set up the subroutine that will handle the transfers. */
2896 dtp
->u
.p
.transfer
= iolength_transfer
;
2900 /* Library entry point for the IOLENGTH form of the INQUIRE
2901 statement. The IOLENGTH form requires no I/O to be performed, but
2902 it must still be a runtime library call so that we can determine
2903 the iolength for dynamic arrays and such. */
2905 extern void st_iolength (st_parameter_dt
*);
2906 export_proto(st_iolength
);
2909 st_iolength (st_parameter_dt
*dtp
)
2911 library_start (&dtp
->common
);
2912 iolength_transfer_init (dtp
);
2915 extern void st_iolength_done (st_parameter_dt
*);
2916 export_proto(st_iolength_done
);
2919 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2922 if (dtp
->u
.p
.scratch
!= NULL
)
2923 free_mem (dtp
->u
.p
.scratch
);
2928 /* The READ statement. */
2930 extern void st_read (st_parameter_dt
*);
2931 export_proto(st_read
);
2934 st_read (st_parameter_dt
*dtp
)
2936 library_start (&dtp
->common
);
2938 data_transfer_init (dtp
, 1);
2940 /* Handle complications dealing with the endfile record. */
2942 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2943 switch (dtp
->u
.p
.current_unit
->endfile
)
2949 if (!is_internal_unit (dtp
))
2951 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2952 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2953 dtp
->u
.p
.current_unit
->current_record
= 0;
2958 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2959 dtp
->u
.p
.current_unit
->current_record
= 0;
2964 extern void st_read_done (st_parameter_dt
*);
2965 export_proto(st_read_done
);
2968 st_read_done (st_parameter_dt
*dtp
)
2970 finalize_transfer (dtp
);
2971 free_format_data (dtp
);
2973 if (dtp
->u
.p
.scratch
!= NULL
)
2974 free_mem (dtp
->u
.p
.scratch
);
2975 if (dtp
->u
.p
.current_unit
!= NULL
)
2976 unlock_unit (dtp
->u
.p
.current_unit
);
2978 free_internal_unit (dtp
);
2983 extern void st_write (st_parameter_dt
*);
2984 export_proto(st_write
);
2987 st_write (st_parameter_dt
*dtp
)
2989 library_start (&dtp
->common
);
2990 data_transfer_init (dtp
, 0);
2993 extern void st_write_done (st_parameter_dt
*);
2994 export_proto(st_write_done
);
2997 st_write_done (st_parameter_dt
*dtp
)
2999 finalize_transfer (dtp
);
3001 /* Deal with endfile conditions associated with sequential files. */
3003 if (dtp
->u
.p
.current_unit
!= NULL
3004 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
3005 switch (dtp
->u
.p
.current_unit
->endfile
)
3007 case AT_ENDFILE
: /* Remain at the endfile record. */
3011 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
3015 /* Get rid of whatever is after this record. */
3016 if (!is_internal_unit (dtp
))
3018 flush (dtp
->u
.p
.current_unit
->s
);
3019 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
3020 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
3022 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
3026 free_format_data (dtp
);
3028 if (dtp
->u
.p
.scratch
!= NULL
)
3029 free_mem (dtp
->u
.p
.scratch
);
3030 if (dtp
->u
.p
.current_unit
!= NULL
)
3031 unlock_unit (dtp
->u
.p
.current_unit
);
3033 free_internal_unit (dtp
);
3039 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3041 st_wait (st_parameter_wait
*wtp
__attribute__((unused
)))
3046 /* Receives the scalar information for namelist objects and stores it
3047 in a linked list of namelist_info types. */
3049 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
3050 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
3051 export_proto(st_set_nml_var
);
3055 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
3056 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
3057 GFC_INTEGER_4 dtype
)
3059 namelist_info
*t1
= NULL
;
3061 size_t var_name_len
= strlen (var_name
);
3063 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
3065 nml
->mem_pos
= var_addr
;
3067 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
3068 memcpy (nml
->var_name
, var_name
, var_name_len
);
3069 nml
->var_name
[var_name_len
] = '\0';
3071 nml
->len
= (int) len
;
3072 nml
->string_length
= (index_type
) string_length
;
3074 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
3075 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
3076 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
3078 if (nml
->var_rank
> 0)
3080 nml
->dim
= (descriptor_dimension
*)
3081 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
3082 nml
->ls
= (array_loop_spec
*)
3083 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
3093 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
3095 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
3096 dtp
->u
.p
.ionml
= nml
;
3100 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
3105 /* Store the dimensional information for the namelist object. */
3106 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
3107 index_type
, index_type
,
3109 export_proto(st_set_nml_var_dim
);
3112 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
3113 index_type stride
, index_type lbound
,
3116 namelist_info
* nml
;
3121 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3123 nml
->dim
[n
].stride
= stride
;
3124 nml
->dim
[n
].lbound
= lbound
;
3125 nml
->dim
[n
].ubound
= ubound
;
3128 /* Reverse memcpy - used for byte swapping. */
3130 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3136 s
= (char *) src
+ n
- 1;
3138 /* Write with ascending order - this is likely faster
3139 on modern architectures because of write combining. */