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 const st_option advance_opt[] = {
93 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
94 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
100 current_mode (st_parameter_dt *dtp)
104 m = FORM_UNSPECIFIED;
106 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
108 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
109 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
111 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
113 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
114 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
116 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
118 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
119 FORMATTED_STREAM : UNFORMATTED_STREAM;
126 /* Mid level data transfer statements. These subroutines do reading
127 and writing in the style of salloc_r()/salloc_w() within the
130 /* When reading sequential formatted records we have a problem. We
131 don't know how long the line is until we read the trailing newline,
132 and we don't want to read too much. If we read too much, we might
133 have to do a physical seek backwards depending on how much data is
134 present, and devices like terminals aren't seekable and would cause
137 Given this, the solution is to read a byte at a time, stopping if
138 we hit the newline. For small allocations, we use a static buffer.
139 For larger allocations, we are forced to allocate memory on the
140 heap. Hopefully this won't happen very often. */
143 read_sf (st_parameter_dt *dtp, int *length, int no_error)
146 int n, readlen, crlf;
149 if (*length > SCRATCH_SIZE)
150 dtp->u.p.line_buffer = get_mem (*length);
151 p = base = dtp->u.p.line_buffer;
153 /* If we have seen an eor previously, return a length of 0. The
154 caller is responsible for correctly padding the input field. */
155 if (dtp->u.p.sf_seen_eor)
166 if (is_internal_unit (dtp))
168 /* readlen may be modified inside salloc_r if
169 is_internal_unit (dtp) is true. */
173 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
177 /* If we have a line without a terminating \n, drop through to
179 if (readlen < 1 && n == 0)
183 generate_error (&dtp->common, ERROR_END, NULL);
187 if (readlen < 1 || *q == '\n' || *q == '\r')
189 /* Unexpected end of line. */
191 /* If we see an EOR during non-advancing I/O, we need to skip
192 the rest of the I/O statement. Set the corresponding flag. */
193 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
194 dtp->u.p.eor_condition = 1;
197 /* If we encounter a CR, it might be a CRLF. */
198 if (*q == '\r') /* Probably a CRLF */
201 pos = stream_offset (dtp->u.p.current_unit->s);
202 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
203 if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */
204 sseek (dtp->u.p.current_unit->s, pos);
209 /* Without padding, terminate the I/O statement without assigning
210 the value. With padding, the value still needs to be assigned,
211 so we can just continue with a short read. */
212 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
216 generate_error (&dtp->common, ERROR_EOR, NULL);
221 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
224 /* Short circuit the read if a comma is found during numeric input.
225 The flag is set to zero during character reads so that commas in
226 strings are not ignored */
228 if (dtp->u.p.sf_read_comma == 1)
230 notify_std (&dtp->common, GFC_STD_GNU,
231 "Comma in formatted numeric read.");
238 dtp->u.p.sf_seen_eor = 0;
241 dtp->u.p.current_unit->bytes_left -= *length;
243 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
244 dtp->u.p.size_used += (gfc_offset) *length;
250 /* Function for reading the next couple of bytes from the current
251 file, advancing the current position. We return a pointer to a
252 buffer containing the bytes. We return NULL on end of record or
255 If the read is short, then it is because the current record does not
256 have enough data to satisfy the read request and the file was
257 opened with PAD=YES. The caller must assume tailing spaces for
261 read_block (st_parameter_dt *dtp, int *length)
266 if (is_stream_io (dtp))
268 if (sseek (dtp->u.p.current_unit->s,
269 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
271 generate_error (&dtp->common, ERROR_END, NULL);
277 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
279 /* For preconnected units with default record length, set bytes left
280 to unit record length and proceed, otherwise error. */
281 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
282 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
283 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
286 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
288 /* Not enough data left. */
289 generate_error (&dtp->common, ERROR_EOR, NULL);
294 if (dtp->u.p.current_unit->bytes_left == 0)
296 dtp->u.p.current_unit->endfile = AT_ENDFILE;
297 generate_error (&dtp->common, ERROR_END, NULL);
301 *length = dtp->u.p.current_unit->bytes_left;
305 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
306 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
307 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
309 source = read_sf (dtp, length, 0);
310 dtp->u.p.current_unit->strm_pos +=
311 (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
314 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
317 source = salloc_r (dtp->u.p.current_unit->s, &nread);
319 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
320 dtp->u.p.size_used += (gfc_offset) nread;
322 if (nread != *length)
323 { /* Short read, this shouldn't happen. */
324 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
328 generate_error (&dtp->common, ERROR_EOR, NULL);
333 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
339 /* Reads a block directly into application data space. */
342 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
347 if (is_stream_io (dtp))
349 if (sseek (dtp->u.p.current_unit->s,
350 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
352 generate_error (&dtp->common, ERROR_END, NULL);
357 if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
359 generate_error (&dtp->common, ERROR_OS, NULL);
363 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
365 if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
366 generate_error (&dtp->common, ERROR_END, NULL);
371 /* Unformatted file with records */
372 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
375 nread = (size_t) dtp->u.p.current_unit->bytes_left;
378 if (dtp->u.p.current_unit->bytes_left == 0)
380 dtp->u.p.current_unit->endfile = AT_ENDFILE;
381 generate_error (&dtp->common, ERROR_END, NULL);
392 dtp->u.p.current_unit->bytes_left -= nread;
394 if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
396 generate_error (&dtp->common, ERROR_OS, NULL);
400 if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
403 generate_error (&dtp->common, ERROR_END, NULL);
409 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
415 /* Function for writing a block of bytes to the current file at the
416 current position, advancing the file pointer. We are given a length
417 and return a pointer to a buffer that the caller must (completely)
418 fill in. Returns NULL on error. */
421 write_block (st_parameter_dt *dtp, int length)
425 if (is_stream_io (dtp))
427 if (sseek (dtp->u.p.current_unit->s,
428 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
430 generate_error (&dtp->common, ERROR_OS, NULL);
436 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
438 /* For preconnected units with default record length, set bytes left
439 to unit record length and proceed, otherwise error. */
440 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
441 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
442 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
443 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
446 generate_error (&dtp->common, ERROR_EOR, NULL);
451 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
454 dest = salloc_w (dtp->u.p.current_unit->s, &length);
458 generate_error (&dtp->common, ERROR_END, NULL);
462 if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
463 generate_error (&dtp->common, ERROR_END, NULL);
465 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
466 dtp->u.p.size_used += (gfc_offset) length;
468 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
474 /* High level interface to swrite(), taking care of errors. */
477 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
479 if (is_stream_io (dtp))
481 if (sseek (dtp->u.p.current_unit->s,
482 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
484 generate_error (&dtp->common, ERROR_OS, NULL);
490 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
492 /* For preconnected units with default record length, set
493 bytes left to unit record length and proceed, otherwise
495 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
496 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
497 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
498 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
501 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
502 generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
504 generate_error (&dtp->common, ERROR_EOR, NULL);
509 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
512 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
514 generate_error (&dtp->common, ERROR_OS, NULL);
518 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
519 dtp->u.p.size_used += (gfc_offset) nbytes;
521 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
527 /* Master function for unformatted reads. */
530 unformatted_read (st_parameter_dt *dtp, bt type,
531 void *dest, int kind,
532 size_t size, size_t nelems)
536 /* Currently, character implies size=1. */
537 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
538 || size == 1 || type == BT_CHARACTER)
541 read_block_direct (dtp, dest, &sz);
548 /* Break up complex into its constituent reals. */
549 if (type == BT_COMPLEX)
556 /* By now, all complex variables have been split into their
557 constituent reals. For types with padding, we only need to
558 read kind bytes. We don't care about the contents
559 of the padding. If we hit a short record, then sz is
560 adjusted accordingly, making later reads no-ops. */
563 for (i=0; i<nelems; i++)
565 read_block_direct (dtp, buffer, &sz);
566 reverse_memcpy (p, buffer, sz);
573 /* Master function for unformatted writes. */
576 unformatted_write (st_parameter_dt *dtp, bt type,
577 void *source, int kind,
578 size_t size, size_t nelems)
580 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
581 size == 1 || type == BT_CHARACTER)
585 write_buf (dtp, source, size);
593 /* Break up complex into its constituent reals. */
594 if (type == BT_COMPLEX)
602 /* By now, all complex variables have been split into their
603 constituent reals. For types with padding, we only need to
604 read kind bytes. We don't care about the contents
608 for (i=0; i<nelems; i++)
610 reverse_memcpy(buffer, p, size);
612 write_buf (dtp, buffer, sz);
618 /* Return a pointer to the name of a type. */
643 internal_error (NULL, "type_name(): Bad type");
650 /* Write a constant string to the output.
651 This is complicated because the string can have doubled delimiters
652 in it. The length in the format node is the true length. */
655 write_constant_string (st_parameter_dt *dtp, const fnode *f)
657 char c, delimiter, *p, *q;
660 length = f->u.string.length;
664 p = write_block (dtp, length);
671 for (; length > 0; length--)
674 if (c == delimiter && c != 'H' && c != 'h')
675 q++; /* Skip the doubled delimiter. */
680 /* Given actual and expected types in a formatted data transfer, make
681 sure they agree. If not, an error message is generated. Returns
682 nonzero if something went wrong. */
685 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
689 if (actual == expected)
692 st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
693 type_name (expected), dtp->u.p.item_count, type_name (actual));
695 format_error (dtp, f, buffer);
700 /* This subroutine is the main loop for a formatted data transfer
701 statement. It would be natural to implement this as a coroutine
702 with the user program, but C makes that awkward. We loop,
703 processing format elements. When we actually have to transfer
704 data instead of just setting flags, we return control to the user
705 program which calls a subroutine that supplies the address and type
706 of the next element, then comes back here to process it. */
709 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
712 char scratch[SCRATCH_SIZE];
717 int consume_data_flag;
719 /* Change a complex data item into a pair of reals. */
721 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
722 if (type == BT_COMPLEX)
728 /* If there's an EOR condition, we simulate finalizing the transfer
730 if (dtp->u.p.eor_condition)
733 /* Set this flag so that commas in reads cause the read to complete before
734 the entire field has been read. The next read field will start right after
735 the comma in the stream. (Set to 0 for character reads). */
736 dtp->u.p.sf_read_comma = 1;
738 dtp->u.p.line_buffer = scratch;
741 /* If reversion has occurred and there is another real data item,
742 then we have to move to the next record. */
743 if (dtp->u.p.reversion_flag && n > 0)
745 dtp->u.p.reversion_flag = 0;
746 next_record (dtp, 0);
749 consume_data_flag = 1 ;
750 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
753 f = next_format (dtp);
756 /* No data descriptors left. */
758 generate_error (&dtp->common, ERROR_FORMAT,
759 "Insufficient data descriptors in format after reversion");
763 /* Now discharge T, TR and X movements to the right. This is delayed
764 until a data producing format to suppress trailing spaces. */
767 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
768 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
769 || t == FMT_Z || t == FMT_F || t == FMT_E
770 || t == FMT_EN || t == FMT_ES || t == FMT_G
771 || t == FMT_L || t == FMT_A || t == FMT_D))
774 if (dtp->u.p.skips > 0)
776 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
777 dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
778 - dtp->u.p.current_unit->bytes_left);
780 if (dtp->u.p.skips < 0)
782 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
783 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
785 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
788 bytes_used = (int)(dtp->u.p.current_unit->recl
789 - dtp->u.p.current_unit->bytes_left);
796 if (require_type (dtp, BT_INTEGER, type, f))
799 if (dtp->u.p.mode == READING)
800 read_decimal (dtp, f, p, len);
802 write_i (dtp, f, p, len);
810 if (compile_options.allow_std < GFC_STD_GNU
811 && require_type (dtp, BT_INTEGER, type, f))
814 if (dtp->u.p.mode == READING)
815 read_radix (dtp, f, p, len, 2);
817 write_b (dtp, f, p, len);
825 if (compile_options.allow_std < GFC_STD_GNU
826 && require_type (dtp, BT_INTEGER, type, f))
829 if (dtp->u.p.mode == READING)
830 read_radix (dtp, f, p, len, 8);
832 write_o (dtp, f, p, len);
840 if (compile_options.allow_std < GFC_STD_GNU
841 && require_type (dtp, BT_INTEGER, type, f))
844 if (dtp->u.p.mode == READING)
845 read_radix (dtp, f, p, len, 16);
847 write_z (dtp, f, p, len);
855 if (dtp->u.p.mode == READING)
856 read_a (dtp, f, p, len);
858 write_a (dtp, f, p, len);
866 if (dtp->u.p.mode == READING)
867 read_l (dtp, f, p, len);
869 write_l (dtp, f, p, len);
876 if (require_type (dtp, BT_REAL, type, f))
879 if (dtp->u.p.mode == READING)
880 read_f (dtp, f, p, len);
882 write_d (dtp, f, p, len);
889 if (require_type (dtp, BT_REAL, type, f))
892 if (dtp->u.p.mode == READING)
893 read_f (dtp, f, p, len);
895 write_e (dtp, f, p, len);
901 if (require_type (dtp, BT_REAL, type, f))
904 if (dtp->u.p.mode == READING)
905 read_f (dtp, f, p, len);
907 write_en (dtp, f, p, len);
914 if (require_type (dtp, BT_REAL, type, f))
917 if (dtp->u.p.mode == READING)
918 read_f (dtp, f, p, len);
920 write_es (dtp, f, p, len);
927 if (require_type (dtp, BT_REAL, type, f))
930 if (dtp->u.p.mode == READING)
931 read_f (dtp, f, p, len);
933 write_f (dtp, f, p, len);
940 if (dtp->u.p.mode == READING)
944 read_decimal (dtp, f, p, len);
947 read_l (dtp, f, p, len);
950 read_a (dtp, f, p, len);
953 read_f (dtp, f, p, len);
962 write_i (dtp, f, p, len);
965 write_l (dtp, f, p, len);
968 write_a (dtp, f, p, len);
971 write_d (dtp, f, p, len);
975 internal_error (&dtp->common,
976 "formatted_transfer(): Bad type");
982 consume_data_flag = 0 ;
983 if (dtp->u.p.mode == READING)
985 format_error (dtp, f, "Constant string in input format");
988 write_constant_string (dtp, f);
991 /* Format codes that don't transfer data. */
994 consume_data_flag = 0 ;
996 pos = bytes_used + f->u.n + dtp->u.p.skips;
997 dtp->u.p.skips = f->u.n + dtp->u.p.skips;
998 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1000 /* Writes occur just before the switch on f->format, above, so
1001 that trailing blanks are suppressed, unless we are doing a
1002 non-advancing write in which case we want to output the blanks
1004 if (dtp->u.p.mode == WRITING
1005 && dtp->u.p.advance_status == ADVANCE_NO)
1007 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1008 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1010 if (dtp->u.p.mode == READING)
1011 read_x (dtp, f->u.n);
1017 if (f->format == FMT_TL)
1020 /* Handle the special case when no bytes have been used yet.
1021 Cannot go below zero. */
1022 if (bytes_used == 0)
1024 dtp->u.p.pending_spaces -= f->u.n;
1025 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1026 : dtp->u.p.pending_spaces;
1027 dtp->u.p.skips -= f->u.n;
1028 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1031 pos = bytes_used - f->u.n;
1035 consume_data_flag = 0;
1039 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1040 left tab limit. We do not check if the position has gone
1041 beyond the end of record because a subsequent tab could
1042 bring us back again. */
1043 pos = pos < 0 ? 0 : pos;
1045 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1046 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1047 + pos - dtp->u.p.max_pos;
1049 if (dtp->u.p.skips == 0)
1052 /* Writes occur just before the switch on f->format, above, so that
1053 trailing blanks are suppressed. */
1054 if (dtp->u.p.mode == READING)
1056 /* Adjust everything for end-of-record condition */
1057 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1059 if (dtp->u.p.sf_seen_eor == 2)
1061 /* The EOR was a CRLF (two bytes wide). */
1062 dtp->u.p.current_unit->bytes_left -= 2;
1063 dtp->u.p.skips -= 2;
1067 /* The EOR marker was only one byte wide. */
1068 dtp->u.p.current_unit->bytes_left--;
1072 dtp->u.p.sf_seen_eor = 0;
1074 if (dtp->u.p.skips < 0)
1076 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1077 dtp->u.p.current_unit->bytes_left
1078 -= (gfc_offset) dtp->u.p.skips;
1079 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1082 read_x (dtp, dtp->u.p.skips);
1088 consume_data_flag = 0 ;
1089 dtp->u.p.sign_status = SIGN_S;
1093 consume_data_flag = 0 ;
1094 dtp->u.p.sign_status = SIGN_SS;
1098 consume_data_flag = 0 ;
1099 dtp->u.p.sign_status = SIGN_SP;
1103 consume_data_flag = 0 ;
1104 dtp->u.p.blank_status = BLANK_NULL;
1108 consume_data_flag = 0 ;
1109 dtp->u.p.blank_status = BLANK_ZERO;
1113 consume_data_flag = 0 ;
1114 dtp->u.p.scale_factor = f->u.k;
1118 consume_data_flag = 0 ;
1119 dtp->u.p.seen_dollar = 1;
1123 consume_data_flag = 0 ;
1124 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1125 next_record (dtp, 0);
1129 /* A colon descriptor causes us to exit this loop (in
1130 particular preventing another / descriptor from being
1131 processed) unless there is another data item to be
1133 consume_data_flag = 0 ;
1139 internal_error (&dtp->common, "Bad format node");
1142 /* Free a buffer that we had to allocate during a sequential
1143 formatted read of a block that was larger than the static
1146 if (dtp->u.p.line_buffer != scratch)
1148 free_mem (dtp->u.p.line_buffer);
1149 dtp->u.p.line_buffer = scratch;
1152 /* Adjust the item count and data pointer. */
1154 if ((consume_data_flag > 0) && (n > 0))
1157 p = ((char *) p) + size;
1160 if (dtp->u.p.mode == READING)
1163 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1164 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1170 /* Come here when we need a data descriptor but don't have one. We
1171 push the current format node back onto the input, then return and
1172 let the user program call us back with the data. */
1174 unget_format (dtp, f);
1178 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1179 size_t size, size_t nelems)
1186 /* Big loop over all the elements. */
1187 for (elem = 0; elem < nelems; elem++)
1189 dtp->u.p.item_count++;
1190 formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1196 /* Data transfer entry points. The type of the data entity is
1197 implicit in the subroutine call. This prevents us from having to
1198 share a common enum with the compiler. */
1201 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1203 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1205 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1210 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1213 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1215 size = size_from_real_kind (kind);
1216 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1221 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1223 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1225 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1230 transfer_character (st_parameter_dt *dtp, void *p, int len)
1232 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1234 /* Currently we support only 1 byte chars, and the library is a bit
1235 confused of character kind vs. length, so we kludge it by setting
1237 dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1242 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1245 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1247 size = size_from_complex_kind (kind);
1248 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1253 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1254 gfc_charlen_type charlen)
1256 index_type count[GFC_MAX_DIMENSIONS];
1257 index_type extent[GFC_MAX_DIMENSIONS];
1258 index_type stride[GFC_MAX_DIMENSIONS];
1259 index_type stride0, rank, size, type, n;
1264 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1267 type = GFC_DESCRIPTOR_TYPE (desc);
1268 size = GFC_DESCRIPTOR_SIZE (desc);
1270 /* FIXME: What a kludge: Array descriptors and the IO library use
1271 different enums for types. */
1274 case GFC_DTYPE_UNKNOWN:
1275 iotype = BT_NULL; /* Is this correct? */
1277 case GFC_DTYPE_INTEGER:
1278 iotype = BT_INTEGER;
1280 case GFC_DTYPE_LOGICAL:
1281 iotype = BT_LOGICAL;
1283 case GFC_DTYPE_REAL:
1286 case GFC_DTYPE_COMPLEX:
1287 iotype = BT_COMPLEX;
1289 case GFC_DTYPE_CHARACTER:
1290 iotype = BT_CHARACTER;
1291 /* FIXME: Currently dtype contains the charlen, which is
1292 clobbered if charlen > 2**24. That's why we use a separate
1293 argument for the charlen. However, if we want to support
1294 non-8-bit charsets we need to fix dtype to contain
1295 sizeof(chartype) and fix the code below. */
1299 case GFC_DTYPE_DERIVED:
1300 internal_error (&dtp->common,
1301 "Derived type I/O should have been handled via the frontend.");
1304 internal_error (&dtp->common, "transfer_array(): Bad type");
1307 rank = GFC_DESCRIPTOR_RANK (desc);
1308 for (n = 0; n < rank; n++)
1311 stride[n] = desc->dim[n].stride;
1312 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1314 /* If the extent of even one dimension is zero, then the entire
1315 array section contains zero elements, so we return. */
1320 stride0 = stride[0];
1322 /* If the innermost dimension has stride 1, we can do the transfer
1323 in contiguous chunks. */
1329 data = GFC_DESCRIPTOR_DATA (desc);
1333 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1334 data += stride0 * size * tsize;
1337 while (count[n] == extent[n])
1340 data -= stride[n] * extent[n] * size;
1350 data += stride[n] * size;
1357 /* Preposition a sequential unformatted file while reading. */
1360 us_read (st_parameter_dt *dtp)
1369 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1372 if (compile_options.record_marker == 0)
1373 n = sizeof (gfc_offset);
1375 n = compile_options.record_marker;
1379 p = salloc_r (dtp->u.p.current_unit->s, &n);
1383 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1384 return; /* end of file */
1387 if (p == NULL || n != nr)
1389 generate_error (&dtp->common, ERROR_BAD_US, NULL);
1393 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1394 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1396 switch (compile_options.record_marker)
1399 memcpy (&i, p, sizeof(gfc_offset));
1402 case sizeof(GFC_INTEGER_4):
1403 memcpy (&i4, p, sizeof (i4));
1407 case sizeof(GFC_INTEGER_8):
1408 memcpy (&i8, p, sizeof (i8));
1413 runtime_error ("Illegal value for record marker");
1418 switch (compile_options.record_marker)
1421 reverse_memcpy (&i, p, sizeof(gfc_offset));
1424 case sizeof(GFC_INTEGER_4):
1425 reverse_memcpy (&i4, p, sizeof (i4));
1429 case sizeof(GFC_INTEGER_8):
1430 reverse_memcpy (&i8, p, sizeof (i8));
1435 runtime_error ("Illegal value for record marker");
1439 dtp->u.p.current_unit->bytes_left = i;
1443 /* Preposition a sequential unformatted file while writing. This
1444 amount to writing a bogus length that will be filled in later. */
1447 us_write (st_parameter_dt *dtp)
1454 if (compile_options.record_marker == 0)
1455 nbytes = sizeof (gfc_offset);
1457 nbytes = compile_options.record_marker ;
1459 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1460 generate_error (&dtp->common, ERROR_OS, NULL);
1462 /* For sequential unformatted, we write until we have more bytes
1463 than can fit in the record markers. If disk space runs out first,
1464 it will error on the write. */
1465 dtp->u.p.current_unit->recl = max_offset;
1467 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1471 /* Position to the next record prior to transfer. We are assumed to
1472 be before the next record. We also calculate the bytes in the next
1476 pre_position (st_parameter_dt *dtp)
1478 if (dtp->u.p.current_unit->current_record)
1479 return; /* Already positioned. */
1481 switch (current_mode (dtp))
1483 case FORMATTED_STREAM:
1484 case UNFORMATTED_STREAM:
1485 /* There are no records with stream I/O. Set the default position
1486 to the beginning of the file if no position was specified. */
1487 if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1488 dtp->u.p.current_unit->strm_pos = 1;
1491 case UNFORMATTED_SEQUENTIAL:
1492 if (dtp->u.p.mode == READING)
1499 case FORMATTED_SEQUENTIAL:
1500 case FORMATTED_DIRECT:
1501 case UNFORMATTED_DIRECT:
1502 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1506 dtp->u.p.current_unit->current_record = 1;
1510 /* Initialize things for a data transfer. This code is common for
1511 both reading and writing. */
1514 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1516 unit_flags u_flags; /* Used for creating a unit if needed. */
1517 GFC_INTEGER_4 cf = dtp->common.flags;
1518 namelist_info *ionml;
1520 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1521 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1522 dtp->u.p.ionml = ionml;
1523 dtp->u.p.mode = read_flag ? READING : WRITING;
1525 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1526 dtp->u.p.size_used = 0; /* Initialize the count. */
1528 dtp->u.p.current_unit = get_unit (dtp, 1);
1529 if (dtp->u.p.current_unit->s == NULL)
1530 { /* Open the unit with some default flags. */
1531 st_parameter_open opp;
1534 if (dtp->common.unit < 0)
1536 close_unit (dtp->u.p.current_unit);
1537 dtp->u.p.current_unit = NULL;
1538 generate_error (&dtp->common, ERROR_BAD_OPTION,
1539 "Bad unit number in OPEN statement");
1542 memset (&u_flags, '\0', sizeof (u_flags));
1543 u_flags.access = ACCESS_SEQUENTIAL;
1544 u_flags.action = ACTION_READWRITE;
1546 /* Is it unformatted? */
1547 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1548 | IOPARM_DT_IONML_SET)))
1549 u_flags.form = FORM_UNFORMATTED;
1551 u_flags.form = FORM_UNSPECIFIED;
1553 u_flags.delim = DELIM_UNSPECIFIED;
1554 u_flags.blank = BLANK_UNSPECIFIED;
1555 u_flags.pad = PAD_UNSPECIFIED;
1556 u_flags.status = STATUS_UNKNOWN;
1558 conv = get_unformatted_convert (dtp->common.unit);
1560 if (conv == CONVERT_NONE)
1561 conv = compile_options.convert;
1563 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1564 and 1 on big-endian machines. */
1567 case CONVERT_NATIVE:
1572 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1575 case CONVERT_LITTLE:
1576 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1580 internal_error (&opp.common, "Illegal value for CONVERT");
1584 u_flags.convert = conv;
1586 opp.common = dtp->common;
1587 opp.common.flags &= IOPARM_COMMON_MASK;
1588 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1589 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1590 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1591 if (dtp->u.p.current_unit == NULL)
1595 /* Check the action. */
1597 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1598 generate_error (&dtp->common, ERROR_BAD_ACTION,
1599 "Cannot read from file opened for WRITE");
1601 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1602 generate_error (&dtp->common, ERROR_BAD_ACTION,
1603 "Cannot write to file opened for READ");
1605 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1608 dtp->u.p.first_item = 1;
1610 /* Check the format. */
1612 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1615 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1618 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1619 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1621 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1622 "Format present for UNFORMATTED data transfer");
1624 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1626 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1627 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1628 "A format cannot be specified with a namelist");
1630 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1631 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1632 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1633 "Missing format for FORMATTED data transfer");
1635 if (is_internal_unit (dtp)
1636 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1637 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1638 "Internal file cannot be accessed by UNFORMATTED data transfer");
1640 /* Check the record or position number. */
1642 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1643 && (cf & IOPARM_DT_HAS_REC) == 0)
1645 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1646 "Direct access data transfer requires record number");
1650 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1651 && (cf & IOPARM_DT_HAS_REC) != 0)
1653 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1654 "Record number not allowed for sequential access data transfer");
1658 /* Process the ADVANCE option. */
1660 dtp->u.p.advance_status
1661 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1662 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1663 "Bad ADVANCE parameter in data transfer statement");
1665 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1667 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1668 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1669 "ADVANCE specification conflicts with sequential access");
1671 if (is_internal_unit (dtp))
1672 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1673 "ADVANCE specification conflicts with internal file");
1675 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1676 != IOPARM_DT_HAS_FORMAT)
1677 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1678 "ADVANCE specification requires an explicit format");
1683 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1684 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1685 "EOR specification requires an ADVANCE specification of NO");
1687 if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1688 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1689 "SIZE specification requires an ADVANCE specification of NO");
1693 { /* Write constraints. */
1694 if ((cf & IOPARM_END) != 0)
1695 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1696 "END specification cannot appear in a write statement");
1698 if ((cf & IOPARM_EOR) != 0)
1699 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1700 "EOR specification cannot appear in a write statement");
1702 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1703 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1704 "SIZE specification cannot appear in a write statement");
1707 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1708 dtp->u.p.advance_status = ADVANCE_YES;
1709 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1712 /* Sanity checks on the record number. */
1713 if ((cf & IOPARM_DT_HAS_REC) != 0)
1717 generate_error (&dtp->common, ERROR_BAD_OPTION,
1718 "Record number must be positive");
1722 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1724 generate_error (&dtp->common, ERROR_BAD_OPTION,
1725 "Record number too large");
1729 /* Check to see if we might be reading what we wrote before */
1731 if (dtp->u.p.mode == READING
1732 && dtp->u.p.current_unit->mode == WRITING
1733 && !is_internal_unit (dtp))
1734 flush(dtp->u.p.current_unit->s);
1736 /* Check whether the record exists to be read. Only
1737 a partial record needs to exist. */
1739 if (dtp->u.p.mode == READING && (dtp->rec -1)
1740 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1742 generate_error (&dtp->common, ERROR_BAD_OPTION,
1743 "Non-existing record number");
1747 /* Position the file. */
1748 if (!is_stream_io (dtp))
1750 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1751 * dtp->u.p.current_unit->recl) == FAILURE)
1753 generate_error (&dtp->common, ERROR_OS, NULL);
1758 dtp->u.p.current_unit->strm_pos = dtp->rec;
1762 /* Overwriting an existing sequential file ?
1763 it is always safe to truncate the file on the first write */
1764 if (dtp->u.p.mode == WRITING
1765 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1766 && dtp->u.p.current_unit->last_record == 0
1767 && !is_preconnected(dtp->u.p.current_unit->s))
1768 struncate(dtp->u.p.current_unit->s);
1770 /* Bugware for badly written mixed C-Fortran I/O. */
1771 flush_if_preconnected(dtp->u.p.current_unit->s);
1773 dtp->u.p.current_unit->mode = dtp->u.p.mode;
1775 /* Set the initial value of flags. */
1777 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1778 dtp->u.p.sign_status = SIGN_S;
1782 /* Set up the subroutine that will handle the transfers. */
1786 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1787 dtp->u.p.transfer = unformatted_read;
1790 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1791 dtp->u.p.transfer = list_formatted_read;
1793 dtp->u.p.transfer = formatted_transfer;
1798 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1799 dtp->u.p.transfer = unformatted_write;
1802 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1803 dtp->u.p.transfer = list_formatted_write;
1805 dtp->u.p.transfer = formatted_transfer;
1809 /* Make sure that we don't do a read after a nonadvancing write. */
1813 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1815 generate_error (&dtp->common, ERROR_BAD_OPTION,
1816 "Cannot READ after a nonadvancing WRITE");
1822 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1823 dtp->u.p.current_unit->read_bad = 1;
1826 /* Start the data transfer if we are doing a formatted transfer. */
1827 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1828 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1829 && dtp->u.p.ionml == NULL)
1830 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
1833 /* Initialize an array_loop_spec given the array descriptor. The function
1834 returns the index of the last element of the array. */
1837 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1839 int rank = GFC_DESCRIPTOR_RANK(desc);
1844 for (i=0; i<rank; i++)
1847 ls[i].start = desc->dim[i].lbound;
1848 ls[i].end = desc->dim[i].ubound;
1849 ls[i].step = desc->dim[i].stride;
1851 index += (desc->dim[i].ubound - desc->dim[i].lbound)
1852 * desc->dim[i].stride;
1857 /* Determine the index to the next record in an internal unit array by
1858 by incrementing through the array_loop_spec. TODO: Implement handling
1859 negative strides. */
1862 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
1870 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
1875 if (ls[i].idx > ls[i].end)
1877 ls[i].idx = ls[i].start;
1883 index = index + (ls[i].idx - 1) * ls[i].step;
1888 /* Space to the next record for read mode. If the file is not
1889 seekable, we read MAX_READ chunks until we get to the right
1892 #define MAX_READ 4096
1895 next_record_r (st_parameter_dt *dtp)
1897 gfc_offset new, record;
1898 int bytes_left, rlength, length;
1901 switch (current_mode (dtp))
1903 /* No records in unformatted STREAM I/O. */
1904 case UNFORMATTED_STREAM:
1907 case UNFORMATTED_SEQUENTIAL:
1909 /* Skip over tail */
1910 dtp->u.p.current_unit->bytes_left +=
1911 compile_options.record_marker == 0 ?
1912 sizeof (gfc_offset) : compile_options.record_marker;
1914 /* Fall through... */
1916 case FORMATTED_DIRECT:
1917 case UNFORMATTED_DIRECT:
1918 if (dtp->u.p.current_unit->bytes_left == 0)
1921 if (is_seekable (dtp->u.p.current_unit->s))
1923 new = file_position (dtp->u.p.current_unit->s)
1924 + dtp->u.p.current_unit->bytes_left;
1926 /* Direct access files do not generate END conditions,
1928 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1929 generate_error (&dtp->common, ERROR_OS, NULL);
1933 { /* Seek by reading data. */
1934 while (dtp->u.p.current_unit->bytes_left > 0)
1936 rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1937 MAX_READ : dtp->u.p.current_unit->bytes_left;
1939 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1942 generate_error (&dtp->common, ERROR_OS, NULL);
1946 dtp->u.p.current_unit->bytes_left -= length;
1951 case FORMATTED_STREAM:
1952 case FORMATTED_SEQUENTIAL:
1954 /* sf_read has already terminated input because of an '\n' */
1955 if (dtp->u.p.sf_seen_eor)
1957 dtp->u.p.sf_seen_eor = 0;
1961 if (is_internal_unit (dtp))
1963 if (is_array_io (dtp))
1965 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1967 /* Now seek to this record. */
1968 record = record * dtp->u.p.current_unit->recl;
1969 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1971 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
1974 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1978 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
1979 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
1981 dtp->u.p.current_unit->bytes_left
1982 = dtp->u.p.current_unit->recl;
1988 p = salloc_r (dtp->u.p.current_unit->s, &length);
1992 generate_error (&dtp->common, ERROR_OS, NULL);
1998 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2002 if (is_stream_io (dtp))
2003 dtp->u.p.current_unit->strm_pos++;
2010 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2011 test_endfile (dtp->u.p.current_unit);
2015 /* Small utility function to write a record marker, taking care of
2016 byte swapping and of choosing the correct size. */
2019 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2024 char p[sizeof (GFC_INTEGER_8)];
2026 if (compile_options.record_marker == 0)
2027 len = sizeof (gfc_offset);
2029 len = compile_options.record_marker;
2031 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2032 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2034 switch (compile_options.record_marker)
2037 return swrite (dtp->u.p.current_unit->s, &buf, &len);
2040 case sizeof (GFC_INTEGER_4):
2042 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2045 case sizeof (GFC_INTEGER_8):
2047 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2051 runtime_error ("Illegal value for record marker");
2057 switch (compile_options.record_marker)
2060 reverse_memcpy (p, &buf, sizeof (gfc_offset));
2061 return swrite (dtp->u.p.current_unit->s, p, &len);
2064 case sizeof (GFC_INTEGER_4):
2066 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2067 return swrite (dtp->u.p.current_unit->s, p, &len);
2070 case sizeof (GFC_INTEGER_8):
2072 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
2073 return swrite (dtp->u.p.current_unit->s, p, &len);
2077 runtime_error ("Illegal value for record marker");
2085 /* Position to the next record in write mode. */
2088 next_record_w (st_parameter_dt *dtp, int done)
2090 gfc_offset c, m, record, max_pos;
2093 size_t record_marker;
2095 /* Zero counters for X- and T-editing. */
2096 max_pos = dtp->u.p.max_pos;
2097 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2099 switch (current_mode (dtp))
2101 /* No records in unformatted STREAM I/O. */
2102 case UNFORMATTED_STREAM:
2105 case FORMATTED_DIRECT:
2106 if (dtp->u.p.current_unit->bytes_left == 0)
2109 if (sset (dtp->u.p.current_unit->s, ' ',
2110 dtp->u.p.current_unit->bytes_left) == FAILURE)
2115 case UNFORMATTED_DIRECT:
2116 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2120 case UNFORMATTED_SEQUENTIAL:
2121 /* Bytes written. */
2122 m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
2123 c = file_position (dtp->u.p.current_unit->s);
2125 /* Write the length tail. */
2127 if (write_us_marker (dtp, m) != 0)
2130 if (compile_options.record_marker == 4)
2131 record_marker = sizeof(GFC_INTEGER_4);
2133 record_marker = sizeof (gfc_offset);
2135 /* Seek to the head and overwrite the bogus length with the real
2138 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2142 if (write_us_marker (dtp, m) != 0)
2145 /* Seek past the end of the current record. */
2147 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2152 case FORMATTED_STREAM:
2153 case FORMATTED_SEQUENTIAL:
2155 if (is_internal_unit (dtp))
2157 if (is_array_io (dtp))
2159 length = (int) dtp->u.p.current_unit->bytes_left;
2161 /* If the farthest position reached is greater than current
2162 position, adjust the position and set length to pad out
2163 whats left. Otherwise just pad whats left.
2164 (for character array unit) */
2165 m = dtp->u.p.current_unit->recl
2166 - dtp->u.p.current_unit->bytes_left;
2169 length = (int) (max_pos - m);
2170 p = salloc_w (dtp->u.p.current_unit->s, &length);
2171 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2174 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2176 generate_error (&dtp->common, ERROR_END, NULL);
2180 /* Now that the current record has been padded out,
2181 determine where the next record in the array is. */
2182 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2184 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2186 /* Now seek to this record */
2187 record = record * dtp->u.p.current_unit->recl;
2189 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2191 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2195 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2201 /* If this is the last call to next_record move to the farthest
2202 position reached and set length to pad out the remainder
2203 of the record. (for character scaler unit) */
2206 m = dtp->u.p.current_unit->recl
2207 - dtp->u.p.current_unit->bytes_left;
2210 length = (int) (max_pos - m);
2211 p = salloc_w (dtp->u.p.current_unit->s, &length);
2212 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2215 length = (int) dtp->u.p.current_unit->bytes_left;
2218 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2220 generate_error (&dtp->common, ERROR_END, NULL);
2228 /* If this is the last call to next_record move to the farthest
2229 position reached in preparation for completing the record.
2233 m = dtp->u.p.current_unit->recl -
2234 dtp->u.p.current_unit->bytes_left;
2237 length = (int) (max_pos - m);
2238 p = salloc_w (dtp->u.p.current_unit->s, &length);
2242 const char crlf[] = "\r\n";
2248 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2251 if (is_stream_io (dtp))
2252 dtp->u.p.current_unit->strm_pos += len;
2258 generate_error (&dtp->common, ERROR_OS, NULL);
2263 /* Position to the next record, which means moving to the end of the
2264 current record. This can happen under several different
2265 conditions. If the done flag is not set, we get ready to process
2269 next_record (st_parameter_dt *dtp, int done)
2271 gfc_offset fp; /* File position. */
2273 dtp->u.p.current_unit->read_bad = 0;
2275 if (dtp->u.p.mode == READING)
2276 next_record_r (dtp);
2278 next_record_w (dtp, done);
2280 if (!is_stream_io (dtp))
2282 /* keep position up to date for INQUIRE */
2283 dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2284 dtp->u.p.current_unit->current_record = 0;
2285 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2287 fp = file_position (dtp->u.p.current_unit->s);
2288 /* Calculate next record, rounding up partial records. */
2289 dtp->u.p.current_unit->last_record =
2290 (fp + dtp->u.p.current_unit->recl - 1) /
2291 dtp->u.p.current_unit->recl;
2294 dtp->u.p.current_unit->last_record++;
2302 /* Finalize the current data transfer. For a nonadvancing transfer,
2303 this means advancing to the next record. For internal units close the
2304 stream associated with the unit. */
2307 finalize_transfer (st_parameter_dt *dtp)
2310 GFC_INTEGER_4 cf = dtp->common.flags;
2312 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2313 *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2315 if (dtp->u.p.eor_condition)
2317 generate_error (&dtp->common, ERROR_EOR, NULL);
2321 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2324 if ((dtp->u.p.ionml != NULL)
2325 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2327 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2328 namelist_read (dtp);
2330 namelist_write (dtp);
2333 dtp->u.p.transfer = NULL;
2334 if (dtp->u.p.current_unit == NULL)
2337 dtp->u.p.eof_jump = &eof_jump;
2338 if (setjmp (eof_jump))
2340 generate_error (&dtp->common, ERROR_END, NULL);
2344 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2346 finish_list_read (dtp);
2347 sfree (dtp->u.p.current_unit->s);
2351 if (is_stream_io (dtp))
2353 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2354 next_record (dtp, 1);
2355 flush (dtp->u.p.current_unit->s);
2356 sfree (dtp->u.p.current_unit->s);
2360 dtp->u.p.current_unit->current_record = 0;
2362 if (dtp->u.p.advance_status == ADVANCE_NO)
2365 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2367 dtp->u.p.seen_dollar = 0;
2368 sfree (dtp->u.p.current_unit->s);
2372 next_record (dtp, 1);
2373 sfree (dtp->u.p.current_unit->s);
2376 /* Transfer function for IOLENGTH. It doesn't actually do any
2377 data transfer, it just updates the length counter. */
2380 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2381 void *dest __attribute__ ((unused)),
2382 int kind __attribute__((unused)),
2383 size_t size, size_t nelems)
2385 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2386 *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2390 /* Initialize the IOLENGTH data transfer. This function is in essence
2391 a very much simplified version of data_transfer_init(), because it
2392 doesn't have to deal with units at all. */
2395 iolength_transfer_init (st_parameter_dt *dtp)
2397 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2400 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2402 /* Set up the subroutine that will handle the transfers. */
2404 dtp->u.p.transfer = iolength_transfer;
2408 /* Library entry point for the IOLENGTH form of the INQUIRE
2409 statement. The IOLENGTH form requires no I/O to be performed, but
2410 it must still be a runtime library call so that we can determine
2411 the iolength for dynamic arrays and such. */
2413 extern void st_iolength (st_parameter_dt *);
2414 export_proto(st_iolength);
2417 st_iolength (st_parameter_dt *dtp)
2419 library_start (&dtp->common);
2420 iolength_transfer_init (dtp);
2423 extern void st_iolength_done (st_parameter_dt *);
2424 export_proto(st_iolength_done);
2427 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2430 if (dtp->u.p.scratch != NULL)
2431 free_mem (dtp->u.p.scratch);
2436 /* The READ statement. */
2438 extern void st_read (st_parameter_dt *);
2439 export_proto(st_read);
2442 st_read (st_parameter_dt *dtp)
2444 library_start (&dtp->common);
2446 data_transfer_init (dtp, 1);
2448 /* Handle complications dealing with the endfile record. It is
2449 significant that this is the only place where ERROR_END is
2450 generated. Reading an end of file elsewhere is either end of
2451 record or an I/O error. */
2453 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2454 switch (dtp->u.p.current_unit->endfile)
2460 if (!is_internal_unit (dtp))
2462 generate_error (&dtp->common, ERROR_END, NULL);
2463 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2464 dtp->u.p.current_unit->current_record = 0;
2469 generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2470 dtp->u.p.current_unit->current_record = 0;
2475 extern void st_read_done (st_parameter_dt *);
2476 export_proto(st_read_done);
2479 st_read_done (st_parameter_dt *dtp)
2481 finalize_transfer (dtp);
2482 free_format_data (dtp);
2484 if (dtp->u.p.scratch != NULL)
2485 free_mem (dtp->u.p.scratch);
2486 if (dtp->u.p.current_unit != NULL)
2487 unlock_unit (dtp->u.p.current_unit);
2489 free_internal_unit (dtp);
2494 extern void st_write (st_parameter_dt *);
2495 export_proto(st_write);
2498 st_write (st_parameter_dt *dtp)
2500 library_start (&dtp->common);
2501 data_transfer_init (dtp, 0);
2504 extern void st_write_done (st_parameter_dt *);
2505 export_proto(st_write_done);
2508 st_write_done (st_parameter_dt *dtp)
2510 finalize_transfer (dtp);
2512 /* Deal with endfile conditions associated with sequential files. */
2514 if (dtp->u.p.current_unit != NULL
2515 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2516 switch (dtp->u.p.current_unit->endfile)
2518 case AT_ENDFILE: /* Remain at the endfile record. */
2522 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2526 /* Get rid of whatever is after this record. */
2527 if (!is_internal_unit (dtp))
2529 flush (dtp->u.p.current_unit->s);
2530 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2531 generate_error (&dtp->common, ERROR_OS, NULL);
2533 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2537 free_format_data (dtp);
2539 if (dtp->u.p.scratch != NULL)
2540 free_mem (dtp->u.p.scratch);
2541 if (dtp->u.p.current_unit != NULL)
2542 unlock_unit (dtp->u.p.current_unit);
2544 free_internal_unit (dtp);
2549 /* Receives the scalar information for namelist objects and stores it
2550 in a linked list of namelist_info types. */
2552 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2553 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2554 export_proto(st_set_nml_var);
2558 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2559 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2560 GFC_INTEGER_4 dtype)
2562 namelist_info *t1 = NULL;
2565 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2567 nml->mem_pos = var_addr;
2569 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2570 strcpy (nml->var_name, var_name);
2572 nml->len = (int) len;
2573 nml->string_length = (index_type) string_length;
2575 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2576 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2577 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2579 if (nml->var_rank > 0)
2581 nml->dim = (descriptor_dimension*)
2582 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2583 nml->ls = (array_loop_spec*)
2584 get_mem (nml->var_rank * sizeof (array_loop_spec));
2594 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2596 dtp->common.flags |= IOPARM_DT_IONML_SET;
2597 dtp->u.p.ionml = nml;
2601 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2606 /* Store the dimensional information for the namelist object. */
2607 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2608 GFC_INTEGER_4, GFC_INTEGER_4,
2610 export_proto(st_set_nml_var_dim);
2613 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2614 GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2615 GFC_INTEGER_4 ubound)
2617 namelist_info * nml;
2622 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2624 nml->dim[n].stride = (ssize_t)stride;
2625 nml->dim[n].lbound = (ssize_t)lbound;
2626 nml->dim[n].ubound = (ssize_t)ubound;
2629 /* Reverse memcpy - used for byte swapping. */
2631 void reverse_memcpy (void *dest, const void *src, size_t n)
2637 s = (char *) src + n - 1;
2639 /* Write with ascending order - this is likely faster
2640 on modern architectures because of write combining. */