1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
32 /* transfer.c -- Top level handling of data transfer statements. */
37 #include "libgfortran.h"
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
59 These subroutines do not return status.
61 The last call is a call to st_[read|write]_done(). While
62 something can easily go wrong with the initial st_read() or
63 st_write(), an error inhibits any data from actually being
66 extern void transfer_integer (st_parameter_dt
*, void *, int);
67 export_proto(transfer_integer
);
69 extern void transfer_real (st_parameter_dt
*, void *, int);
70 export_proto(transfer_real
);
72 extern void transfer_logical (st_parameter_dt
*, void *, int);
73 export_proto(transfer_logical
);
75 extern void transfer_character (st_parameter_dt
*, void *, int);
76 export_proto(transfer_character
);
78 extern void transfer_complex (st_parameter_dt
*, void *, int);
79 export_proto(transfer_complex
);
81 extern void transfer_array (st_parameter_dt
*, gfc_array_char
*, int,
83 export_proto(transfer_array
);
85 static const st_option advance_opt
[] = {
93 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
94 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
100 current_mode (st_parameter_dt
*dtp
)
104 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
106 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
107 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
111 m
= dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
?
112 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
119 /* Mid level data transfer statements. These subroutines do reading
120 and writing in the style of salloc_r()/salloc_w() within the
123 /* When reading sequential formatted records we have a problem. We
124 don't know how long the line is until we read the trailing newline,
125 and we don't want to read too much. If we read too much, we might
126 have to do a physical seek backwards depending on how much data is
127 present, and devices like terminals aren't seekable and would cause
130 Given this, the solution is to read a byte at a time, stopping if
131 we hit the newline. For small locations, we use a static buffer.
132 For larger allocations, we are forced to allocate memory on the
133 heap. Hopefully this won't happen very often. */
136 read_sf (st_parameter_dt
*dtp
, int *length
)
139 int n
, readlen
, crlf
;
142 if (*length
> SCRATCH_SIZE
)
143 dtp
->u
.p
.line_buffer
= get_mem (*length
);
144 p
= base
= dtp
->u
.p
.line_buffer
;
146 /* If we have seen an eor previously, return a length of 0. The
147 caller is responsible for correctly padding the input field. */
148 if (dtp
->u
.p
.sf_seen_eor
)
159 if (is_internal_unit (dtp
))
161 /* readlen may be modified inside salloc_r if
162 is_internal_unit (dtp) is true. */
166 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
170 /* If we have a line without a terminating \n, drop through to
172 if (readlen
< 1 && n
== 0)
174 generate_error (&dtp
->common
, ERROR_END
, NULL
);
178 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
180 /* Unexpected end of line. */
182 /* If we see an EOR during non-advancing I/O, we need to skip
183 the rest of the I/O statement. Set the corresponding flag. */
184 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
185 dtp
->u
.p
.eor_condition
= 1;
188 /* If we encounter a CR, it might be a CRLF. */
189 if (*q
== '\r') /* Probably a CRLF */
192 pos
= stream_offset (dtp
->u
.p
.current_unit
->s
);
193 q
= salloc_r (dtp
->u
.p
.current_unit
->s
, &readlen
);
194 if (*q
!= '\n' && readlen
== 1) /* Not a CRLF after all. */
195 sseek (dtp
->u
.p
.current_unit
->s
, pos
);
200 /* Without padding, terminate the I/O statement without assigning
201 the value. With padding, the value still needs to be assigned,
202 so we can just continue with a short read. */
203 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
205 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
210 dtp
->u
.p
.sf_seen_eor
= (crlf
? 2 : 1);
213 /* Short circuit the read if a comma is found during numeric input.
214 The flag is set to zero during character reads so that commas in
215 strings are not ignored */
217 if (dtp
->u
.p
.sf_read_comma
== 1)
219 notify_std (GFC_STD_GNU
, "Comma in formatted numeric read.");
226 dtp
->u
.p
.sf_seen_eor
= 0;
229 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
231 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
232 *dtp
->size
+= *length
;
238 /* Function for reading the next couple of bytes from the current
239 file, advancing the current position. We return a pointer to a
240 buffer containing the bytes. We return NULL on end of record or
243 If the read is short, then it is because the current record does not
244 have enough data to satisfy the read request and the file was
245 opened with PAD=YES. The caller must assume tailing spaces for
249 read_block (st_parameter_dt
*dtp
, int *length
)
254 if (dtp
->u
.p
.current_unit
->bytes_left
< *length
)
256 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
258 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
259 /* Not enough data left. */
263 *length
= dtp
->u
.p
.current_unit
->bytes_left
;
266 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
267 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
268 return read_sf (dtp
, length
); /* Special case. */
270 dtp
->u
.p
.current_unit
->bytes_left
-= *length
;
273 source
= salloc_r (dtp
->u
.p
.current_unit
->s
, &nread
);
275 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
278 if (nread
!= *length
)
279 { /* Short read, this shouldn't happen. */
280 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
284 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
293 /* Reads a block directly into application data space. */
296 read_block_direct (st_parameter_dt
*dtp
, void *buf
, size_t *nbytes
)
302 if (dtp
->u
.p
.current_unit
->bytes_left
< *nbytes
)
304 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_NO
)
306 /* Not enough data left. */
307 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
311 *nbytes
= dtp
->u
.p
.current_unit
->bytes_left
;
314 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
315 dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
317 length
= (int *) nbytes
;
318 data
= read_sf (dtp
, length
); /* Special case. */
319 memcpy (buf
, data
, (size_t) *length
);
323 dtp
->u
.p
.current_unit
->bytes_left
-= *nbytes
;
326 if (sread (dtp
->u
.p
.current_unit
->s
, buf
, &nread
) != 0)
328 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
332 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
333 *dtp
->size
+= (GFC_INTEGER_4
) nread
;
335 if (nread
!= *nbytes
)
336 { /* Short read, e.g. if we hit EOF. */
337 if (dtp
->u
.p
.current_unit
->flags
.pad
== PAD_YES
)
339 memset (((char *) buf
) + nread
, ' ', *nbytes
- nread
);
343 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
348 /* Function for writing a block of bytes to the current file at the
349 current position, advancing the file pointer. We are given a length
350 and return a pointer to a buffer that the caller must (completely)
351 fill in. Returns NULL on error. */
354 write_block (st_parameter_dt
*dtp
, int length
)
358 if (dtp
->u
.p
.current_unit
->bytes_left
< length
)
360 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
364 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) length
;
365 dest
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
369 generate_error (&dtp
->common
, ERROR_END
, NULL
);
373 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
374 *dtp
->size
+= length
;
380 /* High level interface to swrite(), taking care of errors. */
383 write_buf (st_parameter_dt
*dtp
, void *buf
, size_t nbytes
)
385 if (dtp
->u
.p
.current_unit
->bytes_left
< nbytes
)
387 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
391 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) nbytes
;
393 if (swrite (dtp
->u
.p
.current_unit
->s
, buf
, &nbytes
) != 0)
395 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
399 if ((dtp
->common
.flags
& IOPARM_DT_HAS_SIZE
) != 0)
401 *dtp
->size
+= (GFC_INTEGER_4
) nbytes
;
409 /* Master function for unformatted reads. */
412 unformatted_read (st_parameter_dt
*dtp
, bt type
,
413 void *dest
, int kind
,
414 size_t size
, size_t nelems
)
416 /* Currently, character implies size=1. */
417 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
418 || size
== 1 || type
== BT_CHARACTER
)
421 read_block_direct (dtp
, dest
, &size
);
429 /* Break up complex into its constituent reals. */
430 if (type
== BT_COMPLEX
)
437 /* By now, all complex variables have been split into their
438 constituent reals. For types with padding, we only need to
439 read kind bytes. We don't care about the contents
443 for (i
=0; i
<nelems
; i
++)
445 read_block_direct (dtp
, buffer
, &sz
);
446 reverse_memcpy (p
, buffer
, sz
);
453 /* Master function for unformatted writes. */
456 unformatted_write (st_parameter_dt
*dtp
, bt type
,
457 void *source
, int kind
,
458 size_t size
, size_t nelems
)
460 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
||
461 size
== 1 || type
== BT_CHARACTER
)
465 write_buf (dtp
, source
, size
);
473 /* Break up complex into its constituent reals. */
474 if (type
== BT_COMPLEX
)
482 /* By now, all complex variables have been split into their
483 constituent reals. For types with padding, we only need to
484 read kind bytes. We don't care about the contents
488 for (i
=0; i
<nelems
; i
++)
490 reverse_memcpy(buffer
, p
, size
);
492 write_buf (dtp
, buffer
, sz
);
498 /* Return a pointer to the name of a type. */
523 internal_error (NULL
, "type_name(): Bad type");
530 /* Write a constant string to the output.
531 This is complicated because the string can have doubled delimiters
532 in it. The length in the format node is the true length. */
535 write_constant_string (st_parameter_dt
*dtp
, const fnode
*f
)
537 char c
, delimiter
, *p
, *q
;
540 length
= f
->u
.string
.length
;
544 p
= write_block (dtp
, length
);
551 for (; length
> 0; length
--)
554 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
555 q
++; /* Skip the doubled delimiter. */
560 /* Given actual and expected types in a formatted data transfer, make
561 sure they agree. If not, an error message is generated. Returns
562 nonzero if something went wrong. */
565 require_type (st_parameter_dt
*dtp
, bt expected
, bt actual
, const fnode
*f
)
569 if (actual
== expected
)
572 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
573 type_name (expected
), dtp
->u
.p
.item_count
, type_name (actual
));
575 format_error (dtp
, f
, buffer
);
580 /* This subroutine is the main loop for a formatted data transfer
581 statement. It would be natural to implement this as a coroutine
582 with the user program, but C makes that awkward. We loop,
583 processesing format elements. When we actually have to transfer
584 data instead of just setting flags, we return control to the user
585 program which calls a subroutine that supplies the address and type
586 of the next element, then comes back here to process it. */
589 formatted_transfer_scalar (st_parameter_dt
*dtp
, bt type
, void *p
, int len
,
592 char scratch
[SCRATCH_SIZE
];
597 int consume_data_flag
;
599 /* Change a complex data item into a pair of reals. */
601 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
602 if (type
== BT_COMPLEX
)
608 /* If there's an EOR condition, we simulate finalizing the transfer
610 if (dtp
->u
.p
.eor_condition
)
613 /* Set this flag so that commas in reads cause the read to complete before
614 the entire field has been read. The next read field will start right after
615 the comma in the stream. (Set to 0 for character reads). */
616 dtp
->u
.p
.sf_read_comma
= 1;
618 dtp
->u
.p
.line_buffer
= scratch
;
621 /* If reversion has occurred and there is another real data item,
622 then we have to move to the next record. */
623 if (dtp
->u
.p
.reversion_flag
&& n
> 0)
625 dtp
->u
.p
.reversion_flag
= 0;
626 next_record (dtp
, 0);
629 consume_data_flag
= 1 ;
630 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
633 f
= next_format (dtp
);
635 return; /* No data descriptors left (already raised). */
637 /* Now discharge T, TR and X movements to the right. This is delayed
638 until a data producing format to suppress trailing spaces. */
641 if (dtp
->u
.p
.mode
== WRITING
&& dtp
->u
.p
.skips
!= 0
642 && ((n
>0 && ( t
== FMT_I
|| t
== FMT_B
|| t
== FMT_O
643 || t
== FMT_Z
|| t
== FMT_F
|| t
== FMT_E
644 || t
== FMT_EN
|| t
== FMT_ES
|| t
== FMT_G
645 || t
== FMT_L
|| t
== FMT_A
|| t
== FMT_D
))
648 if (dtp
->u
.p
.skips
> 0)
650 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
651 dtp
->u
.p
.max_pos
= (int)(dtp
->u
.p
.current_unit
->recl
652 - dtp
->u
.p
.current_unit
->bytes_left
);
654 if (dtp
->u
.p
.skips
< 0)
656 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
657 dtp
->u
.p
.current_unit
->bytes_left
-= (gfc_offset
) dtp
->u
.p
.skips
;
659 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
662 bytes_used
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
669 if (require_type (dtp
, BT_INTEGER
, type
, f
))
672 if (dtp
->u
.p
.mode
== READING
)
673 read_decimal (dtp
, f
, p
, len
);
675 write_i (dtp
, f
, p
, len
);
682 if (require_type (dtp
, BT_INTEGER
, type
, f
))
685 if (dtp
->u
.p
.mode
== READING
)
686 read_radix (dtp
, f
, p
, len
, 2);
688 write_b (dtp
, f
, p
, len
);
696 if (dtp
->u
.p
.mode
== READING
)
697 read_radix (dtp
, f
, p
, len
, 8);
699 write_o (dtp
, f
, p
, len
);
707 if (dtp
->u
.p
.mode
== READING
)
708 read_radix (dtp
, f
, p
, len
, 16);
710 write_z (dtp
, f
, p
, len
);
718 if (dtp
->u
.p
.mode
== READING
)
719 read_a (dtp
, f
, p
, len
);
721 write_a (dtp
, f
, p
, len
);
729 if (dtp
->u
.p
.mode
== READING
)
730 read_l (dtp
, f
, p
, len
);
732 write_l (dtp
, f
, p
, len
);
739 if (require_type (dtp
, BT_REAL
, type
, f
))
742 if (dtp
->u
.p
.mode
== READING
)
743 read_f (dtp
, f
, p
, len
);
745 write_d (dtp
, f
, p
, len
);
752 if (require_type (dtp
, BT_REAL
, type
, f
))
755 if (dtp
->u
.p
.mode
== READING
)
756 read_f (dtp
, f
, p
, len
);
758 write_e (dtp
, f
, p
, len
);
764 if (require_type (dtp
, BT_REAL
, type
, f
))
767 if (dtp
->u
.p
.mode
== READING
)
768 read_f (dtp
, f
, p
, len
);
770 write_en (dtp
, f
, p
, len
);
777 if (require_type (dtp
, BT_REAL
, type
, f
))
780 if (dtp
->u
.p
.mode
== READING
)
781 read_f (dtp
, f
, p
, len
);
783 write_es (dtp
, f
, p
, len
);
790 if (require_type (dtp
, BT_REAL
, type
, f
))
793 if (dtp
->u
.p
.mode
== READING
)
794 read_f (dtp
, f
, p
, len
);
796 write_f (dtp
, f
, p
, len
);
803 if (dtp
->u
.p
.mode
== READING
)
807 read_decimal (dtp
, f
, p
, len
);
810 read_l (dtp
, f
, p
, len
);
813 read_a (dtp
, f
, p
, len
);
816 read_f (dtp
, f
, p
, len
);
825 write_i (dtp
, f
, p
, len
);
828 write_l (dtp
, f
, p
, len
);
831 write_a (dtp
, f
, p
, len
);
834 write_d (dtp
, f
, p
, len
);
838 internal_error (&dtp
->common
,
839 "formatted_transfer(): Bad type");
845 consume_data_flag
= 0 ;
846 if (dtp
->u
.p
.mode
== READING
)
848 format_error (dtp
, f
, "Constant string in input format");
851 write_constant_string (dtp
, f
);
854 /* Format codes that don't transfer data. */
857 consume_data_flag
= 0 ;
859 pos
= bytes_used
+ f
->u
.n
+ dtp
->u
.p
.skips
;
860 dtp
->u
.p
.skips
= f
->u
.n
+ dtp
->u
.p
.skips
;
861 dtp
->u
.p
.pending_spaces
= pos
- dtp
->u
.p
.max_pos
;
863 /* Writes occur just before the switch on f->format, above, so
864 that trailing blanks are suppressed, unless we are doing a
865 non-advancing write in which case we want to output the blanks
867 if (dtp
->u
.p
.mode
== WRITING
868 && dtp
->u
.p
.advance_status
== ADVANCE_NO
)
870 write_x (dtp
, dtp
->u
.p
.skips
, dtp
->u
.p
.pending_spaces
);
871 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
873 if (dtp
->u
.p
.mode
== READING
)
874 read_x (dtp
, f
->u
.n
);
880 if (f
->format
== FMT_TL
)
883 /* Handle the special case when no bytes have been used yet.
884 Cannot go below zero. */
887 dtp
->u
.p
.pending_spaces
-= f
->u
.n
;
888 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
< 0 ? 0
889 : dtp
->u
.p
.pending_spaces
;
890 dtp
->u
.p
.skips
-= f
->u
.n
;
891 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
< 0 ? 0 : dtp
->u
.p
.skips
;
894 pos
= bytes_used
- f
->u
.n
;
898 consume_data_flag
= 0;
902 /* Standard 10.6.1.1: excessive left tabbing is reset to the
903 left tab limit. We do not check if the position has gone
904 beyond the end of record because a subsequent tab could
905 bring us back again. */
906 pos
= pos
< 0 ? 0 : pos
;
908 dtp
->u
.p
.skips
= dtp
->u
.p
.skips
+ pos
- bytes_used
;
909 dtp
->u
.p
.pending_spaces
= dtp
->u
.p
.pending_spaces
910 + pos
- dtp
->u
.p
.max_pos
;
912 if (dtp
->u
.p
.skips
== 0)
915 /* Writes occur just before the switch on f->format, above, so that
916 trailing blanks are suppressed. */
917 if (dtp
->u
.p
.mode
== READING
)
919 /* Adjust everything for end-of-record condition */
920 if (dtp
->u
.p
.sf_seen_eor
&& !is_internal_unit (dtp
))
922 if (dtp
->u
.p
.sf_seen_eor
== 2)
924 /* The EOR was a CRLF (two bytes wide). */
925 dtp
->u
.p
.current_unit
->bytes_left
-= 2;
930 /* The EOR marker was only one byte wide. */
931 dtp
->u
.p
.current_unit
->bytes_left
--;
935 dtp
->u
.p
.sf_seen_eor
= 0;
937 if (dtp
->u
.p
.skips
< 0)
939 move_pos_offset (dtp
->u
.p
.current_unit
->s
, dtp
->u
.p
.skips
);
940 dtp
->u
.p
.current_unit
->bytes_left
941 -= (gfc_offset
) dtp
->u
.p
.skips
;
942 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
945 read_x (dtp
, dtp
->u
.p
.skips
);
951 consume_data_flag
= 0 ;
952 dtp
->u
.p
.sign_status
= SIGN_S
;
956 consume_data_flag
= 0 ;
957 dtp
->u
.p
.sign_status
= SIGN_SS
;
961 consume_data_flag
= 0 ;
962 dtp
->u
.p
.sign_status
= SIGN_SP
;
966 consume_data_flag
= 0 ;
967 dtp
->u
.p
.blank_status
= BLANK_NULL
;
971 consume_data_flag
= 0 ;
972 dtp
->u
.p
.blank_status
= BLANK_ZERO
;
976 consume_data_flag
= 0 ;
977 dtp
->u
.p
.scale_factor
= f
->u
.k
;
981 consume_data_flag
= 0 ;
982 dtp
->u
.p
.seen_dollar
= 1;
986 consume_data_flag
= 0 ;
987 dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
988 next_record (dtp
, 0);
992 /* A colon descriptor causes us to exit this loop (in
993 particular preventing another / descriptor from being
994 processed) unless there is another data item to be
996 consume_data_flag
= 0 ;
1002 internal_error (&dtp
->common
, "Bad format node");
1005 /* Free a buffer that we had to allocate during a sequential
1006 formatted read of a block that was larger than the static
1009 if (dtp
->u
.p
.line_buffer
!= scratch
)
1011 free_mem (dtp
->u
.p
.line_buffer
);
1012 dtp
->u
.p
.line_buffer
= scratch
;
1015 /* Adjust the item count and data pointer. */
1017 if ((consume_data_flag
> 0) && (n
> 0))
1020 p
= ((char *) p
) + size
;
1023 if (dtp
->u
.p
.mode
== READING
)
1026 pos
= (int)(dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
);
1027 dtp
->u
.p
.max_pos
= (dtp
->u
.p
.max_pos
> pos
) ? dtp
->u
.p
.max_pos
: pos
;
1033 /* Come here when we need a data descriptor but don't have one. We
1034 push the current format node back onto the input, then return and
1035 let the user program call us back with the data. */
1037 unget_format (dtp
, f
);
1041 formatted_transfer (st_parameter_dt
*dtp
, bt type
, void *p
, int kind
,
1042 size_t size
, size_t nelems
)
1049 /* Big loop over all the elements. */
1050 for (elem
= 0; elem
< nelems
; elem
++)
1052 dtp
->u
.p
.item_count
++;
1053 formatted_transfer_scalar (dtp
, type
, tmp
+ size
*elem
, kind
, size
);
1059 /* Data transfer entry points. The type of the data entity is
1060 implicit in the subroutine call. This prevents us from having to
1061 share a common enum with the compiler. */
1064 transfer_integer (st_parameter_dt
*dtp
, void *p
, int kind
)
1066 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1068 dtp
->u
.p
.transfer (dtp
, BT_INTEGER
, p
, kind
, kind
, 1);
1073 transfer_real (st_parameter_dt
*dtp
, void *p
, int kind
)
1076 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1078 size
= size_from_real_kind (kind
);
1079 dtp
->u
.p
.transfer (dtp
, BT_REAL
, p
, kind
, size
, 1);
1084 transfer_logical (st_parameter_dt
*dtp
, void *p
, int kind
)
1086 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1088 dtp
->u
.p
.transfer (dtp
, BT_LOGICAL
, p
, kind
, kind
, 1);
1093 transfer_character (st_parameter_dt
*dtp
, void *p
, int len
)
1095 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1097 /* Currently we support only 1 byte chars, and the library is a bit
1098 confused of character kind vs. length, so we kludge it by setting
1100 dtp
->u
.p
.transfer (dtp
, BT_CHARACTER
, p
, len
, len
, 1);
1105 transfer_complex (st_parameter_dt
*dtp
, void *p
, int kind
)
1108 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1110 size
= size_from_complex_kind (kind
);
1111 dtp
->u
.p
.transfer (dtp
, BT_COMPLEX
, p
, kind
, size
, 1);
1116 transfer_array (st_parameter_dt
*dtp
, gfc_array_char
*desc
, int kind
,
1117 gfc_charlen_type charlen
)
1119 index_type count
[GFC_MAX_DIMENSIONS
];
1120 index_type extent
[GFC_MAX_DIMENSIONS
];
1121 index_type stride
[GFC_MAX_DIMENSIONS
];
1122 index_type stride0
, rank
, size
, type
, n
;
1127 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1130 type
= GFC_DESCRIPTOR_TYPE (desc
);
1131 size
= GFC_DESCRIPTOR_SIZE (desc
);
1133 /* FIXME: What a kludge: Array descriptors and the IO library use
1134 different enums for types. */
1137 case GFC_DTYPE_UNKNOWN
:
1138 iotype
= BT_NULL
; /* Is this correct? */
1140 case GFC_DTYPE_INTEGER
:
1141 iotype
= BT_INTEGER
;
1143 case GFC_DTYPE_LOGICAL
:
1144 iotype
= BT_LOGICAL
;
1146 case GFC_DTYPE_REAL
:
1149 case GFC_DTYPE_COMPLEX
:
1150 iotype
= BT_COMPLEX
;
1152 case GFC_DTYPE_CHARACTER
:
1153 iotype
= BT_CHARACTER
;
1154 /* FIXME: Currently dtype contains the charlen, which is
1155 clobbered if charlen > 2**24. That's why we use a separate
1156 argument for the charlen. However, if we want to support
1157 non-8-bit charsets we need to fix dtype to contain
1158 sizeof(chartype) and fix the code below. */
1162 case GFC_DTYPE_DERIVED
:
1163 internal_error (&dtp
->common
,
1164 "Derived type I/O should have been handled via the frontend.");
1167 internal_error (&dtp
->common
, "transfer_array(): Bad type");
1170 if (desc
->dim
[0].stride
== 0)
1171 desc
->dim
[0].stride
= 1;
1173 rank
= GFC_DESCRIPTOR_RANK (desc
);
1174 for (n
= 0; n
< rank
; n
++)
1177 stride
[n
] = desc
->dim
[n
].stride
;
1178 extent
[n
] = desc
->dim
[n
].ubound
+ 1 - desc
->dim
[n
].lbound
;
1180 /* If the extent of even one dimension is zero, then the entire
1181 array section contains zero elements, so we return. */
1186 stride0
= stride
[0];
1188 /* If the innermost dimension has stride 1, we can do the transfer
1189 in contiguous chunks. */
1195 data
= GFC_DESCRIPTOR_DATA (desc
);
1199 dtp
->u
.p
.transfer (dtp
, iotype
, data
, kind
, size
, tsize
);
1200 data
+= stride0
* size
* tsize
;
1203 while (count
[n
] == extent
[n
])
1206 data
-= stride
[n
] * extent
[n
] * size
;
1216 data
+= stride
[n
] * size
;
1223 /* Preposition a sequential unformatted file while reading. */
1226 us_read (st_parameter_dt
*dtp
)
1232 if (dtp
->u
.p
.current_unit
->endfile
== AT_ENDFILE
)
1235 n
= sizeof (gfc_offset
);
1236 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &n
);
1240 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1241 return; /* end of file */
1244 if (p
== NULL
|| n
!= sizeof (gfc_offset
))
1246 generate_error (&dtp
->common
, ERROR_BAD_US
, NULL
);
1250 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1251 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1252 memcpy (&i
, p
, sizeof (gfc_offset
));
1254 reverse_memcpy (&i
, p
, sizeof (gfc_offset
));
1256 dtp
->u
.p
.current_unit
->bytes_left
= i
;
1260 /* Preposition a sequential unformatted file while writing. This
1261 amount to writing a bogus length that will be filled in later. */
1264 us_write (st_parameter_dt
*dtp
)
1270 nbytes
= sizeof (gfc_offset
);
1272 if (swrite (dtp
->u
.p
.current_unit
->s
, &dummy
, &nbytes
) != 0)
1273 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1275 /* For sequential unformatted, we write until we have more bytes
1276 than can fit in the record markers. If disk space runs out first,
1277 it will error on the write. */
1278 dtp
->u
.p
.current_unit
->recl
= max_offset
;
1280 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1284 /* Position to the next record prior to transfer. We are assumed to
1285 be before the next record. We also calculate the bytes in the next
1289 pre_position (st_parameter_dt
*dtp
)
1291 if (dtp
->u
.p
.current_unit
->current_record
)
1292 return; /* Already positioned. */
1294 switch (current_mode (dtp
))
1296 case UNFORMATTED_SEQUENTIAL
:
1297 if (dtp
->u
.p
.mode
== READING
)
1304 case FORMATTED_SEQUENTIAL
:
1305 case FORMATTED_DIRECT
:
1306 case UNFORMATTED_DIRECT
:
1307 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1311 dtp
->u
.p
.current_unit
->current_record
= 1;
1315 /* Initialize things for a data transfer. This code is common for
1316 both reading and writing. */
1319 data_transfer_init (st_parameter_dt
*dtp
, int read_flag
)
1321 unit_flags u_flags
; /* Used for creating a unit if needed. */
1322 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1323 namelist_info
*ionml
;
1325 ionml
= ((cf
& IOPARM_DT_IONML_SET
) != 0) ? dtp
->u
.p
.ionml
: NULL
;
1326 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
1327 dtp
->u
.p
.ionml
= ionml
;
1328 dtp
->u
.p
.mode
= read_flag
? READING
: WRITING
;
1330 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1331 *dtp
->size
= 0; /* Initialize the count. */
1333 dtp
->u
.p
.current_unit
= get_unit (dtp
, 1);
1334 if (dtp
->u
.p
.current_unit
->s
== NULL
)
1335 { /* Open the unit with some default flags. */
1336 st_parameter_open opp
;
1337 if (dtp
->common
.unit
< 0)
1339 close_unit (dtp
->u
.p
.current_unit
);
1340 dtp
->u
.p
.current_unit
= NULL
;
1341 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1342 "Bad unit number in OPEN statement");
1345 memset (&u_flags
, '\0', sizeof (u_flags
));
1346 u_flags
.access
= ACCESS_SEQUENTIAL
;
1347 u_flags
.action
= ACTION_READWRITE
;
1349 /* Is it unformatted? */
1350 if (!(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
1351 | IOPARM_DT_IONML_SET
)))
1352 u_flags
.form
= FORM_UNFORMATTED
;
1354 u_flags
.form
= FORM_UNSPECIFIED
;
1356 u_flags
.delim
= DELIM_UNSPECIFIED
;
1357 u_flags
.blank
= BLANK_UNSPECIFIED
;
1358 u_flags
.pad
= PAD_UNSPECIFIED
;
1359 u_flags
.status
= STATUS_UNKNOWN
;
1360 opp
.common
= dtp
->common
;
1361 opp
.common
.flags
&= IOPARM_COMMON_MASK
;
1362 dtp
->u
.p
.current_unit
= new_unit (&opp
, dtp
->u
.p
.current_unit
, &u_flags
);
1363 dtp
->common
.flags
&= ~IOPARM_COMMON_MASK
;
1364 dtp
->common
.flags
|= (opp
.common
.flags
& IOPARM_COMMON_MASK
);
1365 if (dtp
->u
.p
.current_unit
== NULL
)
1369 /* Check the action. */
1371 if (read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_WRITE
)
1372 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1373 "Cannot read from file opened for WRITE");
1375 if (!read_flag
&& dtp
->u
.p
.current_unit
->flags
.action
== ACTION_READ
)
1376 generate_error (&dtp
->common
, ERROR_BAD_ACTION
,
1377 "Cannot write to file opened for READ");
1379 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1382 dtp
->u
.p
.first_item
= 1;
1384 /* Check the format. */
1386 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1389 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1392 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
1393 && (cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1395 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1396 "Format present for UNFORMATTED data transfer");
1398 if ((cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0 && dtp
->u
.p
.ionml
!= NULL
)
1400 if ((cf
& IOPARM_DT_HAS_FORMAT
) != 0)
1401 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1402 "A format cannot be specified with a namelist");
1404 else if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
&&
1405 !(cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
)))
1406 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1407 "Missing format for FORMATTED data transfer");
1410 if (is_internal_unit (dtp
)
1411 && dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1412 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1413 "Internal file cannot be accessed by UNFORMATTED data transfer");
1415 /* Check the record number. */
1417 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
1418 && (cf
& IOPARM_DT_HAS_REC
) == 0)
1420 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1421 "Direct access data transfer requires record number");
1425 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1426 && (cf
& IOPARM_DT_HAS_REC
) != 0)
1428 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1429 "Record number not allowed for sequential access data transfer");
1433 /* Process the ADVANCE option. */
1435 dtp
->u
.p
.advance_status
1436 = !(cf
& IOPARM_DT_HAS_ADVANCE
) ? ADVANCE_UNSPECIFIED
:
1437 find_option (&dtp
->common
, dtp
->advance
, dtp
->advance_len
, advance_opt
,
1438 "Bad ADVANCE parameter in data transfer statement");
1440 if (dtp
->u
.p
.advance_status
!= ADVANCE_UNSPECIFIED
)
1442 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1443 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1444 "ADVANCE specification conflicts with sequential access");
1446 if (is_internal_unit (dtp
))
1447 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1448 "ADVANCE specification conflicts with internal file");
1450 if ((cf
& (IOPARM_DT_HAS_FORMAT
| IOPARM_DT_LIST_FORMAT
))
1451 != IOPARM_DT_HAS_FORMAT
)
1452 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1453 "ADVANCE specification requires an explicit format");
1458 if ((cf
& IOPARM_EOR
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1459 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1460 "EOR specification requires an ADVANCE specification of NO");
1462 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0 && dtp
->u
.p
.advance_status
!= ADVANCE_NO
)
1463 generate_error (&dtp
->common
, ERROR_MISSING_OPTION
,
1464 "SIZE specification requires an ADVANCE specification of NO");
1468 { /* Write constraints. */
1469 if ((cf
& IOPARM_END
) != 0)
1470 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1471 "END specification cannot appear in a write statement");
1473 if ((cf
& IOPARM_EOR
) != 0)
1474 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1475 "EOR specification cannot appear in a write statement");
1477 if ((cf
& IOPARM_DT_HAS_SIZE
) != 0)
1478 generate_error (&dtp
->common
, ERROR_OPTION_CONFLICT
,
1479 "SIZE specification cannot appear in a write statement");
1482 if (dtp
->u
.p
.advance_status
== ADVANCE_UNSPECIFIED
)
1483 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
1484 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
1487 /* Sanity checks on the record number. */
1489 if ((cf
& IOPARM_DT_HAS_REC
) != 0)
1493 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1494 "Record number must be positive");
1498 if (dtp
->rec
>= dtp
->u
.p
.current_unit
->maxrec
)
1500 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1501 "Record number too large");
1505 /* Check to see if we might be reading what we wrote before */
1507 if (dtp
->u
.p
.mode
== READING
&& dtp
->u
.p
.current_unit
->mode
== WRITING
)
1508 flush(dtp
->u
.p
.current_unit
->s
);
1510 /* Check whether the record exists to be read. Only
1511 a partial record needs to exist. */
1513 if (dtp
->u
.p
.mode
== READING
&& (dtp
->rec
-1)
1514 * dtp
->u
.p
.current_unit
->recl
>= file_length (dtp
->u
.p
.current_unit
->s
))
1516 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1517 "Non-existing record number");
1521 /* Position the file. */
1522 if (sseek (dtp
->u
.p
.current_unit
->s
,
1523 (dtp
->rec
- 1) * dtp
->u
.p
.current_unit
->recl
) == FAILURE
)
1525 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1530 /* Overwriting an existing sequential file ?
1531 it is always safe to truncate the file on the first write */
1532 if (dtp
->u
.p
.mode
== WRITING
1533 && dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1534 && dtp
->u
.p
.current_unit
->last_record
== 0 && !is_preconnected(dtp
->u
.p
.current_unit
->s
))
1535 struncate(dtp
->u
.p
.current_unit
->s
);
1537 /* Bugware for badly written mixed C-Fortran I/O. */
1538 flush_if_preconnected(dtp
->u
.p
.current_unit
->s
);
1540 dtp
->u
.p
.current_unit
->mode
= dtp
->u
.p
.mode
;
1542 /* Set the initial value of flags. */
1544 dtp
->u
.p
.blank_status
= dtp
->u
.p
.current_unit
->flags
.blank
;
1545 dtp
->u
.p
.sign_status
= SIGN_S
;
1549 /* Set up the subroutine that will handle the transfers. */
1553 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1554 dtp
->u
.p
.transfer
= unformatted_read
;
1557 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1558 dtp
->u
.p
.transfer
= list_formatted_read
;
1560 dtp
->u
.p
.transfer
= formatted_transfer
;
1565 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_UNFORMATTED
)
1566 dtp
->u
.p
.transfer
= unformatted_write
;
1569 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0)
1570 dtp
->u
.p
.transfer
= list_formatted_write
;
1572 dtp
->u
.p
.transfer
= formatted_transfer
;
1576 /* Make sure that we don't do a read after a nonadvancing write. */
1580 if (dtp
->u
.p
.current_unit
->read_bad
)
1582 generate_error (&dtp
->common
, ERROR_BAD_OPTION
,
1583 "Cannot READ after a nonadvancing WRITE");
1589 if (dtp
->u
.p
.advance_status
== ADVANCE_YES
&& !dtp
->u
.p
.seen_dollar
)
1590 dtp
->u
.p
.current_unit
->read_bad
= 1;
1593 /* Start the data transfer if we are doing a formatted transfer. */
1594 if (dtp
->u
.p
.current_unit
->flags
.form
== FORM_FORMATTED
1595 && ((cf
& (IOPARM_DT_LIST_FORMAT
| IOPARM_DT_HAS_NAMELIST_NAME
)) == 0)
1596 && dtp
->u
.p
.ionml
== NULL
)
1597 formatted_transfer (dtp
, 0, NULL
, 0, 0, 1);
1600 /* Initialize an array_loop_spec given the array descriptor. The function
1601 returns the index of the last element of the array. */
1604 init_loop_spec (gfc_array_char
*desc
, array_loop_spec
*ls
)
1606 int rank
= GFC_DESCRIPTOR_RANK(desc
);
1611 for (i
=0; i
<rank
; i
++)
1614 ls
[i
].start
= desc
->dim
[i
].lbound
;
1615 ls
[i
].end
= desc
->dim
[i
].ubound
;
1616 ls
[i
].step
= desc
->dim
[i
].stride
;
1618 index
+= (desc
->dim
[i
].ubound
- desc
->dim
[i
].lbound
)
1619 * desc
->dim
[i
].stride
;
1624 /* Determine the index to the next record in an internal unit array by
1625 by incrementing through the array_loop_spec. TODO: Implement handling
1626 negative strides. */
1629 next_array_record (st_parameter_dt
*dtp
, array_loop_spec
*ls
)
1637 for (i
= 0; i
< dtp
->u
.p
.current_unit
->rank
; i
++)
1642 if (ls
[i
].idx
> ls
[i
].end
)
1644 ls
[i
].idx
= ls
[i
].start
;
1650 index
= index
+ (ls
[i
].idx
- 1) * ls
[i
].step
;
1655 /* Space to the next record for read mode. If the file is not
1656 seekable, we read MAX_READ chunks until we get to the right
1659 #define MAX_READ 4096
1662 next_record_r (st_parameter_dt
*dtp
)
1664 gfc_offset
new, record
;
1665 int bytes_left
, rlength
, length
;
1668 switch (current_mode (dtp
))
1670 case UNFORMATTED_SEQUENTIAL
:
1672 /* Skip over tail */
1673 dtp
->u
.p
.current_unit
->bytes_left
+= sizeof (gfc_offset
);
1675 /* Fall through... */
1677 case FORMATTED_DIRECT
:
1678 case UNFORMATTED_DIRECT
:
1679 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1682 if (is_seekable (dtp
->u
.p
.current_unit
->s
))
1684 new = file_position (dtp
->u
.p
.current_unit
->s
)
1685 + dtp
->u
.p
.current_unit
->bytes_left
;
1687 /* Direct access files do not generate END conditions,
1689 if (sseek (dtp
->u
.p
.current_unit
->s
, new) == FAILURE
)
1690 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1694 { /* Seek by reading data. */
1695 while (dtp
->u
.p
.current_unit
->bytes_left
> 0)
1697 rlength
= length
= (MAX_READ
> dtp
->u
.p
.current_unit
->bytes_left
) ?
1698 MAX_READ
: dtp
->u
.p
.current_unit
->bytes_left
;
1700 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &rlength
);
1703 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1707 dtp
->u
.p
.current_unit
->bytes_left
-= length
;
1712 case FORMATTED_SEQUENTIAL
:
1714 /* sf_read has already terminated input because of an '\n' */
1715 if (dtp
->u
.p
.sf_seen_eor
)
1717 dtp
->u
.p
.sf_seen_eor
= 0;
1721 if (is_internal_unit (dtp
))
1723 if (is_array_io (dtp
))
1725 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1727 /* Now seek to this record. */
1728 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1729 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1731 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
1734 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1738 bytes_left
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1739 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &bytes_left
);
1741 dtp
->u
.p
.current_unit
->bytes_left
1742 = dtp
->u
.p
.current_unit
->recl
;
1748 p
= salloc_r (dtp
->u
.p
.current_unit
->s
, &length
);
1752 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1758 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
1767 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1768 test_endfile (dtp
->u
.p
.current_unit
);
1772 /* Small utility function to write a record marker, taking care of
1776 write_us_marker (st_parameter_dt
*dtp
, const gfc_offset buf
)
1778 size_t len
= sizeof (gfc_offset
);
1779 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1780 if (dtp
->u
.p
.current_unit
->flags
.convert
== CONVERT_NATIVE
)
1781 return swrite (dtp
->u
.p
.current_unit
->s
, &buf
, &len
);
1784 reverse_memcpy (&p
, &buf
, sizeof (gfc_offset
));
1785 return swrite (dtp
->u
.p
.current_unit
->s
, &p
, &len
);
1790 /* Position to the next record in write mode. */
1793 next_record_w (st_parameter_dt
*dtp
, int done
)
1795 gfc_offset c
, m
, record
, max_pos
;
1799 /* Zero counters for X- and T-editing. */
1800 max_pos
= dtp
->u
.p
.max_pos
;
1801 dtp
->u
.p
.max_pos
= dtp
->u
.p
.skips
= dtp
->u
.p
.pending_spaces
= 0;
1803 switch (current_mode (dtp
))
1805 case FORMATTED_DIRECT
:
1806 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1809 if (sset (dtp
->u
.p
.current_unit
->s
, ' ',
1810 dtp
->u
.p
.current_unit
->bytes_left
) == FAILURE
)
1815 case UNFORMATTED_DIRECT
:
1816 if (sfree (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
1820 case UNFORMATTED_SEQUENTIAL
:
1821 /* Bytes written. */
1822 m
= dtp
->u
.p
.current_unit
->recl
- dtp
->u
.p
.current_unit
->bytes_left
;
1823 c
= file_position (dtp
->u
.p
.current_unit
->s
);
1825 /* Write the length tail. */
1827 if (write_us_marker (dtp
, m
) != 0)
1830 /* Seek to the head and overwrite the bogus length with the real
1833 if (sseek (dtp
->u
.p
.current_unit
->s
, c
- m
- sizeof (gfc_offset
))
1837 if (write_us_marker (dtp
, m
) != 0)
1840 /* Seek past the end of the current record. */
1842 if (sseek (dtp
->u
.p
.current_unit
->s
, c
+ sizeof (gfc_offset
)) == FAILURE
)
1847 case FORMATTED_SEQUENTIAL
:
1849 if (dtp
->u
.p
.current_unit
->bytes_left
== 0)
1852 if (is_internal_unit (dtp
))
1854 if (is_array_io (dtp
))
1856 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1858 /* If the farthest position reached is greater than current
1859 position, adjust the position and set length to pad out
1860 whats left. Otherwise just pad whats left.
1861 (for character array unit) */
1862 m
= dtp
->u
.p
.current_unit
->recl
1863 - dtp
->u
.p
.current_unit
->bytes_left
;
1866 length
= (int) (max_pos
- m
);
1867 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1868 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
1871 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
1873 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1877 /* Now that the current record has been padded out,
1878 determine where the next record in the array is. */
1879 record
= next_array_record (dtp
, dtp
->u
.p
.current_unit
->ls
);
1881 /* Now seek to this record */
1882 record
= record
* dtp
->u
.p
.current_unit
->recl
;
1884 if (sseek (dtp
->u
.p
.current_unit
->s
, record
) == FAILURE
)
1886 generate_error (&dtp
->common
, ERROR_INTERNAL_UNIT
, NULL
);
1890 dtp
->u
.p
.current_unit
->bytes_left
= dtp
->u
.p
.current_unit
->recl
;
1896 /* If this is the last call to next_record move to the farthest
1897 position reached and set length to pad out the remainder
1898 of the record. (for character scaler unit) */
1901 m
= dtp
->u
.p
.current_unit
->recl
1902 - dtp
->u
.p
.current_unit
->bytes_left
;
1905 length
= (int) (max_pos
- m
);
1906 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1907 length
= (int) (dtp
->u
.p
.current_unit
->recl
- max_pos
);
1910 length
= (int) dtp
->u
.p
.current_unit
->bytes_left
;
1912 if (sset (dtp
->u
.p
.current_unit
->s
, ' ', length
) == FAILURE
)
1914 generate_error (&dtp
->common
, ERROR_END
, NULL
);
1921 /* If this is the last call to next_record move to the farthest
1922 position reached in preparation for completing the record.
1926 m
= dtp
->u
.p
.current_unit
->recl
-
1927 dtp
->u
.p
.current_unit
->bytes_left
;
1930 length
= (int) (max_pos
- m
);
1931 p
= salloc_w (dtp
->u
.p
.current_unit
->s
, &length
);
1935 const char crlf
[] = "\r\n";
1941 if (swrite (dtp
->u
.p
.current_unit
->s
, &crlf
[2-len
], &len
) != 0)
1948 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
1953 /* Position to the next record, which means moving to the end of the
1954 current record. This can happen under several different
1955 conditions. If the done flag is not set, we get ready to process
1959 next_record (st_parameter_dt
*dtp
, int done
)
1961 gfc_offset fp
; /* File position. */
1963 dtp
->u
.p
.current_unit
->read_bad
= 0;
1965 if (dtp
->u
.p
.mode
== READING
)
1966 next_record_r (dtp
);
1968 next_record_w (dtp
, done
);
1970 /* keep position up to date for INQUIRE */
1971 dtp
->u
.p
.current_unit
->flags
.position
= POSITION_ASIS
;
1973 dtp
->u
.p
.current_unit
->current_record
= 0;
1974 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_DIRECT
)
1976 fp
= file_position (dtp
->u
.p
.current_unit
->s
);
1977 /* Calculate next record, rounding up partial records. */
1978 dtp
->u
.p
.current_unit
->last_record
= (fp
+ dtp
->u
.p
.current_unit
->recl
- 1)
1979 / dtp
->u
.p
.current_unit
->recl
;
1982 dtp
->u
.p
.current_unit
->last_record
++;
1989 /* Finalize the current data transfer. For a nonadvancing transfer,
1990 this means advancing to the next record. For internal units close the
1991 stream associated with the unit. */
1994 finalize_transfer (st_parameter_dt
*dtp
)
1997 GFC_INTEGER_4 cf
= dtp
->common
.flags
;
1999 if (dtp
->u
.p
.eor_condition
)
2001 generate_error (&dtp
->common
, ERROR_EOR
, NULL
);
2005 if ((dtp
->common
.flags
& IOPARM_LIBRETURN_MASK
) != IOPARM_LIBRETURN_OK
)
2008 if ((dtp
->u
.p
.ionml
!= NULL
)
2009 && (cf
& IOPARM_DT_HAS_NAMELIST_NAME
) != 0)
2011 if ((cf
& IOPARM_DT_NAMELIST_READ_MODE
) != 0)
2012 namelist_read (dtp
);
2014 namelist_write (dtp
);
2017 dtp
->u
.p
.transfer
= NULL
;
2018 if (dtp
->u
.p
.current_unit
== NULL
)
2021 dtp
->u
.p
.eof_jump
= &eof_jump
;
2022 if (setjmp (eof_jump
))
2024 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2028 if ((cf
& IOPARM_DT_LIST_FORMAT
) != 0 && dtp
->u
.p
.mode
== READING
)
2029 finish_list_read (dtp
);
2032 dtp
->u
.p
.current_unit
->current_record
= 0;
2033 if (dtp
->u
.p
.advance_status
== ADVANCE_NO
|| dtp
->u
.p
.seen_dollar
)
2035 /* Most systems buffer lines, so force the partial record
2036 to be written out. */
2037 flush (dtp
->u
.p
.current_unit
->s
);
2038 dtp
->u
.p
.seen_dollar
= 0;
2042 next_record (dtp
, 1);
2045 sfree (dtp
->u
.p
.current_unit
->s
);
2047 if (is_internal_unit (dtp
))
2049 if (is_array_io (dtp
) && dtp
->u
.p
.current_unit
->ls
!= NULL
)
2050 free_mem (dtp
->u
.p
.current_unit
->ls
);
2051 sclose (dtp
->u
.p
.current_unit
->s
);
2056 /* Transfer function for IOLENGTH. It doesn't actually do any
2057 data transfer, it just updates the length counter. */
2060 iolength_transfer (st_parameter_dt
*dtp
, bt type
__attribute__((unused
)),
2061 void *dest
__attribute__ ((unused
)),
2062 int kind
__attribute__((unused
)),
2063 size_t size
, size_t nelems
)
2065 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2066 *dtp
->iolength
+= (GFC_INTEGER_4
) size
* nelems
;
2070 /* Initialize the IOLENGTH data transfer. This function is in essence
2071 a very much simplified version of data_transfer_init(), because it
2072 doesn't have to deal with units at all. */
2075 iolength_transfer_init (st_parameter_dt
*dtp
)
2077 if ((dtp
->common
.flags
& IOPARM_DT_HAS_IOLENGTH
) != 0)
2080 memset (&dtp
->u
.p
, 0, sizeof (dtp
->u
.p
));
2082 /* Set up the subroutine that will handle the transfers. */
2084 dtp
->u
.p
.transfer
= iolength_transfer
;
2088 /* Library entry point for the IOLENGTH form of the INQUIRE
2089 statement. The IOLENGTH form requires no I/O to be performed, but
2090 it must still be a runtime library call so that we can determine
2091 the iolength for dynamic arrays and such. */
2093 extern void st_iolength (st_parameter_dt
*);
2094 export_proto(st_iolength
);
2097 st_iolength (st_parameter_dt
*dtp
)
2099 library_start (&dtp
->common
);
2100 iolength_transfer_init (dtp
);
2103 extern void st_iolength_done (st_parameter_dt
*);
2104 export_proto(st_iolength_done
);
2107 st_iolength_done (st_parameter_dt
*dtp
__attribute__((unused
)))
2110 if (dtp
->u
.p
.scratch
!= NULL
)
2111 free_mem (dtp
->u
.p
.scratch
);
2116 /* The READ statement. */
2118 extern void st_read (st_parameter_dt
*);
2119 export_proto(st_read
);
2122 st_read (st_parameter_dt
*dtp
)
2125 library_start (&dtp
->common
);
2127 data_transfer_init (dtp
, 1);
2129 /* Handle complications dealing with the endfile record. It is
2130 significant that this is the only place where ERROR_END is
2131 generated. Reading an end of file elsewhere is either end of
2132 record or an I/O error. */
2134 if (dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2135 switch (dtp
->u
.p
.current_unit
->endfile
)
2141 if (!is_internal_unit (dtp
))
2143 generate_error (&dtp
->common
, ERROR_END
, NULL
);
2144 dtp
->u
.p
.current_unit
->endfile
= AFTER_ENDFILE
;
2145 dtp
->u
.p
.current_unit
->current_record
= 0;
2150 generate_error (&dtp
->common
, ERROR_ENDFILE
, NULL
);
2151 dtp
->u
.p
.current_unit
->current_record
= 0;
2156 extern void st_read_done (st_parameter_dt
*);
2157 export_proto(st_read_done
);
2160 st_read_done (st_parameter_dt
*dtp
)
2162 flush(dtp
->u
.p
.current_unit
->s
);
2163 finalize_transfer (dtp
);
2164 free_format_data (dtp
);
2166 if (dtp
->u
.p
.scratch
!= NULL
)
2167 free_mem (dtp
->u
.p
.scratch
);
2168 if (dtp
->u
.p
.current_unit
!= NULL
)
2169 unlock_unit (dtp
->u
.p
.current_unit
);
2173 extern void st_write (st_parameter_dt
*);
2174 export_proto(st_write
);
2177 st_write (st_parameter_dt
*dtp
)
2179 library_start (&dtp
->common
);
2180 data_transfer_init (dtp
, 0);
2183 extern void st_write_done (st_parameter_dt
*);
2184 export_proto(st_write_done
);
2187 st_write_done (st_parameter_dt
*dtp
)
2189 finalize_transfer (dtp
);
2191 /* Deal with endfile conditions associated with sequential files. */
2193 if (dtp
->u
.p
.current_unit
!= NULL
&& dtp
->u
.p
.current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
2194 switch (dtp
->u
.p
.current_unit
->endfile
)
2196 case AT_ENDFILE
: /* Remain at the endfile record. */
2200 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
2204 if (dtp
->u
.p
.current_unit
->current_record
> dtp
->u
.p
.current_unit
->last_record
)
2206 /* Get rid of whatever is after this record. */
2207 if (struncate (dtp
->u
.p
.current_unit
->s
) == FAILURE
)
2208 generate_error (&dtp
->common
, ERROR_OS
, NULL
);
2211 dtp
->u
.p
.current_unit
->endfile
= AT_ENDFILE
;
2215 free_format_data (dtp
);
2217 if (dtp
->u
.p
.scratch
!= NULL
)
2218 free_mem (dtp
->u
.p
.scratch
);
2219 if (dtp
->u
.p
.current_unit
!= NULL
)
2220 unlock_unit (dtp
->u
.p
.current_unit
);
2224 /* Receives the scalar information for namelist objects and stores it
2225 in a linked list of namelist_info types. */
2227 extern void st_set_nml_var (st_parameter_dt
*dtp
, void *, char *,
2228 GFC_INTEGER_4
, gfc_charlen_type
, GFC_INTEGER_4
);
2229 export_proto(st_set_nml_var
);
2233 st_set_nml_var (st_parameter_dt
*dtp
, void * var_addr
, char * var_name
,
2234 GFC_INTEGER_4 len
, gfc_charlen_type string_length
,
2235 GFC_INTEGER_4 dtype
)
2237 namelist_info
*t1
= NULL
;
2240 nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
2242 nml
->mem_pos
= var_addr
;
2244 nml
->var_name
= (char*) get_mem (strlen (var_name
) + 1);
2245 strcpy (nml
->var_name
, var_name
);
2247 nml
->len
= (int) len
;
2248 nml
->string_length
= (index_type
) string_length
;
2250 nml
->var_rank
= (int) (dtype
& GFC_DTYPE_RANK_MASK
);
2251 nml
->size
= (index_type
) (dtype
>> GFC_DTYPE_SIZE_SHIFT
);
2252 nml
->type
= (bt
) ((dtype
& GFC_DTYPE_TYPE_MASK
) >> GFC_DTYPE_TYPE_SHIFT
);
2254 if (nml
->var_rank
> 0)
2256 nml
->dim
= (descriptor_dimension
*)
2257 get_mem (nml
->var_rank
* sizeof (descriptor_dimension
));
2258 nml
->ls
= (array_loop_spec
*)
2259 get_mem (nml
->var_rank
* sizeof (array_loop_spec
));
2269 if ((dtp
->common
.flags
& IOPARM_DT_IONML_SET
) == 0)
2271 dtp
->common
.flags
|= IOPARM_DT_IONML_SET
;
2272 dtp
->u
.p
.ionml
= nml
;
2276 for (t1
= dtp
->u
.p
.ionml
; t1
->next
; t1
= t1
->next
);
2281 /* Store the dimensional information for the namelist object. */
2282 extern void st_set_nml_var_dim (st_parameter_dt
*, GFC_INTEGER_4
,
2283 GFC_INTEGER_4
, GFC_INTEGER_4
,
2285 export_proto(st_set_nml_var_dim
);
2288 st_set_nml_var_dim (st_parameter_dt
*dtp
, GFC_INTEGER_4 n_dim
,
2289 GFC_INTEGER_4 stride
, GFC_INTEGER_4 lbound
,
2290 GFC_INTEGER_4 ubound
)
2292 namelist_info
* nml
;
2297 for (nml
= dtp
->u
.p
.ionml
; nml
->next
; nml
= nml
->next
);
2299 nml
->dim
[n
].stride
= (ssize_t
)stride
;
2300 nml
->dim
[n
].lbound
= (ssize_t
)lbound
;
2301 nml
->dim
[n
].ubound
= (ssize_t
)ubound
;
2304 /* Reverse memcpy - used for byte swapping. */
2306 void reverse_memcpy (void *dest
, const void *src
, size_t n
)
2312 s
= (char *) src
+ n
- 1;
2314 /* Write with ascending order - this is likely faster
2315 on modern architectures because of write combining. */