1 /* Copyright (C) 2002, 2003, 2004 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 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
22 /* transfer.c -- Top level handling of data transfer statements. */
27 #include "libgfortran.h"
31 /* Calling conventions: Data transfer statements are unlike other
32 library calls in that they extend over several calls.
34 The first call is always a call to st_read() or st_write(). These
35 subroutines return no status unless a namelist read or write is
36 being done, in which case there is the usual status. No further
37 calls are necessary in this case.
39 For other sorts of data transfer, there are zero or more data
40 transfer statement that depend on the format of the data transfer
49 These subroutines do not return status.
51 The last call is a call to st_[read|write]_done(). While
52 something can easily go wrong with the initial st_read() or
53 st_write(), an error inhibits any data from actually being
56 gfc_unit
*current_unit
;
57 static int sf_seen_eor
= 0;
59 char scratch
[SCRATCH_SIZE
];
60 static char *line_buffer
= NULL
;
62 static unit_advance advance_status
;
64 static st_option advance_opt
[] = {
71 static void (*transfer
) (bt
, void *, int);
75 { FORMATTED_SEQUENTIAL
, UNFORMATTED_SEQUENTIAL
,
76 FORMATTED_DIRECT
, UNFORMATTED_DIRECT
86 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
88 m
= current_unit
->flags
.form
== FORM_FORMATTED
?
89 FORMATTED_DIRECT
: UNFORMATTED_DIRECT
;
93 m
= current_unit
->flags
.form
== FORM_FORMATTED
?
94 FORMATTED_SEQUENTIAL
: UNFORMATTED_SEQUENTIAL
;
101 /* Mid level data transfer statements. These subroutines do reading
102 and writing in the style of salloc_r()/salloc_w() within the
105 /* When reading sequential formatted records we have a problem. We
106 don't know how long the line is until we read the trailing newline,
107 and we don't want to read too much. If we read too much, we might
108 have to do a physical seek backwards depending on how much data is
109 present, and devices like terminals aren't seekable and would cause
112 Given this, the solution is to read a byte at a time, stopping if
113 we hit the newline. For small locations, we use a static buffer.
114 For larger allocations, we are forced to allocate memory on the
115 heap. Hopefully this won't happen very often. */
118 read_sf (int *length
)
120 static char data
[SCRATCH_SIZE
];
124 if (*length
> SCRATCH_SIZE
)
125 p
= base
= line_buffer
= get_mem (*length
);
129 memset(base
,'\0',*length
);
131 current_unit
->bytes_left
= options
.default_recl
;
137 if (is_internal_unit())
139 /* readlen may be modified inside salloc_r if
140 is_internal_unit() is true. */
144 q
= salloc_r (current_unit
->s
, &readlen
);
148 /* If we have a line without a terminating \n, drop through to
150 if (readlen
< 1 & n
== 0)
152 generate_error (ERROR_END
, NULL
);
156 if (readlen
< 1 || *q
== '\n')
158 /* ??? What is this for? */
159 if (current_unit
->unit_number
== options
.stdin_unit
)
164 /* Unexpected end of line. */
165 if (current_unit
->flags
.pad
== PAD_NO
)
167 generate_error (ERROR_EOR
, NULL
);
171 current_unit
->bytes_left
= 0;
187 /* Function for reading the next couple of bytes from the current
188 file, advancing the current position. We return a pointer to a
189 buffer containing the bytes. We return NULL on end of record or
192 If the read is short, then it is because the current record does not
193 have enough data to satisfy the read request and the file was
194 opened with PAD=YES. The caller must assume tailing spaces for
198 read_block (int *length
)
203 if (current_unit
->flags
.form
== FORM_FORMATTED
&&
204 current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
205 return read_sf (length
); /* Special case. */
207 if (current_unit
->bytes_left
< *length
)
209 if (current_unit
->flags
.pad
== PAD_NO
)
211 generate_error (ERROR_EOR
, NULL
); /* Not enough data left. */
215 *length
= current_unit
->bytes_left
;
218 current_unit
->bytes_left
-= *length
;
221 source
= salloc_r (current_unit
->s
, &nread
);
223 if (ioparm
.size
!= NULL
)
224 *ioparm
.size
+= nread
;
226 if (nread
!= *length
)
227 { /* Short read, this shouldn't happen. */
228 if (current_unit
->flags
.pad
== PAD_YES
)
232 generate_error (ERROR_EOR
, NULL
);
241 /* Function for writing a block of bytes to the current file at the
242 current position, advancing the file pointer. We are given a length
243 and return a pointer to a buffer that the caller must (completely)
244 fill in. Returns NULL on error. */
247 write_block (int length
)
251 if (!is_internal_unit() && current_unit
->bytes_left
< length
)
253 generate_error (ERROR_EOR
, NULL
);
257 current_unit
->bytes_left
-= length
;
258 dest
= salloc_w (current_unit
->s
, &length
);
260 if (ioparm
.size
!= NULL
)
261 *ioparm
.size
+= length
;
267 /* Master function for unformatted reads. */
270 unformatted_read (bt type
, void *dest
, int length
)
275 source
= read_block (&w
);
279 memcpy (dest
, source
, w
);
281 memset (((char *) dest
) + w
, ' ', length
- w
);
285 /* Master function for unformatted writes. */
288 unformatted_write (bt type
, void *source
, int length
)
291 dest
= write_block (length
);
293 memcpy (dest
, source
, length
);
297 /* Return a pointer to the name of a type. */
322 internal_error ("type_name(): Bad type");
329 /* Write a constant string to the output.
330 This is complicated because the string can have doubled delimiters
331 in it. The length in the format node is the true length. */
334 write_constant_string (fnode
* f
)
336 char c
, delimiter
, *p
, *q
;
339 length
= f
->u
.string
.length
;
343 p
= write_block (length
);
350 for (; length
> 0; length
--)
353 if (c
== delimiter
&& c
!= 'H')
354 q
++; /* Skip the doubled delimiter. */
359 /* Given actual and expected types in a formatted data transfer, make
360 sure they agree. If not, an error message is generated. Returns
361 nonzero if something went wrong. */
364 require_type (bt expected
, bt actual
, fnode
* f
)
368 if (actual
== expected
)
371 st_sprintf (buffer
, "Expected %s for item %d in formatted transfer, got %s",
372 type_name (expected
), g
.item_count
, type_name (actual
));
374 format_error (f
, buffer
);
379 /* This subroutine is the main loop for a formatted data transfer
380 statement. It would be natural to implement this as a coroutine
381 with the user program, but C makes that awkward. We loop,
382 processesing format elements. When we actually have to transfer
383 data instead of just setting flags, we return control to the user
384 program which calls a subroutine that supplies the address and type
385 of the next element, then comes back here to process it. */
388 formatted_transfer (bt type
, void *p
, int len
)
393 int consume_data_flag
;
395 /* Change a complex data item into a pair of reals. */
397 n
= (p
== NULL
) ? 0 : ((type
!= BT_COMPLEX
) ? 1 : 2);
398 if (type
== BT_COMPLEX
)
401 /* If reversion has occurred and there is another real data item,
402 then we have to move to the next record. */
404 if (g
.reversion_flag
&& n
> 0)
406 g
.reversion_flag
= 0;
411 consume_data_flag
= 1 ;
412 if (ioparm
.library_return
!= LIBRARY_OK
)
417 return; /* No data descriptors left (already raised). */
424 if (require_type (BT_INTEGER
, type
, f
))
427 if (g
.mode
== READING
)
428 read_decimal (f
, p
, len
);
437 if (require_type (BT_INTEGER
, type
, f
))
440 if (g
.mode
== READING
)
441 read_radix (f
, p
, len
, 2);
451 if (g
.mode
== READING
)
452 read_radix (f
, p
, len
, 8);
462 if (g
.mode
== READING
)
463 read_radix (f
, p
, len
, 16);
472 if (require_type (BT_CHARACTER
, type
, f
))
475 if (g
.mode
== READING
)
486 if (g
.mode
== READING
)
496 if (require_type (BT_REAL
, type
, f
))
499 if (g
.mode
== READING
)
509 if (require_type (BT_REAL
, type
, f
))
512 if (g
.mode
== READING
)
521 if (require_type (BT_REAL
, type
, f
))
524 if (g
.mode
== READING
)
527 write_en (f
, p
, len
);
534 if (require_type (BT_REAL
, type
, f
))
537 if (g
.mode
== READING
)
540 write_es (f
, p
, len
);
547 if (require_type (BT_REAL
, type
, f
))
550 if (g
.mode
== READING
)
560 if (g
.mode
== READING
)
564 read_decimal (f
, p
, len
);
595 internal_error ("formatted_transfer(): Bad type");
601 consume_data_flag
= 0 ;
602 if (g
.mode
== READING
)
604 format_error (f
, "Constant string in input format");
607 write_constant_string (f
);
610 /* Format codes that don't transfer data. */
613 consume_data_flag
= 0 ;
614 if (g
.mode
== READING
)
623 if (f
->format
==FMT_TL
)
626 pos
= current_unit
->recl
- current_unit
->bytes_left
- pos
;
630 consume_data_flag
= 0 ;
634 if (pos
< 0 || pos
>= current_unit
->recl
)
636 generate_error (ERROR_EOR
, "T Or TL edit position error");
639 m
= pos
- (current_unit
->recl
- current_unit
->bytes_left
);
647 if (g
.mode
== READING
)
654 move_pos_offset (current_unit
->s
,m
);
660 consume_data_flag
= 0 ;
661 g
.sign_status
= SIGN_S
;
665 consume_data_flag
= 0 ;
666 g
.sign_status
= SIGN_SS
;
670 consume_data_flag
= 0 ;
671 g
.sign_status
= SIGN_SP
;
675 consume_data_flag
= 0 ;
676 g
.blank_status
= BLANK_NULL
;
680 consume_data_flag
= 0 ;
681 g
.blank_status
= BLANK_ZERO
;
685 consume_data_flag
= 0 ;
686 g
.scale_factor
= f
->u
.k
;
690 consume_data_flag
= 0 ;
695 consume_data_flag
= 0 ;
696 for (i
= 0; i
< f
->repeat
; i
++)
702 /* A colon descriptor causes us to exit this loop (in
703 particular preventing another / descriptor from being
704 processed) unless there is another data item to be
706 consume_data_flag
= 0 ;
712 internal_error ("Bad format node");
715 /* Free a buffer that we had to allocate during a sequential
716 formatted read of a block that was larger than the static
719 if (line_buffer
!= NULL
)
721 free_mem (line_buffer
);
725 /* Adjust the item count and data pointer. */
727 if ((consume_data_flag
> 0) && (n
> 0))
730 p
= ((char *) p
) + len
;
736 /* Come here when we need a data descriptor but don't have one. We
737 push the current format node back onto the input, then return and
738 let the user program call us back with the data. */
746 /* Data transfer entry points. The type of the data entity is
747 implicit in the subroutine call. This prevents us from having to
748 share a common enum with the compiler. */
751 transfer_integer (void *p
, int kind
)
755 if (ioparm
.library_return
!= LIBRARY_OK
)
757 transfer (BT_INTEGER
, p
, kind
);
762 transfer_real (void *p
, int kind
)
766 if (ioparm
.library_return
!= LIBRARY_OK
)
768 transfer (BT_REAL
, p
, kind
);
773 transfer_logical (void *p
, int kind
)
777 if (ioparm
.library_return
!= LIBRARY_OK
)
779 transfer (BT_LOGICAL
, p
, kind
);
784 transfer_character (void *p
, int len
)
788 if (ioparm
.library_return
!= LIBRARY_OK
)
790 transfer (BT_CHARACTER
, p
, len
);
795 transfer_complex (void *p
, int kind
)
799 if (ioparm
.library_return
!= LIBRARY_OK
)
801 transfer (BT_COMPLEX
, p
, kind
);
805 /* Preposition a sequential unformatted file while reading. */
813 n
= sizeof (gfc_offset
);
814 p
= (gfc_offset
*) salloc_r (current_unit
->s
, &n
);
816 if (p
== NULL
|| n
!= sizeof (gfc_offset
))
818 generate_error (ERROR_BAD_US
, NULL
);
822 current_unit
->bytes_left
= *p
;
826 /* Preposition a sequential unformatted file while writing. This
827 amount to writing a bogus length that will be filled in later. */
835 length
= sizeof (gfc_offset
);
836 p
= (gfc_offset
*) salloc_w (current_unit
->s
, &length
);
840 generate_error (ERROR_OS
, NULL
);
844 *p
= 0; /* Bogus value for now. */
845 if (sfree (current_unit
->s
) == FAILURE
)
846 generate_error (ERROR_OS
, NULL
);
848 /* For sequential unformatted, we write until we have more bytes than
849 can fit in the record markers. If disk space runs out first, it will
850 error on the write. */
851 current_unit
->recl
= g
.max_offset
;
853 current_unit
->bytes_left
= current_unit
->recl
;
857 /* Position to the next record prior to transfer. We are assumed to
858 be before the next record. We also calculate the bytes in the next
865 if (current_unit
->current_record
)
866 return; /* Already positioned. */
868 switch (current_mode ())
870 case UNFORMATTED_SEQUENTIAL
:
871 if (g
.mode
== READING
)
878 case FORMATTED_SEQUENTIAL
:
879 case FORMATTED_DIRECT
:
880 case UNFORMATTED_DIRECT
:
881 current_unit
->bytes_left
= current_unit
->recl
;
885 current_unit
->current_record
= 1;
889 /* Initialize things for a data transfer. This code is common for
890 both reading and writing. */
893 data_transfer_init (int read_flag
)
895 unit_flags u_flags
; /* Used for creating a unit if needed. */
897 g
.mode
= read_flag
? READING
: WRITING
;
899 if (ioparm
.size
!= NULL
)
900 *ioparm
.size
= 0; /* Initialize the count. */
902 current_unit
= get_unit (read_flag
);
903 if (current_unit
== NULL
)
904 { /* Open the unit with some default flags. */
905 memset (&u_flags
, '\0', sizeof (u_flags
));
906 u_flags
.access
= ACCESS_SEQUENTIAL
;
907 u_flags
.action
= ACTION_READWRITE
;
908 /* Is it unformatted? */
909 if (ioparm
.format
== NULL
&& !ioparm
.list_format
)
910 u_flags
.form
= FORM_UNFORMATTED
;
912 u_flags
.form
= FORM_UNSPECIFIED
;
913 u_flags
.delim
= DELIM_UNSPECIFIED
;
914 u_flags
.blank
= BLANK_UNSPECIFIED
;
915 u_flags
.pad
= PAD_UNSPECIFIED
;
916 u_flags
.status
= STATUS_UNKNOWN
;
918 current_unit
= get_unit (read_flag
);
921 if (current_unit
== NULL
)
924 if (is_internal_unit())
926 current_unit
->recl
= file_length(current_unit
->s
);
928 empty_internal_buffer (current_unit
->s
);
931 /* Check the action. */
933 if (read_flag
&& current_unit
->flags
.action
== ACTION_WRITE
)
934 generate_error (ERROR_BAD_ACTION
,
935 "Cannot read from file opened for WRITE");
937 if (!read_flag
&& current_unit
->flags
.action
== ACTION_READ
)
938 generate_error (ERROR_BAD_ACTION
, "Cannot write to file opened for READ");
940 if (ioparm
.library_return
!= LIBRARY_OK
)
943 /* Check the format. */
948 if (ioparm
.library_return
!= LIBRARY_OK
)
951 if (current_unit
->flags
.form
== FORM_UNFORMATTED
952 && (ioparm
.format
!= NULL
|| ioparm
.list_format
))
953 generate_error (ERROR_OPTION_CONFLICT
,
954 "Format present for UNFORMATTED data transfer");
956 if (ioparm
.namelist_name
!= NULL
&& ionml
!= NULL
)
958 if(ioparm
.format
!= NULL
)
959 generate_error (ERROR_OPTION_CONFLICT
,
960 "A format cannot be specified with a namelist");
962 else if (current_unit
->flags
.form
== FORM_FORMATTED
&&
963 ioparm
.format
== NULL
&& !ioparm
.list_format
)
964 generate_error (ERROR_OPTION_CONFLICT
,
965 "Missing format for FORMATTED data transfer");
968 if (is_internal_unit () && current_unit
->flags
.form
== FORM_UNFORMATTED
)
969 generate_error (ERROR_OPTION_CONFLICT
,
970 "Internal file cannot be accessed by UNFORMATTED data transfer");
972 /* Check the record number. */
974 if (current_unit
->flags
.access
== ACCESS_DIRECT
&& ioparm
.rec
== 0)
976 generate_error (ERROR_MISSING_OPTION
,
977 "Direct access data transfer requires record number");
981 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
&& ioparm
.rec
!= 0)
983 generate_error (ERROR_OPTION_CONFLICT
,
984 "Record number not allowed for sequential access data transfer");
988 /* Process the ADVANCE option. */
990 advance_status
= (ioparm
.advance
== NULL
) ? ADVANCE_UNSPECIFIED
:
991 find_option (ioparm
.advance
, ioparm
.advance_len
, advance_opt
,
992 "Bad ADVANCE parameter in data transfer statement");
994 if (advance_status
!= ADVANCE_UNSPECIFIED
)
996 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
997 generate_error (ERROR_OPTION_CONFLICT
,
998 "ADVANCE specification conflicts with sequential access");
1000 if (is_internal_unit ())
1001 generate_error (ERROR_OPTION_CONFLICT
,
1002 "ADVANCE specification conflicts with internal file");
1004 if (ioparm
.format
== NULL
|| ioparm
.list_format
)
1005 generate_error (ERROR_OPTION_CONFLICT
,
1006 "ADVANCE specification requires an explicit format");
1011 if (ioparm
.eor
!= 0 && advance_status
== ADVANCE_NO
)
1012 generate_error (ERROR_MISSING_OPTION
,
1013 "EOR specification requires an ADVANCE specification of NO");
1015 if (ioparm
.size
!= NULL
&& advance_status
!= ADVANCE_NO
)
1016 generate_error (ERROR_MISSING_OPTION
,
1017 "SIZE specification requires an ADVANCE specification of NO");
1021 { /* Write constraints. */
1022 if (ioparm
.end
!= 0)
1023 generate_error (ERROR_OPTION_CONFLICT
,
1024 "END specification cannot appear in a write statement");
1026 if (ioparm
.eor
!= 0)
1027 generate_error (ERROR_OPTION_CONFLICT
,
1028 "EOR specification cannot appear in a write statement");
1030 if (ioparm
.size
!= 0)
1031 generate_error (ERROR_OPTION_CONFLICT
,
1032 "SIZE specification cannot appear in a write statement");
1035 if (advance_status
== ADVANCE_UNSPECIFIED
)
1036 advance_status
= ADVANCE_YES
;
1037 if (ioparm
.library_return
!= LIBRARY_OK
)
1040 /* Sanity checks on the record number. */
1044 if (ioparm
.rec
<= 0)
1046 generate_error (ERROR_BAD_OPTION
, "Record number must be positive");
1050 if (ioparm
.rec
>= current_unit
->maxrec
)
1052 generate_error (ERROR_BAD_OPTION
, "Record number too large");
1056 /* Check to see if we might be reading what we wrote before */
1058 if (g
.mode
== READING
&& current_unit
->mode
== WRITING
)
1059 flush(current_unit
->s
);
1061 /* Position the file. */
1062 if (sseek (current_unit
->s
,
1063 (ioparm
.rec
- 1) * current_unit
->recl
) == FAILURE
)
1064 generate_error (ERROR_OS
, NULL
);
1067 current_unit
->mode
= g
.mode
;
1069 /* Set the initial value of flags. */
1071 g
.blank_status
= current_unit
->flags
.blank
;
1072 g
.sign_status
= SIGN_S
;
1081 /* Set up the subroutine that will handle the transfers. */
1085 if (current_unit
->flags
.form
== FORM_UNFORMATTED
)
1086 transfer
= unformatted_read
;
1089 if (ioparm
.list_format
)
1091 transfer
= list_formatted_read
;
1095 transfer
= formatted_transfer
;
1100 if (current_unit
->flags
.form
== FORM_UNFORMATTED
)
1101 transfer
= unformatted_write
;
1104 if (ioparm
.list_format
)
1105 transfer
= list_formatted_write
;
1107 transfer
= formatted_transfer
;
1111 /* Make sure that we don't do a read after a nonadvancing write. */
1115 if (current_unit
->read_bad
)
1117 generate_error (ERROR_BAD_OPTION
,
1118 "Cannot READ after a nonadvancing WRITE");
1124 if (advance_status
== ADVANCE_YES
)
1125 current_unit
->read_bad
= 1;
1128 /* Start the data transfer if we are doing a formatted transfer. */
1129 if (current_unit
->flags
.form
== FORM_FORMATTED
&& !ioparm
.list_format
1130 && ioparm
.namelist_name
== NULL
&& ionml
== NULL
)
1132 formatted_transfer (0, NULL
, 0);
1137 /* Space to the next record for read mode. If the file is not
1138 seekable, we read MAX_READ chunks until we get to the right
1141 #define MAX_READ 4096
1144 next_record_r (int done
)
1146 int rlength
, length
;
1150 switch (current_mode ())
1152 case UNFORMATTED_SEQUENTIAL
:
1153 current_unit
->bytes_left
+= sizeof (gfc_offset
); /* Skip over tail */
1155 /* Fall through... */
1157 case FORMATTED_DIRECT
:
1158 case UNFORMATTED_DIRECT
:
1159 if (current_unit
->bytes_left
== 0)
1162 if (is_seekable (current_unit
->s
))
1164 new = file_position (current_unit
->s
) + current_unit
->bytes_left
;
1166 /* Direct access files do not generate END conditions,
1168 if (sseek (current_unit
->s
, new) == FAILURE
)
1169 generate_error (ERROR_OS
, NULL
);
1173 { /* Seek by reading data. */
1174 while (current_unit
->bytes_left
> 0)
1176 rlength
= length
= (MAX_READ
> current_unit
->bytes_left
) ?
1177 MAX_READ
: current_unit
->bytes_left
;
1179 p
= salloc_r (current_unit
->s
, &rlength
);
1182 generate_error (ERROR_OS
, NULL
);
1186 current_unit
->bytes_left
-= length
;
1192 case FORMATTED_SEQUENTIAL
:
1194 if (sf_seen_eor
&& done
)
1199 p
= salloc_r (current_unit
->s
, &length
);
1201 /* In case of internal file, there may not be any '\n'. */
1202 if (is_internal_unit() && p
== NULL
)
1209 generate_error (ERROR_OS
, NULL
);
1215 current_unit
->endfile
= AT_ENDFILE
;
1224 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1225 test_endfile (current_unit
);
1229 /* Position to the next record in write mode. */
1232 next_record_w (int done
)
1238 switch (current_mode ())
1240 case FORMATTED_DIRECT
:
1241 if (current_unit
->bytes_left
== 0)
1244 length
= current_unit
->bytes_left
;
1245 p
= salloc_w (current_unit
->s
, &length
);
1250 memset (p
, ' ', current_unit
->bytes_left
);
1251 if (sfree (current_unit
->s
) == FAILURE
)
1255 case UNFORMATTED_DIRECT
:
1256 if (sfree (current_unit
->s
) == FAILURE
)
1260 case UNFORMATTED_SEQUENTIAL
:
1261 m
= current_unit
->recl
- current_unit
->bytes_left
; /* Bytes written. */
1262 c
= file_position (current_unit
->s
);
1264 length
= sizeof (gfc_offset
);
1266 /* Write the length tail. */
1268 p
= salloc_w (current_unit
->s
, &length
);
1272 *((gfc_offset
*) p
) = m
;
1273 if (sfree (current_unit
->s
) == FAILURE
)
1276 /* Seek to the head and overwrite the bogus length with the real
1279 p
= salloc_w_at (current_unit
->s
, &length
, c
- m
- length
);
1281 generate_error (ERROR_OS
, NULL
);
1283 *((gfc_offset
*) p
) = m
;
1284 if (sfree (current_unit
->s
) == FAILURE
)
1287 /* Seek past the end of the current record. */
1289 if (sseek (current_unit
->s
, c
+ sizeof (gfc_offset
)) == FAILURE
)
1294 case FORMATTED_SEQUENTIAL
:
1296 p
= salloc_w (current_unit
->s
, &length
);
1298 if (!is_internal_unit())
1301 *p
= '\n'; /* No CR for internal writes. */
1306 if (sfree (current_unit
->s
) == FAILURE
)
1312 generate_error (ERROR_OS
, NULL
);
1318 /* Position to the next record, which means moving to the end of the
1319 current record. This can happen under several different
1320 conditions. If the done flag is not set, we get ready to process
1324 next_record (int done
)
1326 gfc_offset fp
; /* File position. */
1328 current_unit
->read_bad
= 0;
1330 if (g
.mode
== READING
)
1331 next_record_r (done
);
1333 next_record_w (done
);
1335 current_unit
->current_record
= 0;
1336 if (current_unit
->flags
.access
== ACCESS_DIRECT
)
1338 fp
= file_position (current_unit
->s
);
1339 /* Calculate next record, rounding up partial records. */
1340 current_unit
->last_record
= (fp
+ current_unit
->recl
- 1)
1341 / current_unit
->recl
;
1344 current_unit
->last_record
++;
1351 /* Finalize the current data transfer. For a nonadvancing transfer,
1352 this means advancing to the next record. For internal units close the
1353 steam associated with the unit. */
1356 finalize_transfer (void)
1359 if ((ionml
!= NULL
) && (ioparm
.namelist_name
!= NULL
))
1361 if (ioparm
.namelist_read_mode
)
1368 if (current_unit
== NULL
)
1371 if (setjmp (g
.eof_jump
))
1373 generate_error (ERROR_END
, NULL
);
1377 if (ioparm
.list_format
&& g
.mode
== READING
)
1378 finish_list_read ();
1383 if (advance_status
== ADVANCE_NO
)
1385 /* Most systems buffer lines, so force the partial record
1386 to be written out. */
1387 flush (current_unit
->s
);
1392 current_unit
->current_record
= 0;
1395 sfree (current_unit
->s
);
1397 if (is_internal_unit ())
1398 sclose (current_unit
->s
);
1402 /* Transfer function for IOLENGTH. It doesn't actually do any
1403 data transfer, it just updates the length counter. */
1406 iolength_transfer (bt type
, void *dest
, int len
)
1408 if (ioparm
.iolength
!= NULL
)
1409 *ioparm
.iolength
+= len
;
1413 /* Initialize the IOLENGTH data transfer. This function is in essence
1414 a very much simplified version of data_transfer_init(), because it
1415 doesn't have to deal with units at all. */
1418 iolength_transfer_init (void)
1421 if (ioparm
.iolength
!= NULL
)
1422 *ioparm
.iolength
= 0;
1426 /* Set up the subroutine that will handle the transfers. */
1428 transfer
= iolength_transfer
;
1433 /* Library entry point for the IOLENGTH form of the INQUIRE
1434 statement. The IOLENGTH form requires no I/O to be performed, but
1435 it must still be a runtime library call so that we can determine
1436 the iolength for dynamic arrays and such. */
1443 iolength_transfer_init ();
1447 st_iolength_done (void)
1453 /* The READ statement. */
1461 data_transfer_init (1);
1463 /* Handle complications dealing with the endfile record. It is
1464 significant that this is the only place where ERROR_END is
1465 generated. Reading an end of file elsewhere is either end of
1466 record or an I/O error. */
1468 if (current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1469 switch (current_unit
->endfile
)
1475 if (!is_internal_unit())
1477 generate_error (ERROR_END
, NULL
);
1478 current_unit
->endfile
= AFTER_ENDFILE
;
1483 generate_error (ERROR_ENDFILE
, NULL
);
1492 finalize_transfer ();
1503 data_transfer_init (0);
1508 st_write_done (void)
1511 finalize_transfer ();
1513 /* Deal with endfile conditions associated with sequential files. */
1515 if (current_unit
!= NULL
&& current_unit
->flags
.access
== ACCESS_SEQUENTIAL
)
1516 switch (current_unit
->endfile
)
1518 case AT_ENDFILE
: /* Remain at the endfile record. */
1522 current_unit
->endfile
= AT_ENDFILE
; /* Just at it now. */
1525 case NO_ENDFILE
: /* Get rid of whatever is after this record. */
1526 if (struncate (current_unit
->s
) == FAILURE
)
1527 generate_error (ERROR_OS
, NULL
);
1529 current_unit
->endfile
= AT_ENDFILE
;
1538 st_set_nml_var (void * var_addr
, char * var_name
, int var_name_len
,
1539 int kind
, bt type
, int string_length
)
1541 namelist_info
*t1
= NULL
, *t2
= NULL
;
1542 namelist_info
*nml
= (namelist_info
*) get_mem (sizeof (namelist_info
));
1543 nml
->mem_pos
= var_addr
;
1546 assert (var_name_len
> 0);
1547 nml
->var_name
= (char*) get_mem (var_name_len
+1);
1548 strncpy (nml
->var_name
, var_name
, var_name_len
);
1549 nml
->var_name
[var_name_len
] = 0;
1553 assert (var_name_len
== 0);
1554 nml
->var_name
= NULL
;
1559 nml
->string_length
= string_length
;
1578 st_set_nml_var_int (void * var_addr
, char * var_name
, int var_name_len
,
1582 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_INTEGER
, 0);
1586 st_set_nml_var_float (void * var_addr
, char * var_name
, int var_name_len
,
1590 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_REAL
, 0);
1594 st_set_nml_var_char (void * var_addr
, char * var_name
, int var_name_len
,
1595 int kind
, gfc_charlen_type string_length
)
1598 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_CHARACTER
,
1603 st_set_nml_var_complex (void * var_addr
, char * var_name
, int var_name_len
,
1607 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_COMPLEX
, 0);
1611 st_set_nml_var_log (void * var_addr
, char * var_name
, int var_name_len
,
1615 st_set_nml_var (var_addr
, var_name
, var_name_len
, kind
, BT_LOGICAL
, 0);