1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
32 /* transfer.c -- Top level handling of data transfer statements. */
37 #include "libgfortran.h"
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
59 These subroutines do not return status.
61 The last call is a call to st_[read|write]_done(). While
62 something can easily go wrong with the initial st_read() or
63 st_write(), an error inhibits any data from actually being
66 extern void transfer_integer (st_parameter_dt
*, void *, int);
67 export_proto(transfer_integer
);
69 extern void transfer_real (st_parameter_dt
*, void *, int);
70 export_proto(transfer_real
);
72 extern void transfer_logical (st_parameter_dt
*, void *, int);
73 export_proto(transfer_logical
);
75 extern void transfer_character (st_parameter_dt
*, void *, int);
76 export_proto(transfer_character
);
78 extern void transfer_complex (st_parameter_dt
*, void *, int);
79 export_proto(transfer_complex
);
81 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
83 export_proto(transfer_array
);
85 static const st_option advance_opt
[] = {
93 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
94 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
, FORMATTED_STREAM
, UNFORMATTED_STREAM
100 current_mode (st_parameter_dt
*dtp
)
104 m
= FORM_UNSPECIFIED
;
106 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
108 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
109 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
111 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
113 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
114 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
116 else if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_STREAM
)
118 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
119 FORMATTED_STREAM
: UNFORMATTED_STREAM
;
126 /* Mid level data transfer statements. These subroutines do reading
127 and writing in the style of salloc_r()/salloc_w() within the
130 /* When reading sequential formatted records we have a problem. We
131 don't know how long the line is until we read the trailing newline,
132 and we don't want to read too much. If we read too much, we might
133 have to do a physical seek backwards depending on how much data is
134 present, and devices like terminals aren't seekable and would cause
137 Given this, the solution is to read a byte at a time, stopping if
138 we hit the newline. For small allocations, we use a static buffer.
139 For larger allocations, we are forced to allocate memory on the
140 heap. Hopefully this won't happen very often. */
143 read_sf (st_parameter_dt
*dtp
, int *length
, int no_error
)
146 int n
, readlen
, crlf
;
149 if (*length
> SCRATCH_SIZE
)
150 dtp
->u
.p
.line_buffer
= get_mem (*length
);
151 p
= base
= dtp
->u
.p
.line_buffer
;
153 /* If we have seen an eor previously, return a length of 0. The
154 caller is responsible for correctly padding the input field. */
155 if (dtp
->u
.p
.sf_seen_eor
)
166 if (is_internal_unit (dtp
))
168 /* readlen may be modified inside salloc_r if
169 is_internal_unit (dtp) is true. */
173 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
177 /* If we have a line without a terminating \n, drop through to
179 if (readlen
< 1 && n
== 0)
183 generate_error (&dtp
->common
, ERROR_END
, NULL
);
187 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
189 /* Unexpected end of line. */
191 /* If we see an EOR during non-advancing I/O, we need to skip
192 the rest of the I/O statement. Set the corresponding flag. */
193 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
194 dtp
->u
.p
.eor_condition
= 1;
197 /* If we encounter a CR, it might be a CRLF. */
198 if (*q
== '\r') /* Probably a CRLF */
201 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
202 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
203 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
204 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
209 /* Without padding, terminate the I/O statement without assigning
210 the value. With padding, the value still needs to be assigned,
211 so we can just continue with a short read. */
212 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
216 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
221 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
224 /* Short circuit the read if a comma is found during numeric input.
225 The flag is set to zero during character reads so that commas in
226 strings are not ignored */
228 if (dtp
->u
.p
.sf_read_comma
== 1)
230 notify_std (&dtp
->common
, GFC_STD_GNU
,
231 "Comma in formatted numeric read.");
238 dtp
->u
.p
.sf_seen_eor
= 0;
241 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
243 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
244 dtp
->u
.p
.size_used
+= (gfc_offset
) *length
;
250 /* Function for reading the next couple of bytes from the current
251 file, advancing the current position. We return a pointer to a
252 buffer containing the bytes. We return NULL on end of record or
255 If the read is short, then it is because the current record does not
256 have enough data to satisfy the read request and the file was
257 opened with PAD=YES. The caller must assume tailing spaces for
261 read_block (st_parameter_dt
*dtp
, int *length
)
266 if (!is_stream_io (dtp
))
268 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *length
)
270 /* For preconnected units with default record length, set bytes left
271 to unit record length and proceed, otherwise error. */
272 if (dtp
->u
.p
.current_unit
->unit_number
== options
.stdin_unit
273 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
274 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
277 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
279 /* Not enough data left. */
280 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
285 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
287 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
288 generate_error (&dtp
->common
, ERROR_END
, NULL
);
292 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
295 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
296 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
297 return read_sf (dtp
, length
, 0); /* Special case. */
299 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *length
;
302 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
304 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
305 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
307 if (nread
!= *length
)
308 { /* Short read, this shouldn't happen. */
309 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
313 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
320 if (sseek (dtp
->u
.p
.current_unit
->s
,
321 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
323 generate_error (&dtp
->common
, ERROR_END
, NULL
);
327 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
329 source
= read_sf (dtp
, length
, 0);
330 dtp
->u
.p
.current_unit
->strm_pos
+=
331 (gfc_offset
) (*length
+ dtp
->u
.p
.sf_seen_eor
);
335 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
337 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
338 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
340 if (nread
!= *length
)
341 { /* Short read, this shouldn't happen. */
342 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
346 generate_error (&dtp
->common
, ERROR_END
, NULL
);
351 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
357 /* Reads a block directly into application data space. */
360 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
365 if (is_stream_io (dtp
))
367 if (sseek (dtp
->u
.p
.current_unit
->s
,
368 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
370 generate_error (&dtp
->common
, ERROR_END
, NULL
);
375 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
377 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
381 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nread
;
383 if (nread
!= *nbytes
) /* Short read, e.g. if we hit EOF. */
384 generate_error (&dtp
->common
, ERROR_END
, NULL
);
389 /* Unformatted file with records */
390 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) *nbytes
)
393 nread
= (size_t) dtp
->u
.p
.current_unit
->bytes_left
;
396 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
398 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
399 generate_error (&dtp
->common
, ERROR_END
, NULL
);
410 dtp
->u
.p
.current_unit
->bytes_left
-= nread
;
412 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
414 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
418 if (nread
!= *nbytes
) /* Short read, e.g. if we hit EOF. */
421 generate_error (&dtp
->common
, ERROR_END
, NULL
);
427 generate_error (&dtp
->common
, ERROR_SHORT_RECORD
, NULL
);
433 /* Function for writing a block of bytes to the current file at the
434 current position, advancing the file pointer. We are given a length
435 and return a pointer to a buffer that the caller must (completely)
436 fill in. Returns NULL on error. */
439 write_block (st_parameter_dt
*dtp
, int length
)
443 if (!is_stream_io (dtp
))
445 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) length
)
447 /* For preconnected units with default record length, set bytes left
448 to unit record length and proceed, otherwise error. */
449 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
450 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
451 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
452 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
455 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
460 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
463 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
467 generate_error (&dtp
->common
, ERROR_END
, NULL
);
471 if (is_internal_unit (dtp
) && dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
472 generate_error (&dtp
->common
, ERROR_END
, NULL
);
474 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
475 dtp
->u
.p
.size_used
+= (gfc_offset
) length
;
479 if (sseek (dtp
->u
.p
.current_unit
->s
,
480 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
482 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
486 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
490 generate_error (&dtp
->common
, ERROR_END
, NULL
);
494 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) length
;
501 /* High level interface to swrite(), taking care of errors. */
504 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
506 if (!is_stream_io (dtp
))
508 if (dtp
->u
.p
.current_unit
->bytes_left
< (gfc_offset
) nbytes
)
510 /* For preconnected units with default record length, set
511 bytes left to unit record length and proceed, otherwise
513 if ((dtp
->u
.p
.current_unit
->unit_number
== options
.stdout_unit
514 || dtp
->u
.p
.current_unit
->unit_number
== options
.stderr_unit
)
515 && dtp
->u
.p
.current_unit
->recl
== DEFAULT_RECL
)
516 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
519 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
520 generate_error (&dtp
->common
, ERROR_DIRECT_EOR
, NULL
);
522 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
527 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
531 if (sseek (dtp
->u
.p
.current_unit
->s
,
532 dtp
->u
.p
.current_unit
->strm_pos
- 1) == FAILURE
)
534 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
539 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
541 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
545 if (!is_stream_io (dtp
))
547 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
548 dtp
->u
.p
.size_used
+= (gfc_offset
) nbytes
;
551 dtp
->u
.p
.current_unit
->strm_pos
+= (gfc_offset
) nbytes
;
557 /* Master function for unformatted reads. */
560 unformatted_read (st_parameter_dt
*dtp
, bt type
,
561 void *dest
, int kind
,
562 size_t size
, size_t nelems
)
566 /* Currently, character implies size=1. */
567 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
568 || size
== 1 || type
== BT_CHARACTER
)
571 read_block_direct (dtp
, dest
, &sz
);
578 /* Break up complex into its constituent reals. */
579 if (type
== BT_COMPLEX
)
586 /* By now, all complex variables have been split into their
587 constituent reals. For types with padding, we only need to
588 read kind bytes. We don't care about the contents
589 of the padding. If we hit a short record, then sz is
590 adjusted accordingly, making later reads no-ops. */
593 for (i
=0; i
<nelems
; i
++)
595 read_block_direct (dtp
, buffer
, &sz
);
596 reverse_memcpy (p
, buffer
, sz
);
603 /* Master function for unformatted writes. */
606 unformatted_write (st_parameter_dt
*dtp
, bt type
,
607 void *source
, int kind
,
608 size_t size
, size_t nelems
)
610 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
611 size
== 1 || type
== BT_CHARACTER
)
615 write_buf (dtp
, source
, size
);
623 /* Break up complex into its constituent reals. */
624 if (type
== BT_COMPLEX
)
632 /* By now, all complex variables have been split into their
633 constituent reals. For types with padding, we only need to
634 read kind bytes. We don't care about the contents
638 for (i
=0; i
<nelems
; i
++)
640 reverse_memcpy(buffer
, p
, size
);
642 write_buf (dtp
, buffer
, sz
);
648 /* Return a pointer to the name of a type. */
673 internal_error (NULL
, "type_name(): Bad type");
680 /* Write a constant string to the output.
681 This is complicated because the string can have doubled delimiters
682 in it. The length in the format node is the true length. */
685 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
687 char c
, delimiter
, *p
, *q
;
690 length
= f
->u
.string
.length
;
694 p
= write_block (dtp
, length
);
701 for (; length
> 0; length
--)
704 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
705 q
++; /* Skip the doubled delimiter. */
710 /* Given actual and expected types in a formatted data transfer, make
711 sure they agree. If not, an error message is generated. Returns
712 nonzero if something went wrong. */
715 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
719 if (actual
== expected
)
722 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
723 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
725 format_error (dtp
, f
, buffer
);
730 /* This subroutine is the main loop for a formatted data transfer
731 statement. It would be natural to implement this as a coroutine
732 with the user program, but C makes that awkward. We loop,
733 processing format elements. When we actually have to transfer
734 data instead of just setting flags, we return control to the user
735 program which calls a subroutine that supplies the address and type
736 of the next element, then comes back here to process it. */
739 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
742 char scratch
[SCRATCH_SIZE
];
747 int consume_data_flag
;
749 /* Change a complex data item into a pair of reals. */
751 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
752 if (type
== BT_COMPLEX
)
758 /* If there's an EOR condition, we simulate finalizing the transfer
760 if (dtp
->u
.p
.eor_condition
)
763 /* Set this flag so that commas in reads cause the read to complete before
764 the entire field has been read. The next read field will start right after
765 the comma in the stream. (Set to 0 for character reads). */
766 dtp
->u
.p
.sf_read_comma
= 1;
768 dtp
->u
.p
.line_buffer
= scratch
;
771 /* If reversion has occurred and there is another real data item,
772 then we have to move to the next record. */
773 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
775 dtp
->u
.p
.reversion_flag
= 0;
776 next_record (dtp
, 0);
779 consume_data_flag
= 1 ;
780 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
783 f
= next_format (dtp
);
786 /* No data descriptors left. */
788 generate_error (&dtp
->common
, ERROR_FORMAT
,
789 "Insufficient data descriptors in format after reversion");
793 /* Now discharge T, TR and X movements to the right. This is delayed
794 until a data producing format to suppress trailing spaces. */
797 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
798 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
799 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
800 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
801 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
804 if (dtp
->u
.p
.skips
> 0)
806 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
807 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
808 - dtp
->u
.p
.current_unit
->bytes_left
);
810 if (dtp
->u
.p
.skips
< 0)
812 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
813 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
815 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
818 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
819 - dtp
->u
.p
.current_unit
->bytes_left
);
826 if (require_type (dtp
, BT_INTEGER
, type
, f
))
829 if (dtp
->u
.p
.mode
== READING
)
830 read_decimal (dtp
, f
, p
, len
);
832 write_i (dtp
, f
, p
, len
);
840 if (compile_options
.allow_std
< GFC_STD_GNU
841 && require_type (dtp
, BT_INTEGER
, type
, f
))
844 if (dtp
->u
.p
.mode
== READING
)
845 read_radix (dtp
, f
, p
, len
, 2);
847 write_b (dtp
, f
, p
, len
);
855 if (compile_options
.allow_std
< GFC_STD_GNU
856 && require_type (dtp
, BT_INTEGER
, type
, f
))
859 if (dtp
->u
.p
.mode
== READING
)
860 read_radix (dtp
, f
, p
, len
, 8);
862 write_o (dtp
, f
, p
, len
);
870 if (compile_options
.allow_std
< GFC_STD_GNU
871 && require_type (dtp
, BT_INTEGER
, type
, f
))
874 if (dtp
->u
.p
.mode
== READING
)
875 read_radix (dtp
, f
, p
, len
, 16);
877 write_z (dtp
, f
, p
, len
);
885 if (dtp
->u
.p
.mode
== READING
)
886 read_a (dtp
, f
, p
, len
);
888 write_a (dtp
, f
, p
, len
);
896 if (dtp
->u
.p
.mode
== READING
)
897 read_l (dtp
, f
, p
, len
);
899 write_l (dtp
, f
, p
, len
);
906 if (require_type (dtp
, BT_REAL
, type
, f
))
909 if (dtp
->u
.p
.mode
== READING
)
910 read_f (dtp
, f
, p
, len
);
912 write_d (dtp
, f
, p
, len
);
919 if (require_type (dtp
, BT_REAL
, type
, f
))
922 if (dtp
->u
.p
.mode
== READING
)
923 read_f (dtp
, f
, p
, len
);
925 write_e (dtp
, f
, p
, len
);
931 if (require_type (dtp
, BT_REAL
, type
, f
))
934 if (dtp
->u
.p
.mode
== READING
)
935 read_f (dtp
, f
, p
, len
);
937 write_en (dtp
, f
, p
, len
);
944 if (require_type (dtp
, BT_REAL
, type
, f
))
947 if (dtp
->u
.p
.mode
== READING
)
948 read_f (dtp
, f
, p
, len
);
950 write_es (dtp
, f
, p
, len
);
957 if (require_type (dtp
, BT_REAL
, type
, f
))
960 if (dtp
->u
.p
.mode
== READING
)
961 read_f (dtp
, f
, p
, len
);
963 write_f (dtp
, f
, p
, len
);
970 if (dtp
->u
.p
.mode
== READING
)
974 read_decimal (dtp
, f
, p
, len
);
977 read_l (dtp
, f
, p
, len
);
980 read_a (dtp
, f
, p
, len
);
983 read_f (dtp
, f
, p
, len
);
992 write_i (dtp
, f
, p
, len
);
995 write_l (dtp
, f
, p
, len
);
998 write_a (dtp
, f
, p
, len
);
1001 write_d (dtp
, f
, p
, len
);
1005 internal_error (&dtp
->common
,
1006 "formatted_transfer(): Bad type");
1012 consume_data_flag
= 0 ;
1013 if (dtp
->u
.p
.mode
== READING
)
1015 format_error (dtp
, f
, "Constant string in input format");
1018 write_constant_string (dtp
, f
);
1021 /* Format codes that don't transfer data. */
1024 consume_data_flag
= 0 ;
1026 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
1027 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
1028 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
1030 /* Writes occur just before the switch on f->format, above, so
1031 that trailing blanks are suppressed, unless we are doing a
1032 non-advancing write in which case we want to output the blanks
1034 if (dtp
->u
.p
.mode
== WRITING
1035 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
1037 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
1038 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1040 if (dtp
->u
.p
.mode
== READING
)
1041 read_x (dtp
, f
->u
.n
);
1047 if (f
->format
== FMT_TL
)
1050 /* Handle the special case when no bytes have been used yet.
1051 Cannot go below zero. */
1052 if (bytes_used
== 0)
1054 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
1055 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
1056 : dtp
->u
.p
.pending_spaces
;
1057 dtp
->u
.p
.skips
-= f
->u
.n
;
1058 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
1061 pos
= bytes_used
- f
->u
.n
;
1065 consume_data_flag
= 0;
1069 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1070 left tab limit. We do not check if the position has gone
1071 beyond the end of record because a subsequent tab could
1072 bring us back again. */
1073 pos
= pos
< 0 ? 0 : pos
;
1075 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
1076 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
1077 + pos
- dtp
->u
.p
.max_pos
;
1079 if (dtp
->u
.p
.skips
== 0)
1082 /* Writes occur just before the switch on f->format, above, so that
1083 trailing blanks are suppressed. */
1084 if (dtp
->u
.p
.mode
== READING
)
1086 /* Adjust everything for end-of-record condition */
1087 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
1089 if (dtp
->u
.p
.sf_seen_eor
== 2)
1091 /* The EOR was a CRLF (two bytes wide). */
1092 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
1093 dtp
->u
.p
.skips
-= 2;
1097 /* The EOR marker was only one byte wide. */
1098 dtp
->u
.p
.current_unit
->bytes_left
--;
1102 dtp
->u
.p
.sf_seen_eor
= 0;
1104 if (dtp
->u
.p
.skips
< 0)
1106 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
1107 dtp
->u
.p
.current_unit
->bytes_left
1108 -= (gfc_offset
) dtp
->u
.p
.skips
;
1109 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1112 read_x (dtp
, dtp
->u
.p
.skips
);
1118 consume_data_flag
= 0 ;
1119 dtp
->u
.p
.sign_status
= SIGN_S
;
1123 consume_data_flag
= 0 ;
1124 dtp
->u
.p
.sign_status
= SIGN_SS
;
1128 consume_data_flag
= 0 ;
1129 dtp
->u
.p
.sign_status
= SIGN_SP
;
1133 consume_data_flag
= 0 ;
1134 dtp
->u
.p
.blank_status
= BLANK_NULL
;
1138 consume_data_flag
= 0 ;
1139 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
1143 consume_data_flag
= 0 ;
1144 dtp
->u
.p
.scale_factor
= f
->u
.k
;
1148 consume_data_flag
= 0 ;
1149 dtp
->u
.p
.seen_dollar
= 1;
1153 consume_data_flag
= 0 ;
1154 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1155 next_record (dtp
, 0);
1159 /* A colon descriptor causes us to exit this loop (in
1160 particular preventing another / descriptor from being
1161 processed) unless there is another data item to be
1163 consume_data_flag
= 0 ;
1169 internal_error (&dtp
->common
, "Bad format node");
1172 /* Free a buffer that we had to allocate during a sequential
1173 formatted read of a block that was larger than the static
1176 if (dtp
->u
.p
.line_buffer
!= scratch
)
1178 free_mem (dtp
->u
.p
.line_buffer
);
1179 dtp
->u
.p
.line_buffer
= scratch
;
1182 /* Adjust the item count and data pointer. */
1184 if ((consume_data_flag
> 0) && (n
> 0))
1187 p
= ((char *) p
) + size
;
1190 if (dtp
->u
.p
.mode
== READING
)
1193 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1194 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1200 /* Come here when we need a data descriptor but don't have one. We
1201 push the current format node back onto the input, then return and
1202 let the user program call us back with the data. */
1204 unget_format (dtp
, f
);
1208 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1209 size_t size
, size_t nelems
)
1216 /* Big loop over all the elements. */
1217 for (elem
= 0; elem
< nelems
; elem
++)
1219 dtp
->u
.p
.item_count
++;
1220 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1226 /* Data transfer entry points. The type of the data entity is
1227 implicit in the subroutine call. This prevents us from having to
1228 share a common enum with the compiler. */
1231 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1233 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1235 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1240 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1243 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1245 size
= size_from_real_kind (kind
);
1246 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1251 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1253 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1255 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1260 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1262 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1264 /* Currently we support only 1 byte chars, and the library is a bit
1265 confused of character kind vs. length, so we kludge it by setting
1267 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1272 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1275 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1277 size
= size_from_complex_kind (kind
);
1278 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1283 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1284 gfc_charlen_type charlen
)
1286 index_type count
[GFC_MAX_DIMENSIONS
];
1287 index_type extent
[GFC_MAX_DIMENSIONS
];
1288 index_type stride
[GFC_MAX_DIMENSIONS
];
1289 index_type stride0
, rank
, size
, type
, n
;
1294 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1297 type
= GFC_DESCRIPTOR_TYPE (desc
);
1298 size
= GFC_DESCRIPTOR_SIZE (desc
);
1300 /* FIXME: What a kludge: Array descriptors and the IO library use
1301 different enums for types. */
1304 case GFC_DTYPE_UNKNOWN
:
1305 iotype
= BT_NULL
; /* Is this correct? */
1307 case GFC_DTYPE_INTEGER
:
1308 iotype
= BT_INTEGER
;
1310 case GFC_DTYPE_LOGICAL
:
1311 iotype
= BT_LOGICAL
;
1313 case GFC_DTYPE_REAL
:
1316 case GFC_DTYPE_COMPLEX
:
1317 iotype
= BT_COMPLEX
;
1319 case GFC_DTYPE_CHARACTER
:
1320 iotype
= BT_CHARACTER
;
1321 /* FIXME: Currently dtype contains the charlen, which is
1322 clobbered if charlen > 2**24. That's why we use a separate
1323 argument for the charlen. However, if we want to support
1324 non-8-bit charsets we need to fix dtype to contain
1325 sizeof(chartype) and fix the code below. */
1329 case GFC_DTYPE_DERIVED
:
1330 internal_error (&dtp
->common
,
1331 "Derived type I/O should have been handled via the frontend.");
1334 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1337 rank
= GFC_DESCRIPTOR_RANK (desc
);
1338 for (n
= 0; n
< rank
; n
++)
1341 stride
[n
] = desc
->dim
[n
].stride
;
1342 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1344 /* If the extent of even one dimension is zero, then the entire
1345 array section contains zero elements, so we return. */
1350 stride0
= stride
[0];
1352 /* If the innermost dimension has stride 1, we can do the transfer
1353 in contiguous chunks. */
1359 data
= GFC_DESCRIPTOR_DATA (desc
);
1363 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1364 data
+= stride0
* size
* tsize
;
1367 while (count
[n
] == extent
[n
])
1370 data
-= stride
[n
] * extent
[n
] * size
;
1380 data
+= stride
[n
] * size
;
1387 /* Preposition a sequential unformatted file while reading. */
1390 us_read (st_parameter_dt
*dtp
)
1399 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1402 if (compile_options
.record_marker
== 0)
1403 n
= sizeof (gfc_offset
);
1405 n
= compile_options
.record_marker
;
1409 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1413 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1414 return; /* end of file */
1417 if (p
== NULL
|| n
!= nr
)
1419 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1423 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1424 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1426 switch (compile_options
.record_marker
)
1429 memcpy (&i
, p
, sizeof(gfc_offset
));
1432 case sizeof(GFC_INTEGER_4
):
1433 memcpy (&i4
, p
, sizeof (i4
));
1437 case sizeof(GFC_INTEGER_8
):
1438 memcpy (&i8
, p
, sizeof (i8
));
1443 runtime_error ("Illegal value for record marker");
1448 switch (compile_options
.record_marker
)
1451 reverse_memcpy (&i
, p
, sizeof(gfc_offset
));
1454 case sizeof(GFC_INTEGER_4
):
1455 reverse_memcpy (&i4
, p
, sizeof (i4
));
1459 case sizeof(GFC_INTEGER_8
):
1460 reverse_memcpy (&i8
, p
, sizeof (i8
));
1465 runtime_error ("Illegal value for record marker");
1469 dtp
->u
.p
.current_unit
->bytes_left
= i
;
1473 /* Preposition a sequential unformatted file while writing. This
1474 amount to writing a bogus length that will be filled in later. */
1477 us_write (st_parameter_dt
*dtp
)
1484 if (compile_options
.record_marker
== 0)
1485 nbytes
= sizeof (gfc_offset
);
1487 nbytes
= compile_options
.record_marker
;
1489 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1490 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1492 /* For sequential unformatted, we write until we have more bytes
1493 than can fit in the record markers. If disk space runs out first,
1494 it will error on the write. */
1495 dtp
->u
.p
.current_unit
->recl
= max_offset
;
1497 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1501 /* Position to the next record prior to transfer. We are assumed to
1502 be before the next record. We also calculate the bytes in the next
1506 pre_position (st_parameter_dt
*dtp
)
1508 if (dtp
->u
.p
.current_unit
->current_record
)
1509 return; /* Already positioned. */
1511 switch (current_mode (dtp
))
1513 case FORMATTED_STREAM
:
1514 case UNFORMATTED_STREAM
:
1515 /* There are no records with stream I/O. Set the default position
1516 to the beginning of the file if no position was specified. */
1517 if ((dtp
->common
.flags
& IOPARM_DT_HAS_REC
) == 0)
1518 dtp
->u
.p
.current_unit
->strm_pos
= 1;
1521 case UNFORMATTED_SEQUENTIAL
:
1522 if (dtp
->u
.p
.mode
== READING
)
1529 case FORMATTED_SEQUENTIAL
:
1530 case FORMATTED_DIRECT
:
1531 case UNFORMATTED_DIRECT
:
1532 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1536 dtp
->u
.p
.current_unit
->current_record
= 1;
1540 /* Initialize things for a data transfer. This code is common for
1541 both reading and writing. */
1544 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1546 unit_flags u_flags
; /* Used for creating a unit if needed. */
1547 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1548 namelist_info
*ionml
;
1550 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1551 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1552 dtp
->u
.p
.ionml
= ionml
;
1553 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1555 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1556 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1558 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1559 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1560 { /* Open the unit with some default flags. */
1561 st_parameter_open opp
;
1564 if (dtp
->common
.unit
< 0)
1566 close_unit (dtp
->u
.p
.current_unit
);
1567 dtp
->u
.p
.current_unit
= NULL
;
1568 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1569 "Bad unit number in OPEN statement");
1572 memset (&u_flags
, '\0', sizeof (u_flags
));
1573 u_flags
.access
= ACCESS_SEQUENTIAL
;
1574 u_flags
.action
= ACTION_READWRITE
;
1576 /* Is it unformatted? */
1577 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1578 | IOPARM_DT_IONML_SET
)))
1579 u_flags
.form
= FORM_UNFORMATTED
;
1581 u_flags
.form
= FORM_UNSPECIFIED
;
1583 u_flags
.delim
= DELIM_UNSPECIFIED
;
1584 u_flags
.blank
= BLANK_UNSPECIFIED
;
1585 u_flags
.pad
= PAD_UNSPECIFIED
;
1586 u_flags
.status
= STATUS_UNKNOWN
;
1588 conv
= get_unformatted_convert (dtp
->common
.unit
);
1590 if (conv
== CONVERT_NONE
)
1591 conv
= compile_options
.convert
;
1593 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1594 and 1 on big-endian machines. */
1597 case CONVERT_NATIVE
:
1602 conv
= l8_to_l4_offset
? CONVERT_NATIVE
: CONVERT_SWAP
;
1605 case CONVERT_LITTLE
:
1606 conv
= l8_to_l4_offset
? CONVERT_SWAP
: CONVERT_NATIVE
;
1610 internal_error (&opp
.common
, "Illegal value for CONVERT");
1614 u_flags
.convert
= conv
;
1616 opp
.common
= dtp
->common
;
1617 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1618 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1619 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1620 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1621 if (dtp
->u
.p
.current_unit
== NULL
)
1625 /* Check the action. */
1627 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1628 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1629 "Cannot read from file opened for WRITE");
1631 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1632 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1633 "Cannot write to file opened for READ");
1635 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1638 dtp
->u
.p
.first_item
= 1;
1640 /* Check the format. */
1642 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1645 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1648 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1649 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1651 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1652 "Format present for UNFORMATTED data transfer");
1654 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1656 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1657 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1658 "A format cannot be specified with a namelist");
1660 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1661 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1662 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1663 "Missing format for FORMATTED data transfer");
1665 if (is_internal_unit (dtp
)
1666 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1667 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1668 "Internal file cannot be accessed by UNFORMATTED data transfer");
1670 /* Check the record or position number. */
1672 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1673 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1675 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1676 "Direct access data transfer requires record number");
1680 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1681 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1683 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1684 "Record number not allowed for sequential access data transfer");
1688 /* Process the ADVANCE option. */
1690 dtp
->u
.p
.advance_status
1691 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1692 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1693 "Bad ADVANCE parameter in data transfer statement");
1695 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1697 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1698 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1699 "ADVANCE specification conflicts with sequential access");
1701 if (is_internal_unit (dtp
))
1702 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1703 "ADVANCE specification conflicts with internal file");
1705 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1706 != IOPARM_DT_HAS_FORMAT
)
1707 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1708 "ADVANCE specification requires an explicit format");
1713 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1714 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1715 "EOR specification requires an ADVANCE specification of NO");
1717 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1718 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1719 "SIZE specification requires an ADVANCE specification of NO");
1723 { /* Write constraints. */
1724 if ((cf
& IOPARM_END
) != 0)
1725 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1726 "END specification cannot appear in a write statement");
1728 if ((cf
& IOPARM_EOR
) != 0)
1729 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1730 "EOR specification cannot appear in a write statement");
1732 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1733 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1734 "SIZE specification cannot appear in a write statement");
1737 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1738 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1739 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1742 /* Sanity checks on the record number. */
1743 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1747 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1748 "Record number must be positive");
1752 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1754 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1755 "Record number too large");
1759 /* Check to see if we might be reading what we wrote before */
1761 if (dtp
->u
.p
.mode
== READING
1762 && dtp
->u
.p
.current_unit
->mode
== WRITING
1763 && !is_internal_unit (dtp
))
1764 flush(dtp
->u
.p
.current_unit
->s
);
1766 /* Check whether the record exists to be read. Only
1767 a partial record needs to exist. */
1769 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1770 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1772 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1773 "Non-existing record number");
1777 /* Position the file. */
1778 if (!is_stream_io (dtp
))
1780 if (sseek (dtp
->u
.p
.current_unit
->s
, (gfc_offset
) (dtp
->rec
- 1)
1781 * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1783 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1788 dtp
->u
.p
.current_unit
->strm_pos
= dtp
->rec
;
1792 /* Overwriting an existing sequential file ?
1793 it is always safe to truncate the file on the first write */
1794 if (dtp
->u
.p
.mode
== WRITING
1795 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1796 && dtp
->u
.p
.current_unit
->last_record
== 0
1797 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1798 struncate(dtp
->u
.p
.current_unit
->s
);
1800 /* Bugware for badly written mixed C-Fortran I/O. */
1801 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1803 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1805 /* Set the initial value of flags. */
1807 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1808 dtp
->u
.p
.sign_status
= SIGN_S
;
1812 /* Set up the subroutine that will handle the transfers. */
1816 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1817 dtp
->u
.p
.transfer
= unformatted_read
;
1820 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1821 dtp
->u
.p
.transfer
= list_formatted_read
;
1823 dtp
->u
.p
.transfer
= formatted_transfer
;
1828 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1829 dtp
->u
.p
.transfer
= unformatted_write
;
1832 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1833 dtp
->u
.p
.transfer
= list_formatted_write
;
1835 dtp
->u
.p
.transfer
= formatted_transfer
;
1839 /* Make sure that we don't do a read after a nonadvancing write. */
1843 if (dtp
->u
.p
.current_unit
->read_bad
&& !is_stream_io (dtp
))
1845 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1846 "Cannot READ after a nonadvancing WRITE");
1852 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
1853 dtp
->u
.p
.current_unit
->read_bad
= 1;
1856 /* Start the data transfer if we are doing a formatted transfer. */
1857 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
1858 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
1859 && dtp
->u
.p
.ionml
== NULL
)
1860 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
1863 /* Initialize an array_loop_spec given the array descriptor. The function
1864 returns the index of the last element of the array. */
1867 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
1869 int rank
= GFC_DESCRIPTOR_RANK(desc
);
1874 for (i
=0; i
<rank
; i
++)
1877 ls
[i
].start
= desc
->dim
[i
].lbound
;
1878 ls
[i
].end
= desc
->dim
[i
].ubound
;
1879 ls
[i
].step
= desc
->dim
[i
].stride
;
1881 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
1882 * desc
->dim
[i
].stride
;
1887 /* Determine the index to the next record in an internal unit array by
1888 by incrementing through the array_loop_spec. TODO: Implement handling
1889 negative strides. */
1892 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
1900 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
1905 if (ls
[i
].idx
> ls
[i
].end
)
1907 ls
[i
].idx
= ls
[i
].start
;
1913 index
= index
+ (ls
[i
].idx
- 1) * ls
[i
].step
;
1918 /* Space to the next record for read mode. If the file is not
1919 seekable, we read MAX_READ chunks until we get to the right
1922 #define MAX_READ 4096
1925 next_record_r (st_parameter_dt
*dtp
)
1927 gfc_offset
new, record
;
1928 int bytes_left
, rlength
, length
;
1931 switch (current_mode (dtp
))
1933 /* No records in unformatted STREAM I/O. */
1934 case UNFORMATTED_STREAM
:
1937 case UNFORMATTED_SEQUENTIAL
:
1939 /* Skip over tail */
1940 dtp
->u
.p
.current_unit
->bytes_left
+=
1941 compile_options
.record_marker
== 0 ?
1942 sizeof (gfc_offset
) : compile_options
.record_marker
;
1944 /* Fall through... */
1946 case FORMATTED_DIRECT
:
1947 case UNFORMATTED_DIRECT
:
1948 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1951 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
1953 new = file_position (dtp
->u
.p
.current_unit
->s
)
1954 + dtp
->u
.p
.current_unit
->bytes_left
;
1956 /* Direct access files do not generate END conditions,
1958 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
1959 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1963 { /* Seek by reading data. */
1964 while (dtp
->u
.p
.current_unit
->bytes_left
> 0)
1966 rlength
= length
= (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left
) ?
1967 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left
;
1969 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
1972 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1976 dtp
->u
.p
.current_unit
->bytes_left
-= length
;
1981 case FORMATTED_STREAM
:
1982 case FORMATTED_SEQUENTIAL
:
1984 /* sf_read has already terminated input because of an '\n' */
1985 if (dtp
->u
.p
.sf_seen_eor
)
1987 dtp
->u
.p
.sf_seen_eor
= 0;
1991 if (is_internal_unit (dtp
))
1993 if (is_array_io (dtp
))
1995 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1997 /* Now seek to this record. */
1998 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1999 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2001 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2004 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2008 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2009 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
2011 dtp
->u
.p
.current_unit
->bytes_left
2012 = dtp
->u
.p
.current_unit
->recl
;
2018 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
2022 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2028 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2032 if (is_stream_io (dtp
))
2033 dtp
->u
.p
.current_unit
->strm_pos
++;
2040 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2041 test_endfile (dtp
->u
.p
.current_unit
);
2045 /* Small utility function to write a record marker, taking care of
2046 byte swapping and of choosing the correct size. */
2049 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
2054 char p
[sizeof (GFC_INTEGER_8
)];
2056 if (compile_options
.record_marker
== 0)
2057 len
= sizeof (gfc_offset
);
2059 len
= compile_options
.record_marker
;
2061 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2062 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
2064 switch (compile_options
.record_marker
)
2067 return swrite (dtp
->u
.p
.current_unit
->s
, &buf
, &len
);
2070 case sizeof (GFC_INTEGER_4
):
2072 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
2075 case sizeof (GFC_INTEGER_8
):
2077 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
2081 runtime_error ("Illegal value for record marker");
2087 switch (compile_options
.record_marker
)
2090 reverse_memcpy (p
, &buf
, sizeof (gfc_offset
));
2091 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2094 case sizeof (GFC_INTEGER_4
):
2096 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
2097 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2100 case sizeof (GFC_INTEGER_8
):
2102 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_4
));
2103 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
2107 runtime_error ("Illegal value for record marker");
2115 /* Position to the next record in write mode. */
2118 next_record_w (st_parameter_dt
*dtp
, int done
)
2120 gfc_offset c
, m
, record
, max_pos
;
2123 size_t record_marker
;
2125 /* Zero counters for X- and T-editing. */
2126 max_pos
= dtp
->u
.p
.max_pos
;
2127 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
2129 switch (current_mode (dtp
))
2131 /* No records in unformatted STREAM I/O. */
2132 case UNFORMATTED_STREAM
:
2135 case FORMATTED_DIRECT
:
2136 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2139 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
2140 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
2145 case UNFORMATTED_DIRECT
:
2146 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2150 case UNFORMATTED_SEQUENTIAL
:
2151 /* Bytes written. */
2152 m
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
2153 c
= file_position (dtp
->u
.p
.current_unit
->s
);
2155 /* Write the length tail. */
2157 if (write_us_marker (dtp
, m
) != 0)
2160 if (compile_options
.record_marker
== 4)
2161 record_marker
= sizeof(GFC_INTEGER_4
);
2163 record_marker
= sizeof (gfc_offset
);
2165 /* Seek to the head and overwrite the bogus length with the real
2168 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
2172 if (write_us_marker (dtp
, m
) != 0)
2175 /* Seek past the end of the current record. */
2177 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
2182 case FORMATTED_STREAM
:
2183 case FORMATTED_SEQUENTIAL
:
2185 if (is_internal_unit (dtp
))
2187 if (is_array_io (dtp
))
2189 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2191 /* If the farthest position reached is greater than current
2192 position, adjust the position and set length to pad out
2193 whats left. Otherwise just pad whats left.
2194 (for character array unit) */
2195 m
= dtp
->u
.p
.current_unit
->recl
2196 - dtp
->u
.p
.current_unit
->bytes_left
;
2199 length
= (int) (max_pos
- m
);
2200 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2201 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2204 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2206 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2210 /* Now that the current record has been padded out,
2211 determine where the next record in the array is. */
2212 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2214 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2216 /* Now seek to this record */
2217 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2219 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2221 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2225 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2231 /* If this is the last call to next_record move to the farthest
2232 position reached and set length to pad out the remainder
2233 of the record. (for character scaler unit) */
2236 m
= dtp
->u
.p
.current_unit
->recl
2237 - dtp
->u
.p
.current_unit
->bytes_left
;
2240 length
= (int) (max_pos
- m
);
2241 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2242 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2245 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2247 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2249 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2257 /* If this is the last call to next_record move to the farthest
2258 position reached in preparation for completing the record.
2262 m
= dtp
->u
.p
.current_unit
->recl
-
2263 dtp
->u
.p
.current_unit
->bytes_left
;
2266 length
= (int) (max_pos
- m
);
2267 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2271 const char crlf
[] = "\r\n";
2277 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2280 if (is_stream_io (dtp
))
2281 dtp
->u
.p
.current_unit
->strm_pos
+= len
;
2287 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2292 /* Position to the next record, which means moving to the end of the
2293 current record. This can happen under several different
2294 conditions. If the done flag is not set, we get ready to process
2298 next_record (st_parameter_dt
*dtp
, int done
)
2300 gfc_offset fp
; /* File position. */
2302 dtp
->u
.p
.current_unit
->read_bad
= 0;
2304 if (dtp
->u
.p
.mode
== READING
)
2305 next_record_r (dtp
);
2307 next_record_w (dtp
, done
);
2309 if (!is_stream_io (dtp
))
2311 /* keep position up to date for INQUIRE */
2312 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
2313 dtp
->u
.p
.current_unit
->current_record
= 0;
2314 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2316 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2317 /* Calculate next record, rounding up partial records. */
2318 dtp
->u
.p
.current_unit
->last_record
=
2319 (fp
+ dtp
->u
.p
.current_unit
->recl
- 1) /
2320 dtp
->u
.p
.current_unit
->recl
;
2323 dtp
->u
.p
.current_unit
->last_record
++;
2331 /* Finalize the current data transfer. For a nonadvancing transfer,
2332 this means advancing to the next record. For internal units close the
2333 stream associated with the unit. */
2336 finalize_transfer (st_parameter_dt
*dtp
)
2339 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2341 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2342 *dtp
->size
= (GFC_INTEGER_4
) dtp
->u
.p
.size_used
;
2344 if (dtp
->u
.p
.eor_condition
)
2346 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2350 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2353 if ((dtp
->u
.p
.ionml
!= NULL
)
2354 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2356 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2357 namelist_read (dtp
);
2359 namelist_write (dtp
);
2362 dtp
->u
.p
.transfer
= NULL
;
2363 if (dtp
->u
.p
.current_unit
== NULL
)
2366 dtp
->u
.p
.eof_jump
= &eof_jump
;
2367 if (setjmp (eof_jump
))
2369 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2373 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2374 finish_list_read (dtp
);
2375 else if (!is_stream_io (dtp
))
2377 dtp
->u
.p
.current_unit
->current_record
= 0;
2378 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
2380 /* Most systems buffer lines, so force the partial record
2381 to be written out. */
2382 if (!is_internal_unit (dtp
))
2383 flush (dtp
->u
.p
.current_unit
->s
);
2384 dtp
->u
.p
.seen_dollar
= 0;
2387 next_record (dtp
, 1);
2391 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
)
2392 next_record (dtp
, 1);
2393 flush (dtp
->u
.p
.current_unit
->s
);
2396 sfree (dtp
->u
.p
.current_unit
->s
);
2399 /* Transfer function for IOLENGTH. It doesn't actually do any
2400 data transfer, it just updates the length counter. */
2403 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2404 void *dest
__attribute__ ((unused
)),
2405 int kind
__attribute__((unused
)),
2406 size_t size
, size_t nelems
)
2408 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2409 *dtp
->iolength
+= (GFC_INTEGER_4
) size
* nelems
;
2413 /* Initialize the IOLENGTH data transfer. This function is in essence
2414 a very much simplified version of data_transfer_init(), because it
2415 doesn't have to deal with units at all. */
2418 iolength_transfer_init (st_parameter_dt
*dtp
)
2420 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2423 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2425 /* Set up the subroutine that will handle the transfers. */
2427 dtp
->u
.p
.transfer
= iolength_transfer
;
2431 /* Library entry point for the IOLENGTH form of the INQUIRE
2432 statement. The IOLENGTH form requires no I/O to be performed, but
2433 it must still be a runtime library call so that we can determine
2434 the iolength for dynamic arrays and such. */
2436 extern void st_iolength (st_parameter_dt
*);
2437 export_proto(st_iolength
);
2440 st_iolength (st_parameter_dt
*dtp
)
2442 library_start (&dtp
->common
);
2443 iolength_transfer_init (dtp
);
2446 extern void st_iolength_done (st_parameter_dt
*);
2447 export_proto(st_iolength_done
);
2450 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2453 if (dtp
->u
.p
.scratch
!= NULL
)
2454 free_mem (dtp
->u
.p
.scratch
);
2459 /* The READ statement. */
2461 extern void st_read (st_parameter_dt
*);
2462 export_proto(st_read
);
2465 st_read (st_parameter_dt
*dtp
)
2467 library_start (&dtp
->common
);
2469 data_transfer_init (dtp
, 1);
2471 /* Handle complications dealing with the endfile record. It is
2472 significant that this is the only place where ERROR_END is
2473 generated. Reading an end of file elsewhere is either end of
2474 record or an I/O error. */
2476 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2477 switch (dtp
->u
.p
.current_unit
->endfile
)
2483 if (!is_internal_unit (dtp
))
2485 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2486 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2487 dtp
->u
.p
.current_unit
->current_record
= 0;
2492 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2493 dtp
->u
.p
.current_unit
->current_record
= 0;
2498 extern void st_read_done (st_parameter_dt
*);
2499 export_proto(st_read_done
);
2502 st_read_done (st_parameter_dt
*dtp
)
2504 finalize_transfer (dtp
);
2505 free_format_data (dtp
);
2507 if (dtp
->u
.p
.scratch
!= NULL
)
2508 free_mem (dtp
->u
.p
.scratch
);
2509 if (dtp
->u
.p
.current_unit
!= NULL
)
2510 unlock_unit (dtp
->u
.p
.current_unit
);
2512 free_internal_unit (dtp
);
2517 extern void st_write (st_parameter_dt
*);
2518 export_proto(st_write
);
2521 st_write (st_parameter_dt
*dtp
)
2523 library_start (&dtp
->common
);
2524 data_transfer_init (dtp
, 0);
2527 extern void st_write_done (st_parameter_dt
*);
2528 export_proto(st_write_done
);
2531 st_write_done (st_parameter_dt
*dtp
)
2533 finalize_transfer (dtp
);
2535 /* Deal with endfile conditions associated with sequential files. */
2537 if (dtp
->u
.p
.current_unit
!= NULL
2538 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2539 switch (dtp
->u
.p
.current_unit
->endfile
)
2541 case AT_ENDFILE
: /* Remain at the endfile record. */
2545 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2549 /* Get rid of whatever is after this record. */
2550 if (!is_internal_unit (dtp
))
2552 flush (dtp
->u
.p
.current_unit
->s
);
2553 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2554 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2556 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2560 free_format_data (dtp
);
2562 if (dtp
->u
.p
.scratch
!= NULL
)
2563 free_mem (dtp
->u
.p
.scratch
);
2564 if (dtp
->u
.p
.current_unit
!= NULL
)
2565 unlock_unit (dtp
->u
.p
.current_unit
);
2567 free_internal_unit (dtp
);
2572 /* Receives the scalar information for namelist objects and stores it
2573 in a linked list of namelist_info types. */
2575 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2576 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2577 export_proto(st_set_nml_var
);
2581 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2582 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2583 GFC_INTEGER_4 dtype
)
2585 namelist_info
*t1
= NULL
;
2588 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2590 nml
->mem_pos
= var_addr
;
2592 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2593 strcpy (nml
->var_name
, var_name
);
2595 nml
->len
= (int) len
;
2596 nml
->string_length
= (index_type
) string_length
;
2598 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2599 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2600 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2602 if (nml
->var_rank
> 0)
2604 nml
->dim
= (descriptor_dimension
*)
2605 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2606 nml
->ls
= (array_loop_spec
*)
2607 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2617 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2619 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2620 dtp
->u
.p
.ionml
= nml
;
2624 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2629 /* Store the dimensional information for the namelist object. */
2630 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2631 GFC_INTEGER_4
, GFC_INTEGER_4
,
2633 export_proto(st_set_nml_var_dim
);
2636 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2637 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2638 GFC_INTEGER_4 ubound
)
2640 namelist_info
* nml
;
2645 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2647 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2648 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2649 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2652 /* Reverse memcpy - used for byte swapping. */
2654 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2660 s
= (char *) src
+ n
- 1;
2662 /* Write with ascending order - this is likely faster
2663 on modern architectures because of write combining. */