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 p
= write_block (dtp
, dtp
->u
.p
.current_unit
->recl
);
645 memset (p
, 0, dtp
->u
.p
.current_unit
->recl
);
649 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
651 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
655 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
656 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
661 /* Unformatted sequential. */
665 if (dtp
->u
.p
.current_unit
->flags
.has_recl
666 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
668 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
680 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
681 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
683 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
684 (gfc_offset
) to_write_subrecord
;
686 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
687 &to_write_subrecord
) != 0)
689 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
693 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
694 nbytes
-= to_write_subrecord
;
695 have_written
+= to_write_subrecord
;
700 next_record_w_unf (dtp
, 1);
703 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
706 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
713 /* Master function for unformatted reads. */
716 unformatted_read (st_parameter_dt
*dtp
, bt type
,
717 void *dest
, int kind
__attribute__((unused
)),
718 size_t size
, size_t nelems
)
722 /* Currently, character implies size=1. */
723 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
724 || size
== 1 || type
== BT_CHARACTER
)
727 read_block_direct (dtp
, dest
, &sz
);
734 /* Break up complex into its constituent reals. */
735 if (type
== BT_COMPLEX
)
742 /* By now, all complex variables have been split into their
743 constituent reals. */
745 for (i
=0; i
<nelems
; i
++)
747 read_block_direct (dtp
, buffer
, &size
);
748 reverse_memcpy (p
, buffer
, size
);
755 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
756 bytes on 64 bit machines. The unused bytes are not initialized and never
757 used, which can show an error with memory checking analyzers like
761 unformatted_write (st_parameter_dt
*dtp
, bt type
,
762 void *source
, int kind
__attribute__((unused
)),
763 size_t size
, size_t nelems
)
765 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
766 size
== 1 || type
== BT_CHARACTER
)
769 write_buf (dtp
, source
, size
);
777 /* Break up complex into its constituent reals. */
778 if (type
== BT_COMPLEX
)
786 /* By now, all complex variables have been split into their
787 constituent reals. */
790 for (i
=0; i
<nelems
; i
++)
792 reverse_memcpy(buffer
, p
, size
);
794 write_buf (dtp
, buffer
, size
);
800 /* Return a pointer to the name of a type. */
825 internal_error (NULL
, "type_name(): Bad type");
832 /* Write a constant string to the output.
833 This is complicated because the string can have doubled delimiters
834 in it. The length in the format node is the true length. */
837 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
839 char c
, delimiter
, *p
, *q
;
842 length
= f
->u
.string
.length
;
846 p
= write_block (dtp
, length
);
853 for (; length
> 0; length
--)
856 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
857 q
++; /* Skip the doubled delimiter. */
862 /* Given actual and expected types in a formatted data transfer, make
863 sure they agree. If not, an error message is generated. Returns
864 nonzero if something went wrong. */
867 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
871 if (actual
== expected
)
874 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
875 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
877 format_error (dtp
, f
, buffer
);
882 /* This subroutine is the main loop for a formatted data transfer
883 statement. It would be natural to implement this as a coroutine
884 with the user program, but C makes that awkward. We loop,
885 processing format elements. When we actually have to transfer
886 data instead of just setting flags, we return control to the user
887 program which calls a subroutine that supplies the address and type
888 of the next element, then comes back here to process it. */
891 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
894 char scratch
[SCRATCH_SIZE
];
899 int consume_data_flag
;
901 /* Change a complex data item into a pair of reals. */
903 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
904 if (type
== BT_COMPLEX
)
910 /* If there's an EOR condition, we simulate finalizing the transfer
912 if (dtp
->u
.p
.eor_condition
)
915 /* Set this flag so that commas in reads cause the read to complete before
916 the entire field has been read. The next read field will start right after
917 the comma in the stream. (Set to 0 for character reads). */
918 dtp
->u
.p
.sf_read_comma
= 1;
919 dtp
->u
.p
.line_buffer
= scratch
;
923 /* If reversion has occurred and there is another real data item,
924 then we have to move to the next record. */
925 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
927 dtp
->u
.p
.reversion_flag
= 0;
928 next_record (dtp
, 0);
931 consume_data_flag
= 1 ;
932 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
935 f
= next_format (dtp
);
938 /* No data descriptors left. */
940 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
941 "Insufficient data descriptors in format after reversion");
945 /* Now discharge T, TR and X movements to the right. This is delayed
946 until a data producing format to suppress trailing spaces. */
949 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
950 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
951 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
952 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
953 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
956 if (dtp
->u
.p
.skips
> 0)
959 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
960 tmp
= (int)(dtp
->u
.p
.current_unit
->recl
961 - dtp
->u
.p
.current_unit
->bytes_left
);
963 dtp
->u
.p
.max_pos
> tmp
? dtp
->u
.p
.max_pos
: tmp
;
965 if (dtp
->u
.p
.skips
< 0)
967 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
968 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
970 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
973 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
974 - dtp
->u
.p
.current_unit
->bytes_left
);
976 if (is_stream_io(dtp
))
984 if (require_type (dtp
, BT_INTEGER
, type
, f
))
987 if (dtp
->u
.p
.mode
== READING
)
988 read_decimal (dtp
, f
, p
, len
);
990 write_i (dtp
, f
, p
, len
);
998 if (compile_options
.allow_std
< GFC_STD_GNU
999 && require_type (dtp
, BT_INTEGER
, type
, f
))
1002 if (dtp
->u
.p
.mode
== READING
)
1003 read_radix (dtp
, f
, p
, len
, 2);
1005 write_b (dtp
, f
, p
, len
);
1013 if (compile_options
.allow_std
< GFC_STD_GNU
1014 && require_type (dtp
, BT_INTEGER
, type
, f
))
1017 if (dtp
->u
.p
.mode
== READING
)
1018 read_radix (dtp
, f
, p
, len
, 8);
1020 write_o (dtp
, f
, p
, len
);
1028 if (compile_options
.allow_std
< GFC_STD_GNU
1029 && require_type (dtp
, BT_INTEGER
, type
, f
))
1032 if (dtp
->u
.p
.mode
== READING
)
1033 read_radix (dtp
, f
, p
, len
, 16);
1035 write_z (dtp
, f
, p
, len
);
1043 if (dtp
->u
.p
.mode
== READING
)
1044 read_a (dtp
, f
, p
, len
);
1046 write_a (dtp
, f
, p
, len
);
1054 if (dtp
->u
.p
.mode
== READING
)
1055 read_l (dtp
, f
, p
, len
);
1057 write_l (dtp
, f
, p
, len
);
1064 if (require_type (dtp
, BT_REAL
, type
, f
))
1067 if (dtp
->u
.p
.mode
== READING
)
1068 read_f (dtp
, f
, p
, len
);
1070 write_d (dtp
, f
, p
, len
);
1077 if (require_type (dtp
, BT_REAL
, type
, f
))
1080 if (dtp
->u
.p
.mode
== READING
)
1081 read_f (dtp
, f
, p
, len
);
1083 write_e (dtp
, f
, p
, len
);
1089 if (require_type (dtp
, BT_REAL
, type
, f
))
1092 if (dtp
->u
.p
.mode
== READING
)
1093 read_f (dtp
, f
, p
, len
);
1095 write_en (dtp
, f
, p
, len
);
1102 if (require_type (dtp
, BT_REAL
, type
, f
))
1105 if (dtp
->u
.p
.mode
== READING
)
1106 read_f (dtp
, f
, p
, len
);
1108 write_es (dtp
, f
, p
, len
);
1115 if (require_type (dtp
, BT_REAL
, type
, f
))
1118 if (dtp
->u
.p
.mode
== READING
)
1119 read_f (dtp
, f
, p
, len
);
1121 write_f (dtp
, f
, p
, len
);
1128 if (dtp
->u
.p
.mode
== READING
)
1132 read_decimal (dtp
, f
, p
, len
);
1135 read_l (dtp
, f
, p
, len
);
1138 read_a (dtp
, f
, p
, len
);
1141 read_f (dtp
, f
, p
, len
);
1150 write_i (dtp
, f
, p
, len
);
1153 write_l (dtp
, f
, p
, len
);
1156 write_a (dtp
, f
, p
, len
);
1159 write_d (dtp
, f
, p
, len
);
1163 internal_error (&dtp
->common
,
1164 "formatted_transfer(): Bad type");
1170 consume_data_flag
= 0 ;
1171 if (dtp
->u
.p
.mode
== READING
)
1173 format_error (dtp
, f
, "Constant string in input format");
1176 write_constant_string (dtp
, f
);
1179 /* Format codes that don't transfer data. */
1182 consume_data_flag
= 0;
1184 dtp
->u
.p
.skips
+= f
->u
.n
;
1185 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1186 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1188 /* Writes occur just before the switch on f->format, above, so
1189 that trailing blanks are suppressed, unless we are doing a
1190 non-advancing write in which case we want to output the blanks
1192 if (dtp
->u
.p
.mode
== WRITING
1193 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1195 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1196 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1199 if (dtp
->u
.p
.mode
== READING
)
1200 read_x (dtp
, f
->u
.n
);
1206 consume_data_flag
= 0;
1208 if (f
->format
== FMT_TL
)
1211 /* Handle the special case when no bytes have been used yet.
1212 Cannot go below zero. */
1213 if (bytes_used
== 0)
1215 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1216 dtp
->u
.p
.skips
-= f
->u
.n
;
1217 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1220 pos
= bytes_used
- f
->u
.n
;
1224 if (dtp
->u
.p
.mode
== READING
)
1227 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1230 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1231 left tab limit. We do not check if the position has gone
1232 beyond the end of record because a subsequent tab could
1233 bring us back again. */
1234 pos
= pos
< 0 ? 0 : pos
;
1236 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1237 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1238 + pos
- dtp
->u
.p
.max_pos
;
1239 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1240 ? 0 : dtp
->u
.p
.pending_spaces
;
1242 if (dtp
->u
.p
.skips
== 0)
1245 /* Writes occur just before the switch on f->format, above, so that
1246 trailing blanks are suppressed. */
1247 if (dtp
->u
.p
.mode
== READING
)
1249 /* Adjust everything for end-of-record condition */
1250 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1252 if (dtp
->u
.p
.sf_seen_eor
== 2)
1254 /* The EOR was a CRLF (two bytes wide). */
1255 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1256 dtp
->u
.p
.skips
-= 2;
1260 /* The EOR marker was only one byte wide. */
1261 dtp
->u
.p
.current_unit
->bytes_left
--;
1265 dtp
->u
.p
.sf_seen_eor
= 0;
1267 if (dtp
->u
.p
.skips
< 0)
1269 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1270 dtp
->u
.p
.current_unit
->bytes_left
1271 -= (gfc_offset
) dtp
->u
.p
.skips
;
1272 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1275 read_x (dtp
, dtp
->u
.p
.skips
);
1279 if (dtp
->u
.p
.skips
< 0)
1280 flush (dtp
->u
.p
.current_unit
->s
);
1286 consume_data_flag
= 0 ;
1287 dtp
->u
.p
.sign_status
= SIGN_S
;
1291 consume_data_flag
= 0 ;
1292 dtp
->u
.p
.sign_status
= SIGN_SS
;
1296 consume_data_flag
= 0 ;
1297 dtp
->u
.p
.sign_status
= SIGN_SP
;
1301 consume_data_flag
= 0 ;
1302 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1306 consume_data_flag
= 0 ;
1307 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1311 consume_data_flag
= 0 ;
1312 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1316 consume_data_flag
= 0 ;
1317 dtp
->u
.p
.seen_dollar
= 1;
1321 consume_data_flag
= 0 ;
1322 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1323 next_record (dtp
, 0);
1327 /* A colon descriptor causes us to exit this loop (in
1328 particular preventing another / descriptor from being
1329 processed) unless there is another data item to be
1331 consume_data_flag
= 0 ;
1337 internal_error (&dtp
->common
, "Bad format node");
1340 /* Free a buffer that we had to allocate during a sequential
1341 formatted read of a block that was larger than the static
1344 if (dtp
->u
.p
.line_buffer
!= scratch
)
1346 free_mem (dtp
->u
.p
.line_buffer
);
1347 dtp
->u
.p
.line_buffer
= scratch
;
1350 /* Adjust the item count and data pointer. */
1352 if ((consume_data_flag
> 0) && (n
> 0))
1355 p
= ((char *) p
) + size
;
1358 if (dtp
->u
.p
.mode
== READING
)
1361 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1362 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1368 /* Come here when we need a data descriptor but don't have one. We
1369 push the current format node back onto the input, then return and
1370 let the user program call us back with the data. */
1372 unget_format (dtp
, f
);
1376 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1377 size_t size
, size_t nelems
)
1384 /* Big loop over all the elements. */
1385 for (elem
= 0; elem
< nelems
; elem
++)
1387 dtp
->u
.p
.item_count
++;
1388 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1394 /* Data transfer entry points. The type of the data entity is
1395 implicit in the subroutine call. This prevents us from having to
1396 share a common enum with the compiler. */
1399 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1401 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1403 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1408 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1411 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1413 size
= size_from_real_kind (kind
);
1414 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1419 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1421 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1423 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1428 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1430 static char *empty_string
[0];
1432 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1435 /* Strings of zero length can have p == NULL, which confuses the
1436 transfer routines into thinking we need more data elements. To avoid
1437 this, we give them a nice pointer. */
1438 if (len
== 0 && p
== NULL
)
1441 /* Currently we support only 1 byte chars, and the library is a bit
1442 confused of character kind vs. length, so we kludge it by setting
1444 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1449 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1452 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1454 size
= size_from_complex_kind (kind
);
1455 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1460 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1461 gfc_charlen_type charlen
)
1463 index_type count
[GFC_MAX_DIMENSIONS
];
1464 index_type extent
[GFC_MAX_DIMENSIONS
];
1465 index_type stride
[GFC_MAX_DIMENSIONS
];
1466 index_type stride0
, rank
, size
, type
, n
;
1471 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1474 type
= GFC_DESCRIPTOR_TYPE (desc
);
1475 size
= GFC_DESCRIPTOR_SIZE (desc
);
1477 /* FIXME: What a kludge: Array descriptors and the IO library use
1478 different enums for types. */
1481 case GFC_DTYPE_UNKNOWN
:
1482 iotype
= BT_NULL
; /* Is this correct? */
1484 case GFC_DTYPE_INTEGER
:
1485 iotype
= BT_INTEGER
;
1487 case GFC_DTYPE_LOGICAL
:
1488 iotype
= BT_LOGICAL
;
1490 case GFC_DTYPE_REAL
:
1493 case GFC_DTYPE_COMPLEX
:
1494 iotype
= BT_COMPLEX
;
1496 case GFC_DTYPE_CHARACTER
:
1497 iotype
= BT_CHARACTER
;
1498 /* FIXME: Currently dtype contains the charlen, which is
1499 clobbered if charlen > 2**24. That's why we use a separate
1500 argument for the charlen. However, if we want to support
1501 non-8-bit charsets we need to fix dtype to contain
1502 sizeof(chartype) and fix the code below. */
1506 case GFC_DTYPE_DERIVED
:
1507 internal_error (&dtp
->common
,
1508 "Derived type I/O should have been handled via the frontend.");
1511 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1514 rank
= GFC_DESCRIPTOR_RANK (desc
);
1515 for (n
= 0; n
< rank
; n
++)
1518 stride
[n
] = desc
->dim
[n
].stride
;
1519 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1521 /* If the extent of even one dimension is zero, then the entire
1522 array section contains zero elements, so we return after writing
1523 a zero array record. */
1528 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1533 stride0
= stride
[0];
1535 /* If the innermost dimension has stride 1, we can do the transfer
1536 in contiguous chunks. */
1542 data
= GFC_DESCRIPTOR_DATA (desc
);
1546 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1547 data
+= stride0
* size
* tsize
;
1550 while (count
[n
] == extent
[n
])
1553 data
-= stride
[n
] * extent
[n
] * size
;
1563 data
+= stride
[n
] * size
;
1570 /* Preposition a sequential unformatted file while reading. */
1573 us_read (st_parameter_dt
*dtp
, int continued
)
1582 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1585 if (compile_options
.record_marker
== 0)
1586 n
= sizeof (GFC_INTEGER_4
);
1588 n
= compile_options
.record_marker
;
1592 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1596 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1597 return; /* end of file */
1600 if (p
== NULL
|| n
!= nr
)
1602 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1606 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1607 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1611 case sizeof(GFC_INTEGER_4
):
1612 memcpy (&i4
, p
, sizeof (i4
));
1616 case sizeof(GFC_INTEGER_8
):
1617 memcpy (&i8
, p
, sizeof (i8
));
1622 runtime_error ("Illegal value for record marker");
1629 case sizeof(GFC_INTEGER_4
):
1630 reverse_memcpy (&i4
, p
, sizeof (i4
));
1634 case sizeof(GFC_INTEGER_8
):
1635 reverse_memcpy (&i8
, p
, sizeof (i8
));
1640 runtime_error ("Illegal value for record marker");
1646 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1647 dtp
->u
.p
.current_unit
->continued
= 0;
1651 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1652 dtp
->u
.p
.current_unit
->continued
= 1;
1656 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1660 /* Preposition a sequential unformatted file while writing. This
1661 amount to writing a bogus length that will be filled in later. */
1664 us_write (st_parameter_dt
*dtp
, int continued
)
1671 if (compile_options
.record_marker
== 0)
1672 nbytes
= sizeof (GFC_INTEGER_4
);
1674 nbytes
= compile_options
.record_marker
;
1676 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1677 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1679 /* For sequential unformatted, if RECL= was not specified in the OPEN
1680 we write until we have more bytes than can fit in the subrecord
1681 markers, then we write a new subrecord. */
1683 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1684 dtp
->u
.p
.current_unit
->recl_subrecord
;
1685 dtp
->u
.p
.current_unit
->continued
= continued
;
1689 /* Position to the next record prior to transfer. We are assumed to
1690 be before the next record. We also calculate the bytes in the next
1694 pre_position (st_parameter_dt
*dtp
)
1696 if (dtp
->u
.p
.current_unit
->current_record
)
1697 return; /* Already positioned. */
1699 switch (current_mode (dtp
))
1701 case FORMATTED_STREAM
:
1702 case UNFORMATTED_STREAM
:
1703 /* There are no records with stream I/O. Set the default position
1704 to the beginning of the file if no position was specified. */
1705 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1706 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1709 case UNFORMATTED_SEQUENTIAL
:
1710 if (dtp
->u
.p
.mode
== READING
)
1717 case FORMATTED_SEQUENTIAL
:
1718 case FORMATTED_DIRECT
:
1719 case UNFORMATTED_DIRECT
:
1720 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1724 dtp
->u
.p
.current_unit
->current_record
= 1;
1728 /* Initialize things for a data transfer. This code is common for
1729 both reading and writing. */
1732 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1734 unit_flags u_flags
; /* Used for creating a unit if needed. */
1735 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1736 namelist_info
*ionml
;
1738 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1739 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1740 dtp
->u
.p
.ionml
= ionml
;
1741 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1743 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1746 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1747 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1749 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1750 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1751 { /* Open the unit with some default flags. */
1752 st_parameter_open opp
;
1755 if (dtp
->common
.unit
< 0)
1757 close_unit (dtp
->u
.p
.current_unit
);
1758 dtp
->u
.p
.current_unit
= NULL
;
1759 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1760 "Bad unit number in OPEN statement");
1763 memset (&u_flags
, '\0', sizeof (u_flags
));
1764 u_flags
.access
= ACCESS_SEQUENTIAL
;
1765 u_flags
.action
= ACTION_READWRITE
;
1767 /* Is it unformatted? */
1768 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1769 | IOPARM_DT_IONML_SET
)))
1770 u_flags
.form
= FORM_UNFORMATTED
;
1772 u_flags
.form
= FORM_UNSPECIFIED
;
1774 u_flags
.delim
= DELIM_UNSPECIFIED
;
1775 u_flags
.blank
= BLANK_UNSPECIFIED
;
1776 u_flags
.pad
= PAD_UNSPECIFIED
;
1777 u_flags
.status
= STATUS_UNKNOWN
;
1779 conv
= get_unformatted_convert (dtp
->common
.unit
);
1781 if (conv
== GFC_CONVERT_NONE
)
1782 conv
= compile_options
.convert
;
1784 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1785 and 1 on big-endian machines. */
1788 case GFC_CONVERT_NATIVE
:
1789 case GFC_CONVERT_SWAP
:
1792 case GFC_CONVERT_BIG
:
1793 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1796 case GFC_CONVERT_LITTLE
:
1797 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1801 internal_error (&opp
.common
, "Illegal value for CONVERT");
1805 u_flags
.convert
= conv
;
1807 opp
.common
= dtp
->common
;
1808 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1809 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1810 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1811 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1812 if (dtp
->u
.p
.current_unit
== NULL
)
1816 /* Check the action. */
1818 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1820 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1821 "Cannot read from file opened for WRITE");
1825 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1827 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1828 "Cannot write to file opened for READ");
1832 dtp
->u
.p
.first_item
= 1;
1834 /* Check the format. */
1836 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1839 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1840 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1843 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1844 "Format present for UNFORMATTED data transfer");
1848 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1850 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1851 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1852 "A format cannot be specified with a namelist");
1854 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1855 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1857 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1858 "Missing format for FORMATTED data transfer");
1861 if (is_internal_unit (dtp
)
1862 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1864 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1865 "Internal file cannot be accessed by UNFORMATTED "
1870 /* Check the record or position number. */
1872 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1873 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1875 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1876 "Direct access data transfer requires record number");
1880 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1881 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1883 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1884 "Record number not allowed for sequential access data transfer");
1888 /* Process the ADVANCE option. */
1890 dtp
->u
.p
.advance_status
1891 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1892 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1893 "Bad ADVANCE parameter in data transfer statement");
1895 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1897 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1899 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1900 "ADVANCE specification conflicts with sequential access");
1904 if (is_internal_unit (dtp
))
1906 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1907 "ADVANCE specification conflicts with internal file");
1911 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1912 != IOPARM_DT_HAS_FORMAT
)
1914 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1915 "ADVANCE specification requires an explicit format");
1922 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1924 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1926 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1927 "EOR specification requires an ADVANCE specification "
1932 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1934 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1935 "SIZE specification requires an ADVANCE specification of NO");
1940 { /* Write constraints. */
1941 if ((cf
& IOPARM_END
) != 0)
1943 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1944 "END specification cannot appear in a write statement");
1948 if ((cf
& IOPARM_EOR
) != 0)
1950 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1951 "EOR specification cannot appear in a write statement");
1955 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1957 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1958 "SIZE specification cannot appear in a write statement");
1963 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1964 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1966 /* Sanity checks on the record number. */
1967 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1971 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1972 "Record number must be positive");
1976 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1978 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1979 "Record number too large");
1983 /* Check to see if we might be reading what we wrote before */
1985 if (dtp
->u
.p
.mode
== READING
1986 && dtp
->u
.p
.current_unit
->mode
== WRITING
1987 && !is_internal_unit (dtp
))
1988 flush(dtp
->u
.p
.current_unit
->s
);
1990 /* Check whether the record exists to be read. Only
1991 a partial record needs to exist. */
1993 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1994 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1996 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1997 "Non-existing record number");
2001 /* Position the file. */
2002 if (!is_stream_io (dtp
))
2004 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
2005 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
2007 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2012 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
2018 /* Overwriting an existing sequential file ?
2019 it is always safe to truncate the file on the first write */
2020 if (dtp
->u
.p
.mode
== WRITING
2021 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2022 && dtp
->u
.p
.current_unit
->last_record
== 0
2023 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2024 struncate(dtp
->u
.p
.current_unit
->s
);
2026 /* Bugware for badly written mixed C-Fortran I/O. */
2027 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2029 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2031 /* Set the initial value of flags. */
2033 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2034 dtp
->u
.p
.sign_status
= SIGN_S
;
2036 /* Set the maximum position reached from the previous I/O operation. This
2037 could be greater than zero from a previous non-advancing write. */
2038 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2042 /* Set up the subroutine that will handle the transfers. */
2046 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2047 dtp
->u
.p
.transfer
= unformatted_read
;
2050 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2051 dtp
->u
.p
.transfer
= list_formatted_read
;
2053 dtp
->u
.p
.transfer
= formatted_transfer
;
2058 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2059 dtp
->u
.p
.transfer
= unformatted_write
;
2062 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2063 dtp
->u
.p
.transfer
= list_formatted_write
;
2065 dtp
->u
.p
.transfer
= formatted_transfer
;
2069 /* Make sure that we don't do a read after a nonadvancing write. */
2073 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2075 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2076 "Cannot READ after a nonadvancing WRITE");
2082 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2083 dtp
->u
.p
.current_unit
->read_bad
= 1;
2086 /* Start the data transfer if we are doing a formatted transfer. */
2087 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2088 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2089 && dtp
->u
.p
.ionml
== NULL
)
2090 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2093 /* Initialize an array_loop_spec given the array descriptor. The function
2094 returns the index of the last element of the array, and also returns
2095 starting record, where the first I/O goes to (necessary in case of
2096 negative strides). */
2099 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
,
2100 gfc_offset
*start_record
)
2102 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2111 for (i
=0; i
<rank
; i
++)
2113 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2114 ls
[i
].start
= desc
->dim
[i
].lbound
;
2115 ls
[i
].end
= desc
->dim
[i
].ubound
;
2116 ls
[i
].step
= desc
->dim
[i
].stride
;
2117 empty
= empty
|| (desc
->dim
[i
].ubound
< desc
->dim
[i
].lbound
);
2119 if (desc
->dim
[i
].stride
> 0)
2121 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2122 * desc
->dim
[i
].stride
;
2126 index
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2127 * desc
->dim
[i
].stride
;
2128 *start_record
-= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2129 * desc
->dim
[i
].stride
;
2139 /* Determine the index to the next record in an internal unit array by
2140 by incrementing through the array_loop_spec. */
2143 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
, int *finished
)
2151 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2156 if (ls
[i
].idx
> ls
[i
].end
)
2158 ls
[i
].idx
= ls
[i
].start
;
2164 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2174 /* Skip to the end of the current record, taking care of an optional
2175 record marker of size bytes. If the file is not seekable, we
2176 read chunks of size MAX_READ until we get to the right
2179 #define MAX_READ 4096
2182 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2185 int rlength
, length
;
2188 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2189 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2192 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2194 new = file_position (dtp
->u
.p
.current_unit
->s
)
2195 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2197 /* Direct access files do not generate END conditions,
2199 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2200 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2203 { /* Seek by reading data. */
2204 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2207 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2208 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2210 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2213 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2217 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2225 /* Advance to the next record reading unformatted files, taking
2226 care of subrecords. If complete_record is nonzero, we loop
2227 until all subrecords are cleared. */
2230 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2234 bytes
= compile_options
.record_marker
== 0 ?
2235 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2240 /* Skip over tail */
2242 skip_record (dtp
, bytes
);
2244 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2251 /* Space to the next record for read mode. */
2254 next_record_r (st_parameter_dt
*dtp
)
2257 int length
, bytes_left
;
2260 switch (current_mode (dtp
))
2262 /* No records in unformatted STREAM I/O. */
2263 case UNFORMATTED_STREAM
:
2266 case UNFORMATTED_SEQUENTIAL
:
2267 next_record_r_unf (dtp
, 1);
2268 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2271 case FORMATTED_DIRECT
:
2272 case UNFORMATTED_DIRECT
:
2273 skip_record (dtp
, 0);
2276 case FORMATTED_STREAM
:
2277 case FORMATTED_SEQUENTIAL
:
2279 /* sf_read has already terminated input because of an '\n' */
2280 if (dtp
->u
.p
.sf_seen_eor
)
2282 dtp
->u
.p
.sf_seen_eor
= 0;
2286 if (is_internal_unit (dtp
))
2288 if (is_array_io (dtp
))
2292 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2295 /* Now seek to this record. */
2296 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2297 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2299 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2302 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2306 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2307 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2309 dtp
->u
.p
.current_unit
->bytes_left
2310 = dtp
->u
.p
.current_unit
->recl
;
2316 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2320 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2326 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2330 if (is_stream_io (dtp
))
2331 dtp
->u
.p
.current_unit
->strm_pos
++;
2338 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2339 && !dtp
->u
.p
.namelist_mode
2340 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2341 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2342 file_position (dtp
->u
.p
.current_unit
->s
)))
2343 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2348 /* Small utility function to write a record marker, taking care of
2349 byte swapping and of choosing the correct size. */
2352 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2357 char p
[sizeof (GFC_INTEGER_8
)];
2359 if (compile_options
.record_marker
== 0)
2360 len
= sizeof (GFC_INTEGER_4
);
2362 len
= compile_options
.record_marker
;
2364 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2365 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2369 case sizeof (GFC_INTEGER_4
):
2371 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2374 case sizeof (GFC_INTEGER_8
):
2376 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2380 runtime_error ("Illegal value for record marker");
2388 case sizeof (GFC_INTEGER_4
):
2390 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2391 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2394 case sizeof (GFC_INTEGER_8
):
2396 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2397 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2401 runtime_error ("Illegal value for record marker");
2408 /* Position to the next (sub)record in write mode for
2409 unformatted sequential files. */
2412 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2414 gfc_offset c
, m
, m_write
;
2415 size_t record_marker
;
2417 /* Bytes written. */
2418 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2419 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2420 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2422 /* Write the length tail. If we finish a record containing
2423 subrecords, we write out the negative length. */
2425 if (dtp
->u
.p
.current_unit
->continued
)
2430 if (write_us_marker (dtp
, m_write
) != 0)
2433 if (compile_options
.record_marker
== 0)
2434 record_marker
= sizeof (GFC_INTEGER_4
);
2436 record_marker
= compile_options
.record_marker
;
2438 /* Seek to the head and overwrite the bogus length with the real
2441 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2450 if (write_us_marker (dtp
, m_write
) != 0)
2453 /* Seek past the end of the current record. */
2455 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2461 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2466 /* Position to the next record in write mode. */
2469 next_record_w (st_parameter_dt
*dtp
, int done
)
2471 gfc_offset m
, record
, max_pos
;
2475 /* Zero counters for X- and T-editing. */
2476 max_pos
= dtp
->u
.p
.max_pos
;
2477 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2479 switch (current_mode (dtp
))
2481 /* No records in unformatted STREAM I/O. */
2482 case UNFORMATTED_STREAM
:
2485 case FORMATTED_DIRECT
:
2486 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2489 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2490 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2495 case UNFORMATTED_DIRECT
:
2496 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2500 case UNFORMATTED_SEQUENTIAL
:
2501 next_record_w_unf (dtp
, 0);
2502 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2505 case FORMATTED_STREAM
:
2506 case FORMATTED_SEQUENTIAL
:
2508 if (is_internal_unit (dtp
))
2510 if (is_array_io (dtp
))
2514 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2516 /* If the farthest position reached is greater than current
2517 position, adjust the position and set length to pad out
2518 whats left. Otherwise just pad whats left.
2519 (for character array unit) */
2520 m
= dtp
->u
.p
.current_unit
->recl
2521 - dtp
->u
.p
.current_unit
->bytes_left
;
2524 length
= (int) (max_pos
- m
);
2525 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2526 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2529 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2531 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2535 /* Now that the current record has been padded out,
2536 determine where the next record in the array is. */
2537 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
,
2540 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2542 /* Now seek to this record */
2543 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2545 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2547 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2551 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2557 /* If this is the last call to next_record move to the farthest
2558 position reached and set length to pad out the remainder
2559 of the record. (for character scaler unit) */
2562 m
= dtp
->u
.p
.current_unit
->recl
2563 - dtp
->u
.p
.current_unit
->bytes_left
;
2566 length
= (int) (max_pos
- m
);
2567 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2568 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2571 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2574 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2576 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2584 const char crlf
[] = "\r\n";
2586 /* Move to the farthest position reached in preparation for
2587 completing the record. (for file unit) */
2588 m
= dtp
->u
.p
.current_unit
->recl
-
2589 dtp
->u
.p
.current_unit
->bytes_left
;
2592 length
= (int) (max_pos
- m
);
2593 sseek (dtp
->u
.p
.current_unit
->s
,
2594 file_position (dtp
->u
.p
.current_unit
->s
) + length
);
2601 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2604 if (is_stream_io (dtp
))
2606 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2607 struncate(dtp
->u
.p
.current_unit
->s
);
2614 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2619 /* Position to the next record, which means moving to the end of the
2620 current record. This can happen under several different
2621 conditions. If the done flag is not set, we get ready to process
2625 next_record (st_parameter_dt
*dtp
, int done
)
2627 gfc_offset fp
; /* File position. */
2629 dtp
->u
.p
.current_unit
->read_bad
= 0;
2631 if (dtp
->u
.p
.mode
== READING
)
2632 next_record_r (dtp
);
2634 next_record_w (dtp
, done
);
2636 if (!is_stream_io (dtp
))
2638 /* Keep position up to date for INQUIRE */
2640 update_position (dtp
->u
.p
.current_unit
);
2642 dtp
->u
.p
.current_unit
->current_record
= 0;
2643 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2645 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2646 /* Calculate next record, rounding up partial records. */
2647 dtp
->u
.p
.current_unit
->last_record
=
2648 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2649 dtp
->u
.p
.current_unit
->recl
;
2652 dtp
->u
.p
.current_unit
->last_record
++;
2660 /* Finalize the current data transfer. For a nonadvancing transfer,
2661 this means advancing to the next record. For internal units close the
2662 stream associated with the unit. */
2665 finalize_transfer (st_parameter_dt
*dtp
)
2668 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2670 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2671 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2673 if (dtp
->u
.p
.eor_condition
)
2675 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2679 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2682 if ((dtp
->u
.p
.ionml
!= NULL
)
2683 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2685 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2686 namelist_read (dtp
);
2688 namelist_write (dtp
);
2691 dtp
->u
.p
.transfer
= NULL
;
2692 if (dtp
->u
.p
.current_unit
== NULL
)
2695 dtp
->u
.p
.eof_jump
= &eof_jump
;
2696 if (setjmp (eof_jump
))
2698 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2702 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2704 finish_list_read (dtp
);
2705 sfree (dtp
->u
.p
.current_unit
->s
);
2709 if (dtp
->u
.p
.mode
== WRITING
)
2710 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2711 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2713 if (is_stream_io (dtp
))
2715 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2716 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2717 next_record (dtp
, 1);
2719 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2720 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2722 flush (dtp
->u
.p
.current_unit
->s
);
2723 sfree (dtp
->u
.p
.current_unit
->s
);
2728 dtp
->u
.p
.current_unit
->current_record
= 0;
2730 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2732 dtp
->u
.p
.seen_dollar
= 0;
2733 sfree (dtp
->u
.p
.current_unit
->s
);
2737 /* For non-advancing I/O, save the current maximum position for use in the
2738 next I/O operation if needed. */
2739 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2741 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2742 - dtp
->u
.p
.current_unit
->bytes_left
);
2743 dtp
->u
.p
.current_unit
->saved_pos
=
2744 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2745 flush (dtp
->u
.p
.current_unit
->s
);
2749 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2751 next_record (dtp
, 1);
2752 sfree (dtp
->u
.p
.current_unit
->s
);
2755 /* Transfer function for IOLENGTH. It doesn't actually do any
2756 data transfer, it just updates the length counter. */
2759 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2760 void *dest
__attribute__ ((unused
)),
2761 int kind
__attribute__((unused
)),
2762 size_t size
, size_t nelems
)
2764 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2765 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2769 /* Initialize the IOLENGTH data transfer. This function is in essence
2770 a very much simplified version of data_transfer_init(), because it
2771 doesn't have to deal with units at all. */
2774 iolength_transfer_init (st_parameter_dt
*dtp
)
2776 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2779 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2781 /* Set up the subroutine that will handle the transfers. */
2783 dtp
->u
.p
.transfer
= iolength_transfer
;
2787 /* Library entry point for the IOLENGTH form of the INQUIRE
2788 statement. The IOLENGTH form requires no I/O to be performed, but
2789 it must still be a runtime library call so that we can determine
2790 the iolength for dynamic arrays and such. */
2792 extern void st_iolength (st_parameter_dt
*);
2793 export_proto(st_iolength
);
2796 st_iolength (st_parameter_dt
*dtp
)
2798 library_start (&dtp
->common
);
2799 iolength_transfer_init (dtp
);
2802 extern void st_iolength_done (st_parameter_dt
*);
2803 export_proto(st_iolength_done
);
2806 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2809 if (dtp
->u
.p
.scratch
!= NULL
)
2810 free_mem (dtp
->u
.p
.scratch
);
2815 /* The READ statement. */
2817 extern void st_read (st_parameter_dt
*);
2818 export_proto(st_read
);
2821 st_read (st_parameter_dt
*dtp
)
2823 library_start (&dtp
->common
);
2825 data_transfer_init (dtp
, 1);
2827 /* Handle complications dealing with the endfile record. */
2829 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2830 switch (dtp
->u
.p
.current_unit
->endfile
)
2836 if (!is_internal_unit (dtp
))
2838 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2839 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2840 dtp
->u
.p
.current_unit
->current_record
= 0;
2845 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2846 dtp
->u
.p
.current_unit
->current_record
= 0;
2851 extern void st_read_done (st_parameter_dt
*);
2852 export_proto(st_read_done
);
2855 st_read_done (st_parameter_dt
*dtp
)
2857 finalize_transfer (dtp
);
2858 free_format_data (dtp
);
2860 if (dtp
->u
.p
.scratch
!= NULL
)
2861 free_mem (dtp
->u
.p
.scratch
);
2862 if (dtp
->u
.p
.current_unit
!= NULL
)
2863 unlock_unit (dtp
->u
.p
.current_unit
);
2865 free_internal_unit (dtp
);
2870 extern void st_write (st_parameter_dt
*);
2871 export_proto(st_write
);
2874 st_write (st_parameter_dt
*dtp
)
2876 library_start (&dtp
->common
);
2877 data_transfer_init (dtp
, 0);
2880 extern void st_write_done (st_parameter_dt
*);
2881 export_proto(st_write_done
);
2884 st_write_done (st_parameter_dt
*dtp
)
2886 finalize_transfer (dtp
);
2888 /* Deal with endfile conditions associated with sequential files. */
2890 if (dtp
->u
.p
.current_unit
!= NULL
2891 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2892 switch (dtp
->u
.p
.current_unit
->endfile
)
2894 case AT_ENDFILE
: /* Remain at the endfile record. */
2898 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2902 /* Get rid of whatever is after this record. */
2903 if (!is_internal_unit (dtp
))
2905 flush (dtp
->u
.p
.current_unit
->s
);
2906 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2907 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2909 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2913 free_format_data (dtp
);
2915 if (dtp
->u
.p
.scratch
!= NULL
)
2916 free_mem (dtp
->u
.p
.scratch
);
2917 if (dtp
->u
.p
.current_unit
!= NULL
)
2918 unlock_unit (dtp
->u
.p
.current_unit
);
2920 free_internal_unit (dtp
);
2925 /* Receives the scalar information for namelist objects and stores it
2926 in a linked list of namelist_info types. */
2928 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2929 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2930 export_proto(st_set_nml_var
);
2934 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2935 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2936 GFC_INTEGER_4 dtype
)
2938 namelist_info
*t1
= NULL
;
2940 size_t var_name_len
= strlen (var_name
);
2942 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2944 nml
->mem_pos
= var_addr
;
2946 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2947 memcpy (nml
->var_name
, var_name
, var_name_len
);
2948 nml
->var_name
[var_name_len
] = '\0';
2950 nml
->len
= (int) len
;
2951 nml
->string_length
= (index_type
) string_length
;
2953 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2954 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2955 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2957 if (nml
->var_rank
> 0)
2959 nml
->dim
= (descriptor_dimension
*)
2960 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2961 nml
->ls
= (array_loop_spec
*)
2962 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2972 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2974 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2975 dtp
->u
.p
.ionml
= nml
;
2979 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2984 /* Store the dimensional information for the namelist object. */
2985 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2986 index_type
, index_type
,
2988 export_proto(st_set_nml_var_dim
);
2991 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2992 index_type stride
, index_type lbound
,
2995 namelist_info
* nml
;
3000 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
3002 nml
->dim
[n
].stride
= stride
;
3003 nml
->dim
[n
].lbound
= lbound
;
3004 nml
->dim
[n
].ubound
= ubound
;
3007 /* Reverse memcpy - used for byte swapping. */
3009 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
3015 s
= (char *) src
+ n
- 1;
3017 /* Write with ascending order - this is likely faster
3018 on modern architectures because of write combining. */