1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 Namelist transfer functions contributed by Paul Thomas
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public License
27 along with Libgfortran; see the file COPYING. If not, write to
28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
32 /* transfer.c -- Top level handling of data transfer statements. */
37 #include "libgfortran.h"
41 /* Calling conventions: Data transfer statements are unlike other
42 library calls in that they extend over several calls.
44 The first call is always a call to st_read() or st_write(). These
45 subroutines return no status unless a namelist read or write is
46 being done, in which case there is the usual status. No further
47 calls are necessary in this case.
49 For other sorts of data transfer, there are zero or more data
50 transfer statement that depend on the format of the data transfer
59 These subroutines do not return status.
61 The last call is a call to st_[read|write]_done(). While
62 something can easily go wrong with the initial st_read() or
63 st_write(), an error inhibits any data from actually being
66 extern void transfer_integer (st_parameter_dt *, void *, int);
67 export_proto(transfer_integer);
69 extern void transfer_real (st_parameter_dt *, void *, int);
70 export_proto(transfer_real);
72 extern void transfer_logical (st_parameter_dt *, void *, int);
73 export_proto(transfer_logical);
75 extern void transfer_character (st_parameter_dt *, void *, int);
76 export_proto(transfer_character);
78 extern void transfer_complex (st_parameter_dt *, void *, int);
79 export_proto(transfer_complex);
81 extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
83 export_proto(transfer_array);
85 static const st_option advance_opt[] = {
93 { FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
94 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
100 current_mode (st_parameter_dt *dtp)
104 m = FORM_UNSPECIFIED;
106 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
108 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
109 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
111 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
113 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
114 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
116 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
118 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
119 FORMATTED_STREAM : UNFORMATTED_STREAM;
126 /* Mid level data transfer statements. These subroutines do reading
127 and writing in the style of salloc_r()/salloc_w() within the
130 /* When reading sequential formatted records we have a problem. We
131 don't know how long the line is until we read the trailing newline,
132 and we don't want to read too much. If we read too much, we might
133 have to do a physical seek backwards depending on how much data is
134 present, and devices like terminals aren't seekable and would cause
137 Given this, the solution is to read a byte at a time, stopping if
138 we hit the newline. For small allocations, we use a static buffer.
139 For larger allocations, we are forced to allocate memory on the
140 heap. Hopefully this won't happen very often. */
143 read_sf (st_parameter_dt *dtp, int *length, int no_error)
146 int n, readlen, crlf;
149 if (*length > SCRATCH_SIZE)
150 dtp->u.p.line_buffer = get_mem (*length);
151 p = base = dtp->u.p.line_buffer;
153 /* If we have seen an eor previously, return a length of 0. The
154 caller is responsible for correctly padding the input field. */
155 if (dtp->u.p.sf_seen_eor)
166 if (is_internal_unit (dtp))
168 /* readlen may be modified inside salloc_r if
169 is_internal_unit (dtp) is true. */
173 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
177 /* If we have a line without a terminating \n, drop through to
179 if (readlen < 1 && n == 0)
183 generate_error (&dtp->common, ERROR_END, NULL);
187 if (readlen < 1 || *q == '\n' || *q == '\r')
189 /* Unexpected end of line. */
191 /* If we see an EOR during non-advancing I/O, we need to skip
192 the rest of the I/O statement. Set the corresponding flag. */
193 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
194 dtp->u.p.eor_condition = 1;
197 /* If we encounter a CR, it might be a CRLF. */
198 if (*q == '\r') /* Probably a CRLF */
201 pos = stream_offset (dtp->u.p.current_unit->s);
202 q = salloc_r (dtp->u.p.current_unit->s, &readlen);
203 if (*q != '\n' && readlen == 1) /* Not a CRLF after all. */
204 sseek (dtp->u.p.current_unit->s, pos);
209 /* Without padding, terminate the I/O statement without assigning
210 the value. With padding, the value still needs to be assigned,
211 so we can just continue with a short read. */
212 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
216 generate_error (&dtp->common, ERROR_EOR, NULL);
221 dtp->u.p.sf_seen_eor = (crlf ? 2 : 1);
224 /* Short circuit the read if a comma is found during numeric input.
225 The flag is set to zero during character reads so that commas in
226 strings are not ignored */
228 if (dtp->u.p.sf_read_comma == 1)
230 notify_std (&dtp->common, GFC_STD_GNU,
231 "Comma in formatted numeric read.");
238 dtp->u.p.sf_seen_eor = 0;
241 dtp->u.p.current_unit->bytes_left -= *length;
243 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
244 dtp->u.p.size_used += (gfc_offset) *length;
250 /* Function for reading the next couple of bytes from the current
251 file, advancing the current position. We return a pointer to a
252 buffer containing the bytes. We return NULL on end of record or
255 If the read is short, then it is because the current record does not
256 have enough data to satisfy the read request and the file was
257 opened with PAD=YES. The caller must assume tailing spaces for
261 read_block (st_parameter_dt *dtp, int *length)
266 if (!is_stream_io (dtp))
268 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *length)
270 /* For preconnected units with default record length, set bytes left
271 to unit record length and proceed, otherwise error. */
272 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
273 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
274 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
277 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
279 /* Not enough data left. */
280 generate_error (&dtp->common, ERROR_EOR, NULL);
285 if (dtp->u.p.current_unit->bytes_left == 0)
287 dtp->u.p.current_unit->endfile = AT_ENDFILE;
288 generate_error (&dtp->common, ERROR_END, NULL);
292 *length = dtp->u.p.current_unit->bytes_left;
295 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
296 dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
297 return read_sf (dtp, length, 0); /* Special case. */
299 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *length;
302 source = salloc_r (dtp->u.p.current_unit->s, &nread);
304 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
305 dtp->u.p.size_used += (gfc_offset) nread;
307 if (nread != *length)
308 { /* Short read, this shouldn't happen. */
309 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
313 generate_error (&dtp->common, ERROR_EOR, NULL);
320 if (sseek (dtp->u.p.current_unit->s,
321 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
323 generate_error (&dtp->common, ERROR_END, NULL);
327 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
329 source = read_sf (dtp, length, 0);
330 dtp->u.p.current_unit->strm_pos +=
331 (gfc_offset) (*length + dtp->u.p.sf_seen_eor);
335 source = salloc_r (dtp->u.p.current_unit->s, &nread);
337 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
338 dtp->u.p.size_used += (gfc_offset) nread;
340 if (nread != *length)
341 { /* Short read, this shouldn't happen. */
342 if (dtp->u.p.current_unit->flags.pad == PAD_YES)
346 generate_error (&dtp->common, ERROR_END, NULL);
351 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
357 /* Reads a block directly into application data space. */
360 read_block_direct (st_parameter_dt *dtp, void *buf, size_t *nbytes)
366 if (!is_stream_io (dtp))
368 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
370 /* For preconnected units with default record length, set
371 bytes left to unit record length and proceed, otherwise
373 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
374 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
375 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
378 if (dtp->u.p.current_unit->flags.pad == PAD_NO)
380 /* Not enough data left. */
381 generate_error (&dtp->common, ERROR_EOR, NULL);
386 if (dtp->u.p.current_unit->bytes_left == 0)
388 dtp->u.p.current_unit->endfile = AT_ENDFILE;
389 generate_error (&dtp->common, ERROR_END, NULL);
393 *nbytes = (size_t) dtp->u.p.current_unit->bytes_left;
396 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
397 dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
399 length = (int *) nbytes;
400 data = read_sf (dtp, length, 0); /* Special case. */
401 memcpy (buf, data, (size_t) *length);
405 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
409 if (sseek (dtp->u.p.current_unit->s,
410 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
412 generate_error (&dtp->common, ERROR_END, NULL);
418 if (sread (dtp->u.p.current_unit->s, buf, &nread) != 0)
420 generate_error (&dtp->common, ERROR_OS, NULL);
424 if (!is_stream_io (dtp))
426 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
427 dtp->u.p.size_used += (gfc_offset) nread;
430 dtp->u.p.current_unit->strm_pos += (gfc_offset) nread;
432 if (nread != *nbytes) /* Short read, e.g. if we hit EOF. */
434 if (!is_stream_io (dtp))
435 generate_error (&dtp->common, ERROR_EOR, NULL);
437 generate_error (&dtp->common, ERROR_END, NULL);
442 /* Function for writing a block of bytes to the current file at the
443 current position, advancing the file pointer. We are given a length
444 and return a pointer to a buffer that the caller must (completely)
445 fill in. Returns NULL on error. */
448 write_block (st_parameter_dt *dtp, int length)
452 if (!is_stream_io (dtp))
454 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
456 /* For preconnected units with default record length, set bytes left
457 to unit record length and proceed, otherwise error. */
458 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
459 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
460 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
461 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
464 generate_error (&dtp->common, ERROR_EOR, NULL);
469 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
472 dest = salloc_w (dtp->u.p.current_unit->s, &length);
476 generate_error (&dtp->common, ERROR_END, NULL);
480 if (is_internal_unit (dtp) && dtp->u.p.current_unit->endfile == AT_ENDFILE)
481 generate_error (&dtp->common, ERROR_END, NULL);
483 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
484 dtp->u.p.size_used += (gfc_offset) length;
488 if (sseek (dtp->u.p.current_unit->s,
489 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
491 generate_error (&dtp->common, ERROR_OS, NULL);
495 dest = salloc_w (dtp->u.p.current_unit->s, &length);
499 generate_error (&dtp->common, ERROR_END, NULL);
503 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
510 /* High level interface to swrite(), taking care of errors. */
513 write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
515 if (!is_stream_io (dtp))
517 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
519 /* For preconnected units with default record length, set
520 bytes left to unit record length and proceed, otherwise
522 if ((dtp->u.p.current_unit->unit_number == options.stdout_unit
523 || dtp->u.p.current_unit->unit_number == options.stderr_unit)
524 && dtp->u.p.current_unit->recl == DEFAULT_RECL)
525 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
528 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
529 generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
531 generate_error (&dtp->common, ERROR_EOR, NULL);
536 dtp->u.p.current_unit->bytes_left -= (gfc_offset) nbytes;
540 if (sseek (dtp->u.p.current_unit->s,
541 dtp->u.p.current_unit->strm_pos - 1) == FAILURE)
543 generate_error (&dtp->common, ERROR_OS, NULL);
548 if (swrite (dtp->u.p.current_unit->s, buf, &nbytes) != 0)
550 generate_error (&dtp->common, ERROR_OS, NULL);
554 if (!is_stream_io (dtp))
556 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
557 dtp->u.p.size_used += (gfc_offset) nbytes;
560 dtp->u.p.current_unit->strm_pos += (gfc_offset) nbytes;
566 /* Master function for unformatted reads. */
569 unformatted_read (st_parameter_dt *dtp, bt type,
570 void *dest, int kind,
571 size_t size, size_t nelems)
575 /* Currently, character implies size=1. */
576 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE
577 || size == 1 || type == BT_CHARACTER)
580 read_block_direct (dtp, dest, &sz);
587 /* Break up complex into its constituent reals. */
588 if (type == BT_COMPLEX)
595 /* By now, all complex variables have been split into their
596 constituent reals. For types with padding, we only need to
597 read kind bytes. We don't care about the contents
601 for (i=0; i<nelems; i++)
603 read_block_direct (dtp, buffer, &sz);
604 reverse_memcpy (p, buffer, sz);
611 /* Master function for unformatted writes. */
614 unformatted_write (st_parameter_dt *dtp, bt type,
615 void *source, int kind,
616 size_t size, size_t nelems)
618 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE ||
619 size == 1 || type == BT_CHARACTER)
623 write_buf (dtp, source, size);
631 /* Break up complex into its constituent reals. */
632 if (type == BT_COMPLEX)
640 /* By now, all complex variables have been split into their
641 constituent reals. For types with padding, we only need to
642 read kind bytes. We don't care about the contents
646 for (i=0; i<nelems; i++)
648 reverse_memcpy(buffer, p, size);
650 write_buf (dtp, buffer, sz);
656 /* Return a pointer to the name of a type. */
681 internal_error (NULL, "type_name(): Bad type");
688 /* Write a constant string to the output.
689 This is complicated because the string can have doubled delimiters
690 in it. The length in the format node is the true length. */
693 write_constant_string (st_parameter_dt *dtp, const fnode *f)
695 char c, delimiter, *p, *q;
698 length = f->u.string.length;
702 p = write_block (dtp, length);
709 for (; length > 0; length--)
712 if (c == delimiter && c != 'H' && c != 'h')
713 q++; /* Skip the doubled delimiter. */
718 /* Given actual and expected types in a formatted data transfer, make
719 sure they agree. If not, an error message is generated. Returns
720 nonzero if something went wrong. */
723 require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
727 if (actual == expected)
730 st_sprintf (buffer, "Expected %s for item %d in formatted transfer, got %s",
731 type_name (expected), dtp->u.p.item_count, type_name (actual));
733 format_error (dtp, f, buffer);
738 /* This subroutine is the main loop for a formatted data transfer
739 statement. It would be natural to implement this as a coroutine
740 with the user program, but C makes that awkward. We loop,
741 processesing format elements. When we actually have to transfer
742 data instead of just setting flags, we return control to the user
743 program which calls a subroutine that supplies the address and type
744 of the next element, then comes back here to process it. */
747 formatted_transfer_scalar (st_parameter_dt *dtp, bt type, void *p, int len,
750 char scratch[SCRATCH_SIZE];
755 int consume_data_flag;
757 /* Change a complex data item into a pair of reals. */
759 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
760 if (type == BT_COMPLEX)
766 /* If there's an EOR condition, we simulate finalizing the transfer
768 if (dtp->u.p.eor_condition)
771 /* Set this flag so that commas in reads cause the read to complete before
772 the entire field has been read. The next read field will start right after
773 the comma in the stream. (Set to 0 for character reads). */
774 dtp->u.p.sf_read_comma = 1;
776 dtp->u.p.line_buffer = scratch;
779 /* If reversion has occurred and there is another real data item,
780 then we have to move to the next record. */
781 if (dtp->u.p.reversion_flag && n > 0)
783 dtp->u.p.reversion_flag = 0;
784 next_record (dtp, 0);
787 consume_data_flag = 1 ;
788 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
791 f = next_format (dtp);
794 /* No data descriptors left. */
796 generate_error (&dtp->common, ERROR_FORMAT,
797 "Insufficient data descriptors in format after reversion");
801 /* Now discharge T, TR and X movements to the right. This is delayed
802 until a data producing format to suppress trailing spaces. */
805 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
806 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
807 || t == FMT_Z || t == FMT_F || t == FMT_E
808 || t == FMT_EN || t == FMT_ES || t == FMT_G
809 || t == FMT_L || t == FMT_A || t == FMT_D))
812 if (dtp->u.p.skips > 0)
814 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
815 dtp->u.p.max_pos = (int)(dtp->u.p.current_unit->recl
816 - dtp->u.p.current_unit->bytes_left);
818 if (dtp->u.p.skips < 0)
820 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
821 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
823 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
826 bytes_used = (int)(dtp->u.p.current_unit->recl
827 - dtp->u.p.current_unit->bytes_left);
834 if (require_type (dtp, BT_INTEGER, type, f))
837 if (dtp->u.p.mode == READING)
838 read_decimal (dtp, f, p, len);
840 write_i (dtp, f, p, len);
847 if (require_type (dtp, BT_INTEGER, type, f))
850 if (dtp->u.p.mode == READING)
851 read_radix (dtp, f, p, len, 2);
853 write_b (dtp, f, p, len);
861 if (dtp->u.p.mode == READING)
862 read_radix (dtp, f, p, len, 8);
864 write_o (dtp, f, p, len);
872 if (dtp->u.p.mode == READING)
873 read_radix (dtp, f, p, len, 16);
875 write_z (dtp, f, p, len);
883 if (dtp->u.p.mode == READING)
884 read_a (dtp, f, p, len);
886 write_a (dtp, f, p, len);
894 if (dtp->u.p.mode == READING)
895 read_l (dtp, f, p, len);
897 write_l (dtp, f, p, len);
904 if (require_type (dtp, BT_REAL, type, f))
907 if (dtp->u.p.mode == READING)
908 read_f (dtp, f, p, len);
910 write_d (dtp, f, p, len);
917 if (require_type (dtp, BT_REAL, type, f))
920 if (dtp->u.p.mode == READING)
921 read_f (dtp, f, p, len);
923 write_e (dtp, f, p, len);
929 if (require_type (dtp, BT_REAL, type, f))
932 if (dtp->u.p.mode == READING)
933 read_f (dtp, f, p, len);
935 write_en (dtp, f, p, len);
942 if (require_type (dtp, BT_REAL, type, f))
945 if (dtp->u.p.mode == READING)
946 read_f (dtp, f, p, len);
948 write_es (dtp, f, p, len);
955 if (require_type (dtp, BT_REAL, type, f))
958 if (dtp->u.p.mode == READING)
959 read_f (dtp, f, p, len);
961 write_f (dtp, f, p, len);
968 if (dtp->u.p.mode == READING)
972 read_decimal (dtp, f, p, len);
975 read_l (dtp, f, p, len);
978 read_a (dtp, f, p, len);
981 read_f (dtp, f, p, len);
990 write_i (dtp, f, p, len);
993 write_l (dtp, f, p, len);
996 write_a (dtp, f, p, len);
999 write_d (dtp, f, p, len);
1003 internal_error (&dtp->common,
1004 "formatted_transfer(): Bad type");
1010 consume_data_flag = 0 ;
1011 if (dtp->u.p.mode == READING)
1013 format_error (dtp, f, "Constant string in input format");
1016 write_constant_string (dtp, f);
1019 /* Format codes that don't transfer data. */
1022 consume_data_flag = 0 ;
1024 pos = bytes_used + f->u.n + dtp->u.p.skips;
1025 dtp->u.p.skips = f->u.n + dtp->u.p.skips;
1026 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos;
1028 /* Writes occur just before the switch on f->format, above, so
1029 that trailing blanks are suppressed, unless we are doing a
1030 non-advancing write in which case we want to output the blanks
1032 if (dtp->u.p.mode == WRITING
1033 && dtp->u.p.advance_status == ADVANCE_NO)
1035 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
1036 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1038 if (dtp->u.p.mode == READING)
1039 read_x (dtp, f->u.n);
1045 if (f->format == FMT_TL)
1048 /* Handle the special case when no bytes have been used yet.
1049 Cannot go below zero. */
1050 if (bytes_used == 0)
1052 dtp->u.p.pending_spaces -= f->u.n;
1053 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0 ? 0
1054 : dtp->u.p.pending_spaces;
1055 dtp->u.p.skips -= f->u.n;
1056 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1059 pos = bytes_used - f->u.n;
1063 consume_data_flag = 0;
1067 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1068 left tab limit. We do not check if the position has gone
1069 beyond the end of record because a subsequent tab could
1070 bring us back again. */
1071 pos = pos < 0 ? 0 : pos;
1073 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1074 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1075 + pos - dtp->u.p.max_pos;
1077 if (dtp->u.p.skips == 0)
1080 /* Writes occur just before the switch on f->format, above, so that
1081 trailing blanks are suppressed. */
1082 if (dtp->u.p.mode == READING)
1084 /* Adjust everything for end-of-record condition */
1085 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1087 if (dtp->u.p.sf_seen_eor == 2)
1089 /* The EOR was a CRLF (two bytes wide). */
1090 dtp->u.p.current_unit->bytes_left -= 2;
1091 dtp->u.p.skips -= 2;
1095 /* The EOR marker was only one byte wide. */
1096 dtp->u.p.current_unit->bytes_left--;
1100 dtp->u.p.sf_seen_eor = 0;
1102 if (dtp->u.p.skips < 0)
1104 move_pos_offset (dtp->u.p.current_unit->s, dtp->u.p.skips);
1105 dtp->u.p.current_unit->bytes_left
1106 -= (gfc_offset) dtp->u.p.skips;
1107 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1110 read_x (dtp, dtp->u.p.skips);
1116 consume_data_flag = 0 ;
1117 dtp->u.p.sign_status = SIGN_S;
1121 consume_data_flag = 0 ;
1122 dtp->u.p.sign_status = SIGN_SS;
1126 consume_data_flag = 0 ;
1127 dtp->u.p.sign_status = SIGN_SP;
1131 consume_data_flag = 0 ;
1132 dtp->u.p.blank_status = BLANK_NULL;
1136 consume_data_flag = 0 ;
1137 dtp->u.p.blank_status = BLANK_ZERO;
1141 consume_data_flag = 0 ;
1142 dtp->u.p.scale_factor = f->u.k;
1146 consume_data_flag = 0 ;
1147 dtp->u.p.seen_dollar = 1;
1151 consume_data_flag = 0 ;
1152 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1153 next_record (dtp, 0);
1157 /* A colon descriptor causes us to exit this loop (in
1158 particular preventing another / descriptor from being
1159 processed) unless there is another data item to be
1161 consume_data_flag = 0 ;
1167 internal_error (&dtp->common, "Bad format node");
1170 /* Free a buffer that we had to allocate during a sequential
1171 formatted read of a block that was larger than the static
1174 if (dtp->u.p.line_buffer != scratch)
1176 free_mem (dtp->u.p.line_buffer);
1177 dtp->u.p.line_buffer = scratch;
1180 /* Adjust the item count and data pointer. */
1182 if ((consume_data_flag > 0) && (n > 0))
1185 p = ((char *) p) + size;
1188 if (dtp->u.p.mode == READING)
1191 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1192 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1198 /* Come here when we need a data descriptor but don't have one. We
1199 push the current format node back onto the input, then return and
1200 let the user program call us back with the data. */
1202 unget_format (dtp, f);
1206 formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
1207 size_t size, size_t nelems)
1214 /* Big loop over all the elements. */
1215 for (elem = 0; elem < nelems; elem++)
1217 dtp->u.p.item_count++;
1218 formatted_transfer_scalar (dtp, type, tmp + size*elem, kind, size);
1224 /* Data transfer entry points. The type of the data entity is
1225 implicit in the subroutine call. This prevents us from having to
1226 share a common enum with the compiler. */
1229 transfer_integer (st_parameter_dt *dtp, void *p, int kind)
1231 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1233 dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
1238 transfer_real (st_parameter_dt *dtp, void *p, int kind)
1241 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1243 size = size_from_real_kind (kind);
1244 dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
1249 transfer_logical (st_parameter_dt *dtp, void *p, int kind)
1251 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1253 dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
1258 transfer_character (st_parameter_dt *dtp, void *p, int len)
1260 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1262 /* Currently we support only 1 byte chars, and the library is a bit
1263 confused of character kind vs. length, so we kludge it by setting
1265 dtp->u.p.transfer (dtp, BT_CHARACTER, p, len, len, 1);
1270 transfer_complex (st_parameter_dt *dtp, void *p, int kind)
1273 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1275 size = size_from_complex_kind (kind);
1276 dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
1281 transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
1282 gfc_charlen_type charlen)
1284 index_type count[GFC_MAX_DIMENSIONS];
1285 index_type extent[GFC_MAX_DIMENSIONS];
1286 index_type stride[GFC_MAX_DIMENSIONS];
1287 index_type stride0, rank, size, type, n;
1292 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1295 type = GFC_DESCRIPTOR_TYPE (desc);
1296 size = GFC_DESCRIPTOR_SIZE (desc);
1298 /* FIXME: What a kludge: Array descriptors and the IO library use
1299 different enums for types. */
1302 case GFC_DTYPE_UNKNOWN:
1303 iotype = BT_NULL; /* Is this correct? */
1305 case GFC_DTYPE_INTEGER:
1306 iotype = BT_INTEGER;
1308 case GFC_DTYPE_LOGICAL:
1309 iotype = BT_LOGICAL;
1311 case GFC_DTYPE_REAL:
1314 case GFC_DTYPE_COMPLEX:
1315 iotype = BT_COMPLEX;
1317 case GFC_DTYPE_CHARACTER:
1318 iotype = BT_CHARACTER;
1319 /* FIXME: Currently dtype contains the charlen, which is
1320 clobbered if charlen > 2**24. That's why we use a separate
1321 argument for the charlen. However, if we want to support
1322 non-8-bit charsets we need to fix dtype to contain
1323 sizeof(chartype) and fix the code below. */
1327 case GFC_DTYPE_DERIVED:
1328 internal_error (&dtp->common,
1329 "Derived type I/O should have been handled via the frontend.");
1332 internal_error (&dtp->common, "transfer_array(): Bad type");
1335 rank = GFC_DESCRIPTOR_RANK (desc);
1336 for (n = 0; n < rank; n++)
1339 stride[n] = desc->dim[n].stride;
1340 extent[n] = desc->dim[n].ubound + 1 - desc->dim[n].lbound;
1342 /* If the extent of even one dimension is zero, then the entire
1343 array section contains zero elements, so we return. */
1348 stride0 = stride[0];
1350 /* If the innermost dimension has stride 1, we can do the transfer
1351 in contiguous chunks. */
1357 data = GFC_DESCRIPTOR_DATA (desc);
1361 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
1362 data += stride0 * size * tsize;
1365 while (count[n] == extent[n])
1368 data -= stride[n] * extent[n] * size;
1378 data += stride[n] * size;
1385 /* Preposition a sequential unformatted file while reading. */
1388 us_read (st_parameter_dt *dtp)
1397 if (dtp->u.p.current_unit->endfile == AT_ENDFILE)
1400 if (compile_options.record_marker == 0)
1401 n = sizeof (gfc_offset);
1403 n = compile_options.record_marker;
1407 p = salloc_r (dtp->u.p.current_unit->s, &n);
1411 dtp->u.p.current_unit->endfile = AT_ENDFILE;
1412 return; /* end of file */
1415 if (p == NULL || n != nr)
1417 generate_error (&dtp->common, ERROR_BAD_US, NULL);
1421 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
1422 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
1424 switch (compile_options.record_marker)
1427 memcpy (&i, p, sizeof(gfc_offset));
1430 case sizeof(GFC_INTEGER_4):
1431 memcpy (&i4, p, sizeof (i4));
1435 case sizeof(GFC_INTEGER_8):
1436 memcpy (&i8, p, sizeof (i8));
1441 runtime_error ("Illegal value for record marker");
1446 switch (compile_options.record_marker)
1449 reverse_memcpy (&i, p, sizeof(gfc_offset));
1452 case sizeof(GFC_INTEGER_4):
1453 reverse_memcpy (&i4, p, sizeof (i4));
1457 case sizeof(GFC_INTEGER_8):
1458 reverse_memcpy (&i8, p, sizeof (i8));
1463 runtime_error ("Illegal value for record marker");
1467 dtp->u.p.current_unit->bytes_left = i;
1471 /* Preposition a sequential unformatted file while writing. This
1472 amount to writing a bogus length that will be filled in later. */
1475 us_write (st_parameter_dt *dtp)
1482 if (compile_options.record_marker == 0)
1483 nbytes = sizeof (gfc_offset);
1485 nbytes = compile_options.record_marker ;
1487 if (swrite (dtp->u.p.current_unit->s, &dummy, &nbytes) != 0)
1488 generate_error (&dtp->common, ERROR_OS, NULL);
1490 /* For sequential unformatted, we write until we have more bytes
1491 than can fit in the record markers. If disk space runs out first,
1492 it will error on the write. */
1493 dtp->u.p.current_unit->recl = max_offset;
1495 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1499 /* Position to the next record prior to transfer. We are assumed to
1500 be before the next record. We also calculate the bytes in the next
1504 pre_position (st_parameter_dt *dtp)
1506 if (dtp->u.p.current_unit->current_record)
1507 return; /* Already positioned. */
1509 switch (current_mode (dtp))
1511 case FORMATTED_STREAM:
1512 case UNFORMATTED_STREAM:
1513 /* There are no records with stream I/O. Set the default position
1514 to the beginning of the file if no position was specified. */
1515 if ((dtp->common.flags & IOPARM_DT_HAS_REC) == 0)
1516 dtp->u.p.current_unit->strm_pos = 1;
1519 case UNFORMATTED_SEQUENTIAL:
1520 if (dtp->u.p.mode == READING)
1527 case FORMATTED_SEQUENTIAL:
1528 case FORMATTED_DIRECT:
1529 case UNFORMATTED_DIRECT:
1530 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
1534 dtp->u.p.current_unit->current_record = 1;
1538 /* Initialize things for a data transfer. This code is common for
1539 both reading and writing. */
1542 data_transfer_init (st_parameter_dt *dtp, int read_flag)
1544 unit_flags u_flags; /* Used for creating a unit if needed. */
1545 GFC_INTEGER_4 cf = dtp->common.flags;
1546 namelist_info *ionml;
1548 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
1549 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
1550 dtp->u.p.ionml = ionml;
1551 dtp->u.p.mode = read_flag ? READING : WRITING;
1553 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1554 dtp->u.p.size_used = 0; /* Initialize the count. */
1556 dtp->u.p.current_unit = get_unit (dtp, 1);
1557 if (dtp->u.p.current_unit->s == NULL)
1558 { /* Open the unit with some default flags. */
1559 st_parameter_open opp;
1562 if (dtp->common.unit < 0)
1564 close_unit (dtp->u.p.current_unit);
1565 dtp->u.p.current_unit = NULL;
1566 generate_error (&dtp->common, ERROR_BAD_OPTION,
1567 "Bad unit number in OPEN statement");
1570 memset (&u_flags, '\0', sizeof (u_flags));
1571 u_flags.access = ACCESS_SEQUENTIAL;
1572 u_flags.action = ACTION_READWRITE;
1574 /* Is it unformatted? */
1575 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
1576 | IOPARM_DT_IONML_SET)))
1577 u_flags.form = FORM_UNFORMATTED;
1579 u_flags.form = FORM_UNSPECIFIED;
1581 u_flags.delim = DELIM_UNSPECIFIED;
1582 u_flags.blank = BLANK_UNSPECIFIED;
1583 u_flags.pad = PAD_UNSPECIFIED;
1584 u_flags.status = STATUS_UNKNOWN;
1586 conv = get_unformatted_convert (dtp->common.unit);
1588 if (conv == CONVERT_NONE)
1589 conv = compile_options.convert;
1591 /* We use l8_to_l4_offset, which is 0 on little-endian machines
1592 and 1 on big-endian machines. */
1595 case CONVERT_NATIVE:
1600 conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
1603 case CONVERT_LITTLE:
1604 conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
1608 internal_error (&opp.common, "Illegal value for CONVERT");
1612 u_flags.convert = conv;
1614 opp.common = dtp->common;
1615 opp.common.flags &= IOPARM_COMMON_MASK;
1616 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
1617 dtp->common.flags &= ~IOPARM_COMMON_MASK;
1618 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
1619 if (dtp->u.p.current_unit == NULL)
1623 /* Check the action. */
1625 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
1626 generate_error (&dtp->common, ERROR_BAD_ACTION,
1627 "Cannot read from file opened for WRITE");
1629 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
1630 generate_error (&dtp->common, ERROR_BAD_ACTION,
1631 "Cannot write to file opened for READ");
1633 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1636 dtp->u.p.first_item = 1;
1638 /* Check the format. */
1640 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1643 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1646 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
1647 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1649 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1650 "Format present for UNFORMATTED data transfer");
1652 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
1654 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1655 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1656 "A format cannot be specified with a namelist");
1658 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
1659 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
1660 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1661 "Missing format for FORMATTED data transfer");
1663 if (is_internal_unit (dtp)
1664 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1665 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1666 "Internal file cannot be accessed by UNFORMATTED data transfer");
1668 /* Check the record or position number. */
1670 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
1671 && (cf & IOPARM_DT_HAS_REC) == 0)
1673 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1674 "Direct access data transfer requires record number");
1678 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1679 && (cf & IOPARM_DT_HAS_REC) != 0)
1681 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1682 "Record number not allowed for sequential access data transfer");
1686 /* Process the ADVANCE option. */
1688 dtp->u.p.advance_status
1689 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
1690 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
1691 "Bad ADVANCE parameter in data transfer statement");
1693 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
1695 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
1696 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1697 "ADVANCE specification conflicts with sequential access");
1699 if (is_internal_unit (dtp))
1700 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1701 "ADVANCE specification conflicts with internal file");
1703 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
1704 != IOPARM_DT_HAS_FORMAT)
1705 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1706 "ADVANCE specification requires an explicit format");
1711 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1712 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1713 "EOR specification requires an ADVANCE specification of NO");
1715 if ((cf & IOPARM_DT_HAS_SIZE) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
1716 generate_error (&dtp->common, ERROR_MISSING_OPTION,
1717 "SIZE specification requires an ADVANCE specification of NO");
1721 { /* Write constraints. */
1722 if ((cf & IOPARM_END) != 0)
1723 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1724 "END specification cannot appear in a write statement");
1726 if ((cf & IOPARM_EOR) != 0)
1727 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1728 "EOR specification cannot appear in a write statement");
1730 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
1731 generate_error (&dtp->common, ERROR_OPTION_CONFLICT,
1732 "SIZE specification cannot appear in a write statement");
1735 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
1736 dtp->u.p.advance_status = ADVANCE_YES;
1737 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1740 /* Sanity checks on the record number. */
1741 if ((cf & IOPARM_DT_HAS_REC) != 0)
1745 generate_error (&dtp->common, ERROR_BAD_OPTION,
1746 "Record number must be positive");
1750 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
1752 generate_error (&dtp->common, ERROR_BAD_OPTION,
1753 "Record number too large");
1757 /* Check to see if we might be reading what we wrote before */
1759 if (dtp->u.p.mode == READING
1760 && dtp->u.p.current_unit->mode == WRITING
1761 && !is_internal_unit (dtp))
1762 flush(dtp->u.p.current_unit->s);
1764 /* Check whether the record exists to be read. Only
1765 a partial record needs to exist. */
1767 if (dtp->u.p.mode == READING && (dtp->rec -1)
1768 * dtp->u.p.current_unit->recl >= file_length (dtp->u.p.current_unit->s))
1770 generate_error (&dtp->common, ERROR_BAD_OPTION,
1771 "Non-existing record number");
1775 /* Position the file. */
1776 if (!is_stream_io (dtp))
1778 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
1779 * dtp->u.p.current_unit->recl) == FAILURE)
1781 generate_error (&dtp->common, ERROR_OS, NULL);
1786 dtp->u.p.current_unit->strm_pos = dtp->rec;
1790 /* Overwriting an existing sequential file ?
1791 it is always safe to truncate the file on the first write */
1792 if (dtp->u.p.mode == WRITING
1793 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL
1794 && dtp->u.p.current_unit->last_record == 0
1795 && !is_preconnected(dtp->u.p.current_unit->s))
1796 struncate(dtp->u.p.current_unit->s);
1798 /* Bugware for badly written mixed C-Fortran I/O. */
1799 flush_if_preconnected(dtp->u.p.current_unit->s);
1801 dtp->u.p.current_unit->mode = dtp->u.p.mode;
1803 /* Set the initial value of flags. */
1805 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
1806 dtp->u.p.sign_status = SIGN_S;
1810 /* Set up the subroutine that will handle the transfers. */
1814 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1815 dtp->u.p.transfer = unformatted_read;
1818 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1819 dtp->u.p.transfer = list_formatted_read;
1821 dtp->u.p.transfer = formatted_transfer;
1826 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
1827 dtp->u.p.transfer = unformatted_write;
1830 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
1831 dtp->u.p.transfer = list_formatted_write;
1833 dtp->u.p.transfer = formatted_transfer;
1837 /* Make sure that we don't do a read after a nonadvancing write. */
1841 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
1843 generate_error (&dtp->common, ERROR_BAD_OPTION,
1844 "Cannot READ after a nonadvancing WRITE");
1850 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
1851 dtp->u.p.current_unit->read_bad = 1;
1854 /* Start the data transfer if we are doing a formatted transfer. */
1855 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
1856 && ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0)
1857 && dtp->u.p.ionml == NULL)
1858 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
1861 /* Initialize an array_loop_spec given the array descriptor. The function
1862 returns the index of the last element of the array. */
1865 init_loop_spec (gfc_array_char *desc, array_loop_spec *ls)
1867 int rank = GFC_DESCRIPTOR_RANK(desc);
1872 for (i=0; i<rank; i++)
1875 ls[i].start = desc->dim[i].lbound;
1876 ls[i].end = desc->dim[i].ubound;
1877 ls[i].step = desc->dim[i].stride;
1879 index += (desc->dim[i].ubound - desc->dim[i].lbound)
1880 * desc->dim[i].stride;
1885 /* Determine the index to the next record in an internal unit array by
1886 by incrementing through the array_loop_spec. TODO: Implement handling
1887 negative strides. */
1890 next_array_record (st_parameter_dt *dtp, array_loop_spec *ls)
1898 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
1903 if (ls[i].idx > ls[i].end)
1905 ls[i].idx = ls[i].start;
1911 index = index + (ls[i].idx - 1) * ls[i].step;
1916 /* Space to the next record for read mode. If the file is not
1917 seekable, we read MAX_READ chunks until we get to the right
1920 #define MAX_READ 4096
1923 next_record_r (st_parameter_dt *dtp)
1925 gfc_offset new, record;
1926 int bytes_left, rlength, length;
1929 switch (current_mode (dtp))
1931 /* No records in unformatted STREAM I/O. */
1932 case UNFORMATTED_STREAM:
1935 case UNFORMATTED_SEQUENTIAL:
1937 /* Skip over tail */
1938 dtp->u.p.current_unit->bytes_left +=
1939 compile_options.record_marker == 0 ?
1940 sizeof (gfc_offset) : compile_options.record_marker;
1942 /* Fall through... */
1944 case FORMATTED_DIRECT:
1945 case UNFORMATTED_DIRECT:
1946 if (dtp->u.p.current_unit->bytes_left == 0)
1949 if (is_seekable (dtp->u.p.current_unit->s))
1951 new = file_position (dtp->u.p.current_unit->s)
1952 + dtp->u.p.current_unit->bytes_left;
1954 /* Direct access files do not generate END conditions,
1956 if (sseek (dtp->u.p.current_unit->s, new) == FAILURE)
1957 generate_error (&dtp->common, ERROR_OS, NULL);
1961 { /* Seek by reading data. */
1962 while (dtp->u.p.current_unit->bytes_left > 0)
1964 rlength = length = (MAX_READ > dtp->u.p.current_unit->bytes_left) ?
1965 MAX_READ : dtp->u.p.current_unit->bytes_left;
1967 p = salloc_r (dtp->u.p.current_unit->s, &rlength);
1970 generate_error (&dtp->common, ERROR_OS, NULL);
1974 dtp->u.p.current_unit->bytes_left -= length;
1979 case FORMATTED_STREAM:
1980 case FORMATTED_SEQUENTIAL:
1982 /* sf_read has already terminated input because of an '\n' */
1983 if (dtp->u.p.sf_seen_eor)
1985 dtp->u.p.sf_seen_eor = 0;
1989 if (is_internal_unit (dtp))
1991 if (is_array_io (dtp))
1993 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
1995 /* Now seek to this record. */
1996 record = record * dtp->u.p.current_unit->recl;
1997 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
1999 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2002 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2006 bytes_left = (int) dtp->u.p.current_unit->bytes_left;
2007 p = salloc_r (dtp->u.p.current_unit->s, &bytes_left);
2009 dtp->u.p.current_unit->bytes_left
2010 = dtp->u.p.current_unit->recl;
2016 p = salloc_r (dtp->u.p.current_unit->s, &length);
2020 generate_error (&dtp->common, ERROR_OS, NULL);
2026 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2030 if (is_stream_io (dtp))
2031 dtp->u.p.current_unit->strm_pos++;
2038 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2039 test_endfile (dtp->u.p.current_unit);
2043 /* Small utility function to write a record marker, taking care of
2044 byte swapping and of choosing the correct size. */
2047 write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
2052 char p[sizeof (GFC_INTEGER_8)];
2054 if (compile_options.record_marker == 0)
2055 len = sizeof (gfc_offset);
2057 len = compile_options.record_marker;
2059 /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here. */
2060 if (dtp->u.p.current_unit->flags.convert == CONVERT_NATIVE)
2062 switch (compile_options.record_marker)
2065 return swrite (dtp->u.p.current_unit->s, &buf, &len);
2068 case sizeof (GFC_INTEGER_4):
2070 return swrite (dtp->u.p.current_unit->s, &buf4, &len);
2073 case sizeof (GFC_INTEGER_8):
2075 return swrite (dtp->u.p.current_unit->s, &buf8, &len);
2079 runtime_error ("Illegal value for record marker");
2085 switch (compile_options.record_marker)
2088 reverse_memcpy (p, &buf, sizeof (gfc_offset));
2089 return swrite (dtp->u.p.current_unit->s, p, &len);
2092 case sizeof (GFC_INTEGER_4):
2094 reverse_memcpy (p, &buf4, sizeof (GFC_INTEGER_4));
2095 return swrite (dtp->u.p.current_unit->s, p, &len);
2098 case sizeof (GFC_INTEGER_8):
2100 reverse_memcpy (p, &buf8, sizeof (GFC_INTEGER_4));
2101 return swrite (dtp->u.p.current_unit->s, p, &len);
2105 runtime_error ("Illegal value for record marker");
2113 /* Position to the next record in write mode. */
2116 next_record_w (st_parameter_dt *dtp, int done)
2118 gfc_offset c, m, record, max_pos;
2121 size_t record_marker;
2123 /* Zero counters for X- and T-editing. */
2124 max_pos = dtp->u.p.max_pos;
2125 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2127 switch (current_mode (dtp))
2129 /* No records in unformatted STREAM I/O. */
2130 case UNFORMATTED_STREAM:
2133 case FORMATTED_DIRECT:
2134 if (dtp->u.p.current_unit->bytes_left == 0)
2137 if (sset (dtp->u.p.current_unit->s, ' ',
2138 dtp->u.p.current_unit->bytes_left) == FAILURE)
2143 case UNFORMATTED_DIRECT:
2144 if (sfree (dtp->u.p.current_unit->s) == FAILURE)
2148 case UNFORMATTED_SEQUENTIAL:
2149 /* Bytes written. */
2150 m = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
2151 c = file_position (dtp->u.p.current_unit->s);
2153 /* Write the length tail. */
2155 if (write_us_marker (dtp, m) != 0)
2158 if (compile_options.record_marker == 4)
2159 record_marker = sizeof(GFC_INTEGER_4);
2161 record_marker = sizeof (gfc_offset);
2163 /* Seek to the head and overwrite the bogus length with the real
2166 if (sseek (dtp->u.p.current_unit->s, c - m - record_marker)
2170 if (write_us_marker (dtp, m) != 0)
2173 /* Seek past the end of the current record. */
2175 if (sseek (dtp->u.p.current_unit->s, c + record_marker) == FAILURE)
2180 case FORMATTED_STREAM:
2181 case FORMATTED_SEQUENTIAL:
2183 if (is_internal_unit (dtp))
2185 if (is_array_io (dtp))
2187 length = (int) dtp->u.p.current_unit->bytes_left;
2189 /* If the farthest position reached is greater than current
2190 position, adjust the position and set length to pad out
2191 whats left. Otherwise just pad whats left.
2192 (for character array unit) */
2193 m = dtp->u.p.current_unit->recl
2194 - dtp->u.p.current_unit->bytes_left;
2197 length = (int) (max_pos - m);
2198 p = salloc_w (dtp->u.p.current_unit->s, &length);
2199 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2202 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2204 generate_error (&dtp->common, ERROR_END, NULL);
2208 /* Now that the current record has been padded out,
2209 determine where the next record in the array is. */
2210 record = next_array_record (dtp, dtp->u.p.current_unit->ls);
2212 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2214 /* Now seek to this record */
2215 record = record * dtp->u.p.current_unit->recl;
2217 if (sseek (dtp->u.p.current_unit->s, record) == FAILURE)
2219 generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
2223 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
2229 /* If this is the last call to next_record move to the farthest
2230 position reached and set length to pad out the remainder
2231 of the record. (for character scaler unit) */
2234 m = dtp->u.p.current_unit->recl
2235 - dtp->u.p.current_unit->bytes_left;
2238 length = (int) (max_pos - m);
2239 p = salloc_w (dtp->u.p.current_unit->s, &length);
2240 length = (int) (dtp->u.p.current_unit->recl - max_pos);
2243 length = (int) dtp->u.p.current_unit->bytes_left;
2245 if (sset (dtp->u.p.current_unit->s, ' ', length) == FAILURE)
2247 generate_error (&dtp->common, ERROR_END, NULL);
2255 /* If this is the last call to next_record move to the farthest
2256 position reached in preparation for completing the record.
2260 m = dtp->u.p.current_unit->recl -
2261 dtp->u.p.current_unit->bytes_left;
2264 length = (int) (max_pos - m);
2265 p = salloc_w (dtp->u.p.current_unit->s, &length);
2269 const char crlf[] = "\r\n";
2275 if (swrite (dtp->u.p.current_unit->s, &crlf[2-len], &len) != 0)
2278 if (is_stream_io (dtp))
2279 dtp->u.p.current_unit->strm_pos += len;
2285 generate_error (&dtp->common, ERROR_OS, NULL);
2290 /* Position to the next record, which means moving to the end of the
2291 current record. This can happen under several different
2292 conditions. If the done flag is not set, we get ready to process
2296 next_record (st_parameter_dt *dtp, int done)
2298 gfc_offset fp; /* File position. */
2300 dtp->u.p.current_unit->read_bad = 0;
2302 if (dtp->u.p.mode == READING)
2303 next_record_r (dtp);
2305 next_record_w (dtp, done);
2307 if (!is_stream_io (dtp))
2309 /* keep position up to date for INQUIRE */
2310 dtp->u.p.current_unit->flags.position = POSITION_ASIS;
2311 dtp->u.p.current_unit->current_record = 0;
2312 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
2314 fp = file_position (dtp->u.p.current_unit->s);
2315 /* Calculate next record, rounding up partial records. */
2316 dtp->u.p.current_unit->last_record =
2317 (fp + dtp->u.p.current_unit->recl - 1) /
2318 dtp->u.p.current_unit->recl;
2321 dtp->u.p.current_unit->last_record++;
2329 /* Finalize the current data transfer. For a nonadvancing transfer,
2330 this means advancing to the next record. For internal units close the
2331 stream associated with the unit. */
2334 finalize_transfer (st_parameter_dt *dtp)
2337 GFC_INTEGER_4 cf = dtp->common.flags;
2339 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
2340 *dtp->size = (GFC_INTEGER_4) dtp->u.p.size_used;
2342 if (dtp->u.p.eor_condition)
2344 generate_error (&dtp->common, ERROR_EOR, NULL);
2348 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2351 if ((dtp->u.p.ionml != NULL)
2352 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
2354 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
2355 namelist_read (dtp);
2357 namelist_write (dtp);
2360 dtp->u.p.transfer = NULL;
2361 if (dtp->u.p.current_unit == NULL)
2364 dtp->u.p.eof_jump = &eof_jump;
2365 if (setjmp (eof_jump))
2367 generate_error (&dtp->common, ERROR_END, NULL);
2371 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
2372 finish_list_read (dtp);
2373 else if (!is_stream_io (dtp))
2375 dtp->u.p.current_unit->current_record = 0;
2376 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
2378 /* Most systems buffer lines, so force the partial record
2379 to be written out. */
2380 if (!is_internal_unit (dtp))
2381 flush (dtp->u.p.current_unit->s);
2382 dtp->u.p.seen_dollar = 0;
2385 next_record (dtp, 1);
2389 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
2390 next_record (dtp, 1);
2391 flush (dtp->u.p.current_unit->s);
2394 sfree (dtp->u.p.current_unit->s);
2397 /* Transfer function for IOLENGTH. It doesn't actually do any
2398 data transfer, it just updates the length counter. */
2401 iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
2402 void *dest __attribute__ ((unused)),
2403 int kind __attribute__((unused)),
2404 size_t size, size_t nelems)
2406 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2407 *dtp->iolength += (GFC_INTEGER_4) size * nelems;
2411 /* Initialize the IOLENGTH data transfer. This function is in essence
2412 a very much simplified version of data_transfer_init(), because it
2413 doesn't have to deal with units at all. */
2416 iolength_transfer_init (st_parameter_dt *dtp)
2418 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
2421 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
2423 /* Set up the subroutine that will handle the transfers. */
2425 dtp->u.p.transfer = iolength_transfer;
2429 /* Library entry point for the IOLENGTH form of the INQUIRE
2430 statement. The IOLENGTH form requires no I/O to be performed, but
2431 it must still be a runtime library call so that we can determine
2432 the iolength for dynamic arrays and such. */
2434 extern void st_iolength (st_parameter_dt *);
2435 export_proto(st_iolength);
2438 st_iolength (st_parameter_dt *dtp)
2440 library_start (&dtp->common);
2441 iolength_transfer_init (dtp);
2444 extern void st_iolength_done (st_parameter_dt *);
2445 export_proto(st_iolength_done);
2448 st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
2451 if (dtp->u.p.scratch != NULL)
2452 free_mem (dtp->u.p.scratch);
2457 /* The READ statement. */
2459 extern void st_read (st_parameter_dt *);
2460 export_proto(st_read);
2463 st_read (st_parameter_dt *dtp)
2465 library_start (&dtp->common);
2467 data_transfer_init (dtp, 1);
2469 /* Handle complications dealing with the endfile record. It is
2470 significant that this is the only place where ERROR_END is
2471 generated. Reading an end of file elsewhere is either end of
2472 record or an I/O error. */
2474 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2475 switch (dtp->u.p.current_unit->endfile)
2481 if (!is_internal_unit (dtp))
2483 generate_error (&dtp->common, ERROR_END, NULL);
2484 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
2485 dtp->u.p.current_unit->current_record = 0;
2490 generate_error (&dtp->common, ERROR_ENDFILE, NULL);
2491 dtp->u.p.current_unit->current_record = 0;
2496 extern void st_read_done (st_parameter_dt *);
2497 export_proto(st_read_done);
2500 st_read_done (st_parameter_dt *dtp)
2502 finalize_transfer (dtp);
2503 free_format_data (dtp);
2505 if (dtp->u.p.scratch != NULL)
2506 free_mem (dtp->u.p.scratch);
2507 if (dtp->u.p.current_unit != NULL)
2508 unlock_unit (dtp->u.p.current_unit);
2510 free_internal_unit (dtp);
2515 extern void st_write (st_parameter_dt *);
2516 export_proto(st_write);
2519 st_write (st_parameter_dt *dtp)
2521 library_start (&dtp->common);
2522 data_transfer_init (dtp, 0);
2525 extern void st_write_done (st_parameter_dt *);
2526 export_proto(st_write_done);
2529 st_write_done (st_parameter_dt *dtp)
2531 finalize_transfer (dtp);
2533 /* Deal with endfile conditions associated with sequential files. */
2535 if (dtp->u.p.current_unit != NULL
2536 && dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
2537 switch (dtp->u.p.current_unit->endfile)
2539 case AT_ENDFILE: /* Remain at the endfile record. */
2543 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
2547 /* Get rid of whatever is after this record. */
2548 if (!is_internal_unit (dtp))
2550 flush (dtp->u.p.current_unit->s);
2551 if (struncate (dtp->u.p.current_unit->s) == FAILURE)
2552 generate_error (&dtp->common, ERROR_OS, NULL);
2554 dtp->u.p.current_unit->endfile = AT_ENDFILE;
2558 free_format_data (dtp);
2560 if (dtp->u.p.scratch != NULL)
2561 free_mem (dtp->u.p.scratch);
2562 if (dtp->u.p.current_unit != NULL)
2563 unlock_unit (dtp->u.p.current_unit);
2565 free_internal_unit (dtp);
2570 /* Receives the scalar information for namelist objects and stores it
2571 in a linked list of namelist_info types. */
2573 extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
2574 GFC_INTEGER_4, gfc_charlen_type, GFC_INTEGER_4);
2575 export_proto(st_set_nml_var);
2579 st_set_nml_var (st_parameter_dt *dtp, void * var_addr, char * var_name,
2580 GFC_INTEGER_4 len, gfc_charlen_type string_length,
2581 GFC_INTEGER_4 dtype)
2583 namelist_info *t1 = NULL;
2586 nml = (namelist_info*) get_mem (sizeof (namelist_info));
2588 nml->mem_pos = var_addr;
2590 nml->var_name = (char*) get_mem (strlen (var_name) + 1);
2591 strcpy (nml->var_name, var_name);
2593 nml->len = (int) len;
2594 nml->string_length = (index_type) string_length;
2596 nml->var_rank = (int) (dtype & GFC_DTYPE_RANK_MASK);
2597 nml->size = (index_type) (dtype >> GFC_DTYPE_SIZE_SHIFT);
2598 nml->type = (bt) ((dtype & GFC_DTYPE_TYPE_MASK) >> GFC_DTYPE_TYPE_SHIFT);
2600 if (nml->var_rank > 0)
2602 nml->dim = (descriptor_dimension*)
2603 get_mem (nml->var_rank * sizeof (descriptor_dimension));
2604 nml->ls = (array_loop_spec*)
2605 get_mem (nml->var_rank * sizeof (array_loop_spec));
2615 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
2617 dtp->common.flags |= IOPARM_DT_IONML_SET;
2618 dtp->u.p.ionml = nml;
2622 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
2627 /* Store the dimensional information for the namelist object. */
2628 extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
2629 GFC_INTEGER_4, GFC_INTEGER_4,
2631 export_proto(st_set_nml_var_dim);
2634 st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
2635 GFC_INTEGER_4 stride, GFC_INTEGER_4 lbound,
2636 GFC_INTEGER_4 ubound)
2638 namelist_info * nml;
2643 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
2645 nml->dim[n].stride = (ssize_t)stride;
2646 nml->dim[n].lbound = (ssize_t)lbound;
2647 nml->dim[n].ubound = (ssize_t)ubound;
2650 /* Reverse memcpy - used for byte swapping. */
2652 void reverse_memcpy (void *dest, const void *src, size_t n)
2658 s = (char *) src + n - 1;
2660 /* Write with ascending order - this is likely faster
2661 on modern architectures because of write combining. */