1 /* Copyright (C) 2002, 2003, 2004, 2005 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 (void *, int);
67 export_proto(transfer_integer);
69 extern void transfer_real (void *, int);
70 export_proto(transfer_real);
72 extern void transfer_logical (void *, int);
73 export_proto(transfer_logical);
75 extern void transfer_character (void *, int);
76 export_proto(transfer_character);
78 extern void transfer_complex (void *, int);
79 export_proto(transfer_complex);
81 extern void transfer_array (gfc_array_char *, int, gfc_charlen_type);
82 export_proto(transfer_array);
84 gfc_unit *current_unit = NULL;
85 static int sf_seen_eor = 0;
86 static int eor_condition = 0;
88 /* Maximum righthand column written to. */
90 /* Number of skips + spaces to be done for T and X-editing. */
92 /* Number of spaces to be done for T and X-editing. */
93 static int pending_spaces;
95 char scratch[SCRATCH_SIZE];
96 static char *line_buffer = NULL;
98 static unit_advance advance_status;
100 static const st_option advance_opt[] = {
101 {"yes", ADVANCE_YES},
107 static void (*transfer) (bt, void *, int, size_t, size_t);
111 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
112 FORMATTED_DIRECT, UNFORMATTED_DIRECT
122 if (current_unit->flags.access == ACCESS_DIRECT)
124 m = current_unit->flags.form == FORM_FORMATTED ?
125 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
129 m = current_unit->flags.form == FORM_FORMATTED ?
130 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
137 /* Mid level data transfer statements. These subroutines do reading
138 and writing in the style of salloc_r()/salloc_w() within the
141 /* When reading sequential formatted records we have a problem. We
142 don't know how long the line is until we read the trailing newline,
143 and we don't want to read too much. If we read too much, we might
144 have to do a physical seek backwards depending on how much data is
145 present, and devices like terminals aren't seekable and would cause
148 Given this, the solution is to read a byte at a time, stopping if
149 we hit the newline. For small locations, we use a static buffer.
150 For larger allocations, we are forced to allocate memory on the
151 heap. Hopefully this won't happen very often. */
154 read_sf (int *length)
156 static char data[SCRATCH_SIZE];
160 if (*length > SCRATCH_SIZE)
161 p = base = line_buffer = get_mem (*length);
165 /* If we have seen an eor previously, return a length of 0. The
166 caller is responsible for correctly padding the input field. */
178 if (is_internal_unit())
180 /* readlen may be modified inside salloc_r if
181 is_internal_unit() is true. */
185 q = salloc_r (current_unit->s, &readlen);
189 /* If we have a line without a terminating \n, drop through to
191 if (readlen < 1 && n == 0)
193 generate_error (ERROR_END, NULL);
197 if (readlen < 1 || *q == '\n' || *q == '\r')
199 /* Unexpected end of line. */
201 /* If we see an EOR during non-advancing I/O, we need to skip
202 the rest of the I/O statement. Set the corresponding flag. */
203 if (advance_status == ADVANCE_NO || g.seen_dollar)
206 /* Without padding, terminate the I/O statement without assigning
207 the value. With padding, the value still needs to be assigned,
208 so we can just continue with a short read. */
209 if (current_unit->flags.pad == PAD_NO)
211 generate_error (ERROR_EOR, NULL);
215 current_unit->bytes_left = 0;
226 current_unit->bytes_left -= *length;
228 if (ioparm.size != NULL)
229 *ioparm.size += *length;
235 /* Function for reading the next couple of bytes from the current
236 file, advancing the current position. We return a pointer to a
237 buffer containing the bytes. We return NULL on end of record or
240 If the read is short, then it is because the current record does not
241 have enough data to satisfy the read request and the file was
242 opened with PAD=YES. The caller must assume tailing spaces for
246 read_block (int *length)
251 if (current_unit->bytes_left < *length)
253 if (current_unit->flags.pad == PAD_NO)
255 generate_error (ERROR_EOR, NULL); /* Not enough data left. */
259 *length = current_unit->bytes_left;
262 if (current_unit->flags.form == FORM_FORMATTED &&
263 current_unit->flags.access == ACCESS_SEQUENTIAL)
264 return read_sf (length); /* Special case. */
266 current_unit->bytes_left -= *length;
269 source = salloc_r (current_unit->s, &nread);
271 if (ioparm.size != NULL)
272 *ioparm.size += nread;
274 if (nread != *length)
275 { /* Short read, this shouldn't happen. */
276 if (current_unit->flags.pad == PAD_YES)
280 generate_error (ERROR_EOR, NULL);
289 /* Reads a block directly into application data space. */
292 read_block_direct (void * buf, size_t * nbytes)
298 if (current_unit->bytes_left < *nbytes)
300 if (current_unit->flags.pad == PAD_NO)
302 generate_error (ERROR_EOR, NULL); /* Not enough data left. */
306 *nbytes = current_unit->bytes_left;
309 if (current_unit->flags.form == FORM_FORMATTED &&
310 current_unit->flags.access == ACCESS_SEQUENTIAL)
312 length = (int*) nbytes;
313 data = read_sf (length); /* Special case. */
314 memcpy (buf, data, (size_t) *length);
318 current_unit->bytes_left -= *nbytes;
321 if (sread (current_unit->s, buf, &nread) != 0)
323 generate_error (ERROR_OS, NULL);
327 if (ioparm.size != NULL)
328 *ioparm.size += (GFC_INTEGER_4) nread;
330 if (nread != *nbytes)
331 { /* Short read, e.g. if we hit EOF. */
332 if (current_unit->flags.pad == PAD_YES)
334 memset (((char *) buf) + nread, ' ', *nbytes - nread);
338 generate_error (ERROR_EOR, NULL);
343 /* Function for writing a block of bytes to the current file at the
344 current position, advancing the file pointer. We are given a length
345 and return a pointer to a buffer that the caller must (completely)
346 fill in. Returns NULL on error. */
349 write_block (int length)
353 if (current_unit->bytes_left < length)
355 generate_error (ERROR_EOR, NULL);
359 current_unit->bytes_left -= (gfc_offset)length;
360 dest = salloc_w (current_unit->s, &length);
364 generate_error (ERROR_END, NULL);
368 if (ioparm.size != NULL)
369 *ioparm.size += length;
375 /* Writes a block directly without necessarily allocating space in a
379 write_block_direct (void * buf, size_t * nbytes)
381 if (current_unit->bytes_left < *nbytes)
382 generate_error (ERROR_EOR, NULL);
384 current_unit->bytes_left -= (gfc_offset) *nbytes;
386 if (swrite (current_unit->s, buf, nbytes) != 0)
387 generate_error (ERROR_OS, NULL);
389 if (ioparm.size != NULL)
390 *ioparm.size += (GFC_INTEGER_4) *nbytes;
394 /* Master function for unformatted reads. */
397 unformatted_read (bt type __attribute__((unused)), void *dest,
398 int kind __attribute__((unused)),
399 size_t size, size_t nelems)
403 read_block_direct (dest, &size);
407 /* Master function for unformatted writes. */
410 unformatted_write (bt type __attribute__((unused)), void *source,
411 int kind __attribute__((unused)),
412 size_t size, size_t nelems)
416 write_block_direct (source, &size);
420 /* Return a pointer to the name of a type. */
445 internal_error ("type_name(): Bad type");
452 /* Write a constant string to the output.
453 This is complicated because the string can have doubled delimiters
454 in it. The length in the format node is the true length. */
457 write_constant_string (fnode * f)
459 char c, delimiter, *p, *q;
462 length = f->u.string.length;
466 p = write_block (length);
473 for (; length > 0; length--)
476 if (c == delimiter && c != 'H' && c != 'h')
477 q++; /* Skip the doubled delimiter. */
482 /* Given actual and expected types in a formatted data transfer, make
483 sure they agree. If not, an error message is generated. Returns
484 nonzero if something went wrong. */
487 require_type (bt expected, bt actual, fnode * f)
491 if (actual == expected)
494 st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
495 type_name (expected), g.item_count, type_name (actual));
497 format_error (f, buffer);
502 /* This subroutine is the main loop for a formatted data transfer
503 statement. It would be natural to implement this as a coroutine
504 with the user program, but C makes that awkward. We loop,
505 processesing format elements. When we actually have to transfer
506 data instead of just setting flags, we return control to the user
507 program which calls a subroutine that supplies the address and type
508 of the next element, then comes back here to process it. */
511 formatted_transfer_scalar (bt type, void *p, int len, size_t size)
517 int consume_data_flag;
519 /* Change a complex data item into a pair of reals. */
521 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
522 if (type == BT_COMPLEX)
528 /* If there's an EOR condition, we simulate finalizing the transfer
535 /* If reversion has occurred and there is another real data item,
536 then we have to move to the next record. */
537 if (g.reversion_flag && n > 0)
539 g.reversion_flag = 0;
543 consume_data_flag = 1 ;
544 if (ioparm.library_return != LIBRARY_OK)
549 return; /* No data descriptors left (already raised). */
551 /* Now discharge T, TR and X movements to the right. This is delayed
552 until a data producing format to suppress trailing spaces. */
554 if (g.mode == WRITING && skips != 0
555 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
556 || t == FMT_Z || t == FMT_F || t == FMT_E
557 || t == FMT_EN || t == FMT_ES || t == FMT_G
558 || t == FMT_L || t == FMT_A || t == FMT_D))
563 write_x (skips, pending_spaces);
564 max_pos = (int)(current_unit->recl - current_unit->bytes_left);
568 move_pos_offset (current_unit->s, skips);
569 current_unit->bytes_left -= (gfc_offset)skips;
571 skips = pending_spaces = 0;
574 bytes_used = (int)(current_unit->recl - current_unit->bytes_left);
581 if (require_type (BT_INTEGER, type, f))
584 if (g.mode == READING)
585 read_decimal (f, p, len);
594 if (require_type (BT_INTEGER, type, f))
597 if (g.mode == READING)
598 read_radix (f, p, len, 2);
608 if (g.mode == READING)
609 read_radix (f, p, len, 8);
619 if (g.mode == READING)
620 read_radix (f, p, len, 16);
630 if (g.mode == READING)
641 if (g.mode == READING)
651 if (require_type (BT_REAL, type, f))
654 if (g.mode == READING)
664 if (require_type (BT_REAL, type, f))
667 if (g.mode == READING)
676 if (require_type (BT_REAL, type, f))
679 if (g.mode == READING)
682 write_en (f, p, len);
689 if (require_type (BT_REAL, type, f))
692 if (g.mode == READING)
695 write_es (f, p, len);
702 if (require_type (BT_REAL, type, f))
705 if (g.mode == READING)
715 if (g.mode == READING)
719 read_decimal (f, p, len);
750 internal_error ("formatted_transfer(): Bad type");
756 consume_data_flag = 0 ;
757 if (g.mode == READING)
759 format_error (f, "Constant string in input format");
762 write_constant_string (f);
765 /* Format codes that don't transfer data. */
768 consume_data_flag = 0 ;
770 pos = bytes_used + f->u.n + skips;
771 skips = f->u.n + skips;
772 pending_spaces = pos - max_pos;
774 /* Writes occur just before the switch on f->format, above, so that
775 trailing blanks are suppressed. */
776 if (g.mode == READING)
783 if (f->format == FMT_TL)
784 pos = bytes_used - f->u.n;
787 consume_data_flag = 0;
791 /* Standard 10.6.1.1: excessive left tabbing is reset to the
792 left tab limit. We do not check if the position has gone
793 beyond the end of record because a subsequent tab could
794 bring us back again. */
795 pos = pos < 0 ? 0 : pos;
797 skips = skips + pos - bytes_used;
798 pending_spaces = pending_spaces + pos - max_pos;
803 /* Writes occur just before the switch on f->format, above, so that
804 trailing blanks are suppressed. */
805 if (g.mode == READING)
811 move_pos_offset (current_unit->s, skips);
812 current_unit->bytes_left -= (gfc_offset)skips;
813 skips = pending_spaces = 0;
820 consume_data_flag = 0 ;
821 g.sign_status = SIGN_S;
825 consume_data_flag = 0 ;
826 g.sign_status = SIGN_SS;
830 consume_data_flag = 0 ;
831 g.sign_status = SIGN_SP;
835 consume_data_flag = 0 ;
836 g.blank_status = BLANK_NULL;
840 consume_data_flag = 0 ;
841 g.blank_status = BLANK_ZERO;
845 consume_data_flag = 0 ;
846 g.scale_factor = f->u.k;
850 consume_data_flag = 0 ;
855 consume_data_flag = 0 ;
856 skips = pending_spaces = 0;
861 /* A colon descriptor causes us to exit this loop (in
862 particular preventing another / descriptor from being
863 processed) unless there is another data item to be
865 consume_data_flag = 0 ;
871 internal_error ("Bad format node");
874 /* Free a buffer that we had to allocate during a sequential
875 formatted read of a block that was larger than the static
878 if (line_buffer != NULL)
880 free_mem (line_buffer);
884 /* Adjust the item count and data pointer. */
886 if ((consume_data_flag > 0) && (n > 0))
889 p = ((char *) p) + size;
892 if (g.mode == READING)
895 pos = (int)(current_unit->recl - current_unit->bytes_left);
896 max_pos = (max_pos > pos) ? max_pos : pos;
902 /* Come here when we need a data descriptor but don't have one. We
903 push the current format node back onto the input, then return and
904 let the user program call us back with the data. */
910 formatted_transfer (bt type, void *p, int kind, size_t size, size_t nelems)
917 /* Big loop over all the elements. */
918 for (elem = 0; elem < nelems; elem++)
921 formatted_transfer_scalar (type, tmp + size*elem, kind, size);
927 /* Data transfer entry points. The type of the data entity is
928 implicit in the subroutine call. This prevents us from having to
929 share a common enum with the compiler. */
932 transfer_integer (void *p, int kind)
934 if (ioparm.library_return != LIBRARY_OK)
936 transfer (BT_INTEGER, p, kind, kind, 1);
941 transfer_real (void *p, int kind)
944 if (ioparm.library_return != LIBRARY_OK)
946 size = size_from_real_kind (kind);
947 transfer (BT_REAL, p, kind, size, 1);
952 transfer_logical (void *p, int kind)
954 if (ioparm.library_return != LIBRARY_OK)
956 transfer (BT_LOGICAL, p, kind, kind, 1);
961 transfer_character (void *p, int len)
963 if (ioparm.library_return != LIBRARY_OK)
965 /* Currently we support only 1 byte chars, and the library is a bit
966 confused of character kind vs. length, so we kludge it by setting
968 transfer (BT_CHARACTER, p, len, len, 1);
973 transfer_complex (void *p, int kind)
976 if (ioparm.library_return != LIBRARY_OK)
978 size = size_from_complex_kind (kind);
979 transfer (BT_COMPLEX, p, kind, size, 1);
984 transfer_array (gfc_array_char *desc, int kind, gfc_charlen_type charlen)
986 index_type count[GFC_MAX_DIMENSIONS];
987 index_type extent[GFC_MAX_DIMENSIONS];
988 index_type stride[GFC_MAX_DIMENSIONS];
989 index_type stride0, rank, size, type, n;
994 if (ioparm.library_return != LIBRARY_OK)
997 type = GFC_DESCRIPTOR_TYPE (desc);
998 size = GFC_DESCRIPTOR_SIZE (desc);
1000 /* FIXME: What a kludge: Array descriptors and the IO library use
1001 different enums for types. */
1004 case GFC_DTYPE_UNKNOWN:
1005 iotype = BT_NULL; /* Is this correct? */
1007 case GFC_DTYPE_INTEGER:
1008 iotype = BT_INTEGER;
1010 case GFC_DTYPE_LOGICAL:
1011 iotype = BT_LOGICAL;
1013 case GFC_DTYPE_REAL:
1016 case GFC_DTYPE_COMPLEX:
1017 iotype = BT_COMPLEX;
1019 case GFC_DTYPE_CHARACTER:
1020 iotype = BT_CHARACTER;
1021 /* FIXME: Currently dtype contains the charlen, which is
1022 clobbered if charlen > 2**24. That's why we use a separate
1023 argument for the charlen. However, if we want to support
1024 non-8-bit charsets we need to fix dtype to contain
1025 sizeof(chartype) and fix the code below. */
1029 case GFC_DTYPE_DERIVED:
1030 internal_error ("Derived type I/O should have been handled via the frontend.");
1033 internal_error ("transfer_array(): Bad type");
1036 if (desc->dim[0].stride == 0)
1037 desc->dim[0].stride = 1;
1039 rank = GFC_DESCRIPTOR_RANK (desc);
1040 for (n = 0; n < rank; n++)
1043 stride[n] = desc->dim[n].stride;
1044 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1046 /* If the extent of even one dimension is zero, then the entire
1047 array section contains zero elements, so we return. */
1052 stride0 = stride[0];
1054 /* If the innermost dimension has stride 1, we can do the transfer
1055 in contiguous chunks. */
1061 data = GFC_DESCRIPTOR_DATA (desc);
1065 transfer (iotype, data, kind, size, tsize);
1066 data += stride0 * size * tsize;
1069 while (count[n] == extent[n])
1072 data -= stride[n] * extent[n] * size;
1082 data += stride[n] * size;
1089 /* Preposition a sequential unformatted file while reading. */
1098 n = sizeof (gfc_offset);
1099 p = salloc_r (current_unit->s, &n);
1102 return; /* end of file */
1104 if (p == NULL || n != sizeof (gfc_offset))
1106 generate_error (ERROR_BAD_US, NULL);
1110 memcpy (&i, p, sizeof (gfc_offset));
1111 current_unit->bytes_left = i;
1115 /* Preposition a sequential unformatted file while writing. This
1116 amount to writing a bogus length that will be filled in later. */
1124 length = sizeof (gfc_offset);
1125 p = salloc_w (current_unit->s, &length);
1129 generate_error (ERROR_OS, NULL);
1133 memset (p, '\0', sizeof (gfc_offset)); /* Bogus value for now. */
1134 if (sfree (current_unit->s) == FAILURE)
1135 generate_error (ERROR_OS, NULL);
1137 /* For sequential unformatted, we write until we have more bytes than
1138 can fit in the record markers. If disk space runs out first, it will
1139 error on the write. */
1140 current_unit->recl = g.max_offset;
1142 current_unit->bytes_left = current_unit->recl;
1146 /* Position to the next record prior to transfer. We are assumed to
1147 be before the next record. We also calculate the bytes in the next
1153 if (current_unit->current_record)
1154 return; /* Already positioned. */
1156 switch (current_mode ())
1158 case UNFORMATTED_SEQUENTIAL:
1159 if (g.mode == READING)
1166 case FORMATTED_SEQUENTIAL:
1167 case FORMATTED_DIRECT:
1168 case UNFORMATTED_DIRECT:
1169 current_unit->bytes_left = current_unit->recl;
1173 current_unit->current_record = 1;
1177 /* Initialize things for a data transfer. This code is common for
1178 both reading and writing. */
1181 data_transfer_init (int read_flag)
1183 unit_flags u_flags; /* Used for creating a unit if needed. */
1185 g.mode = read_flag ? READING : WRITING;
1187 if (ioparm.size != NULL)
1188 *ioparm.size = 0; /* Initialize the count. */
1190 current_unit = get_unit (read_flag);
1191 if (current_unit == NULL)
1192 { /* Open the unit with some default flags. */
1193 if (ioparm.unit < 0)
1195 generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
1199 memset (&u_flags, '\0', sizeof (u_flags));
1200 u_flags.access = ACCESS_SEQUENTIAL;
1201 u_flags.action = ACTION_READWRITE;
1202 /* Is it unformatted? */
1203 if (ioparm.format == NULL && !ioparm.list_format)
1204 u_flags.form = FORM_UNFORMATTED;
1206 u_flags.form = FORM_UNSPECIFIED;
1207 u_flags.delim = DELIM_UNSPECIFIED;
1208 u_flags.blank = BLANK_UNSPECIFIED;
1209 u_flags.pad = PAD_UNSPECIFIED;
1210 u_flags.status = STATUS_UNKNOWN;
1212 current_unit = get_unit (read_flag);
1215 if (current_unit == NULL)
1218 /* Check the action. */
1220 if (read_flag && current_unit->flags.action == ACTION_WRITE)
1221 generate_error (ERROR_BAD_ACTION,
1222 "Cannot read from file opened for WRITE");
1224 if (!read_flag && current_unit->flags.action == ACTION_READ)
1225 generate_error (ERROR_BAD_ACTION, "Cannot write to file opened for READ");
1227 if (ioparm.library_return != LIBRARY_OK)
1230 /* Check the format. */
1235 if (ioparm.library_return != LIBRARY_OK)
1238 if (current_unit->flags.form == FORM_UNFORMATTED
1239 && (ioparm.format != NULL || ioparm.list_format))
1240 generate_error (ERROR_OPTION_CONFLICT,
1241 "Format present for UNFORMATTED data transfer");
1243 if (ioparm.namelist_name != NULL && ionml != NULL)
1245 if(ioparm.format != NULL)
1246 generate_error (ERROR_OPTION_CONFLICT,
1247 "A format cannot be specified with a namelist");
1249 else if (current_unit->flags.form == FORM_FORMATTED &&
1250 ioparm.format == NULL && !ioparm.list_format)
1251 generate_error (ERROR_OPTION_CONFLICT,
1252 "Missing format for FORMATTED data transfer");
1255 if (is_internal_unit () && current_unit->flags.form == FORM_UNFORMATTED)
1256 generate_error (ERROR_OPTION_CONFLICT,
1257 "Internal file cannot be accessed by UNFORMATTED data transfer");
1259 /* Check the record number. */
1261 if (current_unit->flags.access == ACCESS_DIRECT && ioparm.rec == 0)
1263 generate_error (ERROR_MISSING_OPTION,
1264 "Direct access data transfer requires record number");
1268 if (current_unit->flags.access == ACCESS_SEQUENTIAL && ioparm.rec != 0)
1270 generate_error (ERROR_OPTION_CONFLICT,
1271 "Record number not allowed for sequential access data transfer");
1275 /* Process the ADVANCE option. */
1277 advance_status = (ioparm.advance == NULL) ? ADVANCE_UNSPECIFIED :
1278 find_option (ioparm.advance, ioparm.advance_len, advance_opt,
1279 "Bad ADVANCE parameter in data transfer statement");
1281 if (advance_status != ADVANCE_UNSPECIFIED)
1283 if (current_unit->flags.access == ACCESS_DIRECT)
1284 generate_error (ERROR_OPTION_CONFLICT,
1285 "ADVANCE specification conflicts with sequential access");
1287 if (is_internal_unit ())
1288 generate_error (ERROR_OPTION_CONFLICT,
1289 "ADVANCE specification conflicts with internal file");
1291 if (ioparm.format == NULL || ioparm.list_format)
1292 generate_error (ERROR_OPTION_CONFLICT,
1293 "ADVANCE specification requires an explicit format");
1298 if (ioparm.eor != 0 && advance_status != ADVANCE_NO)
1299 generate_error (ERROR_MISSING_OPTION,
1300 "EOR specification requires an ADVANCE specification of NO");
1302 if (ioparm.size != NULL && advance_status != ADVANCE_NO)
1303 generate_error (ERROR_MISSING_OPTION,
1304 "SIZE specification requires an ADVANCE specification of NO");
1308 { /* Write constraints. */
1309 if (ioparm.end != 0)
1310 generate_error (ERROR_OPTION_CONFLICT,
1311 "END specification cannot appear in a write statement");
1313 if (ioparm.eor != 0)
1314 generate_error (ERROR_OPTION_CONFLICT,
1315 "EOR specification cannot appear in a write statement");
1317 if (ioparm.size != 0)
1318 generate_error (ERROR_OPTION_CONFLICT,
1319 "SIZE specification cannot appear in a write statement");
1322 if (advance_status == ADVANCE_UNSPECIFIED)
1323 advance_status = ADVANCE_YES;
1324 if (ioparm.library_return != LIBRARY_OK)
1327 /* Sanity checks on the record number. */
1331 if (ioparm.rec <= 0)
1333 generate_error (ERROR_BAD_OPTION, "Record number must be positive");
1337 if (ioparm.rec >= current_unit->maxrec)
1339 generate_error (ERROR_BAD_OPTION, "Record number too large");
1343 /* Check to see if we might be reading what we wrote before */
1345 if (g.mode == READING && current_unit->mode == WRITING)
1346 flush(current_unit->s);
1348 /* Check whether the record exists to be read. Only
1349 a partial record needs to exist. */
1351 if (g.mode == READING && (ioparm.rec -1)
1352 * current_unit->recl >= file_length (current_unit->s))
1354 generate_error (ERROR_BAD_OPTION, "Non-existing record number");
1358 /* Position the file. */
1359 if (sseek (current_unit->s,
1360 (ioparm.rec - 1) * current_unit->recl) == FAILURE)
1362 generate_error (ERROR_OS, NULL);
1367 /* Overwriting an existing sequential file ?
1368 it is always safe to truncate the file on the first write */
1369 if (g.mode == WRITING
1370 && current_unit->flags.access == ACCESS_SEQUENTIAL
1371 && current_unit->last_record == 0 && !is_preconnected(current_unit->s))
1372 struncate(current_unit->s);
1374 /* Bugware for badly written mixed C-Fortran I/O. */
1375 flush_if_preconnected(current_unit->s);
1377 current_unit->mode = g.mode;
1379 /* Set the initial value of flags. */
1381 g.blank_status = current_unit->flags.blank;
1382 g.sign_status = SIGN_S;
1392 /* Set up the subroutine that will handle the transfers. */
1396 if (current_unit->flags.form == FORM_UNFORMATTED)
1397 transfer = unformatted_read;
1400 if (ioparm.list_format)
1402 transfer = list_formatted_read;
1406 transfer = formatted_transfer;
1411 if (current_unit->flags.form == FORM_UNFORMATTED)
1412 transfer = unformatted_write;
1415 if (ioparm.list_format)
1416 transfer = list_formatted_write;
1418 transfer = formatted_transfer;
1422 /* Make sure that we don't do a read after a nonadvancing write. */
1426 if (current_unit->read_bad)
1428 generate_error (ERROR_BAD_OPTION,
1429 "Cannot READ after a nonadvancing WRITE");
1435 if (advance_status == ADVANCE_YES && !g.seen_dollar)
1436 current_unit->read_bad = 1;
1439 /* Reset counters for T and X-editing. */
1440 max_pos = skips = pending_spaces = 0;
1442 /* Start the data transfer if we are doing a formatted transfer. */
1443 if (current_unit->flags.form == FORM_FORMATTED && !ioparm.list_format
1444 && ioparm.namelist_name == NULL && ionml == NULL)
1445 formatted_transfer (0, NULL, 0, 0, 1);
1448 /* Initialize an array_loop_spec given the array descriptor. The function
1449 returns the index of the last element of the array. */
1452 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1454 int rank = GFC_DESCRIPTOR_RANK(desc);
1459 for (i=0; i<rank; i++)
1462 ls[i].start = desc->dim[i].lbound;
1463 ls[i].end = desc->dim[i].ubound;
1464 ls[i].step = desc->dim[i].stride;
1466 index += (desc->dim[i].ubound - desc->dim[i].lbound)
1467 * desc->dim[i].stride;
1472 /* Determine the index to the next record in an internal unit array by
1473 by incrementing through the array_loop_spec. TODO: Implement handling
1474 negative strides. */
1477 next_array_record ( array_loop_spec * ls )
1485 for (i = 0; i < current_unit->rank; i++)
1490 if (ls[i].idx > ls[i].end)
1492 ls[i].idx = ls[i].start;
1498 index = index + (ls[i].idx - 1) * ls[i].step;
1503 /* Space to the next record for read mode. If the file is not
1504 seekable, we read MAX_READ chunks until we get to the right
1507 #define MAX_READ 4096
1510 next_record_r (void)
1512 gfc_offset new, record;
1513 int bytes_left, rlength, length;
1516 switch (current_mode ())
1518 case UNFORMATTED_SEQUENTIAL:
1519 current_unit->bytes_left += sizeof (gfc_offset); /* Skip over tail */
1521 /* Fall through... */
1523 case FORMATTED_DIRECT:
1524 case UNFORMATTED_DIRECT:
1525 if (current_unit->bytes_left == 0)
1528 if (is_seekable (current_unit->s))
1530 new = file_position (current_unit->s) + current_unit->bytes_left;
1532 /* Direct access files do not generate END conditions,
1534 if (sseek (current_unit->s, new) == FAILURE)
1535 generate_error (ERROR_OS, NULL);
1539 { /* Seek by reading data. */
1540 while (current_unit->bytes_left > 0)
1542 rlength = length = (MAX_READ > current_unit->bytes_left) ?
1543 MAX_READ : current_unit->bytes_left;
1545 p = salloc_r (current_unit->s, &rlength);
1548 generate_error (ERROR_OS, NULL);
1552 current_unit->bytes_left -= length;
1557 case FORMATTED_SEQUENTIAL:
1559 /* sf_read has already terminated input because of an '\n' */
1566 if (is_internal_unit())
1570 record = next_array_record (current_unit->ls);
1572 /* Now seek to this record. */
1573 record = record * current_unit->recl;
1574 if (sseek (current_unit->s, record) == FAILURE)
1576 generate_error (ERROR_OS, NULL);
1579 current_unit->bytes_left = current_unit->recl;
1583 bytes_left = (int) current_unit->bytes_left;
1584 p = salloc_r (current_unit->s, &bytes_left);
1586 current_unit->bytes_left = current_unit->recl;
1592 p = salloc_r (current_unit->s, &length);
1596 generate_error (ERROR_OS, NULL);
1602 current_unit->endfile = AT_ENDFILE;
1611 if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1612 test_endfile (current_unit);
1616 /* Position to the next record in write mode. */
1619 next_record_w (void)
1621 gfc_offset c, m, record;
1622 int bytes_left, length;
1625 /* Zero counters for X- and T-editing. */
1626 max_pos = skips = pending_spaces = 0;
1628 switch (current_mode ())
1630 case FORMATTED_DIRECT:
1631 if (current_unit->bytes_left == 0)
1634 length = current_unit->bytes_left;
1635 p = salloc_w (current_unit->s, &length);
1640 memset (p, ' ', current_unit->bytes_left);
1641 if (sfree (current_unit->s) == FAILURE)
1645 case UNFORMATTED_DIRECT:
1646 if (sfree (current_unit->s) == FAILURE)
1650 case UNFORMATTED_SEQUENTIAL:
1651 m = current_unit->recl - current_unit->bytes_left; /* Bytes written. */
1652 c = file_position (current_unit->s);
1654 length = sizeof (gfc_offset);
1656 /* Write the length tail. */
1658 p = salloc_w (current_unit->s, &length);
1662 memcpy (p, &m, sizeof (gfc_offset));
1663 if (sfree (current_unit->s) == FAILURE)
1666 /* Seek to the head and overwrite the bogus length with the real
1669 p = salloc_w_at (current_unit->s, &length, c - m - length);
1671 generate_error (ERROR_OS, NULL);
1673 memcpy (p, &m, sizeof (gfc_offset));
1674 if (sfree (current_unit->s) == FAILURE)
1677 /* Seek past the end of the current record. */
1679 if (sseek (current_unit->s, c + sizeof (gfc_offset)) == FAILURE)
1684 case FORMATTED_SEQUENTIAL:
1686 if (current_unit->bytes_left == 0)
1689 if (is_internal_unit())
1693 bytes_left = (int) current_unit->bytes_left;
1694 p = salloc_w (current_unit->s, &bytes_left);
1697 generate_error (ERROR_END, NULL);
1700 memset(p, ' ', bytes_left);
1702 /* Now that the current record has been padded out,
1703 determine where the next record in the array is. */
1705 record = next_array_record (current_unit->ls);
1707 /* Now seek to this record */
1708 record = record * current_unit->recl;
1710 if (sseek (current_unit->s, record) == FAILURE)
1713 current_unit->bytes_left = current_unit->recl;
1718 p = salloc_w (current_unit->s, &length);
1730 p = salloc_w (current_unit->s, &length);
1732 { /* No new line for internal writes. */
1747 generate_error (ERROR_OS, NULL);
1752 /* Position to the next record, which means moving to the end of the
1753 current record. This can happen under several different
1754 conditions. If the done flag is not set, we get ready to process
1758 next_record (int done)
1760 gfc_offset fp; /* File position. */
1762 current_unit->read_bad = 0;
1764 if (g.mode == READING)
1769 /* keep position up to date for INQUIRE */
1770 current_unit->flags.position = POSITION_ASIS;
1772 current_unit->current_record = 0;
1773 if (current_unit->flags.access == ACCESS_DIRECT)
1775 fp = file_position (current_unit->s);
1776 /* Calculate next record, rounding up partial records. */
1777 current_unit->last_record = (fp + current_unit->recl - 1)
1778 / current_unit->recl;
1781 current_unit->last_record++;
1788 /* Finalize the current data transfer. For a nonadvancing transfer,
1789 this means advancing to the next record. For internal units close the
1790 stream associated with the unit. */
1793 finalize_transfer (void)
1798 generate_error (ERROR_EOR, NULL);
1802 if (ioparm.library_return != LIBRARY_OK)
1805 if ((ionml != NULL) && (ioparm.namelist_name != NULL))
1807 if (ioparm.namelist_read_mode)
1814 if (current_unit == NULL)
1817 if (setjmp (g.eof_jump))
1819 generate_error (ERROR_END, NULL);
1823 if (ioparm.list_format && g.mode == READING)
1824 finish_list_read ();
1829 if (advance_status == ADVANCE_NO || g.seen_dollar)
1831 /* Most systems buffer lines, so force the partial record
1832 to be written out. */
1833 flush (current_unit->s);
1839 current_unit->current_record = 0;
1842 sfree (current_unit->s);
1844 if (is_internal_unit ())
1846 if (is_array_io() && current_unit->ls != NULL)
1847 free_mem (current_unit->ls);
1848 sclose (current_unit->s);
1853 /* Transfer function for IOLENGTH. It doesn't actually do any
1854 data transfer, it just updates the length counter. */
1857 iolength_transfer (bt type __attribute__((unused)),
1858 void *dest __attribute__ ((unused)),
1859 int kind __attribute__((unused)),
1860 size_t size, size_t nelems)
1862 if (ioparm.iolength != NULL)
1863 *ioparm.iolength += (GFC_INTEGER_4) size * nelems;
1867 /* Initialize the IOLENGTH data transfer. This function is in essence
1868 a very much simplified version of data_transfer_init(), because it
1869 doesn't have to deal with units at all. */
1872 iolength_transfer_init (void)
1874 if (ioparm.iolength != NULL)
1875 *ioparm.iolength = 0;
1879 /* Set up the subroutine that will handle the transfers. */
1881 transfer = iolength_transfer;
1885 /* Library entry point for the IOLENGTH form of the INQUIRE
1886 statement. The IOLENGTH form requires no I/O to be performed, but
1887 it must still be a runtime library call so that we can determine
1888 the iolength for dynamic arrays and such. */
1890 extern void st_iolength (void);
1891 export_proto(st_iolength);
1897 iolength_transfer_init ();
1900 extern void st_iolength_done (void);
1901 export_proto(st_iolength_done);
1904 st_iolength_done (void)
1910 /* The READ statement. */
1912 extern void st_read (void);
1913 export_proto(st_read);
1921 data_transfer_init (1);
1923 /* Handle complications dealing with the endfile record. It is
1924 significant that this is the only place where ERROR_END is
1925 generated. Reading an end of file elsewhere is either end of
1926 record or an I/O error. */
1928 if (current_unit->flags.access == ACCESS_SEQUENTIAL)
1929 switch (current_unit->endfile)
1935 if (!is_internal_unit())
1937 generate_error (ERROR_END, NULL);
1938 current_unit->endfile = AFTER_ENDFILE;
1943 generate_error (ERROR_ENDFILE, NULL);
1948 extern void st_read_done (void);
1949 export_proto(st_read_done);
1954 finalize_transfer ();
1958 extern void st_write (void);
1959 export_proto(st_write);
1966 data_transfer_init (0);
1969 extern void st_write_done (void);
1970 export_proto(st_write_done);
1973 st_write_done (void)
1975 finalize_transfer ();
1977 /* Deal with endfile conditions associated with sequential files. */
1979 if (current_unit != NULL && current_unit->flags.access == ACCESS_SEQUENTIAL)
1980 switch (current_unit->endfile)
1982 case AT_ENDFILE: /* Remain at the endfile record. */
1986 current_unit->endfile = AT_ENDFILE; /* Just at it now. */
1990 if (current_unit->current_record > current_unit->last_record)
1992 /* Get rid of whatever is after this record. */
1993 if (struncate (current_unit->s) == FAILURE)
1994 generate_error (ERROR_OS, NULL);
1997 current_unit->endfile = AT_ENDFILE;
2004 /* Receives the scalar information for namelist objects and stores it
2005 in a linked list of namelist_info types. */
2007 extern void st_set_nml_var (void * ,char * ,
2008 GFC_INTEGER_4 ,gfc_charlen_type ,GFC_INTEGER_4);
2009 export_proto(st_set_nml_var);
2013 st_set_nml_var (void * var_addr, char * var_name, GFC_INTEGER_4 len,
2014 gfc_charlen_type string_length, GFC_INTEGER_4 dtype)
2016 namelist_info *t1 = NULL;
2019 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2021 nml->mem_pos = var_addr;
2023 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2024 strcpy (nml->var_name, var_name);
2026 nml->len = (int) len;
2027 nml->string_length = (index_type) string_length;
2029 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2030 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2031 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2033 if (nml->var_rank > 0)
2035 nml->dim = (descriptor_dimension*)
2036 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2037 nml->ls = (array_loop_spec*)
2038 get_mem (nml->var_rank * sizeof (array_loop_spec));
2052 for (t1 = ionml; t1->next; t1 = t1->next);
2058 /* Store the dimensional information for the namelist object. */
2059 extern void st_set_nml_var_dim (GFC_INTEGER_4, GFC_INTEGER_4,
2060 GFC_INTEGER_4 ,GFC_INTEGER_4);
2061 export_proto(st_set_nml_var_dim);
2064 st_set_nml_var_dim (GFC_INTEGER_4 n_dim, GFC_INTEGER_4 stride,
2065 GFC_INTEGER_4 lbound, GFC_INTEGER_4 ubound)
2067 namelist_info * nml;
2072 for (nml = ionml; nml->next; nml = nml->next);
2074 nml->dim[n].stride = (ssize_t)stride;
2075 nml->dim[n].lbound = (ssize_t)lbound;
2076 nml->dim[n].ubound = (ssize_t)ubound;