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. */
40 /* Calling conventions: Data transfer statements are unlike other
41 library calls in that they extend over several calls.
43 The first call is always a call to st_read() or st_write(). These
44 subroutines return no status unless a namelist read or write is
45 being done, in which case there is the usual status. No further
46 calls are necessary in this case.
48 For other sorts of data transfer, there are zero or more data
49 transfer statement that depend on the format of the data transfer
58 These subroutines do not return status.
60 The last call is a call to st_[read|write]_done(). While
61 something can easily go wrong with the initial st_read() or
62 st_write(), an error inhibits any data from actually being
65 extern void transfer_integer (st_parameter_dt *, void *, int);
66 export_proto(transfer_integer);
68 extern void transfer_real (st_parameter_dt *, void *, int);
69 export_proto(transfer_real);
71 extern void transfer_logical (st_parameter_dt *, void *, int);
72 export_proto(transfer_logical);
74 extern void transfer_character (st_parameter_dt *, void *, int);
75 export_proto(transfer_character);
77 extern void transfer_complex (st_parameter_dt *, void *, int);
78 export_proto(transfer_complex);
80 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
82 export_proto(transfer_array);
84 static void us_read (st_parameter_dt *, int);
85 static void us_write (st_parameter_dt *, int);
86 static void next_record_r_unf (st_parameter_dt *, int);
87 static void next_record_w_unf (st_parameter_dt *, int);
89 static const st_option advance_opt[] = {
97 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
98 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
104 current_mode (st_parameter_dt *dtp)
108 m = FORM_UNSPECIFIED;
110 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
112 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
113 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
115 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
117 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
118 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
120 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
122 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
123 FORMATTED_STREAM : UNFORMATTED_STREAM;
130 /* Mid level data transfer statements. These subroutines do reading
131 and writing in the style of salloc_r()/salloc_w() within the
134 /* When reading sequential formatted records we have a problem. We
135 don't know how long the line is until we read the trailing newline,
136 and we don't want to read too much. If we read too much, we might
137 have to do a physical seek backwards depending on how much data is
138 present, and devices like terminals aren't seekable and would cause
141 Given this, the solution is to read a byte at a time, stopping if
142 we hit the newline. For small allocations, we use a static buffer.
143 For larger allocations, we are forced to allocate memory on the
144 heap. Hopefully this won't happen very often. */
147 read_sf (st_parameter_dt *dtp, int *length, int no_error)
150 int n, readlen, crlf;
153 if (*length > SCRATCH_SIZE)
154 dtp->u.p.line_buffer = get_mem (*length);
155 p = base = dtp->u.p.line_buffer;
157 /* If we have seen an eor previously, return a length of 0. The
158 caller is responsible for correctly padding the input field. */
159 if (dtp->u.p.sf_seen_eor)
165 if (is_internal_unit (dtp))
168 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
169 if (readlen < *length)
171 generate_error (&dtp->common, LIBERROR_END, NULL);
176 memcpy (p, q, readlen);
185 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
189 /* If we have a line without a terminating \n, drop through to
191 if (readlen < 1 && n == 0)
195 generate_error (&dtp->common, LIBERROR_END, NULL);
199 if (readlen < 1 || *q == '\n' || *q == '\r')
201 /* Unexpected end of line. */
203 /* If we see an EOR during non-advancing I/O, we need to skip
204 the rest of the I/O statement. Set the corresponding flag. */
205 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
206 dtp->u.p.eor_condition = 1;
209 /* If we encounter a CR, it might be a CRLF. */
210 if (*q == '\r') /* Probably a CRLF */
213 pos = stream_offset (dtp->u.p.current_unit->s);
214 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
215 if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */
216 sseek (dtp->u.p.current_unit->s, pos);
221 /* Without padding, terminate the I/O statement without assigning
222 the value. With padding, the value still needs to be assigned,
223 so we can just continue with a short read. */
224 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
228 generate_error (&dtp->common, LIBERROR_EOR, NULL);
233 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
236 /* Short circuit the read if a comma is found during numeric input.
237 The flag is set to zero during character reads so that commas in
238 strings are not ignored */
240 if (dtp->u.p.sf_read_comma == 1)
242 notify_std (&dtp->common, GFC_STD_GNU,
243 "Comma in formatted numeric read.");
250 dtp->u.p.sf_seen_eor = 0;
255 dtp->u.p.current_unit->bytes_left -= *length;
257 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
258 dtp->u.p.size_used += (gfc_offset) *length;
264 /* Function for reading the next couple of bytes from the current
265 file, advancing the current position. We return a pointer to a
266 buffer containing the bytes. We return NULL on end of record or
269 If the read is short, then it is because the current record does not
270 have enough data to satisfy the read request and the file was
271 opened with PAD=YES. The caller must assume tailing spaces for
275 read_block (st_parameter_dt *dtp, int *length)
280 if (is_stream_io (dtp))
282 if (dtp->u.p.current_unit->strm_pos - 1
283 != file_position (dtp->u.p.current_unit->s)
284 && sseek (dtp->u.p.current_unit->s,
285 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
287 generate_error (&dtp->common, LIBERROR_END, NULL);
293 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
295 /* For preconnected units with default record length, set bytes left
296 to unit record length and proceed, otherwise error. */
297 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
298 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
299 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
302 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
304 /* Not enough data left. */
305 generate_error (&dtp->common, LIBERROR_EOR, NULL);
310 if (dtp->u.p.current_unit->bytes_left == 0)
312 dtp->u.p.current_unit->endfile = AT_ENDFILE;
313 generate_error (&dtp->common, LIBERROR_END, NULL);
317 *length = dtp->u.p.current_unit->bytes_left;
321 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
322 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
323 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
325 source = read_sf (dtp, length, 0);
326 dtp->u.p.current_unit->strm_pos +=
327 (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
330 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
333 source = salloc_r (dtp->u.p.current_unit->s, &nread);
335 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
336 dtp->u.p.size_used += (gfc_offset) nread;
338 if (nread != *length)
339 { /* Short read, this shouldn't happen. */
340 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
344 generate_error (&dtp->common, LIBERROR_EOR, NULL);
349 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
355 /* Reads a block directly into application data space. This is for
356 unformatted files. */
359 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
361 size_t to_read_record;
362 size_t have_read_record;
363 size_t to_read_subrecord;
364 size_t have_read_subrecord;
367 if (is_stream_io (dtp))
369 if (dtp->u.p.current_unit->strm_pos - 1
370 != file_position (dtp->u.p.current_unit->s)
371 && sseek (dtp->u.p.current_unit->s,
372 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
374 generate_error (&dtp->common, LIBERROR_END, NULL);
378 to_read_record = *nbytes;
379 have_read_record = to_read_record;
380 if (sread (dtp->u.p.current_unit->s, buf, &have_read_record) != 0)
382 generate_error (&dtp->common, LIBERROR_OS, NULL);
386 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
388 if (to_read_record != have_read_record)
390 /* Short read, e.g. if we hit EOF. For stream files,
391 we have to set the end-of-file condition. */
392 generate_error (&dtp->common, LIBERROR_END, NULL);
398 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
400 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
403 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
404 *nbytes = to_read_record;
410 to_read_record = *nbytes;
413 dtp->u.p.current_unit->bytes_left -= to_read_record;
415 if (sread (dtp->u.p.current_unit->s, buf, &to_read_record) != 0)
417 generate_error (&dtp->common, LIBERROR_OS, NULL);
421 if (to_read_record != *nbytes)
423 /* Short read, e.g. if we hit EOF. Apparently, we read
424 more than was written to the last record. */
425 *nbytes = to_read_record;
431 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
437 /* Unformatted sequential. We loop over the subrecords, reading
438 until the request has been fulfilled or the record has run out
439 of continuation subrecords. */
441 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
443 generate_error (&dtp->common, LIBERROR_END, NULL);
447 /* Check whether we exceed the total record length. */
449 if (dtp->u.p.current_unit->flags.has_recl
450 && (*nbytes > (size_t) dtp->u.p.current_unit->bytes_left))
452 to_read_record = (size_t) dtp->u.p.current_unit->bytes_left;
457 to_read_record = *nbytes;
460 have_read_record = 0;
464 if (dtp->u.p.current_unit->bytes_left_subrecord
465 < (gfc_offset) to_read_record)
467 to_read_subrecord = (size_t) dtp->u.p.current_unit->bytes_left_subrecord;
468 to_read_record -= to_read_subrecord;
472 to_read_subrecord = to_read_record;
476 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
478 have_read_subrecord = to_read_subrecord;
479 if (sread (dtp->u.p.current_unit->s, buf + have_read_record,
480 &have_read_subrecord) != 0)
482 generate_error (&dtp->common, LIBERROR_OS, NULL);
486 have_read_record += have_read_subrecord;
488 if (to_read_subrecord != have_read_subrecord)
491 /* Short read, e.g. if we hit EOF. This means the record
492 structure has been corrupted, or the trailing record
493 marker would still be present. */
495 *nbytes = have_read_record;
496 generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
500 if (to_read_record > 0)
502 if (dtp->u.p.current_unit->continued)
504 next_record_r_unf (dtp, 0);
509 /* Let's make sure the file position is correctly pre-positioned
510 for the next read statement. */
512 dtp->u.p.current_unit->current_record = 0;
513 next_record_r_unf (dtp, 0);
514 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
520 /* Normal exit, the read request has been fulfilled. */
525 dtp->u.p.current_unit->bytes_left -= have_read_record;
528 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
535 /* Function for writing a block of bytes to the current file at the
536 current position, advancing the file pointer. We are given a length
537 and return a pointer to a buffer that the caller must (completely)
538 fill in. Returns NULL on error. */
541 write_block (st_parameter_dt *dtp, int length)
545 if (is_stream_io (dtp))
547 if (dtp->u.p.current_unit->strm_pos - 1
548 != file_position (dtp->u.p.current_unit->s)
549 && sseek (dtp->u.p.current_unit->s,
550 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
552 generate_error (&dtp->common, LIBERROR_OS, NULL);
558 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
560 /* For preconnected units with default record length, set bytes left
561 to unit record length and proceed, otherwise error. */
562 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
563 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
564 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
565 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
568 generate_error (&dtp->common, LIBERROR_EOR, NULL);
573 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
576 dest = salloc_w (dtp->u.p.current_unit->s, &length);
580 generate_error (&dtp->common, LIBERROR_END, NULL);
584 if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
585 generate_error (&dtp->common, LIBERROR_END, NULL);
587 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
588 dtp->u.p.size_used += (gfc_offset) length;
590 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
596 /* High level interface to swrite(), taking care of errors. This is only
597 called for unformatted files. There are three cases to consider:
598 Stream I/O, unformatted direct, unformatted sequential. */
601 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
604 size_t have_written, to_write_subrecord;
609 if (is_stream_io (dtp))
611 if (dtp->u.p.current_unit->strm_pos - 1
612 != file_position (dtp->u.p.current_unit->s)
613 && sseek (dtp->u.p.current_unit->s,
614 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
616 generate_error (&dtp->common, LIBERROR_OS, NULL);
620 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
622 generate_error (&dtp->common, LIBERROR_OS, NULL);
626 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
631 /* Unformatted direct access. */
633 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
635 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
637 generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
641 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
643 generate_error (&dtp->common, LIBERROR_OS, NULL);
647 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
648 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
654 /* Unformatted sequential. */
658 if (dtp->u.p.current_unit->flags.has_recl
659 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
661 nbytes = dtp->u.p.current_unit->bytes_left;
673 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
674 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
676 dtp->u.p.current_unit->bytes_left_subrecord -=
677 (gfc_offset) to_write_subrecord;
679 if (swrite (dtp->u.p.current_unit->s, buf + have_written,
680 &to_write_subrecord) != 0)
682 generate_error (&dtp->common, LIBERROR_OS, NULL);
686 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
687 nbytes -= to_write_subrecord;
688 have_written += to_write_subrecord;
693 next_record_w_unf (dtp, 1);
696 dtp->u.p.current_unit->bytes_left -= have_written;
699 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
706 /* Master function for unformatted reads. */
709 unformatted_read (st_parameter_dt *dtp, bt type,
710 void *dest, int kind __attribute__((unused)),
711 size_t size, size_t nelems)
715 /* Currently, character implies size=1. */
716 if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE
717 || size == 1 || type == BT_CHARACTER)
720 read_block_direct (dtp, dest, &sz);
727 /* Break up complex into its constituent reals. */
728 if (type == BT_COMPLEX)
735 /* By now, all complex variables have been split into their
736 constituent reals. */
738 for (i=0; i<nelems; i++)
740 read_block_direct (dtp, buffer, &size);
741 reverse_memcpy (p, buffer, size);
748 /* Master function for unformatted writes. NOTE: For kind=10 the size is 16
749 bytes on 64 bit machines. The unused bytes are not initialized and never
750 used, which can show an error with memory checking analyzers like
754 unformatted_write (st_parameter_dt *dtp, bt type,
755 void *source, int kind __attribute__((unused)),
756 size_t size, size_t nelems)
758 if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE ||
759 size == 1 || type == BT_CHARACTER)
762 write_buf (dtp, source, size);
770 /* Break up complex into its constituent reals. */
771 if (type == BT_COMPLEX)
779 /* By now, all complex variables have been split into their
780 constituent reals. */
783 for (i=0; i<nelems; i++)
785 reverse_memcpy(buffer, p, size);
787 write_buf (dtp, buffer, size);
793 /* Return a pointer to the name of a type. */
818 internal_error (NULL, "type_name(): Bad type");
825 /* Write a constant string to the output.
826 This is complicated because the string can have doubled delimiters
827 in it. The length in the format node is the true length. */
830 write_constant_string (st_parameter_dt *dtp, const fnode *f)
832 char c, delimiter, *p, *q;
835 length = f->u.string.length;
839 p = write_block (dtp, length);
846 for (; length > 0; length--)
849 if (c == delimiter && c != 'H' && c != 'h')
850 q++; /* Skip the doubled delimiter. */
855 /* Given actual and expected types in a formatted data transfer, make
856 sure they agree. If not, an error message is generated. Returns
857 nonzero if something went wrong. */
860 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
864 if (actual == expected)
867 sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
868 type_name (expected), dtp->u.p.item_count, type_name (actual));
870 format_error (dtp, f, buffer);
875 /* This subroutine is the main loop for a formatted data transfer
876 statement. It would be natural to implement this as a coroutine
877 with the user program, but C makes that awkward. We loop,
878 processing format elements. When we actually have to transfer
879 data instead of just setting flags, we return control to the user
880 program which calls a subroutine that supplies the address and type
881 of the next element, then comes back here to process it. */
884 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
887 char scratch[SCRATCH_SIZE];
892 int consume_data_flag;
894 /* Change a complex data item into a pair of reals. */
896 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
897 if (type == BT_COMPLEX)
903 /* If there's an EOR condition, we simulate finalizing the transfer
905 if (dtp->u.p.eor_condition)
908 /* Set this flag so that commas in reads cause the read to complete before
909 the entire field has been read. The next read field will start right after
910 the comma in the stream. (Set to 0 for character reads). */
911 dtp->u.p.sf_read_comma = 1;
913 dtp->u.p.line_buffer = scratch;
916 /* If reversion has occurred and there is another real data item,
917 then we have to move to the next record. */
918 if (dtp->u.p.reversion_flag && n > 0)
920 dtp->u.p.reversion_flag = 0;
921 next_record (dtp, 0);
924 consume_data_flag = 1 ;
925 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
928 f = next_format (dtp);
931 /* No data descriptors left. */
933 generate_error (&dtp->common, LIBERROR_FORMAT,
934 "Insufficient data descriptors in format after reversion");
938 /* Now discharge T, TR and X movements to the right. This is delayed
939 until a data producing format to suppress trailing spaces. */
942 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
943 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
944 || t == FMT_Z || t == FMT_F || t == FMT_E
945 || t == FMT_EN || t == FMT_ES || t == FMT_G
946 || t == FMT_L || t == FMT_A || t == FMT_D))
949 if (dtp->u.p.skips > 0)
952 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
953 tmp = (int)(dtp->u.p.current_unit->recl
954 - dtp->u.p.current_unit->bytes_left);
956 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
958 if (dtp->u.p.skips < 0)
960 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
961 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
963 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
966 bytes_used = (int)(dtp->u.p.current_unit->recl
967 - dtp->u.p.current_unit->bytes_left);
969 if (is_stream_io(dtp))
977 if (require_type (dtp, BT_INTEGER, type, f))
980 if (dtp->u.p.mode == READING)
981 read_decimal (dtp, f, p, len);
983 write_i (dtp, f, p, len);
991 if (compile_options.allow_std < GFC_STD_GNU
992 && require_type (dtp, BT_INTEGER, type, f))
995 if (dtp->u.p.mode == READING)
996 read_radix (dtp, f, p, len, 2);
998 write_b (dtp, f, p, len);
1006 if (compile_options.allow_std < GFC_STD_GNU
1007 && require_type (dtp, BT_INTEGER, type, f))
1010 if (dtp->u.p.mode == READING)
1011 read_radix (dtp, f, p, len, 8);
1013 write_o (dtp, f, p, len);
1021 if (compile_options.allow_std < GFC_STD_GNU
1022 && require_type (dtp, BT_INTEGER, type, f))
1025 if (dtp->u.p.mode == READING)
1026 read_radix (dtp, f, p, len, 16);
1028 write_z (dtp, f, p, len);
1036 if (dtp->u.p.mode == READING)
1037 read_a (dtp, f, p, len);
1039 write_a (dtp, f, p, len);
1047 if (dtp->u.p.mode == READING)
1048 read_l (dtp, f, p, len);
1050 write_l (dtp, f, p, len);
1057 if (require_type (dtp, BT_REAL, type, f))
1060 if (dtp->u.p.mode == READING)
1061 read_f (dtp, f, p, len);
1063 write_d (dtp, f, p, len);
1070 if (require_type (dtp, BT_REAL, type, f))
1073 if (dtp->u.p.mode == READING)
1074 read_f (dtp, f, p, len);
1076 write_e (dtp, f, p, len);
1082 if (require_type (dtp, BT_REAL, type, f))
1085 if (dtp->u.p.mode == READING)
1086 read_f (dtp, f, p, len);
1088 write_en (dtp, f, p, len);
1095 if (require_type (dtp, BT_REAL, type, f))
1098 if (dtp->u.p.mode == READING)
1099 read_f (dtp, f, p, len);
1101 write_es (dtp, f, p, len);
1108 if (require_type (dtp, BT_REAL, type, f))
1111 if (dtp->u.p.mode == READING)
1112 read_f (dtp, f, p, len);
1114 write_f (dtp, f, p, len);
1121 if (dtp->u.p.mode == READING)
1125 read_decimal (dtp, f, p, len);
1128 read_l (dtp, f, p, len);
1131 read_a (dtp, f, p, len);
1134 read_f (dtp, f, p, len);
1143 write_i (dtp, f, p, len);
1146 write_l (dtp, f, p, len);
1149 write_a (dtp, f, p, len);
1152 write_d (dtp, f, p, len);
1156 internal_error (&dtp->common,
1157 "formatted_transfer(): Bad type");
1163 consume_data_flag = 0 ;
1164 if (dtp->u.p.mode == READING)
1166 format_error (dtp, f, "Constant string in input format");
1169 write_constant_string (dtp, f);
1172 /* Format codes that don't transfer data. */
1175 consume_data_flag = 0;
1177 dtp->u.p.skips += f->u.n;
1178 pos = bytes_used + dtp->u.p.skips - 1;
1179 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1181 /* Writes occur just before the switch on f->format, above, so
1182 that trailing blanks are suppressed, unless we are doing a
1183 non-advancing write in which case we want to output the blanks
1185 if (dtp->u.p.mode == WRITING
1186 && dtp->u.p.advance_status == ADVANCE_NO)
1188 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1189 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1192 if (dtp->u.p.mode == READING)
1193 read_x (dtp, f->u.n);
1199 consume_data_flag = 0;
1201 if (f->format == FMT_TL)
1204 /* Handle the special case when no bytes have been used yet.
1205 Cannot go below zero. */
1206 if (bytes_used == 0)
1208 dtp->u.p.pending_spaces -= f->u.n;
1209 dtp->u.p.skips -= f->u.n;
1210 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1213 pos = bytes_used - f->u.n;
1217 if (dtp->u.p.mode == READING)
1220 pos = f->u.n - dtp->u.p.pending_spaces - 1;
1223 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1224 left tab limit. We do not check if the position has gone
1225 beyond the end of record because a subsequent tab could
1226 bring us back again. */
1227 pos = pos < 0 ? 0 : pos;
1229 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1230 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1231 + pos - dtp->u.p.max_pos;
1232 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1233 ? 0 : dtp->u.p.pending_spaces;
1235 if (dtp->u.p.skips == 0)
1238 /* Writes occur just before the switch on f->format, above, so that
1239 trailing blanks are suppressed. */
1240 if (dtp->u.p.mode == READING)
1242 /* Adjust everything for end-of-record condition */
1243 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1245 if (dtp->u.p.sf_seen_eor == 2)
1247 /* The EOR was a CRLF (two bytes wide). */
1248 dtp->u.p.current_unit->bytes_left -= 2;
1249 dtp->u.p.skips -= 2;
1253 /* The EOR marker was only one byte wide. */
1254 dtp->u.p.current_unit->bytes_left--;
1258 dtp->u.p.sf_seen_eor = 0;
1260 if (dtp->u.p.skips < 0)
1262 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1263 dtp->u.p.current_unit->bytes_left
1264 -= (gfc_offset) dtp->u.p.skips;
1265 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1268 read_x (dtp, dtp->u.p.skips);
1274 consume_data_flag = 0 ;
1275 dtp->u.p.sign_status = SIGN_S;
1279 consume_data_flag = 0 ;
1280 dtp->u.p.sign_status = SIGN_SS;
1284 consume_data_flag = 0 ;
1285 dtp->u.p.sign_status = SIGN_SP;
1289 consume_data_flag = 0 ;
1290 dtp->u.p.blank_status = BLANK_NULL;
1294 consume_data_flag = 0 ;
1295 dtp->u.p.blank_status = BLANK_ZERO;
1299 consume_data_flag = 0 ;
1300 dtp->u.p.scale_factor = f->u.k;
1304 consume_data_flag = 0 ;
1305 dtp->u.p.seen_dollar = 1;
1309 consume_data_flag = 0 ;
1310 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1311 next_record (dtp, 0);
1315 /* A colon descriptor causes us to exit this loop (in
1316 particular preventing another / descriptor from being
1317 processed) unless there is another data item to be
1319 consume_data_flag = 0 ;
1325 internal_error (&dtp->common, "Bad format node");
1328 /* Free a buffer that we had to allocate during a sequential
1329 formatted read of a block that was larger than the static
1332 if (dtp->u.p.line_buffer != scratch)
1334 free_mem (dtp->u.p.line_buffer);
1335 dtp->u.p.line_buffer = scratch;
1338 /* Adjust the item count and data pointer. */
1340 if ((consume_data_flag > 0) && (n > 0))
1343 p = ((char *) p) + size;
1346 if (dtp->u.p.mode == READING)
1349 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1350 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1356 /* Come here when we need a data descriptor but don't have one. We
1357 push the current format node back onto the input, then return and
1358 let the user program call us back with the data. */
1360 unget_format (dtp, f);
1364 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1365 size_t size, size_t nelems)
1372 /* Big loop over all the elements. */
1373 for (elem = 0; elem < nelems; elem++)
1375 dtp->u.p.item_count++;
1376 formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1382 /* Data transfer entry points. The type of the data entity is
1383 implicit in the subroutine call. This prevents us from having to
1384 share a common enum with the compiler. */
1387 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1389 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1391 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1396 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1399 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1401 size = size_from_real_kind (kind);
1402 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1407 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1409 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1411 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1416 transfer_character (st_parameter_dt *dtp, void *p, int len)
1418 static char *empty_string[0];
1420 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1423 /* Strings of zero length can have p == NULL, which confuses the
1424 transfer routines into thinking we need more data elements. To avoid
1425 this, we give them a nice pointer. */
1426 if (len == 0 && p == NULL)
1429 /* Currently we support only 1 byte chars, and the library is a bit
1430 confused of character kind vs. length, so we kludge it by setting
1432 dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1437 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1440 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1442 size = size_from_complex_kind (kind);
1443 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1448 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1449 gfc_charlen_type charlen)
1451 index_type count[GFC_MAX_DIMENSIONS];
1452 index_type extent[GFC_MAX_DIMENSIONS];
1453 index_type stride[GFC_MAX_DIMENSIONS];
1454 index_type stride0, rank, size, type, n;
1459 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1462 type = GFC_DESCRIPTOR_TYPE (desc);
1463 size = GFC_DESCRIPTOR_SIZE (desc);
1465 /* FIXME: What a kludge: Array descriptors and the IO library use
1466 different enums for types. */
1469 case GFC_DTYPE_UNKNOWN:
1470 iotype = BT_NULL; /* Is this correct? */
1472 case GFC_DTYPE_INTEGER:
1473 iotype = BT_INTEGER;
1475 case GFC_DTYPE_LOGICAL:
1476 iotype = BT_LOGICAL;
1478 case GFC_DTYPE_REAL:
1481 case GFC_DTYPE_COMPLEX:
1482 iotype = BT_COMPLEX;
1484 case GFC_DTYPE_CHARACTER:
1485 iotype = BT_CHARACTER;
1486 /* FIXME: Currently dtype contains the charlen, which is
1487 clobbered if charlen > 2**24. That's why we use a separate
1488 argument for the charlen. However, if we want to support
1489 non-8-bit charsets we need to fix dtype to contain
1490 sizeof(chartype) and fix the code below. */
1494 case GFC_DTYPE_DERIVED:
1495 internal_error (&dtp->common,
1496 "Derived type I/O should have been handled via the frontend.");
1499 internal_error (&dtp->common, "transfer_array(): Bad type");
1502 rank = GFC_DESCRIPTOR_RANK (desc);
1503 for (n = 0; n < rank; n++)
1506 stride[n] = desc->dim[n].stride;
1507 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1509 /* If the extent of even one dimension is zero, then the entire
1510 array section contains zero elements, so we return. */
1515 stride0 = stride[0];
1517 /* If the innermost dimension has stride 1, we can do the transfer
1518 in contiguous chunks. */
1524 data = GFC_DESCRIPTOR_DATA (desc);
1528 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1529 data += stride0 * size * tsize;
1532 while (count[n] == extent[n])
1535 data -= stride[n] * extent[n] * size;
1545 data += stride[n] * size;
1552 /* Preposition a sequential unformatted file while reading. */
1555 us_read (st_parameter_dt *dtp, int continued)
1564 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1567 if (compile_options.record_marker == 0)
1568 n = sizeof (GFC_INTEGER_4);
1570 n = compile_options.record_marker;
1574 p = salloc_r (dtp->u.p.current_unit->s, &n);
1578 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1579 return; /* end of file */
1582 if (p == NULL || n != nr)
1584 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
1588 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
1589 if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
1593 case sizeof(GFC_INTEGER_4):
1594 memcpy (&i4, p, sizeof (i4));
1598 case sizeof(GFC_INTEGER_8):
1599 memcpy (&i8, p, sizeof (i8));
1604 runtime_error ("Illegal value for record marker");
1611 case sizeof(GFC_INTEGER_4):
1612 reverse_memcpy (&i4, p, sizeof (i4));
1616 case sizeof(GFC_INTEGER_8):
1617 reverse_memcpy (&i8, p, sizeof (i8));
1622 runtime_error ("Illegal value for record marker");
1628 dtp->u.p.current_unit->bytes_left_subrecord = i;
1629 dtp->u.p.current_unit->continued = 0;
1633 dtp->u.p.current_unit->bytes_left_subrecord = -i;
1634 dtp->u.p.current_unit->continued = 1;
1638 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1642 /* Preposition a sequential unformatted file while writing. This
1643 amount to writing a bogus length that will be filled in later. */
1646 us_write (st_parameter_dt *dtp, int continued)
1653 if (compile_options.record_marker == 0)
1654 nbytes = sizeof (GFC_INTEGER_4);
1656 nbytes = compile_options.record_marker ;
1658 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1659 generate_error (&dtp->common, LIBERROR_OS, NULL);
1661 /* For sequential unformatted, if RECL= was not specified in the OPEN
1662 we write until we have more bytes than can fit in the subrecord
1663 markers, then we write a new subrecord. */
1665 dtp->u.p.current_unit->bytes_left_subrecord =
1666 dtp->u.p.current_unit->recl_subrecord;
1667 dtp->u.p.current_unit->continued = continued;
1671 /* Position to the next record prior to transfer. We are assumed to
1672 be before the next record. We also calculate the bytes in the next
1676 pre_position (st_parameter_dt *dtp)
1678 if (dtp->u.p.current_unit->current_record)
1679 return; /* Already positioned. */
1681 switch (current_mode (dtp))
1683 case FORMATTED_STREAM:
1684 case UNFORMATTED_STREAM:
1685 /* There are no records with stream I/O. Set the default position
1686 to the beginning of the file if no position was specified. */
1687 if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1688 dtp->u.p.current_unit->strm_pos = 1;
1691 case UNFORMATTED_SEQUENTIAL:
1692 if (dtp->u.p.mode == READING)
1699 case FORMATTED_SEQUENTIAL:
1700 case FORMATTED_DIRECT:
1701 case UNFORMATTED_DIRECT:
1702 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1706 dtp->u.p.current_unit->current_record = 1;
1710 /* Initialize things for a data transfer. This code is common for
1711 both reading and writing. */
1714 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1716 unit_flags u_flags; /* Used for creating a unit if needed. */
1717 GFC_INTEGER_4 cf = dtp->common.flags;
1718 namelist_info *ionml;
1720 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1721 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1722 dtp->u.p.ionml = ionml;
1723 dtp->u.p.mode = read_flag ? READING : WRITING;
1725 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1728 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1729 dtp->u.p.size_used = 0; /* Initialize the count. */
1731 dtp->u.p.current_unit = get_unit (dtp, 1);
1732 if (dtp->u.p.current_unit->s == NULL)
1733 { /* Open the unit with some default flags. */
1734 st_parameter_open opp;
1737 if (dtp->common.unit < 0)
1739 close_unit (dtp->u.p.current_unit);
1740 dtp->u.p.current_unit = NULL;
1741 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1742 "Bad unit number in OPEN statement");
1745 memset (&u_flags, '\0', sizeof (u_flags));
1746 u_flags.access = ACCESS_SEQUENTIAL;
1747 u_flags.action = ACTION_READWRITE;
1749 /* Is it unformatted? */
1750 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1751 | IOPARM_DT_IONML_SET)))
1752 u_flags.form = FORM_UNFORMATTED;
1754 u_flags.form = FORM_UNSPECIFIED;
1756 u_flags.delim = DELIM_UNSPECIFIED;
1757 u_flags.blank = BLANK_UNSPECIFIED;
1758 u_flags.pad = PAD_UNSPECIFIED;
1759 u_flags.status = STATUS_UNKNOWN;
1761 conv = get_unformatted_convert (dtp->common.unit);
1763 if (conv == GFC_CONVERT_NONE)
1764 conv = compile_options.convert;
1766 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1767 and 1 on big-endian machines. */
1770 case GFC_CONVERT_NATIVE:
1771 case GFC_CONVERT_SWAP:
1774 case GFC_CONVERT_BIG:
1775 conv = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
1778 case GFC_CONVERT_LITTLE:
1779 conv = l8_to_l4_offset ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
1783 internal_error (&opp.common, "Illegal value for CONVERT");
1787 u_flags.convert = conv;
1789 opp.common = dtp->common;
1790 opp.common.flags &= IOPARM_COMMON_MASK;
1791 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1792 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1793 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1794 if (dtp->u.p.current_unit == NULL)
1798 /* Check the action. */
1800 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1802 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
1803 "Cannot read from file opened for WRITE");
1807 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1809 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
1810 "Cannot write to file opened for READ");
1814 dtp->u.p.first_item = 1;
1816 /* Check the format. */
1818 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1821 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1822 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1825 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1826 "Format present for UNFORMATTED data transfer");
1830 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1832 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1833 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1834 "A format cannot be specified with a namelist");
1836 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1837 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1839 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1840 "Missing format for FORMATTED data transfer");
1843 if (is_internal_unit (dtp)
1844 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1846 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1847 "Internal file cannot be accessed by UNFORMATTED "
1852 /* Check the record or position number. */
1854 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1855 && (cf & IOPARM_DT_HAS_REC) == 0)
1857 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
1858 "Direct access data transfer requires record number");
1862 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1863 && (cf & IOPARM_DT_HAS_REC) != 0)
1865 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1866 "Record number not allowed for sequential access data transfer");
1870 /* Process the ADVANCE option. */
1872 dtp->u.p.advance_status
1873 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1874 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1875 "Bad ADVANCE parameter in data transfer statement");
1877 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1879 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1881 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1882 "ADVANCE specification conflicts with sequential access");
1886 if (is_internal_unit (dtp))
1888 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1889 "ADVANCE specification conflicts with internal file");
1893 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1894 != IOPARM_DT_HAS_FORMAT)
1896 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1897 "ADVANCE specification requires an explicit format");
1904 dtp->u.p.current_unit->previous_nonadvancing_write = 0;
1906 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1908 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
1909 "EOR specification requires an ADVANCE specification "
1914 if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1916 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
1917 "SIZE specification requires an ADVANCE specification of NO");
1922 { /* Write constraints. */
1923 if ((cf & IOPARM_END) != 0)
1925 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1926 "END specification cannot appear in a write statement");
1930 if ((cf & IOPARM_EOR) != 0)
1932 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1933 "EOR specification cannot appear in a write statement");
1937 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1939 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
1940 "SIZE specification cannot appear in a write statement");
1945 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1946 dtp->u.p.advance_status = ADVANCE_YES;
1948 /* Sanity checks on the record number. */
1949 if ((cf & IOPARM_DT_HAS_REC) != 0)
1953 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1954 "Record number must be positive");
1958 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1960 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1961 "Record number too large");
1965 /* Check to see if we might be reading what we wrote before */
1967 if (dtp->u.p.mode == READING
1968 && dtp->u.p.current_unit->mode == WRITING
1969 && !is_internal_unit (dtp))
1970 flush(dtp->u.p.current_unit->s);
1972 /* Check whether the record exists to be read. Only
1973 a partial record needs to exist. */
1975 if (dtp->u.p.mode == READING && (dtp->rec -1)
1976 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1978 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
1979 "Non-existing record number");
1983 /* Position the file. */
1984 if (!is_stream_io (dtp))
1986 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1987 * dtp->u.p.current_unit->recl) == FAILURE)
1989 generate_error (&dtp->common, LIBERROR_OS, NULL);
1994 dtp->u.p.current_unit->strm_pos = dtp->rec;
1998 /* Overwriting an existing sequential file ?
1999 it is always safe to truncate the file on the first write */
2000 if (dtp->u.p.mode == WRITING
2001 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
2002 && dtp->u.p.current_unit->last_record == 0
2003 && !is_preconnected(dtp->u.p.current_unit->s))
2004 struncate(dtp->u.p.current_unit->s);
2006 /* Bugware for badly written mixed C-Fortran I/O. */
2007 flush_if_preconnected(dtp->u.p.current_unit->s);
2009 dtp->u.p.current_unit->mode = dtp->u.p.mode;
2011 /* Set the initial value of flags. */
2013 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
2014 dtp->u.p.sign_status = SIGN_S;
2016 /* Set the maximum position reached from the previous I/O operation. This
2017 could be greater than zero from a previous non-advancing write. */
2018 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
2022 /* Set up the subroutine that will handle the transfers. */
2026 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2027 dtp->u.p.transfer = unformatted_read;
2030 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2031 dtp->u.p.transfer = list_formatted_read;
2033 dtp->u.p.transfer = formatted_transfer;
2038 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2039 dtp->u.p.transfer = unformatted_write;
2042 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
2043 dtp->u.p.transfer = list_formatted_write;
2045 dtp->u.p.transfer = formatted_transfer;
2049 /* Make sure that we don't do a read after a nonadvancing write. */
2053 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
2055 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
2056 "Cannot READ after a nonadvancing WRITE");
2062 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
2063 dtp->u.p.current_unit->read_bad = 1;
2066 /* Start the data transfer if we are doing a formatted transfer. */
2067 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2068 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
2069 && dtp->u.p.ionml == NULL)
2070 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
2073 /* Initialize an array_loop_spec given the array descriptor. The function
2074 returns the index of the last element of the array, and also returns
2075 starting record, where the first I/O goes to (necessary in case of
2076 negative strides). */
2079 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
2080 gfc_offset *start_record)
2082 int rank = GFC_DESCRIPTOR_RANK(desc);
2091 for (i=0; i<rank; i++)
2093 ls[i].idx = desc->dim[i].lbound;
2094 ls[i].start = desc->dim[i].lbound;
2095 ls[i].end = desc->dim[i].ubound;
2096 ls[i].step = desc->dim[i].stride;
2097 empty = empty || (desc->dim[i].ubound < desc->dim[i].lbound);
2099 if (desc->dim[i].stride > 0)
2101 index += (desc->dim[i].ubound - desc->dim[i].lbound)
2102 * desc->dim[i].stride;
2106 index -= (desc->dim[i].ubound - desc->dim[i].lbound)
2107 * desc->dim[i].stride;
2108 *start_record -= (desc->dim[i].ubound - desc->dim[i].lbound)
2109 * desc->dim[i].stride;
2119 /* Determine the index to the next record in an internal unit array by
2120 by incrementing through the array_loop_spec. */
2123 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
2131 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
2136 if (ls[i].idx > ls[i].end)
2138 ls[i].idx = ls[i].start;
2144 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
2154 /* Skip to the end of the current record, taking care of an optional
2155 record marker of size bytes. If the file is not seekable, we
2156 read chunks of size MAX_READ until we get to the right
2159 #define MAX_READ 4096
2162 skip_record (st_parameter_dt *dtp, size_t bytes)
2165 int rlength, length;
2168 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
2169 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
2172 if (is_seekable (dtp->u.p.current_unit->s))
2174 new = file_position (dtp->u.p.current_unit->s)
2175 + dtp->u.p.current_unit->bytes_left_subrecord;
2177 /* Direct access files do not generate END conditions,
2179 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
2180 generate_error (&dtp->common, LIBERROR_OS, NULL);
2183 { /* Seek by reading data. */
2184 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
2187 (MAX_READ > dtp->u.p.current_unit->bytes_left_subrecord) ?
2188 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
2190 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
2193 generate_error (&dtp->common, LIBERROR_OS, NULL);
2197 dtp->u.p.current_unit->bytes_left_subrecord -= length;
2205 /* Advance to the next record reading unformatted files, taking
2206 care of subrecords. If complete_record is nonzero, we loop
2207 until all subrecords are cleared. */
2210 next_record_r_unf (st_parameter_dt *dtp, int complete_record)
2214 bytes = compile_options.record_marker == 0 ?
2215 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
2220 /* Skip over tail */
2222 skip_record (dtp, bytes);
2224 if ( ! (complete_record && dtp->u.p.current_unit->continued))
2231 /* Space to the next record for read mode. */
2234 next_record_r (st_parameter_dt *dtp)
2237 int length, bytes_left;
2240 switch (current_mode (dtp))
2242 /* No records in unformatted STREAM I/O. */
2243 case UNFORMATTED_STREAM:
2246 case UNFORMATTED_SEQUENTIAL:
2247 next_record_r_unf (dtp, 1);
2248 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2251 case FORMATTED_DIRECT:
2252 case UNFORMATTED_DIRECT:
2253 skip_record (dtp, 0);
2256 case FORMATTED_STREAM:
2257 case FORMATTED_SEQUENTIAL:
2259 /* sf_read has already terminated input because of an '\n' */
2260 if (dtp->u.p.sf_seen_eor)
2262 dtp->u.p.sf_seen_eor = 0;
2266 if (is_internal_unit (dtp))
2268 if (is_array_io (dtp))
2272 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2275 /* Now seek to this record. */
2276 record = record * dtp->u.p.current_unit->recl;
2277 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2279 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2282 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2286 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2287 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2289 dtp->u.p.current_unit->bytes_left
2290 = dtp->u.p.current_unit->recl;
2296 p = salloc_r (dtp->u.p.current_unit->s, &length);
2300 generate_error (&dtp->common, LIBERROR_OS, NULL);
2306 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2310 if (is_stream_io (dtp))
2311 dtp->u.p.current_unit->strm_pos++;
2318 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
2319 && !dtp->u.p.namelist_mode
2320 && dtp->u.p.current_unit->endfile == NO_ENDFILE
2321 && (file_length (dtp->u.p.current_unit->s) ==
2322 file_position (dtp->u.p.current_unit->s)))
2323 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2328 /* Small utility function to write a record marker, taking care of
2329 byte swapping and of choosing the correct size. */
2332 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2337 char p[sizeof (GFC_INTEGER_8)];
2339 if (compile_options.record_marker == 0)
2340 len = sizeof (GFC_INTEGER_4);
2342 len = compile_options.record_marker;
2344 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
2345 if (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
2349 case sizeof (GFC_INTEGER_4):
2351 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2354 case sizeof (GFC_INTEGER_8):
2356 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2360 runtime_error ("Illegal value for record marker");
2368 case sizeof (GFC_INTEGER_4):
2370 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2371 return swrite (dtp->u.p.current_unit->s, p, &len);
2374 case sizeof (GFC_INTEGER_8):
2376 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_8));
2377 return swrite (dtp->u.p.current_unit->s, p, &len);
2381 runtime_error ("Illegal value for record marker");
2388 /* Position to the next (sub)record in write mode for
2389 unformatted sequential files. */
2392 next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
2394 gfc_offset c, m, m_write;
2395 size_t record_marker;
2397 /* Bytes written. */
2398 m = dtp->u.p.current_unit->recl_subrecord
2399 - dtp->u.p.current_unit->bytes_left_subrecord;
2400 c = file_position (dtp->u.p.current_unit->s);
2402 /* Write the length tail. If we finish a record containing
2403 subrecords, we write out the negative length. */
2405 if (dtp->u.p.current_unit->continued)
2410 if (write_us_marker (dtp, m_write) != 0)
2413 if (compile_options.record_marker == 0)
2414 record_marker = sizeof (GFC_INTEGER_4);
2416 record_marker = compile_options.record_marker;
2418 /* Seek to the head and overwrite the bogus length with the real
2421 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2430 if (write_us_marker (dtp, m_write) != 0)
2433 /* Seek past the end of the current record. */
2435 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2441 generate_error (&dtp->common, LIBERROR_OS, NULL);
2446 /* Position to the next record in write mode. */
2449 next_record_w (st_parameter_dt *dtp, int done)
2451 gfc_offset m, record, max_pos;
2455 /* Zero counters for X- and T-editing. */
2456 max_pos = dtp->u.p.max_pos;
2457 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2459 switch (current_mode (dtp))
2461 /* No records in unformatted STREAM I/O. */
2462 case UNFORMATTED_STREAM:
2465 case FORMATTED_DIRECT:
2466 if (dtp->u.p.current_unit->bytes_left == 0)
2469 if (sset (dtp->u.p.current_unit->s, ' ',
2470 dtp->u.p.current_unit->bytes_left) == FAILURE)
2475 case UNFORMATTED_DIRECT:
2476 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2480 case UNFORMATTED_SEQUENTIAL:
2481 next_record_w_unf (dtp, 0);
2482 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2485 case FORMATTED_STREAM:
2486 case FORMATTED_SEQUENTIAL:
2488 if (is_internal_unit (dtp))
2490 if (is_array_io (dtp))
2494 length = (int) dtp->u.p.current_unit->bytes_left;
2496 /* If the farthest position reached is greater than current
2497 position, adjust the position and set length to pad out
2498 whats left. Otherwise just pad whats left.
2499 (for character array unit) */
2500 m = dtp->u.p.current_unit->recl
2501 - dtp->u.p.current_unit->bytes_left;
2504 length = (int) (max_pos - m);
2505 p = salloc_w (dtp->u.p.current_unit->s, &length);
2506 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2509 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2511 generate_error (&dtp->common, LIBERROR_END, NULL);
2515 /* Now that the current record has been padded out,
2516 determine where the next record in the array is. */
2517 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
2520 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2522 /* Now seek to this record */
2523 record = record * dtp->u.p.current_unit->recl;
2525 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2527 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
2531 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2537 /* If this is the last call to next_record move to the farthest
2538 position reached and set length to pad out the remainder
2539 of the record. (for character scaler unit) */
2542 m = dtp->u.p.current_unit->recl
2543 - dtp->u.p.current_unit->bytes_left;
2546 length = (int) (max_pos - m);
2547 p = salloc_w (dtp->u.p.current_unit->s, &length);
2548 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2551 length = (int) dtp->u.p.current_unit->bytes_left;
2554 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2556 generate_error (&dtp->common, LIBERROR_END, NULL);
2563 /* If this is the last call to next_record move to the farthest
2564 position reached in preparation for completing the record.
2568 m = dtp->u.p.current_unit->recl -
2569 dtp->u.p.current_unit->bytes_left;
2572 length = (int) (max_pos - m);
2573 p = salloc_w (dtp->u.p.current_unit->s, &length);
2577 const char crlf[] = "\r\n";
2583 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2586 if (is_stream_io (dtp))
2587 dtp->u.p.current_unit->strm_pos += len;
2593 generate_error (&dtp->common, LIBERROR_OS, NULL);
2598 /* Position to the next record, which means moving to the end of the
2599 current record. This can happen under several different
2600 conditions. If the done flag is not set, we get ready to process
2604 next_record (st_parameter_dt *dtp, int done)
2606 gfc_offset fp; /* File position. */
2608 dtp->u.p.current_unit->read_bad = 0;
2610 if (dtp->u.p.mode == READING)
2611 next_record_r (dtp);
2613 next_record_w (dtp, done);
2615 if (!is_stream_io (dtp))
2617 /* Keep position up to date for INQUIRE */
2619 update_position (dtp->u.p.current_unit);
2621 dtp->u.p.current_unit->current_record = 0;
2622 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2624 fp = file_position (dtp->u.p.current_unit->s);
2625 /* Calculate next record, rounding up partial records. */
2626 dtp->u.p.current_unit->last_record =
2627 (fp + dtp->u.p.current_unit->recl - 1) /
2628 dtp->u.p.current_unit->recl;
2631 dtp->u.p.current_unit->last_record++;
2639 /* Finalize the current data transfer. For a nonadvancing transfer,
2640 this means advancing to the next record. For internal units close the
2641 stream associated with the unit. */
2644 finalize_transfer (st_parameter_dt *dtp)
2647 GFC_INTEGER_4 cf = dtp->common.flags;
2649 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2650 *dtp->size = (GFC_IO_INT) dtp->u.p.size_used;
2652 if (dtp->u.p.eor_condition)
2654 generate_error (&dtp->common, LIBERROR_EOR, NULL);
2658 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2661 if ((dtp->u.p.ionml != NULL)
2662 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2664 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2665 namelist_read (dtp);
2667 namelist_write (dtp);
2670 dtp->u.p.transfer = NULL;
2671 if (dtp->u.p.current_unit == NULL)
2674 dtp->u.p.eof_jump = &eof_jump;
2675 if (setjmp (eof_jump))
2677 generate_error (&dtp->common, LIBERROR_END, NULL);
2681 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2683 finish_list_read (dtp);
2684 sfree (dtp->u.p.current_unit->s);
2688 if (dtp->u.p.mode == WRITING)
2689 dtp->u.p.current_unit->previous_nonadvancing_write
2690 = dtp->u.p.advance_status == ADVANCE_NO;
2692 if (is_stream_io (dtp))
2694 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
2695 && dtp->u.p.advance_status != ADVANCE_NO)
2696 next_record (dtp, 1);
2698 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
2699 && file_position (dtp->u.p.current_unit->s) >= dtp->rec)
2701 flush (dtp->u.p.current_unit->s);
2702 sfree (dtp->u.p.current_unit->s);
2707 dtp->u.p.current_unit->current_record = 0;
2709 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
2711 dtp->u.p.seen_dollar = 0;
2712 sfree (dtp->u.p.current_unit->s);
2716 /* For non-advancing I/O, save the current maximum position for use in the
2717 next I/O operation if needed. */
2718 if (dtp->u.p.advance_status == ADVANCE_NO)
2720 int bytes_written = (int) (dtp->u.p.current_unit->recl
2721 - dtp->u.p.current_unit->bytes_left);
2722 dtp->u.p.current_unit->saved_pos =
2723 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
2724 flush (dtp->u.p.current_unit->s);
2728 dtp->u.p.current_unit->saved_pos = 0;
2730 next_record (dtp, 1);
2731 sfree (dtp->u.p.current_unit->s);
2734 /* Transfer function for IOLENGTH. It doesn't actually do any
2735 data transfer, it just updates the length counter. */
2738 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2739 void *dest __attribute__ ((unused)),
2740 int kind __attribute__((unused)),
2741 size_t size, size_t nelems)
2743 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2744 *dtp->iolength += (GFC_IO_INT) size * nelems;
2748 /* Initialize the IOLENGTH data transfer. This function is in essence
2749 a very much simplified version of data_transfer_init(), because it
2750 doesn't have to deal with units at all. */
2753 iolength_transfer_init (st_parameter_dt *dtp)
2755 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2758 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2760 /* Set up the subroutine that will handle the transfers. */
2762 dtp->u.p.transfer = iolength_transfer;
2766 /* Library entry point for the IOLENGTH form of the INQUIRE
2767 statement. The IOLENGTH form requires no I/O to be performed, but
2768 it must still be a runtime library call so that we can determine
2769 the iolength for dynamic arrays and such. */
2771 extern void st_iolength (st_parameter_dt *);
2772 export_proto(st_iolength);
2775 st_iolength (st_parameter_dt *dtp)
2777 library_start (&dtp->common);
2778 iolength_transfer_init (dtp);
2781 extern void st_iolength_done (st_parameter_dt *);
2782 export_proto(st_iolength_done);
2785 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2788 if (dtp->u.p.scratch != NULL)
2789 free_mem (dtp->u.p.scratch);
2794 /* The READ statement. */
2796 extern void st_read (st_parameter_dt *);
2797 export_proto(st_read);
2800 st_read (st_parameter_dt *dtp)
2802 library_start (&dtp->common);
2804 data_transfer_init (dtp, 1);
2806 /* Handle complications dealing with the endfile record. */
2808 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2809 switch (dtp->u.p.current_unit->endfile)
2815 if (!is_internal_unit (dtp))
2817 generate_error (&dtp->common, LIBERROR_END, NULL);
2818 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2819 dtp->u.p.current_unit->current_record = 0;
2824 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
2825 dtp->u.p.current_unit->current_record = 0;
2830 extern void st_read_done (st_parameter_dt *);
2831 export_proto(st_read_done);
2834 st_read_done (st_parameter_dt *dtp)
2836 finalize_transfer (dtp);
2837 free_format_data (dtp);
2839 if (dtp->u.p.scratch != NULL)
2840 free_mem (dtp->u.p.scratch);
2841 if (dtp->u.p.current_unit != NULL)
2842 unlock_unit (dtp->u.p.current_unit);
2844 free_internal_unit (dtp);
2849 extern void st_write (st_parameter_dt *);
2850 export_proto(st_write);
2853 st_write (st_parameter_dt *dtp)
2855 library_start (&dtp->common);
2856 data_transfer_init (dtp, 0);
2859 extern void st_write_done (st_parameter_dt *);
2860 export_proto(st_write_done);
2863 st_write_done (st_parameter_dt *dtp)
2865 finalize_transfer (dtp);
2867 /* Deal with endfile conditions associated with sequential files. */
2869 if (dtp->u.p.current_unit != NULL
2870 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2871 switch (dtp->u.p.current_unit->endfile)
2873 case AT_ENDFILE: /* Remain at the endfile record. */
2877 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2881 /* Get rid of whatever is after this record. */
2882 if (!is_internal_unit (dtp))
2884 flush (dtp->u.p.current_unit->s);
2885 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2886 generate_error (&dtp->common, LIBERROR_OS, NULL);
2888 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2892 free_format_data (dtp);
2894 if (dtp->u.p.scratch != NULL)
2895 free_mem (dtp->u.p.scratch);
2896 if (dtp->u.p.current_unit != NULL)
2897 unlock_unit (dtp->u.p.current_unit);
2899 free_internal_unit (dtp);
2904 /* Receives the scalar information for namelist objects and stores it
2905 in a linked list of namelist_info types. */
2907 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2908 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2909 export_proto(st_set_nml_var);
2913 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2914 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2915 GFC_INTEGER_4 dtype)
2917 namelist_info *t1 = NULL;
2919 size_t var_name_len = strlen (var_name);
2921 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2923 nml->mem_pos = var_addr;
2925 nml->var_name = (char*) get_mem (var_name_len + 1);
2926 memcpy (nml->var_name, var_name, var_name_len);
2927 nml->var_name[var_name_len] = '\0';
2929 nml->len = (int) len;
2930 nml->string_length = (index_type) string_length;
2932 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2933 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2934 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2936 if (nml->var_rank > 0)
2938 nml->dim = (descriptor_dimension*)
2939 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2940 nml->ls = (array_loop_spec*)
2941 get_mem (nml->var_rank * sizeof (array_loop_spec));
2951 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2953 dtp->common.flags |= IOPARM_DT_IONML_SET;
2954 dtp->u.p.ionml = nml;
2958 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2963 /* Store the dimensional information for the namelist object. */
2964 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2965 index_type, index_type,
2967 export_proto(st_set_nml_var_dim);
2970 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2971 index_type stride, index_type lbound,
2974 namelist_info * nml;
2979 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2981 nml->dim[n].stride = stride;
2982 nml->dim[n].lbound = lbound;
2983 nml->dim[n].ubound = ubound;
2986 /* Reverse memcpy - used for byte swapping. */
2988 void reverse_memcpy (void *dest, const void *src, size_t n)
2994 s = (char *) src + n - 1;
2996 /* Write with ascending order - this is likely faster
2997 on modern architectures because of write combining. */