1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
33 /* transfer.c -- Top level handling of data transfer statements. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
58 These subroutines do not return status.
60 The last call is a call to st_[read|write]_done(). While
61 something can easily go wrong with the initial st_read() or
62 st_write(), an error inhibits any data from actually being
65 extern void transfer_integer (st_parameter_dt
*, void *, int);
66 export_proto(transfer_integer
);
68 extern void transfer_real (st_parameter_dt
*, void *, int);
69 export_proto(transfer_real
);
71 extern void transfer_logical (st_parameter_dt
*, void *, int);
72 export_proto(transfer_logical
);
74 extern void transfer_character (st_parameter_dt
*, void *, int);
75 export_proto(transfer_character
);
77 extern void transfer_complex (st_parameter_dt
*, void *, int);
78 export_proto(transfer_complex
);
80 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
82 export_proto(transfer_array
);
84 static void us_read (st_parameter_dt
*, int);
85 static void us_write (st_parameter_dt
*, int);
86 static void next_record_r_unf (st_parameter_dt
*, int);
87 static void next_record_w_unf (st_parameter_dt
*, int);
89 static const st_option advance_opt
[] = {
97 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
98 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
104 current_mode (st_parameter_dt
*dtp
)
108 m
= FORM_UNSPECIFIED
;
110 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
112 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
113 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
115 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
117 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
118 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
120 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
122 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
123 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
130 /* Mid level data transfer statements. These subroutines do reading
131 and writing in the style of salloc_r()/salloc_w() within the
134 /* When reading sequential formatted records we have a problem. We
135 don't know how long the line is until we read the trailing newline,
136 and we don't want to read too much. If we read too much, we might
137 have to do a physical seek backwards depending on how much data is
138 present, and devices like terminals aren't seekable and would cause
141 Given this, the solution is to read a byte at a time, stopping if
142 we hit the newline. For small allocations, we use a static buffer.
143 For larger allocations, we are forced to allocate memory on the
144 heap. Hopefully this won't happen very often. */
147 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
150 int n
, readlen
, crlf
;
153 if (*length
> SCRATCH_SIZE
)
154 dtp
->u
.p
.line_buffer
= get_mem (*length
);
155 p
= base
= dtp
->u
.p
.line_buffer
;
157 /* If we have seen an eor previously, return a length of 0. The
158 caller is responsible for correctly padding the input field. */
159 if (dtp
->u
.p
.sf_seen_eor
)
165 if (is_internal_unit (dtp
))
168 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
169 if (readlen
< *length
)
171 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
176 memcpy (p
, q
, readlen
);
185 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
189 /* If we have a line without a terminating \n, drop through to
191 if (readlen
< 1 && n
== 0)
195 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
199 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
201 /* Unexpected end of line. */
203 /* If we see an EOR during non-advancing I/O, we need to skip
204 the rest of the I/O statement. Set the corresponding flag. */
205 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
206 dtp
->u
.p
.eor_condition
= 1;
209 /* If we encounter a CR, it might be a CRLF. */
210 if (*q
== '\r') /* Probably a CRLF */
213 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
214 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
215 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
216 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
221 /* Without padding, terminate the I/O statement without assigning
222 the value. With padding, the value still needs to be assigned,
223 so we can just continue with a short read. */
224 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
228 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
233 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
236 /* Short circuit the read if a comma is found during numeric input.
237 The flag is set to zero during character reads so that commas in
238 strings are not ignored */
240 if (dtp
->u
.p
.sf_read_comma
== 1)
242 notify_std (&dtp
->common
, GFC_STD_GNU
,
243 "Comma in formatted numeric read.");
250 dtp
->u
.p
.sf_seen_eor
= 0;
255 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
257 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
258 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
264 /* Function for reading the next couple of bytes from the current
265 file, advancing the current position. We return a pointer to a
266 buffer containing the bytes. We return NULL on end of record or
269 If the read is short, then it is because the current record does not
270 have enough data to satisfy the read request and the file was
271 opened with PAD=YES. The caller must assume tailing spaces for
275 read_block (st_parameter_dt
*dtp
, int *length
)
280 if (is_stream_io (dtp
))
282 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
283 != file_position (dtp
->u
.p
.current_unit
->s
)
284 && sseek (dtp
->u
.p
.current_unit
->s
,
285 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
287 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
293 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
295 /* For preconnected units with default record length, set bytes left
296 to unit record length and proceed, otherwise error. */
297 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
298 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
299 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
302 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
304 /* Not enough data left. */
305 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
310 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
312 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
313 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
317 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
321 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
322 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
323 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
325 source
= read_sf (dtp
, length
, 0);
326 dtp
->u
.p
.current_unit
->strm_pos
+=
327 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
330 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
333 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
335 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
336 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
338 if (nread
!= *length
)
339 { /* Short read, this shouldn't happen. */
340 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
344 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
349 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
355 /* Reads a block directly into application data space. This is for
356 unformatted files. */
359 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
361 size_t to_read_record
;
362 size_t have_read_record
;
363 size_t to_read_subrecord
;
364 size_t have_read_subrecord
;
367 if (is_stream_io (dtp
))
369 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
370 != file_position (dtp
->u
.p
.current_unit
->s
)
371 && sseek (dtp
->u
.p
.current_unit
->s
,
372 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
374 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
378 to_read_record
= *nbytes
;
379 have_read_record
= to_read_record
;
380 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
382 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
386 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
388 if (to_read_record
!= have_read_record
)
390 /* Short read, e.g. if we hit EOF. For stream files,
391 we have to set the end-of-file condition. */
392 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
398 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
400 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
403 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
404 *nbytes
= to_read_record
;
410 to_read_record
= *nbytes
;
413 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
415 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
417 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
421 if (to_read_record
!= *nbytes
)
423 /* Short read, e.g. if we hit EOF. Apparently, we read
424 more than was written to the last record. */
425 *nbytes
= to_read_record
;
431 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
437 /* Unformatted sequential. We loop over the subrecords, reading
438 until the request has been fulfilled or the record has run out
439 of continuation subrecords. */
441 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
443 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
447 /* Check whether we exceed the total record length. */
449 if (dtp
->u
.p
.current_unit
->flags
.has_recl
450 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
452 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
457 to_read_record
= *nbytes
;
460 have_read_record
= 0;
464 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
465 < (gfc_offset
) to_read_record
)
467 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
468 to_read_record
-= to_read_subrecord
;
472 to_read_subrecord
= to_read_record
;
476 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
478 have_read_subrecord
= to_read_subrecord
;
479 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
480 &have_read_subrecord
) != 0)
482 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
486 have_read_record
+= have_read_subrecord
;
488 if (to_read_subrecord
!= have_read_subrecord
)
491 /* Short read, e.g. if we hit EOF. This means the record
492 structure has been corrupted, or the trailing record
493 marker would still be present. */
495 *nbytes
= have_read_record
;
496 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
500 if (to_read_record
> 0)
502 if (dtp
->u
.p
.current_unit
->continued
)
504 next_record_r_unf (dtp
, 0);
509 /* Let's make sure the file position is correctly pre-positioned
510 for the next read statement. */
512 dtp
->u
.p
.current_unit
->current_record
= 0;
513 next_record_r_unf (dtp
, 0);
514 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
520 /* Normal exit, the read request has been fulfilled. */
525 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
528 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
535 /* Function for writing a block of bytes to the current file at the
536 current position, advancing the file pointer. We are given a length
537 and return a pointer to a buffer that the caller must (completely)
538 fill in. Returns NULL on error. */
541 write_block (st_parameter_dt
*dtp
, int length
)
545 if (is_stream_io (dtp
))
547 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
548 != file_position (dtp
->u
.p
.current_unit
->s
)
549 && sseek (dtp
->u
.p
.current_unit
->s
,
550 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
552 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
558 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
560 /* For preconnected units with default record length, set bytes left
561 to unit record length and proceed, otherwise error. */
562 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
563 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
564 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
565 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
568 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
573 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
576 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
580 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
584 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
585 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
587 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
588 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
590 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
596 /* High level interface to swrite(), taking care of errors. This is only
597 called for unformatted files. There are three cases to consider:
598 Stream I/O, unformatted direct, unformatted sequential. */
601 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
604 size_t have_written
, to_write_subrecord
;
609 if (is_stream_io (dtp
))
611 if (dtp
->u
.p
.current_unit
->strm_pos
- 1
612 != file_position (dtp
->u
.p
.current_unit
->s
)
613 && sseek (dtp
->u
.p
.current_unit
->s
,
614 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
616 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
620 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
622 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
626 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
631 /* Unformatted direct access. */
633 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
635 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
637 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
641 if (buf
== NULL
&& nbytes
== 0)
644 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
646 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
650 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
651 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
656 /* Unformatted sequential. */
660 if (dtp
->u
.p
.current_unit
->flags
.has_recl
661 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
663 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
675 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
676 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
678 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
679 (gfc_offset
) to_write_subrecord
;
681 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
682 &to_write_subrecord
) != 0)
684 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
688 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
689 nbytes
-= to_write_subrecord
;
690 have_written
+= to_write_subrecord
;
695 next_record_w_unf (dtp
, 1);
698 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
701 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
708 /* Master function for unformatted reads. */
711 unformatted_read (st_parameter_dt
*dtp
, bt type
,
712 void *dest
, int kind
__attribute__((unused
)),
713 size_t size
, size_t nelems
)
717 /* Currently, character implies size=1. */
718 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
719 || size
== 1 || type
== BT_CHARACTER
)
722 read_block_direct (dtp
, dest
, &sz
);
729 /* Break up complex into its constituent reals. */
730 if (type
== BT_COMPLEX
)
737 /* By now, all complex variables have been split into their
738 constituent reals. */
740 for (i
=0; i
<nelems
; i
++)
742 read_block_direct (dtp
, buffer
, &size
);
743 reverse_memcpy (p
, buffer
, size
);
750 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
751 bytes on 64 bit machines. The unused bytes are not initialized and never
752 used, which can show an error with memory checking analyzers like
756 unformatted_write (st_parameter_dt
*dtp
, bt type
,
757 void *source
, int kind
__attribute__((unused
)),
758 size_t size
, size_t nelems
)
760 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
761 size
== 1 || type
== BT_CHARACTER
)
764 write_buf (dtp
, source
, size
);
772 /* Break up complex into its constituent reals. */
773 if (type
== BT_COMPLEX
)
781 /* By now, all complex variables have been split into their
782 constituent reals. */
785 for (i
=0; i
<nelems
; i
++)
787 reverse_memcpy(buffer
, p
, size
);
789 write_buf (dtp
, buffer
, size
);
795 /* Return a pointer to the name of a type. */
820 internal_error (NULL
, "type_name(): Bad type");
827 /* Write a constant string to the output.
828 This is complicated because the string can have doubled delimiters
829 in it. The length in the format node is the true length. */
832 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
834 char c
, delimiter
, *p
, *q
;
837 length
= f
->u
.string
.length
;
841 p
= write_block (dtp
, length
);
848 for (; length
> 0; length
--)
851 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
852 q
++; /* Skip the doubled delimiter. */
857 /* Given actual and expected types in a formatted data transfer, make
858 sure they agree. If not, an error message is generated. Returns
859 nonzero if something went wrong. */
862 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
866 if (actual
== expected
)
869 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
870 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
872 format_error (dtp
, f
, buffer
);
877 /* This subroutine is the main loop for a formatted data transfer
878 statement. It would be natural to implement this as a coroutine
879 with the user program, but C makes that awkward. We loop,
880 processing format elements. When we actually have to transfer
881 data instead of just setting flags, we return control to the user
882 program which calls a subroutine that supplies the address and type
883 of the next element, then comes back here to process it. */
886 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
889 char scratch
[SCRATCH_SIZE
];
894 int consume_data_flag
;
896 /* Change a complex data item into a pair of reals. */
898 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
899 if (type
== BT_COMPLEX
)
905 /* If there's an EOR condition, we simulate finalizing the transfer
907 if (dtp
->u
.p
.eor_condition
)
910 /* Set this flag so that commas in reads cause the read to complete before
911 the entire field has been read. The next read field will start right after
912 the comma in the stream. (Set to 0 for character reads). */
913 dtp
->u
.p
.sf_read_comma
= 1;
914 dtp
->u
.p
.line_buffer
= scratch
;
918 /* If reversion has occurred and there is another real data item,
919 then we have to move to the next record. */
920 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
922 dtp
->u
.p
.reversion_flag
= 0;
923 next_record (dtp
, 0);
926 consume_data_flag
= 1 ;
927 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
930 f
= next_format (dtp
);
933 /* No data descriptors left. */
935 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
936 "Insufficient data descriptors in format after reversion");
940 /* Now discharge T, TR and X movements to the right. This is delayed
941 until a data producing format to suppress trailing spaces. */
944 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
945 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
946 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
947 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
948 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
951 if (dtp
->u
.p
.skips
> 0)
954 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
955 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
956 - dtp
->u
.p
.current_unit
->bytes_left
);
958 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
960 if (dtp
->u
.p
.skips
< 0)
962 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
963 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
965 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
968 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
969 - dtp
->u
.p
.current_unit
->bytes_left
);
971 if (is_stream_io(dtp
))
979 if (require_type (dtp
, BT_INTEGER
, type
, f
))
982 if (dtp
->u
.p
.mode
== READING
)
983 read_decimal (dtp
, f
, p
, len
);
985 write_i (dtp
, f
, p
, len
);
993 if (compile_options
.allow_std
< GFC_STD_GNU
994 && require_type (dtp
, BT_INTEGER
, type
, f
))
997 if (dtp
->u
.p
.mode
== READING
)
998 read_radix (dtp
, f
, p
, len
, 2);
1000 write_b (dtp
, f
, p
, len
);
1008 if (compile_options
.allow_std
< GFC_STD_GNU
1009 && require_type (dtp
, BT_INTEGER
, type
, f
))
1012 if (dtp
->u
.p
.mode
== READING
)
1013 read_radix (dtp
, f
, p
, len
, 8);
1015 write_o (dtp
, f
, p
, len
);
1023 if (compile_options
.allow_std
< GFC_STD_GNU
1024 && require_type (dtp
, BT_INTEGER
, type
, f
))
1027 if (dtp
->u
.p
.mode
== READING
)
1028 read_radix (dtp
, f
, p
, len
, 16);
1030 write_z (dtp
, f
, p
, len
);
1038 if (dtp
->u
.p
.mode
== READING
)
1039 read_a (dtp
, f
, p
, len
);
1041 write_a (dtp
, f
, p
, len
);
1049 if (dtp
->u
.p
.mode
== READING
)
1050 read_l (dtp
, f
, p
, len
);
1052 write_l (dtp
, f
, p
, len
);
1059 if (require_type (dtp
, BT_REAL
, type
, f
))
1062 if (dtp
->u
.p
.mode
== READING
)
1063 read_f (dtp
, f
, p
, len
);
1065 write_d (dtp
, f
, p
, len
);
1072 if (require_type (dtp
, BT_REAL
, type
, f
))
1075 if (dtp
->u
.p
.mode
== READING
)
1076 read_f (dtp
, f
, p
, len
);
1078 write_e (dtp
, f
, p
, len
);
1084 if (require_type (dtp
, BT_REAL
, type
, f
))
1087 if (dtp
->u
.p
.mode
== READING
)
1088 read_f (dtp
, f
, p
, len
);
1090 write_en (dtp
, f
, p
, len
);
1097 if (require_type (dtp
, BT_REAL
, type
, f
))
1100 if (dtp
->u
.p
.mode
== READING
)
1101 read_f (dtp
, f
, p
, len
);
1103 write_es (dtp
, f
, p
, len
);
1110 if (require_type (dtp
, BT_REAL
, type
, f
))
1113 if (dtp
->u
.p
.mode
== READING
)
1114 read_f (dtp
, f
, p
, len
);
1116 write_f (dtp
, f
, p
, len
);
1123 if (dtp
->u
.p
.mode
== READING
)
1127 read_decimal (dtp
, f
, p
, len
);
1130 read_l (dtp
, f
, p
, len
);
1133 read_a (dtp
, f
, p
, len
);
1136 read_f (dtp
, f
, p
, len
);
1145 write_i (dtp
, f
, p
, len
);
1148 write_l (dtp
, f
, p
, len
);
1151 write_a (dtp
, f
, p
, len
);
1154 write_d (dtp
, f
, p
, len
);
1158 internal_error (&dtp
->common
,
1159 "formatted_transfer(): Bad type");
1165 consume_data_flag
= 0 ;
1166 if (dtp
->u
.p
.mode
== READING
)
1168 format_error (dtp
, f
, "Constant string in input format");
1171 write_constant_string (dtp
, f
);
1174 /* Format codes that don't transfer data. */
1177 consume_data_flag
= 0;
1179 dtp
->u
.p
.skips
+= f
->u
.n
;
1180 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1181 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1183 /* Writes occur just before the switch on f->format, above, so
1184 that trailing blanks are suppressed, unless we are doing a
1185 non-advancing write in which case we want to output the blanks
1187 if (dtp
->u
.p
.mode
== WRITING
1188 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1190 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1191 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1194 if (dtp
->u
.p
.mode
== READING
)
1195 read_x (dtp
, f
->u
.n
);
1201 consume_data_flag
= 0;
1203 if (f
->format
== FMT_TL
)
1206 /* Handle the special case when no bytes have been used yet.
1207 Cannot go below zero. */
1208 if (bytes_used
== 0)
1210 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1211 dtp
->u
.p
.skips
-= f
->u
.n
;
1212 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1215 pos
= bytes_used
- f
->u
.n
;
1219 if (dtp
->u
.p
.mode
== READING
)
1222 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1225 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1226 left tab limit. We do not check if the position has gone
1227 beyond the end of record because a subsequent tab could
1228 bring us back again. */
1229 pos
= pos
< 0 ? 0 : pos
;
1231 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1232 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1233 + pos
- dtp
->u
.p
.max_pos
;
1234 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1235 ? 0 : dtp
->u
.p
.pending_spaces
;
1237 if (dtp
->u
.p
.skips
== 0)
1240 /* Writes occur just before the switch on f->format, above, so that
1241 trailing blanks are suppressed. */
1242 if (dtp
->u
.p
.mode
== READING
)
1244 /* Adjust everything for end-of-record condition */
1245 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1247 if (dtp
->u
.p
.sf_seen_eor
== 2)
1249 /* The EOR was a CRLF (two bytes wide). */
1250 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1251 dtp
->u
.p
.skips
-= 2;
1255 /* The EOR marker was only one byte wide. */
1256 dtp
->u
.p
.current_unit
->bytes_left
--;
1260 dtp
->u
.p
.sf_seen_eor
= 0;
1262 if (dtp
->u
.p
.skips
< 0)
1264 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1265 dtp
->u
.p
.current_unit
->bytes_left
1266 -= (gfc_offset
) dtp
->u
.p
.skips
;
1267 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1270 read_x (dtp
, dtp
->u
.p
.skips
);
1274 if (dtp
->u
.p
.skips
< 0)
1275 flush (dtp
->u
.p
.current_unit
->s
);
1281 consume_data_flag
= 0 ;
1282 dtp
->u
.p
.sign_status
= SIGN_S
;
1286 consume_data_flag
= 0 ;
1287 dtp
->u
.p
.sign_status
= SIGN_SS
;
1291 consume_data_flag
= 0 ;
1292 dtp
->u
.p
.sign_status
= SIGN_SP
;
1296 consume_data_flag
= 0 ;
1297 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1301 consume_data_flag
= 0 ;
1302 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1306 consume_data_flag
= 0 ;
1307 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1311 consume_data_flag
= 0 ;
1312 dtp
->u
.p
.seen_dollar
= 1;
1316 consume_data_flag
= 0 ;
1317 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1318 next_record (dtp
, 0);
1322 /* A colon descriptor causes us to exit this loop (in
1323 particular preventing another / descriptor from being
1324 processed) unless there is another data item to be
1326 consume_data_flag
= 0 ;
1332 internal_error (&dtp
->common
, "Bad format node");
1335 /* Free a buffer that we had to allocate during a sequential
1336 formatted read of a block that was larger than the static
1339 if (dtp
->u
.p
.line_buffer
!= scratch
)
1341 free_mem (dtp
->u
.p
.line_buffer
);
1342 dtp
->u
.p
.line_buffer
= scratch
;
1345 /* Adjust the item count and data pointer. */
1347 if ((consume_data_flag
> 0) && (n
> 0))
1350 p
= ((char *) p
) + size
;
1353 if (dtp
->u
.p
.mode
== READING
)
1356 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1357 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1363 /* Come here when we need a data descriptor but don't have one. We
1364 push the current format node back onto the input, then return and
1365 let the user program call us back with the data. */
1367 unget_format (dtp
, f
);
1371 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1372 size_t size
, size_t nelems
)
1379 /* Big loop over all the elements. */
1380 for (elem
= 0; elem
< nelems
; elem
++)
1382 dtp
->u
.p
.item_count
++;
1383 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1389 /* Data transfer entry points. The type of the data entity is
1390 implicit in the subroutine call. This prevents us from having to
1391 share a common enum with the compiler. */
1394 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1396 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1398 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1403 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1406 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1408 size
= size_from_real_kind (kind
);
1409 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1414 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1416 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1418 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1423 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1425 static char *empty_string
[0];
1427 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1430 /* Strings of zero length can have p == NULL, which confuses the
1431 transfer routines into thinking we need more data elements. To avoid
1432 this, we give them a nice pointer. */
1433 if (len
== 0 && p
== NULL
)
1436 /* Currently we support only 1 byte chars, and the library is a bit
1437 confused of character kind vs. length, so we kludge it by setting
1439 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1444 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1447 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1449 size
= size_from_complex_kind (kind
);
1450 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1455 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1456 gfc_charlen_type charlen
)
1458 index_type count
[GFC_MAX_DIMENSIONS
];
1459 index_type extent
[GFC_MAX_DIMENSIONS
];
1460 index_type stride
[GFC_MAX_DIMENSIONS
];
1461 index_type stride0
, rank
, size
, type
, n
;
1466 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1469 type
= GFC_DESCRIPTOR_TYPE (desc
);
1470 size
= GFC_DESCRIPTOR_SIZE (desc
);
1472 /* FIXME: What a kludge: Array descriptors and the IO library use
1473 different enums for types. */
1476 case GFC_DTYPE_UNKNOWN
:
1477 iotype
= BT_NULL
; /* Is this correct? */
1479 case GFC_DTYPE_INTEGER
:
1480 iotype
= BT_INTEGER
;
1482 case GFC_DTYPE_LOGICAL
:
1483 iotype
= BT_LOGICAL
;
1485 case GFC_DTYPE_REAL
:
1488 case GFC_DTYPE_COMPLEX
:
1489 iotype
= BT_COMPLEX
;
1491 case GFC_DTYPE_CHARACTER
:
1492 iotype
= BT_CHARACTER
;
1493 /* FIXME: Currently dtype contains the charlen, which is
1494 clobbered if charlen > 2**24. That's why we use a separate
1495 argument for the charlen. However, if we want to support
1496 non-8-bit charsets we need to fix dtype to contain
1497 sizeof(chartype) and fix the code below. */
1501 case GFC_DTYPE_DERIVED
:
1502 internal_error (&dtp
->common
,
1503 "Derived type I/O should have been handled via the frontend.");
1506 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1509 rank
= GFC_DESCRIPTOR_RANK (desc
);
1510 for (n
= 0; n
< rank
; n
++)
1513 stride
[n
] = desc
->dim
[n
].stride
;
1514 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1516 /* If the extent of even one dimension is zero, then the entire
1517 array section contains zero elements, so we return after writing
1518 a zero array record. */
1523 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1528 stride0
= stride
[0];
1530 /* If the innermost dimension has stride 1, we can do the transfer
1531 in contiguous chunks. */
1537 data
= GFC_DESCRIPTOR_DATA (desc
);
1541 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1542 data
+= stride0
* size
* tsize
;
1545 while (count
[n
] == extent
[n
])
1548 data
-= stride
[n
] * extent
[n
] * size
;
1558 data
+= stride
[n
] * size
;
1565 /* Preposition a sequential unformatted file while reading. */
1568 us_read (st_parameter_dt
*dtp
, int continued
)
1577 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1580 if (compile_options
.record_marker
== 0)
1581 n
= sizeof (GFC_INTEGER_4
);
1583 n
= compile_options
.record_marker
;
1587 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1591 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1592 return; /* end of file */
1595 if (p
== NULL
|| n
!= nr
)
1597 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1601 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1602 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1606 case sizeof(GFC_INTEGER_4
):
1607 memcpy (&i4
, p
, sizeof (i4
));
1611 case sizeof(GFC_INTEGER_8
):
1612 memcpy (&i8
, p
, sizeof (i8
));
1617 runtime_error ("Illegal value for record marker");
1624 case sizeof(GFC_INTEGER_4
):
1625 reverse_memcpy (&i4
, p
, sizeof (i4
));
1629 case sizeof(GFC_INTEGER_8
):
1630 reverse_memcpy (&i8
, p
, sizeof (i8
));
1635 runtime_error ("Illegal value for record marker");
1641 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1642 dtp
->u
.p
.current_unit
->continued
= 0;
1646 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1647 dtp
->u
.p
.current_unit
->continued
= 1;
1651 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1655 /* Preposition a sequential unformatted file while writing. This
1656 amount to writing a bogus length that will be filled in later. */
1659 us_write (st_parameter_dt
*dtp
, int continued
)
1666 if (compile_options
.record_marker
== 0)
1667 nbytes
= sizeof (GFC_INTEGER_4
);
1669 nbytes
= compile_options
.record_marker
;
1671 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1672 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1674 /* For sequential unformatted, if RECL= was not specified in the OPEN
1675 we write until we have more bytes than can fit in the subrecord
1676 markers, then we write a new subrecord. */
1678 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1679 dtp
->u
.p
.current_unit
->recl_subrecord
;
1680 dtp
->u
.p
.current_unit
->continued
= continued
;
1684 /* Position to the next record prior to transfer. We are assumed to
1685 be before the next record. We also calculate the bytes in the next
1689 pre_position (st_parameter_dt
*dtp
)
1691 if (dtp
->u
.p
.current_unit
->current_record
)
1692 return; /* Already positioned. */
1694 switch (current_mode (dtp
))
1696 case FORMATTED_STREAM
:
1697 case UNFORMATTED_STREAM
:
1698 /* There are no records with stream I/O. Set the default position
1699 to the beginning of the file if no position was specified. */
1700 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1701 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1704 case UNFORMATTED_SEQUENTIAL
:
1705 if (dtp
->u
.p
.mode
== READING
)
1712 case FORMATTED_SEQUENTIAL
:
1713 case FORMATTED_DIRECT
:
1714 case UNFORMATTED_DIRECT
:
1715 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1719 dtp
->u
.p
.current_unit
->current_record
= 1;
1723 /* Initialize things for a data transfer. This code is common for
1724 both reading and writing. */
1727 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1729 unit_flags u_flags
; /* Used for creating a unit if needed. */
1730 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1731 namelist_info
*ionml
;
1733 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1734 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1735 dtp
->u
.p
.ionml
= ionml
;
1736 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1738 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1741 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1742 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1744 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1745 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1746 { /* Open the unit with some default flags. */
1747 st_parameter_open opp
;
1750 if (dtp
->common
.unit
< 0)
1752 close_unit (dtp
->u
.p
.current_unit
);
1753 dtp
->u
.p
.current_unit
= NULL
;
1754 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1755 "Bad unit number in OPEN statement");
1758 memset (&u_flags
, '\0', sizeof (u_flags
));
1759 u_flags
.access
= ACCESS_SEQUENTIAL
;
1760 u_flags
.action
= ACTION_READWRITE
;
1762 /* Is it unformatted? */
1763 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1764 | IOPARM_DT_IONML_SET
)))
1765 u_flags
.form
= FORM_UNFORMATTED
;
1767 u_flags
.form
= FORM_UNSPECIFIED
;
1769 u_flags
.delim
= DELIM_UNSPECIFIED
;
1770 u_flags
.blank
= BLANK_UNSPECIFIED
;
1771 u_flags
.pad
= PAD_UNSPECIFIED
;
1772 u_flags
.status
= STATUS_UNKNOWN
;
1774 conv
= get_unformatted_convert (dtp
->common
.unit
);
1776 if (conv
== GFC_CONVERT_NONE
)
1777 conv
= compile_options
.convert
;
1779 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1780 and 1 on big-endian machines. */
1783 case GFC_CONVERT_NATIVE
:
1784 case GFC_CONVERT_SWAP
:
1787 case GFC_CONVERT_BIG
:
1788 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1791 case GFC_CONVERT_LITTLE
:
1792 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1796 internal_error (&opp
.common
, "Illegal value for CONVERT");
1800 u_flags
.convert
= conv
;
1802 opp
.common
= dtp
->common
;
1803 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1804 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1805 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1806 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1807 if (dtp
->u
.p
.current_unit
== NULL
)
1811 /* Check the action. */
1813 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1815 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1816 "Cannot read from file opened for WRITE");
1820 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1822 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1823 "Cannot write to file opened for READ");
1827 dtp
->u
.p
.first_item
= 1;
1829 /* Check the format. */
1831 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1834 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1835 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1838 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1839 "Format present for UNFORMATTED data transfer");
1843 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1845 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1846 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1847 "A format cannot be specified with a namelist");
1849 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1850 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1852 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1853 "Missing format for FORMATTED data transfer");
1856 if (is_internal_unit (dtp
)
1857 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1859 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1860 "Internal file cannot be accessed by UNFORMATTED "
1865 /* Check the record or position number. */
1867 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1868 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1870 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1871 "Direct access data transfer requires record number");
1875 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1876 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1878 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1879 "Record number not allowed for sequential access data transfer");
1883 /* Process the ADVANCE option. */
1885 dtp
->u
.p
.advance_status
1886 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1887 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1888 "Bad ADVANCE parameter in data transfer statement");
1890 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1892 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1894 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1895 "ADVANCE specification conflicts with sequential access");
1899 if (is_internal_unit (dtp
))
1901 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1902 "ADVANCE specification conflicts with internal file");
1906 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1907 != IOPARM_DT_HAS_FORMAT
)
1909 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1910 "ADVANCE specification requires an explicit format");
1917 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1919 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1921 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1922 "EOR specification requires an ADVANCE specification "
1927 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1929 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1930 "SIZE specification requires an ADVANCE specification of NO");
1935 { /* Write constraints. */
1936 if ((cf
& IOPARM_END
) != 0)
1938 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1939 "END specification cannot appear in a write statement");
1943 if ((cf
& IOPARM_EOR
) != 0)
1945 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1946 "EOR specification cannot appear in a write statement");
1950 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1952 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1953 "SIZE specification cannot appear in a write statement");
1958 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1959 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1961 /* Sanity checks on the record number. */
1962 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1966 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1967 "Record number must be positive");
1971 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1973 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1974 "Record number too large");
1978 /* Check to see if we might be reading what we wrote before */
1980 if (dtp
->u
.p
.mode
== READING
1981 && dtp
->u
.p
.current_unit
->mode
== WRITING
1982 && !is_internal_unit (dtp
))
1983 flush(dtp
->u
.p
.current_unit
->s
);
1985 /* Check whether the record exists to be read. Only
1986 a partial record needs to exist. */
1988 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
- 1)
1989 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1991 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1992 "Non-existing record number");
1996 /* Position the file. */
1997 if (!is_stream_io (dtp
))
1999 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2000 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2002 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2007 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2013 /* Overwriting an existing sequential file ?
2014 it is always safe to truncate the file on the first write */
2015 if (dtp
->u
.p
.mode
== WRITING
2016 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2017 && dtp
->u
.p
.current_unit
->last_record
== 0
2018 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2019 struncate(dtp
->u
.p
.current_unit
->s
);
2021 /* Bugware for badly written mixed C-Fortran I/O. */
2022 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2024 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2026 /* Set the initial value of flags. */
2028 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2029 dtp
->u
.p
.sign_status
= SIGN_S
;
2031 /* Set the maximum position reached from the previous I/O operation. This
2032 could be greater than zero from a previous non-advancing write. */
2033 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2037 /* Set up the subroutine that will handle the transfers. */
2041 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2042 dtp
->u
.p
.transfer
= unformatted_read
;
2045 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2046 dtp
->u
.p
.transfer
= list_formatted_read
;
2048 dtp
->u
.p
.transfer
= formatted_transfer
;
2053 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2054 dtp
->u
.p
.transfer
= unformatted_write
;
2057 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2058 dtp
->u
.p
.transfer
= list_formatted_write
;
2060 dtp
->u
.p
.transfer
= formatted_transfer
;
2064 /* Make sure that we don't do a read after a nonadvancing write. */
2068 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2070 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2071 "Cannot READ after a nonadvancing WRITE");
2077 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2078 dtp
->u
.p
.current_unit
->read_bad
= 1;
2081 /* Start the data transfer if we are doing a formatted transfer. */
2082 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2083 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2084 && dtp
->u
.p
.ionml
== NULL
)
2085 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2088 /* Initialize an array_loop_spec given the array descriptor. The function
2089 returns the index of the last element of the array, and also returns
2090 starting record, where the first I/O goes to (necessary in case of
2091 negative strides). */
2094 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2095 gfc_offset
*start_record
)
2097 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2106 for (i
=0; i
<rank
; i
++)
2108 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2109 ls
[i
].start
= desc
->dim
[i
].lbound
;
2110 ls
[i
].end
= desc
->dim
[i
].ubound
;
2111 ls
[i
].step
= desc
->dim
[i
].stride
;
2112 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2114 if (desc
->dim
[i
].stride
> 0)
2116 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2117 * desc
->dim
[i
].stride
;
2121 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2122 * desc
->dim
[i
].stride
;
2123 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2124 * desc
->dim
[i
].stride
;
2134 /* Determine the index to the next record in an internal unit array by
2135 by incrementing through the array_loop_spec. */
2138 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2146 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2151 if (ls
[i
].idx
> ls
[i
].end
)
2153 ls
[i
].idx
= ls
[i
].start
;
2159 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2169 /* Skip to the end of the current record, taking care of an optional
2170 record marker of size bytes. If the file is not seekable, we
2171 read chunks of size MAX_READ until we get to the right
2174 #define MAX_READ 4096
2177 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2180 int rlength
, length
;
2183 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2184 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2187 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2189 new = file_position (dtp
->u
.p
.current_unit
->s
)
2190 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2192 /* Direct access files do not generate END conditions,
2194 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2195 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2198 { /* Seek by reading data. */
2199 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2202 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2203 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2205 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2208 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2212 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2220 /* Advance to the next record reading unformatted files, taking
2221 care of subrecords. If complete_record is nonzero, we loop
2222 until all subrecords are cleared. */
2225 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2229 bytes
= compile_options
.record_marker
== 0 ?
2230 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2235 /* Skip over tail */
2237 skip_record (dtp
, bytes
);
2239 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2246 /* Space to the next record for read mode. */
2249 next_record_r (st_parameter_dt
*dtp
)
2252 int length
, bytes_left
;
2255 switch (current_mode (dtp
))
2257 /* No records in unformatted STREAM I/O. */
2258 case UNFORMATTED_STREAM
:
2261 case UNFORMATTED_SEQUENTIAL
:
2262 next_record_r_unf (dtp
, 1);
2263 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2266 case FORMATTED_DIRECT
:
2267 case UNFORMATTED_DIRECT
:
2268 skip_record (dtp
, 0);
2271 case FORMATTED_STREAM
:
2272 case FORMATTED_SEQUENTIAL
:
2274 /* sf_read has already terminated input because of an '\n' */
2275 if (dtp
->u
.p
.sf_seen_eor
)
2277 dtp
->u
.p
.sf_seen_eor
= 0;
2281 if (is_internal_unit (dtp
))
2283 if (is_array_io (dtp
))
2287 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2290 /* Now seek to this record. */
2291 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2292 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2294 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2297 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2301 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2302 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2304 dtp
->u
.p
.current_unit
->bytes_left
2305 = dtp
->u
.p
.current_unit
->recl
;
2311 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2315 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2321 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2325 if (is_stream_io (dtp
))
2326 dtp
->u
.p
.current_unit
->strm_pos
++;
2333 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2334 && !dtp
->u
.p
.namelist_mode
2335 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2336 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2337 file_position (dtp
->u
.p
.current_unit
->s
)))
2338 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2343 /* Small utility function to write a record marker, taking care of
2344 byte swapping and of choosing the correct size. */
2347 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2352 char p
[sizeof (GFC_INTEGER_8
)];
2354 if (compile_options
.record_marker
== 0)
2355 len
= sizeof (GFC_INTEGER_4
);
2357 len
= compile_options
.record_marker
;
2359 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2360 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2364 case sizeof (GFC_INTEGER_4
):
2366 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2369 case sizeof (GFC_INTEGER_8
):
2371 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2375 runtime_error ("Illegal value for record marker");
2383 case sizeof (GFC_INTEGER_4
):
2385 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2386 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2389 case sizeof (GFC_INTEGER_8
):
2391 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2392 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2396 runtime_error ("Illegal value for record marker");
2403 /* Position to the next (sub)record in write mode for
2404 unformatted sequential files. */
2407 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2409 gfc_offset c
, m
, m_write
;
2410 size_t record_marker
;
2412 /* Bytes written. */
2413 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2414 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2415 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2417 /* Write the length tail. If we finish a record containing
2418 subrecords, we write out the negative length. */
2420 if (dtp
->u
.p
.current_unit
->continued
)
2425 if (write_us_marker (dtp
, m_write
) != 0)
2428 if (compile_options
.record_marker
== 0)
2429 record_marker
= sizeof (GFC_INTEGER_4
);
2431 record_marker
= compile_options
.record_marker
;
2433 /* Seek to the head and overwrite the bogus length with the real
2436 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2445 if (write_us_marker (dtp
, m_write
) != 0)
2448 /* Seek past the end of the current record. */
2450 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2456 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2461 /* Position to the next record in write mode. */
2464 next_record_w (st_parameter_dt
*dtp
, int done
)
2466 gfc_offset m
, record
, max_pos
;
2470 /* Zero counters for X- and T-editing. */
2471 max_pos
= dtp
->u
.p
.max_pos
;
2472 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2474 switch (current_mode (dtp
))
2476 /* No records in unformatted STREAM I/O. */
2477 case UNFORMATTED_STREAM
:
2480 case FORMATTED_DIRECT
:
2481 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2484 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2485 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2490 case UNFORMATTED_DIRECT
:
2491 if (dtp
->u
.p
.current_unit
->bytes_left
> 0)
2493 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2494 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2495 memset (p
, 0, length
);
2498 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2502 case UNFORMATTED_SEQUENTIAL
:
2503 next_record_w_unf (dtp
, 0);
2504 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2507 case FORMATTED_STREAM
:
2508 case FORMATTED_SEQUENTIAL
:
2510 if (is_internal_unit (dtp
))
2512 if (is_array_io (dtp
))
2516 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2518 /* If the farthest position reached is greater than current
2519 position, adjust the position and set length to pad out
2520 whats left. Otherwise just pad whats left.
2521 (for character array unit) */
2522 m
= dtp
->u
.p
.current_unit
->recl
2523 - dtp
->u
.p
.current_unit
->bytes_left
;
2526 length
= (int) (max_pos
- m
);
2527 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2528 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2531 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2533 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2537 /* Now that the current record has been padded out,
2538 determine where the next record in the array is. */
2539 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2542 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2544 /* Now seek to this record */
2545 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2547 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2549 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2553 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2559 /* If this is the last call to next_record move to the farthest
2560 position reached and set length to pad out the remainder
2561 of the record. (for character scaler unit) */
2564 m
= dtp
->u
.p
.current_unit
->recl
2565 - dtp
->u
.p
.current_unit
->bytes_left
;
2568 length
= (int) (max_pos
- m
);
2569 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2570 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2573 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2576 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2578 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2586 const char crlf
[] = "\r\n";
2588 /* Move to the farthest position reached in preparation for
2589 completing the record. (for file unit) */
2590 m
= dtp
->u
.p
.current_unit
->recl
-
2591 dtp
->u
.p
.current_unit
->bytes_left
;
2594 length
= (int) (max_pos
- m
);
2595 sseek (dtp
->u
.p
.current_unit
->s
,
2596 file_position (dtp
->u
.p
.current_unit
->s
) + length
);
2603 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2606 if (is_stream_io (dtp
))
2608 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2609 if (dtp
->u
.p
.current_unit
->strm_pos
2610 < file_length (dtp
->u
.p
.current_unit
->s
))
2611 struncate (dtp
->u
.p
.current_unit
->s
);
2618 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2623 /* Position to the next record, which means moving to the end of the
2624 current record. This can happen under several different
2625 conditions. If the done flag is not set, we get ready to process
2629 next_record (st_parameter_dt
*dtp
, int done
)
2631 gfc_offset fp
; /* File position. */
2633 dtp
->u
.p
.current_unit
->read_bad
= 0;
2635 if (dtp
->u
.p
.mode
== READING
)
2636 next_record_r (dtp
);
2638 next_record_w (dtp
, done
);
2640 if (!is_stream_io (dtp
))
2642 /* Keep position up to date for INQUIRE */
2644 update_position (dtp
->u
.p
.current_unit
);
2646 dtp
->u
.p
.current_unit
->current_record
= 0;
2647 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2649 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2650 /* Calculate next record, rounding up partial records. */
2651 dtp
->u
.p
.current_unit
->last_record
=
2652 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2653 dtp
->u
.p
.current_unit
->recl
;
2656 dtp
->u
.p
.current_unit
->last_record
++;
2664 /* Finalize the current data transfer. For a nonadvancing transfer,
2665 this means advancing to the next record. For internal units close the
2666 stream associated with the unit. */
2669 finalize_transfer (st_parameter_dt
*dtp
)
2672 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2674 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2675 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2677 if (dtp
->u
.p
.eor_condition
)
2679 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2683 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2686 if ((dtp
->u
.p
.ionml
!= NULL
)
2687 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2689 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2690 namelist_read (dtp
);
2692 namelist_write (dtp
);
2695 dtp
->u
.p
.transfer
= NULL
;
2696 if (dtp
->u
.p
.current_unit
== NULL
)
2699 dtp
->u
.p
.eof_jump
= &eof_jump
;
2700 if (setjmp (eof_jump
))
2702 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2706 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2708 finish_list_read (dtp
);
2709 sfree (dtp
->u
.p
.current_unit
->s
);
2713 if (dtp
->u
.p
.mode
== WRITING
)
2714 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2715 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2717 if (is_stream_io (dtp
))
2719 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2720 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2721 next_record (dtp
, 1);
2723 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2724 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2726 flush (dtp
->u
.p
.current_unit
->s
);
2727 sfree (dtp
->u
.p
.current_unit
->s
);
2732 dtp
->u
.p
.current_unit
->current_record
= 0;
2734 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2736 dtp
->u
.p
.seen_dollar
= 0;
2737 sfree (dtp
->u
.p
.current_unit
->s
);
2741 /* For non-advancing I/O, save the current maximum position for use in the
2742 next I/O operation if needed. */
2743 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2745 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2746 - dtp
->u
.p
.current_unit
->bytes_left
);
2747 dtp
->u
.p
.current_unit
->saved_pos
=
2748 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2749 flush (dtp
->u
.p
.current_unit
->s
);
2753 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2755 next_record (dtp
, 1);
2756 sfree (dtp
->u
.p
.current_unit
->s
);
2759 /* Transfer function for IOLENGTH. It doesn't actually do any
2760 data transfer, it just updates the length counter. */
2763 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2764 void *dest
__attribute__ ((unused
)),
2765 int kind
__attribute__((unused
)),
2766 size_t size
, size_t nelems
)
2768 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2769 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2773 /* Initialize the IOLENGTH data transfer. This function is in essence
2774 a very much simplified version of data_transfer_init(), because it
2775 doesn't have to deal with units at all. */
2778 iolength_transfer_init (st_parameter_dt
*dtp
)
2780 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2783 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2785 /* Set up the subroutine that will handle the transfers. */
2787 dtp
->u
.p
.transfer
= iolength_transfer
;
2791 /* Library entry point for the IOLENGTH form of the INQUIRE
2792 statement. The IOLENGTH form requires no I/O to be performed, but
2793 it must still be a runtime library call so that we can determine
2794 the iolength for dynamic arrays and such. */
2796 extern void st_iolength (st_parameter_dt
*);
2797 export_proto(st_iolength
);
2800 st_iolength (st_parameter_dt
*dtp
)
2802 library_start (&dtp
->common
);
2803 iolength_transfer_init (dtp
);
2806 extern void st_iolength_done (st_parameter_dt
*);
2807 export_proto(st_iolength_done
);
2810 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2813 if (dtp
->u
.p
.scratch
!= NULL
)
2814 free_mem (dtp
->u
.p
.scratch
);
2819 /* The READ statement. */
2821 extern void st_read (st_parameter_dt
*);
2822 export_proto(st_read
);
2825 st_read (st_parameter_dt
*dtp
)
2827 library_start (&dtp
->common
);
2829 data_transfer_init (dtp
, 1);
2831 /* Handle complications dealing with the endfile record. */
2833 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2834 switch (dtp
->u
.p
.current_unit
->endfile
)
2840 if (!is_internal_unit (dtp
))
2842 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2843 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2844 dtp
->u
.p
.current_unit
->current_record
= 0;
2849 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2850 dtp
->u
.p
.current_unit
->current_record
= 0;
2855 extern void st_read_done (st_parameter_dt
*);
2856 export_proto(st_read_done
);
2859 st_read_done (st_parameter_dt
*dtp
)
2861 finalize_transfer (dtp
);
2862 free_format_data (dtp
);
2864 if (dtp
->u
.p
.scratch
!= NULL
)
2865 free_mem (dtp
->u
.p
.scratch
);
2866 if (dtp
->u
.p
.current_unit
!= NULL
)
2867 unlock_unit (dtp
->u
.p
.current_unit
);
2869 free_internal_unit (dtp
);
2874 extern void st_write (st_parameter_dt
*);
2875 export_proto(st_write
);
2878 st_write (st_parameter_dt
*dtp
)
2880 library_start (&dtp
->common
);
2881 data_transfer_init (dtp
, 0);
2884 extern void st_write_done (st_parameter_dt
*);
2885 export_proto(st_write_done
);
2888 st_write_done (st_parameter_dt
*dtp
)
2890 finalize_transfer (dtp
);
2892 /* Deal with endfile conditions associated with sequential files. */
2894 if (dtp
->u
.p
.current_unit
!= NULL
2895 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2896 switch (dtp
->u
.p
.current_unit
->endfile
)
2898 case AT_ENDFILE
: /* Remain at the endfile record. */
2902 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2906 /* Get rid of whatever is after this record. */
2907 if (!is_internal_unit (dtp
))
2909 flush (dtp
->u
.p
.current_unit
->s
);
2910 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2911 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2913 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2917 free_format_data (dtp
);
2919 if (dtp
->u
.p
.scratch
!= NULL
)
2920 free_mem (dtp
->u
.p
.scratch
);
2921 if (dtp
->u
.p
.current_unit
!= NULL
)
2922 unlock_unit (dtp
->u
.p
.current_unit
);
2924 free_internal_unit (dtp
);
2929 /* Receives the scalar information for namelist objects and stores it
2930 in a linked list of namelist_info types. */
2932 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2933 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2934 export_proto(st_set_nml_var
);
2938 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2939 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2940 GFC_INTEGER_4 dtype
)
2942 namelist_info
*t1
= NULL
;
2944 size_t var_name_len
= strlen (var_name
);
2946 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2948 nml
->mem_pos
= var_addr
;
2950 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2951 memcpy (nml
->var_name
, var_name
, var_name_len
);
2952 nml
->var_name
[var_name_len
] = '\0';
2954 nml
->len
= (int) len
;
2955 nml
->string_length
= (index_type
) string_length
;
2957 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2958 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2959 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2961 if (nml
->var_rank
> 0)
2963 nml
->dim
= (descriptor_dimension
*)
2964 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2965 nml
->ls
= (array_loop_spec
*)
2966 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2976 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2978 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2979 dtp
->u
.p
.ionml
= nml
;
2983 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2988 /* Store the dimensional information for the namelist object. */
2989 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2990 index_type
, index_type
,
2992 export_proto(st_set_nml_var_dim
);
2995 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2996 index_type stride
, index_type lbound
,
2999 namelist_info
* nml
;
3004 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3006 nml
->dim
[n
].stride
= stride
;
3007 nml
->dim
[n
].lbound
= lbound
;
3008 nml
->dim
[n
].ubound
= ubound
;
3011 /* Reverse memcpy - used for byte swapping. */
3013 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3019 s
= (char *) src
+ n
- 1;
3021 /* Write with ascending order - this is likely faster
3022 on modern architectures because of write combining. */