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 (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
643 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
647 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
648 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
654 /* Unformatted sequential. */
658 if (dtp
->u
.p
.current_unit
->flags
.has_recl
659 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
661 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
673 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
674 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
676 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
677 (gfc_offset
) to_write_subrecord
;
679 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
680 &to_write_subrecord
) != 0)
682 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
686 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
687 nbytes
-= to_write_subrecord
;
688 have_written
+= to_write_subrecord
;
693 next_record_w_unf (dtp
, 1);
696 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
699 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
706 /* Master function for unformatted reads. */
709 unformatted_read (st_parameter_dt
*dtp
, bt type
,
710 void *dest
, int kind
__attribute__((unused
)),
711 size_t size
, size_t nelems
)
715 /* Currently, character implies size=1. */
716 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
717 || size
== 1 || type
== BT_CHARACTER
)
720 read_block_direct (dtp
, dest
, &sz
);
727 /* Break up complex into its constituent reals. */
728 if (type
== BT_COMPLEX
)
735 /* By now, all complex variables have been split into their
736 constituent reals. */
738 for (i
=0; i
<nelems
; i
++)
740 read_block_direct (dtp
, buffer
, &size
);
741 reverse_memcpy (p
, buffer
, size
);
748 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
749 bytes on 64 bit machines. The unused bytes are not initialized and never
750 used, which can show an error with memory checking analyzers like
754 unformatted_write (st_parameter_dt
*dtp
, bt type
,
755 void *source
, int kind
__attribute__((unused
)),
756 size_t size
, size_t nelems
)
758 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
759 size
== 1 || type
== BT_CHARACTER
)
762 write_buf (dtp
, source
, size
);
770 /* Break up complex into its constituent reals. */
771 if (type
== BT_COMPLEX
)
779 /* By now, all complex variables have been split into their
780 constituent reals. */
783 for (i
=0; i
<nelems
; i
++)
785 reverse_memcpy(buffer
, p
, size
);
787 write_buf (dtp
, buffer
, size
);
793 /* Return a pointer to the name of a type. */
818 internal_error (NULL
, "type_name(): Bad type");
825 /* Write a constant string to the output.
826 This is complicated because the string can have doubled delimiters
827 in it. The length in the format node is the true length. */
830 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
832 char c
, delimiter
, *p
, *q
;
835 length
= f
->u
.string
.length
;
839 p
= write_block (dtp
, length
);
846 for (; length
> 0; length
--)
849 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
850 q
++; /* Skip the doubled delimiter. */
855 /* Given actual and expected types in a formatted data transfer, make
856 sure they agree. If not, an error message is generated. Returns
857 nonzero if something went wrong. */
860 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
864 if (actual
== expected
)
867 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
868 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
870 format_error (dtp
, f
, buffer
);
875 /* This subroutine is the main loop for a formatted data transfer
876 statement. It would be natural to implement this as a coroutine
877 with the user program, but C makes that awkward. We loop,
878 processing format elements. When we actually have to transfer
879 data instead of just setting flags, we return control to the user
880 program which calls a subroutine that supplies the address and type
881 of the next element, then comes back here to process it. */
884 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
887 char scratch
[SCRATCH_SIZE
];
892 int consume_data_flag
;
894 /* Change a complex data item into a pair of reals. */
896 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
897 if (type
== BT_COMPLEX
)
903 /* If there's an EOR condition, we simulate finalizing the transfer
905 if (dtp
->u
.p
.eor_condition
)
908 /* Set this flag so that commas in reads cause the read to complete before
909 the entire field has been read. The next read field will start right after
910 the comma in the stream. (Set to 0 for character reads). */
911 dtp
->u
.p
.sf_read_comma
= 1;
913 dtp
->u
.p
.line_buffer
= scratch
;
916 /* If reversion has occurred and there is another real data item,
917 then we have to move to the next record. */
918 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
920 dtp
->u
.p
.reversion_flag
= 0;
921 next_record (dtp
, 0);
924 consume_data_flag
= 1 ;
925 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
928 f
= next_format (dtp
);
931 /* No data descriptors left. */
933 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
934 "Insufficient data descriptors in format after reversion");
938 /* Now discharge T, TR and X movements to the right. This is delayed
939 until a data producing format to suppress trailing spaces. */
942 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
943 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
944 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
945 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
946 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
949 if (dtp
->u
.p
.skips
> 0)
951 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
952 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
953 - dtp
->u
.p
.current_unit
->bytes_left
);
955 if (dtp
->u
.p
.skips
< 0)
957 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
958 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
960 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
963 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
964 - dtp
->u
.p
.current_unit
->bytes_left
);
966 if (is_stream_io(dtp
))
974 if (require_type (dtp
, BT_INTEGER
, type
, f
))
977 if (dtp
->u
.p
.mode
== READING
)
978 read_decimal (dtp
, f
, p
, len
);
980 write_i (dtp
, f
, p
, len
);
988 if (compile_options
.allow_std
< GFC_STD_GNU
989 && require_type (dtp
, BT_INTEGER
, type
, f
))
992 if (dtp
->u
.p
.mode
== READING
)
993 read_radix (dtp
, f
, p
, len
, 2);
995 write_b (dtp
, f
, p
, len
);
1003 if (compile_options
.allow_std
< GFC_STD_GNU
1004 && require_type (dtp
, BT_INTEGER
, type
, f
))
1007 if (dtp
->u
.p
.mode
== READING
)
1008 read_radix (dtp
, f
, p
, len
, 8);
1010 write_o (dtp
, f
, p
, len
);
1018 if (compile_options
.allow_std
< GFC_STD_GNU
1019 && require_type (dtp
, BT_INTEGER
, type
, f
))
1022 if (dtp
->u
.p
.mode
== READING
)
1023 read_radix (dtp
, f
, p
, len
, 16);
1025 write_z (dtp
, f
, p
, len
);
1033 if (dtp
->u
.p
.mode
== READING
)
1034 read_a (dtp
, f
, p
, len
);
1036 write_a (dtp
, f
, p
, len
);
1044 if (dtp
->u
.p
.mode
== READING
)
1045 read_l (dtp
, f
, p
, len
);
1047 write_l (dtp
, f
, p
, len
);
1054 if (require_type (dtp
, BT_REAL
, type
, f
))
1057 if (dtp
->u
.p
.mode
== READING
)
1058 read_f (dtp
, f
, p
, len
);
1060 write_d (dtp
, f
, p
, len
);
1067 if (require_type (dtp
, BT_REAL
, type
, f
))
1070 if (dtp
->u
.p
.mode
== READING
)
1071 read_f (dtp
, f
, p
, len
);
1073 write_e (dtp
, f
, p
, len
);
1079 if (require_type (dtp
, BT_REAL
, type
, f
))
1082 if (dtp
->u
.p
.mode
== READING
)
1083 read_f (dtp
, f
, p
, len
);
1085 write_en (dtp
, f
, p
, len
);
1092 if (require_type (dtp
, BT_REAL
, type
, f
))
1095 if (dtp
->u
.p
.mode
== READING
)
1096 read_f (dtp
, f
, p
, len
);
1098 write_es (dtp
, f
, p
, len
);
1105 if (require_type (dtp
, BT_REAL
, type
, f
))
1108 if (dtp
->u
.p
.mode
== READING
)
1109 read_f (dtp
, f
, p
, len
);
1111 write_f (dtp
, f
, p
, len
);
1118 if (dtp
->u
.p
.mode
== READING
)
1122 read_decimal (dtp
, f
, p
, len
);
1125 read_l (dtp
, f
, p
, len
);
1128 read_a (dtp
, f
, p
, len
);
1131 read_f (dtp
, f
, p
, len
);
1140 write_i (dtp
, f
, p
, len
);
1143 write_l (dtp
, f
, p
, len
);
1146 write_a (dtp
, f
, p
, len
);
1149 write_d (dtp
, f
, p
, len
);
1153 internal_error (&dtp
->common
,
1154 "formatted_transfer(): Bad type");
1160 consume_data_flag
= 0 ;
1161 if (dtp
->u
.p
.mode
== READING
)
1163 format_error (dtp
, f
, "Constant string in input format");
1166 write_constant_string (dtp
, f
);
1169 /* Format codes that don't transfer data. */
1172 consume_data_flag
= 0;
1174 dtp
->u
.p
.skips
+= f
->u
.n
;
1175 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1176 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1178 /* Writes occur just before the switch on f->format, above, so
1179 that trailing blanks are suppressed, unless we are doing a
1180 non-advancing write in which case we want to output the blanks
1182 if (dtp
->u
.p
.mode
== WRITING
1183 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1185 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1186 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1189 if (dtp
->u
.p
.mode
== READING
)
1190 read_x (dtp
, f
->u
.n
);
1196 consume_data_flag
= 0;
1198 if (f
->format
== FMT_TL
)
1201 /* Handle the special case when no bytes have been used yet.
1202 Cannot go below zero. */
1203 if (bytes_used
== 0)
1205 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1206 dtp
->u
.p
.skips
-= f
->u
.n
;
1207 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1210 pos
= bytes_used
- f
->u
.n
;
1214 if (dtp
->u
.p
.mode
== READING
)
1217 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1220 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1221 left tab limit. We do not check if the position has gone
1222 beyond the end of record because a subsequent tab could
1223 bring us back again. */
1224 pos
= pos
< 0 ? 0 : pos
;
1226 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1227 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1228 + pos
- dtp
->u
.p
.max_pos
;
1229 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1230 ? 0 : dtp
->u
.p
.pending_spaces
;
1232 if (dtp
->u
.p
.skips
== 0)
1235 /* Writes occur just before the switch on f->format, above, so that
1236 trailing blanks are suppressed. */
1237 if (dtp
->u
.p
.mode
== READING
)
1239 /* Adjust everything for end-of-record condition */
1240 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1242 if (dtp
->u
.p
.sf_seen_eor
== 2)
1244 /* The EOR was a CRLF (two bytes wide). */
1245 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1246 dtp
->u
.p
.skips
-= 2;
1250 /* The EOR marker was only one byte wide. */
1251 dtp
->u
.p
.current_unit
->bytes_left
--;
1255 dtp
->u
.p
.sf_seen_eor
= 0;
1257 if (dtp
->u
.p
.skips
< 0)
1259 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1260 dtp
->u
.p
.current_unit
->bytes_left
1261 -= (gfc_offset
) dtp
->u
.p
.skips
;
1262 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1265 read_x (dtp
, dtp
->u
.p
.skips
);
1271 consume_data_flag
= 0 ;
1272 dtp
->u
.p
.sign_status
= SIGN_S
;
1276 consume_data_flag
= 0 ;
1277 dtp
->u
.p
.sign_status
= SIGN_SS
;
1281 consume_data_flag
= 0 ;
1282 dtp
->u
.p
.sign_status
= SIGN_SP
;
1286 consume_data_flag
= 0 ;
1287 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1291 consume_data_flag
= 0 ;
1292 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1296 consume_data_flag
= 0 ;
1297 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1301 consume_data_flag
= 0 ;
1302 dtp
->u
.p
.seen_dollar
= 1;
1306 consume_data_flag
= 0 ;
1307 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1308 next_record (dtp
, 0);
1312 /* A colon descriptor causes us to exit this loop (in
1313 particular preventing another / descriptor from being
1314 processed) unless there is another data item to be
1316 consume_data_flag
= 0 ;
1322 internal_error (&dtp
->common
, "Bad format node");
1325 /* Free a buffer that we had to allocate during a sequential
1326 formatted read of a block that was larger than the static
1329 if (dtp
->u
.p
.line_buffer
!= scratch
)
1331 free_mem (dtp
->u
.p
.line_buffer
);
1332 dtp
->u
.p
.line_buffer
= scratch
;
1335 /* Adjust the item count and data pointer. */
1337 if ((consume_data_flag
> 0) && (n
> 0))
1340 p
= ((char *) p
) + size
;
1343 if (dtp
->u
.p
.mode
== READING
)
1346 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1347 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1353 /* Come here when we need a data descriptor but don't have one. We
1354 push the current format node back onto the input, then return and
1355 let the user program call us back with the data. */
1357 unget_format (dtp
, f
);
1361 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1362 size_t size
, size_t nelems
)
1369 /* Big loop over all the elements. */
1370 for (elem
= 0; elem
< nelems
; elem
++)
1372 dtp
->u
.p
.item_count
++;
1373 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1379 /* Data transfer entry points. The type of the data entity is
1380 implicit in the subroutine call. This prevents us from having to
1381 share a common enum with the compiler. */
1384 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1386 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1388 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1393 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1396 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1398 size
= size_from_real_kind (kind
);
1399 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1404 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1406 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1408 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1413 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1415 static char *empty_string
[0];
1417 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1420 /* Strings of zero length can have p == NULL, which confuses the
1421 transfer routines into thinking we need more data elements. To avoid
1422 this, we give them a nice pointer. */
1423 if (len
== 0 && p
== NULL
)
1426 /* Currently we support only 1 byte chars, and the library is a bit
1427 confused of character kind vs. length, so we kludge it by setting
1429 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1434 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1437 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1439 size
= size_from_complex_kind (kind
);
1440 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1445 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1446 gfc_charlen_type charlen
)
1448 index_type count
[GFC_MAX_DIMENSIONS
];
1449 index_type extent
[GFC_MAX_DIMENSIONS
];
1450 index_type stride
[GFC_MAX_DIMENSIONS
];
1451 index_type stride0
, rank
, size
, type
, n
;
1456 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1459 type
= GFC_DESCRIPTOR_TYPE (desc
);
1460 size
= GFC_DESCRIPTOR_SIZE (desc
);
1462 /* FIXME: What a kludge: Array descriptors and the IO library use
1463 different enums for types. */
1466 case GFC_DTYPE_UNKNOWN
:
1467 iotype
= BT_NULL
; /* Is this correct? */
1469 case GFC_DTYPE_INTEGER
:
1470 iotype
= BT_INTEGER
;
1472 case GFC_DTYPE_LOGICAL
:
1473 iotype
= BT_LOGICAL
;
1475 case GFC_DTYPE_REAL
:
1478 case GFC_DTYPE_COMPLEX
:
1479 iotype
= BT_COMPLEX
;
1481 case GFC_DTYPE_CHARACTER
:
1482 iotype
= BT_CHARACTER
;
1483 /* FIXME: Currently dtype contains the charlen, which is
1484 clobbered if charlen > 2**24. That's why we use a separate
1485 argument for the charlen. However, if we want to support
1486 non-8-bit charsets we need to fix dtype to contain
1487 sizeof(chartype) and fix the code below. */
1491 case GFC_DTYPE_DERIVED
:
1492 internal_error (&dtp
->common
,
1493 "Derived type I/O should have been handled via the frontend.");
1496 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1499 rank
= GFC_DESCRIPTOR_RANK (desc
);
1500 for (n
= 0; n
< rank
; n
++)
1503 stride
[n
] = desc
->dim
[n
].stride
;
1504 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1506 /* If the extent of even one dimension is zero, then the entire
1507 array section contains zero elements, so we return. */
1512 stride0
= stride
[0];
1514 /* If the innermost dimension has stride 1, we can do the transfer
1515 in contiguous chunks. */
1521 data
= GFC_DESCRIPTOR_DATA (desc
);
1525 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1526 data
+= stride0
* size
* tsize
;
1529 while (count
[n
] == extent
[n
])
1532 data
-= stride
[n
] * extent
[n
] * size
;
1542 data
+= stride
[n
] * size
;
1549 /* Preposition a sequential unformatted file while reading. */
1552 us_read (st_parameter_dt
*dtp
, int continued
)
1561 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1564 if (compile_options
.record_marker
== 0)
1565 n
= sizeof (GFC_INTEGER_4
);
1567 n
= compile_options
.record_marker
;
1571 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1575 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1576 return; /* end of file */
1579 if (p
== NULL
|| n
!= nr
)
1581 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1585 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1586 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1590 case sizeof(GFC_INTEGER_4
):
1591 memcpy (&i4
, p
, sizeof (i4
));
1595 case sizeof(GFC_INTEGER_8
):
1596 memcpy (&i8
, p
, sizeof (i8
));
1601 runtime_error ("Illegal value for record marker");
1608 case sizeof(GFC_INTEGER_4
):
1609 reverse_memcpy (&i4
, p
, sizeof (i4
));
1613 case sizeof(GFC_INTEGER_8
):
1614 reverse_memcpy (&i8
, p
, sizeof (i8
));
1619 runtime_error ("Illegal value for record marker");
1625 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1626 dtp
->u
.p
.current_unit
->continued
= 0;
1630 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1631 dtp
->u
.p
.current_unit
->continued
= 1;
1635 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1639 /* Preposition a sequential unformatted file while writing. This
1640 amount to writing a bogus length that will be filled in later. */
1643 us_write (st_parameter_dt
*dtp
, int continued
)
1650 if (compile_options
.record_marker
== 0)
1651 nbytes
= sizeof (GFC_INTEGER_4
);
1653 nbytes
= compile_options
.record_marker
;
1655 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1656 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1658 /* For sequential unformatted, if RECL= was not specified in the OPEN
1659 we write until we have more bytes than can fit in the subrecord
1660 markers, then we write a new subrecord. */
1662 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1663 dtp
->u
.p
.current_unit
->recl_subrecord
;
1664 dtp
->u
.p
.current_unit
->continued
= continued
;
1668 /* Position to the next record prior to transfer. We are assumed to
1669 be before the next record. We also calculate the bytes in the next
1673 pre_position (st_parameter_dt
*dtp
)
1675 if (dtp
->u
.p
.current_unit
->current_record
)
1676 return; /* Already positioned. */
1678 switch (current_mode (dtp
))
1680 case FORMATTED_STREAM
:
1681 case UNFORMATTED_STREAM
:
1682 /* There are no records with stream I/O. Set the default position
1683 to the beginning of the file if no position was specified. */
1684 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1685 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1688 case UNFORMATTED_SEQUENTIAL
:
1689 if (dtp
->u
.p
.mode
== READING
)
1696 case FORMATTED_SEQUENTIAL
:
1697 case FORMATTED_DIRECT
:
1698 case UNFORMATTED_DIRECT
:
1699 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1703 dtp
->u
.p
.current_unit
->current_record
= 1;
1707 /* Initialize things for a data transfer. This code is common for
1708 both reading and writing. */
1711 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1713 unit_flags u_flags
; /* Used for creating a unit if needed. */
1714 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1715 namelist_info
*ionml
;
1717 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1718 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1719 dtp
->u
.p
.ionml
= ionml
;
1720 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1722 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1725 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1726 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1728 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1729 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1730 { /* Open the unit with some default flags. */
1731 st_parameter_open opp
;
1734 if (dtp
->common
.unit
< 0)
1736 close_unit (dtp
->u
.p
.current_unit
);
1737 dtp
->u
.p
.current_unit
= NULL
;
1738 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1739 "Bad unit number in OPEN statement");
1742 memset (&u_flags
, '\0', sizeof (u_flags
));
1743 u_flags
.access
= ACCESS_SEQUENTIAL
;
1744 u_flags
.action
= ACTION_READWRITE
;
1746 /* Is it unformatted? */
1747 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1748 | IOPARM_DT_IONML_SET
)))
1749 u_flags
.form
= FORM_UNFORMATTED
;
1751 u_flags
.form
= FORM_UNSPECIFIED
;
1753 u_flags
.delim
= DELIM_UNSPECIFIED
;
1754 u_flags
.blank
= BLANK_UNSPECIFIED
;
1755 u_flags
.pad
= PAD_UNSPECIFIED
;
1756 u_flags
.status
= STATUS_UNKNOWN
;
1758 conv
= get_unformatted_convert (dtp
->common
.unit
);
1760 if (conv
== GFC_CONVERT_NONE
)
1761 conv
= compile_options
.convert
;
1763 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1764 and 1 on big-endian machines. */
1767 case GFC_CONVERT_NATIVE
:
1768 case GFC_CONVERT_SWAP
:
1771 case GFC_CONVERT_BIG
:
1772 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1775 case GFC_CONVERT_LITTLE
:
1776 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1780 internal_error (&opp
.common
, "Illegal value for CONVERT");
1784 u_flags
.convert
= conv
;
1786 opp
.common
= dtp
->common
;
1787 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1788 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1789 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1790 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1791 if (dtp
->u
.p
.current_unit
== NULL
)
1795 /* Check the action. */
1797 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1799 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1800 "Cannot read from file opened for WRITE");
1804 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1806 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1807 "Cannot write to file opened for READ");
1811 dtp
->u
.p
.first_item
= 1;
1813 /* Check the format. */
1815 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1818 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1819 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1822 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1823 "Format present for UNFORMATTED data transfer");
1827 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1829 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1830 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1831 "A format cannot be specified with a namelist");
1833 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1834 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1836 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1837 "Missing format for FORMATTED data transfer");
1840 if (is_internal_unit (dtp
)
1841 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1843 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1844 "Internal file cannot be accessed by UNFORMATTED "
1849 /* Check the record or position number. */
1851 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1852 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1854 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1855 "Direct access data transfer requires record number");
1859 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1860 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1862 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1863 "Record number not allowed for sequential access data transfer");
1867 /* Process the ADVANCE option. */
1869 dtp
->u
.p
.advance_status
1870 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1871 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1872 "Bad ADVANCE parameter in data transfer statement");
1874 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1876 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1878 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1879 "ADVANCE specification conflicts with sequential access");
1883 if (is_internal_unit (dtp
))
1885 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1886 "ADVANCE specification conflicts with internal file");
1890 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1891 != IOPARM_DT_HAS_FORMAT
)
1893 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1894 "ADVANCE specification requires an explicit format");
1901 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
= 0;
1903 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1905 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1906 "EOR specification requires an ADVANCE specification "
1911 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1913 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1914 "SIZE specification requires an ADVANCE specification of NO");
1919 { /* Write constraints. */
1920 if ((cf
& IOPARM_END
) != 0)
1922 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1923 "END specification cannot appear in a write statement");
1927 if ((cf
& IOPARM_EOR
) != 0)
1929 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1930 "EOR specification cannot appear in a write statement");
1934 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1936 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1937 "SIZE specification cannot appear in a write statement");
1942 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1943 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1945 /* Sanity checks on the record number. */
1946 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1950 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1951 "Record number must be positive");
1955 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1957 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1958 "Record number too large");
1962 /* Check to see if we might be reading what we wrote before */
1964 if (dtp
->u
.p
.mode
== READING
1965 && dtp
->u
.p
.current_unit
->mode
== WRITING
1966 && !is_internal_unit (dtp
))
1967 flush(dtp
->u
.p
.current_unit
->s
);
1969 /* Check whether the record exists to be read. Only
1970 a partial record needs to exist. */
1972 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1973 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1975 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1976 "Non-existing record number");
1980 /* Position the file. */
1981 if (!is_stream_io (dtp
))
1983 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1984 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1986 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1991 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1995 /* Overwriting an existing sequential file ?
1996 it is always safe to truncate the file on the first write */
1997 if (dtp
->u
.p
.mode
== WRITING
1998 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1999 && dtp
->u
.p
.current_unit
->last_record
== 0
2000 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
2001 struncate(dtp
->u
.p
.current_unit
->s
);
2003 /* Bugware for badly written mixed C-Fortran I/O. */
2004 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
2006 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
2008 /* Set the initial value of flags. */
2010 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
2011 dtp
->u
.p
.sign_status
= SIGN_S
;
2013 /* Set the maximum position reached from the previous I/O operation. This
2014 could be greater than zero from a previous non-advancing write. */
2015 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2019 /* Set up the subroutine that will handle the transfers. */
2023 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2024 dtp
->u
.p
.transfer
= unformatted_read
;
2027 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2028 dtp
->u
.p
.transfer
= list_formatted_read
;
2030 dtp
->u
.p
.transfer
= formatted_transfer
;
2035 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2036 dtp
->u
.p
.transfer
= unformatted_write
;
2039 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2040 dtp
->u
.p
.transfer
= list_formatted_write
;
2042 dtp
->u
.p
.transfer
= formatted_transfer
;
2046 /* Make sure that we don't do a read after a nonadvancing write. */
2050 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2052 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2053 "Cannot READ after a nonadvancing WRITE");
2059 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2060 dtp
->u
.p
.current_unit
->read_bad
= 1;
2063 /* Start the data transfer if we are doing a formatted transfer. */
2064 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2065 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2066 && dtp
->u
.p
.ionml
== NULL
)
2067 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2070 /* Initialize an array_loop_spec given the array descriptor. The function
2071 returns the index of the last element of the array. */
2074 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2076 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2081 for (i
=0; i
<rank
; i
++)
2083 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2084 ls
[i
].start
= desc
->dim
[i
].lbound
;
2085 ls
[i
].end
= desc
->dim
[i
].ubound
;
2086 ls
[i
].step
= desc
->dim
[i
].stride
;
2088 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2089 * desc
->dim
[i
].stride
;
2094 /* Determine the index to the next record in an internal unit array by
2095 by incrementing through the array_loop_spec. TODO: Implement handling
2096 negative strides. */
2099 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2107 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2112 if (ls
[i
].idx
> ls
[i
].end
)
2114 ls
[i
].idx
= ls
[i
].start
;
2120 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2128 /* Skip to the end of the current record, taking care of an optional
2129 record marker of size bytes. If the file is not seekable, we
2130 read chunks of size MAX_READ until we get to the right
2133 #define MAX_READ 4096
2136 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2139 int rlength
, length
;
2142 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2143 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2146 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2148 new = file_position (dtp
->u
.p
.current_unit
->s
)
2149 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2151 /* Direct access files do not generate END conditions,
2153 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2154 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2157 { /* Seek by reading data. */
2158 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2161 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2162 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2164 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2167 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2171 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2179 /* Advance to the next record reading unformatted files, taking
2180 care of subrecords. If complete_record is nonzero, we loop
2181 until all subrecords are cleared. */
2184 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2188 bytes
= compile_options
.record_marker
== 0 ?
2189 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2194 /* Skip over tail */
2196 skip_record (dtp
, bytes
);
2198 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2205 /* Space to the next record for read mode. */
2208 next_record_r (st_parameter_dt
*dtp
)
2211 int length
, bytes_left
;
2214 switch (current_mode (dtp
))
2216 /* No records in unformatted STREAM I/O. */
2217 case UNFORMATTED_STREAM
:
2220 case UNFORMATTED_SEQUENTIAL
:
2221 next_record_r_unf (dtp
, 1);
2222 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2225 case FORMATTED_DIRECT
:
2226 case UNFORMATTED_DIRECT
:
2227 skip_record (dtp
, 0);
2230 case FORMATTED_STREAM
:
2231 case FORMATTED_SEQUENTIAL
:
2233 /* sf_read has already terminated input because of an '\n' */
2234 if (dtp
->u
.p
.sf_seen_eor
)
2236 dtp
->u
.p
.sf_seen_eor
= 0;
2240 if (is_internal_unit (dtp
))
2242 if (is_array_io (dtp
))
2244 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2246 /* Now seek to this record. */
2247 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2248 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2250 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2253 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2257 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2258 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2260 dtp
->u
.p
.current_unit
->bytes_left
2261 = dtp
->u
.p
.current_unit
->recl
;
2267 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2271 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2277 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2281 if (is_stream_io (dtp
))
2282 dtp
->u
.p
.current_unit
->strm_pos
++;
2289 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2290 && !dtp
->u
.p
.namelist_mode
2291 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2292 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2293 file_position (dtp
->u
.p
.current_unit
->s
)))
2294 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2299 /* Small utility function to write a record marker, taking care of
2300 byte swapping and of choosing the correct size. */
2303 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2308 char p
[sizeof (GFC_INTEGER_8
)];
2310 if (compile_options
.record_marker
== 0)
2311 len
= sizeof (GFC_INTEGER_4
);
2313 len
= compile_options
.record_marker
;
2315 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2316 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2320 case sizeof (GFC_INTEGER_4
):
2322 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2325 case sizeof (GFC_INTEGER_8
):
2327 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2331 runtime_error ("Illegal value for record marker");
2339 case sizeof (GFC_INTEGER_4
):
2341 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2342 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2345 case sizeof (GFC_INTEGER_8
):
2347 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2348 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2352 runtime_error ("Illegal value for record marker");
2359 /* Position to the next (sub)record in write mode for
2360 unformatted sequential files. */
2363 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2365 gfc_offset c
, m
, m_write
;
2366 size_t record_marker
;
2368 /* Bytes written. */
2369 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2370 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2371 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2373 /* Write the length tail. If we finish a record containing
2374 subrecords, we write out the negative length. */
2376 if (dtp
->u
.p
.current_unit
->continued
)
2381 if (write_us_marker (dtp
, m_write
) != 0)
2384 if (compile_options
.record_marker
== 0)
2385 record_marker
= sizeof (GFC_INTEGER_4
);
2387 record_marker
= compile_options
.record_marker
;
2389 /* Seek to the head and overwrite the bogus length with the real
2392 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2401 if (write_us_marker (dtp
, m_write
) != 0)
2404 /* Seek past the end of the current record. */
2406 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2412 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2417 /* Position to the next record in write mode. */
2420 next_record_w (st_parameter_dt
*dtp
, int done
)
2422 gfc_offset m
, record
, max_pos
;
2426 /* Zero counters for X- and T-editing. */
2427 max_pos
= dtp
->u
.p
.max_pos
;
2428 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2430 switch (current_mode (dtp
))
2432 /* No records in unformatted STREAM I/O. */
2433 case UNFORMATTED_STREAM
:
2436 case FORMATTED_DIRECT
:
2437 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2440 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2441 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2446 case UNFORMATTED_DIRECT
:
2447 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2451 case UNFORMATTED_SEQUENTIAL
:
2452 next_record_w_unf (dtp
, 0);
2453 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2456 case FORMATTED_STREAM
:
2457 case FORMATTED_SEQUENTIAL
:
2459 if (is_internal_unit (dtp
))
2461 if (is_array_io (dtp
))
2463 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2465 /* If the farthest position reached is greater than current
2466 position, adjust the position and set length to pad out
2467 whats left. Otherwise just pad whats left.
2468 (for character array unit) */
2469 m
= dtp
->u
.p
.current_unit
->recl
2470 - dtp
->u
.p
.current_unit
->bytes_left
;
2473 length
= (int) (max_pos
- m
);
2474 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2475 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2478 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2480 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2484 /* Now that the current record has been padded out,
2485 determine where the next record in the array is. */
2486 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2488 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2490 /* Now seek to this record */
2491 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2493 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2495 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2499 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2505 /* If this is the last call to next_record move to the farthest
2506 position reached and set length to pad out the remainder
2507 of the record. (for character scaler unit) */
2510 m
= dtp
->u
.p
.current_unit
->recl
2511 - dtp
->u
.p
.current_unit
->bytes_left
;
2514 length
= (int) (max_pos
- m
);
2515 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2516 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2519 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2522 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2524 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2531 /* If this is the last call to next_record move to the farthest
2532 position reached in preparation for completing the record.
2536 m
= dtp
->u
.p
.current_unit
->recl
-
2537 dtp
->u
.p
.current_unit
->bytes_left
;
2540 length
= (int) (max_pos
- m
);
2541 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2545 const char crlf
[] = "\r\n";
2551 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2554 if (is_stream_io (dtp
))
2555 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2561 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2566 /* Position to the next record, which means moving to the end of the
2567 current record. This can happen under several different
2568 conditions. If the done flag is not set, we get ready to process
2572 next_record (st_parameter_dt
*dtp
, int done
)
2574 gfc_offset fp
; /* File position. */
2576 dtp
->u
.p
.current_unit
->read_bad
= 0;
2578 if (dtp
->u
.p
.mode
== READING
)
2579 next_record_r (dtp
);
2581 next_record_w (dtp
, done
);
2583 if (!is_stream_io (dtp
))
2585 /* Keep position up to date for INQUIRE */
2587 update_position (dtp
->u
.p
.current_unit
);
2589 dtp
->u
.p
.current_unit
->current_record
= 0;
2590 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2592 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2593 /* Calculate next record, rounding up partial records. */
2594 dtp
->u
.p
.current_unit
->last_record
=
2595 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2596 dtp
->u
.p
.current_unit
->recl
;
2599 dtp
->u
.p
.current_unit
->last_record
++;
2607 /* Finalize the current data transfer. For a nonadvancing transfer,
2608 this means advancing to the next record. For internal units close the
2609 stream associated with the unit. */
2612 finalize_transfer (st_parameter_dt
*dtp
)
2615 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2617 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2618 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2620 if (dtp
->u
.p
.eor_condition
)
2622 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2626 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2629 if ((dtp
->u
.p
.ionml
!= NULL
)
2630 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2632 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2633 namelist_read (dtp
);
2635 namelist_write (dtp
);
2638 dtp
->u
.p
.transfer
= NULL
;
2639 if (dtp
->u
.p
.current_unit
== NULL
)
2642 dtp
->u
.p
.eof_jump
= &eof_jump
;
2643 if (setjmp (eof_jump
))
2645 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2649 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2651 finish_list_read (dtp
);
2652 sfree (dtp
->u
.p
.current_unit
->s
);
2656 if (dtp
->u
.p
.mode
== WRITING
)
2657 dtp
->u
.p
.current_unit
->previous_nonadvancing_write
2658 = dtp
->u
.p
.advance_status
== ADVANCE_NO
;
2660 if (is_stream_io (dtp
))
2662 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2663 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
2664 next_record (dtp
, 1);
2666 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
2667 && file_position (dtp
->u
.p
.current_unit
->s
) >= dtp
->rec
)
2669 flush (dtp
->u
.p
.current_unit
->s
);
2670 sfree (dtp
->u
.p
.current_unit
->s
);
2675 dtp
->u
.p
.current_unit
->current_record
= 0;
2677 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2679 dtp
->u
.p
.seen_dollar
= 0;
2680 sfree (dtp
->u
.p
.current_unit
->s
);
2684 /* For non-advancing I/O, save the current maximum position for use in the
2685 next I/O operation if needed. */
2686 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2688 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2689 - dtp
->u
.p
.current_unit
->bytes_left
);
2690 dtp
->u
.p
.current_unit
->saved_pos
=
2691 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2692 flush (dtp
->u
.p
.current_unit
->s
);
2696 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2698 next_record (dtp
, 1);
2699 sfree (dtp
->u
.p
.current_unit
->s
);
2702 /* Transfer function for IOLENGTH. It doesn't actually do any
2703 data transfer, it just updates the length counter. */
2706 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2707 void *dest
__attribute__ ((unused
)),
2708 int kind
__attribute__((unused
)),
2709 size_t size
, size_t nelems
)
2711 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2712 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2716 /* Initialize the IOLENGTH data transfer. This function is in essence
2717 a very much simplified version of data_transfer_init(), because it
2718 doesn't have to deal with units at all. */
2721 iolength_transfer_init (st_parameter_dt
*dtp
)
2723 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2726 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2728 /* Set up the subroutine that will handle the transfers. */
2730 dtp
->u
.p
.transfer
= iolength_transfer
;
2734 /* Library entry point for the IOLENGTH form of the INQUIRE
2735 statement. The IOLENGTH form requires no I/O to be performed, but
2736 it must still be a runtime library call so that we can determine
2737 the iolength for dynamic arrays and such. */
2739 extern void st_iolength (st_parameter_dt
*);
2740 export_proto(st_iolength
);
2743 st_iolength (st_parameter_dt
*dtp
)
2745 library_start (&dtp
->common
);
2746 iolength_transfer_init (dtp
);
2749 extern void st_iolength_done (st_parameter_dt
*);
2750 export_proto(st_iolength_done
);
2753 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2756 if (dtp
->u
.p
.scratch
!= NULL
)
2757 free_mem (dtp
->u
.p
.scratch
);
2762 /* The READ statement. */
2764 extern void st_read (st_parameter_dt
*);
2765 export_proto(st_read
);
2768 st_read (st_parameter_dt
*dtp
)
2770 library_start (&dtp
->common
);
2772 data_transfer_init (dtp
, 1);
2774 /* Handle complications dealing with the endfile record. */
2776 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2777 switch (dtp
->u
.p
.current_unit
->endfile
)
2783 if (!is_internal_unit (dtp
))
2785 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2786 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2787 dtp
->u
.p
.current_unit
->current_record
= 0;
2792 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2793 dtp
->u
.p
.current_unit
->current_record
= 0;
2798 extern void st_read_done (st_parameter_dt
*);
2799 export_proto(st_read_done
);
2802 st_read_done (st_parameter_dt
*dtp
)
2804 finalize_transfer (dtp
);
2805 free_format_data (dtp
);
2807 if (dtp
->u
.p
.scratch
!= NULL
)
2808 free_mem (dtp
->u
.p
.scratch
);
2809 if (dtp
->u
.p
.current_unit
!= NULL
)
2810 unlock_unit (dtp
->u
.p
.current_unit
);
2812 free_internal_unit (dtp
);
2817 extern void st_write (st_parameter_dt
*);
2818 export_proto(st_write
);
2821 st_write (st_parameter_dt
*dtp
)
2823 library_start (&dtp
->common
);
2824 data_transfer_init (dtp
, 0);
2827 extern void st_write_done (st_parameter_dt
*);
2828 export_proto(st_write_done
);
2831 st_write_done (st_parameter_dt
*dtp
)
2833 finalize_transfer (dtp
);
2835 /* Deal with endfile conditions associated with sequential files. */
2837 if (dtp
->u
.p
.current_unit
!= NULL
2838 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2839 switch (dtp
->u
.p
.current_unit
->endfile
)
2841 case AT_ENDFILE
: /* Remain at the endfile record. */
2845 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2849 /* Get rid of whatever is after this record. */
2850 if (!is_internal_unit (dtp
))
2852 flush (dtp
->u
.p
.current_unit
->s
);
2853 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2854 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2856 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2860 free_format_data (dtp
);
2862 if (dtp
->u
.p
.scratch
!= NULL
)
2863 free_mem (dtp
->u
.p
.scratch
);
2864 if (dtp
->u
.p
.current_unit
!= NULL
)
2865 unlock_unit (dtp
->u
.p
.current_unit
);
2867 free_internal_unit (dtp
);
2872 /* Receives the scalar information for namelist objects and stores it
2873 in a linked list of namelist_info types. */
2875 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2876 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2877 export_proto(st_set_nml_var
);
2881 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2882 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2883 GFC_INTEGER_4 dtype
)
2885 namelist_info
*t1
= NULL
;
2887 size_t var_name_len
= strlen (var_name
);
2889 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2891 nml
->mem_pos
= var_addr
;
2893 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2894 memcpy (nml
->var_name
, var_name
, var_name_len
);
2895 nml
->var_name
[var_name_len
] = '\0';
2897 nml
->len
= (int) len
;
2898 nml
->string_length
= (index_type
) string_length
;
2900 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2901 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2902 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2904 if (nml
->var_rank
> 0)
2906 nml
->dim
= (descriptor_dimension
*)
2907 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2908 nml
->ls
= (array_loop_spec
*)
2909 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2919 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2921 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2922 dtp
->u
.p
.ionml
= nml
;
2926 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2931 /* Store the dimensional information for the namelist object. */
2932 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2933 index_type
, index_type
,
2935 export_proto(st_set_nml_var_dim
);
2938 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2939 index_type stride
, index_type lbound
,
2942 namelist_info
* nml
;
2947 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2949 nml
->dim
[n
].stride
= stride
;
2950 nml
->dim
[n
].lbound
= lbound
;
2951 nml
->dim
[n
].ubound
= ubound
;
2954 /* Reverse memcpy - used for byte swapping. */
2956 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2962 s
= (char *) src
+ n
- 1;
2964 /* Write with ascending order - this is likely faster
2965 on modern architectures because of write combining. */