1 /* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 59 Temple Place - Suite 330,
28 Boston, MA 02111-1307, USA. */
31 /* transfer.c -- Top level handling of data transfer statements. */
36 #include "libgfortran.h"
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
58 These subroutines do not return status.
60 The last call is a call to st_[read|write]_done(). While
61 something can easily go wrong with the initial st_read() or
62 st_write(), an error inhibits any data from actually being
65 extern void transfer_integer (void *, int);
66 export_proto(transfer_integer
);
68 extern void transfer_real (void *, int);
69 export_proto(transfer_real
);
71 extern void transfer_logical (void *, int);
72 export_proto(transfer_logical
);
74 extern void transfer_character (void *, int);
75 export_proto(transfer_character
);
77 extern void transfer_complex (void *, int);
78 export_proto(transfer_complex
);
80 gfc_unit
*current_unit
= NULL
;
81 static int sf_seen_eor
= 0;
82 static int eor_condition
= 0;
84 char scratch
[SCRATCH_SIZE
] = { };
85 static char *line_buffer
= NULL
;
87 static unit_advance advance_status
;
89 static st_option advance_opt
[] = {
96 static void (*transfer
) (bt
, void *, int);
100 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
101 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
111 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
113 m
= current_unit
->flags
.form
== FORM_FORMATTED
?
114 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
118 m
= current_unit
->flags
.form
== FORM_FORMATTED
?
119 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
126 /* Mid level data transfer statements. These subroutines do reading
127 and writing in the style of salloc_r()/salloc_w() within the
130 /* When reading sequential formatted records we have a problem. We
131 don't know how long the line is until we read the trailing newline,
132 and we don't want to read too much. If we read too much, we might
133 have to do a physical seek backwards depending on how much data is
134 present, and devices like terminals aren't seekable and would cause
137 Given this, the solution is to read a byte at a time, stopping if
138 we hit the newline. For small locations, we use a static buffer.
139 For larger allocations, we are forced to allocate memory on the
140 heap. Hopefully this won't happen very often. */
143 read_sf (int *length
)
145 static char data
[SCRATCH_SIZE
];
149 if (*length
> SCRATCH_SIZE
)
150 p
= base
= line_buffer
= get_mem (*length
);
154 /* If we have seen an eor previously, return a length of 0. The
155 caller is responsible for correctly padding the input field. */
162 current_unit
->bytes_left
= options
.default_recl
;
168 if (is_internal_unit())
170 /* readlen may be modified inside salloc_r if
171 is_internal_unit() is true. */
175 q
= salloc_r (current_unit
->s
, &readlen
);
179 /* If we have a line without a terminating \n, drop through to
181 if (readlen
< 1 && n
== 0)
183 generate_error (ERROR_END
, NULL
);
187 if (readlen
< 1 || *q
== '\n' || *q
== '\r')
189 /* Unexpected end of line. */
191 /* If we see an EOR during non-advancing I/O, we need to skip
192 the rest of the I/O statement. Set the corresponding flag. */
193 if (advance_status
== ADVANCE_NO
)
196 /* Without padding, terminate the I/O statement without assigning
197 the value. With padding, the value still needs to be assigned,
198 so we can just continue with a short read. */
199 if (current_unit
->flags
.pad
== PAD_NO
)
201 generate_error (ERROR_EOR
, NULL
);
205 current_unit
->bytes_left
= 0;
217 if (ioparm
.size
!= NULL
)
218 *ioparm
.size
+= *length
;
224 /* Function for reading the next couple of bytes from the current
225 file, advancing the current position. We return a pointer to a
226 buffer containing the bytes. We return NULL on end of record or
229 If the read is short, then it is because the current record does not
230 have enough data to satisfy the read request and the file was
231 opened with PAD=YES. The caller must assume tailing spaces for
235 read_block (int *length
)
240 if (current_unit
->flags
.form
== FORM_FORMATTED
&&
241 current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
242 return read_sf (length
); /* Special case. */
244 if (current_unit
->bytes_left
< *length
)
246 if (current_unit
->flags
.pad
== PAD_NO
)
248 generate_error (ERROR_EOR
, NULL
); /* Not enough data left. */
252 *length
= current_unit
->bytes_left
;
255 current_unit
->bytes_left
-= *length
;
258 source
= salloc_r (current_unit
->s
, &nread
);
260 if (ioparm
.size
!= NULL
)
261 *ioparm
.size
+= nread
;
263 if (nread
!= *length
)
264 { /* Short read, this shouldn't happen. */
265 if (current_unit
->flags
.pad
== PAD_YES
)
269 generate_error (ERROR_EOR
, NULL
);
278 /* Function for writing a block of bytes to the current file at the
279 current position, advancing the file pointer. We are given a length
280 and return a pointer to a buffer that the caller must (completely)
281 fill in. Returns NULL on error. */
284 write_block (int length
)
288 if (!is_internal_unit() && current_unit
->bytes_left
< length
)
290 generate_error (ERROR_EOR
, NULL
);
294 current_unit
->bytes_left
-= length
;
295 dest
= salloc_w (current_unit
->s
, &length
);
297 if (ioparm
.size
!= NULL
)
298 *ioparm
.size
+= length
;
304 /* Master function for unformatted reads. */
307 unformatted_read (bt type
, void *dest
, int length
)
312 /* Transfer functions get passed the kind of the entity, so we have
313 to fix this for COMPLEX data which are twice the size of their
315 if (type
== BT_COMPLEX
)
319 source
= read_block (&w
);
323 memcpy (dest
, source
, w
);
325 memset (((char *) dest
) + w
, ' ', length
- w
);
329 /* Master function for unformatted writes. */
332 unformatted_write (bt type
, void *source
, int length
)
336 /* Correction for kind vs. length as in unformatted_read. */
337 if (type
== BT_COMPLEX
)
340 dest
= write_block (length
);
342 memcpy (dest
, source
, length
);
346 /* Return a pointer to the name of a type. */
371 internal_error ("type_name(): Bad type");
378 /* Write a constant string to the output.
379 This is complicated because the string can have doubled delimiters
380 in it. The length in the format node is the true length. */
383 write_constant_string (fnode
* f
)
385 char c
, delimiter
, *p
, *q
;
388 length
= f
->u
.string
.length
;
392 p
= write_block (length
);
399 for (; length
> 0; length
--)
402 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
403 q
++; /* Skip the doubled delimiter. */
408 /* Given actual and expected types in a formatted data transfer, make
409 sure they agree. If not, an error message is generated. Returns
410 nonzero if something went wrong. */
413 require_type (bt expected
, bt actual
, fnode
* f
)
417 if (actual
== expected
)
420 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
421 type_name (expected
), g
.item_count
, type_name (actual
));
423 format_error (f
, buffer
);
428 /* This subroutine is the main loop for a formatted data transfer
429 statement. It would be natural to implement this as a coroutine
430 with the user program, but C makes that awkward. We loop,
431 processesing format elements. When we actually have to transfer
432 data instead of just setting flags, we return control to the user
433 program which calls a subroutine that supplies the address and type
434 of the next element, then comes back here to process it. */
437 formatted_transfer (bt type
, void *p
, int len
)
442 int consume_data_flag
;
444 /* Change a complex data item into a pair of reals. */
446 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
447 if (type
== BT_COMPLEX
)
450 /* If there's an EOR condition, we simulate finalizing the transfer
457 /* If reversion has occurred and there is another real data item,
458 then we have to move to the next record. */
459 if (g
.reversion_flag
&& n
> 0)
461 g
.reversion_flag
= 0;
465 consume_data_flag
= 1 ;
466 if (ioparm
.library_return
!= LIBRARY_OK
)
471 return; /* No data descriptors left (already raised). */
478 if (require_type (BT_INTEGER
, type
, f
))
481 if (g
.mode
== READING
)
482 read_decimal (f
, p
, len
);
491 if (require_type (BT_INTEGER
, type
, f
))
494 if (g
.mode
== READING
)
495 read_radix (f
, p
, len
, 2);
505 if (g
.mode
== READING
)
506 read_radix (f
, p
, len
, 8);
516 if (g
.mode
== READING
)
517 read_radix (f
, p
, len
, 16);
526 if (require_type (BT_CHARACTER
, type
, f
))
529 if (g
.mode
== READING
)
540 if (g
.mode
== READING
)
550 if (require_type (BT_REAL
, type
, f
))
553 if (g
.mode
== READING
)
563 if (require_type (BT_REAL
, type
, f
))
566 if (g
.mode
== READING
)
575 if (require_type (BT_REAL
, type
, f
))
578 if (g
.mode
== READING
)
581 write_en (f
, p
, len
);
588 if (require_type (BT_REAL
, type
, f
))
591 if (g
.mode
== READING
)
594 write_es (f
, p
, len
);
601 if (require_type (BT_REAL
, type
, f
))
604 if (g
.mode
== READING
)
614 if (g
.mode
== READING
)
618 read_decimal (f
, p
, len
);
649 internal_error ("formatted_transfer(): Bad type");
655 consume_data_flag
= 0 ;
656 if (g
.mode
== READING
)
658 format_error (f
, "Constant string in input format");
661 write_constant_string (f
);
664 /* Format codes that don't transfer data. */
667 consume_data_flag
= 0 ;
668 if (g
.mode
== READING
)
677 if (f
->format
==FMT_TL
)
680 pos
= current_unit
->recl
- current_unit
->bytes_left
- pos
;
684 consume_data_flag
= 0 ;
688 if (pos
< 0 || pos
>= current_unit
->recl
)
690 generate_error (ERROR_EOR
, "T Or TL edit position error");
693 m
= pos
- (current_unit
->recl
- current_unit
->bytes_left
);
701 if (g
.mode
== READING
)
708 move_pos_offset (current_unit
->s
,m
);
714 consume_data_flag
= 0 ;
715 g
.sign_status
= SIGN_S
;
719 consume_data_flag
= 0 ;
720 g
.sign_status
= SIGN_SS
;
724 consume_data_flag
= 0 ;
725 g
.sign_status
= SIGN_SP
;
729 consume_data_flag
= 0 ;
730 g
.blank_status
= BLANK_NULL
;
734 consume_data_flag
= 0 ;
735 g
.blank_status
= BLANK_ZERO
;
739 consume_data_flag
= 0 ;
740 g
.scale_factor
= f
->u
.k
;
744 consume_data_flag
= 0 ;
749 consume_data_flag
= 0 ;
750 for (i
= 0; i
< f
->repeat
; i
++)
756 /* A colon descriptor causes us to exit this loop (in
757 particular preventing another / descriptor from being
758 processed) unless there is another data item to be
760 consume_data_flag
= 0 ;
766 internal_error ("Bad format node");
769 /* Free a buffer that we had to allocate during a sequential
770 formatted read of a block that was larger than the static
773 if (line_buffer
!= NULL
)
775 free_mem (line_buffer
);
779 /* Adjust the item count and data pointer. */
781 if ((consume_data_flag
> 0) && (n
> 0))
784 p
= ((char *) p
) + len
;
790 /* Come here when we need a data descriptor but don't have one. We
791 push the current format node back onto the input, then return and
792 let the user program call us back with the data. */
798 /* Data transfer entry points. The type of the data entity is
799 implicit in the subroutine call. This prevents us from having to
800 share a common enum with the compiler. */
803 transfer_integer (void *p
, int kind
)
806 if (ioparm
.library_return
!= LIBRARY_OK
)
808 transfer (BT_INTEGER
, p
, kind
);
813 transfer_real (void *p
, int kind
)
816 if (ioparm
.library_return
!= LIBRARY_OK
)
818 transfer (BT_REAL
, p
, kind
);
823 transfer_logical (void *p
, int kind
)
826 if (ioparm
.library_return
!= LIBRARY_OK
)
828 transfer (BT_LOGICAL
, p
, kind
);
833 transfer_character (void *p
, int len
)
836 if (ioparm
.library_return
!= LIBRARY_OK
)
838 transfer (BT_CHARACTER
, p
, len
);
843 transfer_complex (void *p
, int kind
)
846 if (ioparm
.library_return
!= LIBRARY_OK
)
848 transfer (BT_COMPLEX
, p
, kind
);
852 /* Preposition a sequential unformatted file while reading. */
861 n
= sizeof (gfc_offset
);
862 p
= salloc_r (current_unit
->s
, &n
);
865 return; /* end of file */
867 if (p
== NULL
|| n
!= sizeof (gfc_offset
))
869 generate_error (ERROR_BAD_US
, NULL
);
873 memcpy (&i
, p
, sizeof (gfc_offset
));
874 current_unit
->bytes_left
= i
;
878 /* Preposition a sequential unformatted file while writing. This
879 amount to writing a bogus length that will be filled in later. */
887 length
= sizeof (gfc_offset
);
888 p
= salloc_w (current_unit
->s
, &length
);
892 generate_error (ERROR_OS
, NULL
);
896 memset (p
, '\0', sizeof (gfc_offset
)); /* Bogus value for now. */
897 if (sfree (current_unit
->s
) == FAILURE
)
898 generate_error (ERROR_OS
, NULL
);
900 /* For sequential unformatted, we write until we have more bytes than
901 can fit in the record markers. If disk space runs out first, it will
902 error on the write. */
903 current_unit
->recl
= g
.max_offset
;
905 current_unit
->bytes_left
= current_unit
->recl
;
909 /* Position to the next record prior to transfer. We are assumed to
910 be before the next record. We also calculate the bytes in the next
916 if (current_unit
->current_record
)
917 return; /* Already positioned. */
919 switch (current_mode ())
921 case UNFORMATTED_SEQUENTIAL
:
922 if (g
.mode
== READING
)
929 case FORMATTED_SEQUENTIAL
:
930 case FORMATTED_DIRECT
:
931 case UNFORMATTED_DIRECT
:
932 current_unit
->bytes_left
= current_unit
->recl
;
936 current_unit
->current_record
= 1;
940 /* Initialize things for a data transfer. This code is common for
941 both reading and writing. */
944 data_transfer_init (int read_flag
)
946 unit_flags u_flags
; /* Used for creating a unit if needed. */
948 g
.mode
= read_flag
? READING
: WRITING
;
950 if (ioparm
.size
!= NULL
)
951 *ioparm
.size
= 0; /* Initialize the count. */
953 current_unit
= get_unit (read_flag
);
954 if (current_unit
== NULL
)
955 { /* Open the unit with some default flags. */
958 generate_error (ERROR_BAD_OPTION
, "Bad unit number in OPEN statement");
962 memset (&u_flags
, '\0', sizeof (u_flags
));
963 u_flags
.access
= ACCESS_SEQUENTIAL
;
964 u_flags
.action
= ACTION_READWRITE
;
965 /* Is it unformatted? */
966 if (ioparm
.format
== NULL
&& !ioparm
.list_format
)
967 u_flags
.form
= FORM_UNFORMATTED
;
969 u_flags
.form
= FORM_UNSPECIFIED
;
970 u_flags
.delim
= DELIM_UNSPECIFIED
;
971 u_flags
.blank
= BLANK_UNSPECIFIED
;
972 u_flags
.pad
= PAD_UNSPECIFIED
;
973 u_flags
.status
= STATUS_UNKNOWN
;
975 current_unit
= get_unit (read_flag
);
978 if (current_unit
== NULL
)
981 if (is_internal_unit())
983 current_unit
->recl
= file_length(current_unit
->s
);
985 empty_internal_buffer (current_unit
->s
);
988 /* Check the action. */
990 if (read_flag
&& current_unit
->flags
.action
== ACTION_WRITE
)
991 generate_error (ERROR_BAD_ACTION
,
992 "Cannot read from file opened for WRITE");
994 if (!read_flag
&& current_unit
->flags
.action
== ACTION_READ
)
995 generate_error (ERROR_BAD_ACTION
, "Cannot write to file opened for READ");
997 if (ioparm
.library_return
!= LIBRARY_OK
)
1000 /* Check the format. */
1005 if (ioparm
.library_return
!= LIBRARY_OK
)
1008 if (current_unit
->flags
.form
== FORM_UNFORMATTED
1009 && (ioparm
.format
!= NULL
|| ioparm
.list_format
))
1010 generate_error (ERROR_OPTION_CONFLICT
,
1011 "Format present for UNFORMATTED data transfer");
1013 if (ioparm
.namelist_name
!= NULL
&& ionml
!= NULL
)
1015 if(ioparm
.format
!= NULL
)
1016 generate_error (ERROR_OPTION_CONFLICT
,
1017 "A format cannot be specified with a namelist");
1019 else if (current_unit
->flags
.form
== FORM_FORMATTED
&&
1020 ioparm
.format
== NULL
&& !ioparm
.list_format
)
1021 generate_error (ERROR_OPTION_CONFLICT
,
1022 "Missing format for FORMATTED data transfer");
1025 if (is_internal_unit () && current_unit
->flags
.form
== FORM_UNFORMATTED
)
1026 generate_error (ERROR_OPTION_CONFLICT
,
1027 "Internal file cannot be accessed by UNFORMATTED data transfer");
1029 /* Check the record number. */
1031 if (current_unit
->flags
.access
== ACCESS_DIRECT
&& ioparm
.rec
== 0)
1033 generate_error (ERROR_MISSING_OPTION
,
1034 "Direct access data transfer requires record number");
1038 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
&& ioparm
.rec
!= 0)
1040 generate_error (ERROR_OPTION_CONFLICT
,
1041 "Record number not allowed for sequential access data transfer");
1045 /* Process the ADVANCE option. */
1047 advance_status
= (ioparm
.advance
== NULL
) ? ADVANCE_UNSPECIFIED
:
1048 find_option (ioparm
.advance
, ioparm
.advance_len
, advance_opt
,
1049 "Bad ADVANCE parameter in data transfer statement");
1051 if (advance_status
!= ADVANCE_UNSPECIFIED
)
1053 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
1054 generate_error (ERROR_OPTION_CONFLICT
,
1055 "ADVANCE specification conflicts with sequential access");
1057 if (is_internal_unit ())
1058 generate_error (ERROR_OPTION_CONFLICT
,
1059 "ADVANCE specification conflicts with internal file");
1061 if (ioparm
.format
== NULL
|| ioparm
.list_format
)
1062 generate_error (ERROR_OPTION_CONFLICT
,
1063 "ADVANCE specification requires an explicit format");
1068 if (ioparm
.eor
!= 0 && advance_status
!= ADVANCE_NO
)
1069 generate_error (ERROR_MISSING_OPTION
,
1070 "EOR specification requires an ADVANCE specification of NO");
1072 if (ioparm
.size
!= NULL
&& advance_status
!= ADVANCE_NO
)
1073 generate_error (ERROR_MISSING_OPTION
,
1074 "SIZE specification requires an ADVANCE specification of NO");
1078 { /* Write constraints. */
1079 if (ioparm
.end
!= 0)
1080 generate_error (ERROR_OPTION_CONFLICT
,
1081 "END specification cannot appear in a write statement");
1083 if (ioparm
.eor
!= 0)
1084 generate_error (ERROR_OPTION_CONFLICT
,
1085 "EOR specification cannot appear in a write statement");
1087 if (ioparm
.size
!= 0)
1088 generate_error (ERROR_OPTION_CONFLICT
,
1089 "SIZE specification cannot appear in a write statement");
1092 if (advance_status
== ADVANCE_UNSPECIFIED
)
1093 advance_status
= ADVANCE_YES
;
1094 if (ioparm
.library_return
!= LIBRARY_OK
)
1097 /* Sanity checks on the record number. */
1101 if (ioparm
.rec
<= 0)
1103 generate_error (ERROR_BAD_OPTION
, "Record number must be positive");
1107 if (ioparm
.rec
>= current_unit
->maxrec
)
1109 generate_error (ERROR_BAD_OPTION
, "Record number too large");
1113 /* Check to see if we might be reading what we wrote before */
1115 if (g
.mode
== READING
&& current_unit
->mode
== WRITING
)
1116 flush(current_unit
->s
);
1118 /* Position the file. */
1119 if (sseek (current_unit
->s
,
1120 (ioparm
.rec
- 1) * current_unit
->recl
) == FAILURE
)
1121 generate_error (ERROR_OS
, NULL
);
1124 /* Overwriting an existing sequential file ?
1125 it is always safe to truncate the file on the first write */
1126 if (g
.mode
== WRITING
1127 && current_unit
->flags
.access
== ACCESS_SEQUENTIAL
1128 && current_unit
->current_record
== 0)
1129 struncate(current_unit
->s
);
1131 current_unit
->mode
= g
.mode
;
1133 /* Set the initial value of flags. */
1135 g
.blank_status
= current_unit
->flags
.blank
;
1136 g
.sign_status
= SIGN_S
;
1146 /* Set up the subroutine that will handle the transfers. */
1150 if (current_unit
->flags
.form
== FORM_UNFORMATTED
)
1151 transfer
= unformatted_read
;
1154 if (ioparm
.list_format
)
1156 transfer
= list_formatted_read
;
1160 transfer
= formatted_transfer
;
1165 if (current_unit
->flags
.form
== FORM_UNFORMATTED
)
1166 transfer
= unformatted_write
;
1169 if (ioparm
.list_format
)
1170 transfer
= list_formatted_write
;
1172 transfer
= formatted_transfer
;
1176 /* Make sure that we don't do a read after a nonadvancing write. */
1180 if (current_unit
->read_bad
)
1182 generate_error (ERROR_BAD_OPTION
,
1183 "Cannot READ after a nonadvancing WRITE");
1189 if (advance_status
== ADVANCE_YES
)
1190 current_unit
->read_bad
= 1;
1193 /* Start the data transfer if we are doing a formatted transfer. */
1194 if (current_unit
->flags
.form
== FORM_FORMATTED
&& !ioparm
.list_format
1195 && ioparm
.namelist_name
== NULL
&& ionml
== NULL
)
1196 formatted_transfer (0, NULL
, 0);
1200 /* Space to the next record for read mode. If the file is not
1201 seekable, we read MAX_READ chunks until we get to the right
1204 #define MAX_READ 4096
1207 next_record_r (int done
)
1209 int rlength
, length
;
1213 switch (current_mode ())
1215 case UNFORMATTED_SEQUENTIAL
:
1216 current_unit
->bytes_left
+= sizeof (gfc_offset
); /* Skip over tail */
1218 /* Fall through... */
1220 case FORMATTED_DIRECT
:
1221 case UNFORMATTED_DIRECT
:
1222 if (current_unit
->bytes_left
== 0)
1225 if (is_seekable (current_unit
->s
))
1227 new = file_position (current_unit
->s
) + current_unit
->bytes_left
;
1229 /* Direct access files do not generate END conditions,
1231 if (sseek (current_unit
->s
, new) == FAILURE
)
1232 generate_error (ERROR_OS
, NULL
);
1236 { /* Seek by reading data. */
1237 while (current_unit
->bytes_left
> 0)
1239 rlength
= length
= (MAX_READ
> current_unit
->bytes_left
) ?
1240 MAX_READ
: current_unit
->bytes_left
;
1242 p
= salloc_r (current_unit
->s
, &rlength
);
1245 generate_error (ERROR_OS
, NULL
);
1249 current_unit
->bytes_left
-= length
;
1254 case FORMATTED_SEQUENTIAL
:
1256 /* sf_read has already terminated input because of an '\n' */
1265 p
= salloc_r (current_unit
->s
, &length
);
1267 /* In case of internal file, there may not be any '\n'. */
1268 if (is_internal_unit() && p
== NULL
)
1275 generate_error (ERROR_OS
, NULL
);
1281 current_unit
->endfile
= AT_ENDFILE
;
1290 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1291 test_endfile (current_unit
);
1295 /* Position to the next record in write mode. */
1298 next_record_w (int done
)
1304 switch (current_mode ())
1306 case FORMATTED_DIRECT
:
1307 if (current_unit
->bytes_left
== 0)
1310 length
= current_unit
->bytes_left
;
1311 p
= salloc_w (current_unit
->s
, &length
);
1316 memset (p
, ' ', current_unit
->bytes_left
);
1317 if (sfree (current_unit
->s
) == FAILURE
)
1321 case UNFORMATTED_DIRECT
:
1322 if (sfree (current_unit
->s
) == FAILURE
)
1326 case UNFORMATTED_SEQUENTIAL
:
1327 m
= current_unit
->recl
- current_unit
->bytes_left
; /* Bytes written. */
1328 c
= file_position (current_unit
->s
);
1330 length
= sizeof (gfc_offset
);
1332 /* Write the length tail. */
1334 p
= salloc_w (current_unit
->s
, &length
);
1338 memcpy (p
, &m
, sizeof (gfc_offset
));
1339 if (sfree (current_unit
->s
) == FAILURE
)
1342 /* Seek to the head and overwrite the bogus length with the real
1345 p
= salloc_w_at (current_unit
->s
, &length
, c
- m
- length
);
1347 generate_error (ERROR_OS
, NULL
);
1349 memcpy (p
, &m
, sizeof (gfc_offset
));
1350 if (sfree (current_unit
->s
) == FAILURE
)
1353 /* Seek past the end of the current record. */
1355 if (sseek (current_unit
->s
, c
+ sizeof (gfc_offset
)) == FAILURE
)
1360 case FORMATTED_SEQUENTIAL
:
1362 p
= salloc_w (current_unit
->s
, &length
);
1364 if (!is_internal_unit())
1367 *p
= '\n'; /* No CR for internal writes. */
1372 if (sfree (current_unit
->s
) == FAILURE
)
1378 generate_error (ERROR_OS
, NULL
);
1384 /* Position to the next record, which means moving to the end of the
1385 current record. This can happen under several different
1386 conditions. If the done flag is not set, we get ready to process
1390 next_record (int done
)
1392 gfc_offset fp
; /* File position. */
1394 current_unit
->read_bad
= 0;
1396 if (g
.mode
== READING
)
1397 next_record_r (done
);
1399 next_record_w (done
);
1401 /* keep position up to date for INQUIRE */
1402 current_unit
->flags
.position
= POSITION_ASIS
;
1404 current_unit
->current_record
= 0;
1405 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
1407 fp
= file_position (current_unit
->s
);
1408 /* Calculate next record, rounding up partial records. */
1409 current_unit
->last_record
= (fp
+ current_unit
->recl
- 1)
1410 / current_unit
->recl
;
1413 current_unit
->last_record
++;
1420 /* Finalize the current data transfer. For a nonadvancing transfer,
1421 this means advancing to the next record. For internal units close the
1422 steam associated with the unit. */
1425 finalize_transfer (void)
1430 generate_error (ERROR_EOR
, NULL
);
1434 if (ioparm
.library_return
!= LIBRARY_OK
)
1437 if ((ionml
!= NULL
) && (ioparm
.namelist_name
!= NULL
))
1439 if (ioparm
.namelist_read_mode
)
1446 if (current_unit
== NULL
)
1449 if (setjmp (g
.eof_jump
))
1451 generate_error (ERROR_END
, NULL
);
1455 if (ioparm
.list_format
&& g
.mode
== READING
)
1456 finish_list_read ();
1461 if (advance_status
== ADVANCE_NO
)
1463 /* Most systems buffer lines, so force the partial record
1464 to be written out. */
1465 flush (current_unit
->s
);
1470 current_unit
->current_record
= 0;
1473 sfree (current_unit
->s
);
1475 if (is_internal_unit ())
1476 sclose (current_unit
->s
);
1480 /* Transfer function for IOLENGTH. It doesn't actually do any
1481 data transfer, it just updates the length counter. */
1484 iolength_transfer (bt type
, void *dest
, int len
)
1486 if (ioparm
.iolength
!= NULL
)
1487 *ioparm
.iolength
+= len
;
1491 /* Initialize the IOLENGTH data transfer. This function is in essence
1492 a very much simplified version of data_transfer_init(), because it
1493 doesn't have to deal with units at all. */
1496 iolength_transfer_init (void)
1498 if (ioparm
.iolength
!= NULL
)
1499 *ioparm
.iolength
= 0;
1503 /* Set up the subroutine that will handle the transfers. */
1505 transfer
= iolength_transfer
;
1509 /* Library entry point for the IOLENGTH form of the INQUIRE
1510 statement. The IOLENGTH form requires no I/O to be performed, but
1511 it must still be a runtime library call so that we can determine
1512 the iolength for dynamic arrays and such. */
1514 extern void st_iolength (void);
1515 export_proto(st_iolength
);
1521 iolength_transfer_init ();
1524 extern void st_iolength_done (void);
1525 export_proto(st_iolength_done
);
1528 st_iolength_done (void)
1534 /* The READ statement. */
1536 extern void st_read (void);
1537 export_proto(st_read
);
1544 data_transfer_init (1);
1546 /* Handle complications dealing with the endfile record. It is
1547 significant that this is the only place where ERROR_END is
1548 generated. Reading an end of file elsewhere is either end of
1549 record or an I/O error. */
1551 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1552 switch (current_unit
->endfile
)
1558 if (!is_internal_unit())
1560 generate_error (ERROR_END
, NULL
);
1561 current_unit
->endfile
= AFTER_ENDFILE
;
1566 generate_error (ERROR_ENDFILE
, NULL
);
1571 extern void st_read_done (void);
1572 export_proto(st_read_done
);
1577 finalize_transfer ();
1581 extern void st_write (void);
1582 export_proto(st_write
);
1588 data_transfer_init (0);
1591 extern void st_write_done (void);
1592 export_proto(st_write_done
);
1595 st_write_done (void)
1597 finalize_transfer ();
1599 /* Deal with endfile conditions associated with sequential files. */
1601 if (current_unit
!= NULL
&& current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1602 switch (current_unit
->endfile
)
1604 case AT_ENDFILE
: /* Remain at the endfile record. */
1608 current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
1612 if (current_unit
->current_record
> current_unit
->last_record
)
1614 /* Get rid of whatever is after this record. */
1615 if (struncate (current_unit
->s
) == FAILURE
)
1616 generate_error (ERROR_OS
, NULL
);
1619 current_unit
->endfile
= AT_ENDFILE
;
1628 st_set_nml_var (void * var_addr
, char * var_name
, int var_name_len
,
1629 int kind
, bt type
, int string_length
)
1631 namelist_info
*t1
= NULL
, *t2
= NULL
;
1632 namelist_info
*nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
1633 nml
->mem_pos
= var_addr
;
1636 assert (var_name_len
> 0);
1637 nml
->var_name
= (char*) get_mem (var_name_len
+1);
1638 strncpy (nml
->var_name
, var_name
, var_name_len
);
1639 nml
->var_name
[var_name_len
] = 0;
1643 assert (var_name_len
== 0);
1644 nml
->var_name
= NULL
;
1649 nml
->string_length
= string_length
;
1667 extern void st_set_nml_var_int (void *, char *, int, int);
1668 export_proto(st_set_nml_var_int
);
1670 extern void st_set_nml_var_float (void *, char *, int, int);
1671 export_proto(st_set_nml_var_float
);
1673 extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type
);
1674 export_proto(st_set_nml_var_char
);
1676 extern void st_set_nml_var_complex (void *, char *, int, int);
1677 export_proto(st_set_nml_var_complex
);
1679 extern void st_set_nml_var_log (void *, char *, int, int);
1680 export_proto(st_set_nml_var_log
);
1683 st_set_nml_var_int (void * var_addr
, char * var_name
, int var_name_len
,
1686 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_INTEGER
, 0);
1690 st_set_nml_var_float (void * var_addr
, char * var_name
, int var_name_len
,
1693 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_REAL
, 0);
1697 st_set_nml_var_char (void * var_addr
, char * var_name
, int var_name_len
,
1698 int kind
, gfc_charlen_type string_length
)
1700 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_CHARACTER
,
1705 st_set_nml_var_complex (void * var_addr
, char * var_name
, int var_name_len
,
1708 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_COMPLEX
, 0);
1712 st_set_nml_var_log (void * var_addr
, char * var_name
, int var_name_len
,
1715 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_LOGICAL
, 0);