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;
83 char scratch
[SCRATCH_SIZE
] = { };
84 static char *line_buffer
= NULL
;
86 static unit_advance advance_status
;
88 static st_option advance_opt
[] = {
95 static void (*transfer
) (bt
, void *, int);
99 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
100 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
110 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
112 m
= current_unit
->flags
.form
== FORM_FORMATTED
?
113 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
117 m
= current_unit
->flags
.form
== FORM_FORMATTED
?
118 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
125 /* Mid level data transfer statements. These subroutines do reading
126 and writing in the style of salloc_r()/salloc_w() within the
129 /* When reading sequential formatted records we have a problem. We
130 don't know how long the line is until we read the trailing newline,
131 and we don't want to read too much. If we read too much, we might
132 have to do a physical seek backwards depending on how much data is
133 present, and devices like terminals aren't seekable and would cause
136 Given this, the solution is to read a byte at a time, stopping if
137 we hit the newline. For small locations, we use a static buffer.
138 For larger allocations, we are forced to allocate memory on the
139 heap. Hopefully this won't happen very often. */
142 read_sf (int *length
)
144 static char data
[SCRATCH_SIZE
];
148 if (*length
> SCRATCH_SIZE
)
149 p
= base
= line_buffer
= get_mem (*length
);
153 memset(base
,'\0',*length
);
155 current_unit
->bytes_left
= options
.default_recl
;
161 if (is_internal_unit())
163 /* readlen may be modified inside salloc_r if
164 is_internal_unit() is true. */
168 q
= salloc_r (current_unit
->s
, &readlen
);
172 /* If we have a line without a terminating \n, drop through to
174 if (readlen
< 1 && n
== 0)
176 generate_error (ERROR_END
, NULL
);
180 if (readlen
< 1 || *q
== '\n')
182 /* ??? What is this for? */
183 if (current_unit
->unit_number
== options
.stdin_unit
)
188 /* Unexpected end of line. */
189 if (current_unit
->flags
.pad
== PAD_NO
)
191 generate_error (ERROR_EOR
, NULL
);
195 current_unit
->bytes_left
= 0;
211 /* Function for reading the next couple of bytes from the current
212 file, advancing the current position. We return a pointer to a
213 buffer containing the bytes. We return NULL on end of record or
216 If the read is short, then it is because the current record does not
217 have enough data to satisfy the read request and the file was
218 opened with PAD=YES. The caller must assume tailing spaces for
222 read_block (int *length
)
227 if (current_unit
->flags
.form
== FORM_FORMATTED
&&
228 current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
229 return read_sf (length
); /* Special case. */
231 if (current_unit
->bytes_left
< *length
)
233 if (current_unit
->flags
.pad
== PAD_NO
)
235 generate_error (ERROR_EOR
, NULL
); /* Not enough data left. */
239 *length
= current_unit
->bytes_left
;
242 current_unit
->bytes_left
-= *length
;
245 source
= salloc_r (current_unit
->s
, &nread
);
247 if (ioparm
.size
!= NULL
)
248 *ioparm
.size
+= nread
;
250 if (nread
!= *length
)
251 { /* Short read, this shouldn't happen. */
252 if (current_unit
->flags
.pad
== PAD_YES
)
256 generate_error (ERROR_EOR
, NULL
);
265 /* Function for writing a block of bytes to the current file at the
266 current position, advancing the file pointer. We are given a length
267 and return a pointer to a buffer that the caller must (completely)
268 fill in. Returns NULL on error. */
271 write_block (int length
)
275 if (!is_internal_unit() && current_unit
->bytes_left
< length
)
277 generate_error (ERROR_EOR
, NULL
);
281 current_unit
->bytes_left
-= length
;
282 dest
= salloc_w (current_unit
->s
, &length
);
284 if (ioparm
.size
!= NULL
)
285 *ioparm
.size
+= length
;
291 /* Master function for unformatted reads. */
294 unformatted_read (bt type
, void *dest
, int length
)
299 /* Transfer functions get passed the kind of the entity, so we have
300 to fix this for COMPLEX data which are twice the size of their
302 if (type
== BT_COMPLEX
)
306 source
= read_block (&w
);
310 memcpy (dest
, source
, w
);
312 memset (((char *) dest
) + w
, ' ', length
- w
);
316 /* Master function for unformatted writes. */
319 unformatted_write (bt type
, void *source
, int length
)
323 /* Correction for kind vs. length as in unformatted_read. */
324 if (type
== BT_COMPLEX
)
327 dest
= write_block (length
);
329 memcpy (dest
, source
, length
);
333 /* Return a pointer to the name of a type. */
358 internal_error ("type_name(): Bad type");
365 /* Write a constant string to the output.
366 This is complicated because the string can have doubled delimiters
367 in it. The length in the format node is the true length. */
370 write_constant_string (fnode
* f
)
372 char c
, delimiter
, *p
, *q
;
375 length
= f
->u
.string
.length
;
379 p
= write_block (length
);
386 for (; length
> 0; length
--)
389 if (c
== delimiter
&& c
!= 'H' && c
!= 'h')
390 q
++; /* Skip the doubled delimiter. */
395 /* Given actual and expected types in a formatted data transfer, make
396 sure they agree. If not, an error message is generated. Returns
397 nonzero if something went wrong. */
400 require_type (bt expected
, bt actual
, fnode
* f
)
404 if (actual
== expected
)
407 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
408 type_name (expected
), g
.item_count
, type_name (actual
));
410 format_error (f
, buffer
);
415 /* This subroutine is the main loop for a formatted data transfer
416 statement. It would be natural to implement this as a coroutine
417 with the user program, but C makes that awkward. We loop,
418 processesing format elements. When we actually have to transfer
419 data instead of just setting flags, we return control to the user
420 program which calls a subroutine that supplies the address and type
421 of the next element, then comes back here to process it. */
424 formatted_transfer (bt type
, void *p
, int len
)
429 int consume_data_flag
;
431 /* Change a complex data item into a pair of reals. */
433 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
434 if (type
== BT_COMPLEX
)
439 /* If reversion has occurred and there is another real data item,
440 then we have to move to the next record. */
441 if (g
.reversion_flag
&& n
> 0)
443 g
.reversion_flag
= 0;
447 consume_data_flag
= 1 ;
448 if (ioparm
.library_return
!= LIBRARY_OK
)
453 return; /* No data descriptors left (already raised). */
460 if (require_type (BT_INTEGER
, type
, f
))
463 if (g
.mode
== READING
)
464 read_decimal (f
, p
, len
);
473 if (require_type (BT_INTEGER
, type
, f
))
476 if (g
.mode
== READING
)
477 read_radix (f
, p
, len
, 2);
487 if (g
.mode
== READING
)
488 read_radix (f
, p
, len
, 8);
498 if (g
.mode
== READING
)
499 read_radix (f
, p
, len
, 16);
508 if (require_type (BT_CHARACTER
, type
, f
))
511 if (g
.mode
== READING
)
522 if (g
.mode
== READING
)
532 if (require_type (BT_REAL
, type
, f
))
535 if (g
.mode
== READING
)
545 if (require_type (BT_REAL
, type
, f
))
548 if (g
.mode
== READING
)
557 if (require_type (BT_REAL
, type
, f
))
560 if (g
.mode
== READING
)
563 write_en (f
, p
, len
);
570 if (require_type (BT_REAL
, type
, f
))
573 if (g
.mode
== READING
)
576 write_es (f
, p
, len
);
583 if (require_type (BT_REAL
, type
, f
))
586 if (g
.mode
== READING
)
596 if (g
.mode
== READING
)
600 read_decimal (f
, p
, len
);
631 internal_error ("formatted_transfer(): Bad type");
637 consume_data_flag
= 0 ;
638 if (g
.mode
== READING
)
640 format_error (f
, "Constant string in input format");
643 write_constant_string (f
);
646 /* Format codes that don't transfer data. */
649 consume_data_flag
= 0 ;
650 if (g
.mode
== READING
)
659 if (f
->format
==FMT_TL
)
662 pos
= current_unit
->recl
- current_unit
->bytes_left
- pos
;
666 consume_data_flag
= 0 ;
670 if (pos
< 0 || pos
>= current_unit
->recl
)
672 generate_error (ERROR_EOR
, "T Or TL edit position error");
675 m
= pos
- (current_unit
->recl
- current_unit
->bytes_left
);
683 if (g
.mode
== READING
)
690 move_pos_offset (current_unit
->s
,m
);
696 consume_data_flag
= 0 ;
697 g
.sign_status
= SIGN_S
;
701 consume_data_flag
= 0 ;
702 g
.sign_status
= SIGN_SS
;
706 consume_data_flag
= 0 ;
707 g
.sign_status
= SIGN_SP
;
711 consume_data_flag
= 0 ;
712 g
.blank_status
= BLANK_NULL
;
716 consume_data_flag
= 0 ;
717 g
.blank_status
= BLANK_ZERO
;
721 consume_data_flag
= 0 ;
722 g
.scale_factor
= f
->u
.k
;
726 consume_data_flag
= 0 ;
731 consume_data_flag
= 0 ;
732 for (i
= 0; i
< f
->repeat
; i
++)
738 /* A colon descriptor causes us to exit this loop (in
739 particular preventing another / descriptor from being
740 processed) unless there is another data item to be
742 consume_data_flag
= 0 ;
748 internal_error ("Bad format node");
751 /* Free a buffer that we had to allocate during a sequential
752 formatted read of a block that was larger than the static
755 if (line_buffer
!= NULL
)
757 free_mem (line_buffer
);
761 /* Adjust the item count and data pointer. */
763 if ((consume_data_flag
> 0) && (n
> 0))
766 p
= ((char *) p
) + len
;
772 /* Come here when we need a data descriptor but don't have one. We
773 push the current format node back onto the input, then return and
774 let the user program call us back with the data. */
780 /* Data transfer entry points. The type of the data entity is
781 implicit in the subroutine call. This prevents us from having to
782 share a common enum with the compiler. */
785 transfer_integer (void *p
, int kind
)
788 if (ioparm
.library_return
!= LIBRARY_OK
)
790 transfer (BT_INTEGER
, p
, kind
);
795 transfer_real (void *p
, int kind
)
798 if (ioparm
.library_return
!= LIBRARY_OK
)
800 transfer (BT_REAL
, p
, kind
);
805 transfer_logical (void *p
, int kind
)
808 if (ioparm
.library_return
!= LIBRARY_OK
)
810 transfer (BT_LOGICAL
, p
, kind
);
815 transfer_character (void *p
, int len
)
818 if (ioparm
.library_return
!= LIBRARY_OK
)
820 transfer (BT_CHARACTER
, p
, len
);
825 transfer_complex (void *p
, int kind
)
828 if (ioparm
.library_return
!= LIBRARY_OK
)
830 transfer (BT_COMPLEX
, p
, kind
);
834 /* Preposition a sequential unformatted file while reading. */
843 n
= sizeof (gfc_offset
);
844 p
= salloc_r (current_unit
->s
, &n
);
847 return; /* end of file */
849 if (p
== NULL
|| n
!= sizeof (gfc_offset
))
851 generate_error (ERROR_BAD_US
, NULL
);
855 memcpy (&i
, p
, sizeof (gfc_offset
));
856 current_unit
->bytes_left
= i
;
860 /* Preposition a sequential unformatted file while writing. This
861 amount to writing a bogus length that will be filled in later. */
869 length
= sizeof (gfc_offset
);
870 p
= salloc_w (current_unit
->s
, &length
);
874 generate_error (ERROR_OS
, NULL
);
878 memset (p
, '\0', sizeof (gfc_offset
)); /* Bogus value for now. */
879 if (sfree (current_unit
->s
) == FAILURE
)
880 generate_error (ERROR_OS
, NULL
);
882 /* For sequential unformatted, we write until we have more bytes than
883 can fit in the record markers. If disk space runs out first, it will
884 error on the write. */
885 current_unit
->recl
= g
.max_offset
;
887 current_unit
->bytes_left
= current_unit
->recl
;
891 /* Position to the next record prior to transfer. We are assumed to
892 be before the next record. We also calculate the bytes in the next
898 if (current_unit
->current_record
)
899 return; /* Already positioned. */
901 switch (current_mode ())
903 case UNFORMATTED_SEQUENTIAL
:
904 if (g
.mode
== READING
)
911 case FORMATTED_SEQUENTIAL
:
912 case FORMATTED_DIRECT
:
913 case UNFORMATTED_DIRECT
:
914 current_unit
->bytes_left
= current_unit
->recl
;
918 current_unit
->current_record
= 1;
922 /* Initialize things for a data transfer. This code is common for
923 both reading and writing. */
926 data_transfer_init (int read_flag
)
928 unit_flags u_flags
; /* Used for creating a unit if needed. */
930 g
.mode
= read_flag
? READING
: WRITING
;
932 if (ioparm
.size
!= NULL
)
933 *ioparm
.size
= 0; /* Initialize the count. */
935 current_unit
= get_unit (read_flag
);
936 if (current_unit
== NULL
)
937 { /* Open the unit with some default flags. */
938 memset (&u_flags
, '\0', sizeof (u_flags
));
939 u_flags
.access
= ACCESS_SEQUENTIAL
;
940 u_flags
.action
= ACTION_READWRITE
;
941 /* Is it unformatted? */
942 if (ioparm
.format
== NULL
&& !ioparm
.list_format
)
943 u_flags
.form
= FORM_UNFORMATTED
;
945 u_flags
.form
= FORM_UNSPECIFIED
;
946 u_flags
.delim
= DELIM_UNSPECIFIED
;
947 u_flags
.blank
= BLANK_UNSPECIFIED
;
948 u_flags
.pad
= PAD_UNSPECIFIED
;
949 u_flags
.status
= STATUS_UNKNOWN
;
951 current_unit
= get_unit (read_flag
);
954 if (current_unit
== NULL
)
957 if (is_internal_unit())
959 current_unit
->recl
= file_length(current_unit
->s
);
961 empty_internal_buffer (current_unit
->s
);
964 /* Check the action. */
966 if (read_flag
&& current_unit
->flags
.action
== ACTION_WRITE
)
967 generate_error (ERROR_BAD_ACTION
,
968 "Cannot read from file opened for WRITE");
970 if (!read_flag
&& current_unit
->flags
.action
== ACTION_READ
)
971 generate_error (ERROR_BAD_ACTION
, "Cannot write to file opened for READ");
973 if (ioparm
.library_return
!= LIBRARY_OK
)
976 /* Check the format. */
981 if (ioparm
.library_return
!= LIBRARY_OK
)
984 if (current_unit
->flags
.form
== FORM_UNFORMATTED
985 && (ioparm
.format
!= NULL
|| ioparm
.list_format
))
986 generate_error (ERROR_OPTION_CONFLICT
,
987 "Format present for UNFORMATTED data transfer");
989 if (ioparm
.namelist_name
!= NULL
&& ionml
!= NULL
)
991 if(ioparm
.format
!= NULL
)
992 generate_error (ERROR_OPTION_CONFLICT
,
993 "A format cannot be specified with a namelist");
995 else if (current_unit
->flags
.form
== FORM_FORMATTED
&&
996 ioparm
.format
== NULL
&& !ioparm
.list_format
)
997 generate_error (ERROR_OPTION_CONFLICT
,
998 "Missing format for FORMATTED data transfer");
1001 if (is_internal_unit () && current_unit
->flags
.form
== FORM_UNFORMATTED
)
1002 generate_error (ERROR_OPTION_CONFLICT
,
1003 "Internal file cannot be accessed by UNFORMATTED data transfer");
1005 /* Check the record number. */
1007 if (current_unit
->flags
.access
== ACCESS_DIRECT
&& ioparm
.rec
== 0)
1009 generate_error (ERROR_MISSING_OPTION
,
1010 "Direct access data transfer requires record number");
1014 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
&& ioparm
.rec
!= 0)
1016 generate_error (ERROR_OPTION_CONFLICT
,
1017 "Record number not allowed for sequential access data transfer");
1021 /* Process the ADVANCE option. */
1023 advance_status
= (ioparm
.advance
== NULL
) ? ADVANCE_UNSPECIFIED
:
1024 find_option (ioparm
.advance
, ioparm
.advance_len
, advance_opt
,
1025 "Bad ADVANCE parameter in data transfer statement");
1027 if (advance_status
!= ADVANCE_UNSPECIFIED
)
1029 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
1030 generate_error (ERROR_OPTION_CONFLICT
,
1031 "ADVANCE specification conflicts with sequential access");
1033 if (is_internal_unit ())
1034 generate_error (ERROR_OPTION_CONFLICT
,
1035 "ADVANCE specification conflicts with internal file");
1037 if (ioparm
.format
== NULL
|| ioparm
.list_format
)
1038 generate_error (ERROR_OPTION_CONFLICT
,
1039 "ADVANCE specification requires an explicit format");
1044 if (ioparm
.eor
!= 0 && advance_status
!= ADVANCE_NO
)
1045 generate_error (ERROR_MISSING_OPTION
,
1046 "EOR specification requires an ADVANCE specification of NO");
1048 if (ioparm
.size
!= NULL
&& advance_status
!= ADVANCE_NO
)
1049 generate_error (ERROR_MISSING_OPTION
,
1050 "SIZE specification requires an ADVANCE specification of NO");
1054 { /* Write constraints. */
1055 if (ioparm
.end
!= 0)
1056 generate_error (ERROR_OPTION_CONFLICT
,
1057 "END specification cannot appear in a write statement");
1059 if (ioparm
.eor
!= 0)
1060 generate_error (ERROR_OPTION_CONFLICT
,
1061 "EOR specification cannot appear in a write statement");
1063 if (ioparm
.size
!= 0)
1064 generate_error (ERROR_OPTION_CONFLICT
,
1065 "SIZE specification cannot appear in a write statement");
1068 if (advance_status
== ADVANCE_UNSPECIFIED
)
1069 advance_status
= ADVANCE_YES
;
1070 if (ioparm
.library_return
!= LIBRARY_OK
)
1073 /* Sanity checks on the record number. */
1077 if (ioparm
.rec
<= 0)
1079 generate_error (ERROR_BAD_OPTION
, "Record number must be positive");
1083 if (ioparm
.rec
>= current_unit
->maxrec
)
1085 generate_error (ERROR_BAD_OPTION
, "Record number too large");
1089 /* Check to see if we might be reading what we wrote before */
1091 if (g
.mode
== READING
&& current_unit
->mode
== WRITING
)
1092 flush(current_unit
->s
);
1094 /* Position the file. */
1095 if (sseek (current_unit
->s
,
1096 (ioparm
.rec
- 1) * current_unit
->recl
) == FAILURE
)
1097 generate_error (ERROR_OS
, NULL
);
1100 current_unit
->mode
= g
.mode
;
1102 /* Set the initial value of flags. */
1104 g
.blank_status
= current_unit
->flags
.blank
;
1105 g
.sign_status
= SIGN_S
;
1114 /* Set up the subroutine that will handle the transfers. */
1118 if (current_unit
->flags
.form
== FORM_UNFORMATTED
)
1119 transfer
= unformatted_read
;
1122 if (ioparm
.list_format
)
1124 transfer
= list_formatted_read
;
1128 transfer
= formatted_transfer
;
1133 if (current_unit
->flags
.form
== FORM_UNFORMATTED
)
1134 transfer
= unformatted_write
;
1137 if (ioparm
.list_format
)
1138 transfer
= list_formatted_write
;
1140 transfer
= formatted_transfer
;
1144 /* Make sure that we don't do a read after a nonadvancing write. */
1148 if (current_unit
->read_bad
)
1150 generate_error (ERROR_BAD_OPTION
,
1151 "Cannot READ after a nonadvancing WRITE");
1157 if (advance_status
== ADVANCE_YES
)
1158 current_unit
->read_bad
= 1;
1161 /* Start the data transfer if we are doing a formatted transfer. */
1162 if (current_unit
->flags
.form
== FORM_FORMATTED
&& !ioparm
.list_format
1163 && ioparm
.namelist_name
== NULL
&& ionml
== NULL
)
1164 formatted_transfer (0, NULL
, 0);
1168 /* Space to the next record for read mode. If the file is not
1169 seekable, we read MAX_READ chunks until we get to the right
1172 #define MAX_READ 4096
1175 next_record_r (int done
)
1177 int rlength
, length
;
1181 switch (current_mode ())
1183 case UNFORMATTED_SEQUENTIAL
:
1184 current_unit
->bytes_left
+= sizeof (gfc_offset
); /* Skip over tail */
1186 /* Fall through... */
1188 case FORMATTED_DIRECT
:
1189 case UNFORMATTED_DIRECT
:
1190 if (current_unit
->bytes_left
== 0)
1193 if (is_seekable (current_unit
->s
))
1195 new = file_position (current_unit
->s
) + current_unit
->bytes_left
;
1197 /* Direct access files do not generate END conditions,
1199 if (sseek (current_unit
->s
, new) == FAILURE
)
1200 generate_error (ERROR_OS
, NULL
);
1204 { /* Seek by reading data. */
1205 while (current_unit
->bytes_left
> 0)
1207 rlength
= length
= (MAX_READ
> current_unit
->bytes_left
) ?
1208 MAX_READ
: current_unit
->bytes_left
;
1210 p
= salloc_r (current_unit
->s
, &rlength
);
1213 generate_error (ERROR_OS
, NULL
);
1217 current_unit
->bytes_left
-= length
;
1222 case FORMATTED_SEQUENTIAL
:
1224 /* sf_read has already terminated input because of an '\n' */
1230 p
= salloc_r (current_unit
->s
, &length
);
1232 /* In case of internal file, there may not be any '\n'. */
1233 if (is_internal_unit() && p
== NULL
)
1240 generate_error (ERROR_OS
, NULL
);
1246 current_unit
->endfile
= AT_ENDFILE
;
1255 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1256 test_endfile (current_unit
);
1260 /* Position to the next record in write mode. */
1263 next_record_w (int done
)
1269 switch (current_mode ())
1271 case FORMATTED_DIRECT
:
1272 if (current_unit
->bytes_left
== 0)
1275 length
= current_unit
->bytes_left
;
1276 p
= salloc_w (current_unit
->s
, &length
);
1281 memset (p
, ' ', current_unit
->bytes_left
);
1282 if (sfree (current_unit
->s
) == FAILURE
)
1286 case UNFORMATTED_DIRECT
:
1287 if (sfree (current_unit
->s
) == FAILURE
)
1291 case UNFORMATTED_SEQUENTIAL
:
1292 m
= current_unit
->recl
- current_unit
->bytes_left
; /* Bytes written. */
1293 c
= file_position (current_unit
->s
);
1295 length
= sizeof (gfc_offset
);
1297 /* Write the length tail. */
1299 p
= salloc_w (current_unit
->s
, &length
);
1303 memcpy (p
, &m
, sizeof (gfc_offset
));
1304 if (sfree (current_unit
->s
) == FAILURE
)
1307 /* Seek to the head and overwrite the bogus length with the real
1310 p
= salloc_w_at (current_unit
->s
, &length
, c
- m
- length
);
1312 generate_error (ERROR_OS
, NULL
);
1314 memcpy (p
, &m
, sizeof (gfc_offset
));
1315 if (sfree (current_unit
->s
) == FAILURE
)
1318 /* Seek past the end of the current record. */
1320 if (sseek (current_unit
->s
, c
+ sizeof (gfc_offset
)) == FAILURE
)
1325 case FORMATTED_SEQUENTIAL
:
1327 p
= salloc_w (current_unit
->s
, &length
);
1329 if (!is_internal_unit())
1332 *p
= '\n'; /* No CR for internal writes. */
1337 if (sfree (current_unit
->s
) == FAILURE
)
1343 generate_error (ERROR_OS
, NULL
);
1349 /* Position to the next record, which means moving to the end of the
1350 current record. This can happen under several different
1351 conditions. If the done flag is not set, we get ready to process
1355 next_record (int done
)
1357 gfc_offset fp
; /* File position. */
1359 current_unit
->read_bad
= 0;
1361 if (g
.mode
== READING
)
1362 next_record_r (done
);
1364 next_record_w (done
);
1366 /* keep position up to date for INQUIRE */
1367 current_unit
->flags
.position
= POSITION_ASIS
;
1369 current_unit
->current_record
= 0;
1370 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
1372 fp
= file_position (current_unit
->s
);
1373 /* Calculate next record, rounding up partial records. */
1374 current_unit
->last_record
= (fp
+ current_unit
->recl
- 1)
1375 / current_unit
->recl
;
1378 current_unit
->last_record
++;
1385 /* Finalize the current data transfer. For a nonadvancing transfer,
1386 this means advancing to the next record. For internal units close the
1387 steam associated with the unit. */
1390 finalize_transfer (void)
1392 if (ioparm
.library_return
!= LIBRARY_OK
)
1395 if ((ionml
!= NULL
) && (ioparm
.namelist_name
!= NULL
))
1397 if (ioparm
.namelist_read_mode
)
1404 if (current_unit
== NULL
)
1407 if (setjmp (g
.eof_jump
))
1409 generate_error (ERROR_END
, NULL
);
1413 if (ioparm
.list_format
&& g
.mode
== READING
)
1414 finish_list_read ();
1419 if (advance_status
== ADVANCE_NO
)
1421 /* Most systems buffer lines, so force the partial record
1422 to be written out. */
1423 flush (current_unit
->s
);
1428 current_unit
->current_record
= 0;
1431 sfree (current_unit
->s
);
1433 if (is_internal_unit ())
1434 sclose (current_unit
->s
);
1438 /* Transfer function for IOLENGTH. It doesn't actually do any
1439 data transfer, it just updates the length counter. */
1442 iolength_transfer (bt type
, void *dest
, int len
)
1444 if (ioparm
.iolength
!= NULL
)
1445 *ioparm
.iolength
+= len
;
1449 /* Initialize the IOLENGTH data transfer. This function is in essence
1450 a very much simplified version of data_transfer_init(), because it
1451 doesn't have to deal with units at all. */
1454 iolength_transfer_init (void)
1456 if (ioparm
.iolength
!= NULL
)
1457 *ioparm
.iolength
= 0;
1461 /* Set up the subroutine that will handle the transfers. */
1463 transfer
= iolength_transfer
;
1467 /* Library entry point for the IOLENGTH form of the INQUIRE
1468 statement. The IOLENGTH form requires no I/O to be performed, but
1469 it must still be a runtime library call so that we can determine
1470 the iolength for dynamic arrays and such. */
1472 extern void st_iolength (void);
1473 export_proto(st_iolength
);
1479 iolength_transfer_init ();
1482 extern void st_iolength_done (void);
1483 export_proto(st_iolength_done
);
1486 st_iolength_done (void)
1492 /* The READ statement. */
1494 extern void st_read (void);
1495 export_proto(st_read
);
1502 data_transfer_init (1);
1504 /* Handle complications dealing with the endfile record. It is
1505 significant that this is the only place where ERROR_END is
1506 generated. Reading an end of file elsewhere is either end of
1507 record or an I/O error. */
1509 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1510 switch (current_unit
->endfile
)
1516 if (!is_internal_unit())
1518 generate_error (ERROR_END
, NULL
);
1519 current_unit
->endfile
= AFTER_ENDFILE
;
1524 generate_error (ERROR_ENDFILE
, NULL
);
1529 extern void st_read_done (void);
1530 export_proto(st_read_done
);
1535 finalize_transfer ();
1539 extern void st_write (void);
1540 export_proto(st_write
);
1546 data_transfer_init (0);
1549 extern void st_write_done (void);
1550 export_proto(st_write_done
);
1553 st_write_done (void)
1555 finalize_transfer ();
1557 /* Deal with endfile conditions associated with sequential files. */
1559 if (current_unit
!= NULL
&& current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1560 switch (current_unit
->endfile
)
1562 case AT_ENDFILE
: /* Remain at the endfile record. */
1566 current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
1570 if (current_unit
->current_record
> current_unit
->last_record
)
1572 /* Get rid of whatever is after this record. */
1573 if (struncate (current_unit
->s
) == FAILURE
)
1574 generate_error (ERROR_OS
, NULL
);
1577 current_unit
->endfile
= AT_ENDFILE
;
1586 st_set_nml_var (void * var_addr
, char * var_name
, int var_name_len
,
1587 int kind
, bt type
, int string_length
)
1589 namelist_info
*t1
= NULL
, *t2
= NULL
;
1590 namelist_info
*nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
1591 nml
->mem_pos
= var_addr
;
1594 assert (var_name_len
> 0);
1595 nml
->var_name
= (char*) get_mem (var_name_len
+1);
1596 strncpy (nml
->var_name
, var_name
, var_name_len
);
1597 nml
->var_name
[var_name_len
] = 0;
1601 assert (var_name_len
== 0);
1602 nml
->var_name
= NULL
;
1607 nml
->string_length
= string_length
;
1625 extern void st_set_nml_var_int (void *, char *, int, int);
1626 export_proto(st_set_nml_var_int
);
1628 extern void st_set_nml_var_float (void *, char *, int, int);
1629 export_proto(st_set_nml_var_float
);
1631 extern void st_set_nml_var_char (void *, char *, int, int, gfc_charlen_type
);
1632 export_proto(st_set_nml_var_char
);
1634 extern void st_set_nml_var_complex (void *, char *, int, int);
1635 export_proto(st_set_nml_var_complex
);
1637 extern void st_set_nml_var_log (void *, char *, int, int);
1638 export_proto(st_set_nml_var_log
);
1641 st_set_nml_var_int (void * var_addr
, char * var_name
, int var_name_len
,
1644 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_INTEGER
, 0);
1648 st_set_nml_var_float (void * var_addr
, char * var_name
, int var_name_len
,
1651 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_REAL
, 0);
1655 st_set_nml_var_char (void * var_addr
, char * var_name
, int var_name_len
,
1656 int kind
, gfc_charlen_type string_length
)
1658 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_CHARACTER
,
1663 st_set_nml_var_complex (void * var_addr
, char * var_name
, int var_name_len
,
1666 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_COMPLEX
, 0);
1670 st_set_nml_var_log (void * var_addr
, char * var_name
, int var_name_len
,
1673 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_LOGICAL
, 0);