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 memcpy (p
, q
, readlen
);
178 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
182 /* If we have a line without a terminating \n, drop through to
184 if (readlen
< 1 && n
== 0)
188 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
192 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
194 /* Unexpected end of line. */
196 /* If we see an EOR during non-advancing I/O, we need to skip
197 the rest of the I/O statement. Set the corresponding flag. */
198 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
199 dtp
->u
.p
.eor_condition
= 1;
202 /* If we encounter a CR, it might be a CRLF. */
203 if (*q
== '\r') /* Probably a CRLF */
206 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
207 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
208 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
209 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
214 /* Without padding, terminate the I/O statement without assigning
215 the value. With padding, the value still needs to be assigned,
216 so we can just continue with a short read. */
217 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
221 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
226 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
229 /* Short circuit the read if a comma is found during numeric input.
230 The flag is set to zero during character reads so that commas in
231 strings are not ignored */
233 if (dtp
->u
.p
.sf_read_comma
== 1)
235 notify_std (&dtp
->common
, GFC_STD_GNU
,
236 "Comma in formatted numeric read.");
243 dtp
->u
.p
.sf_seen_eor
= 0;
248 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
250 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
251 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
257 /* Function for reading the next couple of bytes from the current
258 file, advancing the current position. We return a pointer to a
259 buffer containing the bytes. We return NULL on end of record or
262 If the read is short, then it is because the current record does not
263 have enough data to satisfy the read request and the file was
264 opened with PAD=YES. The caller must assume tailing spaces for
268 read_block (st_parameter_dt
*dtp
, int *length
)
273 if (is_stream_io (dtp
))
275 if (sseek (dtp
->u
.p
.current_unit
->s
,
276 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
278 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
284 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
286 /* For preconnected units with default record length, set bytes left
287 to unit record length and proceed, otherwise error. */
288 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
289 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
290 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
293 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
295 /* Not enough data left. */
296 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
301 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
303 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
304 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
308 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
312 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
313 (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
||
314 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
))
316 source
= read_sf (dtp
, length
, 0);
317 dtp
->u
.p
.current_unit
->strm_pos
+=
318 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
321 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
324 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
326 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
327 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
329 if (nread
!= *length
)
330 { /* Short read, this shouldn't happen. */
331 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
335 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
340 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
346 /* Reads a block directly into application data space. This is for
347 unformatted files. */
350 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
352 size_t to_read_record
;
353 size_t have_read_record
;
354 size_t to_read_subrecord
;
355 size_t have_read_subrecord
;
358 if (is_stream_io (dtp
))
360 if (sseek (dtp
->u
.p
.current_unit
->s
,
361 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
363 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
367 to_read_record
= *nbytes
;
368 have_read_record
= to_read_record
;
369 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &have_read_record
) != 0)
371 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
375 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) have_read_record
;
377 if (to_read_record
!= have_read_record
)
379 /* Short read, e.g. if we hit EOF. For stream files,
380 we have to set the end-of-file condition. */
381 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
387 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
389 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
392 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
393 *nbytes
= to_read_record
;
399 to_read_record
= *nbytes
;
402 dtp
->u
.p
.current_unit
->bytes_left
-= to_read_record
;
404 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &to_read_record
) != 0)
406 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
410 if (to_read_record
!= *nbytes
)
412 /* Short read, e.g. if we hit EOF. Apparently, we read
413 more than was written to the last record. */
414 *nbytes
= to_read_record
;
420 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
426 /* Unformatted sequential. We loop over the subrecords, reading
427 until the request has been fulfilled or the record has run out
428 of continuation subrecords. */
430 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
432 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
436 /* Check whether we exceed the total record length. */
438 if (dtp
->u
.p
.current_unit
->flags
.has_recl
439 && (*nbytes
> (size_t) dtp
->u
.p
.current_unit
->bytes_left
))
441 to_read_record
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
446 to_read_record
= *nbytes
;
449 have_read_record
= 0;
453 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
454 < (gfc_offset
) to_read_record
)
456 to_read_subrecord
= (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
457 to_read_record
-= to_read_subrecord
;
461 to_read_subrecord
= to_read_record
;
465 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= to_read_subrecord
;
467 have_read_subrecord
= to_read_subrecord
;
468 if (sread (dtp
->u
.p
.current_unit
->s
, buf
+ have_read_record
,
469 &have_read_subrecord
) != 0)
471 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
475 have_read_record
+= have_read_subrecord
;
477 if (to_read_subrecord
!= have_read_subrecord
)
480 /* Short read, e.g. if we hit EOF. This means the record
481 structure has been corrupted, or the trailing record
482 marker would still be present. */
484 *nbytes
= have_read_record
;
485 generate_error (&dtp
->common
, LIBERROR_CORRUPT_FILE
, NULL
);
489 if (to_read_record
> 0)
491 if (dtp
->u
.p
.current_unit
->continued
)
493 next_record_r_unf (dtp
, 0);
498 /* Let's make sure the file position is correctly pre-positioned
499 for the next read statement. */
501 dtp
->u
.p
.current_unit
->current_record
= 0;
502 next_record_r_unf (dtp
, 0);
503 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
509 /* Normal exit, the read request has been fulfilled. */
514 dtp
->u
.p
.current_unit
->bytes_left
-= have_read_record
;
517 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
524 /* Function for writing a block of bytes to the current file at the
525 current position, advancing the file pointer. We are given a length
526 and return a pointer to a buffer that the caller must (completely)
527 fill in. Returns NULL on error. */
530 write_block (st_parameter_dt
*dtp
, int length
)
534 if (is_stream_io (dtp
))
536 if (sseek (dtp
->u
.p
.current_unit
->s
,
537 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
539 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
545 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
547 /* For preconnected units with default record length, set bytes left
548 to unit record length and proceed, otherwise error. */
549 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
550 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
551 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
552 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
555 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
560 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
563 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
567 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
571 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
572 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
574 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
575 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
577 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
583 /* High level interface to swrite(), taking care of errors. This is only
584 called for unformatted files. There are three cases to consider:
585 Stream I/O, unformatted direct, unformatted sequential. */
588 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
591 size_t have_written
, to_write_subrecord
;
596 if (is_stream_io (dtp
))
598 if (sseek (dtp
->u
.p
.current_unit
->s
,
599 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
601 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
605 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
607 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
611 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
616 /* Unformatted direct access. */
618 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
620 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
622 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
626 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
628 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
632 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
633 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
639 /* Unformatted sequential. */
643 if (dtp
->u
.p
.current_unit
->flags
.has_recl
644 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
646 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
658 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
659 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
661 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
662 (gfc_offset
) to_write_subrecord
;
664 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
665 &to_write_subrecord
) != 0)
667 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
671 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
672 nbytes
-= to_write_subrecord
;
673 have_written
+= to_write_subrecord
;
678 next_record_w_unf (dtp
, 1);
681 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
684 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
691 /* Master function for unformatted reads. */
694 unformatted_read (st_parameter_dt
*dtp
, bt type
,
695 void *dest
, int kind
__attribute__((unused
)),
696 size_t size
, size_t nelems
)
700 /* Currently, character implies size=1. */
701 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
702 || size
== 1 || type
== BT_CHARACTER
)
705 read_block_direct (dtp
, dest
, &sz
);
712 /* Break up complex into its constituent reals. */
713 if (type
== BT_COMPLEX
)
720 /* By now, all complex variables have been split into their
721 constituent reals. */
723 for (i
=0; i
<nelems
; i
++)
725 read_block_direct (dtp
, buffer
, &size
);
726 reverse_memcpy (p
, buffer
, size
);
733 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
734 bytes on 64 bit machines. The unused bytes are not initialized and never
735 used, which can show an error with memory checking analyzers like
739 unformatted_write (st_parameter_dt
*dtp
, bt type
,
740 void *source
, int kind
__attribute__((unused
)),
741 size_t size
, size_t nelems
)
743 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
744 size
== 1 || type
== BT_CHARACTER
)
747 write_buf (dtp
, source
, size
);
755 /* Break up complex into its constituent reals. */
756 if (type
== BT_COMPLEX
)
764 /* By now, all complex variables have been split into their
765 constituent reals. */
768 for (i
=0; i
<nelems
; i
++)
770 reverse_memcpy(buffer
, p
, size
);
772 write_buf (dtp
, buffer
, size
);
778 /* Return a pointer to the name of a type. */
803 internal_error (NULL
, "type_name(): Bad type");
810 /* Write a constant string to the output.
811 This is complicated because the string can have doubled delimiters
812 in it. The length in the format node is the true length. */
815 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
817 char c
, delimiter
, *p
, *q
;
820 length
= f
->u
.string
.length
;
824 p
= write_block (dtp
, length
);
831 for (; length
> 0; length
--)
834 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
835 q
++; /* Skip the doubled delimiter. */
840 /* Given actual and expected types in a formatted data transfer, make
841 sure they agree. If not, an error message is generated. Returns
842 nonzero if something went wrong. */
845 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
849 if (actual
== expected
)
852 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
853 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
855 format_error (dtp
, f
, buffer
);
860 /* This subroutine is the main loop for a formatted data transfer
861 statement. It would be natural to implement this as a coroutine
862 with the user program, but C makes that awkward. We loop,
863 processing format elements. When we actually have to transfer
864 data instead of just setting flags, we return control to the user
865 program which calls a subroutine that supplies the address and type
866 of the next element, then comes back here to process it. */
869 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
872 char scratch
[SCRATCH_SIZE
];
877 int consume_data_flag
;
879 /* Change a complex data item into a pair of reals. */
881 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
882 if (type
== BT_COMPLEX
)
888 /* If there's an EOR condition, we simulate finalizing the transfer
890 if (dtp
->u
.p
.eor_condition
)
893 /* Set this flag so that commas in reads cause the read to complete before
894 the entire field has been read. The next read field will start right after
895 the comma in the stream. (Set to 0 for character reads). */
896 dtp
->u
.p
.sf_read_comma
= 1;
898 dtp
->u
.p
.line_buffer
= scratch
;
901 /* If reversion has occurred and there is another real data item,
902 then we have to move to the next record. */
903 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
905 dtp
->u
.p
.reversion_flag
= 0;
906 next_record (dtp
, 0);
909 consume_data_flag
= 1 ;
910 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
913 f
= next_format (dtp
);
916 /* No data descriptors left. */
918 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
919 "Insufficient data descriptors in format after reversion");
923 /* Now discharge T, TR and X movements to the right. This is delayed
924 until a data producing format to suppress trailing spaces. */
927 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
928 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
929 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
930 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
931 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
934 if (dtp
->u
.p
.skips
> 0)
936 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
937 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
938 - dtp
->u
.p
.current_unit
->bytes_left
);
940 if (dtp
->u
.p
.skips
< 0)
942 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
943 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
945 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
948 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
949 - dtp
->u
.p
.current_unit
->bytes_left
);
951 if (is_stream_io(dtp
))
959 if (require_type (dtp
, BT_INTEGER
, type
, f
))
962 if (dtp
->u
.p
.mode
== READING
)
963 read_decimal (dtp
, f
, p
, len
);
965 write_i (dtp
, f
, p
, len
);
973 if (compile_options
.allow_std
< GFC_STD_GNU
974 && require_type (dtp
, BT_INTEGER
, type
, f
))
977 if (dtp
->u
.p
.mode
== READING
)
978 read_radix (dtp
, f
, p
, len
, 2);
980 write_b (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
, 8);
995 write_o (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
, 16);
1010 write_z (dtp
, f
, p
, len
);
1018 if (dtp
->u
.p
.mode
== READING
)
1019 read_a (dtp
, f
, p
, len
);
1021 write_a (dtp
, f
, p
, len
);
1029 if (dtp
->u
.p
.mode
== READING
)
1030 read_l (dtp
, f
, p
, len
);
1032 write_l (dtp
, f
, p
, len
);
1039 if (require_type (dtp
, BT_REAL
, type
, f
))
1042 if (dtp
->u
.p
.mode
== READING
)
1043 read_f (dtp
, f
, p
, len
);
1045 write_d (dtp
, f
, p
, len
);
1052 if (require_type (dtp
, BT_REAL
, type
, f
))
1055 if (dtp
->u
.p
.mode
== READING
)
1056 read_f (dtp
, f
, p
, len
);
1058 write_e (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_en (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_es (dtp
, f
, p
, len
);
1090 if (require_type (dtp
, BT_REAL
, type
, f
))
1093 if (dtp
->u
.p
.mode
== READING
)
1094 read_f (dtp
, f
, p
, len
);
1096 write_f (dtp
, f
, p
, len
);
1103 if (dtp
->u
.p
.mode
== READING
)
1107 read_decimal (dtp
, f
, p
, len
);
1110 read_l (dtp
, f
, p
, len
);
1113 read_a (dtp
, f
, p
, len
);
1116 read_f (dtp
, f
, p
, len
);
1125 write_i (dtp
, f
, p
, len
);
1128 write_l (dtp
, f
, p
, len
);
1131 write_a (dtp
, f
, p
, len
);
1134 write_d (dtp
, f
, p
, len
);
1138 internal_error (&dtp
->common
,
1139 "formatted_transfer(): Bad type");
1145 consume_data_flag
= 0 ;
1146 if (dtp
->u
.p
.mode
== READING
)
1148 format_error (dtp
, f
, "Constant string in input format");
1151 write_constant_string (dtp
, f
);
1154 /* Format codes that don't transfer data. */
1157 consume_data_flag
= 0;
1159 dtp
->u
.p
.skips
+= f
->u
.n
;
1160 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1161 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1163 /* Writes occur just before the switch on f->format, above, so
1164 that trailing blanks are suppressed, unless we are doing a
1165 non-advancing write in which case we want to output the blanks
1167 if (dtp
->u
.p
.mode
== WRITING
1168 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1170 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1171 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1174 if (dtp
->u
.p
.mode
== READING
)
1175 read_x (dtp
, f
->u
.n
);
1181 consume_data_flag
= 0;
1183 if (f
->format
== FMT_TL
)
1186 /* Handle the special case when no bytes have been used yet.
1187 Cannot go below zero. */
1188 if (bytes_used
== 0)
1190 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1191 dtp
->u
.p
.skips
-= f
->u
.n
;
1192 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1195 pos
= bytes_used
- f
->u
.n
;
1199 if (dtp
->u
.p
.mode
== READING
)
1202 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1205 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1206 left tab limit. We do not check if the position has gone
1207 beyond the end of record because a subsequent tab could
1208 bring us back again. */
1209 pos
= pos
< 0 ? 0 : pos
;
1211 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1212 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1213 + pos
- dtp
->u
.p
.max_pos
;
1214 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1215 ? 0 : dtp
->u
.p
.pending_spaces
;
1217 if (dtp
->u
.p
.skips
== 0)
1220 /* Writes occur just before the switch on f->format, above, so that
1221 trailing blanks are suppressed. */
1222 if (dtp
->u
.p
.mode
== READING
)
1224 /* Adjust everything for end-of-record condition */
1225 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1227 if (dtp
->u
.p
.sf_seen_eor
== 2)
1229 /* The EOR was a CRLF (two bytes wide). */
1230 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1231 dtp
->u
.p
.skips
-= 2;
1235 /* The EOR marker was only one byte wide. */
1236 dtp
->u
.p
.current_unit
->bytes_left
--;
1240 dtp
->u
.p
.sf_seen_eor
= 0;
1242 if (dtp
->u
.p
.skips
< 0)
1244 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1245 dtp
->u
.p
.current_unit
->bytes_left
1246 -= (gfc_offset
) dtp
->u
.p
.skips
;
1247 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1250 read_x (dtp
, dtp
->u
.p
.skips
);
1256 consume_data_flag
= 0 ;
1257 dtp
->u
.p
.sign_status
= SIGN_S
;
1261 consume_data_flag
= 0 ;
1262 dtp
->u
.p
.sign_status
= SIGN_SS
;
1266 consume_data_flag
= 0 ;
1267 dtp
->u
.p
.sign_status
= SIGN_SP
;
1271 consume_data_flag
= 0 ;
1272 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1276 consume_data_flag
= 0 ;
1277 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1281 consume_data_flag
= 0 ;
1282 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1286 consume_data_flag
= 0 ;
1287 dtp
->u
.p
.seen_dollar
= 1;
1291 consume_data_flag
= 0 ;
1292 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1293 next_record (dtp
, 0);
1297 /* A colon descriptor causes us to exit this loop (in
1298 particular preventing another / descriptor from being
1299 processed) unless there is another data item to be
1301 consume_data_flag
= 0 ;
1307 internal_error (&dtp
->common
, "Bad format node");
1310 /* Free a buffer that we had to allocate during a sequential
1311 formatted read of a block that was larger than the static
1314 if (dtp
->u
.p
.line_buffer
!= scratch
)
1316 free_mem (dtp
->u
.p
.line_buffer
);
1317 dtp
->u
.p
.line_buffer
= scratch
;
1320 /* Adjust the item count and data pointer. */
1322 if ((consume_data_flag
> 0) && (n
> 0))
1325 p
= ((char *) p
) + size
;
1328 if (dtp
->u
.p
.mode
== READING
)
1331 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1332 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1338 /* Come here when we need a data descriptor but don't have one. We
1339 push the current format node back onto the input, then return and
1340 let the user program call us back with the data. */
1342 unget_format (dtp
, f
);
1346 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1347 size_t size
, size_t nelems
)
1354 /* Big loop over all the elements. */
1355 for (elem
= 0; elem
< nelems
; elem
++)
1357 dtp
->u
.p
.item_count
++;
1358 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1364 /* Data transfer entry points. The type of the data entity is
1365 implicit in the subroutine call. This prevents us from having to
1366 share a common enum with the compiler. */
1369 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1371 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1373 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1378 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1381 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1383 size
= size_from_real_kind (kind
);
1384 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1389 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1391 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1393 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1398 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1400 static char *empty_string
[0];
1402 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1405 /* Strings of zero length can have p == NULL, which confuses the
1406 transfer routines into thinking we need more data elements. To avoid
1407 this, we give them a nice pointer. */
1408 if (len
== 0 && p
== NULL
)
1411 /* Currently we support only 1 byte chars, and the library is a bit
1412 confused of character kind vs. length, so we kludge it by setting
1414 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1419 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1422 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1424 size
= size_from_complex_kind (kind
);
1425 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1430 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1431 gfc_charlen_type charlen
)
1433 index_type count
[GFC_MAX_DIMENSIONS
];
1434 index_type extent
[GFC_MAX_DIMENSIONS
];
1435 index_type stride
[GFC_MAX_DIMENSIONS
];
1436 index_type stride0
, rank
, size
, type
, n
;
1441 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1444 type
= GFC_DESCRIPTOR_TYPE (desc
);
1445 size
= GFC_DESCRIPTOR_SIZE (desc
);
1447 /* FIXME: What a kludge: Array descriptors and the IO library use
1448 different enums for types. */
1451 case GFC_DTYPE_UNKNOWN
:
1452 iotype
= BT_NULL
; /* Is this correct? */
1454 case GFC_DTYPE_INTEGER
:
1455 iotype
= BT_INTEGER
;
1457 case GFC_DTYPE_LOGICAL
:
1458 iotype
= BT_LOGICAL
;
1460 case GFC_DTYPE_REAL
:
1463 case GFC_DTYPE_COMPLEX
:
1464 iotype
= BT_COMPLEX
;
1466 case GFC_DTYPE_CHARACTER
:
1467 iotype
= BT_CHARACTER
;
1468 /* FIXME: Currently dtype contains the charlen, which is
1469 clobbered if charlen > 2**24. That's why we use a separate
1470 argument for the charlen. However, if we want to support
1471 non-8-bit charsets we need to fix dtype to contain
1472 sizeof(chartype) and fix the code below. */
1476 case GFC_DTYPE_DERIVED
:
1477 internal_error (&dtp
->common
,
1478 "Derived type I/O should have been handled via the frontend.");
1481 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1484 rank
= GFC_DESCRIPTOR_RANK (desc
);
1485 for (n
= 0; n
< rank
; n
++)
1488 stride
[n
] = desc
->dim
[n
].stride
;
1489 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1491 /* If the extent of even one dimension is zero, then the entire
1492 array section contains zero elements, so we return. */
1497 stride0
= stride
[0];
1499 /* If the innermost dimension has stride 1, we can do the transfer
1500 in contiguous chunks. */
1506 data
= GFC_DESCRIPTOR_DATA (desc
);
1510 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1511 data
+= stride0
* size
* tsize
;
1514 while (count
[n
] == extent
[n
])
1517 data
-= stride
[n
] * extent
[n
] * size
;
1527 data
+= stride
[n
] * size
;
1534 /* Preposition a sequential unformatted file while reading. */
1537 us_read (st_parameter_dt
*dtp
, int continued
)
1546 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1549 if (compile_options
.record_marker
== 0)
1550 n
= sizeof (GFC_INTEGER_4
);
1552 n
= compile_options
.record_marker
;
1556 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1560 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1561 return; /* end of file */
1564 if (p
== NULL
|| n
!= nr
)
1566 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1570 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1571 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1575 case sizeof(GFC_INTEGER_4
):
1576 memcpy (&i4
, p
, sizeof (i4
));
1580 case sizeof(GFC_INTEGER_8
):
1581 memcpy (&i8
, p
, sizeof (i8
));
1586 runtime_error ("Illegal value for record marker");
1593 case sizeof(GFC_INTEGER_4
):
1594 reverse_memcpy (&i4
, p
, sizeof (i4
));
1598 case sizeof(GFC_INTEGER_8
):
1599 reverse_memcpy (&i8
, p
, sizeof (i8
));
1604 runtime_error ("Illegal value for record marker");
1610 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1611 dtp
->u
.p
.current_unit
->continued
= 0;
1615 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1616 dtp
->u
.p
.current_unit
->continued
= 1;
1620 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1624 /* Preposition a sequential unformatted file while writing. This
1625 amount to writing a bogus length that will be filled in later. */
1628 us_write (st_parameter_dt
*dtp
, int continued
)
1635 if (compile_options
.record_marker
== 0)
1636 nbytes
= sizeof (GFC_INTEGER_4
);
1638 nbytes
= compile_options
.record_marker
;
1640 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1641 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1643 /* For sequential unformatted, if RECL= was not specified in the OPEN
1644 we write until we have more bytes than can fit in the subrecord
1645 markers, then we write a new subrecord. */
1647 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1648 dtp
->u
.p
.current_unit
->recl_subrecord
;
1649 dtp
->u
.p
.current_unit
->continued
= continued
;
1653 /* Position to the next record prior to transfer. We are assumed to
1654 be before the next record. We also calculate the bytes in the next
1658 pre_position (st_parameter_dt
*dtp
)
1660 if (dtp
->u
.p
.current_unit
->current_record
)
1661 return; /* Already positioned. */
1663 switch (current_mode (dtp
))
1665 case FORMATTED_STREAM
:
1666 case UNFORMATTED_STREAM
:
1667 /* There are no records with stream I/O. Set the default position
1668 to the beginning of the file if no position was specified. */
1669 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1670 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1673 case UNFORMATTED_SEQUENTIAL
:
1674 if (dtp
->u
.p
.mode
== READING
)
1681 case FORMATTED_SEQUENTIAL
:
1682 case FORMATTED_DIRECT
:
1683 case UNFORMATTED_DIRECT
:
1684 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1688 dtp
->u
.p
.current_unit
->current_record
= 1;
1692 /* Initialize things for a data transfer. This code is common for
1693 both reading and writing. */
1696 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1698 unit_flags u_flags
; /* Used for creating a unit if needed. */
1699 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1700 namelist_info
*ionml
;
1702 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1703 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1704 dtp
->u
.p
.ionml
= ionml
;
1705 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1707 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1710 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1711 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1713 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1714 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1715 { /* Open the unit with some default flags. */
1716 st_parameter_open opp
;
1719 if (dtp
->common
.unit
< 0)
1721 close_unit (dtp
->u
.p
.current_unit
);
1722 dtp
->u
.p
.current_unit
= NULL
;
1723 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1724 "Bad unit number in OPEN statement");
1727 memset (&u_flags
, '\0', sizeof (u_flags
));
1728 u_flags
.access
= ACCESS_SEQUENTIAL
;
1729 u_flags
.action
= ACTION_READWRITE
;
1731 /* Is it unformatted? */
1732 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1733 | IOPARM_DT_IONML_SET
)))
1734 u_flags
.form
= FORM_UNFORMATTED
;
1736 u_flags
.form
= FORM_UNSPECIFIED
;
1738 u_flags
.delim
= DELIM_UNSPECIFIED
;
1739 u_flags
.blank
= BLANK_UNSPECIFIED
;
1740 u_flags
.pad
= PAD_UNSPECIFIED
;
1741 u_flags
.status
= STATUS_UNKNOWN
;
1743 conv
= get_unformatted_convert (dtp
->common
.unit
);
1745 if (conv
== GFC_CONVERT_NONE
)
1746 conv
= compile_options
.convert
;
1748 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1749 and 1 on big-endian machines. */
1752 case GFC_CONVERT_NATIVE
:
1753 case GFC_CONVERT_SWAP
:
1756 case GFC_CONVERT_BIG
:
1757 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1760 case GFC_CONVERT_LITTLE
:
1761 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1765 internal_error (&opp
.common
, "Illegal value for CONVERT");
1769 u_flags
.convert
= conv
;
1771 opp
.common
= dtp
->common
;
1772 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1773 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1774 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1775 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1776 if (dtp
->u
.p
.current_unit
== NULL
)
1780 /* Check the action. */
1782 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1784 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1785 "Cannot read from file opened for WRITE");
1789 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1791 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1792 "Cannot write to file opened for READ");
1796 dtp
->u
.p
.first_item
= 1;
1798 /* Check the format. */
1800 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1803 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1804 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1807 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1808 "Format present for UNFORMATTED data transfer");
1812 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1814 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1815 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1816 "A format cannot be specified with a namelist");
1818 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1819 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1821 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1822 "Missing format for FORMATTED data transfer");
1825 if (is_internal_unit (dtp
)
1826 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1828 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1829 "Internal file cannot be accessed by UNFORMATTED "
1834 /* Check the record or position number. */
1836 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1837 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1839 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1840 "Direct access data transfer requires record number");
1844 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1845 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1847 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1848 "Record number not allowed for sequential access data transfer");
1852 /* Process the ADVANCE option. */
1854 dtp
->u
.p
.advance_status
1855 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1856 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1857 "Bad ADVANCE parameter in data transfer statement");
1859 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1861 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1863 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1864 "ADVANCE specification conflicts with sequential access");
1868 if (is_internal_unit (dtp
))
1870 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1871 "ADVANCE specification conflicts with internal file");
1875 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1876 != IOPARM_DT_HAS_FORMAT
)
1878 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1879 "ADVANCE specification requires an explicit format");
1886 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1888 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1889 "EOR specification requires an ADVANCE specification "
1894 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1896 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1897 "SIZE specification requires an ADVANCE specification of NO");
1902 { /* Write constraints. */
1903 if ((cf
& IOPARM_END
) != 0)
1905 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1906 "END specification cannot appear in a write statement");
1910 if ((cf
& IOPARM_EOR
) != 0)
1912 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1913 "EOR specification cannot appear in a write statement");
1917 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1919 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1920 "SIZE specification cannot appear in a write statement");
1925 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1926 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1928 /* Sanity checks on the record number. */
1929 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1933 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1934 "Record number must be positive");
1938 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1940 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1941 "Record number too large");
1945 /* Check to see if we might be reading what we wrote before */
1947 if (dtp
->u
.p
.mode
== READING
1948 && dtp
->u
.p
.current_unit
->mode
== WRITING
1949 && !is_internal_unit (dtp
))
1950 flush(dtp
->u
.p
.current_unit
->s
);
1952 /* Check whether the record exists to be read. Only
1953 a partial record needs to exist. */
1955 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1956 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1958 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1959 "Non-existing record number");
1963 /* Position the file. */
1964 if (!is_stream_io (dtp
))
1966 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1967 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1969 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1974 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1978 /* Overwriting an existing sequential file ?
1979 it is always safe to truncate the file on the first write */
1980 if (dtp
->u
.p
.mode
== WRITING
1981 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1982 && dtp
->u
.p
.current_unit
->last_record
== 0
1983 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1984 struncate(dtp
->u
.p
.current_unit
->s
);
1986 /* Bugware for badly written mixed C-Fortran I/O. */
1987 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1989 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1991 /* Set the initial value of flags. */
1993 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1994 dtp
->u
.p
.sign_status
= SIGN_S
;
1996 /* Set the maximum position reached from the previous I/O operation. This
1997 could be greater than zero from a previous non-advancing write. */
1998 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2002 /* Set up the subroutine that will handle the transfers. */
2006 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2007 dtp
->u
.p
.transfer
= unformatted_read
;
2010 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2011 dtp
->u
.p
.transfer
= list_formatted_read
;
2013 dtp
->u
.p
.transfer
= formatted_transfer
;
2018 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2019 dtp
->u
.p
.transfer
= unformatted_write
;
2022 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2023 dtp
->u
.p
.transfer
= list_formatted_write
;
2025 dtp
->u
.p
.transfer
= formatted_transfer
;
2029 /* Make sure that we don't do a read after a nonadvancing write. */
2033 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2035 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2036 "Cannot READ after a nonadvancing WRITE");
2042 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2043 dtp
->u
.p
.current_unit
->read_bad
= 1;
2046 /* Start the data transfer if we are doing a formatted transfer. */
2047 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2048 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2049 && dtp
->u
.p
.ionml
== NULL
)
2050 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2053 /* Initialize an array_loop_spec given the array descriptor. The function
2054 returns the index of the last element of the array. */
2057 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2059 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2064 for (i
=0; i
<rank
; i
++)
2066 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2067 ls
[i
].start
= desc
->dim
[i
].lbound
;
2068 ls
[i
].end
= desc
->dim
[i
].ubound
;
2069 ls
[i
].step
= desc
->dim
[i
].stride
;
2071 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2072 * desc
->dim
[i
].stride
;
2077 /* Determine the index to the next record in an internal unit array by
2078 by incrementing through the array_loop_spec. TODO: Implement handling
2079 negative strides. */
2082 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2090 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2095 if (ls
[i
].idx
> ls
[i
].end
)
2097 ls
[i
].idx
= ls
[i
].start
;
2103 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2111 /* Skip to the end of the current record, taking care of an optional
2112 record marker of size bytes. If the file is not seekable, we
2113 read chunks of size MAX_READ until we get to the right
2116 #define MAX_READ 4096
2119 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2122 int rlength
, length
;
2125 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2126 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2129 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2131 new = file_position (dtp
->u
.p
.current_unit
->s
)
2132 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2134 /* Direct access files do not generate END conditions,
2136 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2137 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2140 { /* Seek by reading data. */
2141 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2144 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2145 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2147 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2150 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2154 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2162 /* Advance to the next record reading unformatted files, taking
2163 care of subrecords. If complete_record is nonzero, we loop
2164 until all subrecords are cleared. */
2167 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2171 bytes
= compile_options
.record_marker
== 0 ?
2172 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2177 /* Skip over tail */
2179 skip_record (dtp
, bytes
);
2181 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2188 /* Space to the next record for read mode. */
2191 next_record_r (st_parameter_dt
*dtp
)
2194 int length
, bytes_left
;
2197 switch (current_mode (dtp
))
2199 /* No records in unformatted STREAM I/O. */
2200 case UNFORMATTED_STREAM
:
2203 case UNFORMATTED_SEQUENTIAL
:
2204 next_record_r_unf (dtp
, 1);
2205 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2208 case FORMATTED_DIRECT
:
2209 case UNFORMATTED_DIRECT
:
2210 skip_record (dtp
, 0);
2213 case FORMATTED_STREAM
:
2214 case FORMATTED_SEQUENTIAL
:
2216 /* sf_read has already terminated input because of an '\n' */
2217 if (dtp
->u
.p
.sf_seen_eor
)
2219 dtp
->u
.p
.sf_seen_eor
= 0;
2223 if (is_internal_unit (dtp
))
2225 if (is_array_io (dtp
))
2227 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2229 /* Now seek to this record. */
2230 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2231 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2233 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2236 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2240 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2241 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2243 dtp
->u
.p
.current_unit
->bytes_left
2244 = dtp
->u
.p
.current_unit
->recl
;
2250 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2254 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2260 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2264 if (is_stream_io (dtp
))
2265 dtp
->u
.p
.current_unit
->strm_pos
++;
2272 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2273 && !dtp
->u
.p
.namelist_mode
2274 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2275 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2276 file_position (dtp
->u
.p
.current_unit
->s
)))
2277 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2282 /* Small utility function to write a record marker, taking care of
2283 byte swapping and of choosing the correct size. */
2286 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2291 char p
[sizeof (GFC_INTEGER_8
)];
2293 if (compile_options
.record_marker
== 0)
2294 len
= sizeof (GFC_INTEGER_4
);
2296 len
= compile_options
.record_marker
;
2298 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2299 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2303 case sizeof (GFC_INTEGER_4
):
2305 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2308 case sizeof (GFC_INTEGER_8
):
2310 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2314 runtime_error ("Illegal value for record marker");
2322 case sizeof (GFC_INTEGER_4
):
2324 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2325 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2328 case sizeof (GFC_INTEGER_8
):
2330 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2331 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2335 runtime_error ("Illegal value for record marker");
2342 /* Position to the next (sub)record in write mode for
2343 unformatted sequential files. */
2346 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2348 gfc_offset c
, m
, m_write
;
2349 size_t record_marker
;
2351 /* Bytes written. */
2352 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2353 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2354 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2356 /* Write the length tail. If we finish a record containing
2357 subrecords, we write out the negative length. */
2359 if (dtp
->u
.p
.current_unit
->continued
)
2364 if (write_us_marker (dtp
, m_write
) != 0)
2367 if (compile_options
.record_marker
== 0)
2368 record_marker
= sizeof (GFC_INTEGER_4
);
2370 record_marker
= compile_options
.record_marker
;
2372 /* Seek to the head and overwrite the bogus length with the real
2375 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2384 if (write_us_marker (dtp
, m_write
) != 0)
2387 /* Seek past the end of the current record. */
2389 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2395 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2400 /* Position to the next record in write mode. */
2403 next_record_w (st_parameter_dt
*dtp
, int done
)
2405 gfc_offset m
, record
, max_pos
;
2409 /* Zero counters for X- and T-editing. */
2410 max_pos
= dtp
->u
.p
.max_pos
;
2411 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2413 switch (current_mode (dtp
))
2415 /* No records in unformatted STREAM I/O. */
2416 case UNFORMATTED_STREAM
:
2419 case FORMATTED_DIRECT
:
2420 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2423 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2424 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2429 case UNFORMATTED_DIRECT
:
2430 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2434 case UNFORMATTED_SEQUENTIAL
:
2435 next_record_w_unf (dtp
, 0);
2436 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2439 case FORMATTED_STREAM
:
2440 case FORMATTED_SEQUENTIAL
:
2442 if (is_internal_unit (dtp
))
2444 if (is_array_io (dtp
))
2446 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2448 /* If the farthest position reached is greater than current
2449 position, adjust the position and set length to pad out
2450 whats left. Otherwise just pad whats left.
2451 (for character array unit) */
2452 m
= dtp
->u
.p
.current_unit
->recl
2453 - dtp
->u
.p
.current_unit
->bytes_left
;
2456 length
= (int) (max_pos
- m
);
2457 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2458 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2461 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2463 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2467 /* Now that the current record has been padded out,
2468 determine where the next record in the array is. */
2469 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2471 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2473 /* Now seek to this record */
2474 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2476 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2478 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2482 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2488 /* If this is the last call to next_record move to the farthest
2489 position reached and set length to pad out the remainder
2490 of the record. (for character scaler unit) */
2493 m
= dtp
->u
.p
.current_unit
->recl
2494 - dtp
->u
.p
.current_unit
->bytes_left
;
2497 length
= (int) (max_pos
- m
);
2498 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2499 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2502 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2505 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2507 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2514 /* If this is the last call to next_record move to the farthest
2515 position reached in preparation for completing the record.
2519 m
= dtp
->u
.p
.current_unit
->recl
-
2520 dtp
->u
.p
.current_unit
->bytes_left
;
2523 length
= (int) (max_pos
- m
);
2524 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2528 const char crlf
[] = "\r\n";
2534 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2537 if (is_stream_io (dtp
))
2538 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2544 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2549 /* Position to the next record, which means moving to the end of the
2550 current record. This can happen under several different
2551 conditions. If the done flag is not set, we get ready to process
2555 next_record (st_parameter_dt
*dtp
, int done
)
2557 gfc_offset fp
; /* File position. */
2559 dtp
->u
.p
.current_unit
->read_bad
= 0;
2561 if (dtp
->u
.p
.mode
== READING
)
2562 next_record_r (dtp
);
2564 next_record_w (dtp
, done
);
2566 if (!is_stream_io (dtp
))
2568 /* Keep position up to date for INQUIRE */
2570 update_position (dtp
->u
.p
.current_unit
);
2572 dtp
->u
.p
.current_unit
->current_record
= 0;
2573 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2575 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2576 /* Calculate next record, rounding up partial records. */
2577 dtp
->u
.p
.current_unit
->last_record
=
2578 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2579 dtp
->u
.p
.current_unit
->recl
;
2582 dtp
->u
.p
.current_unit
->last_record
++;
2590 /* Finalize the current data transfer. For a nonadvancing transfer,
2591 this means advancing to the next record. For internal units close the
2592 stream associated with the unit. */
2595 finalize_transfer (st_parameter_dt
*dtp
)
2598 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2600 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2601 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2603 if (dtp
->u
.p
.eor_condition
)
2605 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2609 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2612 if ((dtp
->u
.p
.ionml
!= NULL
)
2613 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2615 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2616 namelist_read (dtp
);
2618 namelist_write (dtp
);
2621 dtp
->u
.p
.transfer
= NULL
;
2622 if (dtp
->u
.p
.current_unit
== NULL
)
2625 dtp
->u
.p
.eof_jump
= &eof_jump
;
2626 if (setjmp (eof_jump
))
2628 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2632 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2634 finish_list_read (dtp
);
2635 sfree (dtp
->u
.p
.current_unit
->s
);
2639 if (is_stream_io (dtp
))
2641 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2642 next_record (dtp
, 1);
2643 flush (dtp
->u
.p
.current_unit
->s
);
2644 sfree (dtp
->u
.p
.current_unit
->s
);
2648 dtp
->u
.p
.current_unit
->current_record
= 0;
2650 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2652 dtp
->u
.p
.seen_dollar
= 0;
2653 sfree (dtp
->u
.p
.current_unit
->s
);
2657 /* For non-advancing I/O, save the current maximum position for use in the
2658 next I/O operation if needed. */
2659 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2661 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2662 - dtp
->u
.p
.current_unit
->bytes_left
);
2663 dtp
->u
.p
.current_unit
->saved_pos
=
2664 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2665 flush (dtp
->u
.p
.current_unit
->s
);
2669 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2671 next_record (dtp
, 1);
2672 sfree (dtp
->u
.p
.current_unit
->s
);
2675 /* Transfer function for IOLENGTH. It doesn't actually do any
2676 data transfer, it just updates the length counter. */
2679 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2680 void *dest
__attribute__ ((unused
)),
2681 int kind
__attribute__((unused
)),
2682 size_t size
, size_t nelems
)
2684 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2685 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2689 /* Initialize the IOLENGTH data transfer. This function is in essence
2690 a very much simplified version of data_transfer_init(), because it
2691 doesn't have to deal with units at all. */
2694 iolength_transfer_init (st_parameter_dt
*dtp
)
2696 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2699 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2701 /* Set up the subroutine that will handle the transfers. */
2703 dtp
->u
.p
.transfer
= iolength_transfer
;
2707 /* Library entry point for the IOLENGTH form of the INQUIRE
2708 statement. The IOLENGTH form requires no I/O to be performed, but
2709 it must still be a runtime library call so that we can determine
2710 the iolength for dynamic arrays and such. */
2712 extern void st_iolength (st_parameter_dt
*);
2713 export_proto(st_iolength
);
2716 st_iolength (st_parameter_dt
*dtp
)
2718 library_start (&dtp
->common
);
2719 iolength_transfer_init (dtp
);
2722 extern void st_iolength_done (st_parameter_dt
*);
2723 export_proto(st_iolength_done
);
2726 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2729 if (dtp
->u
.p
.scratch
!= NULL
)
2730 free_mem (dtp
->u
.p
.scratch
);
2735 /* The READ statement. */
2737 extern void st_read (st_parameter_dt
*);
2738 export_proto(st_read
);
2741 st_read (st_parameter_dt
*dtp
)
2743 library_start (&dtp
->common
);
2745 data_transfer_init (dtp
, 1);
2747 /* Handle complications dealing with the endfile record. */
2749 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2750 switch (dtp
->u
.p
.current_unit
->endfile
)
2756 if (!is_internal_unit (dtp
))
2758 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2759 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2760 dtp
->u
.p
.current_unit
->current_record
= 0;
2765 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2766 dtp
->u
.p
.current_unit
->current_record
= 0;
2771 extern void st_read_done (st_parameter_dt
*);
2772 export_proto(st_read_done
);
2775 st_read_done (st_parameter_dt
*dtp
)
2777 finalize_transfer (dtp
);
2778 free_format_data (dtp
);
2780 if (dtp
->u
.p
.scratch
!= NULL
)
2781 free_mem (dtp
->u
.p
.scratch
);
2782 if (dtp
->u
.p
.current_unit
!= NULL
)
2783 unlock_unit (dtp
->u
.p
.current_unit
);
2785 free_internal_unit (dtp
);
2790 extern void st_write (st_parameter_dt
*);
2791 export_proto(st_write
);
2794 st_write (st_parameter_dt
*dtp
)
2796 library_start (&dtp
->common
);
2797 data_transfer_init (dtp
, 0);
2800 extern void st_write_done (st_parameter_dt
*);
2801 export_proto(st_write_done
);
2804 st_write_done (st_parameter_dt
*dtp
)
2806 finalize_transfer (dtp
);
2808 /* Deal with endfile conditions associated with sequential files. */
2810 if (dtp
->u
.p
.current_unit
!= NULL
2811 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2812 switch (dtp
->u
.p
.current_unit
->endfile
)
2814 case AT_ENDFILE
: /* Remain at the endfile record. */
2818 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2822 /* Get rid of whatever is after this record. */
2823 if (!is_internal_unit (dtp
))
2825 flush (dtp
->u
.p
.current_unit
->s
);
2826 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2827 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2829 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2833 free_format_data (dtp
);
2835 if (dtp
->u
.p
.scratch
!= NULL
)
2836 free_mem (dtp
->u
.p
.scratch
);
2837 if (dtp
->u
.p
.current_unit
!= NULL
)
2838 unlock_unit (dtp
->u
.p
.current_unit
);
2840 free_internal_unit (dtp
);
2845 /* Receives the scalar information for namelist objects and stores it
2846 in a linked list of namelist_info types. */
2848 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2849 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2850 export_proto(st_set_nml_var
);
2854 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2855 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2856 GFC_INTEGER_4 dtype
)
2858 namelist_info
*t1
= NULL
;
2860 size_t var_name_len
= strlen (var_name
);
2862 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2864 nml
->mem_pos
= var_addr
;
2866 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2867 memcpy (nml
->var_name
, var_name
, var_name_len
);
2868 nml
->var_name
[var_name_len
] = '\0';
2870 nml
->len
= (int) len
;
2871 nml
->string_length
= (index_type
) string_length
;
2873 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2874 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2875 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2877 if (nml
->var_rank
> 0)
2879 nml
->dim
= (descriptor_dimension
*)
2880 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2881 nml
->ls
= (array_loop_spec
*)
2882 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2892 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2894 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2895 dtp
->u
.p
.ionml
= nml
;
2899 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2904 /* Store the dimensional information for the namelist object. */
2905 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2906 index_type
, index_type
,
2908 export_proto(st_set_nml_var_dim
);
2911 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2912 index_type stride
, index_type lbound
,
2915 namelist_info
* nml
;
2920 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2922 nml
->dim
[n
].stride
= stride
;
2923 nml
->dim
[n
].lbound
= lbound
;
2924 nml
->dim
[n
].ubound
= ubound
;
2927 /* Reverse memcpy - used for byte swapping. */
2929 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2935 s
= (char *) src
+ n
- 1;
2937 /* Write with ascending order - this is likely faster
2938 on modern architectures because of write combining. */