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
100 current_mode (st_parameter_dt
*dtp
)
104 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
106 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
107 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
111 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
112 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
119 /* Mid level data transfer statements. These subroutines do reading
120 and writing in the style of salloc_r()/salloc_w() within the
123 /* When reading sequential formatted records we have a problem. We
124 don't know how long the line is until we read the trailing newline,
125 and we don't want to read too much. If we read too much, we might
126 have to do a physical seek backwards depending on how much data is
127 present, and devices like terminals aren't seekable and would cause
130 Given this, the solution is to read a byte at a time, stopping if
131 we hit the newline. For small locations, we use a static buffer.
132 For larger allocations, we are forced to allocate memory on the
133 heap. Hopefully this won't happen very often. */
136 read_sf (st_parameter_dt
*dtp
, int *length
)
139 int n
, readlen
, crlf
;
142 if (*length
> SCRATCH_SIZE
)
143 dtp
->u
.p
.line_buffer
= get_mem (*length
);
144 p
= base
= dtp
->u
.p
.line_buffer
;
146 /* If we have seen an eor previously, return a length of 0. The
147 caller is responsible for correctly padding the input field. */
148 if (dtp
->u
.p
.sf_seen_eor
)
159 if (is_internal_unit (dtp
))
161 /* readlen may be modified inside salloc_r if
162 is_internal_unit (dtp) is true. */
166 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
170 /* If we have a line without a terminating \n, drop through to
172 if (readlen
< 1 && n
== 0)
174 generate_error (&dtp
->common
, ERROR_END
, NULL
);
178 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
180 /* Unexpected end of line. */
182 /* If we see an EOR during non-advancing I/O, we need to skip
183 the rest of the I/O statement. Set the corresponding flag. */
184 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
185 dtp
->u
.p
.eor_condition
= 1;
188 /* If we encounter a CR, it might be a CRLF. */
189 if (*q
== '\r') /* Probably a CRLF */
192 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
193 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
194 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
195 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
200 /* Without padding, terminate the I/O statement without assigning
201 the value. With padding, the value still needs to be assigned,
202 so we can just continue with a short read. */
203 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
205 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
210 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
213 /* Short circuit the read if a comma is found during numeric input.
214 The flag is set to zero during character reads so that commas in
215 strings are not ignored */
217 if (dtp
->u
.p
.sf_read_comma
== 1)
219 notify_std (GFC_STD_GNU
, "Comma in formatted numeric read.");
226 dtp
->u
.p
.sf_seen_eor
= 0;
229 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
231 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
232 *dtp
->size
+= *length
;
238 /* Function for reading the next couple of bytes from the current
239 file, advancing the current position. We return a pointer to a
240 buffer containing the bytes. We return NULL on end of record or
243 If the read is short, then it is because the current record does not
244 have enough data to satisfy the read request and the file was
245 opened with PAD=YES. The caller must assume tailing spaces for
249 read_block (st_parameter_dt
*dtp
, int *length
)
254 if (dtp
->u
.p
.current_unit
->bytes_left
< *length
)
256 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
258 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
259 /* Not enough data left. */
263 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
266 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
267 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
268 return read_sf (dtp
, length
); /* Special case. */
270 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
273 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
275 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
278 if (nread
!= *length
)
279 { /* Short read, this shouldn't happen. */
280 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
284 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
293 /* Reads a block directly into application data space. */
296 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
302 if (dtp
->u
.p
.current_unit
->bytes_left
< *nbytes
)
304 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
306 /* Not enough data left. */
307 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
311 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
314 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
315 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
317 length
= (int *) nbytes
;
318 data
= read_sf (dtp
, length
); /* Special case. */
319 memcpy (buf
, data
, (size_t) *length
);
323 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
326 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
328 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
332 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
333 *dtp
->size
+= (GFC_INTEGER_4
) nread
;
335 if (nread
!= *nbytes
)
336 { /* Short read, e.g. if we hit EOF. */
337 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
339 memset (((char *) buf
) + nread
, ' ', *nbytes
- nread
);
343 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
348 /* Function for writing a block of bytes to the current file at the
349 current position, advancing the file pointer. We are given a length
350 and return a pointer to a buffer that the caller must (completely)
351 fill in. Returns NULL on error. */
354 write_block (st_parameter_dt
*dtp
, int length
)
358 if (dtp
->u
.p
.current_unit
->bytes_left
< length
)
360 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
364 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
365 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
369 generate_error (&dtp
->common
, ERROR_END
, NULL
);
373 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
374 *dtp
->size
+= length
;
380 /* High level interface to swrite(), taking care of errors. */
383 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
385 if (dtp
->u
.p
.current_unit
->bytes_left
< nbytes
)
387 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
388 generate_error (&dtp
->common
, ERROR_DIRECT_EOR
, NULL
);
390 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
394 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
396 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
398 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
402 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
404 *dtp
->size
+= (GFC_INTEGER_4
) nbytes
;
412 /* Master function for unformatted reads. */
415 unformatted_read (st_parameter_dt
*dtp
, bt type
,
416 void *dest
, int kind
,
417 size_t size
, size_t nelems
)
419 /* Currently, character implies size=1. */
420 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
421 || size
== 1 || type
== BT_CHARACTER
)
424 read_block_direct (dtp
, dest
, &size
);
432 /* Break up complex into its constituent reals. */
433 if (type
== BT_COMPLEX
)
440 /* By now, all complex variables have been split into their
441 constituent reals. For types with padding, we only need to
442 read kind bytes. We don't care about the contents
446 for (i
=0; i
<nelems
; i
++)
448 read_block_direct (dtp
, buffer
, &sz
);
449 reverse_memcpy (p
, buffer
, sz
);
456 /* Master function for unformatted writes. */
459 unformatted_write (st_parameter_dt
*dtp
, bt type
,
460 void *source
, int kind
,
461 size_t size
, size_t nelems
)
463 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
464 size
== 1 || type
== BT_CHARACTER
)
468 write_buf (dtp
, source
, size
);
476 /* Break up complex into its constituent reals. */
477 if (type
== BT_COMPLEX
)
485 /* By now, all complex variables have been split into their
486 constituent reals. For types with padding, we only need to
487 read kind bytes. We don't care about the contents
491 for (i
=0; i
<nelems
; i
++)
493 reverse_memcpy(buffer
, p
, size
);
495 write_buf (dtp
, buffer
, sz
);
501 /* Return a pointer to the name of a type. */
526 internal_error (NULL
, "type_name(): Bad type");
533 /* Write a constant string to the output.
534 This is complicated because the string can have doubled delimiters
535 in it. The length in the format node is the true length. */
538 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
540 char c
, delimiter
, *p
, *q
;
543 length
= f
->u
.string
.length
;
547 p
= write_block (dtp
, length
);
554 for (; length
> 0; length
--)
557 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
558 q
++; /* Skip the doubled delimiter. */
563 /* Given actual and expected types in a formatted data transfer, make
564 sure they agree. If not, an error message is generated. Returns
565 nonzero if something went wrong. */
568 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
572 if (actual
== expected
)
575 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
576 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
578 format_error (dtp
, f
, buffer
);
583 /* This subroutine is the main loop for a formatted data transfer
584 statement. It would be natural to implement this as a coroutine
585 with the user program, but C makes that awkward. We loop,
586 processesing format elements. When we actually have to transfer
587 data instead of just setting flags, we return control to the user
588 program which calls a subroutine that supplies the address and type
589 of the next element, then comes back here to process it. */
592 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
595 char scratch
[SCRATCH_SIZE
];
600 int consume_data_flag
;
602 /* Change a complex data item into a pair of reals. */
604 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
605 if (type
== BT_COMPLEX
)
611 /* If there's an EOR condition, we simulate finalizing the transfer
613 if (dtp
->u
.p
.eor_condition
)
616 /* Set this flag so that commas in reads cause the read to complete before
617 the entire field has been read. The next read field will start right after
618 the comma in the stream. (Set to 0 for character reads). */
619 dtp
->u
.p
.sf_read_comma
= 1;
621 dtp
->u
.p
.line_buffer
= scratch
;
624 /* If reversion has occurred and there is another real data item,
625 then we have to move to the next record. */
626 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
628 dtp
->u
.p
.reversion_flag
= 0;
629 next_record (dtp
, 0);
632 consume_data_flag
= 1 ;
633 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
636 f
= next_format (dtp
);
638 return; /* No data descriptors left (already raised). */
640 /* Now discharge T, TR and X movements to the right. This is delayed
641 until a data producing format to suppress trailing spaces. */
644 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
645 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
646 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
647 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
648 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
651 if (dtp
->u
.p
.skips
> 0)
653 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
654 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
655 - dtp
->u
.p
.current_unit
->bytes_left
);
657 if (dtp
->u
.p
.skips
< 0)
659 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
660 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
662 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
665 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
672 if (require_type (dtp
, BT_INTEGER
, type
, f
))
675 if (dtp
->u
.p
.mode
== READING
)
676 read_decimal (dtp
, f
, p
, len
);
678 write_i (dtp
, f
, p
, len
);
685 if (require_type (dtp
, BT_INTEGER
, type
, f
))
688 if (dtp
->u
.p
.mode
== READING
)
689 read_radix (dtp
, f
, p
, len
, 2);
691 write_b (dtp
, f
, p
, len
);
699 if (dtp
->u
.p
.mode
== READING
)
700 read_radix (dtp
, f
, p
, len
, 8);
702 write_o (dtp
, f
, p
, len
);
710 if (dtp
->u
.p
.mode
== READING
)
711 read_radix (dtp
, f
, p
, len
, 16);
713 write_z (dtp
, f
, p
, len
);
721 if (dtp
->u
.p
.mode
== READING
)
722 read_a (dtp
, f
, p
, len
);
724 write_a (dtp
, f
, p
, len
);
732 if (dtp
->u
.p
.mode
== READING
)
733 read_l (dtp
, f
, p
, len
);
735 write_l (dtp
, f
, p
, len
);
742 if (require_type (dtp
, BT_REAL
, type
, f
))
745 if (dtp
->u
.p
.mode
== READING
)
746 read_f (dtp
, f
, p
, len
);
748 write_d (dtp
, f
, p
, len
);
755 if (require_type (dtp
, BT_REAL
, type
, f
))
758 if (dtp
->u
.p
.mode
== READING
)
759 read_f (dtp
, f
, p
, len
);
761 write_e (dtp
, f
, p
, len
);
767 if (require_type (dtp
, BT_REAL
, type
, f
))
770 if (dtp
->u
.p
.mode
== READING
)
771 read_f (dtp
, f
, p
, len
);
773 write_en (dtp
, f
, p
, len
);
780 if (require_type (dtp
, BT_REAL
, type
, f
))
783 if (dtp
->u
.p
.mode
== READING
)
784 read_f (dtp
, f
, p
, len
);
786 write_es (dtp
, f
, p
, len
);
793 if (require_type (dtp
, BT_REAL
, type
, f
))
796 if (dtp
->u
.p
.mode
== READING
)
797 read_f (dtp
, f
, p
, len
);
799 write_f (dtp
, f
, p
, len
);
806 if (dtp
->u
.p
.mode
== READING
)
810 read_decimal (dtp
, f
, p
, len
);
813 read_l (dtp
, f
, p
, len
);
816 read_a (dtp
, f
, p
, len
);
819 read_f (dtp
, f
, p
, len
);
828 write_i (dtp
, f
, p
, len
);
831 write_l (dtp
, f
, p
, len
);
834 write_a (dtp
, f
, p
, len
);
837 write_d (dtp
, f
, p
, len
);
841 internal_error (&dtp
->common
,
842 "formatted_transfer(): Bad type");
848 consume_data_flag
= 0 ;
849 if (dtp
->u
.p
.mode
== READING
)
851 format_error (dtp
, f
, "Constant string in input format");
854 write_constant_string (dtp
, f
);
857 /* Format codes that don't transfer data. */
860 consume_data_flag
= 0 ;
862 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
863 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
864 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
866 /* Writes occur just before the switch on f->format, above, so
867 that trailing blanks are suppressed, unless we are doing a
868 non-advancing write in which case we want to output the blanks
870 if (dtp
->u
.p
.mode
== WRITING
871 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
873 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
874 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
876 if (dtp
->u
.p
.mode
== READING
)
877 read_x (dtp
, f
->u
.n
);
883 if (f
->format
== FMT_TL
)
886 /* Handle the special case when no bytes have been used yet.
887 Cannot go below zero. */
890 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
891 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
892 : dtp
->u
.p
.pending_spaces
;
893 dtp
->u
.p
.skips
-= f
->u
.n
;
894 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
897 pos
= bytes_used
- f
->u
.n
;
901 consume_data_flag
= 0;
905 /* Standard 10.6.1.1: excessive left tabbing is reset to the
906 left tab limit. We do not check if the position has gone
907 beyond the end of record because a subsequent tab could
908 bring us back again. */
909 pos
= pos
< 0 ? 0 : pos
;
911 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
912 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
913 + pos
- dtp
->u
.p
.max_pos
;
915 if (dtp
->u
.p
.skips
== 0)
918 /* Writes occur just before the switch on f->format, above, so that
919 trailing blanks are suppressed. */
920 if (dtp
->u
.p
.mode
== READING
)
922 /* Adjust everything for end-of-record condition */
923 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
925 if (dtp
->u
.p
.sf_seen_eor
== 2)
927 /* The EOR was a CRLF (two bytes wide). */
928 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
933 /* The EOR marker was only one byte wide. */
934 dtp
->u
.p
.current_unit
->bytes_left
--;
938 dtp
->u
.p
.sf_seen_eor
= 0;
940 if (dtp
->u
.p
.skips
< 0)
942 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
943 dtp
->u
.p
.current_unit
->bytes_left
944 -= (gfc_offset
) dtp
->u
.p
.skips
;
945 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
948 read_x (dtp
, dtp
->u
.p
.skips
);
954 consume_data_flag
= 0 ;
955 dtp
->u
.p
.sign_status
= SIGN_S
;
959 consume_data_flag
= 0 ;
960 dtp
->u
.p
.sign_status
= SIGN_SS
;
964 consume_data_flag
= 0 ;
965 dtp
->u
.p
.sign_status
= SIGN_SP
;
969 consume_data_flag
= 0 ;
970 dtp
->u
.p
.blank_status
= BLANK_NULL
;
974 consume_data_flag
= 0 ;
975 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
979 consume_data_flag
= 0 ;
980 dtp
->u
.p
.scale_factor
= f
->u
.k
;
984 consume_data_flag
= 0 ;
985 dtp
->u
.p
.seen_dollar
= 1;
989 consume_data_flag
= 0 ;
990 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
991 next_record (dtp
, 0);
995 /* A colon descriptor causes us to exit this loop (in
996 particular preventing another / descriptor from being
997 processed) unless there is another data item to be
999 consume_data_flag
= 0 ;
1005 internal_error (&dtp
->common
, "Bad format node");
1008 /* Free a buffer that we had to allocate during a sequential
1009 formatted read of a block that was larger than the static
1012 if (dtp
->u
.p
.line_buffer
!= scratch
)
1014 free_mem (dtp
->u
.p
.line_buffer
);
1015 dtp
->u
.p
.line_buffer
= scratch
;
1018 /* Adjust the item count and data pointer. */
1020 if ((consume_data_flag
> 0) && (n
> 0))
1023 p
= ((char *) p
) + size
;
1026 if (dtp
->u
.p
.mode
== READING
)
1029 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1030 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1036 /* Come here when we need a data descriptor but don't have one. We
1037 push the current format node back onto the input, then return and
1038 let the user program call us back with the data. */
1040 unget_format (dtp
, f
);
1044 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1045 size_t size
, size_t nelems
)
1052 /* Big loop over all the elements. */
1053 for (elem
= 0; elem
< nelems
; elem
++)
1055 dtp
->u
.p
.item_count
++;
1056 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1062 /* Data transfer entry points. The type of the data entity is
1063 implicit in the subroutine call. This prevents us from having to
1064 share a common enum with the compiler. */
1067 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1069 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1071 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1076 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1079 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1081 size
= size_from_real_kind (kind
);
1082 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1087 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1089 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1091 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1096 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1098 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1100 /* Currently we support only 1 byte chars, and the library is a bit
1101 confused of character kind vs. length, so we kludge it by setting
1103 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1108 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1111 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1113 size
= size_from_complex_kind (kind
);
1114 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1119 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1120 gfc_charlen_type charlen
)
1122 index_type count
[GFC_MAX_DIMENSIONS
];
1123 index_type extent
[GFC_MAX_DIMENSIONS
];
1124 index_type stride
[GFC_MAX_DIMENSIONS
];
1125 index_type stride0
, rank
, size
, type
, n
;
1130 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1133 type
= GFC_DESCRIPTOR_TYPE (desc
);
1134 size
= GFC_DESCRIPTOR_SIZE (desc
);
1136 /* FIXME: What a kludge: Array descriptors and the IO library use
1137 different enums for types. */
1140 case GFC_DTYPE_UNKNOWN
:
1141 iotype
= BT_NULL
; /* Is this correct? */
1143 case GFC_DTYPE_INTEGER
:
1144 iotype
= BT_INTEGER
;
1146 case GFC_DTYPE_LOGICAL
:
1147 iotype
= BT_LOGICAL
;
1149 case GFC_DTYPE_REAL
:
1152 case GFC_DTYPE_COMPLEX
:
1153 iotype
= BT_COMPLEX
;
1155 case GFC_DTYPE_CHARACTER
:
1156 iotype
= BT_CHARACTER
;
1157 /* FIXME: Currently dtype contains the charlen, which is
1158 clobbered if charlen > 2**24. That's why we use a separate
1159 argument for the charlen. However, if we want to support
1160 non-8-bit charsets we need to fix dtype to contain
1161 sizeof(chartype) and fix the code below. */
1165 case GFC_DTYPE_DERIVED
:
1166 internal_error (&dtp
->common
,
1167 "Derived type I/O should have been handled via the frontend.");
1170 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1173 if (desc
->dim
[0].stride
== 0)
1174 desc
->dim
[0].stride
= 1;
1176 rank
= GFC_DESCRIPTOR_RANK (desc
);
1177 for (n
= 0; n
< rank
; n
++)
1180 stride
[n
] = desc
->dim
[n
].stride
;
1181 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1183 /* If the extent of even one dimension is zero, then the entire
1184 array section contains zero elements, so we return. */
1189 stride0
= stride
[0];
1191 /* If the innermost dimension has stride 1, we can do the transfer
1192 in contiguous chunks. */
1198 data
= GFC_DESCRIPTOR_DATA (desc
);
1202 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1203 data
+= stride0
* size
* tsize
;
1206 while (count
[n
] == extent
[n
])
1209 data
-= stride
[n
] * extent
[n
] * size
;
1219 data
+= stride
[n
] * size
;
1226 /* Preposition a sequential unformatted file while reading. */
1229 us_read (st_parameter_dt
*dtp
)
1238 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1241 if (compile_options
.record_marker
== 0)
1242 n
= sizeof (gfc_offset
);
1244 n
= compile_options
.record_marker
;
1248 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1252 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1253 return; /* end of file */
1256 if (p
== NULL
|| n
!= nr
)
1258 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1262 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1263 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1265 switch (compile_options
.record_marker
)
1268 memcpy (&i
, p
, sizeof(gfc_offset
));
1271 case sizeof(GFC_INTEGER_4
):
1272 memcpy (&i4
, p
, sizeof (i4
));
1276 case sizeof(GFC_INTEGER_8
):
1277 memcpy (&i8
, p
, sizeof (i8
));
1282 runtime_error ("Illegal value for record marker");
1287 switch (compile_options
.record_marker
)
1290 reverse_memcpy (&i
, p
, sizeof(gfc_offset
));
1293 case sizeof(GFC_INTEGER_4
):
1294 reverse_memcpy (&i4
, p
, sizeof (i4
));
1298 case sizeof(GFC_INTEGER_8
):
1299 reverse_memcpy (&i8
, p
, sizeof (i8
));
1304 runtime_error ("Illegal value for record marker");
1308 dtp
->u
.p
.current_unit
->bytes_left
= i
;
1312 /* Preposition a sequential unformatted file while writing. This
1313 amount to writing a bogus length that will be filled in later. */
1316 us_write (st_parameter_dt
*dtp
)
1323 if (compile_options
.record_marker
== 0)
1324 nbytes
= sizeof (gfc_offset
);
1326 nbytes
= compile_options
.record_marker
;
1328 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1329 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1331 /* For sequential unformatted, we write until we have more bytes
1332 than can fit in the record markers. If disk space runs out first,
1333 it will error on the write. */
1334 dtp
->u
.p
.current_unit
->recl
= max_offset
;
1336 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1340 /* Position to the next record prior to transfer. We are assumed to
1341 be before the next record. We also calculate the bytes in the next
1345 pre_position (st_parameter_dt
*dtp
)
1347 if (dtp
->u
.p
.current_unit
->current_record
)
1348 return; /* Already positioned. */
1350 switch (current_mode (dtp
))
1352 case UNFORMATTED_SEQUENTIAL
:
1353 if (dtp
->u
.p
.mode
== READING
)
1360 case FORMATTED_SEQUENTIAL
:
1361 case FORMATTED_DIRECT
:
1362 case UNFORMATTED_DIRECT
:
1363 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1367 dtp
->u
.p
.current_unit
->current_record
= 1;
1371 /* Initialize things for a data transfer. This code is common for
1372 both reading and writing. */
1375 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1377 unit_flags u_flags
; /* Used for creating a unit if needed. */
1378 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1379 namelist_info
*ionml
;
1381 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1382 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1383 dtp
->u
.p
.ionml
= ionml
;
1384 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1386 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1387 *dtp
->size
= 0; /* Initialize the count. */
1389 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1390 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1391 { /* Open the unit with some default flags. */
1392 st_parameter_open opp
;
1393 if (dtp
->common
.unit
< 0)
1395 close_unit (dtp
->u
.p
.current_unit
);
1396 dtp
->u
.p
.current_unit
= NULL
;
1397 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1398 "Bad unit number in OPEN statement");
1401 memset (&u_flags
, '\0', sizeof (u_flags
));
1402 u_flags
.access
= ACCESS_SEQUENTIAL
;
1403 u_flags
.action
= ACTION_READWRITE
;
1405 /* Is it unformatted? */
1406 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1407 | IOPARM_DT_IONML_SET
)))
1408 u_flags
.form
= FORM_UNFORMATTED
;
1410 u_flags
.form
= FORM_UNSPECIFIED
;
1412 u_flags
.delim
= DELIM_UNSPECIFIED
;
1413 u_flags
.blank
= BLANK_UNSPECIFIED
;
1414 u_flags
.pad
= PAD_UNSPECIFIED
;
1415 u_flags
.status
= STATUS_UNKNOWN
;
1416 opp
.common
= dtp
->common
;
1417 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1418 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1419 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1420 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1421 if (dtp
->u
.p
.current_unit
== NULL
)
1425 /* Check the action. */
1427 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1428 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1429 "Cannot read from file opened for WRITE");
1431 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1432 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1433 "Cannot write to file opened for READ");
1435 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1438 dtp
->u
.p
.first_item
= 1;
1440 /* Check the format. */
1442 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1445 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1448 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1449 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1451 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1452 "Format present for UNFORMATTED data transfer");
1454 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1456 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1457 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1458 "A format cannot be specified with a namelist");
1460 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1461 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1462 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1463 "Missing format for FORMATTED data transfer");
1466 if (is_internal_unit (dtp
)
1467 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1468 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1469 "Internal file cannot be accessed by UNFORMATTED data transfer");
1471 /* Check the record number. */
1473 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1474 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1476 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1477 "Direct access data transfer requires record number");
1481 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1482 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1484 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1485 "Record number not allowed for sequential access data transfer");
1489 /* Process the ADVANCE option. */
1491 dtp
->u
.p
.advance_status
1492 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1493 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1494 "Bad ADVANCE parameter in data transfer statement");
1496 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1498 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1499 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1500 "ADVANCE specification conflicts with sequential access");
1502 if (is_internal_unit (dtp
))
1503 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1504 "ADVANCE specification conflicts with internal file");
1506 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1507 != IOPARM_DT_HAS_FORMAT
)
1508 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1509 "ADVANCE specification requires an explicit format");
1514 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1515 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1516 "EOR specification requires an ADVANCE specification of NO");
1518 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1519 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1520 "SIZE specification requires an ADVANCE specification of NO");
1524 { /* Write constraints. */
1525 if ((cf
& IOPARM_END
) != 0)
1526 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1527 "END specification cannot appear in a write statement");
1529 if ((cf
& IOPARM_EOR
) != 0)
1530 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1531 "EOR specification cannot appear in a write statement");
1533 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1534 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1535 "SIZE specification cannot appear in a write statement");
1538 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1539 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1540 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1543 /* Sanity checks on the record number. */
1545 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1549 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1550 "Record number must be positive");
1554 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1556 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1557 "Record number too large");
1561 /* Check to see if we might be reading what we wrote before */
1563 if (dtp
->u
.p
.mode
== READING
&& dtp
->u
.p
.current_unit
->mode
== WRITING
)
1564 flush(dtp
->u
.p
.current_unit
->s
);
1566 /* Check whether the record exists to be read. Only
1567 a partial record needs to exist. */
1569 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1570 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1572 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1573 "Non-existing record number");
1577 /* Position the file. */
1578 if (sseek (dtp
->u
.p
.current_unit
->s
,
1579 (dtp
->rec
- 1) * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1581 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1586 /* Overwriting an existing sequential file ?
1587 it is always safe to truncate the file on the first write */
1588 if (dtp
->u
.p
.mode
== WRITING
1589 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1590 && dtp
->u
.p
.current_unit
->last_record
== 0 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1591 struncate(dtp
->u
.p
.current_unit
->s
);
1593 /* Bugware for badly written mixed C-Fortran I/O. */
1594 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1596 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1598 /* Set the initial value of flags. */
1600 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1601 dtp
->u
.p
.sign_status
= SIGN_S
;
1605 /* Set up the subroutine that will handle the transfers. */
1609 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1610 dtp
->u
.p
.transfer
= unformatted_read
;
1613 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1614 dtp
->u
.p
.transfer
= list_formatted_read
;
1616 dtp
->u
.p
.transfer
= formatted_transfer
;
1621 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1622 dtp
->u
.p
.transfer
= unformatted_write
;
1625 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1626 dtp
->u
.p
.transfer
= list_formatted_write
;
1628 dtp
->u
.p
.transfer
= formatted_transfer
;
1632 /* Make sure that we don't do a read after a nonadvancing write. */
1636 if (dtp
->u
.p
.current_unit
->read_bad
)
1638 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1639 "Cannot READ after a nonadvancing WRITE");
1645 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
1646 dtp
->u
.p
.current_unit
->read_bad
= 1;
1649 /* Start the data transfer if we are doing a formatted transfer. */
1650 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
1651 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
1652 && dtp
->u
.p
.ionml
== NULL
)
1653 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
1656 /* Initialize an array_loop_spec given the array descriptor. The function
1657 returns the index of the last element of the array. */
1660 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
1662 int rank
= GFC_DESCRIPTOR_RANK(desc
);
1667 for (i
=0; i
<rank
; i
++)
1670 ls
[i
].start
= desc
->dim
[i
].lbound
;
1671 ls
[i
].end
= desc
->dim
[i
].ubound
;
1672 ls
[i
].step
= desc
->dim
[i
].stride
;
1674 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
1675 * desc
->dim
[i
].stride
;
1680 /* Determine the index to the next record in an internal unit array by
1681 by incrementing through the array_loop_spec. TODO: Implement handling
1682 negative strides. */
1685 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
1693 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
1698 if (ls
[i
].idx
> ls
[i
].end
)
1700 ls
[i
].idx
= ls
[i
].start
;
1706 index
= index
+ (ls
[i
].idx
- 1) * ls
[i
].step
;
1711 /* Space to the next record for read mode. If the file is not
1712 seekable, we read MAX_READ chunks until we get to the right
1715 #define MAX_READ 4096
1718 next_record_r (st_parameter_dt
*dtp
)
1720 gfc_offset
new, record
;
1721 int bytes_left
, rlength
, length
;
1724 switch (current_mode (dtp
))
1726 case UNFORMATTED_SEQUENTIAL
:
1728 /* Skip over tail */
1729 dtp
->u
.p
.current_unit
->bytes_left
+=
1730 compile_options
.record_marker
== 0 ?
1731 sizeof (gfc_offset
) : compile_options
.record_marker
;
1733 /* Fall through... */
1735 case FORMATTED_DIRECT
:
1736 case UNFORMATTED_DIRECT
:
1737 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1740 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
1742 new = file_position (dtp
->u
.p
.current_unit
->s
)
1743 + dtp
->u
.p
.current_unit
->bytes_left
;
1745 /* Direct access files do not generate END conditions,
1747 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
1748 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1752 { /* Seek by reading data. */
1753 while (dtp
->u
.p
.current_unit
->bytes_left
> 0)
1755 rlength
= length
= (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left
) ?
1756 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left
;
1758 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
1761 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1765 dtp
->u
.p
.current_unit
->bytes_left
-= length
;
1770 case FORMATTED_SEQUENTIAL
:
1772 /* sf_read has already terminated input because of an '\n' */
1773 if (dtp
->u
.p
.sf_seen_eor
)
1775 dtp
->u
.p
.sf_seen_eor
= 0;
1779 if (is_internal_unit (dtp
))
1781 if (is_array_io (dtp
))
1783 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1785 /* Now seek to this record. */
1786 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1787 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1789 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
1792 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1796 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1797 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
1799 dtp
->u
.p
.current_unit
->bytes_left
1800 = dtp
->u
.p
.current_unit
->recl
;
1806 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1810 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1816 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1825 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1826 test_endfile (dtp
->u
.p
.current_unit
);
1830 /* Small utility function to write a record marker, taking care of
1831 byte swapping and of choosing the correct size. */
1834 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
1839 char p
[sizeof (GFC_INTEGER_8
)];
1841 if (compile_options
.record_marker
== 0)
1842 len
= sizeof (gfc_offset
);
1844 len
= compile_options
.record_marker
;
1846 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1847 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1849 switch (compile_options
.record_marker
)
1852 return swrite (dtp
->u
.p
.current_unit
->s
, &buf
, &len
);
1855 case sizeof (GFC_INTEGER_4
):
1857 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
1860 case sizeof (GFC_INTEGER_8
):
1862 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
1866 runtime_error ("Illegal value for record marker");
1872 switch (compile_options
.record_marker
)
1875 reverse_memcpy (p
, &buf
, sizeof (gfc_offset
));
1876 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1879 case sizeof (GFC_INTEGER_4
):
1881 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
1882 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1885 case sizeof (GFC_INTEGER_8
):
1887 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_4
));
1888 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1892 runtime_error ("Illegal value for record marker");
1900 /* Position to the next record in write mode. */
1903 next_record_w (st_parameter_dt
*dtp
, int done
)
1905 gfc_offset c
, m
, record
, max_pos
;
1908 size_t record_marker
;
1910 /* Zero counters for X- and T-editing. */
1911 max_pos
= dtp
->u
.p
.max_pos
;
1912 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1914 switch (current_mode (dtp
))
1916 case FORMATTED_DIRECT
:
1917 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1920 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
1921 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
1926 case UNFORMATTED_DIRECT
:
1927 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1931 case UNFORMATTED_SEQUENTIAL
:
1932 /* Bytes written. */
1933 m
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
1934 c
= file_position (dtp
->u
.p
.current_unit
->s
);
1936 /* Write the length tail. */
1938 if (write_us_marker (dtp
, m
) != 0)
1941 if (compile_options
.record_marker
== 4)
1942 record_marker
= sizeof(GFC_INTEGER_4
);
1944 record_marker
= sizeof (gfc_offset
);
1946 /* Seek to the head and overwrite the bogus length with the real
1949 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
1953 if (write_us_marker (dtp
, m
) != 0)
1956 /* Seek past the end of the current record. */
1958 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
1963 case FORMATTED_SEQUENTIAL
:
1965 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1968 if (is_internal_unit (dtp
))
1970 if (is_array_io (dtp
))
1972 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1974 /* If the farthest position reached is greater than current
1975 position, adjust the position and set length to pad out
1976 whats left. Otherwise just pad whats left.
1977 (for character array unit) */
1978 m
= dtp
->u
.p
.current_unit
->recl
1979 - dtp
->u
.p
.current_unit
->bytes_left
;
1982 length
= (int) (max_pos
- m
);
1983 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1984 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
1987 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
1989 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1993 /* Now that the current record has been padded out,
1994 determine where the next record in the array is. */
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
;
2000 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2002 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2006 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2012 /* If this is the last call to next_record move to the farthest
2013 position reached and set length to pad out the remainder
2014 of the record. (for character scaler unit) */
2017 m
= dtp
->u
.p
.current_unit
->recl
2018 - dtp
->u
.p
.current_unit
->bytes_left
;
2021 length
= (int) (max_pos
- m
);
2022 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2023 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2026 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2028 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2030 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2037 /* If this is the last call to next_record move to the farthest
2038 position reached in preparation for completing the record.
2042 m
= dtp
->u
.p
.current_unit
->recl
-
2043 dtp
->u
.p
.current_unit
->bytes_left
;
2046 length
= (int) (max_pos
- m
);
2047 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2051 const char crlf
[] = "\r\n";
2057 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2064 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2069 /* Position to the next record, which means moving to the end of the
2070 current record. This can happen under several different
2071 conditions. If the done flag is not set, we get ready to process
2075 next_record (st_parameter_dt
*dtp
, int done
)
2077 gfc_offset fp
; /* File position. */
2079 dtp
->u
.p
.current_unit
->read_bad
= 0;
2081 if (dtp
->u
.p
.mode
== READING
)
2082 next_record_r (dtp
);
2084 next_record_w (dtp
, done
);
2086 /* keep position up to date for INQUIRE */
2087 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
2089 dtp
->u
.p
.current_unit
->current_record
= 0;
2090 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2092 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2093 /* Calculate next record, rounding up partial records. */
2094 dtp
->u
.p
.current_unit
->last_record
= (fp
+ dtp
->u
.p
.current_unit
->recl
- 1)
2095 / dtp
->u
.p
.current_unit
->recl
;
2098 dtp
->u
.p
.current_unit
->last_record
++;
2105 /* Finalize the current data transfer. For a nonadvancing transfer,
2106 this means advancing to the next record. For internal units close the
2107 stream associated with the unit. */
2110 finalize_transfer (st_parameter_dt
*dtp
)
2113 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2115 if (dtp
->u
.p
.eor_condition
)
2117 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2121 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2124 if ((dtp
->u
.p
.ionml
!= NULL
)
2125 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2127 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2128 namelist_read (dtp
);
2130 namelist_write (dtp
);
2133 dtp
->u
.p
.transfer
= NULL
;
2134 if (dtp
->u
.p
.current_unit
== NULL
)
2137 dtp
->u
.p
.eof_jump
= &eof_jump
;
2138 if (setjmp (eof_jump
))
2140 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2144 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2145 finish_list_read (dtp
);
2148 dtp
->u
.p
.current_unit
->current_record
= 0;
2149 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
2151 /* Most systems buffer lines, so force the partial record
2152 to be written out. */
2153 flush (dtp
->u
.p
.current_unit
->s
);
2154 dtp
->u
.p
.seen_dollar
= 0;
2158 next_record (dtp
, 1);
2161 sfree (dtp
->u
.p
.current_unit
->s
);
2163 if (is_internal_unit (dtp
))
2165 if (is_array_io (dtp
) && dtp
->u
.p
.current_unit
->ls
!= NULL
)
2166 free_mem (dtp
->u
.p
.current_unit
->ls
);
2167 sclose (dtp
->u
.p
.current_unit
->s
);
2172 /* Transfer function for IOLENGTH. It doesn't actually do any
2173 data transfer, it just updates the length counter. */
2176 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2177 void *dest
__attribute__ ((unused
)),
2178 int kind
__attribute__((unused
)),
2179 size_t size
, size_t nelems
)
2181 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2182 *dtp
->iolength
+= (GFC_INTEGER_4
) size
* nelems
;
2186 /* Initialize the IOLENGTH data transfer. This function is in essence
2187 a very much simplified version of data_transfer_init(), because it
2188 doesn't have to deal with units at all. */
2191 iolength_transfer_init (st_parameter_dt
*dtp
)
2193 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2196 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2198 /* Set up the subroutine that will handle the transfers. */
2200 dtp
->u
.p
.transfer
= iolength_transfer
;
2204 /* Library entry point for the IOLENGTH form of the INQUIRE
2205 statement. The IOLENGTH form requires no I/O to be performed, but
2206 it must still be a runtime library call so that we can determine
2207 the iolength for dynamic arrays and such. */
2209 extern void st_iolength (st_parameter_dt
*);
2210 export_proto(st_iolength
);
2213 st_iolength (st_parameter_dt
*dtp
)
2215 library_start (&dtp
->common
);
2216 iolength_transfer_init (dtp
);
2219 extern void st_iolength_done (st_parameter_dt
*);
2220 export_proto(st_iolength_done
);
2223 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2226 if (dtp
->u
.p
.scratch
!= NULL
)
2227 free_mem (dtp
->u
.p
.scratch
);
2232 /* The READ statement. */
2234 extern void st_read (st_parameter_dt
*);
2235 export_proto(st_read
);
2238 st_read (st_parameter_dt
*dtp
)
2241 library_start (&dtp
->common
);
2243 data_transfer_init (dtp
, 1);
2245 /* Handle complications dealing with the endfile record. It is
2246 significant that this is the only place where ERROR_END is
2247 generated. Reading an end of file elsewhere is either end of
2248 record or an I/O error. */
2250 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2251 switch (dtp
->u
.p
.current_unit
->endfile
)
2257 if (!is_internal_unit (dtp
))
2259 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2260 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2261 dtp
->u
.p
.current_unit
->current_record
= 0;
2266 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2267 dtp
->u
.p
.current_unit
->current_record
= 0;
2272 extern void st_read_done (st_parameter_dt
*);
2273 export_proto(st_read_done
);
2276 st_read_done (st_parameter_dt
*dtp
)
2278 finalize_transfer (dtp
);
2279 free_format_data (dtp
);
2281 if (dtp
->u
.p
.scratch
!= NULL
)
2282 free_mem (dtp
->u
.p
.scratch
);
2283 if (dtp
->u
.p
.current_unit
!= NULL
)
2284 unlock_unit (dtp
->u
.p
.current_unit
);
2288 extern void st_write (st_parameter_dt
*);
2289 export_proto(st_write
);
2292 st_write (st_parameter_dt
*dtp
)
2294 library_start (&dtp
->common
);
2295 data_transfer_init (dtp
, 0);
2298 extern void st_write_done (st_parameter_dt
*);
2299 export_proto(st_write_done
);
2302 st_write_done (st_parameter_dt
*dtp
)
2304 finalize_transfer (dtp
);
2306 /* Deal with endfile conditions associated with sequential files. */
2308 if (dtp
->u
.p
.current_unit
!= NULL
2309 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2310 switch (dtp
->u
.p
.current_unit
->endfile
)
2312 case AT_ENDFILE
: /* Remain at the endfile record. */
2316 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2320 /* Get rid of whatever is after this record. */
2321 flush (dtp
->u
.p
.current_unit
->s
);
2322 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2323 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2325 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2329 free_format_data (dtp
);
2331 if (dtp
->u
.p
.scratch
!= NULL
)
2332 free_mem (dtp
->u
.p
.scratch
);
2333 if (dtp
->u
.p
.current_unit
!= NULL
)
2334 unlock_unit (dtp
->u
.p
.current_unit
);
2338 /* Receives the scalar information for namelist objects and stores it
2339 in a linked list of namelist_info types. */
2341 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2342 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2343 export_proto(st_set_nml_var
);
2347 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2348 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2349 GFC_INTEGER_4 dtype
)
2351 namelist_info
*t1
= NULL
;
2354 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2356 nml
->mem_pos
= var_addr
;
2358 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2359 strcpy (nml
->var_name
, var_name
);
2361 nml
->len
= (int) len
;
2362 nml
->string_length
= (index_type
) string_length
;
2364 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2365 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2366 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2368 if (nml
->var_rank
> 0)
2370 nml
->dim
= (descriptor_dimension
*)
2371 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2372 nml
->ls
= (array_loop_spec
*)
2373 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2383 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2385 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2386 dtp
->u
.p
.ionml
= nml
;
2390 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2395 /* Store the dimensional information for the namelist object. */
2396 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2397 GFC_INTEGER_4
, GFC_INTEGER_4
,
2399 export_proto(st_set_nml_var_dim
);
2402 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2403 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2404 GFC_INTEGER_4 ubound
)
2406 namelist_info
* nml
;
2411 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2413 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2414 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2415 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2418 /* Reverse memcpy - used for byte swapping. */
2420 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2426 s
= (char *) src
+ n
- 1;
2428 /* Write with ascending order - this is likely faster
2429 on modern architectures because of write combining. */