1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
2 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
4 Namelist transfer functions contributed by Paul Thomas
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Libgfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public License
28 along with Libgfortran; see the file COPYING. If not, write to
29 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
33 /* transfer.c -- Top level handling of data transfer statements. */
38 #include "libgfortran.h"
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
60 These subroutines do not return status.
62 The last call is a call to st_[read|write]_done(). While
63 something can easily go wrong with the initial st_read() or
64 st_write(), an error inhibits any data from actually being
67 extern void transfer_integer (st_parameter_dt *, void *, int);
68 export_proto(transfer_integer);
70 extern void transfer_real (st_parameter_dt *, void *, int);
71 export_proto(transfer_real);
73 extern void transfer_logical (st_parameter_dt *, void *, int);
74 export_proto(transfer_logical);
76 extern void transfer_character (st_parameter_dt *, void *, int);
77 export_proto(transfer_character);
79 extern void transfer_complex (st_parameter_dt *, void *, int);
80 export_proto(transfer_complex);
82 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
84 export_proto(transfer_array);
86 static void us_read (st_parameter_dt *, int);
87 static void us_write (st_parameter_dt *, int);
88 static void next_record_r_unf (st_parameter_dt *, int);
89 static void next_record_w_unf (st_parameter_dt *, int);
91 static const st_option advance_opt[] = {
99 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
100 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
106 current_mode (st_parameter_dt *dtp)
110 m = FORM_UNSPECIFIED;
112 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
114 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
115 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
117 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
119 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
120 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
122 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
124 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
125 FORMATTED_STREAM : UNFORMATTED_STREAM;
132 /* Mid level data transfer statements. These subroutines do reading
133 and writing in the style of salloc_r()/salloc_w() within the
136 /* When reading sequential formatted records we have a problem. We
137 don't know how long the line is until we read the trailing newline,
138 and we don't want to read too much. If we read too much, we might
139 have to do a physical seek backwards depending on how much data is
140 present, and devices like terminals aren't seekable and would cause
143 Given this, the solution is to read a byte at a time, stopping if
144 we hit the newline. For small allocations, we use a static buffer.
145 For larger allocations, we are forced to allocate memory on the
146 heap. Hopefully this won't happen very often. */
149 read_sf (st_parameter_dt *dtp, int *length, int no_error)
152 int n, readlen, crlf;
155 if (*length > SCRATCH_SIZE)
156 dtp->u.p.line_buffer = get_mem (*length);
157 p = base = dtp->u.p.line_buffer;
159 /* If we have seen an eor previously, return a length of 0. The
160 caller is responsible for correctly padding the input field. */
161 if (dtp->u.p.sf_seen_eor)
172 if (is_internal_unit (dtp))
174 /* readlen may be modified inside salloc_r if
175 is_internal_unit (dtp) is true. */
179 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
183 /* If we have a line without a terminating \n, drop through to
185 if (readlen < 1 && n == 0)
189 generate_error (&dtp->common, ERROR_END, NULL);
193 if (readlen < 1 || *q == '\n' || *q == '\r')
195 /* Unexpected end of line. */
197 /* If we see an EOR during non-advancing I/O, we need to skip
198 the rest of the I/O statement. Set the corresponding flag. */
199 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
200 dtp->u.p.eor_condition = 1;
203 /* If we encounter a CR, it might be a CRLF. */
204 if (*q == '\r') /* Probably a CRLF */
207 pos = stream_offset (dtp->u.p.current_unit->s);
208 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
209 if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */
210 sseek (dtp->u.p.current_unit->s, pos);
215 /* Without padding, terminate the I/O statement without assigning
216 the value. With padding, the value still needs to be assigned,
217 so we can just continue with a short read. */
218 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
222 generate_error (&dtp->common, ERROR_EOR, NULL);
227 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
230 /* Short circuit the read if a comma is found during numeric input.
231 The flag is set to zero during character reads so that commas in
232 strings are not ignored */
234 if (dtp->u.p.sf_read_comma == 1)
236 notify_std (&dtp->common, GFC_STD_GNU,
237 "Comma in formatted numeric read.");
244 dtp->u.p.sf_seen_eor = 0;
247 dtp->u.p.current_unit->bytes_left -= *length;
249 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
250 dtp->u.p.size_used += (gfc_offset) *length;
256 /* Function for reading the next couple of bytes from the current
257 file, advancing the current position. We return a pointer to a
258 buffer containing the bytes. We return NULL on end of record or
261 If the read is short, then it is because the current record does not
262 have enough data to satisfy the read request and the file was
263 opened with PAD=YES. The caller must assume tailing spaces for
267 read_block (st_parameter_dt *dtp, int *length)
272 if (is_stream_io (dtp))
274 if (sseek (dtp->u.p.current_unit->s,
275 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
277 generate_error (&dtp->common, ERROR_END, NULL);
283 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
285 /* For preconnected units with default record length, set bytes left
286 to unit record length and proceed, otherwise error. */
287 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
288 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
289 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
292 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
294 /* Not enough data left. */
295 generate_error (&dtp->common, ERROR_EOR, NULL);
300 if (dtp->u.p.current_unit->bytes_left == 0)
302 dtp->u.p.current_unit->endfile = AT_ENDFILE;
303 generate_error (&dtp->common, ERROR_END, NULL);
307 *length = dtp->u.p.current_unit->bytes_left;
311 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
312 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
313 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
315 source = read_sf (dtp, length, 0);
316 dtp->u.p.current_unit->strm_pos +=
317 (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
320 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
323 source = salloc_r (dtp->u.p.current_unit->s, &nread);
325 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
326 dtp->u.p.size_used += (gfc_offset) nread;
328 if (nread != *length)
329 { /* Short read, this shouldn't happen. */
330 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
334 generate_error (&dtp->common, ERROR_EOR, NULL);
339 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
345 /* Reads a block directly into application data space. This is for
346 unformatted files. */
349 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
351 size_t to_read_record;
352 size_t have_read_record;
353 size_t to_read_subrecord;
354 size_t have_read_subrecord;
357 if (is_stream_io (dtp))
359 if (sseek (dtp->u.p.current_unit->s,
360 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
362 generate_error (&dtp->common, ERROR_END, NULL);
366 to_read_record = *nbytes;
367 have_read_record = to_read_record;
368 if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
370 generate_error (&dtp->common, ERROR_OS, NULL);
374 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
376 if (to_read_record != have_read_record)
378 /* Short read, e.g. if we hit EOF. For stream files,
379 we have to set the end-of-file condition. */
380 generate_error (&dtp->common, ERROR_END, NULL);
386 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
388 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
391 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
392 *nbytes = to_read_record;
398 to_read_record = *nbytes;
401 dtp->u.p.current_unit->bytes_left -= to_read_record;
403 if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
405 generate_error (&dtp->common, ERROR_OS, NULL);
409 if (to_read_record != *nbytes)
411 /* Short read, e.g. if we hit EOF. Apparently, we read
412 more than was written to the last record. */
413 *nbytes = to_read_record;
414 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
420 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
426 /* Unformatted sequential. We loop over the subrecords, reading
427 until the request has been fulfilled or the record has run out
428 of continuation subrecords. */
430 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
432 generate_error (&dtp->common, ERROR_END, NULL);
436 /* Check whether we exceed the total record length. */
438 if (dtp->u.p.current_unit->flags.has_recl
439 && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
441 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
446 to_read_record = *nbytes;
449 have_read_record = 0;
453 if (dtp->u.p.current_unit->bytes_left_subrecord
454 < (gfc_offset) to_read_record)
456 to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
457 to_read_record -= to_read_subrecord;
461 to_read_subrecord = to_read_record;
465 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
467 have_read_subrecord = to_read_subrecord;
468 if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
469 &have_read_subrecord) != 0)
471 generate_error (&dtp->common, ERROR_OS, NULL);
475 have_read_record += have_read_subrecord;
477 if (to_read_subrecord != have_read_subrecord)
480 /* Short read, e.g. if we hit EOF. This means the record
481 structure has been corrupted, or the trailing record
482 marker would still be present. */
484 *nbytes = have_read_record;
485 generate_error (&dtp->common, ERROR_CORRUPT_FILE, NULL);
489 if (to_read_record > 0)
491 if (dtp->u.p.current_unit->continued)
493 next_record_r_unf (dtp, 0);
498 /* Let's make sure the file position is correctly set for the
499 next read statement. */
501 next_record_r_unf (dtp, 0);
503 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
509 /* Normal exit, the read request has been fulfilled. */
514 dtp->u.p.current_unit->bytes_left -= have_read_record;
517 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
524 /* Function for writing a block of bytes to the current file at the
525 current position, advancing the file pointer. We are given a length
526 and return a pointer to a buffer that the caller must (completely)
527 fill in. Returns NULL on error. */
530 write_block (st_parameter_dt *dtp, int length)
534 if (is_stream_io (dtp))
536 if (sseek (dtp->u.p.current_unit->s,
537 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
539 generate_error (&dtp->common, ERROR_OS, NULL);
545 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
547 /* For preconnected units with default record length, set bytes left
548 to unit record length and proceed, otherwise error. */
549 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
550 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
551 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
552 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
555 generate_error (&dtp->common, ERROR_EOR, NULL);
560 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
563 dest = salloc_w (dtp->u.p.current_unit->s, &length);
567 generate_error (&dtp->common, ERROR_END, NULL);
571 if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
572 generate_error (&dtp->common, ERROR_END, NULL);
574 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
575 dtp->u.p.size_used += (gfc_offset) length;
577 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
583 /* High level interface to swrite(), taking care of errors. This is only
584 called for unformatted files. There are three cases to consider:
585 Stream I/O, unformatted direct, unformatted sequential. */
588 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
591 size_t have_written, to_write_subrecord;
597 if (is_stream_io (dtp))
599 if (sseek (dtp->u.p.current_unit->s,
600 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
602 generate_error (&dtp->common, ERROR_OS, NULL);
606 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
608 generate_error (&dtp->common, ERROR_OS, NULL);
612 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
617 /* Unformatted direct access. */
619 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
621 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
623 generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
627 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
629 generate_error (&dtp->common, ERROR_OS, NULL);
633 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
634 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
640 /* Unformatted sequential. */
644 if (dtp->u.p.current_unit->flags.has_recl
645 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
647 nbytes = dtp->u.p.current_unit->bytes_left;
659 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
660 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
662 dtp->u.p.current_unit->bytes_left_subrecord -=
663 (gfc_offset) to_write_subrecord;
665 if (swrite (dtp->u.p.current_unit->s, buf + have_written,
666 &to_write_subrecord) != 0)
668 generate_error (&dtp->common, ERROR_OS, NULL);
672 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
673 nbytes -= to_write_subrecord;
674 have_written += to_write_subrecord;
679 next_record_w_unf (dtp, 1);
682 dtp->u.p.current_unit->bytes_left -= have_written;
685 generate_error (&dtp->common, ERROR_SHORT_RECORD, NULL);
692 /* Master function for unformatted reads. */
695 unformatted_read (st_parameter_dt *dtp, bt type,
696 void *dest, int kind,
697 size_t size, size_t nelems)
701 /* Currently, character implies size=1. */
702 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
703 || size == 1 || type == BT_CHARACTER)
706 read_block_direct (dtp, dest, &sz);
713 /* Break up complex into its constituent reals. */
714 if (type == BT_COMPLEX)
721 /* By now, all complex variables have been split into their
722 constituent reals. For types with padding, we only need to
723 read kind bytes. We don't care about the contents
724 of the padding. If we hit a short record, then sz is
725 adjusted accordingly, making later reads no-ops. */
728 for (i=0; i<nelems; i++)
730 read_block_direct (dtp, buffer, &sz);
731 reverse_memcpy (p, buffer, sz);
738 /* Master function for unformatted writes. */
741 unformatted_write (st_parameter_dt *dtp, bt type,
742 void *source, int kind,
743 size_t size, size_t nelems)
745 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
746 size == 1 || type == BT_CHARACTER)
750 write_buf (dtp, source, size);
758 /* Break up complex into its constituent reals. */
759 if (type == BT_COMPLEX)
767 /* By now, all complex variables have been split into their
768 constituent reals. For types with padding, we only need to
769 read kind bytes. We don't care about the contents
773 for (i=0; i<nelems; i++)
775 reverse_memcpy(buffer, p, size);
777 write_buf (dtp, buffer, sz);
783 /* Return a pointer to the name of a type. */
808 internal_error (NULL, "type_name(): Bad type");
815 /* Write a constant string to the output.
816 This is complicated because the string can have doubled delimiters
817 in it. The length in the format node is the true length. */
820 write_constant_string (st_parameter_dt *dtp, const fnode *f)
822 char c, delimiter, *p, *q;
825 length = f->u.string.length;
829 p = write_block (dtp, length);
836 for (; length > 0; length--)
839 if (c == delimiter && c != 'H' && c != 'h')
840 q++; /* Skip the doubled delimiter. */
845 /* Given actual and expected types in a formatted data transfer, make
846 sure they agree. If not, an error message is generated. Returns
847 nonzero if something went wrong. */
850 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
854 if (actual == expected)
857 st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
858 type_name (expected), dtp->u.p.item_count, type_name (actual));
860 format_error (dtp, f, buffer);
865 /* This subroutine is the main loop for a formatted data transfer
866 statement. It would be natural to implement this as a coroutine
867 with the user program, but C makes that awkward. We loop,
868 processing format elements. When we actually have to transfer
869 data instead of just setting flags, we return control to the user
870 program which calls a subroutine that supplies the address and type
871 of the next element, then comes back here to process it. */
874 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
877 char scratch[SCRATCH_SIZE];
882 int consume_data_flag;
884 /* Change a complex data item into a pair of reals. */
886 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
887 if (type == BT_COMPLEX)
893 /* If there's an EOR condition, we simulate finalizing the transfer
895 if (dtp->u.p.eor_condition)
898 /* Set this flag so that commas in reads cause the read to complete before
899 the entire field has been read. The next read field will start right after
900 the comma in the stream. (Set to 0 for character reads). */
901 dtp->u.p.sf_read_comma = 1;
903 dtp->u.p.line_buffer = scratch;
906 /* If reversion has occurred and there is another real data item,
907 then we have to move to the next record. */
908 if (dtp->u.p.reversion_flag && n > 0)
910 dtp->u.p.reversion_flag = 0;
911 next_record (dtp, 0);
914 consume_data_flag = 1 ;
915 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
918 f = next_format (dtp);
921 /* No data descriptors left. */
923 generate_error (&dtp->common, ERROR_FORMAT,
924 "Insufficient data descriptors in format after reversion");
928 /* Now discharge T, TR and X movements to the right. This is delayed
929 until a data producing format to suppress trailing spaces. */
932 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
933 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
934 || t == FMT_Z || t == FMT_F || t == FMT_E
935 || t == FMT_EN || t == FMT_ES || t == FMT_G
936 || t == FMT_L || t == FMT_A || t == FMT_D))
939 if (dtp->u.p.skips > 0)
941 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
942 dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
943 - dtp->u.p.current_unit->bytes_left);
945 if (dtp->u.p.skips < 0)
947 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
948 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
950 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
953 bytes_used = (int)(dtp->u.p.current_unit->recl
954 - dtp->u.p.current_unit->bytes_left);
961 if (require_type (dtp, BT_INTEGER, type, f))
964 if (dtp->u.p.mode == READING)
965 read_decimal (dtp, f, p, len);
967 write_i (dtp, f, p, len);
975 if (compile_options.allow_std < GFC_STD_GNU
976 && require_type (dtp, BT_INTEGER, type, f))
979 if (dtp->u.p.mode == READING)
980 read_radix (dtp, f, p, len, 2);
982 write_b (dtp, f, p, len);
990 if (compile_options.allow_std < GFC_STD_GNU
991 && require_type (dtp, BT_INTEGER, type, f))
994 if (dtp->u.p.mode == READING)
995 read_radix (dtp, f, p, len, 8);
997 write_o (dtp, f, p, len);
1005 if (compile_options.allow_std < GFC_STD_GNU
1006 && require_type (dtp, BT_INTEGER, type, f))
1009 if (dtp->u.p.mode == READING)
1010 read_radix (dtp, f, p, len, 16);
1012 write_z (dtp, f, p, len);
1020 if (dtp->u.p.mode == READING)
1021 read_a (dtp, f, p, len);
1023 write_a (dtp, f, p, len);
1031 if (dtp->u.p.mode == READING)
1032 read_l (dtp, f, p, len);
1034 write_l (dtp, f, p, len);
1041 if (require_type (dtp, BT_REAL, type, f))
1044 if (dtp->u.p.mode == READING)
1045 read_f (dtp, f, p, len);
1047 write_d (dtp, f, p, len);
1054 if (require_type (dtp, BT_REAL, type, f))
1057 if (dtp->u.p.mode == READING)
1058 read_f (dtp, f, p, len);
1060 write_e (dtp, f, p, len);
1066 if (require_type (dtp, BT_REAL, type, f))
1069 if (dtp->u.p.mode == READING)
1070 read_f (dtp, f, p, len);
1072 write_en (dtp, f, p, len);
1079 if (require_type (dtp, BT_REAL, type, f))
1082 if (dtp->u.p.mode == READING)
1083 read_f (dtp, f, p, len);
1085 write_es (dtp, f, p, len);
1092 if (require_type (dtp, BT_REAL, type, f))
1095 if (dtp->u.p.mode == READING)
1096 read_f (dtp, f, p, len);
1098 write_f (dtp, f, p, len);
1105 if (dtp->u.p.mode == READING)
1109 read_decimal (dtp, f, p, len);
1112 read_l (dtp, f, p, len);
1115 read_a (dtp, f, p, len);
1118 read_f (dtp, f, p, len);
1127 write_i (dtp, f, p, len);
1130 write_l (dtp, f, p, len);
1133 write_a (dtp, f, p, len);
1136 write_d (dtp, f, p, len);
1140 internal_error (&dtp->common,
1141 "formatted_transfer(): Bad type");
1147 consume_data_flag = 0 ;
1148 if (dtp->u.p.mode == READING)
1150 format_error (dtp, f, "Constant string in input format");
1153 write_constant_string (dtp, f);
1156 /* Format codes that don't transfer data. */
1159 consume_data_flag = 0;
1161 pos = bytes_used + f->u.n + dtp->u.p.skips;
1162 dtp->u.p.skips = f->u.n + dtp->u.p.skips;
1163 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1165 /* Writes occur just before the switch on f->format, above, so
1166 that trailing blanks are suppressed, unless we are doing a
1167 non-advancing write in which case we want to output the blanks
1169 if (dtp->u.p.mode == WRITING
1170 && dtp->u.p.advance_status == ADVANCE_NO)
1172 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1173 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1176 if (dtp->u.p.mode == READING)
1177 read_x (dtp, f->u.n);
1183 consume_data_flag = 0;
1185 if (f->format == FMT_TL)
1188 /* Handle the special case when no bytes have been used yet.
1189 Cannot go below zero. */
1190 if (bytes_used == 0)
1192 dtp->u.p.pending_spaces -= f->u.n;
1193 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1194 : dtp->u.p.pending_spaces;
1195 dtp->u.p.skips -= f->u.n;
1196 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1199 pos = bytes_used - f->u.n;
1203 if (dtp->u.p.mode == READING)
1206 pos = f->u.n - dtp->u.p.pending_spaces - 1;
1209 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1210 left tab limit. We do not check if the position has gone
1211 beyond the end of record because a subsequent tab could
1212 bring us back again. */
1213 pos = pos < 0 ? 0 : pos;
1215 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1216 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1217 + pos - dtp->u.p.max_pos;
1219 if (dtp->u.p.skips == 0)
1222 /* Writes occur just before the switch on f->format, above, so that
1223 trailing blanks are suppressed. */
1224 if (dtp->u.p.mode == READING)
1226 /* Adjust everything for end-of-record condition */
1227 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1229 if (dtp->u.p.sf_seen_eor == 2)
1231 /* The EOR was a CRLF (two bytes wide). */
1232 dtp->u.p.current_unit->bytes_left -= 2;
1233 dtp->u.p.skips -= 2;
1237 /* The EOR marker was only one byte wide. */
1238 dtp->u.p.current_unit->bytes_left--;
1242 dtp->u.p.sf_seen_eor = 0;
1244 if (dtp->u.p.skips < 0)
1246 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1247 dtp->u.p.current_unit->bytes_left
1248 -= (gfc_offset) dtp->u.p.skips;
1249 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1252 read_x (dtp, dtp->u.p.skips);
1258 consume_data_flag = 0 ;
1259 dtp->u.p.sign_status = SIGN_S;
1263 consume_data_flag = 0 ;
1264 dtp->u.p.sign_status = SIGN_SS;
1268 consume_data_flag = 0 ;
1269 dtp->u.p.sign_status = SIGN_SP;
1273 consume_data_flag = 0 ;
1274 dtp->u.p.blank_status = BLANK_NULL;
1278 consume_data_flag = 0 ;
1279 dtp->u.p.blank_status = BLANK_ZERO;
1283 consume_data_flag = 0 ;
1284 dtp->u.p.scale_factor = f->u.k;
1288 consume_data_flag = 0 ;
1289 dtp->u.p.seen_dollar = 1;
1293 consume_data_flag = 0 ;
1294 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1295 next_record (dtp, 0);
1299 /* A colon descriptor causes us to exit this loop (in
1300 particular preventing another / descriptor from being
1301 processed) unless there is another data item to be
1303 consume_data_flag = 0 ;
1309 internal_error (&dtp->common, "Bad format node");
1312 /* Free a buffer that we had to allocate during a sequential
1313 formatted read of a block that was larger than the static
1316 if (dtp->u.p.line_buffer != scratch)
1318 free_mem (dtp->u.p.line_buffer);
1319 dtp->u.p.line_buffer = scratch;
1322 /* Adjust the item count and data pointer. */
1324 if ((consume_data_flag > 0) && (n > 0))
1327 p = ((char *) p) + size;
1330 if (dtp->u.p.mode == READING)
1333 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1334 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1340 /* Come here when we need a data descriptor but don't have one. We
1341 push the current format node back onto the input, then return and
1342 let the user program call us back with the data. */
1344 unget_format (dtp, f);
1348 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1349 size_t size, size_t nelems)
1356 /* Big loop over all the elements. */
1357 for (elem = 0; elem < nelems; elem++)
1359 dtp->u.p.item_count++;
1360 formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1366 /* Data transfer entry points. The type of the data entity is
1367 implicit in the subroutine call. This prevents us from having to
1368 share a common enum with the compiler. */
1371 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1373 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1375 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1380 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1383 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1385 size = size_from_real_kind (kind);
1386 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1391 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1393 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1395 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1400 transfer_character (st_parameter_dt *dtp, void *p, int len)
1402 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1404 /* Currently we support only 1 byte chars, and the library is a bit
1405 confused of character kind vs. length, so we kludge it by setting
1407 dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1412 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1415 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1417 size = size_from_complex_kind (kind);
1418 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1423 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1424 gfc_charlen_type charlen)
1426 index_type count[GFC_MAX_DIMENSIONS];
1427 index_type extent[GFC_MAX_DIMENSIONS];
1428 index_type stride[GFC_MAX_DIMENSIONS];
1429 index_type stride0, rank, size, type, n;
1434 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1437 type = GFC_DESCRIPTOR_TYPE (desc);
1438 size = GFC_DESCRIPTOR_SIZE (desc);
1440 /* FIXME: What a kludge: Array descriptors and the IO library use
1441 different enums for types. */
1444 case GFC_DTYPE_UNKNOWN:
1445 iotype = BT_NULL; /* Is this correct? */
1447 case GFC_DTYPE_INTEGER:
1448 iotype = BT_INTEGER;
1450 case GFC_DTYPE_LOGICAL:
1451 iotype = BT_LOGICAL;
1453 case GFC_DTYPE_REAL:
1456 case GFC_DTYPE_COMPLEX:
1457 iotype = BT_COMPLEX;
1459 case GFC_DTYPE_CHARACTER:
1460 iotype = BT_CHARACTER;
1461 /* FIXME: Currently dtype contains the charlen, which is
1462 clobbered if charlen > 2**24. That's why we use a separate
1463 argument for the charlen. However, if we want to support
1464 non-8-bit charsets we need to fix dtype to contain
1465 sizeof(chartype) and fix the code below. */
1469 case GFC_DTYPE_DERIVED:
1470 internal_error (&dtp->common,
1471 "Derived type I/O should have been handled via the frontend.");
1474 internal_error (&dtp->common, "transfer_array(): Bad type");
1477 rank = GFC_DESCRIPTOR_RANK (desc);
1478 for (n = 0; n < rank; n++)
1481 stride[n] = desc->dim[n].stride;
1482 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1484 /* If the extent of even one dimension is zero, then the entire
1485 array section contains zero elements, so we return. */
1490 stride0 = stride[0];
1492 /* If the innermost dimension has stride 1, we can do the transfer
1493 in contiguous chunks. */
1499 data = GFC_DESCRIPTOR_DATA (desc);
1503 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1504 data += stride0 * size * tsize;
1507 while (count[n] == extent[n])
1510 data -= stride[n] * extent[n] * size;
1520 data += stride[n] * size;
1527 /* Preposition a sequential unformatted file while reading. */
1530 us_read (st_parameter_dt *dtp, int continued)
1539 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1542 if (compile_options.record_marker == 0)
1543 n = sizeof (GFC_INTEGER_4);
1545 n = compile_options.record_marker;
1549 p = salloc_r (dtp->u.p.current_unit->s, &n);
1553 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1554 return; /* end of file */
1557 if (p == NULL || n != nr)
1559 generate_error (&dtp->common, ERROR_BAD_US, NULL);
1563 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1564 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1568 case sizeof(GFC_INTEGER_4):
1569 memcpy (&i4, p, sizeof (i4));
1573 case sizeof(GFC_INTEGER_8):
1574 memcpy (&i8, p, sizeof (i8));
1579 runtime_error ("Illegal value for record marker");
1586 case sizeof(GFC_INTEGER_4):
1587 reverse_memcpy (&i4, p, sizeof (i4));
1591 case sizeof(GFC_INTEGER_8):
1592 reverse_memcpy (&i8, p, sizeof (i8));
1597 runtime_error ("Illegal value for record marker");
1603 dtp->u.p.current_unit->bytes_left_subrecord = i;
1604 dtp->u.p.current_unit->continued = 0;
1608 dtp->u.p.current_unit->bytes_left_subrecord = -i;
1609 dtp->u.p.current_unit->continued = 1;
1613 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1617 /* Preposition a sequential unformatted file while writing. This
1618 amount to writing a bogus length that will be filled in later. */
1621 us_write (st_parameter_dt *dtp, int continued)
1628 if (compile_options.record_marker == 0)
1629 nbytes = sizeof (GFC_INTEGER_4);
1631 nbytes = compile_options.record_marker ;
1633 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1634 generate_error (&dtp->common, ERROR_OS, NULL);
1636 /* For sequential unformatted, if RECL= was not specified in the OPEN
1637 we write until we have more bytes than can fit in the subrecord
1638 markers, then we write a new subrecord. */
1640 dtp->u.p.current_unit->bytes_left_subrecord =
1641 dtp->u.p.current_unit->recl_subrecord;
1642 dtp->u.p.current_unit->continued = continued;
1646 /* Position to the next record prior to transfer. We are assumed to
1647 be before the next record. We also calculate the bytes in the next
1651 pre_position (st_parameter_dt *dtp)
1653 if (dtp->u.p.current_unit->current_record)
1654 return; /* Already positioned. */
1656 switch (current_mode (dtp))
1658 case FORMATTED_STREAM:
1659 case UNFORMATTED_STREAM:
1660 /* There are no records with stream I/O. Set the default position
1661 to the beginning of the file if no position was specified. */
1662 if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1663 dtp->u.p.current_unit->strm_pos = 1;
1666 case UNFORMATTED_SEQUENTIAL:
1667 if (dtp->u.p.mode == READING)
1674 case FORMATTED_SEQUENTIAL:
1675 case FORMATTED_DIRECT:
1676 case UNFORMATTED_DIRECT:
1677 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1681 dtp->u.p.current_unit->current_record = 1;
1685 /* Initialize things for a data transfer. This code is common for
1686 both reading and writing. */
1689 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1691 unit_flags u_flags; /* Used for creating a unit if needed. */
1692 GFC_INTEGER_4 cf = dtp->common.flags;
1693 namelist_info *ionml;
1695 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1696 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1697 dtp->u.p.ionml = ionml;
1698 dtp->u.p.mode = read_flag ? READING : WRITING;
1700 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1701 dtp->u.p.size_used = 0; /* Initialize the count. */
1703 dtp->u.p.current_unit = get_unit (dtp, 1);
1704 if (dtp->u.p.current_unit->s == NULL)
1705 { /* Open the unit with some default flags. */
1706 st_parameter_open opp;
1709 if (dtp->common.unit < 0)
1711 close_unit (dtp->u.p.current_unit);
1712 dtp->u.p.current_unit = NULL;
1713 generate_error (&dtp->common, ERROR_BAD_OPTION,
1714 "Bad unit number in OPEN statement");
1717 memset (&u_flags, '\0', sizeof (u_flags));
1718 u_flags.access = ACCESS_SEQUENTIAL;
1719 u_flags.action = ACTION_READWRITE;
1721 /* Is it unformatted? */
1722 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1723 | IOPARM_DT_IONML_SET)))
1724 u_flags.form = FORM_UNFORMATTED;
1726 u_flags.form = FORM_UNSPECIFIED;
1728 u_flags.delim = DELIM_UNSPECIFIED;
1729 u_flags.blank = BLANK_UNSPECIFIED;
1730 u_flags.pad = PAD_UNSPECIFIED;
1731 u_flags.status = STATUS_UNKNOWN;
1733 conv = get_unformatted_convert (dtp->common.unit);
1735 if (conv == CONVERT_NONE)
1736 conv = compile_options.convert;
1738 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1739 and 1 on big-endian machines. */
1742 case CONVERT_NATIVE:
1747 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1750 case CONVERT_LITTLE:
1751 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1755 internal_error (&opp.common, "Illegal value for CONVERT");
1759 u_flags.convert = conv;
1761 opp.common = dtp->common;
1762 opp.common.flags &= IOPARM_COMMON_MASK;
1763 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1764 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1765 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1766 if (dtp->u.p.current_unit == NULL)
1770 /* Check the action. */
1772 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1773 generate_error (&dtp->common, ERROR_BAD_ACTION,
1774 "Cannot read from file opened for WRITE");
1776 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1777 generate_error (&dtp->common, ERROR_BAD_ACTION,
1778 "Cannot write to file opened for READ");
1780 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1783 dtp->u.p.first_item = 1;
1785 /* Check the format. */
1787 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1790 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1793 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1794 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1796 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1797 "Format present for UNFORMATTED data transfer");
1799 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1801 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1802 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1803 "A format cannot be specified with a namelist");
1805 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1806 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1807 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1808 "Missing format for FORMATTED data transfer");
1810 if (is_internal_unit (dtp)
1811 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1812 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1813 "Internal file cannot be accessed by UNFORMATTED data transfer");
1815 /* Check the record or position number. */
1817 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1818 && (cf & IOPARM_DT_HAS_REC) == 0)
1820 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1821 "Direct access data transfer requires record number");
1825 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1826 && (cf & IOPARM_DT_HAS_REC) != 0)
1828 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1829 "Record number not allowed for sequential access data transfer");
1833 /* Process the ADVANCE option. */
1835 dtp->u.p.advance_status
1836 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1837 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1838 "Bad ADVANCE parameter in data transfer statement");
1840 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1842 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1843 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1844 "ADVANCE specification conflicts with sequential access");
1846 if (is_internal_unit (dtp))
1847 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1848 "ADVANCE specification conflicts with internal file");
1850 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1851 != IOPARM_DT_HAS_FORMAT)
1852 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1853 "ADVANCE specification requires an explicit format");
1858 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1859 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1860 "EOR specification requires an ADVANCE specification of NO");
1862 if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1863 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1864 "SIZE specification requires an ADVANCE specification of NO");
1868 { /* Write constraints. */
1869 if ((cf & IOPARM_END) != 0)
1870 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1871 "END specification cannot appear in a write statement");
1873 if ((cf & IOPARM_EOR) != 0)
1874 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1875 "EOR specification cannot appear in a write statement");
1877 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1878 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1879 "SIZE specification cannot appear in a write statement");
1882 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1883 dtp->u.p.advance_status = ADVANCE_YES;
1884 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1887 /* Sanity checks on the record number. */
1888 if ((cf & IOPARM_DT_HAS_REC) != 0)
1892 generate_error (&dtp->common, ERROR_BAD_OPTION,
1893 "Record number must be positive");
1897 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1899 generate_error (&dtp->common, ERROR_BAD_OPTION,
1900 "Record number too large");
1904 /* Check to see if we might be reading what we wrote before */
1906 if (dtp->u.p.mode == READING
1907 && dtp->u.p.current_unit->mode == WRITING
1908 && !is_internal_unit (dtp))
1909 flush(dtp->u.p.current_unit->s);
1911 /* Check whether the record exists to be read. Only
1912 a partial record needs to exist. */
1914 if (dtp->u.p.mode == READING && (dtp->rec -1)
1915 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1917 generate_error (&dtp->common, ERROR_BAD_OPTION,
1918 "Non-existing record number");
1922 /* Position the file. */
1923 if (!is_stream_io (dtp))
1925 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1926 * dtp->u.p.current_unit->recl) == FAILURE)
1928 generate_error (&dtp->common, ERROR_OS, NULL);
1933 dtp->u.p.current_unit->strm_pos = dtp->rec;
1937 /* Overwriting an existing sequential file ?
1938 it is always safe to truncate the file on the first write */
1939 if (dtp->u.p.mode == WRITING
1940 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1941 && dtp->u.p.current_unit->last_record == 0
1942 && !is_preconnected(dtp->u.p.current_unit->s))
1943 struncate(dtp->u.p.current_unit->s);
1945 /* Bugware for badly written mixed C-Fortran I/O. */
1946 flush_if_preconnected(dtp->u.p.current_unit->s);
1948 dtp->u.p.current_unit->mode = dtp->u.p.mode;
1950 /* Set the initial value of flags. */
1952 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1953 dtp->u.p.sign_status = SIGN_S;
1955 /* Set the maximum position reached from the previous I/O operation. This
1956 could be greater than zero from a previous non-advancing write. */
1957 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
1961 /* Set up the subroutine that will handle the transfers. */
1965 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1966 dtp->u.p.transfer = unformatted_read;
1969 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1970 dtp->u.p.transfer = list_formatted_read;
1972 dtp->u.p.transfer = formatted_transfer;
1977 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1978 dtp->u.p.transfer = unformatted_write;
1981 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1982 dtp->u.p.transfer = list_formatted_write;
1984 dtp->u.p.transfer = formatted_transfer;
1988 /* Make sure that we don't do a read after a nonadvancing write. */
1992 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1994 generate_error (&dtp->common, ERROR_BAD_OPTION,
1995 "Cannot READ after a nonadvancing WRITE");
2001 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2002 dtp->u.p.current_unit->read_bad = 1;
2005 /* Start the data transfer if we are doing a formatted transfer. */
2006 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2007 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
2008 && dtp->u.p.ionml == NULL)
2009 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2012 /* Initialize an array_loop_spec given the array descriptor. The function
2013 returns the index of the last element of the array. */
2016 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
2018 int rank = GFC_DESCRIPTOR_RANK(desc);
2023 for (i=0; i<rank; i++)
2025 ls[i].idx = desc->dim[i].lbound;
2026 ls[i].start = desc->dim[i].lbound;
2027 ls[i].end = desc->dim[i].ubound;
2028 ls[i].step = desc->dim[i].stride;
2030 index += (desc->dim[i].ubound - desc->dim[i].lbound)
2031 * desc->dim[i].stride;
2036 /* Determine the index to the next record in an internal unit array by
2037 by incrementing through the array_loop_spec. TODO: Implement handling
2038 negative strides. */
2041 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
2049 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2054 if (ls[i].idx > ls[i].end)
2056 ls[i].idx = ls[i].start;
2062 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2070 /* Skip to the end of the current record, taking care of an optional
2071 record marker of size bytes. If the file is not seekable, we
2072 read chunks of size MAX_READ until we get to the right
2075 #define MAX_READ 4096
2078 skip_record (st_parameter_dt *dtp, size_t bytes)
2081 int rlength, length;
2084 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2085 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2088 if (is_seekable (dtp->u.p.current_unit->s))
2090 new = file_position (dtp->u.p.current_unit->s)
2091 + dtp->u.p.current_unit->bytes_left_subrecord;
2093 /* Direct access files do not generate END conditions,
2095 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2096 generate_error (&dtp->common, ERROR_OS, NULL);
2099 { /* Seek by reading data. */
2100 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2103 (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
2104 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2106 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
2109 generate_error (&dtp->common, ERROR_OS, NULL);
2113 dtp->u.p.current_unit->bytes_left_subrecord -= length;
2121 /* Advance to the next record reading unformatted files, taking
2122 care of subrecords. If complete_record is nonzero, we loop
2123 until all subrecords are cleared. */
2126 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2130 bytes = compile_options.record_marker == 0 ?
2131 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2136 /* Skip over tail */
2138 skip_record (dtp, bytes);
2140 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2147 /* Space to the next record for read mode. */
2150 next_record_r (st_parameter_dt *dtp)
2153 int length, bytes_left;
2156 switch (current_mode (dtp))
2158 /* No records in unformatted STREAM I/O. */
2159 case UNFORMATTED_STREAM:
2162 case UNFORMATTED_SEQUENTIAL:
2163 next_record_r_unf (dtp, 1);
2164 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2167 case FORMATTED_DIRECT:
2168 case UNFORMATTED_DIRECT:
2169 skip_record (dtp, 0);
2172 case FORMATTED_STREAM:
2173 case FORMATTED_SEQUENTIAL:
2175 /* sf_read has already terminated input because of an '\n' */
2176 if (dtp->u.p.sf_seen_eor)
2178 dtp->u.p.sf_seen_eor = 0;
2182 if (is_internal_unit (dtp))
2184 if (is_array_io (dtp))
2186 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2188 /* Now seek to this record. */
2189 record = record * dtp->u.p.current_unit->recl;
2190 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2192 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2195 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2199 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2200 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2202 dtp->u.p.current_unit->bytes_left
2203 = dtp->u.p.current_unit->recl;
2209 p = salloc_r (dtp->u.p.current_unit->s, &length);
2213 generate_error (&dtp->common, ERROR_OS, NULL);
2219 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2223 if (is_stream_io (dtp))
2224 dtp->u.p.current_unit->strm_pos++;
2231 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2232 test_endfile (dtp->u.p.current_unit);
2236 /* Small utility function to write a record marker, taking care of
2237 byte swapping and of choosing the correct size. */
2240 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2245 char p[sizeof (GFC_INTEGER_8)];
2247 if (compile_options.record_marker == 0)
2248 len = sizeof (GFC_INTEGER_4);
2250 len = compile_options.record_marker;
2252 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2253 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2257 case sizeof (GFC_INTEGER_4):
2259 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2262 case sizeof (GFC_INTEGER_8):
2264 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2268 runtime_error ("Illegal value for record marker");
2276 case sizeof (GFC_INTEGER_4):
2278 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2279 return swrite (dtp->u.p.current_unit->s, p, &len);
2282 case sizeof (GFC_INTEGER_8):
2284 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2285 return swrite (dtp->u.p.current_unit->s, p, &len);
2289 runtime_error ("Illegal value for record marker");
2296 /* Position to the next (sub)record in write mode for
2297 unformatted sequential files. */
2300 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2302 gfc_offset c, m, m_write;
2303 size_t record_marker;
2305 /* Bytes written. */
2306 m = dtp->u.p.current_unit->recl_subrecord
2307 - dtp->u.p.current_unit->bytes_left_subrecord;
2308 c = file_position (dtp->u.p.current_unit->s);
2310 /* Write the length tail. If we finish a record containing
2311 subrecords, we write out the negative length. */
2313 if (dtp->u.p.current_unit->continued)
2318 if (write_us_marker (dtp, m_write) != 0)
2321 if (compile_options.record_marker == 0)
2322 record_marker = sizeof (GFC_INTEGER_4);
2324 record_marker = compile_options.record_marker;
2326 /* Seek to the head and overwrite the bogus length with the real
2329 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2338 if (write_us_marker (dtp, m_write) != 0)
2341 /* Seek past the end of the current record. */
2343 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2349 generate_error (&dtp->common, ERROR_OS, NULL);
2354 /* Position to the next record in write mode. */
2357 next_record_w (st_parameter_dt *dtp, int done)
2359 gfc_offset m, record, max_pos;
2363 /* Zero counters for X- and T-editing. */
2364 max_pos = dtp->u.p.max_pos;
2365 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2367 switch (current_mode (dtp))
2369 /* No records in unformatted STREAM I/O. */
2370 case UNFORMATTED_STREAM:
2373 case FORMATTED_DIRECT:
2374 if (dtp->u.p.current_unit->bytes_left == 0)
2377 if (sset (dtp->u.p.current_unit->s, ' ',
2378 dtp->u.p.current_unit->bytes_left) == FAILURE)
2383 case UNFORMATTED_DIRECT:
2384 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2388 case UNFORMATTED_SEQUENTIAL:
2389 next_record_w_unf (dtp, 0);
2390 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2393 case FORMATTED_STREAM:
2394 case FORMATTED_SEQUENTIAL:
2396 if (is_internal_unit (dtp))
2398 if (is_array_io (dtp))
2400 length = (int) dtp->u.p.current_unit->bytes_left;
2402 /* If the farthest position reached is greater than current
2403 position, adjust the position and set length to pad out
2404 whats left. Otherwise just pad whats left.
2405 (for character array unit) */
2406 m = dtp->u.p.current_unit->recl
2407 - dtp->u.p.current_unit->bytes_left;
2410 length = (int) (max_pos - m);
2411 p = salloc_w (dtp->u.p.current_unit->s, &length);
2412 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2415 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2417 generate_error (&dtp->common, ERROR_END, NULL);
2421 /* Now that the current record has been padded out,
2422 determine where the next record in the array is. */
2423 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2425 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2427 /* Now seek to this record */
2428 record = record * dtp->u.p.current_unit->recl;
2430 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2432 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2436 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2442 /* If this is the last call to next_record move to the farthest
2443 position reached and set length to pad out the remainder
2444 of the record. (for character scaler unit) */
2447 m = dtp->u.p.current_unit->recl
2448 - dtp->u.p.current_unit->bytes_left;
2451 length = (int) (max_pos - m);
2452 p = salloc_w (dtp->u.p.current_unit->s, &length);
2453 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2456 length = (int) dtp->u.p.current_unit->bytes_left;
2459 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2461 generate_error (&dtp->common, ERROR_END, NULL);
2468 /* If this is the last call to next_record move to the farthest
2469 position reached in preparation for completing the record.
2473 m = dtp->u.p.current_unit->recl -
2474 dtp->u.p.current_unit->bytes_left;
2477 length = (int) (max_pos - m);
2478 p = salloc_w (dtp->u.p.current_unit->s, &length);
2482 const char crlf[] = "\r\n";
2488 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2491 if (is_stream_io (dtp))
2492 dtp->u.p.current_unit->strm_pos += len;
2498 generate_error (&dtp->common, ERROR_OS, NULL);
2503 /* Position to the next record, which means moving to the end of the
2504 current record. This can happen under several different
2505 conditions. If the done flag is not set, we get ready to process
2509 next_record (st_parameter_dt *dtp, int done)
2511 gfc_offset fp; /* File position. */
2513 dtp->u.p.current_unit->read_bad = 0;
2515 if (dtp->u.p.mode == READING)
2516 next_record_r (dtp);
2518 next_record_w (dtp, done);
2520 if (!is_stream_io (dtp))
2522 /* keep position up to date for INQUIRE */
2523 dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2524 dtp->u.p.current_unit->current_record = 0;
2525 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2527 fp = file_position (dtp->u.p.current_unit->s);
2528 /* Calculate next record, rounding up partial records. */
2529 dtp->u.p.current_unit->last_record =
2530 (fp + dtp->u.p.current_unit->recl - 1) /
2531 dtp->u.p.current_unit->recl;
2534 dtp->u.p.current_unit->last_record++;
2542 /* Finalize the current data transfer. For a nonadvancing transfer,
2543 this means advancing to the next record. For internal units close the
2544 stream associated with the unit. */
2547 finalize_transfer (st_parameter_dt *dtp)
2550 GFC_INTEGER_4 cf = dtp->common.flags;
2552 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2553 *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
2555 if (dtp->u.p.eor_condition)
2557 generate_error (&dtp->common, ERROR_EOR, NULL);
2561 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2564 if ((dtp->u.p.ionml != NULL)
2565 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2567 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2568 namelist_read (dtp);
2570 namelist_write (dtp);
2573 dtp->u.p.transfer = NULL;
2574 if (dtp->u.p.current_unit == NULL)
2577 dtp->u.p.eof_jump = &eof_jump;
2578 if (setjmp (eof_jump))
2580 generate_error (&dtp->common, ERROR_END, NULL);
2584 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2586 finish_list_read (dtp);
2587 sfree (dtp->u.p.current_unit->s);
2591 if (is_stream_io (dtp))
2593 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2594 next_record (dtp, 1);
2595 flush (dtp->u.p.current_unit->s);
2596 sfree (dtp->u.p.current_unit->s);
2600 dtp->u.p.current_unit->current_record = 0;
2602 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2604 dtp->u.p.seen_dollar = 0;
2605 sfree (dtp->u.p.current_unit->s);
2609 /* For non-advancing I/O, save the current maximum position for use in the
2610 next I/O operation if needed. */
2611 if (dtp->u.p.advance_status == ADVANCE_NO)
2613 int bytes_written = (int) (dtp->u.p.current_unit->recl
2614 - dtp->u.p.current_unit->bytes_left);
2615 dtp->u.p.current_unit->saved_pos =
2616 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
2617 flush (dtp->u.p.current_unit->s);
2621 dtp->u.p.current_unit->saved_pos = 0;
2623 next_record (dtp, 1);
2624 sfree (dtp->u.p.current_unit->s);
2627 /* Transfer function for IOLENGTH. It doesn't actually do any
2628 data transfer, it just updates the length counter. */
2631 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2632 void *dest __attribute__ ((unused)),
2633 int kind __attribute__((unused)),
2634 size_t size, size_t nelems)
2636 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2637 *dtp->iolength += (GFC_IO_INT) size * nelems;
2641 /* Initialize the IOLENGTH data transfer. This function is in essence
2642 a very much simplified version of data_transfer_init(), because it
2643 doesn't have to deal with units at all. */
2646 iolength_transfer_init (st_parameter_dt *dtp)
2648 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2651 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2653 /* Set up the subroutine that will handle the transfers. */
2655 dtp->u.p.transfer = iolength_transfer;
2659 /* Library entry point for the IOLENGTH form of the INQUIRE
2660 statement. The IOLENGTH form requires no I/O to be performed, but
2661 it must still be a runtime library call so that we can determine
2662 the iolength for dynamic arrays and such. */
2664 extern void st_iolength (st_parameter_dt *);
2665 export_proto(st_iolength);
2668 st_iolength (st_parameter_dt *dtp)
2670 library_start (&dtp->common);
2671 iolength_transfer_init (dtp);
2674 extern void st_iolength_done (st_parameter_dt *);
2675 export_proto(st_iolength_done);
2678 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2681 if (dtp->u.p.scratch != NULL)
2682 free_mem (dtp->u.p.scratch);
2687 /* The READ statement. */
2689 extern void st_read (st_parameter_dt *);
2690 export_proto(st_read);
2693 st_read (st_parameter_dt *dtp)
2695 library_start (&dtp->common);
2697 data_transfer_init (dtp, 1);
2699 /* Handle complications dealing with the endfile record. */
2701 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2702 switch (dtp->u.p.current_unit->endfile)
2708 if (!is_internal_unit (dtp))
2710 generate_error (&dtp->common, ERROR_END, NULL);
2711 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2712 dtp->u.p.current_unit->current_record = 0;
2717 generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2718 dtp->u.p.current_unit->current_record = 0;
2723 extern void st_read_done (st_parameter_dt *);
2724 export_proto(st_read_done);
2727 st_read_done (st_parameter_dt *dtp)
2729 finalize_transfer (dtp);
2730 free_format_data (dtp);
2732 if (dtp->u.p.scratch != NULL)
2733 free_mem (dtp->u.p.scratch);
2734 if (dtp->u.p.current_unit != NULL)
2735 unlock_unit (dtp->u.p.current_unit);
2737 free_internal_unit (dtp);
2742 extern void st_write (st_parameter_dt *);
2743 export_proto(st_write);
2746 st_write (st_parameter_dt *dtp)
2748 library_start (&dtp->common);
2749 data_transfer_init (dtp, 0);
2752 extern void st_write_done (st_parameter_dt *);
2753 export_proto(st_write_done);
2756 st_write_done (st_parameter_dt *dtp)
2758 finalize_transfer (dtp);
2760 /* Deal with endfile conditions associated with sequential files. */
2762 if (dtp->u.p.current_unit != NULL
2763 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2764 switch (dtp->u.p.current_unit->endfile)
2766 case AT_ENDFILE: /* Remain at the endfile record. */
2770 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2774 /* Get rid of whatever is after this record. */
2775 if (!is_internal_unit (dtp))
2777 flush (dtp->u.p.current_unit->s);
2778 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2779 generate_error (&dtp->common, ERROR_OS, NULL);
2781 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2785 free_format_data (dtp);
2787 if (dtp->u.p.scratch != NULL)
2788 free_mem (dtp->u.p.scratch);
2789 if (dtp->u.p.current_unit != NULL)
2790 unlock_unit (dtp->u.p.current_unit);
2792 free_internal_unit (dtp);
2797 /* Receives the scalar information for namelist objects and stores it
2798 in a linked list of namelist_info types. */
2800 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2801 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2802 export_proto(st_set_nml_var);
2806 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2807 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2808 GFC_INTEGER_4 dtype)
2810 namelist_info *t1 = NULL;
2813 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2815 nml->mem_pos = var_addr;
2817 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2818 strcpy (nml->var_name, var_name);
2820 nml->len = (int) len;
2821 nml->string_length = (index_type) string_length;
2823 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2824 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2825 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2827 if (nml->var_rank > 0)
2829 nml->dim = (descriptor_dimension*)
2830 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2831 nml->ls = (array_loop_spec*)
2832 get_mem (nml->var_rank * sizeof (array_loop_spec));
2842 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2844 dtp->common.flags |= IOPARM_DT_IONML_SET;
2845 dtp->u.p.ionml = nml;
2849 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2854 /* Store the dimensional information for the namelist object. */
2855 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2856 GFC_INTEGER_4, GFC_INTEGER_4,
2858 export_proto(st_set_nml_var_dim);
2861 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2862 GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2863 GFC_INTEGER_4 ubound)
2865 namelist_info * nml;
2870 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2872 nml->dim[n].stride = (ssize_t)stride;
2873 nml->dim[n].lbound = (ssize_t)lbound;
2874 nml->dim[n].ubound = (ssize_t)ubound;
2877 /* Reverse memcpy - used for byte swapping. */
2879 void reverse_memcpy (void *dest, const void *src, size_t n)
2885 s = (char *) src + n - 1;
2887 /* Write with ascending order - this is likely faster
2888 on modern architectures because of write combining. */