1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
32 /* transfer.c -- Top level handling of data transfer statements. */
37 #include "libgfortran.h"
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
59 These subroutines do not return status.
61 The last call is a call to st_[read|write]_done(). While
62 something can easily go wrong with the initial st_read() or
63 st_write(), an error inhibits any data from actually being
66 extern void transfer_integer (st_parameter_dt *, void *, int);
67 export_proto(transfer_integer);
69 extern void transfer_real (st_parameter_dt *, void *, int);
70 export_proto(transfer_real);
72 extern void transfer_logical (st_parameter_dt *, void *, int);
73 export_proto(transfer_logical);
75 extern void transfer_character (st_parameter_dt *, void *, int);
76 export_proto(transfer_character);
78 extern void transfer_complex (st_parameter_dt *, void *, int);
79 export_proto(transfer_complex);
81 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
83 export_proto(transfer_array);
85 static void us_read (st_parameter_dt *, int);
86 static void us_write (st_parameter_dt *, int);
87 static void next_record_r_unf (st_parameter_dt *, int);
88 static void next_record_w_unf (st_parameter_dt *, int);
90 static const st_option advance_opt[] = {
98 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
99 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
105 current_mode (st_parameter_dt *dtp)
109 m = FORM_UNSPECIFIED;
111 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
113 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
114 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
116 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
118 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
119 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
121 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
123 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
124 FORMATTED_STREAM : UNFORMATTED_STREAM;
131 /* Mid level data transfer statements. These subroutines do reading
132 and writing in the style of salloc_r()/salloc_w() within the
135 /* When reading sequential formatted records we have a problem. We
136 don't know how long the line is until we read the trailing newline,
137 and we don't want to read too much. If we read too much, we might
138 have to do a physical seek backwards depending on how much data is
139 present, and devices like terminals aren't seekable and would cause
142 Given this, the solution is to read a byte at a time, stopping if
143 we hit the newline. For small allocations, we use a static buffer.
144 For larger allocations, we are forced to allocate memory on the
145 heap. Hopefully this won't happen very often. */
148 read_sf (st_parameter_dt *dtp, int *length, int no_error)
151 int n, readlen, crlf;
154 if (*length > SCRATCH_SIZE)
155 dtp->u.p.line_buffer = get_mem (*length);
156 p = base = dtp->u.p.line_buffer;
158 /* If we have seen an eor previously, return a length of 0. The
159 caller is responsible for correctly padding the input field. */
160 if (dtp->u.p.sf_seen_eor)
171 if (is_internal_unit (dtp))
173 /* readlen may be modified inside salloc_r if
174 is_internal_unit (dtp) is true. */
178 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
182 /* If we have a line without a terminating \n, drop through to
184 if (readlen < 1 && n == 0)
188 generate_error (&dtp->common, ERROR_END, NULL);
192 if (readlen < 1 || *q == '\n' || *q == '\r')
194 /* Unexpected end of line. */
196 /* If we see an EOR during non-advancing I/O, we need to skip
197 the rest of the I/O statement. Set the corresponding flag. */
198 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
199 dtp->u.p.eor_condition = 1;
202 /* If we encounter a CR, it might be a CRLF. */
203 if (*q == '\r') /* Probably a CRLF */
206 pos = stream_offset (dtp->u.p.current_unit->s);
207 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
208 if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */
209 sseek (dtp->u.p.current_unit->s, pos);
214 /* Without padding, terminate the I/O statement without assigning
215 the value. With padding, the value still needs to be assigned,
216 so we can just continue with a short read. */
217 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
221 generate_error (&dtp->common, ERROR_EOR, NULL);
226 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
229 /* Short circuit the read if a comma is found during numeric input.
230 The flag is set to zero during character reads so that commas in
231 strings are not ignored */
233 if (dtp->u.p.sf_read_comma == 1)
235 notify_std (&dtp->common, GFC_STD_GNU,
236 "Comma in formatted numeric read.");
243 dtp->u.p.sf_seen_eor = 0;
246 dtp->u.p.current_unit->bytes_left -= *length;
248 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
249 dtp->u.p.size_used += (gfc_offset) *length;
255 /* Function for reading the next couple of bytes from the current
256 file, advancing the current position. We return a pointer to a
257 buffer containing the bytes. We return NULL on end of record or
260 If the read is short, then it is because the current record does not
261 have enough data to satisfy the read request and the file was
262 opened with PAD=YES. The caller must assume tailing spaces for
266 read_block (st_parameter_dt *dtp, int *length)
271 if (is_stream_io (dtp))
273 if (sseek (dtp->u.p.current_unit->s,
274 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
276 generate_error (&dtp->common, ERROR_END, NULL);
282 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
284 /* For preconnected units with default record length, set bytes left
285 to unit record length and proceed, otherwise error. */
286 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
287 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
288 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
291 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
293 /* Not enough data left. */
294 generate_error (&dtp->common, ERROR_EOR, NULL);
299 if (dtp->u.p.current_unit->bytes_left == 0)
301 dtp->u.p.current_unit->endfile = AT_ENDFILE;
302 generate_error (&dtp->common, ERROR_END, NULL);
306 *length = dtp->u.p.current_unit->bytes_left;
310 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
311 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
312 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
314 source = read_sf (dtp, length, 0);
315 dtp->u.p.current_unit->strm_pos +=
316 (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
319 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
322 source = salloc_r (dtp->u.p.current_unit->s, &nread);
324 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
325 dtp->u.p.size_used += (gfc_offset) nread;
327 if (nread != *length)
328 { /* Short read, this shouldn't happen. */
329 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
333 generate_error (&dtp->common, ERROR_EOR, NULL);
338 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
344 /* Reads a block directly into application data space. This is for
345 unformatted files. */
348 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
350 size_t to_read_record;
351 size_t have_read_record;
352 size_t to_read_subrecord;
353 size_t have_read_subrecord;
356 if (is_stream_io (dtp))
358 if (sseek (dtp->u.p.current_unit->s,
359 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
361 generate_error (&dtp->common, ERROR_END, NULL);
365 to_read_record = *nbytes;
366 have_read_record = to_read_record;
367 if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
369 generate_error (&dtp->common, ERROR_OS, NULL);
373 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
375 if (to_read_record != have_read_record)
377 /* Short read, e.g. if we hit EOF. For stream files,
378 we have to set the end-of-file condition. */
379 generate_error (&dtp->common, ERROR_END, NULL);
385 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
387 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
390 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
391 *nbytes = to_read_record;
397 to_read_record = *nbytes;
400 dtp->u.p.current_unit->bytes_left -= to_read_record;
402 if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
404 generate_error (&dtp->common, ERROR_OS, NULL);
408 if (to_read_record != *nbytes)
410 /* Short read, e.g. if we hit EOF. Apparently, we read
411 more than was written to the last record. */
412 *nbytes = to_read_record;
413 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
419 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
425 /* Unformatted sequential. We loop over the subrecords, reading
426 until the request has been fulfilled or the record has run out
427 of continuation subrecords. */
429 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
431 generate_error (&dtp->common, ERROR_END, NULL);
435 /* Check whether we exceed the total record length. */
437 if (dtp->u.p.current_unit->flags.has_recl
438 && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
440 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
445 to_read_record = *nbytes;
448 have_read_record = 0;
452 if (dtp->u.p.current_unit->bytes_left_subrecord
453 < (gfc_offset) to_read_record)
455 to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
456 to_read_record -= to_read_subrecord;
460 to_read_subrecord = to_read_record;
464 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
466 have_read_subrecord = to_read_subrecord;
467 if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
468 &have_read_subrecord) != 0)
470 generate_error (&dtp->common, ERROR_OS, NULL);
474 have_read_record += have_read_subrecord;
476 if (to_read_subrecord != have_read_subrecord)
479 /* Short read, e.g. if we hit EOF. This means the record
480 structure has been corrupted, or the trailing record
481 marker would still be present. */
483 *nbytes = have_read_record;
484 generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL);
488 if (to_read_record > 0)
490 if (dtp->u.p.current_unit->continued)
492 next_record_r_unf (dtp, 0);
497 /* Let's make sure the file position is correctly set for the
498 next read statement. */
500 next_record_r_unf (dtp, 0);
502 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
508 /* Normal exit, the read request has been fulfilled. */
513 dtp->u.p.current_unit->bytes_left -= have_read_record;
516 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
523 /* Function for writing a block of bytes to the current file at the
524 current position, advancing the file pointer. We are given a length
525 and return a pointer to a buffer that the caller must (completely)
526 fill in. Returns NULL on error. */
529 write_block (st_parameter_dt *dtp, int length)
533 if (is_stream_io (dtp))
535 if (sseek (dtp->u.p.current_unit->s,
536 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
538 generate_error (&dtp->common, ERROR_OS, NULL);
544 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
546 /* For preconnected units with default record length, set bytes left
547 to unit record length and proceed, otherwise error. */
548 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
549 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
550 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
551 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
554 generate_error (&dtp->common, ERROR_EOR, NULL);
559 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
562 dest = salloc_w (dtp->u.p.current_unit->s, &length);
566 generate_error (&dtp->common, ERROR_END, NULL);
570 if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
571 generate_error (&dtp->common, ERROR_END, NULL);
573 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
574 dtp->u.p.size_used += (gfc_offset) length;
576 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
582 /* High level interface to swrite(), taking care of errors. This is only
583 called for unformatted files. There are three cases to consider:
584 Stream I/O, unformatted direct, unformatted sequential. */
587 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
590 size_t have_written, to_write_subrecord;
596 if (is_stream_io (dtp))
598 if (sseek (dtp->u.p.current_unit->s,
599 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
601 generate_error (&dtp->common, ERROR_OS, NULL);
605 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
607 generate_error (&dtp->common, ERROR_OS, NULL);
611 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
616 /* Unformatted direct access. */
618 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
620 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
622 generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
626 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
628 generate_error (&dtp->common, ERROR_OS, NULL);
632 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
633 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
639 /* Unformatted sequential. */
643 if (dtp->u.p.current_unit->flags.has_recl
644 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
646 nbytes = dtp->u.p.current_unit->bytes_left;
658 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
659 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
661 dtp->u.p.current_unit->bytes_left_subrecord -=
662 (gfc_offset) to_write_subrecord;
664 if (swrite (dtp->u.p.current_unit->s, buf + have_written,
665 &to_write_subrecord) != 0)
667 generate_error (&dtp->common, ERROR_OS, NULL);
671 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
672 nbytes -= to_write_subrecord;
673 have_written += to_write_subrecord;
678 next_record_w_unf (dtp, 1);
681 dtp->u.p.current_unit->bytes_left -= have_written;
684 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
691 /* Master function for unformatted reads. */
694 unformatted_read (st_parameter_dt *dtp, bt type,
695 void *dest, int kind,
696 size_t size, size_t nelems)
700 /* Currently, character implies size=1. */
701 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
702 || size == 1 || type == BT_CHARACTER)
705 read_block_direct (dtp, dest, &sz);
712 /* Break up complex into its constituent reals. */
713 if (type == BT_COMPLEX)
720 /* By now, all complex variables have been split into their
721 constituent reals. For types with padding, we only need to
722 read kind bytes. We don't care about the contents
723 of the padding. If we hit a short record, then sz is
724 adjusted accordingly, making later reads no-ops. */
727 for (i=0; i<nelems; i++)
729 read_block_direct (dtp, buffer, &sz);
730 reverse_memcpy (p, buffer, sz);
737 /* Master function for unformatted writes. */
740 unformatted_write (st_parameter_dt *dtp, bt type,
741 void *source, int kind,
742 size_t size, size_t nelems)
744 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
745 size == 1 || type == BT_CHARACTER)
749 write_buf (dtp, source, size);
757 /* Break up complex into its constituent reals. */
758 if (type == BT_COMPLEX)
766 /* By now, all complex variables have been split into their
767 constituent reals. For types with padding, we only need to
768 read kind bytes. We don't care about the contents
772 for (i=0; i<nelems; i++)
774 reverse_memcpy(buffer, p, size);
776 write_buf (dtp, buffer, sz);
782 /* Return a pointer to the name of a type. */
807 internal_error (NULL, "type_name(): Bad type");
814 /* Write a constant string to the output.
815 This is complicated because the string can have doubled delimiters
816 in it. The length in the format node is the true length. */
819 write_constant_string (st_parameter_dt *dtp, const fnode *f)
821 char c, delimiter, *p, *q;
824 length = f->u.string.length;
828 p = write_block (dtp, length);
835 for (; length > 0; length--)
838 if (c == delimiter && c != 'H' && c != 'h')
839 q++; /* Skip the doubled delimiter. */
844 /* Given actual and expected types in a formatted data transfer, make
845 sure they agree. If not, an error message is generated. Returns
846 nonzero if something went wrong. */
849 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
853 if (actual == expected)
856 st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
857 type_name (expected), dtp->u.p.item_count, type_name (actual));
859 format_error (dtp, f, buffer);
864 /* This subroutine is the main loop for a formatted data transfer
865 statement. It would be natural to implement this as a coroutine
866 with the user program, but C makes that awkward. We loop,
867 processing format elements. When we actually have to transfer
868 data instead of just setting flags, we return control to the user
869 program which calls a subroutine that supplies the address and type
870 of the next element, then comes back here to process it. */
873 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
876 char scratch[SCRATCH_SIZE];
881 int consume_data_flag;
883 /* Change a complex data item into a pair of reals. */
885 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
886 if (type == BT_COMPLEX)
892 /* If there's an EOR condition, we simulate finalizing the transfer
894 if (dtp->u.p.eor_condition)
897 /* Set this flag so that commas in reads cause the read to complete before
898 the entire field has been read. The next read field will start right after
899 the comma in the stream. (Set to 0 for character reads). */
900 dtp->u.p.sf_read_comma = 1;
902 dtp->u.p.line_buffer = scratch;
905 /* If reversion has occurred and there is another real data item,
906 then we have to move to the next record. */
907 if (dtp->u.p.reversion_flag && n > 0)
909 dtp->u.p.reversion_flag = 0;
910 next_record (dtp, 0);
913 consume_data_flag = 1 ;
914 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
917 f = next_format (dtp);
920 /* No data descriptors left. */
922 generate_error (&dtp->common, ERROR_FORMAT,
923 "Insufficient data descriptors in format after reversion");
927 /* Now discharge T, TR and X movements to the right. This is delayed
928 until a data producing format to suppress trailing spaces. */
931 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
932 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
933 || t == FMT_Z || t == FMT_F || t == FMT_E
934 || t == FMT_EN || t == FMT_ES || t == FMT_G
935 || t == FMT_L || t == FMT_A || t == FMT_D))
938 if (dtp->u.p.skips > 0)
940 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
941 dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
942 - dtp->u.p.current_unit->bytes_left);
944 if (dtp->u.p.skips < 0)
946 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
947 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
949 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
952 bytes_used = (int)(dtp->u.p.current_unit->recl
953 - dtp->u.p.current_unit->bytes_left);
960 if (require_type (dtp, BT_INTEGER, type, f))
963 if (dtp->u.p.mode == READING)
964 read_decimal (dtp, f, p, len);
966 write_i (dtp, f, p, len);
974 if (compile_options.allow_std < GFC_STD_GNU
975 && require_type (dtp, BT_INTEGER, type, f))
978 if (dtp->u.p.mode == READING)
979 read_radix (dtp, f, p, len, 2);
981 write_b (dtp, f, p, len);
989 if (compile_options.allow_std < GFC_STD_GNU
990 && require_type (dtp, BT_INTEGER, type, f))
993 if (dtp->u.p.mode == READING)
994 read_radix (dtp, f, p, len, 8);
996 write_o (dtp, f, p, len);
1004 if (compile_options.allow_std < GFC_STD_GNU
1005 && require_type (dtp, BT_INTEGER, type, f))
1008 if (dtp->u.p.mode == READING)
1009 read_radix (dtp, f, p, len, 16);
1011 write_z (dtp, f, p, len);
1019 if (dtp->u.p.mode == READING)
1020 read_a (dtp, f, p, len);
1022 write_a (dtp, f, p, len);
1030 if (dtp->u.p.mode == READING)
1031 read_l (dtp, f, p, len);
1033 write_l (dtp, f, p, len);
1040 if (require_type (dtp, BT_REAL, type, f))
1043 if (dtp->u.p.mode == READING)
1044 read_f (dtp, f, p, len);
1046 write_d (dtp, f, p, len);
1053 if (require_type (dtp, BT_REAL, type, f))
1056 if (dtp->u.p.mode == READING)
1057 read_f (dtp, f, p, len);
1059 write_e (dtp, f, p, len);
1065 if (require_type (dtp, BT_REAL, type, f))
1068 if (dtp->u.p.mode == READING)
1069 read_f (dtp, f, p, len);
1071 write_en (dtp, f, p, len);
1078 if (require_type (dtp, BT_REAL, type, f))
1081 if (dtp->u.p.mode == READING)
1082 read_f (dtp, f, p, len);
1084 write_es (dtp, f, p, len);
1091 if (require_type (dtp, BT_REAL, type, f))
1094 if (dtp->u.p.mode == READING)
1095 read_f (dtp, f, p, len);
1097 write_f (dtp, f, p, len);
1104 if (dtp->u.p.mode == READING)
1108 read_decimal (dtp, f, p, len);
1111 read_l (dtp, f, p, len);
1114 read_a (dtp, f, p, len);
1117 read_f (dtp, f, p, len);
1126 write_i (dtp, f, p, len);
1129 write_l (dtp, f, p, len);
1132 write_a (dtp, f, p, len);
1135 write_d (dtp, f, p, len);
1139 internal_error (&dtp->common,
1140 "formatted_transfer(): Bad type");
1146 consume_data_flag = 0 ;
1147 if (dtp->u.p.mode == READING)
1149 format_error (dtp, f, "Constant string in input format");
1152 write_constant_string (dtp, f);
1155 /* Format codes that don't transfer data. */
1158 consume_data_flag = 0 ;
1160 pos = bytes_used + f->u.n + dtp->u.p.skips;
1161 dtp->u.p.skips = f->u.n + dtp->u.p.skips;
1162 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1164 /* Writes occur just before the switch on f->format, above, so
1165 that trailing blanks are suppressed, unless we are doing a
1166 non-advancing write in which case we want to output the blanks
1168 if (dtp->u.p.mode == WRITING
1169 && dtp->u.p.advance_status == ADVANCE_NO)
1171 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1172 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1174 if (dtp->u.p.mode == READING)
1175 read_x (dtp, f->u.n);
1181 if (f->format == FMT_TL)
1184 /* Handle the special case when no bytes have been used yet.
1185 Cannot go below zero. */
1186 if (bytes_used == 0)
1188 dtp->u.p.pending_spaces -= f->u.n;
1189 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1190 : dtp->u.p.pending_spaces;
1191 dtp->u.p.skips -= f->u.n;
1192 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1195 pos = bytes_used - f->u.n;
1199 consume_data_flag = 0;
1203 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1204 left tab limit. We do not check if the position has gone
1205 beyond the end of record because a subsequent tab could
1206 bring us back again. */
1207 pos = pos < 0 ? 0 : pos;
1209 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1210 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1211 + pos - dtp->u.p.max_pos;
1213 if (dtp->u.p.skips == 0)
1216 /* Writes occur just before the switch on f->format, above, so that
1217 trailing blanks are suppressed. */
1218 if (dtp->u.p.mode == READING)
1220 /* Adjust everything for end-of-record condition */
1221 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1223 if (dtp->u.p.sf_seen_eor == 2)
1225 /* The EOR was a CRLF (two bytes wide). */
1226 dtp->u.p.current_unit->bytes_left -= 2;
1227 dtp->u.p.skips -= 2;
1231 /* The EOR marker was only one byte wide. */
1232 dtp->u.p.current_unit->bytes_left--;
1236 dtp->u.p.sf_seen_eor = 0;
1238 if (dtp->u.p.skips < 0)
1240 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1241 dtp->u.p.current_unit->bytes_left
1242 -= (gfc_offset) dtp->u.p.skips;
1243 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1246 read_x (dtp, dtp->u.p.skips);
1252 consume_data_flag = 0 ;
1253 dtp->u.p.sign_status = SIGN_S;
1257 consume_data_flag = 0 ;
1258 dtp->u.p.sign_status = SIGN_SS;
1262 consume_data_flag = 0 ;
1263 dtp->u.p.sign_status = SIGN_SP;
1267 consume_data_flag = 0 ;
1268 dtp->u.p.blank_status = BLANK_NULL;
1272 consume_data_flag = 0 ;
1273 dtp->u.p.blank_status = BLANK_ZERO;
1277 consume_data_flag = 0 ;
1278 dtp->u.p.scale_factor = f->u.k;
1282 consume_data_flag = 0 ;
1283 dtp->u.p.seen_dollar = 1;
1287 consume_data_flag = 0 ;
1288 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1289 next_record (dtp, 0);
1293 /* A colon descriptor causes us to exit this loop (in
1294 particular preventing another / descriptor from being
1295 processed) unless there is another data item to be
1297 consume_data_flag = 0 ;
1303 internal_error (&dtp->common, "Bad format node");
1306 /* Free a buffer that we had to allocate during a sequential
1307 formatted read of a block that was larger than the static
1310 if (dtp->u.p.line_buffer != scratch)
1312 free_mem (dtp->u.p.line_buffer);
1313 dtp->u.p.line_buffer = scratch;
1316 /* Adjust the item count and data pointer. */
1318 if ((consume_data_flag > 0) && (n > 0))
1321 p = ((char *) p) + size;
1324 if (dtp->u.p.mode == READING)
1327 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1328 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1334 /* Come here when we need a data descriptor but don't have one. We
1335 push the current format node back onto the input, then return and
1336 let the user program call us back with the data. */
1338 unget_format (dtp, f);
1342 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1343 size_t size, size_t nelems)
1350 /* Big loop over all the elements. */
1351 for (elem = 0; elem < nelems; elem++)
1353 dtp->u.p.item_count++;
1354 formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1360 /* Data transfer entry points. The type of the data entity is
1361 implicit in the subroutine call. This prevents us from having to
1362 share a common enum with the compiler. */
1365 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1367 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1369 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1374 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1377 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1379 size = size_from_real_kind (kind);
1380 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1385 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1387 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1389 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1394 transfer_character (st_parameter_dt *dtp, void *p, int len)
1396 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1398 /* Currently we support only 1 byte chars, and the library is a bit
1399 confused of character kind vs. length, so we kludge it by setting
1401 dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1406 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1409 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1411 size = size_from_complex_kind (kind);
1412 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1417 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1418 gfc_charlen_type charlen)
1420 index_type count[GFC_MAX_DIMENSIONS];
1421 index_type extent[GFC_MAX_DIMENSIONS];
1422 index_type stride[GFC_MAX_DIMENSIONS];
1423 index_type stride0, rank, size, type, n;
1428 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1431 type = GFC_DESCRIPTOR_TYPE (desc);
1432 size = GFC_DESCRIPTOR_SIZE (desc);
1434 /* FIXME: What a kludge: Array descriptors and the IO library use
1435 different enums for types. */
1438 case GFC_DTYPE_UNKNOWN:
1439 iotype = BT_NULL; /* Is this correct? */
1441 case GFC_DTYPE_INTEGER:
1442 iotype = BT_INTEGER;
1444 case GFC_DTYPE_LOGICAL:
1445 iotype = BT_LOGICAL;
1447 case GFC_DTYPE_REAL:
1450 case GFC_DTYPE_COMPLEX:
1451 iotype = BT_COMPLEX;
1453 case GFC_DTYPE_CHARACTER:
1454 iotype = BT_CHARACTER;
1455 /* FIXME: Currently dtype contains the charlen, which is
1456 clobbered if charlen > 2**24. That's why we use a separate
1457 argument for the charlen. However, if we want to support
1458 non-8-bit charsets we need to fix dtype to contain
1459 sizeof(chartype) and fix the code below. */
1463 case GFC_DTYPE_DERIVED:
1464 internal_error (&dtp->common,
1465 "Derived type I/O should have been handled via the frontend.");
1468 internal_error (&dtp->common, "transfer_array(): Bad type");
1471 rank = GFC_DESCRIPTOR_RANK (desc);
1472 for (n = 0; n < rank; n++)
1475 stride[n] = desc->dim[n].stride;
1476 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1478 /* If the extent of even one dimension is zero, then the entire
1479 array section contains zero elements, so we return. */
1484 stride0 = stride[0];
1486 /* If the innermost dimension has stride 1, we can do the transfer
1487 in contiguous chunks. */
1493 data = GFC_DESCRIPTOR_DATA (desc);
1497 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1498 data += stride0 * size * tsize;
1501 while (count[n] == extent[n])
1504 data -= stride[n] * extent[n] * size;
1514 data += stride[n] * size;
1521 /* Preposition a sequential unformatted file while reading. */
1524 us_read (st_parameter_dt *dtp, int continued)
1533 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1536 if (compile_options.record_marker == 0)
1537 n = sizeof (GFC_INTEGER_4);
1539 n = compile_options.record_marker;
1543 p = salloc_r (dtp->u.p.current_unit->s, &n);
1547 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1548 return; /* end of file */
1551 if (p == NULL || n != nr)
1553 generate_error (&dtp->common, ERROR_BAD_US, NULL);
1557 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1558 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1562 case sizeof(GFC_INTEGER_4):
1563 memcpy (&i4, p, sizeof (i4));
1567 case sizeof(GFC_INTEGER_8):
1568 memcpy (&i8, p, sizeof (i8));
1573 runtime_error ("Illegal value for record marker");
1580 case sizeof(GFC_INTEGER_4):
1581 reverse_memcpy (&i4, p, sizeof (i4));
1585 case sizeof(GFC_INTEGER_8):
1586 reverse_memcpy (&i8, p, sizeof (i8));
1591 runtime_error ("Illegal value for record marker");
1597 dtp->u.p.current_unit->bytes_left_subrecord = i;
1598 dtp->u.p.current_unit->continued = 0;
1602 dtp->u.p.current_unit->bytes_left_subrecord = -i;
1603 dtp->u.p.current_unit->continued = 1;
1607 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1611 /* Preposition a sequential unformatted file while writing. This
1612 amount to writing a bogus length that will be filled in later. */
1615 us_write (st_parameter_dt *dtp, int continued)
1622 if (compile_options.record_marker == 0)
1623 nbytes = sizeof (GFC_INTEGER_4);
1625 nbytes = compile_options.record_marker ;
1627 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1628 generate_error (&dtp->common, ERROR_OS, NULL);
1630 /* For sequential unformatted, if RECL= was not specified in the OPEN
1631 we write until we have more bytes than can fit in the subrecord
1632 markers, then we write a new subrecord. */
1634 dtp->u.p.current_unit->bytes_left_subrecord =
1635 dtp->u.p.current_unit->recl_subrecord;
1636 dtp->u.p.current_unit->continued = continued;
1640 /* Position to the next record prior to transfer. We are assumed to
1641 be before the next record. We also calculate the bytes in the next
1645 pre_position (st_parameter_dt *dtp)
1647 if (dtp->u.p.current_unit->current_record)
1648 return; /* Already positioned. */
1650 switch (current_mode (dtp))
1652 case FORMATTED_STREAM:
1653 case UNFORMATTED_STREAM:
1654 /* There are no records with stream I/O. Set the default position
1655 to the beginning of the file if no position was specified. */
1656 if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1657 dtp->u.p.current_unit->strm_pos = 1;
1660 case UNFORMATTED_SEQUENTIAL:
1661 if (dtp->u.p.mode == READING)
1668 case FORMATTED_SEQUENTIAL:
1669 case FORMATTED_DIRECT:
1670 case UNFORMATTED_DIRECT:
1671 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1675 dtp->u.p.current_unit->current_record = 1;
1679 /* Initialize things for a data transfer. This code is common for
1680 both reading and writing. */
1683 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1685 unit_flags u_flags; /* Used for creating a unit if needed. */
1686 GFC_INTEGER_4 cf = dtp->common.flags;
1687 namelist_info *ionml;
1689 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1690 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1691 dtp->u.p.ionml = ionml;
1692 dtp->u.p.mode = read_flag ? READING : WRITING;
1694 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1695 dtp->u.p.size_used = 0; /* Initialize the count. */
1697 dtp->u.p.current_unit = get_unit (dtp, 1);
1698 if (dtp->u.p.current_unit->s == NULL)
1699 { /* Open the unit with some default flags. */
1700 st_parameter_open opp;
1703 if (dtp->common.unit < 0)
1705 close_unit (dtp->u.p.current_unit);
1706 dtp->u.p.current_unit = NULL;
1707 generate_error (&dtp->common, ERROR_BAD_OPTION,
1708 "Bad unit number in OPEN statement");
1711 memset (&u_flags, '\0', sizeof (u_flags));
1712 u_flags.access = ACCESS_SEQUENTIAL;
1713 u_flags.action = ACTION_READWRITE;
1715 /* Is it unformatted? */
1716 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1717 | IOPARM_DT_IONML_SET)))
1718 u_flags.form = FORM_UNFORMATTED;
1720 u_flags.form = FORM_UNSPECIFIED;
1722 u_flags.delim = DELIM_UNSPECIFIED;
1723 u_flags.blank = BLANK_UNSPECIFIED;
1724 u_flags.pad = PAD_UNSPECIFIED;
1725 u_flags.status = STATUS_UNKNOWN;
1727 conv = get_unformatted_convert (dtp->common.unit);
1729 if (conv == CONVERT_NONE)
1730 conv = compile_options.convert;
1732 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1733 and 1 on big-endian machines. */
1736 case CONVERT_NATIVE:
1741 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1744 case CONVERT_LITTLE:
1745 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1749 internal_error (&opp.common, "Illegal value for CONVERT");
1753 u_flags.convert = conv;
1755 opp.common = dtp->common;
1756 opp.common.flags &= IOPARM_COMMON_MASK;
1757 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1758 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1759 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1760 if (dtp->u.p.current_unit == NULL)
1764 /* Check the action. */
1766 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1767 generate_error (&dtp->common, ERROR_BAD_ACTION,
1768 "Cannot read from file opened for WRITE");
1770 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1771 generate_error (&dtp->common, ERROR_BAD_ACTION,
1772 "Cannot write to file opened for READ");
1774 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1777 dtp->u.p.first_item = 1;
1779 /* Check the format. */
1781 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1784 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1787 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1788 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1790 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1791 "Format present for UNFORMATTED data transfer");
1793 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1795 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1796 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1797 "A format cannot be specified with a namelist");
1799 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1800 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1801 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1802 "Missing format for FORMATTED data transfer");
1804 if (is_internal_unit (dtp)
1805 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1806 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1807 "Internal file cannot be accessed by UNFORMATTED data transfer");
1809 /* Check the record or position number. */
1811 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1812 && (cf & IOPARM_DT_HAS_REC) == 0)
1814 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1815 "Direct access data transfer requires record number");
1819 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1820 && (cf & IOPARM_DT_HAS_REC) != 0)
1822 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1823 "Record number not allowed for sequential access data transfer");
1827 /* Process the ADVANCE option. */
1829 dtp->u.p.advance_status
1830 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1831 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1832 "Bad ADVANCE parameter in data transfer statement");
1834 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1836 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1837 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1838 "ADVANCE specification conflicts with sequential access");
1840 if (is_internal_unit (dtp))
1841 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1842 "ADVANCE specification conflicts with internal file");
1844 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1845 != IOPARM_DT_HAS_FORMAT)
1846 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1847 "ADVANCE specification requires an explicit format");
1852 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1853 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1854 "EOR specification requires an ADVANCE specification of NO");
1856 if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1857 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1858 "SIZE specification requires an ADVANCE specification of NO");
1862 { /* Write constraints. */
1863 if ((cf & IOPARM_END) != 0)
1864 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1865 "END specification cannot appear in a write statement");
1867 if ((cf & IOPARM_EOR) != 0)
1868 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1869 "EOR specification cannot appear in a write statement");
1871 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1872 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1873 "SIZE specification cannot appear in a write statement");
1876 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1877 dtp->u.p.advance_status = ADVANCE_YES;
1878 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1881 /* Sanity checks on the record number. */
1882 if ((cf & IOPARM_DT_HAS_REC) != 0)
1886 generate_error (&dtp->common, ERROR_BAD_OPTION,
1887 "Record number must be positive");
1891 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1893 generate_error (&dtp->common, ERROR_BAD_OPTION,
1894 "Record number too large");
1898 /* Check to see if we might be reading what we wrote before */
1900 if (dtp->u.p.mode == READING
1901 && dtp->u.p.current_unit->mode == WRITING
1902 && !is_internal_unit (dtp))
1903 flush(dtp->u.p.current_unit->s);
1905 /* Check whether the record exists to be read. Only
1906 a partial record needs to exist. */
1908 if (dtp->u.p.mode == READING && (dtp->rec -1)
1909 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1911 generate_error (&dtp->common, ERROR_BAD_OPTION,
1912 "Non-existing record number");
1916 /* Position the file. */
1917 if (!is_stream_io (dtp))
1919 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1920 * dtp->u.p.current_unit->recl) == FAILURE)
1922 generate_error (&dtp->common, ERROR_OS, NULL);
1927 dtp->u.p.current_unit->strm_pos = dtp->rec;
1931 /* Overwriting an existing sequential file ?
1932 it is always safe to truncate the file on the first write */
1933 if (dtp->u.p.mode == WRITING
1934 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1935 && dtp->u.p.current_unit->last_record == 0
1936 && !is_preconnected(dtp->u.p.current_unit->s))
1937 struncate(dtp->u.p.current_unit->s);
1939 /* Bugware for badly written mixed C-Fortran I/O. */
1940 flush_if_preconnected(dtp->u.p.current_unit->s);
1942 dtp->u.p.current_unit->mode = dtp->u.p.mode;
1944 /* Set the initial value of flags. */
1946 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1947 dtp->u.p.sign_status = SIGN_S;
1951 /* Set up the subroutine that will handle the transfers. */
1955 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1956 dtp->u.p.transfer = unformatted_read;
1959 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1960 dtp->u.p.transfer = list_formatted_read;
1962 dtp->u.p.transfer = formatted_transfer;
1967 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1968 dtp->u.p.transfer = unformatted_write;
1971 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1972 dtp->u.p.transfer = list_formatted_write;
1974 dtp->u.p.transfer = formatted_transfer;
1978 /* Make sure that we don't do a read after a nonadvancing write. */
1982 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1984 generate_error (&dtp->common, ERROR_BAD_OPTION,
1985 "Cannot READ after a nonadvancing WRITE");
1991 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1992 dtp->u.p.current_unit->read_bad = 1;
1995 /* Start the data transfer if we are doing a formatted transfer. */
1996 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1997 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1998 && dtp->u.p.ionml == NULL)
1999 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2002 /* Initialize an array_loop_spec given the array descriptor. The function
2003 returns the index of the last element of the array. */
2006 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
2008 int rank = GFC_DESCRIPTOR_RANK(desc);
2013 for (i=0; i<rank; i++)
2015 ls[i].idx = desc->dim[i].lbound;
2016 ls[i].start = desc->dim[i].lbound;
2017 ls[i].end = desc->dim[i].ubound;
2018 ls[i].step = desc->dim[i].stride;
2020 index += (desc->dim[i].ubound - desc->dim[i].lbound)
2021 * desc->dim[i].stride;
2026 /* Determine the index to the next record in an internal unit array by
2027 by incrementing through the array_loop_spec. TODO: Implement handling
2028 negative strides. */
2031 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
2039 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2044 if (ls[i].idx > ls[i].end)
2046 ls[i].idx = ls[i].start;
2052 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2060 /* Skip to the end of the current record, taking care of an optional
2061 record marker of size bytes. If the file is not seekable, we
2062 read chunks of size MAX_READ until we get to the right
2065 #define MAX_READ 4096
2068 skip_record (st_parameter_dt *dtp, size_t bytes)
2071 int rlength, length;
2074 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2075 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2078 if (is_seekable (dtp->u.p.current_unit->s))
2080 new = file_position (dtp->u.p.current_unit->s)
2081 + dtp->u.p.current_unit->bytes_left_subrecord;
2083 /* Direct access files do not generate END conditions,
2085 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2086 generate_error (&dtp->common, ERROR_OS, NULL);
2089 { /* Seek by reading data. */
2090 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2093 (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
2094 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2096 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
2099 generate_error (&dtp->common, ERROR_OS, NULL);
2103 dtp->u.p.current_unit->bytes_left_subrecord -= length;
2111 /* Advance to the next record reading unformatted files, taking
2112 care of subrecords. If complete_record is nonzero, we loop
2113 until all subrecords are cleared. */
2116 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2120 bytes = compile_options.record_marker == 0 ?
2121 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2126 /* Skip over tail */
2128 skip_record (dtp, bytes);
2130 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2137 /* Space to the next record for read mode. */
2140 next_record_r (st_parameter_dt *dtp)
2143 int length, bytes_left;
2146 switch (current_mode (dtp))
2148 /* No records in unformatted STREAM I/O. */
2149 case UNFORMATTED_STREAM:
2152 case UNFORMATTED_SEQUENTIAL:
2153 next_record_r_unf (dtp, 1);
2154 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2157 case FORMATTED_DIRECT:
2158 case UNFORMATTED_DIRECT:
2159 skip_record (dtp, 0);
2162 case FORMATTED_STREAM:
2163 case FORMATTED_SEQUENTIAL:
2165 /* sf_read has already terminated input because of an '\n' */
2166 if (dtp->u.p.sf_seen_eor)
2168 dtp->u.p.sf_seen_eor = 0;
2172 if (is_internal_unit (dtp))
2174 if (is_array_io (dtp))
2176 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2178 /* Now seek to this record. */
2179 record = record * dtp->u.p.current_unit->recl;
2180 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2182 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2185 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2189 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2190 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2192 dtp->u.p.current_unit->bytes_left
2193 = dtp->u.p.current_unit->recl;
2199 p = salloc_r (dtp->u.p.current_unit->s, &length);
2203 generate_error (&dtp->common, ERROR_OS, NULL);
2209 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2213 if (is_stream_io (dtp))
2214 dtp->u.p.current_unit->strm_pos++;
2221 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2222 test_endfile (dtp->u.p.current_unit);
2226 /* Small utility function to write a record marker, taking care of
2227 byte swapping and of choosing the correct size. */
2230 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2235 char p[sizeof (GFC_INTEGER_8)];
2237 if (compile_options.record_marker == 0)
2238 len = sizeof (GFC_INTEGER_4);
2240 len = compile_options.record_marker;
2242 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2243 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2247 case sizeof (GFC_INTEGER_4):
2249 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2252 case sizeof (GFC_INTEGER_8):
2254 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2258 runtime_error ("Illegal value for record marker");
2266 case sizeof (GFC_INTEGER_4):
2268 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2269 return swrite (dtp->u.p.current_unit->s, p, &len);
2272 case sizeof (GFC_INTEGER_8):
2274 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2275 return swrite (dtp->u.p.current_unit->s, p, &len);
2279 runtime_error ("Illegal value for record marker");
2286 /* Position to the next (sub)record in write mode for
2287 unformatted sequential files. */
2290 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2292 gfc_offset c, m, m_write;
2293 size_t record_marker;
2295 /* Bytes written. */
2296 m = dtp->u.p.current_unit->recl_subrecord
2297 - dtp->u.p.current_unit->bytes_left_subrecord;
2298 c = file_position (dtp->u.p.current_unit->s);
2300 /* Write the length tail. If we finish a record containing
2301 subrecords, we write out the negative length. */
2303 if (dtp->u.p.current_unit->continued)
2308 if (write_us_marker (dtp, m_write) != 0)
2311 if (compile_options.record_marker == 0)
2312 record_marker = sizeof (GFC_INTEGER_4);
2314 record_marker = compile_options.record_marker;
2316 /* Seek to the head and overwrite the bogus length with the real
2319 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2328 if (write_us_marker (dtp, m_write) != 0)
2331 /* Seek past the end of the current record. */
2333 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2339 generate_error (&dtp->common, ERROR_OS, NULL);
2344 /* Position to the next record in write mode. */
2347 next_record_w (st_parameter_dt *dtp, int done)
2349 gfc_offset m, record, max_pos;
2353 /* Zero counters for X- and T-editing. */
2354 max_pos = dtp->u.p.max_pos;
2355 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2357 switch (current_mode (dtp))
2359 /* No records in unformatted STREAM I/O. */
2360 case UNFORMATTED_STREAM:
2363 case FORMATTED_DIRECT:
2364 if (dtp->u.p.current_unit->bytes_left == 0)
2367 if (sset (dtp->u.p.current_unit->s, ' ',
2368 dtp->u.p.current_unit->bytes_left) == FAILURE)
2373 case UNFORMATTED_DIRECT:
2374 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2378 case UNFORMATTED_SEQUENTIAL:
2379 next_record_w_unf (dtp, 0);
2380 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2383 case FORMATTED_STREAM:
2384 case FORMATTED_SEQUENTIAL:
2386 if (is_internal_unit (dtp))
2388 if (is_array_io (dtp))
2390 length = (int) dtp->u.p.current_unit->bytes_left;
2392 /* If the farthest position reached is greater than current
2393 position, adjust the position and set length to pad out
2394 whats left. Otherwise just pad whats left.
2395 (for character array unit) */
2396 m = dtp->u.p.current_unit->recl
2397 - dtp->u.p.current_unit->bytes_left;
2400 length = (int) (max_pos - m);
2401 p = salloc_w (dtp->u.p.current_unit->s, &length);
2402 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2405 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2407 generate_error (&dtp->common, ERROR_END, NULL);
2411 /* Now that the current record has been padded out,
2412 determine where the next record in the array is. */
2413 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2415 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2417 /* Now seek to this record */
2418 record = record * dtp->u.p.current_unit->recl;
2420 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2422 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2426 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2432 /* If this is the last call to next_record move to the farthest
2433 position reached and set length to pad out the remainder
2434 of the record. (for character scaler unit) */
2437 m = dtp->u.p.current_unit->recl
2438 - dtp->u.p.current_unit->bytes_left;
2441 length = (int) (max_pos - m);
2442 p = salloc_w (dtp->u.p.current_unit->s, &length);
2443 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2446 length = (int) dtp->u.p.current_unit->bytes_left;
2449 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2451 generate_error (&dtp->common, ERROR_END, NULL);
2459 /* If this is the last call to next_record move to the farthest
2460 position reached in preparation for completing the record.
2464 m = dtp->u.p.current_unit->recl -
2465 dtp->u.p.current_unit->bytes_left;
2468 length = (int) (max_pos - m);
2469 p = salloc_w (dtp->u.p.current_unit->s, &length);
2473 const char crlf[] = "\r\n";
2479 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2482 if (is_stream_io (dtp))
2483 dtp->u.p.current_unit->strm_pos += len;
2489 generate_error (&dtp->common, ERROR_OS, NULL);
2494 /* Position to the next record, which means moving to the end of the
2495 current record. This can happen under several different
2496 conditions. If the done flag is not set, we get ready to process
2500 next_record (st_parameter_dt *dtp, int done)
2502 gfc_offset fp; /* File position. */
2504 dtp->u.p.current_unit->read_bad = 0;
2506 if (dtp->u.p.mode == READING)
2507 next_record_r (dtp);
2509 next_record_w (dtp, done);
2511 if (!is_stream_io (dtp))
2513 /* keep position up to date for INQUIRE */
2514 dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2515 dtp->u.p.current_unit->current_record = 0;
2516 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2518 fp = file_position (dtp->u.p.current_unit->s);
2519 /* Calculate next record, rounding up partial records. */
2520 dtp->u.p.current_unit->last_record =
2521 (fp + dtp->u.p.current_unit->recl - 1) /
2522 dtp->u.p.current_unit->recl;
2525 dtp->u.p.current_unit->last_record++;
2533 /* Finalize the current data transfer. For a nonadvancing transfer,
2534 this means advancing to the next record. For internal units close the
2535 stream associated with the unit. */
2538 finalize_transfer (st_parameter_dt *dtp)
2541 GFC_INTEGER_4 cf = dtp->common.flags;
2543 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2544 *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
2546 if (dtp->u.p.eor_condition)
2548 generate_error (&dtp->common, ERROR_EOR, NULL);
2552 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2555 if ((dtp->u.p.ionml != NULL)
2556 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2558 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2559 namelist_read (dtp);
2561 namelist_write (dtp);
2564 dtp->u.p.transfer = NULL;
2565 if (dtp->u.p.current_unit == NULL)
2568 dtp->u.p.eof_jump = &eof_jump;
2569 if (setjmp (eof_jump))
2571 generate_error (&dtp->common, ERROR_END, NULL);
2575 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2577 finish_list_read (dtp);
2578 sfree (dtp->u.p.current_unit->s);
2582 if (is_stream_io (dtp))
2584 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2585 next_record (dtp, 1);
2586 flush (dtp->u.p.current_unit->s);
2587 sfree (dtp->u.p.current_unit->s);
2591 dtp->u.p.current_unit->current_record = 0;
2593 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2595 dtp->u.p.seen_dollar = 0;
2596 sfree (dtp->u.p.current_unit->s);
2600 if (dtp->u.p.advance_status == ADVANCE_NO)
2602 flush (dtp->u.p.current_unit->s);
2606 next_record (dtp, 1);
2607 sfree (dtp->u.p.current_unit->s);
2610 /* Transfer function for IOLENGTH. It doesn't actually do any
2611 data transfer, it just updates the length counter. */
2614 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2615 void *dest __attribute__ ((unused)),
2616 int kind __attribute__((unused)),
2617 size_t size, size_t nelems)
2619 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2620 *dtp->iolength += (GFC_IO_INT) size * nelems;
2624 /* Initialize the IOLENGTH data transfer. This function is in essence
2625 a very much simplified version of data_transfer_init(), because it
2626 doesn't have to deal with units at all. */
2629 iolength_transfer_init (st_parameter_dt *dtp)
2631 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2634 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2636 /* Set up the subroutine that will handle the transfers. */
2638 dtp->u.p.transfer = iolength_transfer;
2642 /* Library entry point for the IOLENGTH form of the INQUIRE
2643 statement. The IOLENGTH form requires no I/O to be performed, but
2644 it must still be a runtime library call so that we can determine
2645 the iolength for dynamic arrays and such. */
2647 extern void st_iolength (st_parameter_dt *);
2648 export_proto(st_iolength);
2651 st_iolength (st_parameter_dt *dtp)
2653 library_start (&dtp->common);
2654 iolength_transfer_init (dtp);
2657 extern void st_iolength_done (st_parameter_dt *);
2658 export_proto(st_iolength_done);
2661 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2664 if (dtp->u.p.scratch != NULL)
2665 free_mem (dtp->u.p.scratch);
2670 /* The READ statement. */
2672 extern void st_read (st_parameter_dt *);
2673 export_proto(st_read);
2676 st_read (st_parameter_dt *dtp)
2678 library_start (&dtp->common);
2680 data_transfer_init (dtp, 1);
2682 /* Handle complications dealing with the endfile record. It is
2683 significant that this is the only place where ERROR_END is
2684 generated. Reading an end of file elsewhere is either end of
2685 record or an I/O error. */
2687 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2688 switch (dtp->u.p.current_unit->endfile)
2694 if (!is_internal_unit (dtp))
2696 generate_error (&dtp->common, ERROR_END, NULL);
2697 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2698 dtp->u.p.current_unit->current_record = 0;
2703 generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2704 dtp->u.p.current_unit->current_record = 0;
2709 extern void st_read_done (st_parameter_dt *);
2710 export_proto(st_read_done);
2713 st_read_done (st_parameter_dt *dtp)
2715 finalize_transfer (dtp);
2716 free_format_data (dtp);
2718 if (dtp->u.p.scratch != NULL)
2719 free_mem (dtp->u.p.scratch);
2720 if (dtp->u.p.current_unit != NULL)
2721 unlock_unit (dtp->u.p.current_unit);
2723 free_internal_unit (dtp);
2728 extern void st_write (st_parameter_dt *);
2729 export_proto(st_write);
2732 st_write (st_parameter_dt *dtp)
2734 library_start (&dtp->common);
2735 data_transfer_init (dtp, 0);
2738 extern void st_write_done (st_parameter_dt *);
2739 export_proto(st_write_done);
2742 st_write_done (st_parameter_dt *dtp)
2744 finalize_transfer (dtp);
2746 /* Deal with endfile conditions associated with sequential files. */
2748 if (dtp->u.p.current_unit != NULL
2749 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2750 switch (dtp->u.p.current_unit->endfile)
2752 case AT_ENDFILE: /* Remain at the endfile record. */
2756 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2760 /* Get rid of whatever is after this record. */
2761 if (!is_internal_unit (dtp))
2763 flush (dtp->u.p.current_unit->s);
2764 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2765 generate_error (&dtp->common, ERROR_OS, NULL);
2767 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2771 free_format_data (dtp);
2773 if (dtp->u.p.scratch != NULL)
2774 free_mem (dtp->u.p.scratch);
2775 if (dtp->u.p.current_unit != NULL)
2776 unlock_unit (dtp->u.p.current_unit);
2778 free_internal_unit (dtp);
2783 /* Receives the scalar information for namelist objects and stores it
2784 in a linked list of namelist_info types. */
2786 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2787 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2788 export_proto(st_set_nml_var);
2792 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2793 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2794 GFC_INTEGER_4 dtype)
2796 namelist_info *t1 = NULL;
2799 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2801 nml->mem_pos = var_addr;
2803 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2804 strcpy (nml->var_name, var_name);
2806 nml->len = (int) len;
2807 nml->string_length = (index_type) string_length;
2809 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2810 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2811 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2813 if (nml->var_rank > 0)
2815 nml->dim = (descriptor_dimension*)
2816 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2817 nml->ls = (array_loop_spec*)
2818 get_mem (nml->var_rank * sizeof (array_loop_spec));
2828 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2830 dtp->common.flags |= IOPARM_DT_IONML_SET;
2831 dtp->u.p.ionml = nml;
2835 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2840 /* Store the dimensional information for the namelist object. */
2841 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2842 GFC_INTEGER_4, GFC_INTEGER_4,
2844 export_proto(st_set_nml_var_dim);
2847 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2848 GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2849 GFC_INTEGER_4 ubound)
2851 namelist_info * nml;
2856 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2858 nml->dim[n].stride = (ssize_t)stride;
2859 nml->dim[n].lbound = (ssize_t)lbound;
2860 nml->dim[n].ubound = (ssize_t)ubound;
2863 /* Reverse memcpy - used for byte swapping. */
2865 void reverse_memcpy (void *dest, const void *src, size_t n)
2871 s = (char *) src + n - 1;
2873 /* Write with ascending order - this is likely faster
2874 on modern architectures because of write combining. */