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
, int no_error
)
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)
176 generate_error (&dtp
->common
, ERROR_END
, NULL
);
180 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
182 /* Unexpected end of line. */
184 /* If we see an EOR during non-advancing I/O, we need to skip
185 the rest of the I/O statement. Set the corresponding flag. */
186 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
187 dtp
->u
.p
.eor_condition
= 1;
190 /* If we encounter a CR, it might be a CRLF. */
191 if (*q
== '\r') /* Probably a CRLF */
194 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
195 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
196 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
197 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
202 /* Without padding, terminate the I/O statement without assigning
203 the value. With padding, the value still needs to be assigned,
204 so we can just continue with a short read. */
205 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
209 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
214 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
217 /* Short circuit the read if a comma is found during numeric input.
218 The flag is set to zero during character reads so that commas in
219 strings are not ignored */
221 if (dtp
->u
.p
.sf_read_comma
== 1)
223 notify_std (GFC_STD_GNU
, "Comma in formatted numeric read.");
230 dtp
->u
.p
.sf_seen_eor
= 0;
233 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
235 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
236 *dtp
->size
+= *length
;
242 /* Function for reading the next couple of bytes from the current
243 file, advancing the current position. We return a pointer to a
244 buffer containing the bytes. We return NULL on end of record or
247 If the read is short, then it is because the current record does not
248 have enough data to satisfy the read request and the file was
249 opened with PAD=YES. The caller must assume tailing spaces for
253 read_block (st_parameter_dt
*dtp
, int *length
)
258 if (dtp
->u
.p
.current_unit
->bytes_left
< *length
)
260 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
262 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
263 /* Not enough data left. */
267 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
270 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
271 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
272 return read_sf (dtp
, length
, 0); /* Special case. */
274 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
277 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
279 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
282 if (nread
!= *length
)
283 { /* Short read, this shouldn't happen. */
284 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
288 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
297 /* Reads a block directly into application data space. */
300 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
306 if (dtp
->u
.p
.current_unit
->bytes_left
< *nbytes
)
308 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
310 /* Not enough data left. */
311 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
315 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
318 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
319 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
321 length
= (int *) nbytes
;
322 data
= read_sf (dtp
, length
, 0); /* Special case. */
323 memcpy (buf
, data
, (size_t) *length
);
327 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
330 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
332 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
336 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
337 *dtp
->size
+= (GFC_INTEGER_4
) nread
;
339 if (nread
!= *nbytes
)
340 { /* Short read, e.g. if we hit EOF. */
341 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
343 memset (((char *) buf
) + nread
, ' ', *nbytes
- nread
);
347 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
352 /* Function for writing a block of bytes to the current file at the
353 current position, advancing the file pointer. We are given a length
354 and return a pointer to a buffer that the caller must (completely)
355 fill in. Returns NULL on error. */
358 write_block (st_parameter_dt
*dtp
, int length
)
362 if (dtp
->u
.p
.current_unit
->bytes_left
< length
)
364 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
368 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
369 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
373 generate_error (&dtp
->common
, ERROR_END
, NULL
);
377 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
378 *dtp
->size
+= length
;
384 /* High level interface to swrite(), taking care of errors. */
387 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
389 if (dtp
->u
.p
.current_unit
->bytes_left
< nbytes
)
391 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
392 generate_error (&dtp
->common
, ERROR_DIRECT_EOR
, NULL
);
394 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
398 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
400 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
402 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
406 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
408 *dtp
->size
+= (GFC_INTEGER_4
) nbytes
;
416 /* Master function for unformatted reads. */
419 unformatted_read (st_parameter_dt
*dtp
, bt type
,
420 void *dest
, int kind
,
421 size_t size
, size_t nelems
)
423 /* Currently, character implies size=1. */
424 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
425 || size
== 1 || type
== BT_CHARACTER
)
428 read_block_direct (dtp
, dest
, &size
);
436 /* Break up complex into its constituent reals. */
437 if (type
== BT_COMPLEX
)
444 /* By now, all complex variables have been split into their
445 constituent reals. For types with padding, we only need to
446 read kind bytes. We don't care about the contents
450 for (i
=0; i
<nelems
; i
++)
452 read_block_direct (dtp
, buffer
, &sz
);
453 reverse_memcpy (p
, buffer
, sz
);
460 /* Master function for unformatted writes. */
463 unformatted_write (st_parameter_dt
*dtp
, bt type
,
464 void *source
, int kind
,
465 size_t size
, size_t nelems
)
467 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
468 size
== 1 || type
== BT_CHARACTER
)
472 write_buf (dtp
, source
, size
);
480 /* Break up complex into its constituent reals. */
481 if (type
== BT_COMPLEX
)
489 /* By now, all complex variables have been split into their
490 constituent reals. For types with padding, we only need to
491 read kind bytes. We don't care about the contents
495 for (i
=0; i
<nelems
; i
++)
497 reverse_memcpy(buffer
, p
, size
);
499 write_buf (dtp
, buffer
, sz
);
505 /* Return a pointer to the name of a type. */
530 internal_error (NULL
, "type_name(): Bad type");
537 /* Write a constant string to the output.
538 This is complicated because the string can have doubled delimiters
539 in it. The length in the format node is the true length. */
542 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
544 char c
, delimiter
, *p
, *q
;
547 length
= f
->u
.string
.length
;
551 p
= write_block (dtp
, length
);
558 for (; length
> 0; length
--)
561 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
562 q
++; /* Skip the doubled delimiter. */
567 /* Given actual and expected types in a formatted data transfer, make
568 sure they agree. If not, an error message is generated. Returns
569 nonzero if something went wrong. */
572 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
576 if (actual
== expected
)
579 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
580 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
582 format_error (dtp
, f
, buffer
);
587 /* This subroutine is the main loop for a formatted data transfer
588 statement. It would be natural to implement this as a coroutine
589 with the user program, but C makes that awkward. We loop,
590 processesing format elements. When we actually have to transfer
591 data instead of just setting flags, we return control to the user
592 program which calls a subroutine that supplies the address and type
593 of the next element, then comes back here to process it. */
596 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
599 char scratch
[SCRATCH_SIZE
];
604 int consume_data_flag
;
606 /* Change a complex data item into a pair of reals. */
608 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
609 if (type
== BT_COMPLEX
)
615 /* If there's an EOR condition, we simulate finalizing the transfer
617 if (dtp
->u
.p
.eor_condition
)
620 /* Set this flag so that commas in reads cause the read to complete before
621 the entire field has been read. The next read field will start right after
622 the comma in the stream. (Set to 0 for character reads). */
623 dtp
->u
.p
.sf_read_comma
= 1;
625 dtp
->u
.p
.line_buffer
= scratch
;
628 /* If reversion has occurred and there is another real data item,
629 then we have to move to the next record. */
630 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
632 dtp
->u
.p
.reversion_flag
= 0;
633 next_record (dtp
, 0);
636 consume_data_flag
= 1 ;
637 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
640 f
= next_format (dtp
);
642 return; /* No data descriptors left (already raised). */
644 /* Now discharge T, TR and X movements to the right. This is delayed
645 until a data producing format to suppress trailing spaces. */
648 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
649 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
650 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
651 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
652 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
655 if (dtp
->u
.p
.skips
> 0)
657 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
658 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
659 - dtp
->u
.p
.current_unit
->bytes_left
);
661 if (dtp
->u
.p
.skips
< 0)
663 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
664 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
666 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
669 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
676 if (require_type (dtp
, BT_INTEGER
, type
, f
))
679 if (dtp
->u
.p
.mode
== READING
)
680 read_decimal (dtp
, f
, p
, len
);
682 write_i (dtp
, f
, p
, len
);
689 if (require_type (dtp
, BT_INTEGER
, type
, f
))
692 if (dtp
->u
.p
.mode
== READING
)
693 read_radix (dtp
, f
, p
, len
, 2);
695 write_b (dtp
, f
, p
, len
);
703 if (dtp
->u
.p
.mode
== READING
)
704 read_radix (dtp
, f
, p
, len
, 8);
706 write_o (dtp
, f
, p
, len
);
714 if (dtp
->u
.p
.mode
== READING
)
715 read_radix (dtp
, f
, p
, len
, 16);
717 write_z (dtp
, f
, p
, len
);
725 if (dtp
->u
.p
.mode
== READING
)
726 read_a (dtp
, f
, p
, len
);
728 write_a (dtp
, f
, p
, len
);
736 if (dtp
->u
.p
.mode
== READING
)
737 read_l (dtp
, f
, p
, len
);
739 write_l (dtp
, f
, p
, len
);
746 if (require_type (dtp
, BT_REAL
, type
, f
))
749 if (dtp
->u
.p
.mode
== READING
)
750 read_f (dtp
, f
, p
, len
);
752 write_d (dtp
, f
, p
, len
);
759 if (require_type (dtp
, BT_REAL
, type
, f
))
762 if (dtp
->u
.p
.mode
== READING
)
763 read_f (dtp
, f
, p
, len
);
765 write_e (dtp
, f
, p
, len
);
771 if (require_type (dtp
, BT_REAL
, type
, f
))
774 if (dtp
->u
.p
.mode
== READING
)
775 read_f (dtp
, f
, p
, len
);
777 write_en (dtp
, f
, p
, len
);
784 if (require_type (dtp
, BT_REAL
, type
, f
))
787 if (dtp
->u
.p
.mode
== READING
)
788 read_f (dtp
, f
, p
, len
);
790 write_es (dtp
, f
, p
, len
);
797 if (require_type (dtp
, BT_REAL
, type
, f
))
800 if (dtp
->u
.p
.mode
== READING
)
801 read_f (dtp
, f
, p
, len
);
803 write_f (dtp
, f
, p
, len
);
810 if (dtp
->u
.p
.mode
== READING
)
814 read_decimal (dtp
, f
, p
, len
);
817 read_l (dtp
, f
, p
, len
);
820 read_a (dtp
, f
, p
, len
);
823 read_f (dtp
, f
, p
, len
);
832 write_i (dtp
, f
, p
, len
);
835 write_l (dtp
, f
, p
, len
);
838 write_a (dtp
, f
, p
, len
);
841 write_d (dtp
, f
, p
, len
);
845 internal_error (&dtp
->common
,
846 "formatted_transfer(): Bad type");
852 consume_data_flag
= 0 ;
853 if (dtp
->u
.p
.mode
== READING
)
855 format_error (dtp
, f
, "Constant string in input format");
858 write_constant_string (dtp
, f
);
861 /* Format codes that don't transfer data. */
864 consume_data_flag
= 0 ;
866 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
867 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
868 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
870 /* Writes occur just before the switch on f->format, above, so
871 that trailing blanks are suppressed, unless we are doing a
872 non-advancing write in which case we want to output the blanks
874 if (dtp
->u
.p
.mode
== WRITING
875 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
877 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
878 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
880 if (dtp
->u
.p
.mode
== READING
)
881 read_x (dtp
, f
->u
.n
);
887 if (f
->format
== FMT_TL
)
890 /* Handle the special case when no bytes have been used yet.
891 Cannot go below zero. */
894 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
895 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
896 : dtp
->u
.p
.pending_spaces
;
897 dtp
->u
.p
.skips
-= f
->u
.n
;
898 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
901 pos
= bytes_used
- f
->u
.n
;
905 consume_data_flag
= 0;
909 /* Standard 10.6.1.1: excessive left tabbing is reset to the
910 left tab limit. We do not check if the position has gone
911 beyond the end of record because a subsequent tab could
912 bring us back again. */
913 pos
= pos
< 0 ? 0 : pos
;
915 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
916 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
917 + pos
- dtp
->u
.p
.max_pos
;
919 if (dtp
->u
.p
.skips
== 0)
922 /* Writes occur just before the switch on f->format, above, so that
923 trailing blanks are suppressed. */
924 if (dtp
->u
.p
.mode
== READING
)
926 /* Adjust everything for end-of-record condition */
927 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
929 if (dtp
->u
.p
.sf_seen_eor
== 2)
931 /* The EOR was a CRLF (two bytes wide). */
932 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
937 /* The EOR marker was only one byte wide. */
938 dtp
->u
.p
.current_unit
->bytes_left
--;
942 dtp
->u
.p
.sf_seen_eor
= 0;
944 if (dtp
->u
.p
.skips
< 0)
946 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
947 dtp
->u
.p
.current_unit
->bytes_left
948 -= (gfc_offset
) dtp
->u
.p
.skips
;
949 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
952 read_x (dtp
, dtp
->u
.p
.skips
);
958 consume_data_flag
= 0 ;
959 dtp
->u
.p
.sign_status
= SIGN_S
;
963 consume_data_flag
= 0 ;
964 dtp
->u
.p
.sign_status
= SIGN_SS
;
968 consume_data_flag
= 0 ;
969 dtp
->u
.p
.sign_status
= SIGN_SP
;
973 consume_data_flag
= 0 ;
974 dtp
->u
.p
.blank_status
= BLANK_NULL
;
978 consume_data_flag
= 0 ;
979 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
983 consume_data_flag
= 0 ;
984 dtp
->u
.p
.scale_factor
= f
->u
.k
;
988 consume_data_flag
= 0 ;
989 dtp
->u
.p
.seen_dollar
= 1;
993 consume_data_flag
= 0 ;
994 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
995 next_record (dtp
, 0);
999 /* A colon descriptor causes us to exit this loop (in
1000 particular preventing another / descriptor from being
1001 processed) unless there is another data item to be
1003 consume_data_flag
= 0 ;
1009 internal_error (&dtp
->common
, "Bad format node");
1012 /* Free a buffer that we had to allocate during a sequential
1013 formatted read of a block that was larger than the static
1016 if (dtp
->u
.p
.line_buffer
!= scratch
)
1018 free_mem (dtp
->u
.p
.line_buffer
);
1019 dtp
->u
.p
.line_buffer
= scratch
;
1022 /* Adjust the item count and data pointer. */
1024 if ((consume_data_flag
> 0) && (n
> 0))
1027 p
= ((char *) p
) + size
;
1030 if (dtp
->u
.p
.mode
== READING
)
1033 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1034 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1040 /* Come here when we need a data descriptor but don't have one. We
1041 push the current format node back onto the input, then return and
1042 let the user program call us back with the data. */
1044 unget_format (dtp
, f
);
1048 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1049 size_t size
, size_t nelems
)
1056 /* Big loop over all the elements. */
1057 for (elem
= 0; elem
< nelems
; elem
++)
1059 dtp
->u
.p
.item_count
++;
1060 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1066 /* Data transfer entry points. The type of the data entity is
1067 implicit in the subroutine call. This prevents us from having to
1068 share a common enum with the compiler. */
1071 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1073 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1075 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1080 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1083 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1085 size
= size_from_real_kind (kind
);
1086 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1091 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1093 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1095 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1100 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1102 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1104 /* Currently we support only 1 byte chars, and the library is a bit
1105 confused of character kind vs. length, so we kludge it by setting
1107 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1112 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1115 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1117 size
= size_from_complex_kind (kind
);
1118 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1123 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1124 gfc_charlen_type charlen
)
1126 index_type count
[GFC_MAX_DIMENSIONS
];
1127 index_type extent
[GFC_MAX_DIMENSIONS
];
1128 index_type stride
[GFC_MAX_DIMENSIONS
];
1129 index_type stride0
, rank
, size
, type
, n
;
1134 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1137 type
= GFC_DESCRIPTOR_TYPE (desc
);
1138 size
= GFC_DESCRIPTOR_SIZE (desc
);
1140 /* FIXME: What a kludge: Array descriptors and the IO library use
1141 different enums for types. */
1144 case GFC_DTYPE_UNKNOWN
:
1145 iotype
= BT_NULL
; /* Is this correct? */
1147 case GFC_DTYPE_INTEGER
:
1148 iotype
= BT_INTEGER
;
1150 case GFC_DTYPE_LOGICAL
:
1151 iotype
= BT_LOGICAL
;
1153 case GFC_DTYPE_REAL
:
1156 case GFC_DTYPE_COMPLEX
:
1157 iotype
= BT_COMPLEX
;
1159 case GFC_DTYPE_CHARACTER
:
1160 iotype
= BT_CHARACTER
;
1161 /* FIXME: Currently dtype contains the charlen, which is
1162 clobbered if charlen > 2**24. That's why we use a separate
1163 argument for the charlen. However, if we want to support
1164 non-8-bit charsets we need to fix dtype to contain
1165 sizeof(chartype) and fix the code below. */
1169 case GFC_DTYPE_DERIVED
:
1170 internal_error (&dtp
->common
,
1171 "Derived type I/O should have been handled via the frontend.");
1174 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1177 if (desc
->dim
[0].stride
== 0)
1178 desc
->dim
[0].stride
= 1;
1180 rank
= GFC_DESCRIPTOR_RANK (desc
);
1181 for (n
= 0; n
< rank
; n
++)
1184 stride
[n
] = desc
->dim
[n
].stride
;
1185 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1187 /* If the extent of even one dimension is zero, then the entire
1188 array section contains zero elements, so we return. */
1193 stride0
= stride
[0];
1195 /* If the innermost dimension has stride 1, we can do the transfer
1196 in contiguous chunks. */
1202 data
= GFC_DESCRIPTOR_DATA (desc
);
1206 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1207 data
+= stride0
* size
* tsize
;
1210 while (count
[n
] == extent
[n
])
1213 data
-= stride
[n
] * extent
[n
] * size
;
1223 data
+= stride
[n
] * size
;
1230 /* Preposition a sequential unformatted file while reading. */
1233 us_read (st_parameter_dt
*dtp
)
1242 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1245 if (compile_options
.record_marker
== 0)
1246 n
= sizeof (gfc_offset
);
1248 n
= compile_options
.record_marker
;
1252 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1256 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1257 return; /* end of file */
1260 if (p
== NULL
|| n
!= nr
)
1262 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1266 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1267 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1269 switch (compile_options
.record_marker
)
1272 memcpy (&i
, p
, sizeof(gfc_offset
));
1275 case sizeof(GFC_INTEGER_4
):
1276 memcpy (&i4
, p
, sizeof (i4
));
1280 case sizeof(GFC_INTEGER_8
):
1281 memcpy (&i8
, p
, sizeof (i8
));
1286 runtime_error ("Illegal value for record marker");
1291 switch (compile_options
.record_marker
)
1294 reverse_memcpy (&i
, p
, sizeof(gfc_offset
));
1297 case sizeof(GFC_INTEGER_4
):
1298 reverse_memcpy (&i4
, p
, sizeof (i4
));
1302 case sizeof(GFC_INTEGER_8
):
1303 reverse_memcpy (&i8
, p
, sizeof (i8
));
1308 runtime_error ("Illegal value for record marker");
1312 dtp
->u
.p
.current_unit
->bytes_left
= i
;
1316 /* Preposition a sequential unformatted file while writing. This
1317 amount to writing a bogus length that will be filled in later. */
1320 us_write (st_parameter_dt
*dtp
)
1327 if (compile_options
.record_marker
== 0)
1328 nbytes
= sizeof (gfc_offset
);
1330 nbytes
= compile_options
.record_marker
;
1332 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1333 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1335 /* For sequential unformatted, we write until we have more bytes
1336 than can fit in the record markers. If disk space runs out first,
1337 it will error on the write. */
1338 dtp
->u
.p
.current_unit
->recl
= max_offset
;
1340 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1344 /* Position to the next record prior to transfer. We are assumed to
1345 be before the next record. We also calculate the bytes in the next
1349 pre_position (st_parameter_dt
*dtp
)
1351 if (dtp
->u
.p
.current_unit
->current_record
)
1352 return; /* Already positioned. */
1354 switch (current_mode (dtp
))
1356 case UNFORMATTED_SEQUENTIAL
:
1357 if (dtp
->u
.p
.mode
== READING
)
1364 case FORMATTED_SEQUENTIAL
:
1365 case FORMATTED_DIRECT
:
1366 case UNFORMATTED_DIRECT
:
1367 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1371 dtp
->u
.p
.current_unit
->current_record
= 1;
1375 /* Initialize things for a data transfer. This code is common for
1376 both reading and writing. */
1379 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1381 unit_flags u_flags
; /* Used for creating a unit if needed. */
1382 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1383 namelist_info
*ionml
;
1385 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1386 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1387 dtp
->u
.p
.ionml
= ionml
;
1388 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1390 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1391 *dtp
->size
= 0; /* Initialize the count. */
1393 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1394 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1395 { /* Open the unit with some default flags. */
1396 st_parameter_open opp
;
1399 if (dtp
->common
.unit
< 0)
1401 close_unit (dtp
->u
.p
.current_unit
);
1402 dtp
->u
.p
.current_unit
= NULL
;
1403 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1404 "Bad unit number in OPEN statement");
1407 memset (&u_flags
, '\0', sizeof (u_flags
));
1408 u_flags
.access
= ACCESS_SEQUENTIAL
;
1409 u_flags
.action
= ACTION_READWRITE
;
1411 /* Is it unformatted? */
1412 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1413 | IOPARM_DT_IONML_SET
)))
1414 u_flags
.form
= FORM_UNFORMATTED
;
1416 u_flags
.form
= FORM_UNSPECIFIED
;
1418 u_flags
.delim
= DELIM_UNSPECIFIED
;
1419 u_flags
.blank
= BLANK_UNSPECIFIED
;
1420 u_flags
.pad
= PAD_UNSPECIFIED
;
1421 u_flags
.status
= STATUS_UNKNOWN
;
1423 conv
= get_unformatted_convert (dtp
->common
.unit
);
1425 if (conv
== CONVERT_NONE
)
1426 conv
= compile_options
.convert
;
1428 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1429 and 1 on big-endian machines. */
1432 case CONVERT_NATIVE
:
1437 conv
= l8_to_l4_offset
? CONVERT_NATIVE
: CONVERT_SWAP
;
1440 case CONVERT_LITTLE
:
1441 conv
= l8_to_l4_offset
? CONVERT_SWAP
: CONVERT_NATIVE
;
1445 internal_error (&opp
.common
, "Illegal value for CONVERT");
1449 u_flags
.convert
= conv
;
1451 opp
.common
= dtp
->common
;
1452 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1453 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1454 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1455 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1456 if (dtp
->u
.p
.current_unit
== NULL
)
1460 /* Check the action. */
1462 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1463 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1464 "Cannot read from file opened for WRITE");
1466 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1467 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1468 "Cannot write to file opened for READ");
1470 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1473 dtp
->u
.p
.first_item
= 1;
1475 /* Check the format. */
1477 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1480 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1483 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1484 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1486 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1487 "Format present for UNFORMATTED data transfer");
1489 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1491 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1492 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1493 "A format cannot be specified with a namelist");
1495 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1496 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1497 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1498 "Missing format for FORMATTED data transfer");
1501 if (is_internal_unit (dtp
)
1502 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1503 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1504 "Internal file cannot be accessed by UNFORMATTED data transfer");
1506 /* Check the record number. */
1508 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1509 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1511 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1512 "Direct access data transfer requires record number");
1516 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1517 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1519 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1520 "Record number not allowed for sequential access data transfer");
1524 /* Process the ADVANCE option. */
1526 dtp
->u
.p
.advance_status
1527 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1528 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1529 "Bad ADVANCE parameter in data transfer statement");
1531 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1533 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1534 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1535 "ADVANCE specification conflicts with sequential access");
1537 if (is_internal_unit (dtp
))
1538 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1539 "ADVANCE specification conflicts with internal file");
1541 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1542 != IOPARM_DT_HAS_FORMAT
)
1543 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1544 "ADVANCE specification requires an explicit format");
1549 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1550 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1551 "EOR specification requires an ADVANCE specification of NO");
1553 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1554 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1555 "SIZE specification requires an ADVANCE specification of NO");
1559 { /* Write constraints. */
1560 if ((cf
& IOPARM_END
) != 0)
1561 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1562 "END specification cannot appear in a write statement");
1564 if ((cf
& IOPARM_EOR
) != 0)
1565 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1566 "EOR specification cannot appear in a write statement");
1568 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1569 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1570 "SIZE specification cannot appear in a write statement");
1573 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1574 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1575 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1578 /* Sanity checks on the record number. */
1580 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1584 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1585 "Record number must be positive");
1589 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1591 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1592 "Record number too large");
1596 /* Check to see if we might be reading what we wrote before */
1598 if (dtp
->u
.p
.mode
== READING
&& dtp
->u
.p
.current_unit
->mode
== WRITING
)
1599 flush(dtp
->u
.p
.current_unit
->s
);
1601 /* Check whether the record exists to be read. Only
1602 a partial record needs to exist. */
1604 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1605 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1607 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1608 "Non-existing record number");
1612 /* Position the file. */
1613 if (sseek (dtp
->u
.p
.current_unit
->s
,
1614 (dtp
->rec
- 1) * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1616 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1621 /* Overwriting an existing sequential file ?
1622 it is always safe to truncate the file on the first write */
1623 if (dtp
->u
.p
.mode
== WRITING
1624 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1625 && dtp
->u
.p
.current_unit
->last_record
== 0 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1626 struncate(dtp
->u
.p
.current_unit
->s
);
1628 /* Bugware for badly written mixed C-Fortran I/O. */
1629 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1631 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1633 /* Set the initial value of flags. */
1635 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1636 dtp
->u
.p
.sign_status
= SIGN_S
;
1640 /* Set up the subroutine that will handle the transfers. */
1644 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1645 dtp
->u
.p
.transfer
= unformatted_read
;
1648 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1649 dtp
->u
.p
.transfer
= list_formatted_read
;
1651 dtp
->u
.p
.transfer
= formatted_transfer
;
1656 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1657 dtp
->u
.p
.transfer
= unformatted_write
;
1660 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1661 dtp
->u
.p
.transfer
= list_formatted_write
;
1663 dtp
->u
.p
.transfer
= formatted_transfer
;
1667 /* Make sure that we don't do a read after a nonadvancing write. */
1671 if (dtp
->u
.p
.current_unit
->read_bad
)
1673 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1674 "Cannot READ after a nonadvancing WRITE");
1680 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
1681 dtp
->u
.p
.current_unit
->read_bad
= 1;
1684 /* Start the data transfer if we are doing a formatted transfer. */
1685 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
1686 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
1687 && dtp
->u
.p
.ionml
== NULL
)
1688 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
1691 /* Initialize an array_loop_spec given the array descriptor. The function
1692 returns the index of the last element of the array. */
1695 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
1697 int rank
= GFC_DESCRIPTOR_RANK(desc
);
1702 for (i
=0; i
<rank
; i
++)
1705 ls
[i
].start
= desc
->dim
[i
].lbound
;
1706 ls
[i
].end
= desc
->dim
[i
].ubound
;
1707 ls
[i
].step
= desc
->dim
[i
].stride
;
1709 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
1710 * desc
->dim
[i
].stride
;
1715 /* Determine the index to the next record in an internal unit array by
1716 by incrementing through the array_loop_spec. TODO: Implement handling
1717 negative strides. */
1720 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
1728 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
1733 if (ls
[i
].idx
> ls
[i
].end
)
1735 ls
[i
].idx
= ls
[i
].start
;
1741 index
= index
+ (ls
[i
].idx
- 1) * ls
[i
].step
;
1746 /* Space to the next record for read mode. If the file is not
1747 seekable, we read MAX_READ chunks until we get to the right
1750 #define MAX_READ 4096
1753 next_record_r (st_parameter_dt
*dtp
)
1755 gfc_offset
new, record
;
1756 int bytes_left
, rlength
, length
;
1759 switch (current_mode (dtp
))
1761 case UNFORMATTED_SEQUENTIAL
:
1763 /* Skip over tail */
1764 dtp
->u
.p
.current_unit
->bytes_left
+=
1765 compile_options
.record_marker
== 0 ?
1766 sizeof (gfc_offset
) : compile_options
.record_marker
;
1768 /* Fall through... */
1770 case FORMATTED_DIRECT
:
1771 case UNFORMATTED_DIRECT
:
1772 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1775 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
1777 new = file_position (dtp
->u
.p
.current_unit
->s
)
1778 + dtp
->u
.p
.current_unit
->bytes_left
;
1780 /* Direct access files do not generate END conditions,
1782 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
1783 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1787 { /* Seek by reading data. */
1788 while (dtp
->u
.p
.current_unit
->bytes_left
> 0)
1790 rlength
= length
= (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left
) ?
1791 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left
;
1793 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
1796 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1800 dtp
->u
.p
.current_unit
->bytes_left
-= length
;
1805 case FORMATTED_SEQUENTIAL
:
1807 /* sf_read has already terminated input because of an '\n' */
1808 if (dtp
->u
.p
.sf_seen_eor
)
1810 dtp
->u
.p
.sf_seen_eor
= 0;
1814 if (is_internal_unit (dtp
))
1816 if (is_array_io (dtp
))
1818 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1820 /* Now seek to this record. */
1821 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1822 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1824 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
1827 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1831 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1832 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
1834 dtp
->u
.p
.current_unit
->bytes_left
1835 = dtp
->u
.p
.current_unit
->recl
;
1841 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1845 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1851 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1860 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1861 test_endfile (dtp
->u
.p
.current_unit
);
1865 /* Small utility function to write a record marker, taking care of
1866 byte swapping and of choosing the correct size. */
1869 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
1874 char p
[sizeof (GFC_INTEGER_8
)];
1876 if (compile_options
.record_marker
== 0)
1877 len
= sizeof (gfc_offset
);
1879 len
= compile_options
.record_marker
;
1881 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1882 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1884 switch (compile_options
.record_marker
)
1887 return swrite (dtp
->u
.p
.current_unit
->s
, &buf
, &len
);
1890 case sizeof (GFC_INTEGER_4
):
1892 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
1895 case sizeof (GFC_INTEGER_8
):
1897 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
1901 runtime_error ("Illegal value for record marker");
1907 switch (compile_options
.record_marker
)
1910 reverse_memcpy (p
, &buf
, sizeof (gfc_offset
));
1911 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1914 case sizeof (GFC_INTEGER_4
):
1916 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
1917 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1920 case sizeof (GFC_INTEGER_8
):
1922 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_4
));
1923 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1927 runtime_error ("Illegal value for record marker");
1935 /* Position to the next record in write mode. */
1938 next_record_w (st_parameter_dt
*dtp
, int done
)
1940 gfc_offset c
, m
, record
, max_pos
;
1943 size_t record_marker
;
1945 /* Zero counters for X- and T-editing. */
1946 max_pos
= dtp
->u
.p
.max_pos
;
1947 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1949 switch (current_mode (dtp
))
1951 case FORMATTED_DIRECT
:
1952 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1955 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
1956 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
1961 case UNFORMATTED_DIRECT
:
1962 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1966 case UNFORMATTED_SEQUENTIAL
:
1967 /* Bytes written. */
1968 m
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
1969 c
= file_position (dtp
->u
.p
.current_unit
->s
);
1971 /* Write the length tail. */
1973 if (write_us_marker (dtp
, m
) != 0)
1976 if (compile_options
.record_marker
== 4)
1977 record_marker
= sizeof(GFC_INTEGER_4
);
1979 record_marker
= sizeof (gfc_offset
);
1981 /* Seek to the head and overwrite the bogus length with the real
1984 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
1988 if (write_us_marker (dtp
, m
) != 0)
1991 /* Seek past the end of the current record. */
1993 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
1998 case FORMATTED_SEQUENTIAL
:
2000 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2003 if (is_internal_unit (dtp
))
2005 if (is_array_io (dtp
))
2007 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2009 /* If the farthest position reached is greater than current
2010 position, adjust the position and set length to pad out
2011 whats left. Otherwise just pad whats left.
2012 (for character array unit) */
2013 m
= dtp
->u
.p
.current_unit
->recl
2014 - dtp
->u
.p
.current_unit
->bytes_left
;
2017 length
= (int) (max_pos
- m
);
2018 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2019 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2022 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2024 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2028 /* Now that the current record has been padded out,
2029 determine where the next record in the array is. */
2030 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2032 /* Now seek to this record */
2033 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2035 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2037 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2041 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2047 /* If this is the last call to next_record move to the farthest
2048 position reached and set length to pad out the remainder
2049 of the record. (for character scaler unit) */
2052 m
= dtp
->u
.p
.current_unit
->recl
2053 - dtp
->u
.p
.current_unit
->bytes_left
;
2056 length
= (int) (max_pos
- m
);
2057 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2058 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2061 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2063 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2065 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2072 /* If this is the last call to next_record move to the farthest
2073 position reached in preparation for completing the record.
2077 m
= dtp
->u
.p
.current_unit
->recl
-
2078 dtp
->u
.p
.current_unit
->bytes_left
;
2081 length
= (int) (max_pos
- m
);
2082 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2086 const char crlf
[] = "\r\n";
2092 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2099 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2104 /* Position to the next record, which means moving to the end of the
2105 current record. This can happen under several different
2106 conditions. If the done flag is not set, we get ready to process
2110 next_record (st_parameter_dt
*dtp
, int done
)
2112 gfc_offset fp
; /* File position. */
2114 dtp
->u
.p
.current_unit
->read_bad
= 0;
2116 if (dtp
->u
.p
.mode
== READING
)
2117 next_record_r (dtp
);
2119 next_record_w (dtp
, done
);
2121 /* keep position up to date for INQUIRE */
2122 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
2124 dtp
->u
.p
.current_unit
->current_record
= 0;
2125 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2127 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2128 /* Calculate next record, rounding up partial records. */
2129 dtp
->u
.p
.current_unit
->last_record
= (fp
+ dtp
->u
.p
.current_unit
->recl
- 1)
2130 / dtp
->u
.p
.current_unit
->recl
;
2133 dtp
->u
.p
.current_unit
->last_record
++;
2140 /* Finalize the current data transfer. For a nonadvancing transfer,
2141 this means advancing to the next record. For internal units close the
2142 stream associated with the unit. */
2145 finalize_transfer (st_parameter_dt
*dtp
)
2148 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2150 if (dtp
->u
.p
.eor_condition
)
2152 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2156 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2159 if ((dtp
->u
.p
.ionml
!= NULL
)
2160 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2162 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2163 namelist_read (dtp
);
2165 namelist_write (dtp
);
2168 dtp
->u
.p
.transfer
= NULL
;
2169 if (dtp
->u
.p
.current_unit
== NULL
)
2172 dtp
->u
.p
.eof_jump
= &eof_jump
;
2173 if (setjmp (eof_jump
))
2175 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2179 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2180 finish_list_read (dtp
);
2183 dtp
->u
.p
.current_unit
->current_record
= 0;
2184 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
2186 /* Most systems buffer lines, so force the partial record
2187 to be written out. */
2188 flush (dtp
->u
.p
.current_unit
->s
);
2189 dtp
->u
.p
.seen_dollar
= 0;
2193 next_record (dtp
, 1);
2196 sfree (dtp
->u
.p
.current_unit
->s
);
2198 if (is_internal_unit (dtp
))
2200 if (is_array_io (dtp
) && dtp
->u
.p
.current_unit
->ls
!= NULL
)
2201 free_mem (dtp
->u
.p
.current_unit
->ls
);
2202 sclose (dtp
->u
.p
.current_unit
->s
);
2207 /* Transfer function for IOLENGTH. It doesn't actually do any
2208 data transfer, it just updates the length counter. */
2211 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2212 void *dest
__attribute__ ((unused
)),
2213 int kind
__attribute__((unused
)),
2214 size_t size
, size_t nelems
)
2216 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2217 *dtp
->iolength
+= (GFC_INTEGER_4
) size
* nelems
;
2221 /* Initialize the IOLENGTH data transfer. This function is in essence
2222 a very much simplified version of data_transfer_init(), because it
2223 doesn't have to deal with units at all. */
2226 iolength_transfer_init (st_parameter_dt
*dtp
)
2228 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2231 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2233 /* Set up the subroutine that will handle the transfers. */
2235 dtp
->u
.p
.transfer
= iolength_transfer
;
2239 /* Library entry point for the IOLENGTH form of the INQUIRE
2240 statement. The IOLENGTH form requires no I/O to be performed, but
2241 it must still be a runtime library call so that we can determine
2242 the iolength for dynamic arrays and such. */
2244 extern void st_iolength (st_parameter_dt
*);
2245 export_proto(st_iolength
);
2248 st_iolength (st_parameter_dt
*dtp
)
2250 library_start (&dtp
->common
);
2251 iolength_transfer_init (dtp
);
2254 extern void st_iolength_done (st_parameter_dt
*);
2255 export_proto(st_iolength_done
);
2258 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2261 if (dtp
->u
.p
.scratch
!= NULL
)
2262 free_mem (dtp
->u
.p
.scratch
);
2267 /* The READ statement. */
2269 extern void st_read (st_parameter_dt
*);
2270 export_proto(st_read
);
2273 st_read (st_parameter_dt
*dtp
)
2276 library_start (&dtp
->common
);
2278 data_transfer_init (dtp
, 1);
2280 /* Handle complications dealing with the endfile record. It is
2281 significant that this is the only place where ERROR_END is
2282 generated. Reading an end of file elsewhere is either end of
2283 record or an I/O error. */
2285 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2286 switch (dtp
->u
.p
.current_unit
->endfile
)
2292 if (!is_internal_unit (dtp
))
2294 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2295 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2296 dtp
->u
.p
.current_unit
->current_record
= 0;
2301 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2302 dtp
->u
.p
.current_unit
->current_record
= 0;
2307 extern void st_read_done (st_parameter_dt
*);
2308 export_proto(st_read_done
);
2311 st_read_done (st_parameter_dt
*dtp
)
2313 finalize_transfer (dtp
);
2314 free_format_data (dtp
);
2316 if (dtp
->u
.p
.scratch
!= NULL
)
2317 free_mem (dtp
->u
.p
.scratch
);
2318 if (dtp
->u
.p
.current_unit
!= NULL
)
2319 unlock_unit (dtp
->u
.p
.current_unit
);
2323 extern void st_write (st_parameter_dt
*);
2324 export_proto(st_write
);
2327 st_write (st_parameter_dt
*dtp
)
2329 library_start (&dtp
->common
);
2330 data_transfer_init (dtp
, 0);
2333 extern void st_write_done (st_parameter_dt
*);
2334 export_proto(st_write_done
);
2337 st_write_done (st_parameter_dt
*dtp
)
2339 finalize_transfer (dtp
);
2341 /* Deal with endfile conditions associated with sequential files. */
2343 if (dtp
->u
.p
.current_unit
!= NULL
2344 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2345 switch (dtp
->u
.p
.current_unit
->endfile
)
2347 case AT_ENDFILE
: /* Remain at the endfile record. */
2351 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2355 /* Get rid of whatever is after this record. */
2356 flush (dtp
->u
.p
.current_unit
->s
);
2357 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2358 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2360 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2364 free_format_data (dtp
);
2366 if (dtp
->u
.p
.scratch
!= NULL
)
2367 free_mem (dtp
->u
.p
.scratch
);
2368 if (dtp
->u
.p
.current_unit
!= NULL
)
2369 unlock_unit (dtp
->u
.p
.current_unit
);
2373 /* Receives the scalar information for namelist objects and stores it
2374 in a linked list of namelist_info types. */
2376 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2377 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2378 export_proto(st_set_nml_var
);
2382 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2383 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2384 GFC_INTEGER_4 dtype
)
2386 namelist_info
*t1
= NULL
;
2389 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2391 nml
->mem_pos
= var_addr
;
2393 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2394 strcpy (nml
->var_name
, var_name
);
2396 nml
->len
= (int) len
;
2397 nml
->string_length
= (index_type
) string_length
;
2399 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2400 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2401 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2403 if (nml
->var_rank
> 0)
2405 nml
->dim
= (descriptor_dimension
*)
2406 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2407 nml
->ls
= (array_loop_spec
*)
2408 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2418 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2420 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2421 dtp
->u
.p
.ionml
= nml
;
2425 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2430 /* Store the dimensional information for the namelist object. */
2431 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2432 GFC_INTEGER_4
, GFC_INTEGER_4
,
2434 export_proto(st_set_nml_var_dim
);
2437 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2438 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2439 GFC_INTEGER_4 ubound
)
2441 namelist_info
* nml
;
2446 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2448 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2449 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2450 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2453 /* Reverse memcpy - used for byte swapping. */
2455 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2461 s
= (char *) src
+ n
- 1;
2463 /* Write with ascending order - this is likely faster
2464 on modern architectures because of write combining. */