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++)
2016 ls[i].idx = desc->dim[i].lbound;
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 - ls[i].start) * ls[i].step;
2061 /* Skip to the end of the current record, taking care of an optional
2062 record marker of size bytes. If the file is not seekable, we
2063 read chunks of size MAX_READ until we get to the right
2066 #define MAX_READ 4096
2069 skip_record (st_parameter_dt *dtp, size_t bytes)
2072 int rlength, length;
2075 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2076 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2079 if (is_seekable (dtp->u.p.current_unit->s))
2081 new = file_position (dtp->u.p.current_unit->s)
2082 + dtp->u.p.current_unit->bytes_left_subrecord;
2084 /* Direct access files do not generate END conditions,
2086 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2087 generate_error (&dtp->common, ERROR_OS, NULL);
2090 { /* Seek by reading data. */
2091 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2094 (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
2095 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2097 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
2100 generate_error (&dtp->common, ERROR_OS, NULL);
2104 dtp->u.p.current_unit->bytes_left_subrecord -= length;
2112 /* Advance to the next record reading unformatted files, taking
2113 care of subrecords. If complete_record is nonzero, we loop
2114 until all subrecords are cleared. */
2117 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2121 bytes = compile_options.record_marker == 0 ?
2122 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2127 /* Skip over tail */
2129 skip_record (dtp, bytes);
2131 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2138 /* Space to the next record for read mode. */
2141 next_record_r (st_parameter_dt *dtp)
2144 int length, bytes_left;
2147 switch (current_mode (dtp))
2149 /* No records in unformatted STREAM I/O. */
2150 case UNFORMATTED_STREAM:
2153 case UNFORMATTED_SEQUENTIAL:
2154 next_record_r_unf (dtp, 1);
2157 case FORMATTED_DIRECT:
2158 case UNFORMATTED_DIRECT:
2159 skip_record (dtp, 0);
2162 case FORMATTED_STREAM:
2163 case FORMATTED_SEQUENTIAL:
2165 /* sf_read has already terminated input because of an '\n' */
2166 if (dtp->u.p.sf_seen_eor)
2168 dtp->u.p.sf_seen_eor = 0;
2172 if (is_internal_unit (dtp))
2174 if (is_array_io (dtp))
2176 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2178 /* Now seek to this record. */
2179 record = record * dtp->u.p.current_unit->recl;
2180 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2182 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2185 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2189 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2190 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2192 dtp->u.p.current_unit->bytes_left
2193 = dtp->u.p.current_unit->recl;
2199 p = salloc_r (dtp->u.p.current_unit->s, &length);
2203 generate_error (&dtp->common, ERROR_OS, NULL);
2209 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2213 if (is_stream_io (dtp))
2214 dtp->u.p.current_unit->strm_pos++;
2221 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2222 test_endfile (dtp->u.p.current_unit);
2226 /* Small utility function to write a record marker, taking care of
2227 byte swapping and of choosing the correct size. */
2230 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2235 char p[sizeof (GFC_INTEGER_8)];
2237 if (compile_options.record_marker == 0)
2238 len = sizeof (GFC_INTEGER_4);
2240 len = compile_options.record_marker;
2242 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2243 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2247 case sizeof (GFC_INTEGER_4):
2249 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2252 case sizeof (GFC_INTEGER_8):
2254 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2258 runtime_error ("Illegal value for record marker");
2266 case sizeof (GFC_INTEGER_4):
2268 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2269 return swrite (dtp->u.p.current_unit->s, p, &len);
2272 case sizeof (GFC_INTEGER_8):
2274 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2275 return swrite (dtp->u.p.current_unit->s, p, &len);
2279 runtime_error ("Illegal value for record marker");
2286 /* Position to the next (sub)record in write mode for
2287 unformatted sequential files. */
2290 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2292 gfc_offset c, m, m_write;
2293 size_t record_marker;
2295 /* Bytes written. */
2296 m = dtp->u.p.current_unit->recl_subrecord
2297 - dtp->u.p.current_unit->bytes_left_subrecord;
2298 c = file_position (dtp->u.p.current_unit->s);
2300 /* Write the length tail. If we finish a record containing
2301 subrecords, we write out the negative length. */
2303 if (dtp->u.p.current_unit->continued)
2308 if (write_us_marker (dtp, m_write) != 0)
2311 if (compile_options.record_marker == 0)
2312 record_marker = sizeof (GFC_INTEGER_4);
2314 record_marker = compile_options.record_marker;
2316 /* Seek to the head and overwrite the bogus length with the real
2319 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2328 if (write_us_marker (dtp, m_write) != 0)
2331 /* Seek past the end of the current record. */
2333 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2339 generate_error (&dtp->common, ERROR_OS, NULL);
2344 /* Position to the next record in write mode. */
2347 next_record_w (st_parameter_dt *dtp, int done)
2349 gfc_offset m, record, max_pos;
2353 /* Zero counters for X- and T-editing. */
2354 max_pos = dtp->u.p.max_pos;
2355 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2357 switch (current_mode (dtp))
2359 /* No records in unformatted STREAM I/O. */
2360 case UNFORMATTED_STREAM:
2363 case FORMATTED_DIRECT:
2364 if (dtp->u.p.current_unit->bytes_left == 0)
2367 if (sset (dtp->u.p.current_unit->s, ' ',
2368 dtp->u.p.current_unit->bytes_left) == FAILURE)
2373 case UNFORMATTED_DIRECT:
2374 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2378 case UNFORMATTED_SEQUENTIAL:
2379 next_record_w_unf (dtp, 0);
2382 case FORMATTED_STREAM:
2383 case FORMATTED_SEQUENTIAL:
2385 if (is_internal_unit (dtp))
2387 if (is_array_io (dtp))
2389 length = (int) dtp->u.p.current_unit->bytes_left;
2391 /* If the farthest position reached is greater than current
2392 position, adjust the position and set length to pad out
2393 whats left. Otherwise just pad whats left.
2394 (for character array unit) */
2395 m = dtp->u.p.current_unit->recl
2396 - dtp->u.p.current_unit->bytes_left;
2399 length = (int) (max_pos - m);
2400 p = salloc_w (dtp->u.p.current_unit->s, &length);
2401 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2404 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2406 generate_error (&dtp->common, ERROR_END, NULL);
2410 /* Now that the current record has been padded out,
2411 determine where the next record in the array is. */
2412 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2414 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2416 /* Now seek to this record */
2417 record = record * dtp->u.p.current_unit->recl;
2419 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2421 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2425 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2431 /* If this is the last call to next_record move to the farthest
2432 position reached and set length to pad out the remainder
2433 of the record. (for character scaler unit) */
2436 m = dtp->u.p.current_unit->recl
2437 - dtp->u.p.current_unit->bytes_left;
2440 length = (int) (max_pos - m);
2441 p = salloc_w (dtp->u.p.current_unit->s, &length);
2442 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2445 length = (int) dtp->u.p.current_unit->bytes_left;
2448 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2450 generate_error (&dtp->common, ERROR_END, NULL);
2458 /* If this is the last call to next_record move to the farthest
2459 position reached in preparation for completing the record.
2463 m = dtp->u.p.current_unit->recl -
2464 dtp->u.p.current_unit->bytes_left;
2467 length = (int) (max_pos - m);
2468 p = salloc_w (dtp->u.p.current_unit->s, &length);
2472 const char crlf[] = "\r\n";
2478 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2481 if (is_stream_io (dtp))
2482 dtp->u.p.current_unit->strm_pos += len;
2488 generate_error (&dtp->common, ERROR_OS, NULL);
2493 /* Position to the next record, which means moving to the end of the
2494 current record. This can happen under several different
2495 conditions. If the done flag is not set, we get ready to process
2499 next_record (st_parameter_dt *dtp, int done)
2501 gfc_offset fp; /* File position. */
2503 dtp->u.p.current_unit->read_bad = 0;
2505 if (dtp->u.p.mode == READING)
2506 next_record_r (dtp);
2508 next_record_w (dtp, done);
2510 if (!is_stream_io (dtp))
2512 /* keep position up to date for INQUIRE */
2513 dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2514 dtp->u.p.current_unit->current_record = 0;
2515 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2517 fp = file_position (dtp->u.p.current_unit->s);
2518 /* Calculate next record, rounding up partial records. */
2519 dtp->u.p.current_unit->last_record =
2520 (fp + dtp->u.p.current_unit->recl - 1) /
2521 dtp->u.p.current_unit->recl;
2524 dtp->u.p.current_unit->last_record++;
2532 /* Finalize the current data transfer. For a nonadvancing transfer,
2533 this means advancing to the next record. For internal units close the
2534 stream associated with the unit. */
2537 finalize_transfer (st_parameter_dt *dtp)
2540 GFC_INTEGER_4 cf = dtp->common.flags;
2542 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2543 *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
2545 if (dtp->u.p.eor_condition)
2547 generate_error (&dtp->common, ERROR_EOR, NULL);
2551 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2554 if ((dtp->u.p.ionml != NULL)
2555 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2557 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2558 namelist_read (dtp);
2560 namelist_write (dtp);
2563 dtp->u.p.transfer = NULL;
2564 if (dtp->u.p.current_unit == NULL)
2567 dtp->u.p.eof_jump = &eof_jump;
2568 if (setjmp (eof_jump))
2570 generate_error (&dtp->common, ERROR_END, NULL);
2574 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2576 finish_list_read (dtp);
2577 sfree (dtp->u.p.current_unit->s);
2581 if (is_stream_io (dtp))
2583 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2584 next_record (dtp, 1);
2585 flush (dtp->u.p.current_unit->s);
2586 sfree (dtp->u.p.current_unit->s);
2590 dtp->u.p.current_unit->current_record = 0;
2592 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2594 dtp->u.p.seen_dollar = 0;
2595 sfree (dtp->u.p.current_unit->s);
2599 if (dtp->u.p.advance_status == ADVANCE_NO)
2601 flush (dtp->u.p.current_unit->s);
2605 next_record (dtp, 1);
2606 sfree (dtp->u.p.current_unit->s);
2609 /* Transfer function for IOLENGTH. It doesn't actually do any
2610 data transfer, it just updates the length counter. */
2613 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2614 void *dest __attribute__ ((unused)),
2615 int kind __attribute__((unused)),
2616 size_t size, size_t nelems)
2618 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2619 *dtp->iolength += (GFC_IO_INT) size * nelems;
2623 /* Initialize the IOLENGTH data transfer. This function is in essence
2624 a very much simplified version of data_transfer_init(), because it
2625 doesn't have to deal with units at all. */
2628 iolength_transfer_init (st_parameter_dt *dtp)
2630 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2633 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2635 /* Set up the subroutine that will handle the transfers. */
2637 dtp->u.p.transfer = iolength_transfer;
2641 /* Library entry point for the IOLENGTH form of the INQUIRE
2642 statement. The IOLENGTH form requires no I/O to be performed, but
2643 it must still be a runtime library call so that we can determine
2644 the iolength for dynamic arrays and such. */
2646 extern void st_iolength (st_parameter_dt *);
2647 export_proto(st_iolength);
2650 st_iolength (st_parameter_dt *dtp)
2652 library_start (&dtp->common);
2653 iolength_transfer_init (dtp);
2656 extern void st_iolength_done (st_parameter_dt *);
2657 export_proto(st_iolength_done);
2660 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2663 if (dtp->u.p.scratch != NULL)
2664 free_mem (dtp->u.p.scratch);
2669 /* The READ statement. */
2671 extern void st_read (st_parameter_dt *);
2672 export_proto(st_read);
2675 st_read (st_parameter_dt *dtp)
2677 library_start (&dtp->common);
2679 data_transfer_init (dtp, 1);
2681 /* Handle complications dealing with the endfile record. It is
2682 significant that this is the only place where ERROR_END is
2683 generated. Reading an end of file elsewhere is either end of
2684 record or an I/O error. */
2686 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2687 switch (dtp->u.p.current_unit->endfile)
2693 if (!is_internal_unit (dtp))
2695 generate_error (&dtp->common, ERROR_END, NULL);
2696 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2697 dtp->u.p.current_unit->current_record = 0;
2702 generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2703 dtp->u.p.current_unit->current_record = 0;
2708 extern void st_read_done (st_parameter_dt *);
2709 export_proto(st_read_done);
2712 st_read_done (st_parameter_dt *dtp)
2714 finalize_transfer (dtp);
2715 free_format_data (dtp);
2717 if (dtp->u.p.scratch != NULL)
2718 free_mem (dtp->u.p.scratch);
2719 if (dtp->u.p.current_unit != NULL)
2720 unlock_unit (dtp->u.p.current_unit);
2722 free_internal_unit (dtp);
2727 extern void st_write (st_parameter_dt *);
2728 export_proto(st_write);
2731 st_write (st_parameter_dt *dtp)
2733 library_start (&dtp->common);
2734 data_transfer_init (dtp, 0);
2737 extern void st_write_done (st_parameter_dt *);
2738 export_proto(st_write_done);
2741 st_write_done (st_parameter_dt *dtp)
2743 finalize_transfer (dtp);
2745 /* Deal with endfile conditions associated with sequential files. */
2747 if (dtp->u.p.current_unit != NULL
2748 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2749 switch (dtp->u.p.current_unit->endfile)
2751 case AT_ENDFILE: /* Remain at the endfile record. */
2755 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2759 /* Get rid of whatever is after this record. */
2760 if (!is_internal_unit (dtp))
2762 flush (dtp->u.p.current_unit->s);
2763 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2764 generate_error (&dtp->common, ERROR_OS, NULL);
2766 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2770 free_format_data (dtp);
2772 if (dtp->u.p.scratch != NULL)
2773 free_mem (dtp->u.p.scratch);
2774 if (dtp->u.p.current_unit != NULL)
2775 unlock_unit (dtp->u.p.current_unit);
2777 free_internal_unit (dtp);
2782 /* Receives the scalar information for namelist objects and stores it
2783 in a linked list of namelist_info types. */
2785 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2786 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2787 export_proto(st_set_nml_var);
2791 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2792 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2793 GFC_INTEGER_4 dtype)
2795 namelist_info *t1 = NULL;
2798 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2800 nml->mem_pos = var_addr;
2802 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2803 strcpy (nml->var_name, var_name);
2805 nml->len = (int) len;
2806 nml->string_length = (index_type) string_length;
2808 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2809 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2810 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2812 if (nml->var_rank > 0)
2814 nml->dim = (descriptor_dimension*)
2815 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2816 nml->ls = (array_loop_spec*)
2817 get_mem (nml->var_rank * sizeof (array_loop_spec));
2827 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2829 dtp->common.flags |= IOPARM_DT_IONML_SET;
2830 dtp->u.p.ionml = nml;
2834 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2839 /* Store the dimensional information for the namelist object. */
2840 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2841 GFC_INTEGER_4, GFC_INTEGER_4,
2843 export_proto(st_set_nml_var_dim);
2846 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2847 GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2848 GFC_INTEGER_4 ubound)
2850 namelist_info * nml;
2855 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2857 nml->dim[n].stride = (ssize_t)stride;
2858 nml->dim[n].lbound = (ssize_t)lbound;
2859 nml->dim[n].ubound = (ssize_t)ubound;
2862 /* Reverse memcpy - used for byte swapping. */
2864 void reverse_memcpy (void *dest, const void *src, size_t n)
2870 s = (char *) src + n - 1;
2872 /* Write with ascending order - this is likely faster
2873 on modern architectures because of write combining. */