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
->u
.p
.size_used
+= (gfc_offset
) *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)
280 dtp
->u
.p
.size_used
+= (gfc_offset
) nread
;
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
->u
.p
.size_used
+= (gfc_offset
) 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
->u
.p
.size_used
+= (gfc_offset
) 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)
407 dtp
->u
.p
.size_used
+= (gfc_offset
) nbytes
;
413 /* Master function for unformatted reads. */
416 unformatted_read (st_parameter_dt
*dtp
, bt type
,
417 void *dest
, int kind
,
418 size_t size
, size_t nelems
)
420 /* Currently, character implies size=1. */
421 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
422 || size
== 1 || type
== BT_CHARACTER
)
425 read_block_direct (dtp
, dest
, &size
);
433 /* Break up complex into its constituent reals. */
434 if (type
== BT_COMPLEX
)
441 /* By now, all complex variables have been split into their
442 constituent reals. For types with padding, we only need to
443 read kind bytes. We don't care about the contents
447 for (i
=0; i
<nelems
; i
++)
449 read_block_direct (dtp
, buffer
, &sz
);
450 reverse_memcpy (p
, buffer
, sz
);
457 /* Master function for unformatted writes. */
460 unformatted_write (st_parameter_dt
*dtp
, bt type
,
461 void *source
, int kind
,
462 size_t size
, size_t nelems
)
464 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
465 size
== 1 || type
== BT_CHARACTER
)
469 write_buf (dtp
, source
, size
);
477 /* Break up complex into its constituent reals. */
478 if (type
== BT_COMPLEX
)
486 /* By now, all complex variables have been split into their
487 constituent reals. For types with padding, we only need to
488 read kind bytes. We don't care about the contents
492 for (i
=0; i
<nelems
; i
++)
494 reverse_memcpy(buffer
, p
, size
);
496 write_buf (dtp
, buffer
, sz
);
502 /* Return a pointer to the name of a type. */
527 internal_error (NULL
, "type_name(): Bad type");
534 /* Write a constant string to the output.
535 This is complicated because the string can have doubled delimiters
536 in it. The length in the format node is the true length. */
539 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
541 char c
, delimiter
, *p
, *q
;
544 length
= f
->u
.string
.length
;
548 p
= write_block (dtp
, length
);
555 for (; length
> 0; length
--)
558 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
559 q
++; /* Skip the doubled delimiter. */
564 /* Given actual and expected types in a formatted data transfer, make
565 sure they agree. If not, an error message is generated. Returns
566 nonzero if something went wrong. */
569 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
573 if (actual
== expected
)
576 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
577 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
579 format_error (dtp
, f
, buffer
);
584 /* This subroutine is the main loop for a formatted data transfer
585 statement. It would be natural to implement this as a coroutine
586 with the user program, but C makes that awkward. We loop,
587 processesing format elements. When we actually have to transfer
588 data instead of just setting flags, we return control to the user
589 program which calls a subroutine that supplies the address and type
590 of the next element, then comes back here to process it. */
593 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
596 char scratch
[SCRATCH_SIZE
];
601 int consume_data_flag
;
603 /* Change a complex data item into a pair of reals. */
605 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
606 if (type
== BT_COMPLEX
)
612 /* If there's an EOR condition, we simulate finalizing the transfer
614 if (dtp
->u
.p
.eor_condition
)
617 /* Set this flag so that commas in reads cause the read to complete before
618 the entire field has been read. The next read field will start right after
619 the comma in the stream. (Set to 0 for character reads). */
620 dtp
->u
.p
.sf_read_comma
= 1;
622 dtp
->u
.p
.line_buffer
= scratch
;
625 /* If reversion has occurred and there is another real data item,
626 then we have to move to the next record. */
627 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
629 dtp
->u
.p
.reversion_flag
= 0;
630 next_record (dtp
, 0);
633 consume_data_flag
= 1 ;
634 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
637 f
= next_format (dtp
);
639 return; /* No data descriptors left (already raised). */
641 /* Now discharge T, TR and X movements to the right. This is delayed
642 until a data producing format to suppress trailing spaces. */
645 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
646 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
647 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
648 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
649 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
652 if (dtp
->u
.p
.skips
> 0)
654 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
655 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
656 - dtp
->u
.p
.current_unit
->bytes_left
);
658 if (dtp
->u
.p
.skips
< 0)
660 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
661 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
663 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
666 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
673 if (require_type (dtp
, BT_INTEGER
, type
, f
))
676 if (dtp
->u
.p
.mode
== READING
)
677 read_decimal (dtp
, f
, p
, len
);
679 write_i (dtp
, f
, p
, len
);
686 if (require_type (dtp
, BT_INTEGER
, type
, f
))
689 if (dtp
->u
.p
.mode
== READING
)
690 read_radix (dtp
, f
, p
, len
, 2);
692 write_b (dtp
, f
, p
, len
);
700 if (dtp
->u
.p
.mode
== READING
)
701 read_radix (dtp
, f
, p
, len
, 8);
703 write_o (dtp
, f
, p
, len
);
711 if (dtp
->u
.p
.mode
== READING
)
712 read_radix (dtp
, f
, p
, len
, 16);
714 write_z (dtp
, f
, p
, len
);
722 if (dtp
->u
.p
.mode
== READING
)
723 read_a (dtp
, f
, p
, len
);
725 write_a (dtp
, f
, p
, len
);
733 if (dtp
->u
.p
.mode
== READING
)
734 read_l (dtp
, f
, p
, len
);
736 write_l (dtp
, f
, p
, len
);
743 if (require_type (dtp
, BT_REAL
, type
, f
))
746 if (dtp
->u
.p
.mode
== READING
)
747 read_f (dtp
, f
, p
, len
);
749 write_d (dtp
, f
, p
, len
);
756 if (require_type (dtp
, BT_REAL
, type
, f
))
759 if (dtp
->u
.p
.mode
== READING
)
760 read_f (dtp
, f
, p
, len
);
762 write_e (dtp
, f
, p
, len
);
768 if (require_type (dtp
, BT_REAL
, type
, f
))
771 if (dtp
->u
.p
.mode
== READING
)
772 read_f (dtp
, f
, p
, len
);
774 write_en (dtp
, f
, p
, len
);
781 if (require_type (dtp
, BT_REAL
, type
, f
))
784 if (dtp
->u
.p
.mode
== READING
)
785 read_f (dtp
, f
, p
, len
);
787 write_es (dtp
, f
, p
, len
);
794 if (require_type (dtp
, BT_REAL
, type
, f
))
797 if (dtp
->u
.p
.mode
== READING
)
798 read_f (dtp
, f
, p
, len
);
800 write_f (dtp
, f
, p
, len
);
807 if (dtp
->u
.p
.mode
== READING
)
811 read_decimal (dtp
, f
, p
, len
);
814 read_l (dtp
, f
, p
, len
);
817 read_a (dtp
, f
, p
, len
);
820 read_f (dtp
, f
, p
, len
);
829 write_i (dtp
, f
, p
, len
);
832 write_l (dtp
, f
, p
, len
);
835 write_a (dtp
, f
, p
, len
);
838 write_d (dtp
, f
, p
, len
);
842 internal_error (&dtp
->common
,
843 "formatted_transfer(): Bad type");
849 consume_data_flag
= 0 ;
850 if (dtp
->u
.p
.mode
== READING
)
852 format_error (dtp
, f
, "Constant string in input format");
855 write_constant_string (dtp
, f
);
858 /* Format codes that don't transfer data. */
861 consume_data_flag
= 0 ;
863 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
864 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
865 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
867 /* Writes occur just before the switch on f->format, above, so
868 that trailing blanks are suppressed, unless we are doing a
869 non-advancing write in which case we want to output the blanks
871 if (dtp
->u
.p
.mode
== WRITING
872 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
874 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
875 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
877 if (dtp
->u
.p
.mode
== READING
)
878 read_x (dtp
, f
->u
.n
);
884 if (f
->format
== FMT_TL
)
887 /* Handle the special case when no bytes have been used yet.
888 Cannot go below zero. */
891 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
892 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
893 : dtp
->u
.p
.pending_spaces
;
894 dtp
->u
.p
.skips
-= f
->u
.n
;
895 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
898 pos
= bytes_used
- f
->u
.n
;
902 consume_data_flag
= 0;
906 /* Standard 10.6.1.1: excessive left tabbing is reset to the
907 left tab limit. We do not check if the position has gone
908 beyond the end of record because a subsequent tab could
909 bring us back again. */
910 pos
= pos
< 0 ? 0 : pos
;
912 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
913 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
914 + pos
- dtp
->u
.p
.max_pos
;
916 if (dtp
->u
.p
.skips
== 0)
919 /* Writes occur just before the switch on f->format, above, so that
920 trailing blanks are suppressed. */
921 if (dtp
->u
.p
.mode
== READING
)
923 /* Adjust everything for end-of-record condition */
924 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
926 if (dtp
->u
.p
.sf_seen_eor
== 2)
928 /* The EOR was a CRLF (two bytes wide). */
929 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
934 /* The EOR marker was only one byte wide. */
935 dtp
->u
.p
.current_unit
->bytes_left
--;
939 dtp
->u
.p
.sf_seen_eor
= 0;
941 if (dtp
->u
.p
.skips
< 0)
943 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
944 dtp
->u
.p
.current_unit
->bytes_left
945 -= (gfc_offset
) dtp
->u
.p
.skips
;
946 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
949 read_x (dtp
, dtp
->u
.p
.skips
);
955 consume_data_flag
= 0 ;
956 dtp
->u
.p
.sign_status
= SIGN_S
;
960 consume_data_flag
= 0 ;
961 dtp
->u
.p
.sign_status
= SIGN_SS
;
965 consume_data_flag
= 0 ;
966 dtp
->u
.p
.sign_status
= SIGN_SP
;
970 consume_data_flag
= 0 ;
971 dtp
->u
.p
.blank_status
= BLANK_NULL
;
975 consume_data_flag
= 0 ;
976 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
980 consume_data_flag
= 0 ;
981 dtp
->u
.p
.scale_factor
= f
->u
.k
;
985 consume_data_flag
= 0 ;
986 dtp
->u
.p
.seen_dollar
= 1;
990 consume_data_flag
= 0 ;
991 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
992 next_record (dtp
, 0);
996 /* A colon descriptor causes us to exit this loop (in
997 particular preventing another / descriptor from being
998 processed) unless there is another data item to be
1000 consume_data_flag
= 0 ;
1006 internal_error (&dtp
->common
, "Bad format node");
1009 /* Free a buffer that we had to allocate during a sequential
1010 formatted read of a block that was larger than the static
1013 if (dtp
->u
.p
.line_buffer
!= scratch
)
1015 free_mem (dtp
->u
.p
.line_buffer
);
1016 dtp
->u
.p
.line_buffer
= scratch
;
1019 /* Adjust the item count and data pointer. */
1021 if ((consume_data_flag
> 0) && (n
> 0))
1024 p
= ((char *) p
) + size
;
1027 if (dtp
->u
.p
.mode
== READING
)
1030 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1031 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1037 /* Come here when we need a data descriptor but don't have one. We
1038 push the current format node back onto the input, then return and
1039 let the user program call us back with the data. */
1041 unget_format (dtp
, f
);
1045 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1046 size_t size
, size_t nelems
)
1053 /* Big loop over all the elements. */
1054 for (elem
= 0; elem
< nelems
; elem
++)
1056 dtp
->u
.p
.item_count
++;
1057 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1063 /* Data transfer entry points. The type of the data entity is
1064 implicit in the subroutine call. This prevents us from having to
1065 share a common enum with the compiler. */
1068 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1070 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1072 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1077 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1080 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1082 size
= size_from_real_kind (kind
);
1083 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1088 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1090 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1092 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1097 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1099 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1101 /* Currently we support only 1 byte chars, and the library is a bit
1102 confused of character kind vs. length, so we kludge it by setting
1104 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1109 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1112 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1114 size
= size_from_complex_kind (kind
);
1115 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1120 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1121 gfc_charlen_type charlen
)
1123 index_type count
[GFC_MAX_DIMENSIONS
];
1124 index_type extent
[GFC_MAX_DIMENSIONS
];
1125 index_type stride
[GFC_MAX_DIMENSIONS
];
1126 index_type stride0
, rank
, size
, type
, n
;
1131 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1134 type
= GFC_DESCRIPTOR_TYPE (desc
);
1135 size
= GFC_DESCRIPTOR_SIZE (desc
);
1137 /* FIXME: What a kludge: Array descriptors and the IO library use
1138 different enums for types. */
1141 case GFC_DTYPE_UNKNOWN
:
1142 iotype
= BT_NULL
; /* Is this correct? */
1144 case GFC_DTYPE_INTEGER
:
1145 iotype
= BT_INTEGER
;
1147 case GFC_DTYPE_LOGICAL
:
1148 iotype
= BT_LOGICAL
;
1150 case GFC_DTYPE_REAL
:
1153 case GFC_DTYPE_COMPLEX
:
1154 iotype
= BT_COMPLEX
;
1156 case GFC_DTYPE_CHARACTER
:
1157 iotype
= BT_CHARACTER
;
1158 /* FIXME: Currently dtype contains the charlen, which is
1159 clobbered if charlen > 2**24. That's why we use a separate
1160 argument for the charlen. However, if we want to support
1161 non-8-bit charsets we need to fix dtype to contain
1162 sizeof(chartype) and fix the code below. */
1166 case GFC_DTYPE_DERIVED
:
1167 internal_error (&dtp
->common
,
1168 "Derived type I/O should have been handled via the frontend.");
1171 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1174 if (desc
->dim
[0].stride
== 0)
1175 desc
->dim
[0].stride
= 1;
1177 rank
= GFC_DESCRIPTOR_RANK (desc
);
1178 for (n
= 0; n
< rank
; n
++)
1181 stride
[n
] = desc
->dim
[n
].stride
;
1182 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1184 /* If the extent of even one dimension is zero, then the entire
1185 array section contains zero elements, so we return. */
1190 stride0
= stride
[0];
1192 /* If the innermost dimension has stride 1, we can do the transfer
1193 in contiguous chunks. */
1199 data
= GFC_DESCRIPTOR_DATA (desc
);
1203 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1204 data
+= stride0
* size
* tsize
;
1207 while (count
[n
] == extent
[n
])
1210 data
-= stride
[n
] * extent
[n
] * size
;
1220 data
+= stride
[n
] * size
;
1227 /* Preposition a sequential unformatted file while reading. */
1230 us_read (st_parameter_dt
*dtp
)
1239 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1242 if (compile_options
.record_marker
== 0)
1243 n
= sizeof (gfc_offset
);
1245 n
= compile_options
.record_marker
;
1249 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1253 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1254 return; /* end of file */
1257 if (p
== NULL
|| n
!= nr
)
1259 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1263 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1264 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1266 switch (compile_options
.record_marker
)
1269 memcpy (&i
, p
, sizeof(gfc_offset
));
1272 case sizeof(GFC_INTEGER_4
):
1273 memcpy (&i4
, p
, sizeof (i4
));
1277 case sizeof(GFC_INTEGER_8
):
1278 memcpy (&i8
, p
, sizeof (i8
));
1283 runtime_error ("Illegal value for record marker");
1288 switch (compile_options
.record_marker
)
1291 reverse_memcpy (&i
, p
, sizeof(gfc_offset
));
1294 case sizeof(GFC_INTEGER_4
):
1295 reverse_memcpy (&i4
, p
, sizeof (i4
));
1299 case sizeof(GFC_INTEGER_8
):
1300 reverse_memcpy (&i8
, p
, sizeof (i8
));
1305 runtime_error ("Illegal value for record marker");
1309 dtp
->u
.p
.current_unit
->bytes_left
= i
;
1313 /* Preposition a sequential unformatted file while writing. This
1314 amount to writing a bogus length that will be filled in later. */
1317 us_write (st_parameter_dt
*dtp
)
1324 if (compile_options
.record_marker
== 0)
1325 nbytes
= sizeof (gfc_offset
);
1327 nbytes
= compile_options
.record_marker
;
1329 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1330 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1332 /* For sequential unformatted, we write until we have more bytes
1333 than can fit in the record markers. If disk space runs out first,
1334 it will error on the write. */
1335 dtp
->u
.p
.current_unit
->recl
= max_offset
;
1337 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1341 /* Position to the next record prior to transfer. We are assumed to
1342 be before the next record. We also calculate the bytes in the next
1346 pre_position (st_parameter_dt
*dtp
)
1348 if (dtp
->u
.p
.current_unit
->current_record
)
1349 return; /* Already positioned. */
1351 switch (current_mode (dtp
))
1353 case UNFORMATTED_SEQUENTIAL
:
1354 if (dtp
->u
.p
.mode
== READING
)
1361 case FORMATTED_SEQUENTIAL
:
1362 case FORMATTED_DIRECT
:
1363 case UNFORMATTED_DIRECT
:
1364 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1368 dtp
->u
.p
.current_unit
->current_record
= 1;
1372 /* Initialize things for a data transfer. This code is common for
1373 both reading and writing. */
1376 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1378 unit_flags u_flags
; /* Used for creating a unit if needed. */
1379 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1380 namelist_info
*ionml
;
1382 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1383 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1384 dtp
->u
.p
.ionml
= ionml
;
1385 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1387 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1388 dtp
->u
.p
.size_used
= 0; /* Initialize the count. */
1390 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1391 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1392 { /* Open the unit with some default flags. */
1393 st_parameter_open opp
;
1396 if (dtp
->common
.unit
< 0)
1398 close_unit (dtp
->u
.p
.current_unit
);
1399 dtp
->u
.p
.current_unit
= NULL
;
1400 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1401 "Bad unit number in OPEN statement");
1404 memset (&u_flags
, '\0', sizeof (u_flags
));
1405 u_flags
.access
= ACCESS_SEQUENTIAL
;
1406 u_flags
.action
= ACTION_READWRITE
;
1408 /* Is it unformatted? */
1409 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1410 | IOPARM_DT_IONML_SET
)))
1411 u_flags
.form
= FORM_UNFORMATTED
;
1413 u_flags
.form
= FORM_UNSPECIFIED
;
1415 u_flags
.delim
= DELIM_UNSPECIFIED
;
1416 u_flags
.blank
= BLANK_UNSPECIFIED
;
1417 u_flags
.pad
= PAD_UNSPECIFIED
;
1418 u_flags
.status
= STATUS_UNKNOWN
;
1420 conv
= get_unformatted_convert (dtp
->common
.unit
);
1422 if (conv
== CONVERT_NONE
)
1423 conv
= compile_options
.convert
;
1425 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1426 and 1 on big-endian machines. */
1429 case CONVERT_NATIVE
:
1434 conv
= l8_to_l4_offset
? CONVERT_NATIVE
: CONVERT_SWAP
;
1437 case CONVERT_LITTLE
:
1438 conv
= l8_to_l4_offset
? CONVERT_SWAP
: CONVERT_NATIVE
;
1442 internal_error (&opp
.common
, "Illegal value for CONVERT");
1446 u_flags
.convert
= conv
;
1448 opp
.common
= dtp
->common
;
1449 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1450 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1451 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1452 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1453 if (dtp
->u
.p
.current_unit
== NULL
)
1457 /* Check the action. */
1459 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1460 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1461 "Cannot read from file opened for WRITE");
1463 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1464 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1465 "Cannot write to file opened for READ");
1467 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1470 dtp
->u
.p
.first_item
= 1;
1472 /* Check the format. */
1474 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1477 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1480 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1481 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1483 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1484 "Format present for UNFORMATTED data transfer");
1486 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1488 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1489 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1490 "A format cannot be specified with a namelist");
1492 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1493 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1494 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1495 "Missing format for FORMATTED data transfer");
1498 if (is_internal_unit (dtp
)
1499 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1500 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1501 "Internal file cannot be accessed by UNFORMATTED data transfer");
1503 /* Check the record number. */
1505 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1506 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1508 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1509 "Direct access data transfer requires record number");
1513 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1514 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1516 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1517 "Record number not allowed for sequential access data transfer");
1521 /* Process the ADVANCE option. */
1523 dtp
->u
.p
.advance_status
1524 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1525 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1526 "Bad ADVANCE parameter in data transfer statement");
1528 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1530 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1531 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1532 "ADVANCE specification conflicts with sequential access");
1534 if (is_internal_unit (dtp
))
1535 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1536 "ADVANCE specification conflicts with internal file");
1538 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1539 != IOPARM_DT_HAS_FORMAT
)
1540 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1541 "ADVANCE specification requires an explicit format");
1546 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1547 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1548 "EOR specification requires an ADVANCE specification of NO");
1550 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1551 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1552 "SIZE specification requires an ADVANCE specification of NO");
1556 { /* Write constraints. */
1557 if ((cf
& IOPARM_END
) != 0)
1558 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1559 "END specification cannot appear in a write statement");
1561 if ((cf
& IOPARM_EOR
) != 0)
1562 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1563 "EOR specification cannot appear in a write statement");
1565 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1566 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1567 "SIZE specification cannot appear in a write statement");
1570 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1571 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1572 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1575 /* Sanity checks on the record number. */
1577 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1581 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1582 "Record number must be positive");
1586 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1588 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1589 "Record number too large");
1593 /* Check to see if we might be reading what we wrote before */
1595 if (dtp
->u
.p
.mode
== READING
&& dtp
->u
.p
.current_unit
->mode
== WRITING
)
1596 flush(dtp
->u
.p
.current_unit
->s
);
1598 /* Check whether the record exists to be read. Only
1599 a partial record needs to exist. */
1601 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1602 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1604 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1605 "Non-existing record number");
1609 /* Position the file. */
1610 if (sseek (dtp
->u
.p
.current_unit
->s
,
1611 (dtp
->rec
- 1) * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1613 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1618 /* Overwriting an existing sequential file ?
1619 it is always safe to truncate the file on the first write */
1620 if (dtp
->u
.p
.mode
== WRITING
1621 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1622 && dtp
->u
.p
.current_unit
->last_record
== 0 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1623 struncate(dtp
->u
.p
.current_unit
->s
);
1625 /* Bugware for badly written mixed C-Fortran I/O. */
1626 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1628 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1630 /* Set the initial value of flags. */
1632 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1633 dtp
->u
.p
.sign_status
= SIGN_S
;
1637 /* Set up the subroutine that will handle the transfers. */
1641 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1642 dtp
->u
.p
.transfer
= unformatted_read
;
1645 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1646 dtp
->u
.p
.transfer
= list_formatted_read
;
1648 dtp
->u
.p
.transfer
= formatted_transfer
;
1653 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1654 dtp
->u
.p
.transfer
= unformatted_write
;
1657 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1658 dtp
->u
.p
.transfer
= list_formatted_write
;
1660 dtp
->u
.p
.transfer
= formatted_transfer
;
1664 /* Make sure that we don't do a read after a nonadvancing write. */
1668 if (dtp
->u
.p
.current_unit
->read_bad
)
1670 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1671 "Cannot READ after a nonadvancing WRITE");
1677 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
1678 dtp
->u
.p
.current_unit
->read_bad
= 1;
1681 /* Start the data transfer if we are doing a formatted transfer. */
1682 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
1683 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
1684 && dtp
->u
.p
.ionml
== NULL
)
1685 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
1688 /* Initialize an array_loop_spec given the array descriptor. The function
1689 returns the index of the last element of the array. */
1692 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
1694 int rank
= GFC_DESCRIPTOR_RANK(desc
);
1699 for (i
=0; i
<rank
; i
++)
1702 ls
[i
].start
= desc
->dim
[i
].lbound
;
1703 ls
[i
].end
= desc
->dim
[i
].ubound
;
1704 ls
[i
].step
= desc
->dim
[i
].stride
;
1706 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
1707 * desc
->dim
[i
].stride
;
1712 /* Determine the index to the next record in an internal unit array by
1713 by incrementing through the array_loop_spec. TODO: Implement handling
1714 negative strides. */
1717 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
1725 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
1730 if (ls
[i
].idx
> ls
[i
].end
)
1732 ls
[i
].idx
= ls
[i
].start
;
1738 index
= index
+ (ls
[i
].idx
- 1) * ls
[i
].step
;
1743 /* Space to the next record for read mode. If the file is not
1744 seekable, we read MAX_READ chunks until we get to the right
1747 #define MAX_READ 4096
1750 next_record_r (st_parameter_dt
*dtp
)
1752 gfc_offset
new, record
;
1753 int bytes_left
, rlength
, length
;
1756 switch (current_mode (dtp
))
1758 case UNFORMATTED_SEQUENTIAL
:
1760 /* Skip over tail */
1761 dtp
->u
.p
.current_unit
->bytes_left
+=
1762 compile_options
.record_marker
== 0 ?
1763 sizeof (gfc_offset
) : compile_options
.record_marker
;
1765 /* Fall through... */
1767 case FORMATTED_DIRECT
:
1768 case UNFORMATTED_DIRECT
:
1769 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1772 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
1774 new = file_position (dtp
->u
.p
.current_unit
->s
)
1775 + dtp
->u
.p
.current_unit
->bytes_left
;
1777 /* Direct access files do not generate END conditions,
1779 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
1780 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1784 { /* Seek by reading data. */
1785 while (dtp
->u
.p
.current_unit
->bytes_left
> 0)
1787 rlength
= length
= (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left
) ?
1788 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left
;
1790 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
1793 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1797 dtp
->u
.p
.current_unit
->bytes_left
-= length
;
1802 case FORMATTED_SEQUENTIAL
:
1804 /* sf_read has already terminated input because of an '\n' */
1805 if (dtp
->u
.p
.sf_seen_eor
)
1807 dtp
->u
.p
.sf_seen_eor
= 0;
1811 if (is_internal_unit (dtp
))
1813 if (is_array_io (dtp
))
1815 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1817 /* Now seek to this record. */
1818 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1819 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1821 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
1824 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1828 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1829 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
1831 dtp
->u
.p
.current_unit
->bytes_left
1832 = dtp
->u
.p
.current_unit
->recl
;
1838 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1842 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1848 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1857 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1858 test_endfile (dtp
->u
.p
.current_unit
);
1862 /* Small utility function to write a record marker, taking care of
1863 byte swapping and of choosing the correct size. */
1866 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
1871 char p
[sizeof (GFC_INTEGER_8
)];
1873 if (compile_options
.record_marker
== 0)
1874 len
= sizeof (gfc_offset
);
1876 len
= compile_options
.record_marker
;
1878 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1879 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1881 switch (compile_options
.record_marker
)
1884 return swrite (dtp
->u
.p
.current_unit
->s
, &buf
, &len
);
1887 case sizeof (GFC_INTEGER_4
):
1889 return swrite (dtp
->u
.p
.current_unit
->s
, &buf4
, &len
);
1892 case sizeof (GFC_INTEGER_8
):
1894 return swrite (dtp
->u
.p
.current_unit
->s
, &buf8
, &len
);
1898 runtime_error ("Illegal value for record marker");
1904 switch (compile_options
.record_marker
)
1907 reverse_memcpy (p
, &buf
, sizeof (gfc_offset
));
1908 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1911 case sizeof (GFC_INTEGER_4
):
1913 reverse_memcpy (p
, &buf4
, sizeof (GFC_INTEGER_4
));
1914 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1917 case sizeof (GFC_INTEGER_8
):
1919 reverse_memcpy (p
, &buf8
, sizeof (GFC_INTEGER_4
));
1920 return swrite (dtp
->u
.p
.current_unit
->s
, p
, &len
);
1924 runtime_error ("Illegal value for record marker");
1932 /* Position to the next record in write mode. */
1935 next_record_w (st_parameter_dt
*dtp
, int done
)
1937 gfc_offset c
, m
, record
, max_pos
;
1940 size_t record_marker
;
1942 /* Zero counters for X- and T-editing. */
1943 max_pos
= dtp
->u
.p
.max_pos
;
1944 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1946 switch (current_mode (dtp
))
1948 case FORMATTED_DIRECT
:
1949 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1952 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
1953 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
1958 case UNFORMATTED_DIRECT
:
1959 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1963 case UNFORMATTED_SEQUENTIAL
:
1964 /* Bytes written. */
1965 m
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
1966 c
= file_position (dtp
->u
.p
.current_unit
->s
);
1968 /* Write the length tail. */
1970 if (write_us_marker (dtp
, m
) != 0)
1973 if (compile_options
.record_marker
== 4)
1974 record_marker
= sizeof(GFC_INTEGER_4
);
1976 record_marker
= sizeof (gfc_offset
);
1978 /* Seek to the head and overwrite the bogus length with the real
1981 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- record_marker
)
1985 if (write_us_marker (dtp
, m
) != 0)
1988 /* Seek past the end of the current record. */
1990 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ record_marker
) == FAILURE
)
1995 case FORMATTED_SEQUENTIAL
:
1997 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
2000 if (is_internal_unit (dtp
))
2002 if (is_array_io (dtp
))
2004 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2006 /* If the farthest position reached is greater than current
2007 position, adjust the position and set length to pad out
2008 whats left. Otherwise just pad whats left.
2009 (for character array unit) */
2010 m
= dtp
->u
.p
.current_unit
->recl
2011 - dtp
->u
.p
.current_unit
->bytes_left
;
2014 length
= (int) (max_pos
- m
);
2015 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2016 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2019 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2021 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2025 /* Now that the current record has been padded out,
2026 determine where the next record in the array is. */
2027 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
2029 /* Now seek to this record */
2030 record
= record
* dtp
->u
.p
.current_unit
->recl
;
2032 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
2034 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
2038 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
2044 /* If this is the last call to next_record move to the farthest
2045 position reached and set length to pad out the remainder
2046 of the record. (for character scaler unit) */
2049 m
= dtp
->u
.p
.current_unit
->recl
2050 - dtp
->u
.p
.current_unit
->bytes_left
;
2053 length
= (int) (max_pos
- m
);
2054 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2055 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
2058 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
2060 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
2062 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2069 /* If this is the last call to next_record move to the farthest
2070 position reached in preparation for completing the record.
2074 m
= dtp
->u
.p
.current_unit
->recl
-
2075 dtp
->u
.p
.current_unit
->bytes_left
;
2078 length
= (int) (max_pos
- m
);
2079 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
2083 const char crlf
[] = "\r\n";
2089 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
2096 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2101 /* Position to the next record, which means moving to the end of the
2102 current record. This can happen under several different
2103 conditions. If the done flag is not set, we get ready to process
2107 next_record (st_parameter_dt
*dtp
, int done
)
2109 gfc_offset fp
; /* File position. */
2111 dtp
->u
.p
.current_unit
->read_bad
= 0;
2113 if (dtp
->u
.p
.mode
== READING
)
2114 next_record_r (dtp
);
2116 next_record_w (dtp
, done
);
2118 /* keep position up to date for INQUIRE */
2119 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
2121 dtp
->u
.p
.current_unit
->current_record
= 0;
2122 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
2124 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
2125 /* Calculate next record, rounding up partial records. */
2126 dtp
->u
.p
.current_unit
->last_record
= (fp
+ dtp
->u
.p
.current_unit
->recl
- 1)
2127 / dtp
->u
.p
.current_unit
->recl
;
2130 dtp
->u
.p
.current_unit
->last_record
++;
2137 /* Finalize the current data transfer. For a nonadvancing transfer,
2138 this means advancing to the next record. For internal units close the
2139 stream associated with the unit. */
2142 finalize_transfer (st_parameter_dt
*dtp
)
2145 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
2147 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
2148 *dtp
->size
= (GFC_INTEGER_4
) dtp
->u
.p
.size_used
;
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. */