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
;
597 if (is_stream_io (dtp
))
599 if (sseek (dtp
->u
.p
.current_unit
->s
,
600 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
602 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
606 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
608 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
612 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
617 /* Unformatted direct access. */
619 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
621 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
623 generate_error (&dtp
->common
, LIBERROR_DIRECT_EOR
, NULL
);
627 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
629 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
633 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
634 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
640 /* Unformatted sequential. */
644 if (dtp
->u
.p
.current_unit
->flags
.has_recl
645 && (gfc_offset
) nbytes
> dtp
->u
.p
.current_unit
->bytes_left
)
647 nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
659 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
< nbytes
?
660 (size_t) dtp
->u
.p
.current_unit
->bytes_left_subrecord
: nbytes
;
662 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-=
663 (gfc_offset
) to_write_subrecord
;
665 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
+ have_written
,
666 &to_write_subrecord
) != 0)
668 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
672 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) to_write_subrecord
;
673 nbytes
-= to_write_subrecord
;
674 have_written
+= to_write_subrecord
;
679 next_record_w_unf (dtp
, 1);
682 dtp
->u
.p
.current_unit
->bytes_left
-= have_written
;
685 generate_error (&dtp
->common
, LIBERROR_SHORT_RECORD
, NULL
);
692 /* Master function for unformatted reads. */
695 unformatted_read (st_parameter_dt
*dtp
, bt type
,
696 void *dest
, int kind
__attribute__((unused
)),
697 size_t size
, size_t nelems
)
701 /* Currently, character implies size=1. */
702 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
703 || size
== 1 || type
== BT_CHARACTER
)
706 read_block_direct (dtp
, dest
, &sz
);
713 /* Break up complex into its constituent reals. */
714 if (type
== BT_COMPLEX
)
721 /* By now, all complex variables have been split into their
722 constituent reals. */
724 for (i
=0; i
<nelems
; i
++)
726 read_block_direct (dtp
, buffer
, &size
);
727 reverse_memcpy (p
, buffer
, size
);
734 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
735 bytes on 64 bit machines. The unused bytes are not initialized and never
736 used, which can show an error with memory checking analyzers like
740 unformatted_write (st_parameter_dt
*dtp
, bt type
,
741 void *source
, int kind
__attribute__((unused
)),
742 size_t size
, size_t nelems
)
744 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
||
745 size
== 1 || type
== BT_CHARACTER
)
748 write_buf (dtp
, source
, size
);
756 /* Break up complex into its constituent reals. */
757 if (type
== BT_COMPLEX
)
765 /* By now, all complex variables have been split into their
766 constituent reals. */
769 for (i
=0; i
<nelems
; i
++)
771 reverse_memcpy(buffer
, p
, size
);
773 write_buf (dtp
, buffer
, size
);
779 /* Return a pointer to the name of a type. */
804 internal_error (NULL
, "type_name(): Bad type");
811 /* Write a constant string to the output.
812 This is complicated because the string can have doubled delimiters
813 in it. The length in the format node is the true length. */
816 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
818 char c
, delimiter
, *p
, *q
;
821 length
= f
->u
.string
.length
;
825 p
= write_block (dtp
, length
);
832 for (; length
> 0; length
--)
835 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
836 q
++; /* Skip the doubled delimiter. */
841 /* Given actual and expected types in a formatted data transfer, make
842 sure they agree. If not, an error message is generated. Returns
843 nonzero if something went wrong. */
846 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
850 if (actual
== expected
)
853 sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
854 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
856 format_error (dtp
, f
, buffer
);
861 /* This subroutine is the main loop for a formatted data transfer
862 statement. It would be natural to implement this as a coroutine
863 with the user program, but C makes that awkward. We loop,
864 processing format elements. When we actually have to transfer
865 data instead of just setting flags, we return control to the user
866 program which calls a subroutine that supplies the address and type
867 of the next element, then comes back here to process it. */
870 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
873 char scratch
[SCRATCH_SIZE
];
878 int consume_data_flag
;
880 /* Change a complex data item into a pair of reals. */
882 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
883 if (type
== BT_COMPLEX
)
889 /* If there's an EOR condition, we simulate finalizing the transfer
891 if (dtp
->u
.p
.eor_condition
)
894 /* Set this flag so that commas in reads cause the read to complete before
895 the entire field has been read. The next read field will start right after
896 the comma in the stream. (Set to 0 for character reads). */
897 dtp
->u
.p
.sf_read_comma
= 1;
899 dtp
->u
.p
.line_buffer
= scratch
;
902 /* If reversion has occurred and there is another real data item,
903 then we have to move to the next record. */
904 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
906 dtp
->u
.p
.reversion_flag
= 0;
907 next_record (dtp
, 0);
910 consume_data_flag
= 1 ;
911 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
914 f
= next_format (dtp
);
917 /* No data descriptors left. */
919 generate_error (&dtp
->common
, LIBERROR_FORMAT
,
920 "Insufficient data descriptors in format after reversion");
924 /* Now discharge T, TR and X movements to the right. This is delayed
925 until a data producing format to suppress trailing spaces. */
928 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
929 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
930 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
931 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
932 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
935 if (dtp
->u
.p
.skips
> 0)
937 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
938 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
939 - dtp
->u
.p
.current_unit
->bytes_left
);
941 if (dtp
->u
.p
.skips
< 0)
943 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
944 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
946 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
949 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
950 - dtp
->u
.p
.current_unit
->bytes_left
);
952 if (is_stream_io(dtp
))
960 if (require_type (dtp
, BT_INTEGER
, type
, f
))
963 if (dtp
->u
.p
.mode
== READING
)
964 read_decimal (dtp
, f
, p
, len
);
966 write_i (dtp
, f
, p
, len
);
974 if (compile_options
.allow_std
< GFC_STD_GNU
975 && require_type (dtp
, BT_INTEGER
, type
, f
))
978 if (dtp
->u
.p
.mode
== READING
)
979 read_radix (dtp
, f
, p
, len
, 2);
981 write_b (dtp
, f
, p
, len
);
989 if (compile_options
.allow_std
< GFC_STD_GNU
990 && require_type (dtp
, BT_INTEGER
, type
, f
))
993 if (dtp
->u
.p
.mode
== READING
)
994 read_radix (dtp
, f
, p
, len
, 8);
996 write_o (dtp
, f
, p
, len
);
1004 if (compile_options
.allow_std
< GFC_STD_GNU
1005 && require_type (dtp
, BT_INTEGER
, type
, f
))
1008 if (dtp
->u
.p
.mode
== READING
)
1009 read_radix (dtp
, f
, p
, len
, 16);
1011 write_z (dtp
, f
, p
, len
);
1019 if (dtp
->u
.p
.mode
== READING
)
1020 read_a (dtp
, f
, p
, len
);
1022 write_a (dtp
, f
, p
, len
);
1030 if (dtp
->u
.p
.mode
== READING
)
1031 read_l (dtp
, f
, p
, len
);
1033 write_l (dtp
, f
, p
, len
);
1040 if (require_type (dtp
, BT_REAL
, type
, f
))
1043 if (dtp
->u
.p
.mode
== READING
)
1044 read_f (dtp
, f
, p
, len
);
1046 write_d (dtp
, f
, p
, len
);
1053 if (require_type (dtp
, BT_REAL
, type
, f
))
1056 if (dtp
->u
.p
.mode
== READING
)
1057 read_f (dtp
, f
, p
, len
);
1059 write_e (dtp
, f
, p
, len
);
1065 if (require_type (dtp
, BT_REAL
, type
, f
))
1068 if (dtp
->u
.p
.mode
== READING
)
1069 read_f (dtp
, f
, p
, len
);
1071 write_en (dtp
, f
, p
, len
);
1078 if (require_type (dtp
, BT_REAL
, type
, f
))
1081 if (dtp
->u
.p
.mode
== READING
)
1082 read_f (dtp
, f
, p
, len
);
1084 write_es (dtp
, f
, p
, len
);
1091 if (require_type (dtp
, BT_REAL
, type
, f
))
1094 if (dtp
->u
.p
.mode
== READING
)
1095 read_f (dtp
, f
, p
, len
);
1097 write_f (dtp
, f
, p
, len
);
1104 if (dtp
->u
.p
.mode
== READING
)
1108 read_decimal (dtp
, f
, p
, len
);
1111 read_l (dtp
, f
, p
, len
);
1114 read_a (dtp
, f
, p
, len
);
1117 read_f (dtp
, f
, p
, len
);
1126 write_i (dtp
, f
, p
, len
);
1129 write_l (dtp
, f
, p
, len
);
1132 write_a (dtp
, f
, p
, len
);
1135 write_d (dtp
, f
, p
, len
);
1139 internal_error (&dtp
->common
,
1140 "formatted_transfer(): Bad type");
1146 consume_data_flag
= 0 ;
1147 if (dtp
->u
.p
.mode
== READING
)
1149 format_error (dtp
, f
, "Constant string in input format");
1152 write_constant_string (dtp
, f
);
1155 /* Format codes that don't transfer data. */
1158 consume_data_flag
= 0;
1160 dtp
->u
.p
.skips
+= f
->u
.n
;
1161 pos
= bytes_used
+ dtp
->u
.p
.skips
- 1;
1162 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
+ 1;
1164 /* Writes occur just before the switch on f->format, above, so
1165 that trailing blanks are suppressed, unless we are doing a
1166 non-advancing write in which case we want to output the blanks
1168 if (dtp
->u
.p
.mode
== WRITING
1169 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1171 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1172 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1175 if (dtp
->u
.p
.mode
== READING
)
1176 read_x (dtp
, f
->u
.n
);
1182 consume_data_flag
= 0;
1184 if (f
->format
== FMT_TL
)
1187 /* Handle the special case when no bytes have been used yet.
1188 Cannot go below zero. */
1189 if (bytes_used
== 0)
1191 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1192 dtp
->u
.p
.skips
-= f
->u
.n
;
1193 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1196 pos
= bytes_used
- f
->u
.n
;
1200 if (dtp
->u
.p
.mode
== READING
)
1203 pos
= f
->u
.n
- dtp
->u
.p
.pending_spaces
- 1;
1206 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1207 left tab limit. We do not check if the position has gone
1208 beyond the end of record because a subsequent tab could
1209 bring us back again. */
1210 pos
= pos
< 0 ? 0 : pos
;
1212 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1213 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1214 + pos
- dtp
->u
.p
.max_pos
;
1215 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0
1216 ? 0 : dtp
->u
.p
.pending_spaces
;
1218 if (dtp
->u
.p
.skips
== 0)
1221 /* Writes occur just before the switch on f->format, above, so that
1222 trailing blanks are suppressed. */
1223 if (dtp
->u
.p
.mode
== READING
)
1225 /* Adjust everything for end-of-record condition */
1226 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1228 if (dtp
->u
.p
.sf_seen_eor
== 2)
1230 /* The EOR was a CRLF (two bytes wide). */
1231 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1232 dtp
->u
.p
.skips
-= 2;
1236 /* The EOR marker was only one byte wide. */
1237 dtp
->u
.p
.current_unit
->bytes_left
--;
1241 dtp
->u
.p
.sf_seen_eor
= 0;
1243 if (dtp
->u
.p
.skips
< 0)
1245 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1246 dtp
->u
.p
.current_unit
->bytes_left
1247 -= (gfc_offset
) dtp
->u
.p
.skips
;
1248 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1251 read_x (dtp
, dtp
->u
.p
.skips
);
1257 consume_data_flag
= 0 ;
1258 dtp
->u
.p
.sign_status
= SIGN_S
;
1262 consume_data_flag
= 0 ;
1263 dtp
->u
.p
.sign_status
= SIGN_SS
;
1267 consume_data_flag
= 0 ;
1268 dtp
->u
.p
.sign_status
= SIGN_SP
;
1272 consume_data_flag
= 0 ;
1273 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1277 consume_data_flag
= 0 ;
1278 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1282 consume_data_flag
= 0 ;
1283 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1287 consume_data_flag
= 0 ;
1288 dtp
->u
.p
.seen_dollar
= 1;
1292 consume_data_flag
= 0 ;
1293 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1294 next_record (dtp
, 0);
1298 /* A colon descriptor causes us to exit this loop (in
1299 particular preventing another / descriptor from being
1300 processed) unless there is another data item to be
1302 consume_data_flag
= 0 ;
1308 internal_error (&dtp
->common
, "Bad format node");
1311 /* Free a buffer that we had to allocate during a sequential
1312 formatted read of a block that was larger than the static
1315 if (dtp
->u
.p
.line_buffer
!= scratch
)
1317 free_mem (dtp
->u
.p
.line_buffer
);
1318 dtp
->u
.p
.line_buffer
= scratch
;
1321 /* Adjust the item count and data pointer. */
1323 if ((consume_data_flag
> 0) && (n
> 0))
1326 p
= ((char *) p
) + size
;
1329 if (dtp
->u
.p
.mode
== READING
)
1332 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1333 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1339 /* Come here when we need a data descriptor but don't have one. We
1340 push the current format node back onto the input, then return and
1341 let the user program call us back with the data. */
1343 unget_format (dtp
, f
);
1347 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1348 size_t size
, size_t nelems
)
1355 /* Big loop over all the elements. */
1356 for (elem
= 0; elem
< nelems
; elem
++)
1358 dtp
->u
.p
.item_count
++;
1359 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1365 /* Data transfer entry points. The type of the data entity is
1366 implicit in the subroutine call. This prevents us from having to
1367 share a common enum with the compiler. */
1370 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1372 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1374 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1379 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1382 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1384 size
= size_from_real_kind (kind
);
1385 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1390 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1392 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1394 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1399 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1401 static char *empty_string
[0];
1403 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1406 /* Strings of zero length can have p == NULL, which confuses the
1407 transfer routines into thinking we need more data elements. To avoid
1408 this, we give them a nice pointer. */
1409 if (len
== 0 && p
== NULL
)
1412 /* Currently we support only 1 byte chars, and the library is a bit
1413 confused of character kind vs. length, so we kludge it by setting
1415 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1420 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1423 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1425 size
= size_from_complex_kind (kind
);
1426 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1431 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1432 gfc_charlen_type charlen
)
1434 index_type count
[GFC_MAX_DIMENSIONS
];
1435 index_type extent
[GFC_MAX_DIMENSIONS
];
1436 index_type stride
[GFC_MAX_DIMENSIONS
];
1437 index_type stride0
, rank
, size
, type
, n
;
1442 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1445 type
= GFC_DESCRIPTOR_TYPE (desc
);
1446 size
= GFC_DESCRIPTOR_SIZE (desc
);
1448 /* FIXME: What a kludge: Array descriptors and the IO library use
1449 different enums for types. */
1452 case GFC_DTYPE_UNKNOWN
:
1453 iotype
= BT_NULL
; /* Is this correct? */
1455 case GFC_DTYPE_INTEGER
:
1456 iotype
= BT_INTEGER
;
1458 case GFC_DTYPE_LOGICAL
:
1459 iotype
= BT_LOGICAL
;
1461 case GFC_DTYPE_REAL
:
1464 case GFC_DTYPE_COMPLEX
:
1465 iotype
= BT_COMPLEX
;
1467 case GFC_DTYPE_CHARACTER
:
1468 iotype
= BT_CHARACTER
;
1469 /* FIXME: Currently dtype contains the charlen, which is
1470 clobbered if charlen > 2**24. That's why we use a separate
1471 argument for the charlen. However, if we want to support
1472 non-8-bit charsets we need to fix dtype to contain
1473 sizeof(chartype) and fix the code below. */
1477 case GFC_DTYPE_DERIVED
:
1478 internal_error (&dtp
->common
,
1479 "Derived type I/O should have been handled via the frontend.");
1482 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1485 rank
= GFC_DESCRIPTOR_RANK (desc
);
1486 for (n
= 0; n
< rank
; n
++)
1489 stride
[n
] = desc
->dim
[n
].stride
;
1490 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1492 /* If the extent of even one dimension is zero, then the entire
1493 array section contains zero elements, so we return. */
1498 stride0
= stride
[0];
1500 /* If the innermost dimension has stride 1, we can do the transfer
1501 in contiguous chunks. */
1507 data
= GFC_DESCRIPTOR_DATA (desc
);
1511 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1512 data
+= stride0
* size
* tsize
;
1515 while (count
[n
] == extent
[n
])
1518 data
-= stride
[n
] * extent
[n
] * size
;
1528 data
+= stride
[n
] * size
;
1535 /* Preposition a sequential unformatted file while reading. */
1538 us_read (st_parameter_dt
*dtp
, int continued
)
1547 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1550 if (compile_options
.record_marker
== 0)
1551 n
= sizeof (GFC_INTEGER_4
);
1553 n
= compile_options
.record_marker
;
1557 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1561 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1562 return; /* end of file */
1565 if (p
== NULL
|| n
!= nr
)
1567 generate_error (&dtp
->common
, LIBERROR_BAD_US
, NULL
);
1571 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1572 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
1576 case sizeof(GFC_INTEGER_4
):
1577 memcpy (&i4
, p
, sizeof (i4
));
1581 case sizeof(GFC_INTEGER_8
):
1582 memcpy (&i8
, p
, sizeof (i8
));
1587 runtime_error ("Illegal value for record marker");
1594 case sizeof(GFC_INTEGER_4
):
1595 reverse_memcpy (&i4
, p
, sizeof (i4
));
1599 case sizeof(GFC_INTEGER_8
):
1600 reverse_memcpy (&i8
, p
, sizeof (i8
));
1605 runtime_error ("Illegal value for record marker");
1611 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= i
;
1612 dtp
->u
.p
.current_unit
->continued
= 0;
1616 dtp
->u
.p
.current_unit
->bytes_left_subrecord
= -i
;
1617 dtp
->u
.p
.current_unit
->continued
= 1;
1621 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1625 /* Preposition a sequential unformatted file while writing. This
1626 amount to writing a bogus length that will be filled in later. */
1629 us_write (st_parameter_dt
*dtp
, int continued
)
1636 if (compile_options
.record_marker
== 0)
1637 nbytes
= sizeof (GFC_INTEGER_4
);
1639 nbytes
= compile_options
.record_marker
;
1641 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1642 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1644 /* For sequential unformatted, if RECL= was not specified in the OPEN
1645 we write until we have more bytes than can fit in the subrecord
1646 markers, then we write a new subrecord. */
1648 dtp
->u
.p
.current_unit
->bytes_left_subrecord
=
1649 dtp
->u
.p
.current_unit
->recl_subrecord
;
1650 dtp
->u
.p
.current_unit
->continued
= continued
;
1654 /* Position to the next record prior to transfer. We are assumed to
1655 be before the next record. We also calculate the bytes in the next
1659 pre_position (st_parameter_dt
*dtp
)
1661 if (dtp
->u
.p
.current_unit
->current_record
)
1662 return; /* Already positioned. */
1664 switch (current_mode (dtp
))
1666 case FORMATTED_STREAM
:
1667 case UNFORMATTED_STREAM
:
1668 /* There are no records with stream I/O. Set the default position
1669 to the beginning of the file if no position was specified. */
1670 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1671 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1674 case UNFORMATTED_SEQUENTIAL
:
1675 if (dtp
->u
.p
.mode
== READING
)
1682 case FORMATTED_SEQUENTIAL
:
1683 case FORMATTED_DIRECT
:
1684 case UNFORMATTED_DIRECT
:
1685 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1689 dtp
->u
.p
.current_unit
->current_record
= 1;
1693 /* Initialize things for a data transfer. This code is common for
1694 both reading and writing. */
1697 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1699 unit_flags u_flags
; /* Used for creating a unit if needed. */
1700 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1701 namelist_info
*ionml
;
1703 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1704 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1705 dtp
->u
.p
.ionml
= ionml
;
1706 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1708 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1711 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1712 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1714 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1715 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1716 { /* Open the unit with some default flags. */
1717 st_parameter_open opp
;
1720 if (dtp
->common
.unit
< 0)
1722 close_unit (dtp
->u
.p
.current_unit
);
1723 dtp
->u
.p
.current_unit
= NULL
;
1724 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1725 "Bad unit number in OPEN statement");
1728 memset (&u_flags
, '\0', sizeof (u_flags
));
1729 u_flags
.access
= ACCESS_SEQUENTIAL
;
1730 u_flags
.action
= ACTION_READWRITE
;
1732 /* Is it unformatted? */
1733 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1734 | IOPARM_DT_IONML_SET
)))
1735 u_flags
.form
= FORM_UNFORMATTED
;
1737 u_flags
.form
= FORM_UNSPECIFIED
;
1739 u_flags
.delim
= DELIM_UNSPECIFIED
;
1740 u_flags
.blank
= BLANK_UNSPECIFIED
;
1741 u_flags
.pad
= PAD_UNSPECIFIED
;
1742 u_flags
.status
= STATUS_UNKNOWN
;
1744 conv
= get_unformatted_convert (dtp
->common
.unit
);
1746 if (conv
== GFC_CONVERT_NONE
)
1747 conv
= compile_options
.convert
;
1749 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1750 and 1 on big-endian machines. */
1753 case GFC_CONVERT_NATIVE
:
1754 case GFC_CONVERT_SWAP
:
1757 case GFC_CONVERT_BIG
:
1758 conv
= l8_to_l4_offset
? GFC_CONVERT_NATIVE
: GFC_CONVERT_SWAP
;
1761 case GFC_CONVERT_LITTLE
:
1762 conv
= l8_to_l4_offset
? GFC_CONVERT_SWAP
: GFC_CONVERT_NATIVE
;
1766 internal_error (&opp
.common
, "Illegal value for CONVERT");
1770 u_flags
.convert
= conv
;
1772 opp
.common
= dtp
->common
;
1773 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1774 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1775 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1776 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1777 if (dtp
->u
.p
.current_unit
== NULL
)
1781 /* Check the action. */
1783 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1785 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1786 "Cannot read from file opened for WRITE");
1790 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1792 generate_error (&dtp
->common
, LIBERROR_BAD_ACTION
,
1793 "Cannot write to file opened for READ");
1797 dtp
->u
.p
.first_item
= 1;
1799 /* Check the format. */
1801 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1804 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1805 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1808 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1809 "Format present for UNFORMATTED data transfer");
1813 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1815 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1816 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1817 "A format cannot be specified with a namelist");
1819 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1820 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1822 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1823 "Missing format for FORMATTED data transfer");
1826 if (is_internal_unit (dtp
)
1827 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1829 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1830 "Internal file cannot be accessed by UNFORMATTED "
1835 /* Check the record or position number. */
1837 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1838 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1840 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1841 "Direct access data transfer requires record number");
1845 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1846 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1848 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1849 "Record number not allowed for sequential access data transfer");
1853 /* Process the ADVANCE option. */
1855 dtp
->u
.p
.advance_status
1856 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1857 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1858 "Bad ADVANCE parameter in data transfer statement");
1860 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1862 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1864 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1865 "ADVANCE specification conflicts with sequential access");
1869 if (is_internal_unit (dtp
))
1871 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1872 "ADVANCE specification conflicts with internal file");
1876 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1877 != IOPARM_DT_HAS_FORMAT
)
1879 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1880 "ADVANCE specification requires an explicit format");
1887 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1889 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1890 "EOR specification requires an ADVANCE specification "
1895 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1897 generate_error (&dtp
->common
, LIBERROR_MISSING_OPTION
,
1898 "SIZE specification requires an ADVANCE specification of NO");
1903 { /* Write constraints. */
1904 if ((cf
& IOPARM_END
) != 0)
1906 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1907 "END specification cannot appear in a write statement");
1911 if ((cf
& IOPARM_EOR
) != 0)
1913 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1914 "EOR specification cannot appear in a write statement");
1918 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1920 generate_error (&dtp
->common
, LIBERROR_OPTION_CONFLICT
,
1921 "SIZE specification cannot appear in a write statement");
1926 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1927 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1929 /* Sanity checks on the record number. */
1930 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1934 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1935 "Record number must be positive");
1939 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1941 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1942 "Record number too large");
1946 /* Check to see if we might be reading what we wrote before */
1948 if (dtp
->u
.p
.mode
== READING
1949 && dtp
->u
.p
.current_unit
->mode
== WRITING
1950 && !is_internal_unit (dtp
))
1951 flush(dtp
->u
.p
.current_unit
->s
);
1953 /* Check whether the record exists to be read. Only
1954 a partial record needs to exist. */
1956 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1957 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1959 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
1960 "Non-existing record number");
1964 /* Position the file. */
1965 if (!is_stream_io (dtp
))
1967 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1968 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1970 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
1975 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1979 /* Overwriting an existing sequential file ?
1980 it is always safe to truncate the file on the first write */
1981 if (dtp
->u
.p
.mode
== WRITING
1982 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1983 && dtp
->u
.p
.current_unit
->last_record
== 0
1984 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1985 struncate(dtp
->u
.p
.current_unit
->s
);
1987 /* Bugware for badly written mixed C-Fortran I/O. */
1988 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1990 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1992 /* Set the initial value of flags. */
1994 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1995 dtp
->u
.p
.sign_status
= SIGN_S
;
1997 /* Set the maximum position reached from the previous I/O operation. This
1998 could be greater than zero from a previous non-advancing write. */
1999 dtp
->u
.p
.max_pos
= dtp
->u
.p
.current_unit
->saved_pos
;
2003 /* Set up the subroutine that will handle the transfers. */
2007 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2008 dtp
->u
.p
.transfer
= unformatted_read
;
2011 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2012 dtp
->u
.p
.transfer
= list_formatted_read
;
2014 dtp
->u
.p
.transfer
= formatted_transfer
;
2019 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
2020 dtp
->u
.p
.transfer
= unformatted_write
;
2023 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
2024 dtp
->u
.p
.transfer
= list_formatted_write
;
2026 dtp
->u
.p
.transfer
= formatted_transfer
;
2030 /* Make sure that we don't do a read after a nonadvancing write. */
2034 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
2036 generate_error (&dtp
->common
, LIBERROR_BAD_OPTION
,
2037 "Cannot READ after a nonadvancing WRITE");
2043 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
2044 dtp
->u
.p
.current_unit
->read_bad
= 1;
2047 /* Start the data transfer if we are doing a formatted transfer. */
2048 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
2049 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
2050 && dtp
->u
.p
.ionml
== NULL
)
2051 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
2054 /* Initialize an array_loop_spec given the array descriptor. The function
2055 returns the index of the last element of the array. */
2058 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
2060 int rank
= GFC_DESCRIPTOR_RANK(desc
);
2065 for (i
=0; i
<rank
; i
++)
2067 ls
[i
].idx
= desc
->dim
[i
].lbound
;
2068 ls
[i
].start
= desc
->dim
[i
].lbound
;
2069 ls
[i
].end
= desc
->dim
[i
].ubound
;
2070 ls
[i
].step
= desc
->dim
[i
].stride
;
2072 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
2073 * desc
->dim
[i
].stride
;
2078 /* Determine the index to the next record in an internal unit array by
2079 by incrementing through the array_loop_spec. TODO: Implement handling
2080 negative strides. */
2083 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
2091 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
2096 if (ls
[i
].idx
> ls
[i
].end
)
2098 ls
[i
].idx
= ls
[i
].start
;
2104 index
= index
+ (ls
[i
].idx
- ls
[i
].start
) * ls
[i
].step
;
2112 /* Skip to the end of the current record, taking care of an optional
2113 record marker of size bytes. If the file is not seekable, we
2114 read chunks of size MAX_READ until we get to the right
2117 #define MAX_READ 4096
2120 skip_record (st_parameter_dt
*dtp
, size_t bytes
)
2123 int rlength
, length
;
2126 dtp
->u
.p
.current_unit
->bytes_left_subrecord
+= bytes
;
2127 if (dtp
->u
.p
.current_unit
->bytes_left_subrecord
== 0)
2130 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
2132 new = file_position (dtp
->u
.p
.current_unit
->s
)
2133 + dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2135 /* Direct access files do not generate END conditions,
2137 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
2138 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2141 { /* Seek by reading data. */
2142 while (dtp
->u
.p
.current_unit
->bytes_left_subrecord
> 0)
2145 (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left_subrecord
) ?
2146 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2148 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
2151 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2155 dtp
->u
.p
.current_unit
->bytes_left_subrecord
-= length
;
2163 /* Advance to the next record reading unformatted files, taking
2164 care of subrecords. If complete_record is nonzero, we loop
2165 until all subrecords are cleared. */
2168 next_record_r_unf (st_parameter_dt
*dtp
, int complete_record
)
2172 bytes
= compile_options
.record_marker
== 0 ?
2173 sizeof (GFC_INTEGER_4
) : compile_options
.record_marker
;
2178 /* Skip over tail */
2180 skip_record (dtp
, bytes
);
2182 if ( ! (complete_record
&& dtp
->u
.p
.current_unit
->continued
))
2189 /* Space to the next record for read mode. */
2192 next_record_r (st_parameter_dt
*dtp
)
2195 int length
, bytes_left
;
2198 switch (current_mode (dtp
))
2200 /* No records in unformatted STREAM I/O. */
2201 case UNFORMATTED_STREAM
:
2204 case UNFORMATTED_SEQUENTIAL
:
2205 next_record_r_unf (dtp
, 1);
2206 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2209 case FORMATTED_DIRECT
:
2210 case UNFORMATTED_DIRECT
:
2211 skip_record (dtp
, 0);
2214 case FORMATTED_STREAM
:
2215 case FORMATTED_SEQUENTIAL
:
2217 /* sf_read has already terminated input because of an '\n' */
2218 if (dtp
->u
.p
.sf_seen_eor
)
2220 dtp
->u
.p
.sf_seen_eor
= 0;
2224 if (is_internal_unit (dtp
))
2226 if (is_array_io (dtp
))
2228 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2230 /* Now seek to this record. */
2231 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2232 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2234 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2237 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2241 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2242 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2244 dtp
->u
.p
.current_unit
->bytes_left
2245 = dtp
->u
.p
.current_unit
->recl
;
2251 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2255 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2261 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2265 if (is_stream_io (dtp
))
2266 dtp
->u
.p
.current_unit
->strm_pos
++;
2273 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
2274 && !dtp
->u
.p
.namelist_mode
2275 && dtp
->u
.p
.current_unit
->endfile
== NO_ENDFILE
2276 && (file_length (dtp
->u
.p
.current_unit
->s
) ==
2277 file_position (dtp
->u
.p
.current_unit
->s
)))
2278 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2283 /* Small utility function to write a record marker, taking care of
2284 byte swapping and of choosing the correct size. */
2287 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2292 char p
[sizeof (GFC_INTEGER_8
)];
2294 if (compile_options
.record_marker
== 0)
2295 len
= sizeof (GFC_INTEGER_4
);
2297 len
= compile_options
.record_marker
;
2299 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2300 if (dtp
->u
.p
.current_unit
->flags
.convert
== GFC_CONVERT_NATIVE
)
2304 case sizeof (GFC_INTEGER_4
):
2306 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2309 case sizeof (GFC_INTEGER_8
):
2311 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2315 runtime_error ("Illegal value for record marker");
2323 case sizeof (GFC_INTEGER_4
):
2325 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2326 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2329 case sizeof (GFC_INTEGER_8
):
2331 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_8
));
2332 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2336 runtime_error ("Illegal value for record marker");
2343 /* Position to the next (sub)record in write mode for
2344 unformatted sequential files. */
2347 next_record_w_unf (st_parameter_dt
*dtp
, int next_subrecord
)
2349 gfc_offset c
, m
, m_write
;
2350 size_t record_marker
;
2352 /* Bytes written. */
2353 m
= dtp
->u
.p
.current_unit
->recl_subrecord
2354 - dtp
->u
.p
.current_unit
->bytes_left_subrecord
;
2355 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2357 /* Write the length tail. If we finish a record containing
2358 subrecords, we write out the negative length. */
2360 if (dtp
->u
.p
.current_unit
->continued
)
2365 if (write_us_marker (dtp
, m_write
) != 0)
2368 if (compile_options
.record_marker
== 0)
2369 record_marker
= sizeof (GFC_INTEGER_4
);
2371 record_marker
= compile_options
.record_marker
;
2373 /* Seek to the head and overwrite the bogus length with the real
2376 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2385 if (write_us_marker (dtp
, m_write
) != 0)
2388 /* Seek past the end of the current record. */
2390 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2396 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2401 /* Position to the next record in write mode. */
2404 next_record_w (st_parameter_dt
*dtp
, int done
)
2406 gfc_offset m
, record
, max_pos
;
2410 /* Zero counters for X- and T-editing. */
2411 max_pos
= dtp
->u
.p
.max_pos
;
2412 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2414 switch (current_mode (dtp
))
2416 /* No records in unformatted STREAM I/O. */
2417 case UNFORMATTED_STREAM
:
2420 case FORMATTED_DIRECT
:
2421 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2424 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2425 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2430 case UNFORMATTED_DIRECT
:
2431 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2435 case UNFORMATTED_SEQUENTIAL
:
2436 next_record_w_unf (dtp
, 0);
2437 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2440 case FORMATTED_STREAM
:
2441 case FORMATTED_SEQUENTIAL
:
2443 if (is_internal_unit (dtp
))
2445 if (is_array_io (dtp
))
2447 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2449 /* If the farthest position reached is greater than current
2450 position, adjust the position and set length to pad out
2451 whats left. Otherwise just pad whats left.
2452 (for character array unit) */
2453 m
= dtp
->u
.p
.current_unit
->recl
2454 - dtp
->u
.p
.current_unit
->bytes_left
;
2457 length
= (int) (max_pos
- m
);
2458 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2459 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2462 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2464 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2468 /* Now that the current record has been padded out,
2469 determine where the next record in the array is. */
2470 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2472 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2474 /* Now seek to this record */
2475 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2477 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2479 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
2483 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2489 /* If this is the last call to next_record move to the farthest
2490 position reached and set length to pad out the remainder
2491 of the record. (for character scaler unit) */
2494 m
= dtp
->u
.p
.current_unit
->recl
2495 - dtp
->u
.p
.current_unit
->bytes_left
;
2498 length
= (int) (max_pos
- m
);
2499 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2500 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2503 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2506 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2508 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2515 /* If this is the last call to next_record move to the farthest
2516 position reached in preparation for completing the record.
2520 m
= dtp
->u
.p
.current_unit
->recl
-
2521 dtp
->u
.p
.current_unit
->bytes_left
;
2524 length
= (int) (max_pos
- m
);
2525 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2529 const char crlf
[] = "\r\n";
2535 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2538 if (is_stream_io (dtp
))
2539 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2545 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2550 /* Position to the next record, which means moving to the end of the
2551 current record. This can happen under several different
2552 conditions. If the done flag is not set, we get ready to process
2556 next_record (st_parameter_dt
*dtp
, int done
)
2558 gfc_offset fp
; /* File position. */
2560 dtp
->u
.p
.current_unit
->read_bad
= 0;
2562 if (dtp
->u
.p
.mode
== READING
)
2563 next_record_r (dtp
);
2565 next_record_w (dtp
, done
);
2567 if (!is_stream_io (dtp
))
2569 /* Keep position up to date for INQUIRE */
2571 update_position (dtp
->u
.p
.current_unit
);
2573 dtp
->u
.p
.current_unit
->current_record
= 0;
2574 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2576 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2577 /* Calculate next record, rounding up partial records. */
2578 dtp
->u
.p
.current_unit
->last_record
=
2579 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2580 dtp
->u
.p
.current_unit
->recl
;
2583 dtp
->u
.p
.current_unit
->last_record
++;
2591 /* Finalize the current data transfer. For a nonadvancing transfer,
2592 this means advancing to the next record. For internal units close the
2593 stream associated with the unit. */
2596 finalize_transfer (st_parameter_dt
*dtp
)
2599 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2601 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2602 *dtp
->size
= (GFC_IO_INT
) dtp
->u
.p
.size_used
;
2604 if (dtp
->u
.p
.eor_condition
)
2606 generate_error (&dtp
->common
, LIBERROR_EOR
, NULL
);
2610 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2613 if ((dtp
->u
.p
.ionml
!= NULL
)
2614 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2616 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2617 namelist_read (dtp
);
2619 namelist_write (dtp
);
2622 dtp
->u
.p
.transfer
= NULL
;
2623 if (dtp
->u
.p
.current_unit
== NULL
)
2626 dtp
->u
.p
.eof_jump
= &eof_jump
;
2627 if (setjmp (eof_jump
))
2629 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2633 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2635 finish_list_read (dtp
);
2636 sfree (dtp
->u
.p
.current_unit
->s
);
2640 if (is_stream_io (dtp
))
2642 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2643 next_record (dtp
, 1);
2644 flush (dtp
->u
.p
.current_unit
->s
);
2645 sfree (dtp
->u
.p
.current_unit
->s
);
2649 dtp
->u
.p
.current_unit
->current_record
= 0;
2651 if (!is_internal_unit (dtp
) && dtp
->u
.p
.seen_dollar
)
2653 dtp
->u
.p
.seen_dollar
= 0;
2654 sfree (dtp
->u
.p
.current_unit
->s
);
2658 /* For non-advancing I/O, save the current maximum position for use in the
2659 next I/O operation if needed. */
2660 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
)
2662 int bytes_written
= (int) (dtp
->u
.p
.current_unit
->recl
2663 - dtp
->u
.p
.current_unit
->bytes_left
);
2664 dtp
->u
.p
.current_unit
->saved_pos
=
2665 dtp
->u
.p
.max_pos
> 0 ? dtp
->u
.p
.max_pos
- bytes_written
: 0;
2666 flush (dtp
->u
.p
.current_unit
->s
);
2670 dtp
->u
.p
.current_unit
->saved_pos
= 0;
2672 next_record (dtp
, 1);
2673 sfree (dtp
->u
.p
.current_unit
->s
);
2676 /* Transfer function for IOLENGTH. It doesn't actually do any
2677 data transfer, it just updates the length counter. */
2680 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2681 void *dest
__attribute__ ((unused
)),
2682 int kind
__attribute__((unused
)),
2683 size_t size
, size_t nelems
)
2685 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2686 *dtp
->iolength
+= (GFC_IO_INT
) size
* nelems
;
2690 /* Initialize the IOLENGTH data transfer. This function is in essence
2691 a very much simplified version of data_transfer_init(), because it
2692 doesn't have to deal with units at all. */
2695 iolength_transfer_init (st_parameter_dt
*dtp
)
2697 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2700 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2702 /* Set up the subroutine that will handle the transfers. */
2704 dtp
->u
.p
.transfer
= iolength_transfer
;
2708 /* Library entry point for the IOLENGTH form of the INQUIRE
2709 statement. The IOLENGTH form requires no I/O to be performed, but
2710 it must still be a runtime library call so that we can determine
2711 the iolength for dynamic arrays and such. */
2713 extern void st_iolength (st_parameter_dt
*);
2714 export_proto(st_iolength
);
2717 st_iolength (st_parameter_dt
*dtp
)
2719 library_start (&dtp
->common
);
2720 iolength_transfer_init (dtp
);
2723 extern void st_iolength_done (st_parameter_dt
*);
2724 export_proto(st_iolength_done
);
2727 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2730 if (dtp
->u
.p
.scratch
!= NULL
)
2731 free_mem (dtp
->u
.p
.scratch
);
2736 /* The READ statement. */
2738 extern void st_read (st_parameter_dt
*);
2739 export_proto(st_read
);
2742 st_read (st_parameter_dt
*dtp
)
2744 library_start (&dtp
->common
);
2746 data_transfer_init (dtp
, 1);
2748 /* Handle complications dealing with the endfile record. */
2750 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2751 switch (dtp
->u
.p
.current_unit
->endfile
)
2757 if (!is_internal_unit (dtp
))
2759 generate_error (&dtp
->common
, LIBERROR_END
, NULL
);
2760 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2761 dtp
->u
.p
.current_unit
->current_record
= 0;
2766 generate_error (&dtp
->common
, LIBERROR_ENDFILE
, NULL
);
2767 dtp
->u
.p
.current_unit
->current_record
= 0;
2772 extern void st_read_done (st_parameter_dt
*);
2773 export_proto(st_read_done
);
2776 st_read_done (st_parameter_dt
*dtp
)
2778 finalize_transfer (dtp
);
2779 free_format_data (dtp
);
2781 if (dtp
->u
.p
.scratch
!= NULL
)
2782 free_mem (dtp
->u
.p
.scratch
);
2783 if (dtp
->u
.p
.current_unit
!= NULL
)
2784 unlock_unit (dtp
->u
.p
.current_unit
);
2786 free_internal_unit (dtp
);
2791 extern void st_write (st_parameter_dt
*);
2792 export_proto(st_write
);
2795 st_write (st_parameter_dt
*dtp
)
2797 library_start (&dtp
->common
);
2798 data_transfer_init (dtp
, 0);
2801 extern void st_write_done (st_parameter_dt
*);
2802 export_proto(st_write_done
);
2805 st_write_done (st_parameter_dt
*dtp
)
2807 finalize_transfer (dtp
);
2809 /* Deal with endfile conditions associated with sequential files. */
2811 if (dtp
->u
.p
.current_unit
!= NULL
2812 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2813 switch (dtp
->u
.p
.current_unit
->endfile
)
2815 case AT_ENDFILE
: /* Remain at the endfile record. */
2819 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2823 /* Get rid of whatever is after this record. */
2824 if (!is_internal_unit (dtp
))
2826 flush (dtp
->u
.p
.current_unit
->s
);
2827 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2828 generate_error (&dtp
->common
, LIBERROR_OS
, NULL
);
2830 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2834 free_format_data (dtp
);
2836 if (dtp
->u
.p
.scratch
!= NULL
)
2837 free_mem (dtp
->u
.p
.scratch
);
2838 if (dtp
->u
.p
.current_unit
!= NULL
)
2839 unlock_unit (dtp
->u
.p
.current_unit
);
2841 free_internal_unit (dtp
);
2846 /* Receives the scalar information for namelist objects and stores it
2847 in a linked list of namelist_info types. */
2849 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2850 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2851 export_proto(st_set_nml_var
);
2855 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2856 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2857 GFC_INTEGER_4 dtype
)
2859 namelist_info
*t1
= NULL
;
2861 size_t var_name_len
= strlen (var_name
);
2863 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2865 nml
->mem_pos
= var_addr
;
2867 nml
->var_name
= (char*) get_mem (var_name_len
+ 1);
2868 memcpy (nml
->var_name
, var_name
, var_name_len
);
2869 nml
->var_name
[var_name_len
] = '\0';
2871 nml
->len
= (int) len
;
2872 nml
->string_length
= (index_type
) string_length
;
2874 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2875 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2876 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2878 if (nml
->var_rank
> 0)
2880 nml
->dim
= (descriptor_dimension
*)
2881 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2882 nml
->ls
= (array_loop_spec
*)
2883 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2893 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2895 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2896 dtp
->u
.p
.ionml
= nml
;
2900 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2905 /* Store the dimensional information for the namelist object. */
2906 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2907 index_type
, index_type
,
2909 export_proto(st_set_nml_var_dim
);
2912 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2913 index_type stride
, index_type lbound
,
2916 namelist_info
* nml
;
2921 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2923 nml
->dim
[n
].stride
= stride
;
2924 nml
->dim
[n
].lbound
= lbound
;
2925 nml
->dim
[n
].ubound
= ubound
;
2928 /* Reverse memcpy - used for byte swapping. */
2930 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2936 s
= (char *) src
+ n
- 1;
2938 /* Write with ascending order - this is likely faster
2939 on modern architectures because of write combining. */