1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran 95 runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 2, or (at your option)
14 In addition to the permissions in the GNU General Public License, the
15 Free Software Foundation gives you unlimited permission to link the
16 compiled version of this file into combinations with other programs,
17 and to distribute those combinations without any restriction coming
18 from the use of this file. (The General Public License restrictions
19 do apply in other respects; for example, they cover modification of
20 the file, and distribution when not linked into a combine
23 Libgfortran is distributed in the hope that it will be useful,
24 but WITHOUT ANY WARRANTY; without even the implied warranty of
25 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
26 GNU General Public License for more details.
28 You should have received a copy of the GNU General Public License
29 along with Libgfortran; see the file COPYING. If not, write to
30 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
31 Boston, MA 02110-1301, USA. */
34 /* transfer.c -- Top level handling of data transfer statements. */
42 /* Calling conventions: Data transfer statements are unlike other
43 library calls in that they extend over several calls.
45 The first call is always a call to st_read() or st_write(). These
46 subroutines return no status unless a namelist read or write is
47 being done, in which case there is the usual status. No further
48 calls are necessary in this case.
50 For other sorts of data transfer, there are zero or more data
51 transfer statement that depend on the format of the data transfer
57 transfer_character_wide
61 These subroutines do not return status.
63 The last call is a call to st_[read|write]_done(). While
64 something can easily go wrong with the initial st_read() or
65 st_write(), an error inhibits any data from actually being
68 extern void transfer_integer (st_parameter_dt *, void *, int);
69 export_proto(transfer_integer);
71 extern void transfer_real (st_parameter_dt *, void *, int);
72 export_proto(transfer_real);
74 extern void transfer_logical (st_parameter_dt *, void *, int);
75 export_proto(transfer_logical);
77 extern void transfer_character (st_parameter_dt *, void *, int);
78 export_proto(transfer_character);
80 extern void transfer_character_wide (st_parameter_dt *, void *, int, int);
81 export_proto(transfer_character_wide);
83 extern void transfer_complex (st_parameter_dt *, void *, int);
84 export_proto(transfer_complex);
86 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
88 export_proto(transfer_array);
90 static void us_read (st_parameter_dt *, int);
91 static void us_write (st_parameter_dt *, int);
92 static void next_record_r_unf (st_parameter_dt *, int);
93 static void next_record_w_unf (st_parameter_dt *, int);
95 static const st_option advance_opt[] = {
102 static const st_option decimal_opt[] = {
103 {"point", DECIMAL_POINT},
104 {"comma", DECIMAL_COMMA},
109 static const st_option sign_opt[] = {
111 {"suppress", SIGN_SS},
112 {"processor_defined", SIGN_S},
116 static const st_option blank_opt[] = {
117 {"null", BLANK_NULL},
118 {"zero", BLANK_ZERO},
122 static const st_option delim_opt[] = {
123 {"apostrophe", DELIM_APOSTROPHE},
124 {"quote", DELIM_QUOTE},
125 {"none", DELIM_NONE},
129 static const st_option pad_opt[] = {
136 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
137 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
143 current_mode (st_parameter_dt *dtp)
147 m = FORM_UNSPECIFIED;
149 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
151 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
152 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
154 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
156 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
157 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
159 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
161 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
162 FORMATTED_STREAM : UNFORMATTED_STREAM;
169 /* Mid level data transfer statements. These subroutines do reading
170 and writing in the style of salloc_r()/salloc_w() within the
173 /* When reading sequential formatted records we have a problem. We
174 don't know how long the line is until we read the trailing newline,
175 and we don't want to read too much. If we read too much, we might
176 have to do a physical seek backwards depending on how much data is
177 present, and devices like terminals aren't seekable and would cause
180 Given this, the solution is to read a byte at a time, stopping if
181 we hit the newline. For small allocations, we use a static buffer.
182 For larger allocations, we are forced to allocate memory on the
183 heap. Hopefully this won't happen very often. */
186 read_sf (st_parameter_dt *dtp, int *length, int no_error)
193 if (*length > SCRATCH_SIZE)
194 dtp->u.p.line_buffer = get_mem (*length);
195 p = base = dtp->u.p.line_buffer;
197 /* If we have seen an eor previously, return a length of 0. The
198 caller is responsible for correctly padding the input field. */
199 if (dtp->u.p.sf_seen_eor)
205 if (is_internal_unit (dtp))
208 if (sread (dtp->u.p.current_unit->s, p, &readlen) != 0 || readlen < (size_t) *length)
210 generate_error (&dtp->common, LIBERROR_END, NULL);
222 if (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0)
224 generate_error (&dtp->common, LIBERROR_END, NULL);
228 /* If we have a line without a terminating \n, drop through to
230 if (readlen < 1 && n == 0)
234 generate_error (&dtp->common, LIBERROR_END, NULL);
238 if (readlen < 1 || q == '\n' || q == '\r')
240 /* Unexpected end of line. */
242 /* If we see an EOR during non-advancing I/O, we need to skip
243 the rest of the I/O statement. Set the corresponding flag. */
244 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
245 dtp->u.p.eor_condition = 1;
248 /* If we encounter a CR, it might be a CRLF. */
249 if (q == '\r') /* Probably a CRLF */
252 pos = stream_offset (dtp->u.p.current_unit->s);
253 if (sread (dtp->u.p.current_unit->s, &q, &readlen) != 0)
255 generate_error (&dtp->common, LIBERROR_END, NULL);
258 if (q != '\n' && readlen == 1) /* Not a CRLF after all. */
259 sseek (dtp->u.p.current_unit->s, pos);
264 /* Without padding, terminate the I/O statement without assigning
265 the value. With padding, the value still needs to be assigned,
266 so we can just continue with a short read. */
267 if (dtp->u.p.current_unit->pad_status == PAD_NO)
271 generate_error (&dtp->common, LIBERROR_EOR, NULL);
276 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
279 /* Short circuit the read if a comma is found during numeric input.
280 The flag is set to zero during character reads so that commas in
281 strings are not ignored */
283 if (dtp->u.p.sf_read_comma == 1)
285 notify_std (&dtp->common, GFC_STD_GNU,
286 "Comma in formatted numeric read.");
293 dtp->u.p.sf_seen_eor = 0;
298 dtp->u.p.current_unit->bytes_left -= *length;
300 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
301 dtp->u.p.size_used += (gfc_offset) *length;
307 /* Function for reading the next couple of bytes from the current
308 file, advancing the current position. We return FAILURE on end of record or
309 end of file. This function is only for formatted I/O, unformatted uses
312 If the read is short, then it is because the current record does not
313 have enough data to satisfy the read request and the file was
314 opened with PAD=YES. The caller must assume tailing spaces for
318 read_block_form (st_parameter_dt *dtp, void *buf, size_t *nbytes)
324 if (!is_stream_io (dtp))
326 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
328 /* For preconnected units with default record length, set bytes left
329 to unit record length and proceed, otherwise error. */
330 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
331 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
332 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
335 if (dtp->u.p.current_unit->pad_status == PAD_NO)
337 /* Not enough data left. */
338 generate_error (&dtp->common, LIBERROR_EOR, NULL);
343 if (dtp->u.p.current_unit->bytes_left == 0)
345 dtp->u.p.current_unit->endfile = AT_ENDFILE;
346 generate_error (&dtp->common, LIBERROR_END, NULL);
350 *nbytes = dtp->u.p.current_unit->bytes_left;
354 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
355 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
356 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
359 source = read_sf (dtp, &nb, 0);
361 dtp->u.p.current_unit->strm_pos +=
362 (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
365 memcpy (buf, source, *nbytes);
368 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
371 if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
373 generate_error (&dtp->common, LIBERROR_OS, NULL);
377 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
378 dtp->u.p.size_used += (gfc_offset) nread;
380 if (nread != *nbytes)
381 { /* Short read, this shouldn't happen. */
382 if (dtp->u.p.current_unit->pad_status == PAD_YES)
386 generate_error (&dtp->common, LIBERROR_EOR, NULL);
391 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
397 /* Reads a block directly into application data space. This is for
398 unformatted files. */
401 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
403 size_t to_read_record;
404 size_t have_read_record;
405 size_t to_read_subrecord;
406 size_t have_read_subrecord;
409 if (is_stream_io (dtp))
411 to_read_record = *nbytes;
412 have_read_record = to_read_record;
413 if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
415 generate_error (&dtp->common, LIBERROR_OS, NULL);
419 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
421 if (to_read_record != have_read_record)
423 /* Short read, e.g. if we hit EOF. For stream files,
424 we have to set the end-of-file condition. */
425 generate_error (&dtp->common, LIBERROR_END, NULL);
431 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
433 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
436 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
437 *nbytes = to_read_record;
443 to_read_record = *nbytes;
446 dtp->u.p.current_unit->bytes_left -= to_read_record;
448 if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
450 generate_error (&dtp->common, LIBERROR_OS, NULL);
454 if (to_read_record != *nbytes)
456 /* Short read, e.g. if we hit EOF. Apparently, we read
457 more than was written to the last record. */
458 *nbytes = to_read_record;
464 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
470 /* Unformatted sequential. We loop over the subrecords, reading
471 until the request has been fulfilled or the record has run out
472 of continuation subrecords. */
474 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
476 generate_error (&dtp->common, LIBERROR_END, NULL);
480 /* Check whether we exceed the total record length. */
482 if (dtp->u.p.current_unit->flags.has_recl
483 && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
485 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
490 to_read_record = *nbytes;
493 have_read_record = 0;
497 if (dtp->u.p.current_unit->bytes_left_subrecord
498 < (gfc_offset) to_read_record)
500 to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
501 to_read_record -= to_read_subrecord;
505 to_read_subrecord = to_read_record;
509 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
511 have_read_subrecord = to_read_subrecord;
512 if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
513 &have_read_subrecord) != 0)
515 generate_error (&dtp->common, LIBERROR_OS, NULL);
519 have_read_record += have_read_subrecord;
521 if (to_read_subrecord != have_read_subrecord)
524 /* Short read, e.g. if we hit EOF. This means the record
525 structure has been corrupted, or the trailing record
526 marker would still be present. */
528 *nbytes = have_read_record;
529 generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
533 if (to_read_record > 0)
535 if (dtp->u.p.current_unit->continued)
537 next_record_r_unf (dtp, 0);
542 /* Let's make sure the file position is correctly pre-positioned
543 for the next read statement. */
545 dtp->u.p.current_unit->current_record = 0;
546 next_record_r_unf (dtp, 0);
547 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
553 /* Normal exit, the read request has been fulfilled. */
558 dtp->u.p.current_unit->bytes_left -= have_read_record;
561 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
568 /* Function for writing a block of bytes to the current file at the
569 current position, advancing the file pointer. We are given a length
570 and return a pointer to a buffer that the caller must (completely)
571 fill in. Returns NULL on error. */
574 write_block (st_parameter_dt *dtp, int length)
578 if (!is_stream_io (dtp))
580 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
582 /* For preconnected units with default record length, set bytes left
583 to unit record length and proceed, otherwise error. */
584 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
585 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
586 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
587 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
590 generate_error (&dtp->common, LIBERROR_EOR, NULL);
595 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
598 if (is_internal_unit (dtp))
600 dest = salloc_w (dtp->u.p.current_unit->s, &length);
604 generate_error (&dtp->common, LIBERROR_END, NULL);
608 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
609 generate_error (&dtp->common, LIBERROR_END, NULL);
613 dest = fbuf_alloc (dtp->u.p.current_unit, length);
616 generate_error (&dtp->common, LIBERROR_OS, NULL);
621 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
622 dtp->u.p.size_used += (gfc_offset) length;
624 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
630 /* High level interface to swrite(), taking care of errors. This is only
631 called for unformatted files. There are three cases to consider:
632 Stream I/O, unformatted direct, unformatted sequential. */
635 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
638 size_t have_written, to_write_subrecord;
643 if (is_stream_io (dtp))
645 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
647 generate_error (&dtp->common, LIBERROR_OS, NULL);
651 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
656 /* Unformatted direct access. */
658 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
660 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
662 generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
666 if (buf == NULL && nbytes == 0)
669 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
671 generate_error (&dtp->common, LIBERROR_OS, NULL);
675 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
676 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
681 /* Unformatted sequential. */
685 if (dtp->u.p.current_unit->flags.has_recl
686 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
688 nbytes = dtp->u.p.current_unit->bytes_left;
700 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
701 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
703 dtp->u.p.current_unit->bytes_left_subrecord -=
704 (gfc_offset) to_write_subrecord;
706 if (swrite (dtp->u.p.current_unit->s, buf + have_written,
707 &to_write_subrecord) != 0)
709 generate_error (&dtp->common, LIBERROR_OS, NULL);
713 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
714 nbytes -= to_write_subrecord;
715 have_written += to_write_subrecord;
720 next_record_w_unf (dtp, 1);
723 dtp->u.p.current_unit->bytes_left -= have_written;
726 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
733 /* Master function for unformatted reads. */
736 unformatted_read (st_parameter_dt *dtp, bt type,
737 void *dest, int kind, size_t size, size_t nelems)
741 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
745 if (type == BT_CHARACTER)
746 sz *= GFC_SIZE_OF_CHAR_KIND(kind);
747 read_block_direct (dtp, dest, &sz);
756 /* Handle wide chracters. */
757 if (type == BT_CHARACTER && kind != 1)
763 /* Break up complex into its constituent reals. */
764 if (type == BT_COMPLEX)
770 /* By now, all complex variables have been split into their
771 constituent reals. */
773 for (i = 0; i < nelems; i++)
775 read_block_direct (dtp, buffer, &size);
776 reverse_memcpy (p, buffer, size);
783 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
784 bytes on 64 bit machines. The unused bytes are not initialized and never
785 used, which can show an error with memory checking analyzers like
789 unformatted_write (st_parameter_dt *dtp, bt type,
790 void *source, int kind, size_t size, size_t nelems)
792 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
795 size_t stride = type == BT_CHARACTER ?
796 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
798 write_buf (dtp, source, stride * nelems);
808 /* Handle wide chracters. */
809 if (type == BT_CHARACTER && kind != 1)
815 /* Break up complex into its constituent reals. */
816 if (type == BT_COMPLEX)
822 /* By now, all complex variables have been split into their
823 constituent reals. */
825 for (i = 0; i < nelems; i++)
827 reverse_memcpy(buffer, p, size);
829 write_buf (dtp, buffer, size);
835 /* Return a pointer to the name of a type. */
860 internal_error (NULL, "type_name(): Bad type");
867 /* Write a constant string to the output.
868 This is complicated because the string can have doubled delimiters
869 in it. The length in the format node is the true length. */
872 write_constant_string (st_parameter_dt *dtp, const fnode *f)
874 char c, delimiter, *p, *q;
877 length = f->u.string.length;
881 p = write_block (dtp, length);
888 for (; length > 0; length--)
891 if (c == delimiter && c != 'H' && c != 'h')
892 q++; /* Skip the doubled delimiter. */
897 /* Given actual and expected types in a formatted data transfer, make
898 sure they agree. If not, an error message is generated. Returns
899 nonzero if something went wrong. */
902 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
906 if (actual == expected)
909 sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
910 type_name (expected), dtp->u.p.item_count, type_name (actual));
912 format_error (dtp, f, buffer);
917 /* This subroutine is the main loop for a formatted data transfer
918 statement. It would be natural to implement this as a coroutine
919 with the user program, but C makes that awkward. We loop,
920 processing format elements. When we actually have to transfer
921 data instead of just setting flags, we return control to the user
922 program which calls a subroutine that supplies the address and type
923 of the next element, then comes back here to process it. */
926 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int kind,
929 char scratch[SCRATCH_SIZE];
934 int consume_data_flag;
936 /* Change a complex data item into a pair of reals. */
938 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
939 if (type == BT_COMPLEX)
945 /* If there's an EOR condition, we simulate finalizing the transfer
947 if (dtp->u.p.eor_condition)
950 /* Set this flag so that commas in reads cause the read to complete before
951 the entire field has been read. The next read field will start right after
952 the comma in the stream. (Set to 0 for character reads). */
953 dtp->u.p.sf_read_comma =
954 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
956 dtp->u.p.line_buffer = scratch;
960 /* If reversion has occurred and there is another real data item,
961 then we have to move to the next record. */
962 if (dtp->u.p.reversion_flag && n > 0)
964 dtp->u.p.reversion_flag = 0;
965 next_record (dtp, 0);
968 consume_data_flag = 1;
969 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
972 f = next_format (dtp);
975 /* No data descriptors left. */
977 generate_error (&dtp->common, LIBERROR_FORMAT,
978 "Insufficient data descriptors in format after reversion");
982 /* Now discharge T, TR and X movements to the right. This is delayed
983 until a data producing format to suppress trailing spaces. */
986 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
987 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
988 || t == FMT_Z || t == FMT_F || t == FMT_E
989 || t == FMT_EN || t == FMT_ES || t == FMT_G
990 || t == FMT_L || t == FMT_A || t == FMT_D))
993 if (dtp->u.p.skips > 0)
996 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
997 tmp = (int)(dtp->u.p.current_unit->recl
998 - dtp->u.p.current_unit->bytes_left);
1000 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
1002 if (dtp->u.p.skips < 0)
1004 if (is_internal_unit (dtp))
1005 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1007 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips);
1008 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1010 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1013 bytes_used = (int)(dtp->u.p.current_unit->recl
1014 - dtp->u.p.current_unit->bytes_left);
1016 if (is_stream_io(dtp))
1024 if (require_type (dtp, BT_INTEGER, type, f))
1027 if (dtp->u.p.mode == READING)
1028 read_decimal (dtp, f, p, kind);
1030 write_i (dtp, f, p, kind);
1038 if (compile_options.allow_std < GFC_STD_GNU
1039 && require_type (dtp, BT_INTEGER, type, f))
1042 if (dtp->u.p.mode == READING)
1043 read_radix (dtp, f, p, kind, 2);
1045 write_b (dtp, f, p, kind);
1053 if (compile_options.allow_std < GFC_STD_GNU
1054 && require_type (dtp, BT_INTEGER, type, f))
1057 if (dtp->u.p.mode == READING)
1058 read_radix (dtp, f, p, kind, 8);
1060 write_o (dtp, f, p, kind);
1068 if (compile_options.allow_std < GFC_STD_GNU
1069 && require_type (dtp, BT_INTEGER, type, f))
1072 if (dtp->u.p.mode == READING)
1073 read_radix (dtp, f, p, kind, 16);
1075 write_z (dtp, f, p, kind);
1083 /* It is possible to have FMT_A with something not BT_CHARACTER such
1084 as when writing out hollerith strings, so check both type
1085 and kind before calling wide character routines. */
1086 if (dtp->u.p.mode == READING)
1088 if (type == BT_CHARACTER && kind == 4)
1089 read_a_char4 (dtp, f, p, size);
1091 read_a (dtp, f, p, size);
1095 if (type == BT_CHARACTER && kind == 4)
1096 write_a_char4 (dtp, f, p, size);
1098 write_a (dtp, f, p, size);
1106 if (dtp->u.p.mode == READING)
1107 read_l (dtp, f, p, kind);
1109 write_l (dtp, f, p, kind);
1116 if (require_type (dtp, BT_REAL, type, f))
1119 if (dtp->u.p.mode == READING)
1120 read_f (dtp, f, p, kind);
1122 write_d (dtp, f, p, kind);
1129 if (require_type (dtp, BT_REAL, type, f))
1132 if (dtp->u.p.mode == READING)
1133 read_f (dtp, f, p, kind);
1135 write_e (dtp, f, p, kind);
1141 if (require_type (dtp, BT_REAL, type, f))
1144 if (dtp->u.p.mode == READING)
1145 read_f (dtp, f, p, kind);
1147 write_en (dtp, f, p, kind);
1154 if (require_type (dtp, BT_REAL, type, f))
1157 if (dtp->u.p.mode == READING)
1158 read_f (dtp, f, p, kind);
1160 write_es (dtp, f, p, kind);
1167 if (require_type (dtp, BT_REAL, type, f))
1170 if (dtp->u.p.mode == READING)
1171 read_f (dtp, f, p, kind);
1173 write_f (dtp, f, p, kind);
1180 if (dtp->u.p.mode == READING)
1184 read_decimal (dtp, f, p, kind);
1187 read_l (dtp, f, p, kind);
1191 read_a_char4 (dtp, f, p, size);
1193 read_a (dtp, f, p, size);
1196 read_f (dtp, f, p, kind);
1205 write_i (dtp, f, p, kind);
1208 write_l (dtp, f, p, kind);
1212 write_a_char4 (dtp, f, p, size);
1214 write_a (dtp, f, p, size);
1217 if (f->u.real.w == 0)
1219 if (f->u.real.d == 0)
1220 write_real (dtp, p, kind);
1222 write_real_g0 (dtp, p, kind, f->u.real.d);
1225 write_d (dtp, f, p, kind);
1229 internal_error (&dtp->common,
1230 "formatted_transfer(): Bad type");
1236 consume_data_flag = 0;
1237 if (dtp->u.p.mode == READING)
1239 format_error (dtp, f, "Constant string in input format");
1242 write_constant_string (dtp, f);
1245 /* Format codes that don't transfer data. */
1248 consume_data_flag = 0;
1250 dtp->u.p.skips += f->u.n;
1251 pos = bytes_used + dtp->u.p.skips - 1;
1252 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1254 /* Writes occur just before the switch on f->format, above, so
1255 that trailing blanks are suppressed, unless we are doing a
1256 non-advancing write in which case we want to output the blanks
1258 if (dtp->u.p.mode == WRITING
1259 && dtp->u.p.advance_status == ADVANCE_NO)
1261 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1262 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1265 if (dtp->u.p.mode == READING)
1266 read_x (dtp, f->u.n);
1272 consume_data_flag = 0;
1274 if (f->format == FMT_TL)
1277 /* Handle the special case when no bytes have been used yet.
1278 Cannot go below zero. */
1279 if (bytes_used == 0)
1281 dtp->u.p.pending_spaces -= f->u.n;
1282 dtp->u.p.skips -= f->u.n;
1283 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1286 pos = bytes_used - f->u.n;
1290 if (dtp->u.p.mode == READING)
1293 pos = f->u.n - dtp->u.p.pending_spaces - 1;
1296 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1297 left tab limit. We do not check if the position has gone
1298 beyond the end of record because a subsequent tab could
1299 bring us back again. */
1300 pos = pos < 0 ? 0 : pos;
1302 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1303 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1304 + pos - dtp->u.p.max_pos;
1305 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1306 ? 0 : dtp->u.p.pending_spaces;
1308 if (dtp->u.p.skips == 0)
1311 /* Writes occur just before the switch on f->format, above, so that
1312 trailing blanks are suppressed. */
1313 if (dtp->u.p.mode == READING)
1315 /* Adjust everything for end-of-record condition */
1316 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1318 if (dtp->u.p.sf_seen_eor == 2)
1320 /* The EOR was a CRLF (two bytes wide). */
1321 dtp->u.p.current_unit->bytes_left -= 2;
1322 dtp->u.p.skips -= 2;
1326 /* The EOR marker was only one byte wide. */
1327 dtp->u.p.current_unit->bytes_left--;
1331 dtp->u.p.sf_seen_eor = 0;
1333 if (dtp->u.p.skips < 0)
1335 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1336 dtp->u.p.current_unit->bytes_left
1337 -= (gfc_offset) dtp->u.p.skips;
1338 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1341 read_x (dtp, dtp->u.p.skips);
1347 consume_data_flag = 0;
1348 dtp->u.p.sign_status = SIGN_S;
1352 consume_data_flag = 0;
1353 dtp->u.p.sign_status = SIGN_SS;
1357 consume_data_flag = 0;
1358 dtp->u.p.sign_status = SIGN_SP;
1362 consume_data_flag = 0 ;
1363 dtp->u.p.blank_status = BLANK_NULL;
1367 consume_data_flag = 0;
1368 dtp->u.p.blank_status = BLANK_ZERO;
1372 consume_data_flag = 0;
1373 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1377 consume_data_flag = 0;
1378 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1382 consume_data_flag = 0;
1383 dtp->u.p.scale_factor = f->u.k;
1387 consume_data_flag = 0;
1388 dtp->u.p.seen_dollar = 1;
1392 consume_data_flag = 0;
1393 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1394 next_record (dtp, 0);
1398 /* A colon descriptor causes us to exit this loop (in
1399 particular preventing another / descriptor from being
1400 processed) unless there is another data item to be
1402 consume_data_flag = 0;
1408 internal_error (&dtp->common, "Bad format node");
1411 /* Free a buffer that we had to allocate during a sequential
1412 formatted read of a block that was larger than the static
1415 if (dtp->u.p.line_buffer != scratch)
1417 free_mem (dtp->u.p.line_buffer);
1418 dtp->u.p.line_buffer = scratch;
1421 /* Adjust the item count and data pointer. */
1423 if ((consume_data_flag > 0) && (n > 0))
1426 p = ((char *) p) + size;
1429 if (dtp->u.p.mode == READING)
1432 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1433 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1439 /* Come here when we need a data descriptor but don't have one. We
1440 push the current format node back onto the input, then return and
1441 let the user program call us back with the data. */
1443 unget_format (dtp, f);
1447 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1448 size_t size, size_t nelems)
1454 size_t stride = type == BT_CHARACTER ?
1455 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1456 /* Big loop over all the elements. */
1457 for (elem = 0; elem < nelems; elem++)
1459 dtp->u.p.item_count++;
1460 formatted_transfer_scalar (dtp, type, tmp + stride*elem, kind, size);
1466 /* Data transfer entry points. The type of the data entity is
1467 implicit in the subroutine call. This prevents us from having to
1468 share a common enum with the compiler. */
1471 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1473 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1475 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1480 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1483 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1485 size = size_from_real_kind (kind);
1486 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1491 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1493 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1495 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1500 transfer_character (st_parameter_dt *dtp, void *p, int len)
1502 static char *empty_string[0];
1504 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1507 /* Strings of zero length can have p == NULL, which confuses the
1508 transfer routines into thinking we need more data elements. To avoid
1509 this, we give them a nice pointer. */
1510 if (len == 0 && p == NULL)
1513 /* Set kind here to 1. */
1514 dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
1518 transfer_character_wide (st_parameter_dt *dtp, void *p, int len, int kind)
1520 static char *empty_string[0];
1522 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1525 /* Strings of zero length can have p == NULL, which confuses the
1526 transfer routines into thinking we need more data elements. To avoid
1527 this, we give them a nice pointer. */
1528 if (len == 0 && p == NULL)
1531 /* Here we pass the actual kind value. */
1532 dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
1537 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1540 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1542 size = size_from_complex_kind (kind);
1543 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1548 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1549 gfc_charlen_type charlen)
1551 index_type count[GFC_MAX_DIMENSIONS];
1552 index_type extent[GFC_MAX_DIMENSIONS];
1553 index_type stride[GFC_MAX_DIMENSIONS];
1554 index_type stride0, rank, size, type, n;
1559 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1562 type = GFC_DESCRIPTOR_TYPE (desc);
1563 size = GFC_DESCRIPTOR_SIZE (desc);
1565 /* FIXME: What a kludge: Array descriptors and the IO library use
1566 different enums for types. */
1569 case GFC_DTYPE_UNKNOWN:
1570 iotype = BT_NULL; /* Is this correct? */
1572 case GFC_DTYPE_INTEGER:
1573 iotype = BT_INTEGER;
1575 case GFC_DTYPE_LOGICAL:
1576 iotype = BT_LOGICAL;
1578 case GFC_DTYPE_REAL:
1581 case GFC_DTYPE_COMPLEX:
1582 iotype = BT_COMPLEX;
1584 case GFC_DTYPE_CHARACTER:
1585 iotype = BT_CHARACTER;
1588 case GFC_DTYPE_DERIVED:
1589 internal_error (&dtp->common,
1590 "Derived type I/O should have been handled via the frontend.");
1593 internal_error (&dtp->common, "transfer_array(): Bad type");
1596 rank = GFC_DESCRIPTOR_RANK (desc);
1597 for (n = 0; n < rank; n++)
1600 stride[n] = iotype == BT_CHARACTER ?
1601 desc->dim[n].stride * GFC_SIZE_OF_CHAR_KIND(kind) :
1602 desc->dim[n].stride;
1603 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1605 /* If the extent of even one dimension is zero, then the entire
1606 array section contains zero elements, so we return after writing
1607 a zero array record. */
1612 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1617 stride0 = stride[0];
1619 /* If the innermost dimension has stride 1, we can do the transfer
1620 in contiguous chunks. */
1626 data = GFC_DESCRIPTOR_DATA (desc);
1630 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1631 data += stride0 * size * tsize;
1634 while (count[n] == extent[n])
1637 data -= stride[n] * extent[n] * size;
1647 data += stride[n] * size;
1654 /* Preposition a sequential unformatted file while reading. */
1657 us_read (st_parameter_dt *dtp, int continued)
1664 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1667 if (compile_options.record_marker == 0)
1668 n = sizeof (GFC_INTEGER_4);
1670 n = compile_options.record_marker;
1674 if (sread (dtp->u.p.current_unit->s, &i, &n) != 0)
1676 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
1682 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1683 return; /* end of file */
1688 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
1692 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1693 if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
1697 case sizeof(GFC_INTEGER_4):
1698 memcpy (&i4, &i, sizeof (i4));
1702 case sizeof(GFC_INTEGER_8):
1703 memcpy (&i8, &i, sizeof (i8));
1708 runtime_error ("Illegal value for record marker");
1715 case sizeof(GFC_INTEGER_4):
1716 reverse_memcpy (&i4, &i, sizeof (i4));
1720 case sizeof(GFC_INTEGER_8):
1721 reverse_memcpy (&i8, &i, sizeof (i8));
1726 runtime_error ("Illegal value for record marker");
1732 dtp->u.p.current_unit->bytes_left_subrecord = i;
1733 dtp->u.p.current_unit->continued = 0;
1737 dtp->u.p.current_unit->bytes_left_subrecord = -i;
1738 dtp->u.p.current_unit->continued = 1;
1742 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1746 /* Preposition a sequential unformatted file while writing. This
1747 amount to writing a bogus length that will be filled in later. */
1750 us_write (st_parameter_dt *dtp, int continued)
1757 if (compile_options.record_marker == 0)
1758 nbytes = sizeof (GFC_INTEGER_4);
1760 nbytes = compile_options.record_marker ;
1762 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1763 generate_error (&dtp->common, LIBERROR_OS, NULL);
1765 /* For sequential unformatted, if RECL= was not specified in the OPEN
1766 we write until we have more bytes than can fit in the subrecord
1767 markers, then we write a new subrecord. */
1769 dtp->u.p.current_unit->bytes_left_subrecord =
1770 dtp->u.p.current_unit->recl_subrecord;
1771 dtp->u.p.current_unit->continued = continued;
1775 /* Position to the next record prior to transfer. We are assumed to
1776 be before the next record. We also calculate the bytes in the next
1780 pre_position (st_parameter_dt *dtp)
1782 if (dtp->u.p.current_unit->current_record)
1783 return; /* Already positioned. */
1785 switch (current_mode (dtp))
1787 case FORMATTED_STREAM:
1788 case UNFORMATTED_STREAM:
1789 /* There are no records with stream I/O. If the position was specified
1790 data_transfer_init has already positioned the file. If no position
1791 was specified, we continue from where we last left off. I.e.
1792 there is nothing to do here. */
1795 case UNFORMATTED_SEQUENTIAL:
1796 if (dtp->u.p.mode == READING)
1803 case FORMATTED_SEQUENTIAL:
1804 case FORMATTED_DIRECT:
1805 case UNFORMATTED_DIRECT:
1806 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1810 dtp->u.p.current_unit->current_record = 1;
1814 /* Initialize things for a data transfer. This code is common for
1815 both reading and writing. */
1818 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1820 unit_flags u_flags; /* Used for creating a unit if needed. */
1821 GFC_INTEGER_4 cf = dtp->common.flags;
1822 namelist_info *ionml;
1824 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1826 /* To maintain ABI, &transfer is the start of the private memory area in
1827 in st_parameter_dt. Memory from the beginning of the structure to this
1828 point is set by the front end and must not be touched. The number of
1829 bytes to clear must stay within the sizeof q to avoid over-writing. */
1830 memset (&dtp->u.p.transfer, 0, sizeof (dtp->u.q));
1832 dtp->u.p.ionml = ionml;
1833 dtp->u.p.mode = read_flag ? READING : WRITING;
1835 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1838 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1839 dtp->u.p.size_used = 0; /* Initialize the count. */
1841 dtp->u.p.current_unit = get_unit (dtp, 1);
1842 if (dtp->u.p.current_unit->s == NULL)
1843 { /* Open the unit with some default flags. */
1844 st_parameter_open opp;
1847 if (dtp->common.unit < 0)
1849 close_unit (dtp->u.p.current_unit);
1850 dtp->u.p.current_unit = NULL;
1851 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1852 "Bad unit number in OPEN statement");
1855 memset (&u_flags, '\0', sizeof (u_flags));
1856 u_flags.access = ACCESS_SEQUENTIAL;
1857 u_flags.action = ACTION_READWRITE;
1859 /* Is it unformatted? */
1860 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1861 | IOPARM_DT_IONML_SET)))
1862 u_flags.form = FORM_UNFORMATTED;
1864 u_flags.form = FORM_UNSPECIFIED;
1866 u_flags.delim = DELIM_UNSPECIFIED;
1867 u_flags.blank = BLANK_UNSPECIFIED;
1868 u_flags.pad = PAD_UNSPECIFIED;
1869 u_flags.decimal = DECIMAL_UNSPECIFIED;
1870 u_flags.encoding = ENCODING_UNSPECIFIED;
1871 u_flags.async = ASYNC_UNSPECIFIED;
1872 u_flags.round = ROUND_UNSPECIFIED;
1873 u_flags.sign = SIGN_UNSPECIFIED;
1875 u_flags.status = STATUS_UNKNOWN;
1877 conv = get_unformatted_convert (dtp->common.unit);
1879 if (conv == GFC_CONVERT_NONE)
1880 conv = compile_options.convert;
1882 /* We use big_endian, which is 0 on little-endian machines
1883 and 1 on big-endian machines. */
1886 case GFC_CONVERT_NATIVE:
1887 case GFC_CONVERT_SWAP:
1890 case GFC_CONVERT_BIG:
1891 conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
1894 case GFC_CONVERT_LITTLE:
1895 conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
1899 internal_error (&opp.common, "Illegal value for CONVERT");
1903 u_flags.convert = conv;
1905 opp.common = dtp->common;
1906 opp.common.flags &= IOPARM_COMMON_MASK;
1907 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1908 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1909 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1910 if (dtp->u.p.current_unit == NULL)
1914 /* Check the action. */
1916 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1918 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
1919 "Cannot read from file opened for WRITE");
1923 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1925 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
1926 "Cannot write to file opened for READ");
1930 dtp->u.p.first_item = 1;
1932 /* Check the format. */
1934 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1937 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1938 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1941 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1942 "Format present for UNFORMATTED data transfer");
1946 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1948 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1949 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1950 "A format cannot be specified with a namelist");
1952 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1953 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1955 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1956 "Missing format for FORMATTED data transfer");
1959 if (is_internal_unit (dtp)
1960 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1962 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1963 "Internal file cannot be accessed by UNFORMATTED "
1968 /* Check the record or position number. */
1970 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1971 && (cf & IOPARM_DT_HAS_REC) == 0)
1973 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
1974 "Direct access data transfer requires record number");
1978 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1979 && (cf & IOPARM_DT_HAS_REC) != 0)
1981 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1982 "Record number not allowed for sequential access "
1987 /* Process the ADVANCE option. */
1989 dtp->u.p.advance_status
1990 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1991 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1992 "Bad ADVANCE parameter in data transfer statement");
1994 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1996 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1998 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1999 "ADVANCE specification conflicts with sequential "
2004 if (is_internal_unit (dtp))
2006 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2007 "ADVANCE specification conflicts with internal file");
2011 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
2012 != IOPARM_DT_HAS_FORMAT)
2014 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2015 "ADVANCE specification requires an explicit format");
2022 dtp->u.p.current_unit->previous_nonadvancing_write = 0;
2024 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
2026 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2027 "EOR specification requires an ADVANCE specification "
2032 if ((cf & IOPARM_DT_HAS_SIZE) != 0
2033 && dtp->u.p.advance_status != ADVANCE_NO)
2035 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
2036 "SIZE specification requires an ADVANCE "
2037 "specification of NO");
2042 { /* Write constraints. */
2043 if ((cf & IOPARM_END) != 0)
2045 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2046 "END specification cannot appear in a write "
2051 if ((cf & IOPARM_EOR) != 0)
2053 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2054 "EOR specification cannot appear in a write "
2059 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2061 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2062 "SIZE specification cannot appear in a write "
2068 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
2069 dtp->u.p.advance_status = ADVANCE_YES;
2071 /* Check the decimal mode. */
2072 dtp->u.p.current_unit->decimal_status
2073 = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
2074 find_option (&dtp->common, dtp->u.p.decimal, dtp->u.p.decimal_len,
2075 decimal_opt, "Bad DECIMAL parameter in data transfer "
2078 if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
2079 dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
2081 /* Check the sign mode. */
2082 dtp->u.p.sign_status
2083 = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
2084 find_option (&dtp->common, dtp->u.p.sign, dtp->u.p.sign_len, sign_opt,
2085 "Bad SIGN parameter in data transfer statement");
2087 if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
2088 dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
2090 /* Check the blank mode. */
2091 dtp->u.p.blank_status
2092 = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
2093 find_option (&dtp->common, dtp->u.p.blank, dtp->u.p.blank_len,
2095 "Bad BLANK parameter in data transfer statement");
2097 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
2098 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2100 /* Check the delim mode. */
2101 dtp->u.p.current_unit->delim_status
2102 = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
2103 find_option (&dtp->common, dtp->u.p.delim, dtp->u.p.delim_len,
2104 delim_opt, "Bad DELIM parameter in data transfer statement");
2106 if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
2107 dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
2109 /* Check the pad mode. */
2110 dtp->u.p.current_unit->pad_status
2111 = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
2112 find_option (&dtp->common, dtp->u.p.pad, dtp->u.p.pad_len, pad_opt,
2113 "Bad PAD parameter in data transfer statement");
2115 if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
2116 dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
2118 /* Sanity checks on the record number. */
2119 if ((cf & IOPARM_DT_HAS_REC) != 0)
2123 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2124 "Record number must be positive");
2128 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
2130 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2131 "Record number too large");
2135 /* Check to see if we might be reading what we wrote before */
2137 if (dtp->u.p.mode == READING
2138 && dtp->u.p.current_unit->mode == WRITING
2139 && !is_internal_unit (dtp))
2141 fbuf_flush (dtp->u.p.current_unit, 1);
2142 flush(dtp->u.p.current_unit->s);
2145 /* Check whether the record exists to be read. Only
2146 a partial record needs to exist. */
2148 if (dtp->u.p.mode == READING && (dtp->rec - 1)
2149 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
2151 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2152 "Non-existing record number");
2156 /* Position the file. */
2157 if (!is_stream_io (dtp))
2159 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
2160 * dtp->u.p.current_unit->recl) == FAILURE)
2162 generate_error (&dtp->common, LIBERROR_OS, NULL);
2168 if (dtp->u.p.current_unit->strm_pos != dtp->rec)
2170 fbuf_flush (dtp->u.p.current_unit, 1);
2171 flush (dtp->u.p.current_unit->s);
2172 if (sseek (dtp->u.p.current_unit->s, dtp->rec - 1) == FAILURE)
2174 generate_error (&dtp->common, LIBERROR_OS, NULL);
2177 dtp->u.p.current_unit->strm_pos = dtp->rec;
2183 /* Overwriting an existing sequential file ?
2184 it is always safe to truncate the file on the first write */
2185 if (dtp->u.p.mode == WRITING
2186 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
2187 && dtp->u.p.current_unit->last_record == 0
2188 && !is_preconnected(dtp->u.p.current_unit->s))
2189 struncate(dtp->u.p.current_unit->s);
2191 /* Bugware for badly written mixed C-Fortran I/O. */
2192 flush_if_preconnected(dtp->u.p.current_unit->s);
2194 dtp->u.p.current_unit->mode = dtp->u.p.mode;
2196 /* Set the maximum position reached from the previous I/O operation. This
2197 could be greater than zero from a previous non-advancing write. */
2198 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2203 /* Set up the subroutine that will handle the transfers. */
2207 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2208 dtp->u.p.transfer = unformatted_read;
2211 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2212 dtp->u.p.transfer = list_formatted_read;
2214 dtp->u.p.transfer = formatted_transfer;
2219 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2220 dtp->u.p.transfer = unformatted_write;
2223 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2224 dtp->u.p.transfer = list_formatted_write;
2226 dtp->u.p.transfer = formatted_transfer;
2230 /* Make sure that we don't do a read after a nonadvancing write. */
2234 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2236 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2237 "Cannot READ after a nonadvancing WRITE");
2243 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2244 dtp->u.p.current_unit->read_bad = 1;
2247 /* Start the data transfer if we are doing a formatted transfer. */
2248 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2249 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
2250 && dtp->u.p.ionml == NULL)
2251 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2254 /* Initialize an array_loop_spec given the array descriptor. The function
2255 returns the index of the last element of the array, and also returns
2256 starting record, where the first I/O goes to (necessary in case of
2257 negative strides). */
2260 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
2261 gfc_offset *start_record)
2263 int rank = GFC_DESCRIPTOR_RANK(desc);
2272 for (i=0; i<rank; i++)
2274 ls[i].idx = desc->dim[i].lbound;
2275 ls[i].start = desc->dim[i].lbound;
2276 ls[i].end = desc->dim[i].ubound;
2277 ls[i].step = desc->dim[i].stride;
2278 empty = empty || (desc->dim[i].ubound < desc->dim[i].lbound);
2280 if (desc->dim[i].stride > 0)
2282 index += (desc->dim[i].ubound - desc->dim[i].lbound)
2283 * desc->dim[i].stride;
2287 index -= (desc->dim[i].ubound - desc->dim[i].lbound)
2288 * desc->dim[i].stride;
2289 *start_record -= (desc->dim[i].ubound - desc->dim[i].lbound)
2290 * desc->dim[i].stride;
2300 /* Determine the index to the next record in an internal unit array by
2301 by incrementing through the array_loop_spec. */
2304 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
2312 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2317 if (ls[i].idx > ls[i].end)
2319 ls[i].idx = ls[i].start;
2325 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2335 /* Skip to the end of the current record, taking care of an optional
2336 record marker of size bytes. If the file is not seekable, we
2337 read chunks of size MAX_READ until we get to the right
2341 skip_record (st_parameter_dt *dtp, size_t bytes)
2345 static const size_t MAX_READ = 4096;
2348 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2349 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2352 if (is_seekable (dtp->u.p.current_unit->s))
2354 new = file_position (dtp->u.p.current_unit->s)
2355 + dtp->u.p.current_unit->bytes_left_subrecord;
2357 /* Direct access files do not generate END conditions,
2359 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2360 generate_error (&dtp->common, LIBERROR_OS, NULL);
2363 { /* Seek by reading data. */
2364 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2367 (MAX_READ > (size_t) dtp->u.p.current_unit->bytes_left_subrecord) ?
2368 MAX_READ : (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
2370 if (sread (dtp->u.p.current_unit->s, p, &rlength) != 0)
2372 generate_error (&dtp->common, LIBERROR_OS, NULL);
2376 dtp->u.p.current_unit->bytes_left_subrecord -= rlength;
2383 /* Advance to the next record reading unformatted files, taking
2384 care of subrecords. If complete_record is nonzero, we loop
2385 until all subrecords are cleared. */
2388 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2392 bytes = compile_options.record_marker == 0 ?
2393 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2398 /* Skip over tail */
2400 skip_record (dtp, bytes);
2402 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2410 static inline gfc_offset
2411 min_off (gfc_offset a, gfc_offset b)
2413 return (a < b ? a : b);
2417 /* Space to the next record for read mode. */
2420 next_record_r (st_parameter_dt *dtp)
2427 switch (current_mode (dtp))
2429 /* No records in unformatted STREAM I/O. */
2430 case UNFORMATTED_STREAM:
2433 case UNFORMATTED_SEQUENTIAL:
2434 next_record_r_unf (dtp, 1);
2435 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2438 case FORMATTED_DIRECT:
2439 case UNFORMATTED_DIRECT:
2440 skip_record (dtp, 0);
2443 case FORMATTED_STREAM:
2444 case FORMATTED_SEQUENTIAL:
2446 /* sf_read has already terminated input because of an '\n' */
2447 if (dtp->u.p.sf_seen_eor)
2449 dtp->u.p.sf_seen_eor = 0;
2453 if (is_internal_unit (dtp))
2455 if (is_array_io (dtp))
2459 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2462 /* Now seek to this record. */
2463 record = record * dtp->u.p.current_unit->recl;
2464 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2466 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2469 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2473 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2474 bytes_left = min_off (bytes_left,
2475 file_length (dtp->u.p.current_unit->s)
2476 - file_position (dtp->u.p.current_unit->s));
2477 if (sseek (dtp->u.p.current_unit->s,
2478 file_position (dtp->u.p.current_unit->s)
2479 + bytes_left) == FAILURE)
2481 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2484 dtp->u.p.current_unit->bytes_left
2485 = dtp->u.p.current_unit->recl;
2491 if (sread (dtp->u.p.current_unit->s, &p, &length) != 0)
2493 generate_error (&dtp->common, LIBERROR_OS, NULL);
2499 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2503 if (is_stream_io (dtp))
2504 dtp->u.p.current_unit->strm_pos++;
2511 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
2512 && !dtp->u.p.namelist_mode
2513 && dtp->u.p.current_unit->endfile == NO_ENDFILE
2514 && (file_length (dtp->u.p.current_unit->s) ==
2515 file_position (dtp->u.p.current_unit->s)))
2516 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2521 /* Small utility function to write a record marker, taking care of
2522 byte swapping and of choosing the correct size. */
2525 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2530 char p[sizeof (GFC_INTEGER_8)];
2532 if (compile_options.record_marker == 0)
2533 len = sizeof (GFC_INTEGER_4);
2535 len = compile_options.record_marker;
2537 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2538 if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
2542 case sizeof (GFC_INTEGER_4):
2544 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2547 case sizeof (GFC_INTEGER_8):
2549 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2553 runtime_error ("Illegal value for record marker");
2561 case sizeof (GFC_INTEGER_4):
2563 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2564 return swrite (dtp->u.p.current_unit->s, p, &len);
2567 case sizeof (GFC_INTEGER_8):
2569 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2570 return swrite (dtp->u.p.current_unit->s, p, &len);
2574 runtime_error ("Illegal value for record marker");
2581 /* Position to the next (sub)record in write mode for
2582 unformatted sequential files. */
2585 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2587 gfc_offset c, m, m_write;
2588 size_t record_marker;
2590 /* Bytes written. */
2591 m = dtp->u.p.current_unit->recl_subrecord
2592 - dtp->u.p.current_unit->bytes_left_subrecord;
2593 c = file_position (dtp->u.p.current_unit->s);
2595 /* Write the length tail. If we finish a record containing
2596 subrecords, we write out the negative length. */
2598 if (dtp->u.p.current_unit->continued)
2603 if (write_us_marker (dtp, m_write) != 0)
2606 if (compile_options.record_marker == 0)
2607 record_marker = sizeof (GFC_INTEGER_4);
2609 record_marker = compile_options.record_marker;
2611 /* Seek to the head and overwrite the bogus length with the real
2614 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2623 if (write_us_marker (dtp, m_write) != 0)
2626 /* Seek past the end of the current record. */
2628 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2634 generate_error (&dtp->common, LIBERROR_OS, NULL);
2639 /* Position to the next record in write mode. */
2642 next_record_w (st_parameter_dt *dtp, int done)
2644 gfc_offset m, record, max_pos;
2647 /* Flush and reset the format buffer. */
2648 fbuf_flush (dtp->u.p.current_unit, 1);
2650 /* Zero counters for X- and T-editing. */
2651 max_pos = dtp->u.p.max_pos;
2652 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2654 switch (current_mode (dtp))
2656 /* No records in unformatted STREAM I/O. */
2657 case UNFORMATTED_STREAM:
2660 case FORMATTED_DIRECT:
2661 if (dtp->u.p.current_unit->bytes_left == 0)
2664 if (sset (dtp->u.p.current_unit->s, ' ',
2665 dtp->u.p.current_unit->bytes_left) == FAILURE)
2670 case UNFORMATTED_DIRECT:
2671 if (dtp->u.p.current_unit->bytes_left > 0)
2673 length = (int) dtp->u.p.current_unit->bytes_left;
2674 if (sset (dtp->u.p.current_unit->s, 0, length) == FAILURE)
2679 case UNFORMATTED_SEQUENTIAL:
2680 next_record_w_unf (dtp, 0);
2681 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2684 case FORMATTED_STREAM:
2685 case FORMATTED_SEQUENTIAL:
2687 if (is_internal_unit (dtp))
2689 if (is_array_io (dtp))
2693 length = (int) dtp->u.p.current_unit->bytes_left;
2695 /* If the farthest position reached is greater than current
2696 position, adjust the position and set length to pad out
2697 whats left. Otherwise just pad whats left.
2698 (for character array unit) */
2699 m = dtp->u.p.current_unit->recl
2700 - dtp->u.p.current_unit->bytes_left;
2703 length = (int) (max_pos - m);
2704 if (sseek (dtp->u.p.current_unit->s,
2705 file_position (dtp->u.p.current_unit->s)
2706 + length) == FAILURE)
2708 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2711 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2714 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2716 generate_error (&dtp->common, LIBERROR_END, NULL);
2720 /* Now that the current record has been padded out,
2721 determine where the next record in the array is. */
2722 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2725 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2727 /* Now seek to this record */
2728 record = record * dtp->u.p.current_unit->recl;
2730 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2732 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2736 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2742 /* If this is the last call to next_record move to the farthest
2743 position reached and set length to pad out the remainder
2744 of the record. (for character scaler unit) */
2747 m = dtp->u.p.current_unit->recl
2748 - dtp->u.p.current_unit->bytes_left;
2751 length = (int) (max_pos - m);
2752 if (sseek (dtp->u.p.current_unit->s,
2753 file_position (dtp->u.p.current_unit->s)
2754 + length) == FAILURE)
2756 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2759 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2762 length = (int) dtp->u.p.current_unit->bytes_left;
2765 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2767 generate_error (&dtp->common, LIBERROR_END, NULL);
2775 const char crlf[] = "\r\n";
2782 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2785 if (is_stream_io (dtp))
2787 dtp->u.p.current_unit->strm_pos += len;
2788 if (dtp->u.p.current_unit->strm_pos
2789 < file_length (dtp->u.p.current_unit->s))
2790 struncate (dtp->u.p.current_unit->s);
2797 generate_error (&dtp->common, LIBERROR_OS, NULL);
2802 /* Position to the next record, which means moving to the end of the
2803 current record. This can happen under several different
2804 conditions. If the done flag is not set, we get ready to process
2808 next_record (st_parameter_dt *dtp, int done)
2810 gfc_offset fp; /* File position. */
2812 dtp->u.p.current_unit->read_bad = 0;
2814 if (dtp->u.p.mode == READING)
2815 next_record_r (dtp);
2817 next_record_w (dtp, done);
2819 if (!is_stream_io (dtp))
2821 /* Keep position up to date for INQUIRE */
2823 update_position (dtp->u.p.current_unit);
2825 dtp->u.p.current_unit->current_record = 0;
2826 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2828 fp = file_position (dtp->u.p.current_unit->s);
2829 /* Calculate next record, rounding up partial records. */
2830 dtp->u.p.current_unit->last_record =
2831 (fp + dtp->u.p.current_unit->recl - 1) /
2832 dtp->u.p.current_unit->recl;
2835 dtp->u.p.current_unit->last_record++;
2843 /* Finalize the current data transfer. For a nonadvancing transfer,
2844 this means advancing to the next record. For internal units close the
2845 stream associated with the unit. */
2848 finalize_transfer (st_parameter_dt *dtp)
2851 GFC_INTEGER_4 cf = dtp->common.flags;
2853 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2854 *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
2856 if (dtp->u.p.eor_condition)
2858 generate_error (&dtp->common, LIBERROR_EOR, NULL);
2862 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2865 if ((dtp->u.p.ionml != NULL)
2866 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2868 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2869 namelist_read (dtp);
2871 namelist_write (dtp);
2874 dtp->u.p.transfer = NULL;
2875 if (dtp->u.p.current_unit == NULL)
2878 dtp->u.p.eof_jump = &eof_jump;
2879 if (setjmp (eof_jump))
2881 generate_error (&dtp->common, LIBERROR_END, NULL);
2885 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2887 finish_list_read (dtp);
2888 sfree (dtp->u.p.current_unit->s);
2892 if (dtp->u.p.mode == WRITING)
2893 dtp->u.p.current_unit->previous_nonadvancing_write
2894 = dtp->u.p.advance_status == ADVANCE_NO;
2896 if (is_stream_io (dtp))
2898 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2899 && dtp->u.p.advance_status != ADVANCE_NO)
2900 next_record (dtp, 1);
2902 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2903 && file_position (dtp->u.p.current_unit->s) >= dtp->rec)
2905 flush (dtp->u.p.current_unit->s);
2906 sfree (dtp->u.p.current_unit->s);
2911 dtp->u.p.current_unit->current_record = 0;
2913 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2915 dtp->u.p.seen_dollar = 0;
2916 fbuf_flush (dtp->u.p.current_unit, 1);
2917 sfree (dtp->u.p.current_unit->s);
2921 /* For non-advancing I/O, save the current maximum position for use in the
2922 next I/O operation if needed. */
2923 if (dtp->u.p.advance_status == ADVANCE_NO)
2925 int bytes_written = (int) (dtp->u.p.current_unit->recl
2926 - dtp->u.p.current_unit->bytes_left);
2927 dtp->u.p.current_unit->saved_pos =
2928 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
2929 fbuf_flush (dtp->u.p.current_unit, 0);
2930 flush (dtp->u.p.current_unit->s);
2934 dtp->u.p.current_unit->saved_pos = 0;
2936 next_record (dtp, 1);
2937 sfree (dtp->u.p.current_unit->s);
2940 /* Transfer function for IOLENGTH. It doesn't actually do any
2941 data transfer, it just updates the length counter. */
2944 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2945 void *dest __attribute__ ((unused)),
2946 int kind __attribute__((unused)),
2947 size_t size, size_t nelems)
2949 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2950 *dtp->iolength += (GFC_IO_INT) size * nelems;
2954 /* Initialize the IOLENGTH data transfer. This function is in essence
2955 a very much simplified version of data_transfer_init(), because it
2956 doesn't have to deal with units at all. */
2959 iolength_transfer_init (st_parameter_dt *dtp)
2961 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2964 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2966 /* Set up the subroutine that will handle the transfers. */
2968 dtp->u.p.transfer = iolength_transfer;
2972 /* Library entry point for the IOLENGTH form of the INQUIRE
2973 statement. The IOLENGTH form requires no I/O to be performed, but
2974 it must still be a runtime library call so that we can determine
2975 the iolength for dynamic arrays and such. */
2977 extern void st_iolength (st_parameter_dt *);
2978 export_proto(st_iolength);
2981 st_iolength (st_parameter_dt *dtp)
2983 library_start (&dtp->common);
2984 iolength_transfer_init (dtp);
2987 extern void st_iolength_done (st_parameter_dt *);
2988 export_proto(st_iolength_done);
2991 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2994 if (dtp->u.p.scratch != NULL)
2995 free_mem (dtp->u.p.scratch);
3000 /* The READ statement. */
3002 extern void st_read (st_parameter_dt *);
3003 export_proto(st_read);
3006 st_read (st_parameter_dt *dtp)
3008 library_start (&dtp->common);
3010 data_transfer_init (dtp, 1);
3012 /* Handle complications dealing with the endfile record. */
3014 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3015 switch (dtp->u.p.current_unit->endfile)
3021 if (!is_internal_unit (dtp))
3023 generate_error (&dtp->common, LIBERROR_END, NULL);
3024 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
3025 dtp->u.p.current_unit->current_record = 0;
3030 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
3031 dtp->u.p.current_unit->current_record = 0;
3036 extern void st_read_done (st_parameter_dt *);
3037 export_proto(st_read_done);
3040 st_read_done (st_parameter_dt *dtp)
3042 finalize_transfer (dtp);
3043 free_format_data (dtp);
3045 if (dtp->u.p.scratch != NULL)
3046 free_mem (dtp->u.p.scratch);
3047 if (dtp->u.p.current_unit != NULL)
3048 unlock_unit (dtp->u.p.current_unit);
3050 free_internal_unit (dtp);
3055 extern void st_write (st_parameter_dt *);
3056 export_proto(st_write);
3059 st_write (st_parameter_dt *dtp)
3061 library_start (&dtp->common);
3062 data_transfer_init (dtp, 0);
3065 extern void st_write_done (st_parameter_dt *);
3066 export_proto(st_write_done);
3069 st_write_done (st_parameter_dt *dtp)
3071 finalize_transfer (dtp);
3073 /* Deal with endfile conditions associated with sequential files. */
3075 if (dtp->u.p.current_unit != NULL
3076 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
3077 switch (dtp->u.p.current_unit->endfile)
3079 case AT_ENDFILE: /* Remain at the endfile record. */
3083 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
3087 /* Get rid of whatever is after this record. */
3088 if (!is_internal_unit (dtp))
3090 flush (dtp->u.p.current_unit->s);
3091 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
3092 generate_error (&dtp->common, LIBERROR_OS, NULL);
3094 dtp->u.p.current_unit->endfile = AT_ENDFILE;
3098 free_format_data (dtp);
3100 if (dtp->u.p.scratch != NULL)
3101 free_mem (dtp->u.p.scratch);
3102 if (dtp->u.p.current_unit != NULL)
3103 unlock_unit (dtp->u.p.current_unit);
3105 free_internal_unit (dtp);
3111 /* F2003: This is a stub for the runtime portion of the WAIT statement. */
3113 st_wait (st_parameter_wait *wtp __attribute__((unused)))
3118 /* Receives the scalar information for namelist objects and stores it
3119 in a linked list of namelist_info types. */
3121 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
3122 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
3123 export_proto(st_set_nml_var);
3127 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
3128 GFC_INTEGER_4 len, gfc_charlen_type string_length,
3129 GFC_INTEGER_4 dtype)
3131 namelist_info *t1 = NULL;
3133 size_t var_name_len = strlen (var_name);
3135 nml = (namelist_info*) get_mem (sizeof (namelist_info));
3137 nml->mem_pos = var_addr;
3139 nml->var_name = (char*) get_mem (var_name_len + 1);
3140 memcpy (nml->var_name, var_name, var_name_len);
3141 nml->var_name[var_name_len] = '\0';
3143 nml->len = (int) len;
3144 nml->string_length = (index_type) string_length;
3146 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
3147 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
3148 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
3150 if (nml->var_rank > 0)
3152 nml->dim = (descriptor_dimension*)
3153 get_mem (nml->var_rank * sizeof (descriptor_dimension));
3154 nml->ls = (array_loop_spec*)
3155 get_mem (nml->var_rank * sizeof (array_loop_spec));
3165 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
3167 dtp->common.flags |= IOPARM_DT_IONML_SET;
3168 dtp->u.p.ionml = nml;
3172 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
3177 /* Store the dimensional information for the namelist object. */
3178 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
3179 index_type, index_type,
3181 export_proto(st_set_nml_var_dim);
3184 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
3185 index_type stride, index_type lbound,
3188 namelist_info * nml;
3193 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
3195 nml->dim[n].stride = stride;
3196 nml->dim[n].lbound = lbound;
3197 nml->dim[n].ubound = ubound;
3200 /* Reverse memcpy - used for byte swapping. */
3202 void reverse_memcpy (void *dest, const void *src, size_t n)
3208 s = (char *) src + n - 1;
3210 /* Write with ascending order - this is likely faster
3211 on modern architectures because of write combining. */