1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
32 /* transfer.c -- Top level handling of data transfer statements. */
37 #include "libgfortran.h"
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
59 These subroutines do not return status.
61 The last call is a call to st_[read|write]_done(). While
62 something can easily go wrong with the initial st_read() or
63 st_write(), an error inhibits any data from actually being
66 extern void transfer_integer (st_parameter_dt *, void *, int);
67 export_proto(transfer_integer);
69 extern void transfer_real (st_parameter_dt *, void *, int);
70 export_proto(transfer_real);
72 extern void transfer_logical (st_parameter_dt *, void *, int);
73 export_proto(transfer_logical);
75 extern void transfer_character (st_parameter_dt *, void *, int);
76 export_proto(transfer_character);
78 extern void transfer_complex (st_parameter_dt *, void *, int);
79 export_proto(transfer_complex);
81 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
83 export_proto(transfer_array);
85 static void us_read (st_parameter_dt *, int);
86 static void us_write (st_parameter_dt *, int);
87 static void next_record_r_unf (st_parameter_dt *, int);
88 static void next_record_w_unf (st_parameter_dt *, int);
90 static const st_option advance_opt[] = {
98 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
99 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
105 current_mode (st_parameter_dt *dtp)
109 m = FORM_UNSPECIFIED;
111 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
113 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
114 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
116 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
118 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
119 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
121 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
123 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
124 FORMATTED_STREAM : UNFORMATTED_STREAM;
131 /* Mid level data transfer statements. These subroutines do reading
132 and writing in the style of salloc_r()/salloc_w() within the
135 /* When reading sequential formatted records we have a problem. We
136 don't know how long the line is until we read the trailing newline,
137 and we don't want to read too much. If we read too much, we might
138 have to do a physical seek backwards depending on how much data is
139 present, and devices like terminals aren't seekable and would cause
142 Given this, the solution is to read a byte at a time, stopping if
143 we hit the newline. For small allocations, we use a static buffer.
144 For larger allocations, we are forced to allocate memory on the
145 heap. Hopefully this won't happen very often. */
148 read_sf (st_parameter_dt *dtp, int *length, int no_error)
151 int n, readlen, crlf;
154 if (*length > SCRATCH_SIZE)
155 dtp->u.p.line_buffer = get_mem (*length);
156 p = base = dtp->u.p.line_buffer;
158 /* If we have seen an eor previously, return a length of 0. The
159 caller is responsible for correctly padding the input field. */
160 if (dtp->u.p.sf_seen_eor)
171 if (is_internal_unit (dtp))
173 /* readlen may be modified inside salloc_r if
174 is_internal_unit (dtp) is true. */
178 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
182 /* If we have a line without a terminating \n, drop through to
184 if (readlen < 1 && n == 0)
188 generate_error (&dtp->common, ERROR_END, NULL);
192 if (readlen < 1 || *q == '\n' || *q == '\r')
194 /* Unexpected end of line. */
196 /* If we see an EOR during non-advancing I/O, we need to skip
197 the rest of the I/O statement. Set the corresponding flag. */
198 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
199 dtp->u.p.eor_condition = 1;
202 /* If we encounter a CR, it might be a CRLF. */
203 if (*q == '\r') /* Probably a CRLF */
206 pos = stream_offset (dtp->u.p.current_unit->s);
207 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
208 if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */
209 sseek (dtp->u.p.current_unit->s, pos);
214 /* Without padding, terminate the I/O statement without assigning
215 the value. With padding, the value still needs to be assigned,
216 so we can just continue with a short read. */
217 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
221 generate_error (&dtp->common, ERROR_EOR, NULL);
226 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
229 /* Short circuit the read if a comma is found during numeric input.
230 The flag is set to zero during character reads so that commas in
231 strings are not ignored */
233 if (dtp->u.p.sf_read_comma == 1)
235 notify_std (&dtp->common, GFC_STD_GNU,
236 "Comma in formatted numeric read.");
243 dtp->u.p.sf_seen_eor = 0;
246 dtp->u.p.current_unit->bytes_left -= *length;
248 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
249 dtp->u.p.size_used += (gfc_offset) *length;
255 /* Function for reading the next couple of bytes from the current
256 file, advancing the current position. We return a pointer to a
257 buffer containing the bytes. We return NULL on end of record or
260 If the read is short, then it is because the current record does not
261 have enough data to satisfy the read request and the file was
262 opened with PAD=YES. The caller must assume tailing spaces for
266 read_block (st_parameter_dt *dtp, int *length)
271 if (is_stream_io (dtp))
273 if (sseek (dtp->u.p.current_unit->s,
274 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
276 generate_error (&dtp->common, ERROR_END, NULL);
282 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
284 /* For preconnected units with default record length, set bytes left
285 to unit record length and proceed, otherwise error. */
286 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
287 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
288 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
291 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
293 /* Not enough data left. */
294 generate_error (&dtp->common, ERROR_EOR, NULL);
299 if (dtp->u.p.current_unit->bytes_left == 0)
301 dtp->u.p.current_unit->endfile = AT_ENDFILE;
302 generate_error (&dtp->common, ERROR_END, NULL);
306 *length = dtp->u.p.current_unit->bytes_left;
310 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
311 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
312 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
314 source = read_sf (dtp, length, 0);
315 dtp->u.p.current_unit->strm_pos +=
316 (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
319 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
322 source = salloc_r (dtp->u.p.current_unit->s, &nread);
324 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
325 dtp->u.p.size_used += (gfc_offset) nread;
327 if (nread != *length)
328 { /* Short read, this shouldn't happen. */
329 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
333 generate_error (&dtp->common, ERROR_EOR, NULL);
338 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
344 /* Reads a block directly into application data space. This is for
345 unformatted files. */
348 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
350 size_t to_read_record;
351 size_t have_read_record;
352 size_t to_read_subrecord;
353 size_t have_read_subrecord;
356 if (is_stream_io (dtp))
358 if (sseek (dtp->u.p.current_unit->s,
359 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
361 generate_error (&dtp->common, ERROR_END, NULL);
365 to_read_record = *nbytes;
366 have_read_record = to_read_record;
367 if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
369 generate_error (&dtp->common, ERROR_OS, NULL);
373 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
375 if (to_read_record != have_read_record)
377 /* Short read, e.g. if we hit EOF. For stream files,
378 we have to set the end-of-file condition. */
379 generate_error (&dtp->common, ERROR_END, NULL);
385 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
387 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
390 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
391 *nbytes = to_read_record;
397 to_read_record = *nbytes;
400 dtp->u.p.current_unit->bytes_left -= to_read_record;
402 if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
404 generate_error (&dtp->common, ERROR_OS, NULL);
408 if (to_read_record != *nbytes)
410 /* Short read, e.g. if we hit EOF. Apparently, we read
411 more than was written to the last record. */
412 *nbytes = to_read_record;
413 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
419 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
425 /* Unformatted sequential. We loop over the subrecords, reading
426 until the request has been fulfilled or the record has run out
427 of continuation subrecords. */
429 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
431 generate_error (&dtp->common, ERROR_END, NULL);
435 /* Check whether we exceed the total record length. */
437 if (dtp->u.p.current_unit->flags.has_recl)
440 *nbytes > (size_t) dtp->u.p.current_unit->bytes_left ?
441 *nbytes : (size_t) dtp->u.p.current_unit->bytes_left;
446 to_read_record = *nbytes;
449 have_read_record = 0;
453 if (dtp->u.p.current_unit->bytes_left_subrecord
454 < (gfc_offset) to_read_record)
456 to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
457 to_read_record -= to_read_subrecord;
461 to_read_subrecord = to_read_record;
465 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
467 have_read_subrecord = to_read_subrecord;
468 if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
469 &have_read_subrecord) != 0)
471 generate_error (&dtp->common, ERROR_OS, NULL);
475 have_read_record += have_read_subrecord;
477 if (to_read_subrecord != have_read_subrecord)
480 /* Short read, e.g. if we hit EOF. This means the record
481 structure has been corrupted, or the trailing record
482 marker would still be present. */
484 *nbytes = have_read_record;
485 generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL);
489 if (to_read_record > 0)
491 if (dtp->u.p.current_unit->continued)
493 next_record_r_unf (dtp, 0);
498 /* Let's make sure the file position is correctly set for the
499 next read statement. */
501 next_record_r_unf (dtp, 0);
503 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
509 /* Normal exit, the read request has been fulfilled. */
514 dtp->u.p.current_unit->bytes_left -= have_read_record;
517 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
524 /* Function for writing a block of bytes to the current file at the
525 current position, advancing the file pointer. We are given a length
526 and return a pointer to a buffer that the caller must (completely)
527 fill in. Returns NULL on error. */
530 write_block (st_parameter_dt *dtp, int length)
534 if (is_stream_io (dtp))
536 if (sseek (dtp->u.p.current_unit->s,
537 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
539 generate_error (&dtp->common, ERROR_OS, NULL);
545 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
547 /* For preconnected units with default record length, set bytes left
548 to unit record length and proceed, otherwise error. */
549 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
550 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
551 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
552 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
555 generate_error (&dtp->common, ERROR_EOR, NULL);
560 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
563 dest = salloc_w (dtp->u.p.current_unit->s, &length);
567 generate_error (&dtp->common, ERROR_END, NULL);
571 if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
572 generate_error (&dtp->common, ERROR_END, NULL);
574 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
575 dtp->u.p.size_used += (gfc_offset) length;
577 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
583 /* High level interface to swrite(), taking care of errors. This is only
584 called for unformatted files. There are three cases to consider:
585 Stream I/O, unformatted direct, unformatted sequential. */
588 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
591 size_t have_written, to_write_subrecord;
597 if (is_stream_io (dtp))
599 if (sseek (dtp->u.p.current_unit->s,
600 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
602 generate_error (&dtp->common, ERROR_OS, NULL);
606 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
608 generate_error (&dtp->common, ERROR_OS, NULL);
612 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
617 /* Unformatted direct access. */
619 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
621 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
623 generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
627 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
629 generate_error (&dtp->common, ERROR_OS, NULL);
633 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
634 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
640 /* Unformatted sequential. */
644 if (dtp->u.p.current_unit->flags.has_recl
645 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
647 nbytes = dtp->u.p.current_unit->bytes_left;
659 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
660 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
662 dtp->u.p.current_unit->bytes_left_subrecord -=
663 (gfc_offset) to_write_subrecord;
665 if (swrite (dtp->u.p.current_unit->s, buf + have_written,
666 &to_write_subrecord) != 0)
668 generate_error (&dtp->common, ERROR_OS, NULL);
672 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
673 nbytes -= to_write_subrecord;
674 have_written += to_write_subrecord;
679 next_record_w_unf (dtp, 1);
682 dtp->u.p.current_unit->bytes_left -= have_written;
685 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
692 /* Master function for unformatted reads. */
695 unformatted_read (st_parameter_dt *dtp, bt type,
696 void *dest, int kind,
697 size_t size, size_t nelems)
701 /* Currently, character implies size=1. */
702 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
703 || size == 1 || type == BT_CHARACTER)
706 read_block_direct (dtp, dest, &sz);
713 /* Break up complex into its constituent reals. */
714 if (type == BT_COMPLEX)
721 /* By now, all complex variables have been split into their
722 constituent reals. For types with padding, we only need to
723 read kind bytes. We don't care about the contents
724 of the padding. If we hit a short record, then sz is
725 adjusted accordingly, making later reads no-ops. */
728 for (i=0; i<nelems; i++)
730 read_block_direct (dtp, buffer, &sz);
731 reverse_memcpy (p, buffer, sz);
738 /* Master function for unformatted writes. */
741 unformatted_write (st_parameter_dt *dtp, bt type,
742 void *source, int kind,
743 size_t size, size_t nelems)
745 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
746 size == 1 || type == BT_CHARACTER)
750 write_buf (dtp, source, size);
758 /* Break up complex into its constituent reals. */
759 if (type == BT_COMPLEX)
767 /* By now, all complex variables have been split into their
768 constituent reals. For types with padding, we only need to
769 read kind bytes. We don't care about the contents
773 for (i=0; i<nelems; i++)
775 reverse_memcpy(buffer, p, size);
777 write_buf (dtp, buffer, sz);
783 /* Return a pointer to the name of a type. */
808 internal_error (NULL, "type_name(): Bad type");
815 /* Write a constant string to the output.
816 This is complicated because the string can have doubled delimiters
817 in it. The length in the format node is the true length. */
820 write_constant_string (st_parameter_dt *dtp, const fnode *f)
822 char c, delimiter, *p, *q;
825 length = f->u.string.length;
829 p = write_block (dtp, length);
836 for (; length > 0; length--)
839 if (c == delimiter && c != 'H' && c != 'h')
840 q++; /* Skip the doubled delimiter. */
845 /* Given actual and expected types in a formatted data transfer, make
846 sure they agree. If not, an error message is generated. Returns
847 nonzero if something went wrong. */
850 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
854 if (actual == expected)
857 st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
858 type_name (expected), dtp->u.p.item_count, type_name (actual));
860 format_error (dtp, f, buffer);
865 /* This subroutine is the main loop for a formatted data transfer
866 statement. It would be natural to implement this as a coroutine
867 with the user program, but C makes that awkward. We loop,
868 processing format elements. When we actually have to transfer
869 data instead of just setting flags, we return control to the user
870 program which calls a subroutine that supplies the address and type
871 of the next element, then comes back here to process it. */
874 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
877 char scratch[SCRATCH_SIZE];
882 int consume_data_flag;
884 /* Change a complex data item into a pair of reals. */
886 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
887 if (type == BT_COMPLEX)
893 /* If there's an EOR condition, we simulate finalizing the transfer
895 if (dtp->u.p.eor_condition)
898 /* Set this flag so that commas in reads cause the read to complete before
899 the entire field has been read. The next read field will start right after
900 the comma in the stream. (Set to 0 for character reads). */
901 dtp->u.p.sf_read_comma = 1;
903 dtp->u.p.line_buffer = scratch;
906 /* If reversion has occurred and there is another real data item,
907 then we have to move to the next record. */
908 if (dtp->u.p.reversion_flag && n > 0)
910 dtp->u.p.reversion_flag = 0;
911 next_record (dtp, 0);
914 consume_data_flag = 1 ;
915 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
918 f = next_format (dtp);
921 /* No data descriptors left. */
923 generate_error (&dtp->common, ERROR_FORMAT,
924 "Insufficient data descriptors in format after reversion");
928 /* Now discharge T, TR and X movements to the right. This is delayed
929 until a data producing format to suppress trailing spaces. */
932 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
933 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
934 || t == FMT_Z || t == FMT_F || t == FMT_E
935 || t == FMT_EN || t == FMT_ES || t == FMT_G
936 || t == FMT_L || t == FMT_A || t == FMT_D))
939 if (dtp->u.p.skips > 0)
941 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
942 dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
943 - dtp->u.p.current_unit->bytes_left);
945 if (dtp->u.p.skips < 0)
947 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
948 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
950 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
953 bytes_used = (int)(dtp->u.p.current_unit->recl
954 - dtp->u.p.current_unit->bytes_left);
961 if (require_type (dtp, BT_INTEGER, type, f))
964 if (dtp->u.p.mode == READING)
965 read_decimal (dtp, f, p, len);
967 write_i (dtp, f, p, len);
975 if (compile_options.allow_std < GFC_STD_GNU
976 && require_type (dtp, BT_INTEGER, type, f))
979 if (dtp->u.p.mode == READING)
980 read_radix (dtp, f, p, len, 2);
982 write_b (dtp, f, p, len);
990 if (compile_options.allow_std < GFC_STD_GNU
991 && require_type (dtp, BT_INTEGER, type, f))
994 if (dtp->u.p.mode == READING)
995 read_radix (dtp, f, p, len, 8);
997 write_o (dtp, f, p, len);
1005 if (compile_options.allow_std < GFC_STD_GNU
1006 && require_type (dtp, BT_INTEGER, type, f))
1009 if (dtp->u.p.mode == READING)
1010 read_radix (dtp, f, p, len, 16);
1012 write_z (dtp, f, p, len);
1020 if (dtp->u.p.mode == READING)
1021 read_a (dtp, f, p, len);
1023 write_a (dtp, f, p, len);
1031 if (dtp->u.p.mode == READING)
1032 read_l (dtp, f, p, len);
1034 write_l (dtp, f, p, len);
1041 if (require_type (dtp, BT_REAL, type, f))
1044 if (dtp->u.p.mode == READING)
1045 read_f (dtp, f, p, len);
1047 write_d (dtp, f, p, len);
1054 if (require_type (dtp, BT_REAL, type, f))
1057 if (dtp->u.p.mode == READING)
1058 read_f (dtp, f, p, len);
1060 write_e (dtp, f, p, len);
1066 if (require_type (dtp, BT_REAL, type, f))
1069 if (dtp->u.p.mode == READING)
1070 read_f (dtp, f, p, len);
1072 write_en (dtp, f, p, len);
1079 if (require_type (dtp, BT_REAL, type, f))
1082 if (dtp->u.p.mode == READING)
1083 read_f (dtp, f, p, len);
1085 write_es (dtp, f, p, len);
1092 if (require_type (dtp, BT_REAL, type, f))
1095 if (dtp->u.p.mode == READING)
1096 read_f (dtp, f, p, len);
1098 write_f (dtp, f, p, len);
1105 if (dtp->u.p.mode == READING)
1109 read_decimal (dtp, f, p, len);
1112 read_l (dtp, f, p, len);
1115 read_a (dtp, f, p, len);
1118 read_f (dtp, f, p, len);
1127 write_i (dtp, f, p, len);
1130 write_l (dtp, f, p, len);
1133 write_a (dtp, f, p, len);
1136 write_d (dtp, f, p, len);
1140 internal_error (&dtp->common,
1141 "formatted_transfer(): Bad type");
1147 consume_data_flag = 0 ;
1148 if (dtp->u.p.mode == READING)
1150 format_error (dtp, f, "Constant string in input format");
1153 write_constant_string (dtp, f);
1156 /* Format codes that don't transfer data. */
1159 consume_data_flag = 0 ;
1161 pos = bytes_used + f->u.n + dtp->u.p.skips;
1162 dtp->u.p.skips = f->u.n + dtp->u.p.skips;
1163 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1165 /* Writes occur just before the switch on f->format, above, so
1166 that trailing blanks are suppressed, unless we are doing a
1167 non-advancing write in which case we want to output the blanks
1169 if (dtp->u.p.mode == WRITING
1170 && dtp->u.p.advance_status == ADVANCE_NO)
1172 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1173 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1175 if (dtp->u.p.mode == READING)
1176 read_x (dtp, f->u.n);
1182 if (f->format == FMT_TL)
1185 /* Handle the special case when no bytes have been used yet.
1186 Cannot go below zero. */
1187 if (bytes_used == 0)
1189 dtp->u.p.pending_spaces -= f->u.n;
1190 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1191 : dtp->u.p.pending_spaces;
1192 dtp->u.p.skips -= f->u.n;
1193 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1196 pos = bytes_used - f->u.n;
1200 consume_data_flag = 0;
1204 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1205 left tab limit. We do not check if the position has gone
1206 beyond the end of record because a subsequent tab could
1207 bring us back again. */
1208 pos = pos < 0 ? 0 : pos;
1210 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1211 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1212 + pos - dtp->u.p.max_pos;
1214 if (dtp->u.p.skips == 0)
1217 /* Writes occur just before the switch on f->format, above, so that
1218 trailing blanks are suppressed. */
1219 if (dtp->u.p.mode == READING)
1221 /* Adjust everything for end-of-record condition */
1222 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1224 if (dtp->u.p.sf_seen_eor == 2)
1226 /* The EOR was a CRLF (two bytes wide). */
1227 dtp->u.p.current_unit->bytes_left -= 2;
1228 dtp->u.p.skips -= 2;
1232 /* The EOR marker was only one byte wide. */
1233 dtp->u.p.current_unit->bytes_left--;
1237 dtp->u.p.sf_seen_eor = 0;
1239 if (dtp->u.p.skips < 0)
1241 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1242 dtp->u.p.current_unit->bytes_left
1243 -= (gfc_offset) dtp->u.p.skips;
1244 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1247 read_x (dtp, dtp->u.p.skips);
1253 consume_data_flag = 0 ;
1254 dtp->u.p.sign_status = SIGN_S;
1258 consume_data_flag = 0 ;
1259 dtp->u.p.sign_status = SIGN_SS;
1263 consume_data_flag = 0 ;
1264 dtp->u.p.sign_status = SIGN_SP;
1268 consume_data_flag = 0 ;
1269 dtp->u.p.blank_status = BLANK_NULL;
1273 consume_data_flag = 0 ;
1274 dtp->u.p.blank_status = BLANK_ZERO;
1278 consume_data_flag = 0 ;
1279 dtp->u.p.scale_factor = f->u.k;
1283 consume_data_flag = 0 ;
1284 dtp->u.p.seen_dollar = 1;
1288 consume_data_flag = 0 ;
1289 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1290 next_record (dtp, 0);
1294 /* A colon descriptor causes us to exit this loop (in
1295 particular preventing another / descriptor from being
1296 processed) unless there is another data item to be
1298 consume_data_flag = 0 ;
1304 internal_error (&dtp->common, "Bad format node");
1307 /* Free a buffer that we had to allocate during a sequential
1308 formatted read of a block that was larger than the static
1311 if (dtp->u.p.line_buffer != scratch)
1313 free_mem (dtp->u.p.line_buffer);
1314 dtp->u.p.line_buffer = scratch;
1317 /* Adjust the item count and data pointer. */
1319 if ((consume_data_flag > 0) && (n > 0))
1322 p = ((char *) p) + size;
1325 if (dtp->u.p.mode == READING)
1328 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1329 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1335 /* Come here when we need a data descriptor but don't have one. We
1336 push the current format node back onto the input, then return and
1337 let the user program call us back with the data. */
1339 unget_format (dtp, f);
1343 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1344 size_t size, size_t nelems)
1351 /* Big loop over all the elements. */
1352 for (elem = 0; elem < nelems; elem++)
1354 dtp->u.p.item_count++;
1355 formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1361 /* Data transfer entry points. The type of the data entity is
1362 implicit in the subroutine call. This prevents us from having to
1363 share a common enum with the compiler. */
1366 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1368 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1370 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1375 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1378 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1380 size = size_from_real_kind (kind);
1381 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1386 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1388 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1390 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1395 transfer_character (st_parameter_dt *dtp, void *p, int len)
1397 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1399 /* Currently we support only 1 byte chars, and the library is a bit
1400 confused of character kind vs. length, so we kludge it by setting
1402 dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1407 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1410 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1412 size = size_from_complex_kind (kind);
1413 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1418 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1419 gfc_charlen_type charlen)
1421 index_type count[GFC_MAX_DIMENSIONS];
1422 index_type extent[GFC_MAX_DIMENSIONS];
1423 index_type stride[GFC_MAX_DIMENSIONS];
1424 index_type stride0, rank, size, type, n;
1429 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1432 type = GFC_DESCRIPTOR_TYPE (desc);
1433 size = GFC_DESCRIPTOR_SIZE (desc);
1435 /* FIXME: What a kludge: Array descriptors and the IO library use
1436 different enums for types. */
1439 case GFC_DTYPE_UNKNOWN:
1440 iotype = BT_NULL; /* Is this correct? */
1442 case GFC_DTYPE_INTEGER:
1443 iotype = BT_INTEGER;
1445 case GFC_DTYPE_LOGICAL:
1446 iotype = BT_LOGICAL;
1448 case GFC_DTYPE_REAL:
1451 case GFC_DTYPE_COMPLEX:
1452 iotype = BT_COMPLEX;
1454 case GFC_DTYPE_CHARACTER:
1455 iotype = BT_CHARACTER;
1456 /* FIXME: Currently dtype contains the charlen, which is
1457 clobbered if charlen > 2**24. That's why we use a separate
1458 argument for the charlen. However, if we want to support
1459 non-8-bit charsets we need to fix dtype to contain
1460 sizeof(chartype) and fix the code below. */
1464 case GFC_DTYPE_DERIVED:
1465 internal_error (&dtp->common,
1466 "Derived type I/O should have been handled via the frontend.");
1469 internal_error (&dtp->common, "transfer_array(): Bad type");
1472 rank = GFC_DESCRIPTOR_RANK (desc);
1473 for (n = 0; n < rank; n++)
1476 stride[n] = desc->dim[n].stride;
1477 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1479 /* If the extent of even one dimension is zero, then the entire
1480 array section contains zero elements, so we return. */
1485 stride0 = stride[0];
1487 /* If the innermost dimension has stride 1, we can do the transfer
1488 in contiguous chunks. */
1494 data = GFC_DESCRIPTOR_DATA (desc);
1498 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1499 data += stride0 * size * tsize;
1502 while (count[n] == extent[n])
1505 data -= stride[n] * extent[n] * size;
1515 data += stride[n] * size;
1522 /* Preposition a sequential unformatted file while reading. */
1525 us_read (st_parameter_dt *dtp, int continued)
1534 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1537 if (compile_options.record_marker == 0)
1538 n = sizeof (GFC_INTEGER_4);
1540 n = compile_options.record_marker;
1544 p = salloc_r (dtp->u.p.current_unit->s, &n);
1548 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1549 return; /* end of file */
1552 if (p == NULL || n != nr)
1554 generate_error (&dtp->common, ERROR_BAD_US, NULL);
1558 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1559 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1563 case sizeof(GFC_INTEGER_4):
1564 memcpy (&i4, p, sizeof (i4));
1568 case sizeof(GFC_INTEGER_8):
1569 memcpy (&i8, p, sizeof (i8));
1574 runtime_error ("Illegal value for record marker");
1581 case sizeof(GFC_INTEGER_4):
1582 reverse_memcpy (&i4, p, sizeof (i4));
1586 case sizeof(GFC_INTEGER_8):
1587 reverse_memcpy (&i8, p, sizeof (i8));
1592 runtime_error ("Illegal value for record marker");
1598 dtp->u.p.current_unit->bytes_left_subrecord = i;
1599 dtp->u.p.current_unit->continued = 0;
1603 dtp->u.p.current_unit->bytes_left_subrecord = -i;
1604 dtp->u.p.current_unit->continued = 1;
1608 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1612 /* Preposition a sequential unformatted file while writing. This
1613 amount to writing a bogus length that will be filled in later. */
1616 us_write (st_parameter_dt *dtp, int continued)
1623 if (compile_options.record_marker == 0)
1624 nbytes = sizeof (GFC_INTEGER_4);
1626 nbytes = compile_options.record_marker ;
1628 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1629 generate_error (&dtp->common, ERROR_OS, NULL);
1631 /* For sequential unformatted, if RECL= was not specified in the OPEN
1632 we write until we have more bytes than can fit in the subrecord
1633 markers, then we write a new subrecord. */
1635 dtp->u.p.current_unit->bytes_left_subrecord =
1636 dtp->u.p.current_unit->recl_subrecord;
1637 dtp->u.p.current_unit->continued = continued;
1641 /* Position to the next record prior to transfer. We are assumed to
1642 be before the next record. We also calculate the bytes in the next
1646 pre_position (st_parameter_dt *dtp)
1648 if (dtp->u.p.current_unit->current_record)
1649 return; /* Already positioned. */
1651 switch (current_mode (dtp))
1653 case FORMATTED_STREAM:
1654 case UNFORMATTED_STREAM:
1655 /* There are no records with stream I/O. Set the default position
1656 to the beginning of the file if no position was specified. */
1657 if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1658 dtp->u.p.current_unit->strm_pos = 1;
1661 case UNFORMATTED_SEQUENTIAL:
1662 if (dtp->u.p.mode == READING)
1669 case FORMATTED_SEQUENTIAL:
1670 case FORMATTED_DIRECT:
1671 case UNFORMATTED_DIRECT:
1672 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1676 dtp->u.p.current_unit->current_record = 1;
1680 /* Initialize things for a data transfer. This code is common for
1681 both reading and writing. */
1684 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1686 unit_flags u_flags; /* Used for creating a unit if needed. */
1687 GFC_INTEGER_4 cf = dtp->common.flags;
1688 namelist_info *ionml;
1690 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1691 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1692 dtp->u.p.ionml = ionml;
1693 dtp->u.p.mode = read_flag ? READING : WRITING;
1695 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1696 dtp->u.p.size_used = 0; /* Initialize the count. */
1698 dtp->u.p.current_unit = get_unit (dtp, 1);
1699 if (dtp->u.p.current_unit->s == NULL)
1700 { /* Open the unit with some default flags. */
1701 st_parameter_open opp;
1704 if (dtp->common.unit < 0)
1706 close_unit (dtp->u.p.current_unit);
1707 dtp->u.p.current_unit = NULL;
1708 generate_error (&dtp->common, ERROR_BAD_OPTION,
1709 "Bad unit number in OPEN statement");
1712 memset (&u_flags, '\0', sizeof (u_flags));
1713 u_flags.access = ACCESS_SEQUENTIAL;
1714 u_flags.action = ACTION_READWRITE;
1716 /* Is it unformatted? */
1717 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1718 | IOPARM_DT_IONML_SET)))
1719 u_flags.form = FORM_UNFORMATTED;
1721 u_flags.form = FORM_UNSPECIFIED;
1723 u_flags.delim = DELIM_UNSPECIFIED;
1724 u_flags.blank = BLANK_UNSPECIFIED;
1725 u_flags.pad = PAD_UNSPECIFIED;
1726 u_flags.status = STATUS_UNKNOWN;
1728 conv = get_unformatted_convert (dtp->common.unit);
1730 if (conv == CONVERT_NONE)
1731 conv = compile_options.convert;
1733 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1734 and 1 on big-endian machines. */
1737 case CONVERT_NATIVE:
1742 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1745 case CONVERT_LITTLE:
1746 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1750 internal_error (&opp.common, "Illegal value for CONVERT");
1754 u_flags.convert = conv;
1756 opp.common = dtp->common;
1757 opp.common.flags &= IOPARM_COMMON_MASK;
1758 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1759 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1760 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1761 if (dtp->u.p.current_unit == NULL)
1765 /* Check the action. */
1767 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1768 generate_error (&dtp->common, ERROR_BAD_ACTION,
1769 "Cannot read from file opened for WRITE");
1771 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1772 generate_error (&dtp->common, ERROR_BAD_ACTION,
1773 "Cannot write to file opened for READ");
1775 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1778 dtp->u.p.first_item = 1;
1780 /* Check the format. */
1782 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1785 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1788 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1789 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1791 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1792 "Format present for UNFORMATTED data transfer");
1794 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1796 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1797 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1798 "A format cannot be specified with a namelist");
1800 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1801 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1802 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1803 "Missing format for FORMATTED data transfer");
1805 if (is_internal_unit (dtp)
1806 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1807 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1808 "Internal file cannot be accessed by UNFORMATTED data transfer");
1810 /* Check the record or position number. */
1812 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1813 && (cf & IOPARM_DT_HAS_REC) == 0)
1815 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1816 "Direct access data transfer requires record number");
1820 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1821 && (cf & IOPARM_DT_HAS_REC) != 0)
1823 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1824 "Record number not allowed for sequential access data transfer");
1828 /* Process the ADVANCE option. */
1830 dtp->u.p.advance_status
1831 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1832 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1833 "Bad ADVANCE parameter in data transfer statement");
1835 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1837 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1838 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1839 "ADVANCE specification conflicts with sequential access");
1841 if (is_internal_unit (dtp))
1842 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1843 "ADVANCE specification conflicts with internal file");
1845 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1846 != IOPARM_DT_HAS_FORMAT)
1847 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1848 "ADVANCE specification requires an explicit format");
1853 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1854 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1855 "EOR specification requires an ADVANCE specification of NO");
1857 if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1858 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1859 "SIZE specification requires an ADVANCE specification of NO");
1863 { /* Write constraints. */
1864 if ((cf & IOPARM_END) != 0)
1865 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1866 "END specification cannot appear in a write statement");
1868 if ((cf & IOPARM_EOR) != 0)
1869 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1870 "EOR specification cannot appear in a write statement");
1872 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1873 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1874 "SIZE specification cannot appear in a write statement");
1877 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1878 dtp->u.p.advance_status = ADVANCE_YES;
1879 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1882 /* Sanity checks on the record number. */
1883 if ((cf & IOPARM_DT_HAS_REC) != 0)
1887 generate_error (&dtp->common, ERROR_BAD_OPTION,
1888 "Record number must be positive");
1892 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1894 generate_error (&dtp->common, ERROR_BAD_OPTION,
1895 "Record number too large");
1899 /* Check to see if we might be reading what we wrote before */
1901 if (dtp->u.p.mode == READING
1902 && dtp->u.p.current_unit->mode == WRITING
1903 && !is_internal_unit (dtp))
1904 flush(dtp->u.p.current_unit->s);
1906 /* Check whether the record exists to be read. Only
1907 a partial record needs to exist. */
1909 if (dtp->u.p.mode == READING && (dtp->rec -1)
1910 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1912 generate_error (&dtp->common, ERROR_BAD_OPTION,
1913 "Non-existing record number");
1917 /* Position the file. */
1918 if (!is_stream_io (dtp))
1920 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1921 * dtp->u.p.current_unit->recl) == FAILURE)
1923 generate_error (&dtp->common, ERROR_OS, NULL);
1928 dtp->u.p.current_unit->strm_pos = dtp->rec;
1932 /* Overwriting an existing sequential file ?
1933 it is always safe to truncate the file on the first write */
1934 if (dtp->u.p.mode == WRITING
1935 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1936 && dtp->u.p.current_unit->last_record == 0
1937 && !is_preconnected(dtp->u.p.current_unit->s))
1938 struncate(dtp->u.p.current_unit->s);
1940 /* Bugware for badly written mixed C-Fortran I/O. */
1941 flush_if_preconnected(dtp->u.p.current_unit->s);
1943 dtp->u.p.current_unit->mode = dtp->u.p.mode;
1945 /* Set the initial value of flags. */
1947 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1948 dtp->u.p.sign_status = SIGN_S;
1952 /* Set up the subroutine that will handle the transfers. */
1956 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1957 dtp->u.p.transfer = unformatted_read;
1960 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1961 dtp->u.p.transfer = list_formatted_read;
1963 dtp->u.p.transfer = formatted_transfer;
1968 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1969 dtp->u.p.transfer = unformatted_write;
1972 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1973 dtp->u.p.transfer = list_formatted_write;
1975 dtp->u.p.transfer = formatted_transfer;
1979 /* Make sure that we don't do a read after a nonadvancing write. */
1983 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1985 generate_error (&dtp->common, ERROR_BAD_OPTION,
1986 "Cannot READ after a nonadvancing WRITE");
1992 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1993 dtp->u.p.current_unit->read_bad = 1;
1996 /* Start the data transfer if we are doing a formatted transfer. */
1997 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1998 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1999 && dtp->u.p.ionml == NULL)
2000 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2003 /* Initialize an array_loop_spec given the array descriptor. The function
2004 returns the index of the last element of the array. */
2007 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
2009 int rank = GFC_DESCRIPTOR_RANK(desc);
2014 for (i=0; i<rank; i++)
2017 ls[i].start = desc->dim[i].lbound;
2018 ls[i].end = desc->dim[i].ubound;
2019 ls[i].step = desc->dim[i].stride;
2021 index += (desc->dim[i].ubound - desc->dim[i].lbound)
2022 * desc->dim[i].stride;
2027 /* Determine the index to the next record in an internal unit array by
2028 by incrementing through the array_loop_spec. TODO: Implement handling
2029 negative strides. */
2032 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
2040 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2045 if (ls[i].idx > ls[i].end)
2047 ls[i].idx = ls[i].start;
2053 index = index + (ls[i].idx - 1) * ls[i].step;
2060 /* Skip to the end of the current record, taking care of an optional
2061 record marker of size bytes. If the file is not seekable, we
2062 read chunks of size MAX_READ until we get to the right
2065 #define MAX_READ 4096
2068 skip_record (st_parameter_dt *dtp, size_t bytes)
2071 int rlength, length;
2074 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2075 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2078 if (is_seekable (dtp->u.p.current_unit->s))
2080 new = file_position (dtp->u.p.current_unit->s)
2081 + dtp->u.p.current_unit->bytes_left_subrecord;
2083 /* Direct access files do not generate END conditions,
2085 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2086 generate_error (&dtp->common, ERROR_OS, NULL);
2089 { /* Seek by reading data. */
2090 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2093 (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
2094 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2096 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
2099 generate_error (&dtp->common, ERROR_OS, NULL);
2103 dtp->u.p.current_unit->bytes_left_subrecord -= length;
2111 /* Advance to the next record reading unformatted files, taking
2112 care of subrecords. If complete_record is nonzero, we loop
2113 until all subrecords are cleared. */
2116 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2120 bytes = compile_options.record_marker == 0 ?
2121 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2126 /* Skip over tail */
2128 skip_record (dtp, bytes);
2130 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2137 /* Space to the next record for read mode. */
2140 next_record_r (st_parameter_dt *dtp)
2143 int length, bytes_left;
2146 switch (current_mode (dtp))
2148 /* No records in unformatted STREAM I/O. */
2149 case UNFORMATTED_STREAM:
2152 case UNFORMATTED_SEQUENTIAL:
2153 next_record_r_unf (dtp, 1);
2156 case FORMATTED_DIRECT:
2157 case UNFORMATTED_DIRECT:
2158 skip_record (dtp, 0);
2161 case FORMATTED_STREAM:
2162 case FORMATTED_SEQUENTIAL:
2164 /* sf_read has already terminated input because of an '\n' */
2165 if (dtp->u.p.sf_seen_eor)
2167 dtp->u.p.sf_seen_eor = 0;
2171 if (is_internal_unit (dtp))
2173 if (is_array_io (dtp))
2175 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2177 /* Now seek to this record. */
2178 record = record * dtp->u.p.current_unit->recl;
2179 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2181 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2184 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2188 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2189 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2191 dtp->u.p.current_unit->bytes_left
2192 = dtp->u.p.current_unit->recl;
2198 p = salloc_r (dtp->u.p.current_unit->s, &length);
2202 generate_error (&dtp->common, ERROR_OS, NULL);
2208 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2212 if (is_stream_io (dtp))
2213 dtp->u.p.current_unit->strm_pos++;
2220 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2221 test_endfile (dtp->u.p.current_unit);
2225 /* Small utility function to write a record marker, taking care of
2226 byte swapping and of choosing the correct size. */
2229 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2234 char p[sizeof (GFC_INTEGER_8)];
2236 if (compile_options.record_marker == 0)
2237 len = sizeof (GFC_INTEGER_4);
2239 len = compile_options.record_marker;
2241 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2242 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2246 case sizeof (GFC_INTEGER_4):
2248 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2251 case sizeof (GFC_INTEGER_8):
2253 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2257 runtime_error ("Illegal value for record marker");
2265 case sizeof (GFC_INTEGER_4):
2267 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2268 return swrite (dtp->u.p.current_unit->s, p, &len);
2271 case sizeof (GFC_INTEGER_8):
2273 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2274 return swrite (dtp->u.p.current_unit->s, p, &len);
2278 runtime_error ("Illegal value for record marker");
2285 /* Position to the next (sub)record in write mode for
2286 unformatted sequential files. */
2289 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2291 gfc_offset c, m, m_write;
2292 size_t record_marker;
2294 /* Bytes written. */
2295 m = dtp->u.p.current_unit->recl_subrecord
2296 - dtp->u.p.current_unit->bytes_left_subrecord;
2297 c = file_position (dtp->u.p.current_unit->s);
2299 /* Write the length tail. If we finish a record containing
2300 subrecords, we write out the negative length. */
2302 if (dtp->u.p.current_unit->continued)
2307 if (write_us_marker (dtp, m_write) != 0)
2310 if (compile_options.record_marker == 0)
2311 record_marker = sizeof (GFC_INTEGER_4);
2313 record_marker = compile_options.record_marker;
2315 /* Seek to the head and overwrite the bogus length with the real
2318 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2327 if (write_us_marker (dtp, m_write) != 0)
2330 /* Seek past the end of the current record. */
2332 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2338 generate_error (&dtp->common, ERROR_OS, NULL);
2343 /* Position to the next record in write mode. */
2346 next_record_w (st_parameter_dt *dtp, int done)
2348 gfc_offset m, record, max_pos;
2352 /* Zero counters for X- and T-editing. */
2353 max_pos = dtp->u.p.max_pos;
2354 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2356 switch (current_mode (dtp))
2358 /* No records in unformatted STREAM I/O. */
2359 case UNFORMATTED_STREAM:
2362 case FORMATTED_DIRECT:
2363 if (dtp->u.p.current_unit->bytes_left == 0)
2366 if (sset (dtp->u.p.current_unit->s, ' ',
2367 dtp->u.p.current_unit->bytes_left) == FAILURE)
2372 case UNFORMATTED_DIRECT:
2373 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2377 case UNFORMATTED_SEQUENTIAL:
2378 next_record_w_unf (dtp, 0);
2381 case FORMATTED_STREAM:
2382 case FORMATTED_SEQUENTIAL:
2384 if (is_internal_unit (dtp))
2386 if (is_array_io (dtp))
2388 length = (int) dtp->u.p.current_unit->bytes_left;
2390 /* If the farthest position reached is greater than current
2391 position, adjust the position and set length to pad out
2392 whats left. Otherwise just pad whats left.
2393 (for character array unit) */
2394 m = dtp->u.p.current_unit->recl
2395 - dtp->u.p.current_unit->bytes_left;
2398 length = (int) (max_pos - m);
2399 p = salloc_w (dtp->u.p.current_unit->s, &length);
2400 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2403 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2405 generate_error (&dtp->common, ERROR_END, NULL);
2409 /* Now that the current record has been padded out,
2410 determine where the next record in the array is. */
2411 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2413 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2415 /* Now seek to this record */
2416 record = record * dtp->u.p.current_unit->recl;
2418 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2420 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2424 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2430 /* If this is the last call to next_record move to the farthest
2431 position reached and set length to pad out the remainder
2432 of the record. (for character scaler unit) */
2435 m = dtp->u.p.current_unit->recl
2436 - dtp->u.p.current_unit->bytes_left;
2439 length = (int) (max_pos - m);
2440 p = salloc_w (dtp->u.p.current_unit->s, &length);
2441 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2444 length = (int) dtp->u.p.current_unit->bytes_left;
2447 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2449 generate_error (&dtp->common, ERROR_END, NULL);
2457 /* If this is the last call to next_record move to the farthest
2458 position reached in preparation for completing the record.
2462 m = dtp->u.p.current_unit->recl -
2463 dtp->u.p.current_unit->bytes_left;
2466 length = (int) (max_pos - m);
2467 p = salloc_w (dtp->u.p.current_unit->s, &length);
2471 const char crlf[] = "\r\n";
2477 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2480 if (is_stream_io (dtp))
2481 dtp->u.p.current_unit->strm_pos += len;
2487 generate_error (&dtp->common, ERROR_OS, NULL);
2492 /* Position to the next record, which means moving to the end of the
2493 current record. This can happen under several different
2494 conditions. If the done flag is not set, we get ready to process
2498 next_record (st_parameter_dt *dtp, int done)
2500 gfc_offset fp; /* File position. */
2502 dtp->u.p.current_unit->read_bad = 0;
2504 if (dtp->u.p.mode == READING)
2505 next_record_r (dtp);
2507 next_record_w (dtp, done);
2509 if (!is_stream_io (dtp))
2511 /* keep position up to date for INQUIRE */
2512 dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2513 dtp->u.p.current_unit->current_record = 0;
2514 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2516 fp = file_position (dtp->u.p.current_unit->s);
2517 /* Calculate next record, rounding up partial records. */
2518 dtp->u.p.current_unit->last_record =
2519 (fp + dtp->u.p.current_unit->recl - 1) /
2520 dtp->u.p.current_unit->recl;
2523 dtp->u.p.current_unit->last_record++;
2531 /* Finalize the current data transfer. For a nonadvancing transfer,
2532 this means advancing to the next record. For internal units close the
2533 stream associated with the unit. */
2536 finalize_transfer (st_parameter_dt *dtp)
2539 GFC_INTEGER_4 cf = dtp->common.flags;
2541 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2542 *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2544 if (dtp->u.p.eor_condition)
2546 generate_error (&dtp->common, ERROR_EOR, NULL);
2550 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2553 if ((dtp->u.p.ionml != NULL)
2554 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2556 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2557 namelist_read (dtp);
2559 namelist_write (dtp);
2562 dtp->u.p.transfer = NULL;
2563 if (dtp->u.p.current_unit == NULL)
2566 dtp->u.p.eof_jump = &eof_jump;
2567 if (setjmp (eof_jump))
2569 generate_error (&dtp->common, ERROR_END, NULL);
2573 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2575 finish_list_read (dtp);
2576 sfree (dtp->u.p.current_unit->s);
2580 if (is_stream_io (dtp))
2582 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2583 next_record (dtp, 1);
2584 flush (dtp->u.p.current_unit->s);
2585 sfree (dtp->u.p.current_unit->s);
2589 dtp->u.p.current_unit->current_record = 0;
2591 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2593 dtp->u.p.seen_dollar = 0;
2594 sfree (dtp->u.p.current_unit->s);
2598 if (dtp->u.p.advance_status == ADVANCE_NO)
2600 flush (dtp->u.p.current_unit->s);
2604 next_record (dtp, 1);
2605 sfree (dtp->u.p.current_unit->s);
2608 /* Transfer function for IOLENGTH. It doesn't actually do any
2609 data transfer, it just updates the length counter. */
2612 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2613 void *dest __attribute__ ((unused)),
2614 int kind __attribute__((unused)),
2615 size_t size, size_t nelems)
2617 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2618 *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2622 /* Initialize the IOLENGTH data transfer. This function is in essence
2623 a very much simplified version of data_transfer_init(), because it
2624 doesn't have to deal with units at all. */
2627 iolength_transfer_init (st_parameter_dt *dtp)
2629 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2632 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2634 /* Set up the subroutine that will handle the transfers. */
2636 dtp->u.p.transfer = iolength_transfer;
2640 /* Library entry point for the IOLENGTH form of the INQUIRE
2641 statement. The IOLENGTH form requires no I/O to be performed, but
2642 it must still be a runtime library call so that we can determine
2643 the iolength for dynamic arrays and such. */
2645 extern void st_iolength (st_parameter_dt *);
2646 export_proto(st_iolength);
2649 st_iolength (st_parameter_dt *dtp)
2651 library_start (&dtp->common);
2652 iolength_transfer_init (dtp);
2655 extern void st_iolength_done (st_parameter_dt *);
2656 export_proto(st_iolength_done);
2659 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2662 if (dtp->u.p.scratch != NULL)
2663 free_mem (dtp->u.p.scratch);
2668 /* The READ statement. */
2670 extern void st_read (st_parameter_dt *);
2671 export_proto(st_read);
2674 st_read (st_parameter_dt *dtp)
2676 library_start (&dtp->common);
2678 data_transfer_init (dtp, 1);
2680 /* Handle complications dealing with the endfile record. It is
2681 significant that this is the only place where ERROR_END is
2682 generated. Reading an end of file elsewhere is either end of
2683 record or an I/O error. */
2685 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2686 switch (dtp->u.p.current_unit->endfile)
2692 if (!is_internal_unit (dtp))
2694 generate_error (&dtp->common, ERROR_END, NULL);
2695 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2696 dtp->u.p.current_unit->current_record = 0;
2701 generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2702 dtp->u.p.current_unit->current_record = 0;
2707 extern void st_read_done (st_parameter_dt *);
2708 export_proto(st_read_done);
2711 st_read_done (st_parameter_dt *dtp)
2713 finalize_transfer (dtp);
2714 free_format_data (dtp);
2716 if (dtp->u.p.scratch != NULL)
2717 free_mem (dtp->u.p.scratch);
2718 if (dtp->u.p.current_unit != NULL)
2719 unlock_unit (dtp->u.p.current_unit);
2721 free_internal_unit (dtp);
2726 extern void st_write (st_parameter_dt *);
2727 export_proto(st_write);
2730 st_write (st_parameter_dt *dtp)
2732 library_start (&dtp->common);
2733 data_transfer_init (dtp, 0);
2736 extern void st_write_done (st_parameter_dt *);
2737 export_proto(st_write_done);
2740 st_write_done (st_parameter_dt *dtp)
2742 finalize_transfer (dtp);
2744 /* Deal with endfile conditions associated with sequential files. */
2746 if (dtp->u.p.current_unit != NULL
2747 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2748 switch (dtp->u.p.current_unit->endfile)
2750 case AT_ENDFILE: /* Remain at the endfile record. */
2754 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2758 /* Get rid of whatever is after this record. */
2759 if (!is_internal_unit (dtp))
2761 flush (dtp->u.p.current_unit->s);
2762 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2763 generate_error (&dtp->common, ERROR_OS, NULL);
2765 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2769 free_format_data (dtp);
2771 if (dtp->u.p.scratch != NULL)
2772 free_mem (dtp->u.p.scratch);
2773 if (dtp->u.p.current_unit != NULL)
2774 unlock_unit (dtp->u.p.current_unit);
2776 free_internal_unit (dtp);
2781 /* Receives the scalar information for namelist objects and stores it
2782 in a linked list of namelist_info types. */
2784 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2785 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2786 export_proto(st_set_nml_var);
2790 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2791 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2792 GFC_INTEGER_4 dtype)
2794 namelist_info *t1 = NULL;
2797 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2799 nml->mem_pos = var_addr;
2801 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2802 strcpy (nml->var_name, var_name);
2804 nml->len = (int) len;
2805 nml->string_length = (index_type) string_length;
2807 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2808 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2809 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2811 if (nml->var_rank > 0)
2813 nml->dim = (descriptor_dimension*)
2814 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2815 nml->ls = (array_loop_spec*)
2816 get_mem (nml->var_rank * sizeof (array_loop_spec));
2826 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2828 dtp->common.flags |= IOPARM_DT_IONML_SET;
2829 dtp->u.p.ionml = nml;
2833 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2838 /* Store the dimensional information for the namelist object. */
2839 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2840 GFC_INTEGER_4, GFC_INTEGER_4,
2842 export_proto(st_set_nml_var_dim);
2845 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2846 GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2847 GFC_INTEGER_4 ubound)
2849 namelist_info * nml;
2854 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2856 nml->dim[n].stride = (ssize_t)stride;
2857 nml->dim[n].lbound = (ssize_t)lbound;
2858 nml->dim[n].ubound = (ssize_t)ubound;
2861 /* Reverse memcpy - used for byte swapping. */
2863 void reverse_memcpy (void *dest, const void *src, size_t n)
2869 s = (char *) src + n - 1;
2871 /* Write with ascending order - this is likely faster
2872 on modern architectures because of write combining. */