1 /* Copyright (C) 2002, 2003, 2004, 2005 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 /* Writes a block directly without necessarily allocating space in a
384 write_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
386 if (dtp
->u
.p
.current_unit
->bytes_left
< *nbytes
)
387 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
389 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) *nbytes
;
391 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, nbytes
) != 0)
392 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
394 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
395 *dtp
->size
+= (GFC_INTEGER_4
) *nbytes
;
399 /* Master function for unformatted reads. */
402 unformatted_read (st_parameter_dt
*dtp
, bt type
,
403 void *dest
, int kind
,
404 size_t size
, size_t nelems
)
406 /* Currently, character implies size=1. */
407 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
408 || size
== 1 || type
== BT_CHARACTER
)
411 read_block_direct (dtp
, dest
, &size
);
419 /* Break up complex into its constituent reals. */
420 if (type
== BT_COMPLEX
)
427 /* By now, all complex variables have been split into their
428 constituent reals. For types with padding, we only need to
429 read kind bytes. We don't care about the contents
433 for (i
=0; i
<nelems
; i
++)
435 read_block_direct (dtp
, buffer
, &sz
);
436 reverse_memcpy (p
, buffer
, sz
);
443 /* Master function for unformatted writes. */
446 unformatted_write (st_parameter_dt
*dtp
, bt type
,
447 void *source
, int kind
,
448 size_t size
, size_t nelems
)
450 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
451 size
== 1 || type
== BT_CHARACTER
)
455 write_block_direct (dtp
, source
, &size
);
463 /* Break up complex into its constituent reals. */
464 if (type
== BT_COMPLEX
)
472 /* By now, all complex variables have been split into their
473 constituent reals. For types with padding, we only need to
474 read kind bytes. We don't care about the contents
478 for (i
=0; i
<nelems
; i
++)
480 reverse_memcpy(buffer
, p
, size
);
482 write_block_direct (dtp
, buffer
, &sz
);
488 /* Return a pointer to the name of a type. */
513 internal_error (NULL
, "type_name(): Bad type");
520 /* Write a constant string to the output.
521 This is complicated because the string can have doubled delimiters
522 in it. The length in the format node is the true length. */
525 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
527 char c
, delimiter
, *p
, *q
;
530 length
= f
->u
.string
.length
;
534 p
= write_block (dtp
, length
);
541 for (; length
> 0; length
--)
544 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
545 q
++; /* Skip the doubled delimiter. */
550 /* Given actual and expected types in a formatted data transfer, make
551 sure they agree. If not, an error message is generated. Returns
552 nonzero if something went wrong. */
555 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
559 if (actual
== expected
)
562 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
563 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
565 format_error (dtp
, f
, buffer
);
570 /* This subroutine is the main loop for a formatted data transfer
571 statement. It would be natural to implement this as a coroutine
572 with the user program, but C makes that awkward. We loop,
573 processesing format elements. When we actually have to transfer
574 data instead of just setting flags, we return control to the user
575 program which calls a subroutine that supplies the address and type
576 of the next element, then comes back here to process it. */
579 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
582 char scratch
[SCRATCH_SIZE
];
587 int consume_data_flag
;
589 /* Change a complex data item into a pair of reals. */
591 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
592 if (type
== BT_COMPLEX
)
598 /* If there's an EOR condition, we simulate finalizing the transfer
600 if (dtp
->u
.p
.eor_condition
)
603 /* Set this flag so that commas in reads cause the read to complete before
604 the entire field has been read. The next read field will start right after
605 the comma in the stream. (Set to 0 for character reads). */
606 dtp
->u
.p
.sf_read_comma
= 1;
608 dtp
->u
.p
.line_buffer
= scratch
;
611 /* If reversion has occurred and there is another real data item,
612 then we have to move to the next record. */
613 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
615 dtp
->u
.p
.reversion_flag
= 0;
616 next_record (dtp
, 0);
619 consume_data_flag
= 1 ;
620 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
623 f
= next_format (dtp
);
625 return; /* No data descriptors left (already raised). */
627 /* Now discharge T, TR and X movements to the right. This is delayed
628 until a data producing format to suppress trailing spaces. */
631 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
632 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
633 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
634 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
635 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
638 if (dtp
->u
.p
.skips
> 0)
640 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
641 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
642 - dtp
->u
.p
.current_unit
->bytes_left
);
644 if (dtp
->u
.p
.skips
< 0)
646 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
647 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
649 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
652 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
659 if (require_type (dtp
, BT_INTEGER
, type
, f
))
662 if (dtp
->u
.p
.mode
== READING
)
663 read_decimal (dtp
, f
, p
, len
);
665 write_i (dtp
, f
, p
, len
);
672 if (require_type (dtp
, BT_INTEGER
, type
, f
))
675 if (dtp
->u
.p
.mode
== READING
)
676 read_radix (dtp
, f
, p
, len
, 2);
678 write_b (dtp
, f
, p
, len
);
686 if (dtp
->u
.p
.mode
== READING
)
687 read_radix (dtp
, f
, p
, len
, 8);
689 write_o (dtp
, f
, p
, len
);
697 if (dtp
->u
.p
.mode
== READING
)
698 read_radix (dtp
, f
, p
, len
, 16);
700 write_z (dtp
, f
, p
, len
);
708 if (dtp
->u
.p
.mode
== READING
)
709 read_a (dtp
, f
, p
, len
);
711 write_a (dtp
, f
, p
, len
);
719 if (dtp
->u
.p
.mode
== READING
)
720 read_l (dtp
, f
, p
, len
);
722 write_l (dtp
, f
, p
, len
);
729 if (require_type (dtp
, BT_REAL
, type
, f
))
732 if (dtp
->u
.p
.mode
== READING
)
733 read_f (dtp
, f
, p
, len
);
735 write_d (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_e (dtp
, f
, p
, len
);
754 if (require_type (dtp
, BT_REAL
, type
, f
))
757 if (dtp
->u
.p
.mode
== READING
)
758 read_f (dtp
, f
, p
, len
);
760 write_en (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_es (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_f (dtp
, f
, p
, len
);
793 if (dtp
->u
.p
.mode
== READING
)
797 read_decimal (dtp
, f
, p
, len
);
800 read_l (dtp
, f
, p
, len
);
803 read_a (dtp
, f
, p
, len
);
806 read_f (dtp
, f
, p
, len
);
815 write_i (dtp
, f
, p
, len
);
818 write_l (dtp
, f
, p
, len
);
821 write_a (dtp
, f
, p
, len
);
824 write_d (dtp
, f
, p
, len
);
828 internal_error (&dtp
->common
,
829 "formatted_transfer(): Bad type");
835 consume_data_flag
= 0 ;
836 if (dtp
->u
.p
.mode
== READING
)
838 format_error (dtp
, f
, "Constant string in input format");
841 write_constant_string (dtp
, f
);
844 /* Format codes that don't transfer data. */
847 consume_data_flag
= 0 ;
849 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
850 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
851 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
853 /* Writes occur just before the switch on f->format, above, so
854 that trailing blanks are suppressed, unless we are doing a
855 non-advancing write in which case we want to output the blanks
857 if (dtp
->u
.p
.mode
== WRITING
858 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
860 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
861 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
863 if (dtp
->u
.p
.mode
== READING
)
864 read_x (dtp
, f
->u
.n
);
870 if (f
->format
== FMT_TL
)
871 pos
= bytes_used
- f
->u
.n
;
874 consume_data_flag
= 0;
878 /* Standard 10.6.1.1: excessive left tabbing is reset to the
879 left tab limit. We do not check if the position has gone
880 beyond the end of record because a subsequent tab could
881 bring us back again. */
882 pos
= pos
< 0 ? 0 : pos
;
884 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
885 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
886 + pos
- dtp
->u
.p
.max_pos
;
888 if (dtp
->u
.p
.skips
== 0)
891 /* Writes occur just before the switch on f->format, above, so that
892 trailing blanks are suppressed. */
893 if (dtp
->u
.p
.mode
== READING
)
895 /* Adjust everything for end-of-record condition */
896 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
898 if (dtp
->u
.p
.sf_seen_eor
== 2)
900 /* The EOR was a CRLF (two bytes wide). */
901 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
906 /* The EOR marker was only one byte wide. */
907 dtp
->u
.p
.current_unit
->bytes_left
--;
911 dtp
->u
.p
.sf_seen_eor
= 0;
913 if (dtp
->u
.p
.skips
< 0)
915 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
916 dtp
->u
.p
.current_unit
->bytes_left
917 -= (gfc_offset
) dtp
->u
.p
.skips
;
918 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
921 read_x (dtp
, dtp
->u
.p
.skips
);
927 consume_data_flag
= 0 ;
928 dtp
->u
.p
.sign_status
= SIGN_S
;
932 consume_data_flag
= 0 ;
933 dtp
->u
.p
.sign_status
= SIGN_SS
;
937 consume_data_flag
= 0 ;
938 dtp
->u
.p
.sign_status
= SIGN_SP
;
942 consume_data_flag
= 0 ;
943 dtp
->u
.p
.blank_status
= BLANK_NULL
;
947 consume_data_flag
= 0 ;
948 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
952 consume_data_flag
= 0 ;
953 dtp
->u
.p
.scale_factor
= f
->u
.k
;
957 consume_data_flag
= 0 ;
958 dtp
->u
.p
.seen_dollar
= 1;
962 consume_data_flag
= 0 ;
963 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
964 next_record (dtp
, 0);
968 /* A colon descriptor causes us to exit this loop (in
969 particular preventing another / descriptor from being
970 processed) unless there is another data item to be
972 consume_data_flag
= 0 ;
978 internal_error (&dtp
->common
, "Bad format node");
981 /* Free a buffer that we had to allocate during a sequential
982 formatted read of a block that was larger than the static
985 if (dtp
->u
.p
.line_buffer
!= scratch
)
987 free_mem (dtp
->u
.p
.line_buffer
);
988 dtp
->u
.p
.line_buffer
= scratch
;
991 /* Adjust the item count and data pointer. */
993 if ((consume_data_flag
> 0) && (n
> 0))
996 p
= ((char *) p
) + size
;
999 if (dtp
->u
.p
.mode
== READING
)
1002 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1003 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1009 /* Come here when we need a data descriptor but don't have one. We
1010 push the current format node back onto the input, then return and
1011 let the user program call us back with the data. */
1013 unget_format (dtp
, f
);
1017 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1018 size_t size
, size_t nelems
)
1025 /* Big loop over all the elements. */
1026 for (elem
= 0; elem
< nelems
; elem
++)
1028 dtp
->u
.p
.item_count
++;
1029 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1035 /* Data transfer entry points. The type of the data entity is
1036 implicit in the subroutine call. This prevents us from having to
1037 share a common enum with the compiler. */
1040 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1042 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1044 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1049 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1052 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1054 size
= size_from_real_kind (kind
);
1055 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1060 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1062 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1064 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1069 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1071 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1073 /* Currently we support only 1 byte chars, and the library is a bit
1074 confused of character kind vs. length, so we kludge it by setting
1076 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1081 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1084 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1086 size
= size_from_complex_kind (kind
);
1087 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1092 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1093 gfc_charlen_type charlen
)
1095 index_type count
[GFC_MAX_DIMENSIONS
];
1096 index_type extent
[GFC_MAX_DIMENSIONS
];
1097 index_type stride
[GFC_MAX_DIMENSIONS
];
1098 index_type stride0
, rank
, size
, type
, n
;
1103 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1106 type
= GFC_DESCRIPTOR_TYPE (desc
);
1107 size
= GFC_DESCRIPTOR_SIZE (desc
);
1109 /* FIXME: What a kludge: Array descriptors and the IO library use
1110 different enums for types. */
1113 case GFC_DTYPE_UNKNOWN
:
1114 iotype
= BT_NULL
; /* Is this correct? */
1116 case GFC_DTYPE_INTEGER
:
1117 iotype
= BT_INTEGER
;
1119 case GFC_DTYPE_LOGICAL
:
1120 iotype
= BT_LOGICAL
;
1122 case GFC_DTYPE_REAL
:
1125 case GFC_DTYPE_COMPLEX
:
1126 iotype
= BT_COMPLEX
;
1128 case GFC_DTYPE_CHARACTER
:
1129 iotype
= BT_CHARACTER
;
1130 /* FIXME: Currently dtype contains the charlen, which is
1131 clobbered if charlen > 2**24. That's why we use a separate
1132 argument for the charlen. However, if we want to support
1133 non-8-bit charsets we need to fix dtype to contain
1134 sizeof(chartype) and fix the code below. */
1138 case GFC_DTYPE_DERIVED
:
1139 internal_error (&dtp
->common
,
1140 "Derived type I/O should have been handled via the frontend.");
1143 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1146 if (desc
->dim
[0].stride
== 0)
1147 desc
->dim
[0].stride
= 1;
1149 rank
= GFC_DESCRIPTOR_RANK (desc
);
1150 for (n
= 0; n
< rank
; n
++)
1153 stride
[n
] = desc
->dim
[n
].stride
;
1154 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1156 /* If the extent of even one dimension is zero, then the entire
1157 array section contains zero elements, so we return. */
1162 stride0
= stride
[0];
1164 /* If the innermost dimension has stride 1, we can do the transfer
1165 in contiguous chunks. */
1171 data
= GFC_DESCRIPTOR_DATA (desc
);
1175 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1176 data
+= stride0
* size
* tsize
;
1179 while (count
[n
] == extent
[n
])
1182 data
-= stride
[n
] * extent
[n
] * size
;
1192 data
+= stride
[n
] * size
;
1199 /* Preposition a sequential unformatted file while reading. */
1202 us_read (st_parameter_dt
*dtp
)
1208 n
= sizeof (gfc_offset
);
1209 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1212 return; /* end of file */
1214 if (p
== NULL
|| n
!= sizeof (gfc_offset
))
1216 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1220 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1221 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1222 memcpy (&i
, p
, sizeof (gfc_offset
));
1224 reverse_memcpy (&i
, p
, sizeof (gfc_offset
));
1226 dtp
->u
.p
.current_unit
->bytes_left
= i
;
1230 /* Preposition a sequential unformatted file while writing. This
1231 amount to writing a bogus length that will be filled in later. */
1234 us_write (st_parameter_dt
*dtp
)
1239 length
= sizeof (gfc_offset
);
1240 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1244 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1248 memset (p
, '\0', sizeof (gfc_offset
)); /* Bogus value for now. */
1249 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1250 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1252 /* For sequential unformatted, we write until we have more bytes than
1253 can fit in the record markers. If disk space runs out first, it will
1254 error on the write. */
1255 dtp
->u
.p
.current_unit
->recl
= max_offset
;
1257 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1261 /* Position to the next record prior to transfer. We are assumed to
1262 be before the next record. We also calculate the bytes in the next
1266 pre_position (st_parameter_dt
*dtp
)
1268 if (dtp
->u
.p
.current_unit
->current_record
)
1269 return; /* Already positioned. */
1271 switch (current_mode (dtp
))
1273 case UNFORMATTED_SEQUENTIAL
:
1274 if (dtp
->u
.p
.mode
== READING
)
1281 case FORMATTED_SEQUENTIAL
:
1282 case FORMATTED_DIRECT
:
1283 case UNFORMATTED_DIRECT
:
1284 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1288 dtp
->u
.p
.current_unit
->current_record
= 1;
1292 /* Initialize things for a data transfer. This code is common for
1293 both reading and writing. */
1296 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1298 unit_flags u_flags
; /* Used for creating a unit if needed. */
1299 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1300 namelist_info
*ionml
;
1302 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1303 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1304 dtp
->u
.p
.ionml
= ionml
;
1305 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1307 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1308 *dtp
->size
= 0; /* Initialize the count. */
1310 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1311 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1312 { /* Open the unit with some default flags. */
1313 st_parameter_open opp
;
1314 if (dtp
->common
.unit
< 0)
1316 close_unit (dtp
->u
.p
.current_unit
);
1317 dtp
->u
.p
.current_unit
= NULL
;
1318 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1319 "Bad unit number in OPEN statement");
1322 memset (&u_flags
, '\0', sizeof (u_flags
));
1323 u_flags
.access
= ACCESS_SEQUENTIAL
;
1324 u_flags
.action
= ACTION_READWRITE
;
1326 /* Is it unformatted? */
1327 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1328 | IOPARM_DT_IONML_SET
)))
1329 u_flags
.form
= FORM_UNFORMATTED
;
1331 u_flags
.form
= FORM_UNSPECIFIED
;
1333 u_flags
.delim
= DELIM_UNSPECIFIED
;
1334 u_flags
.blank
= BLANK_UNSPECIFIED
;
1335 u_flags
.pad
= PAD_UNSPECIFIED
;
1336 u_flags
.status
= STATUS_UNKNOWN
;
1337 opp
.common
= dtp
->common
;
1338 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1339 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1340 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1341 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1342 if (dtp
->u
.p
.current_unit
== NULL
)
1346 /* Check the action. */
1348 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1349 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1350 "Cannot read from file opened for WRITE");
1352 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1353 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1354 "Cannot write to file opened for READ");
1356 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1359 dtp
->u
.p
.first_item
= 1;
1361 /* Check the format. */
1363 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1366 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1369 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1370 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1372 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1373 "Format present for UNFORMATTED data transfer");
1375 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1377 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1378 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1379 "A format cannot be specified with a namelist");
1381 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1382 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1383 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1384 "Missing format for FORMATTED data transfer");
1387 if (is_internal_unit (dtp
)
1388 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1389 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1390 "Internal file cannot be accessed by UNFORMATTED data transfer");
1392 /* Check the record number. */
1394 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1395 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1397 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1398 "Direct access data transfer requires record number");
1402 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1403 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1405 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1406 "Record number not allowed for sequential access data transfer");
1410 /* Process the ADVANCE option. */
1412 dtp
->u
.p
.advance_status
1413 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1414 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1415 "Bad ADVANCE parameter in data transfer statement");
1417 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1419 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1420 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1421 "ADVANCE specification conflicts with sequential access");
1423 if (is_internal_unit (dtp
))
1424 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1425 "ADVANCE specification conflicts with internal file");
1427 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1428 != IOPARM_DT_HAS_FORMAT
)
1429 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1430 "ADVANCE specification requires an explicit format");
1435 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1436 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1437 "EOR specification requires an ADVANCE specification of NO");
1439 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1440 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1441 "SIZE specification requires an ADVANCE specification of NO");
1445 { /* Write constraints. */
1446 if ((cf
& IOPARM_END
) != 0)
1447 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1448 "END specification cannot appear in a write statement");
1450 if ((cf
& IOPARM_EOR
) != 0)
1451 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1452 "EOR specification cannot appear in a write statement");
1454 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1455 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1456 "SIZE specification cannot appear in a write statement");
1459 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1460 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1461 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1464 /* Sanity checks on the record number. */
1466 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1470 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1471 "Record number must be positive");
1475 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1477 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1478 "Record number too large");
1482 /* Check to see if we might be reading what we wrote before */
1484 if (dtp
->u
.p
.mode
== READING
&& dtp
->u
.p
.current_unit
->mode
== WRITING
)
1485 flush(dtp
->u
.p
.current_unit
->s
);
1487 /* Check whether the record exists to be read. Only
1488 a partial record needs to exist. */
1490 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1491 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1493 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1494 "Non-existing record number");
1498 /* Position the file. */
1499 if (sseek (dtp
->u
.p
.current_unit
->s
,
1500 (dtp
->rec
- 1) * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1502 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1507 /* Overwriting an existing sequential file ?
1508 it is always safe to truncate the file on the first write */
1509 if (dtp
->u
.p
.mode
== WRITING
1510 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1511 && dtp
->u
.p
.current_unit
->last_record
== 0 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1512 struncate(dtp
->u
.p
.current_unit
->s
);
1514 /* Bugware for badly written mixed C-Fortran I/O. */
1515 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1517 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1519 /* Set the initial value of flags. */
1521 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1522 dtp
->u
.p
.sign_status
= SIGN_S
;
1526 /* Set up the subroutine that will handle the transfers. */
1530 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1531 dtp
->u
.p
.transfer
= unformatted_read
;
1534 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1535 dtp
->u
.p
.transfer
= list_formatted_read
;
1537 dtp
->u
.p
.transfer
= formatted_transfer
;
1542 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1543 dtp
->u
.p
.transfer
= unformatted_write
;
1546 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1547 dtp
->u
.p
.transfer
= list_formatted_write
;
1549 dtp
->u
.p
.transfer
= formatted_transfer
;
1553 /* Make sure that we don't do a read after a nonadvancing write. */
1557 if (dtp
->u
.p
.current_unit
->read_bad
)
1559 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1560 "Cannot READ after a nonadvancing WRITE");
1566 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
1567 dtp
->u
.p
.current_unit
->read_bad
= 1;
1570 /* Start the data transfer if we are doing a formatted transfer. */
1571 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
1572 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
1573 && dtp
->u
.p
.ionml
== NULL
)
1574 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
1577 /* Initialize an array_loop_spec given the array descriptor. The function
1578 returns the index of the last element of the array. */
1581 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
1583 int rank
= GFC_DESCRIPTOR_RANK(desc
);
1588 for (i
=0; i
<rank
; i
++)
1591 ls
[i
].start
= desc
->dim
[i
].lbound
;
1592 ls
[i
].end
= desc
->dim
[i
].ubound
;
1593 ls
[i
].step
= desc
->dim
[i
].stride
;
1595 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
1596 * desc
->dim
[i
].stride
;
1601 /* Determine the index to the next record in an internal unit array by
1602 by incrementing through the array_loop_spec. TODO: Implement handling
1603 negative strides. */
1606 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
1614 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
1619 if (ls
[i
].idx
> ls
[i
].end
)
1621 ls
[i
].idx
= ls
[i
].start
;
1627 index
= index
+ (ls
[i
].idx
- 1) * ls
[i
].step
;
1632 /* Space to the next record for read mode. If the file is not
1633 seekable, we read MAX_READ chunks until we get to the right
1636 #define MAX_READ 4096
1639 next_record_r (st_parameter_dt
*dtp
)
1641 gfc_offset
new, record
;
1642 int bytes_left
, rlength
, length
;
1645 switch (current_mode (dtp
))
1647 case UNFORMATTED_SEQUENTIAL
:
1648 dtp
->u
.p
.current_unit
->bytes_left
+= sizeof (gfc_offset
); /* Skip over tail */
1650 /* Fall through... */
1652 case FORMATTED_DIRECT
:
1653 case UNFORMATTED_DIRECT
:
1654 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1657 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
1659 new = file_position (dtp
->u
.p
.current_unit
->s
) + dtp
->u
.p
.current_unit
->bytes_left
;
1661 /* Direct access files do not generate END conditions,
1663 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
1664 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1668 { /* Seek by reading data. */
1669 while (dtp
->u
.p
.current_unit
->bytes_left
> 0)
1671 rlength
= length
= (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left
) ?
1672 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left
;
1674 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
1677 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1681 dtp
->u
.p
.current_unit
->bytes_left
-= length
;
1686 case FORMATTED_SEQUENTIAL
:
1688 /* sf_read has already terminated input because of an '\n' */
1689 if (dtp
->u
.p
.sf_seen_eor
)
1691 dtp
->u
.p
.sf_seen_eor
= 0;
1695 if (is_internal_unit (dtp
))
1697 if (is_array_io (dtp
))
1699 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1701 /* Now seek to this record. */
1702 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1703 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1705 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1708 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1712 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1713 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
1715 dtp
->u
.p
.current_unit
->bytes_left
1716 = dtp
->u
.p
.current_unit
->recl
;
1722 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1726 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1732 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1741 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1742 test_endfile (dtp
->u
.p
.current_unit
);
1746 /* Position to the next record in write mode. */
1749 next_record_w (st_parameter_dt
*dtp
)
1751 gfc_offset c
, m
, record
;
1752 int bytes_left
, length
;
1755 /* Zero counters for X- and T-editing. */
1756 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1758 switch (current_mode (dtp
))
1760 case FORMATTED_DIRECT
:
1761 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1764 length
= dtp
->u
.p
.current_unit
->bytes_left
;
1765 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1770 memset (p
, ' ', dtp
->u
.p
.current_unit
->bytes_left
);
1771 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1775 case UNFORMATTED_DIRECT
:
1776 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1780 case UNFORMATTED_SEQUENTIAL
:
1781 /* Bytes written. */
1782 m
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
1783 c
= file_position (dtp
->u
.p
.current_unit
->s
);
1785 length
= sizeof (gfc_offset
);
1787 /* Write the length tail. */
1789 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1793 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1794 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1795 memcpy (p
, &m
, sizeof (gfc_offset
));
1797 reverse_memcpy (p
, &m
, sizeof (gfc_offset
));
1799 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1802 /* Seek to the head and overwrite the bogus length with the real
1805 p
= salloc_w_at (dtp
->u
.p
.current_unit
->s
, &length
, c
- m
- length
);
1807 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1809 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1810 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1811 memcpy (p
, &m
, sizeof (gfc_offset
));
1813 reverse_memcpy (p
, &m
, sizeof (gfc_offset
));
1815 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1818 /* Seek past the end of the current record. */
1820 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ sizeof (gfc_offset
)) == FAILURE
)
1825 case FORMATTED_SEQUENTIAL
:
1827 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1830 if (is_internal_unit (dtp
))
1832 if (is_array_io (dtp
))
1834 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1835 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
1838 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1841 memset(p
, ' ', bytes_left
);
1843 /* Now that the current record has been padded out,
1844 determine where the next record in the array is. */
1846 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1848 /* Now seek to this record */
1849 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1851 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1854 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1859 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1871 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1873 { /* No new line for internal writes. */
1888 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1893 /* Position to the next record, which means moving to the end of the
1894 current record. This can happen under several different
1895 conditions. If the done flag is not set, we get ready to process
1899 next_record (st_parameter_dt
*dtp
, int done
)
1901 gfc_offset fp
; /* File position. */
1903 dtp
->u
.p
.current_unit
->read_bad
= 0;
1905 if (dtp
->u
.p
.mode
== READING
)
1906 next_record_r (dtp
);
1908 next_record_w (dtp
);
1910 /* keep position up to date for INQUIRE */
1911 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
1913 dtp
->u
.p
.current_unit
->current_record
= 0;
1914 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1916 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
1917 /* Calculate next record, rounding up partial records. */
1918 dtp
->u
.p
.current_unit
->last_record
= (fp
+ dtp
->u
.p
.current_unit
->recl
- 1)
1919 / dtp
->u
.p
.current_unit
->recl
;
1922 dtp
->u
.p
.current_unit
->last_record
++;
1929 /* Finalize the current data transfer. For a nonadvancing transfer,
1930 this means advancing to the next record. For internal units close the
1931 stream associated with the unit. */
1934 finalize_transfer (st_parameter_dt
*dtp
)
1937 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1939 if (dtp
->u
.p
.eor_condition
)
1941 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
1945 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1948 if ((dtp
->u
.p
.ionml
!= NULL
)
1949 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
1951 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
1952 namelist_read (dtp
);
1954 namelist_write (dtp
);
1957 dtp
->u
.p
.transfer
= NULL
;
1958 if (dtp
->u
.p
.current_unit
== NULL
)
1961 dtp
->u
.p
.eof_jump
= &eof_jump
;
1962 if (setjmp (eof_jump
))
1964 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1968 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
1969 finish_list_read (dtp
);
1972 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
1974 /* Most systems buffer lines, so force the partial record
1975 to be written out. */
1976 flush (dtp
->u
.p
.current_unit
->s
);
1977 dtp
->u
.p
.seen_dollar
= 0;
1981 next_record (dtp
, 1);
1982 dtp
->u
.p
.current_unit
->current_record
= 0;
1985 sfree (dtp
->u
.p
.current_unit
->s
);
1987 if (is_internal_unit (dtp
))
1989 if (is_array_io (dtp
) && dtp
->u
.p
.current_unit
->ls
!= NULL
)
1990 free_mem (dtp
->u
.p
.current_unit
->ls
);
1991 sclose (dtp
->u
.p
.current_unit
->s
);
1996 /* Transfer function for IOLENGTH. It doesn't actually do any
1997 data transfer, it just updates the length counter. */
2000 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2001 void *dest
__attribute__ ((unused
)),
2002 int kind
__attribute__((unused
)),
2003 size_t size
, size_t nelems
)
2005 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2006 *dtp
->iolength
+= (GFC_INTEGER_4
) size
* nelems
;
2010 /* Initialize the IOLENGTH data transfer. This function is in essence
2011 a very much simplified version of data_transfer_init(), because it
2012 doesn't have to deal with units at all. */
2015 iolength_transfer_init (st_parameter_dt
*dtp
)
2017 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2020 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2022 /* Set up the subroutine that will handle the transfers. */
2024 dtp
->u
.p
.transfer
= iolength_transfer
;
2028 /* Library entry point for the IOLENGTH form of the INQUIRE
2029 statement. The IOLENGTH form requires no I/O to be performed, but
2030 it must still be a runtime library call so that we can determine
2031 the iolength for dynamic arrays and such. */
2033 extern void st_iolength (st_parameter_dt
*);
2034 export_proto(st_iolength
);
2037 st_iolength (st_parameter_dt
*dtp
)
2039 library_start (&dtp
->common
);
2040 iolength_transfer_init (dtp
);
2043 extern void st_iolength_done (st_parameter_dt
*);
2044 export_proto(st_iolength_done
);
2047 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2050 if (dtp
->u
.p
.scratch
!= NULL
)
2051 free_mem (dtp
->u
.p
.scratch
);
2056 /* The READ statement. */
2058 extern void st_read (st_parameter_dt
*);
2059 export_proto(st_read
);
2062 st_read (st_parameter_dt
*dtp
)
2065 library_start (&dtp
->common
);
2067 data_transfer_init (dtp
, 1);
2069 /* Handle complications dealing with the endfile record. It is
2070 significant that this is the only place where ERROR_END is
2071 generated. Reading an end of file elsewhere is either end of
2072 record or an I/O error. */
2074 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2075 switch (dtp
->u
.p
.current_unit
->endfile
)
2081 if (!is_internal_unit (dtp
))
2083 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2084 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2085 dtp
->u
.p
.current_unit
->current_record
= 0;
2090 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2091 dtp
->u
.p
.current_unit
->current_record
= 0;
2096 extern void st_read_done (st_parameter_dt
*);
2097 export_proto(st_read_done
);
2100 st_read_done (st_parameter_dt
*dtp
)
2102 finalize_transfer (dtp
);
2103 free_format_data (dtp
);
2105 if (dtp
->u
.p
.scratch
!= NULL
)
2106 free_mem (dtp
->u
.p
.scratch
);
2107 if (dtp
->u
.p
.current_unit
!= NULL
)
2108 unlock_unit (dtp
->u
.p
.current_unit
);
2112 extern void st_write (st_parameter_dt
*);
2113 export_proto(st_write
);
2116 st_write (st_parameter_dt
*dtp
)
2118 library_start (&dtp
->common
);
2119 data_transfer_init (dtp
, 0);
2122 extern void st_write_done (st_parameter_dt
*);
2123 export_proto(st_write_done
);
2126 st_write_done (st_parameter_dt
*dtp
)
2128 finalize_transfer (dtp
);
2130 /* Deal with endfile conditions associated with sequential files. */
2132 if (dtp
->u
.p
.current_unit
!= NULL
&& dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2133 switch (dtp
->u
.p
.current_unit
->endfile
)
2135 case AT_ENDFILE
: /* Remain at the endfile record. */
2139 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2143 if (dtp
->u
.p
.current_unit
->current_record
> dtp
->u
.p
.current_unit
->last_record
)
2145 /* Get rid of whatever is after this record. */
2146 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2147 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2150 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2154 free_format_data (dtp
);
2156 if (dtp
->u
.p
.scratch
!= NULL
)
2157 free_mem (dtp
->u
.p
.scratch
);
2158 if (dtp
->u
.p
.current_unit
!= NULL
)
2159 unlock_unit (dtp
->u
.p
.current_unit
);
2163 /* Receives the scalar information for namelist objects and stores it
2164 in a linked list of namelist_info types. */
2166 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2167 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2168 export_proto(st_set_nml_var
);
2172 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2173 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2174 GFC_INTEGER_4 dtype
)
2176 namelist_info
*t1
= NULL
;
2179 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2181 nml
->mem_pos
= var_addr
;
2183 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2184 strcpy (nml
->var_name
, var_name
);
2186 nml
->len
= (int) len
;
2187 nml
->string_length
= (index_type
) string_length
;
2189 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2190 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2191 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2193 if (nml
->var_rank
> 0)
2195 nml
->dim
= (descriptor_dimension
*)
2196 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2197 nml
->ls
= (array_loop_spec
*)
2198 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2208 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2210 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2211 dtp
->u
.p
.ionml
= nml
;
2215 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2220 /* Store the dimensional information for the namelist object. */
2221 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2222 GFC_INTEGER_4
, GFC_INTEGER_4
,
2224 export_proto(st_set_nml_var_dim
);
2227 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2228 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2229 GFC_INTEGER_4 ubound
)
2231 namelist_info
* nml
;
2236 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2238 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2239 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2240 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2243 /* Reverse memcpy - used for byte swapping. */
2245 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2251 s
= (char *) src
+ n
- 1;
2253 /* Write with ascending order - this is likely faster
2254 on modern architectures because of write combining. */