]> git.ipfire.org Git - thirdparty/gcc.git/blame - libgfortran/io/transfer.c
projects / thirdparty / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
PR fortran/95104 - Segfault on a legal WAIT statement
[thirdparty/gcc.git] / libgfortran / io / transfer.c
CommitLineData
8d9254fc 1/* Copyright (C) 2002-2020 Free Software Foundation, Inc.
6de9cd9a 2 Contributed by Andy Vaught
29dc5138 3 Namelist transfer functions contributed by Paul Thomas
10256cbe 4 F2003 I/O support contributed by Jerry DeLisle
6de9cd9a 5
58fc89f6 6This file is part of the GNU Fortran runtime library (libgfortran).
6de9cd9a
DN		 7
8Libgfortran is free software; you can redistribute it and/or modify
9it under the terms of the GNU General Public License as published by
748086b7 10the Free Software Foundation; either version 3, or (at your option)
6de9cd9a
DN		 11any later version.
12
13Libgfortran is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16GNU General Public License for more details.
17
748086b7
JJ		 18Under Section 7 of GPL version 3, you are granted additional
19permissions described in the GCC Runtime Library Exception, version
203.1, as published by the Free Software Foundation.
21
22You should have received a copy of the GNU General Public License and
23a copy of the GCC Runtime Library Exception along with this program;
24see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25<http://www.gnu.org/licenses/>. */
6de9cd9a
DN		 26
27
7fcb1804 28/* transfer.c -- Top level handling of data transfer statements. */
6de9cd9a 29
36ae8a61 30#include "io.h"
92cbdb68
JB		 31#include "fbuf.h"
32#include "format.h"
33#include "unix.h"
2b4c9065 34#include "async.h"
6de9cd9a 35#include <string.h>
7812c78c 36#include <errno.h>
6de9cd9a
DN		 37
38
39/* Calling conventions: Data transfer statements are unlike other
7fcb1804
TS		 40 library calls in that they extend over several calls.
41
42 The first call is always a call to st_read() or st_write(). These
43 subroutines return no status unless a namelist read or write is
44 being done, in which case there is the usual status. No further
45 calls are necessary in this case.
46
47 For other sorts of data transfer, there are zero or more data
48 transfer statement that depend on the format of the data transfer
1ec601bf 49 statement. For READ (and for backwards compatibily: for WRITE), one has
7fcb1804
TS		 50
51 transfer_integer
52 transfer_logical
53 transfer_character
cea93abb 54 transfer_character_wide
7fcb1804
TS		 55 transfer_real
56 transfer_complex
1ec601bf
FXC		 57 transfer_real128
58 transfer_complex128
e73d3ca6 59
1ec601bf
FXC		 60 and for WRITE
61
62 transfer_integer_write
63 transfer_logical_write
64 transfer_character_write
65 transfer_character_wide_write
66 transfer_real_write
67 transfer_complex_write
68 transfer_real128_write
69 transfer_complex128_write
70
71 These subroutines do not return status. The *128 functions
72 are in the file transfer128.c.
7fcb1804
TS		 73
74 The last call is a call to st_[read|write]_done(). While
75 something can easily go wrong with the initial st_read() or
76 st_write(), an error inhibits any data from actually being
77 transferred. */
6de9cd9a 78
5e805e44 79extern void transfer_integer (st_parameter_dt *, void *, int);
7d7b8bfe
RH		 80export_proto(transfer_integer);
81
6eb6875d
TK		 82extern void transfer_integer_write (st_parameter_dt *, void *, int);
83export_proto(transfer_integer_write);
84
5e805e44 85extern void transfer_real (st_parameter_dt *, void *, int);
7d7b8bfe
RH		 86export_proto(transfer_real);
87
6eb6875d
TK		 88extern void transfer_real_write (st_parameter_dt *, void *, int);
89export_proto(transfer_real_write);
90
5e805e44 91extern void transfer_logical (st_parameter_dt *, void *, int);
7d7b8bfe
RH		 92export_proto(transfer_logical);
93
6eb6875d
TK		 94extern void transfer_logical_write (st_parameter_dt *, void *, int);
95export_proto(transfer_logical_write);
96
f622221a 97extern void transfer_character (st_parameter_dt *, void *, gfc_charlen_type);
7d7b8bfe
RH		 98export_proto(transfer_character);
99
f622221a 100extern void transfer_character_write (st_parameter_dt *, void *, gfc_charlen_type);
6eb6875d
TK		 101export_proto(transfer_character_write);
102
f622221a 103extern void transfer_character_wide (st_parameter_dt *, void *, gfc_charlen_type, int);
cea93abb
JD		 104export_proto(transfer_character_wide);
105
6eb6875d 106extern void transfer_character_wide_write (st_parameter_dt *,
f622221a 107 void *, gfc_charlen_type, int);
6eb6875d
TK		 108export_proto(transfer_character_wide_write);
109
5e805e44 110extern void transfer_complex (st_parameter_dt *, void *, int);
7d7b8bfe
RH		 111export_proto(transfer_complex);
112
6eb6875d
TK		 113extern void transfer_complex_write (st_parameter_dt *, void *, int);
114export_proto(transfer_complex_write);
115
5e805e44
JJ		 116extern void transfer_array (st_parameter_dt *, gfc_array_char *, int,
117 gfc_charlen_type);
18623fae
JB		 118export_proto(transfer_array);
119
6eb6875d
TK		 120extern void transfer_array_write (st_parameter_dt *, gfc_array_char *, int,
121 gfc_charlen_type);
122export_proto(transfer_array_write);
123
e73d3ca6
PT		 124/* User defined derived type input/output. */
125extern void
126transfer_derived (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
127export_proto(transfer_derived);
128
129extern void
130transfer_derived_write (st_parameter_dt *dtp, void *dtio_source, void *dtio_proc);
131export_proto(transfer_derived_write);
132
07b3bbf2
TK		 133static void us_read (st_parameter_dt *, int);
134static void us_write (st_parameter_dt *, int);
135static void next_record_r_unf (st_parameter_dt *, int);
136static void next_record_w_unf (st_parameter_dt *, int);
137
09003779 138static const st_option advance_opt[] = {
6de9cd9a
DN		 139 {"yes", ADVANCE_YES},
140 {"no", ADVANCE_NO},
4b6903ec 141 {NULL, 0}
6de9cd9a
DN		 142};
143
144
10256cbe
JD		 145static const st_option decimal_opt[] = {
146 {"point", DECIMAL_POINT},
147 {"comma", DECIMAL_COMMA},
148 {NULL, 0}
149};
150
379924dd
JD		 151static const st_option round_opt[] = {
152 {"up", ROUND_UP},
153 {"down", ROUND_DOWN},
154 {"zero", ROUND_ZERO},
155 {"nearest", ROUND_NEAREST},
156 {"compatible", ROUND_COMPATIBLE},
157 {"processor_defined", ROUND_PROCDEFINED},
158 {NULL, 0}
159};
160
10256cbe
JD		 161
162static const st_option sign_opt[] = {
163 {"plus", SIGN_SP},
164 {"suppress", SIGN_SS},
165 {"processor_defined", SIGN_S},
166 {NULL, 0}
167};
168
169static const st_option blank_opt[] = {
170 {"null", BLANK_NULL},
171 {"zero", BLANK_ZERO},
172 {NULL, 0}
173};
174
931149a6
JD		 175static const st_option delim_opt[] = {
176 {"apostrophe", DELIM_APOSTROPHE},
177 {"quote", DELIM_QUOTE},
178 {"none", DELIM_NONE},
179 {NULL, 0}
180};
181
182static const st_option pad_opt[] = {
183 {"yes", PAD_YES},
184 {"no", PAD_NO},
185 {NULL, 0}
186};
187
2b4c9065
NK		 188static const st_option async_opt[] = {
189 {"yes", ASYNC_YES},
190 {"no", ASYNC_NO},
191 {NULL, 0}
192};
193
6de9cd9a
DN		 194typedef enum
195{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
60674b3f
JD		 196 FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM,
197 UNFORMATTED_STREAM, FORMATTED_UNSPECIFIED
6de9cd9a
DN		 198}
199file_mode;
200
201
202static file_mode
5e805e44 203current_mode (st_parameter_dt *dtp)
6de9cd9a
DN		 204{
205 file_mode m;
206
60674b3f 207 m = FORMATTED_UNSPECIFIED;
91b30ee5 208
5e805e44 209 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
6de9cd9a 210 {
5e805e44 211 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
6de9cd9a
DN		 212 FORMATTED_DIRECT : UNFORMATTED_DIRECT;
213 }
91b30ee5 214 else if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
6de9cd9a 215 {
5e805e44 216 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
6de9cd9a
DN		 217 FORMATTED_SEQUENTIAL : UNFORMATTED_SEQUENTIAL;
218 }
91b30ee5
JD		 219 else if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
220 {
221 m = dtp->u.p.current_unit->flags.form == FORM_FORMATTED ?
222 FORMATTED_STREAM : UNFORMATTED_STREAM;
223 }
6de9cd9a
DN		 224
225 return m;
226}
227
228
59011a60 229/* Mid level data transfer statements. */
7fcb1804 230
59011a60 231/* Read sequential file - internal unit */
6de9cd9a 232
bf71e8f0 233static char *
ea99ec5b 234read_sf_internal (st_parameter_dt *dtp, size_t *length)
6de9cd9a 235{
7812c78c 236 static char *empty_string[0];
1f10d710 237 char *base = NULL;
ea99ec5b 238 size_t lorig;
59011a60
JD		 239
240 /* Zero size array gives internal unit len of 0. Nothing to read. */
241 if (dtp->internal_unit_len == 0
242 && dtp->u.p.current_unit->pad_status == PAD_NO)
243 hit_eof (dtp);
6de9cd9a 244
1f10d710
JD		 245 /* There are some cases with mixed DTIO where we have read a character
246 and saved it in the last character buffer, so we need to backup. */
247 if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
248 dtp->u.p.current_unit->last_char != EOF - 1))
249 {
250 dtp->u.p.current_unit->last_char = EOF - 1;
251 sseek (dtp->u.p.current_unit->s, -1, SEEK_CUR);
252 }
253
3f328462
JD		 254 /* To support legacy code we have to scan the input string one byte
255 at a time because we don't know where an early comma may be and the
256 requested length could go past the end of a comma shortened
257 string. We only do this if -std=legacy was given at compile
258 time. We also do not support this on kind=4 strings. */
3f328462 259 if (unlikely(compile_options.warn_std == 0)) // the slow legacy way.
74db2a47 260 {
3f328462
JD		 261 size_t n;
262 size_t tmp = 1;
263 char *q;
264
265 /* If we have seen an eor previously, return a length of 0. The
266 caller is responsible for correctly padding the input field. */
267 if (dtp->u.p.sf_seen_eor)
268 {
269 *length = 0;
270 /* Just return something that isn't a NULL pointer, otherwise the
271 caller thinks an error occurred. */
272 return (char*) empty_string;
273 }
274
275 /* Get the first character of the string to establish the base
276 address and check for comma or end-of-record condition. */
277 base = mem_alloc_r (dtp->u.p.current_unit->s, &tmp);
278 if (tmp == 0)
279 {
280 dtp->u.p.sf_seen_eor = 1;
281 *length = 0;
282 return (char*) empty_string;
283 }
284 if (*base == ',')
285 {
286 dtp->u.p.current_unit->bytes_left--;
287 *length = 0;
288 return (char*) empty_string;
289 }
290
291 /* Now we scan the rest and deal with either an end-of-file
292 condition or a comma, as needed. */
293 for (n = 1; n < *length; n++)
294 {
295 q = mem_alloc_r (dtp->u.p.current_unit->s, &tmp);
296 if (tmp == 0)
297 {
298 hit_eof (dtp);
299 return NULL;
300 }
301 if (*q == ',')
302 {
303 dtp->u.p.current_unit->bytes_left -= n;
304 *length = n;
305 break;
306 }
307 }
74db2a47 308 }
3f328462 309 else // the fast way
d10fb73e 310 {
3f328462
JD		 311 lorig = *length;
312 if (is_char4_unit(dtp))
313 {
314 gfc_char4_t *p = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s,
315 length);
316 base = fbuf_alloc (dtp->u.p.current_unit, lorig);
317 for (size_t i = 0; i < *length; i++, p++)
318 base[i] = *p > 255 ? '?' : (unsigned char) *p;
319 }
320 else
321 base = mem_alloc_r (dtp->u.p.current_unit->s, length);
322
323 if (unlikely (lorig > *length))
324 {
325 hit_eof (dtp);
326 return NULL;
327 }
59011a60
JD		 328 }
329
330 dtp->u.p.current_unit->bytes_left -= *length;
331
c680ada5
JD		 332 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
333 dtp->u.p.current_unit->has_size)
334 dtp->u.p.current_unit->size_used += (GFC_IO_INT) *length;
59011a60
JD		 335
336 return base;
337
338}
339
c7421e06
JD		 340/* When reading sequential formatted records we have a problem. We
341 don't know how long the line is until we read the trailing newline,
342 and we don't want to read too much. If we read too much, we might
343 have to do a physical seek backwards depending on how much data is
344 present, and devices like terminals aren't seekable and would cause
345 an I/O error.
346
347 Given this, the solution is to read a byte at a time, stopping if
348 we hit the newline. For small allocations, we use a static buffer.
349 For larger allocations, we are forced to allocate memory on the
350 heap. Hopefully this won't happen very often. */
351
59011a60
JD		 352/* Read sequential file - external unit */
353
354static char *
ea99ec5b 355read_sf (st_parameter_dt *dtp, size_t *length)
59011a60
JD		 356{
357 static char *empty_string[0];
ea99ec5b 358 size_t lorig, n;
a2c037bd 359 int q, q2;
ea99ec5b 360 int seen_comma;
59011a60
JD		 361
362 /* If we have seen an eor previously, return a length of 0. The
363 caller is responsible for correctly padding the input field. */
364 if (dtp->u.p.sf_seen_eor)
365 {
366 *length = 0;
367 /* Just return something that isn't a NULL pointer, otherwise the
9b110be2 368 caller thinks an error occurred. */
59011a60 369 return (char*) empty_string;
d10fb73e
JD		 370 }
371
1f10d710
JD		 372 /* There are some cases with mixed DTIO where we have read a character
373 and saved it in the last character buffer, so we need to backup. */
374 if (unlikely (dtp->u.p.current_unit->child_dtio > 0 &&
375 dtp->u.p.current_unit->last_char != EOF - 1))
376 {
377 dtp->u.p.current_unit->last_char = EOF - 1;
378 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
379 }
380
7812c78c 381 n = seen_comma = 0;
6de9cd9a 382
7812c78c
JD		 383 /* Read data into format buffer and scan through it. */
384 lorig = *length;
bd72d66c 385
7812c78c
JD		 386 while (n < *length)
387 {
a2c037bd
JB		 388 q = fbuf_getc (dtp->u.p.current_unit);
389 if (q == EOF)
390 break;
0ef33d44
FR		 391 else if (dtp->u.p.current_unit->flags.cc != CC_NONE
392 && (q == '\n' || q == '\r'))
bd72d66c 393 {
ee3eb6a4 394 /* Unexpected end of line. Set the position. */
ee3eb6a4 395 dtp->u.p.sf_seen_eor = 1;
59afe4b4
TK		 396
397 /* If we see an EOR during non-advancing I/O, we need to skip
398 the rest of the I/O statement. Set the corresponding flag. */
5e805e44
JJ		 399 if (dtp->u.p.advance_status == ADVANCE_NO || dtp->u.p.seen_dollar)
400 dtp->u.p.eor_condition = 1;
e73d3ca6 401
8824fd4c 402 /* If we encounter a CR, it might be a CRLF. */
15877a88 403 if (q == '\r') /* Probably a CRLF */
8824fd4c 404 {
a2c037bd
JB		 405 /* See if there is an LF. */
406 q2 = fbuf_getc (dtp->u.p.current_unit);
407 if (q2 == '\n')
408 dtp->u.p.sf_seen_eor = 2;
409 else if (q2 != EOF) /* Oops, seek back. */
410 fbuf_seek (dtp->u.p.current_unit, -1, SEEK_CUR);
8824fd4c
FXC		 411 }
412
59afe4b4
TK		 413 /* Without padding, terminate the I/O statement without assigning
414 the value. With padding, the value still needs to be assigned,
415 so we can just continue with a short read. */
105b7136 416 if (dtp->u.p.current_unit->pad_status == PAD_NO)
6de9cd9a 417 {
d74b97cc 418 generate_error (&dtp->common, LIBERROR_EOR, NULL);
6de9cd9a
DN		 419 return NULL;
420 }
421
6de9cd9a 422 *length = n;
ee3eb6a4 423 goto done;
6de9cd9a 424 }
b14c7e14
JD		 425 /* Short circuit the read if a comma is found during numeric input.
426 The flag is set to zero during character reads so that commas in
427 strings are not ignored */
a2c037bd 428 else if (q == ',')
b14c7e14
JD		 429 if (dtp->u.p.sf_read_comma == 1)
430 {
7812c78c 431 seen_comma = 1;
2e444427
JD		 432 notify_std (&dtp->common, GFC_STD_GNU,
433 "Comma in formatted numeric read.");
b14c7e14
JD		 434 break;
435 }
6de9cd9a 436 n++;
a2c037bd 437 }
7812c78c 438
a2c037bd 439 *length = n;
7812c78c
JD		 440
441 /* A short read implies we hit EOF, unless we hit EOR, a comma, or
442 some other stuff. Set the relevant flags. */
443 if (lorig > *length && !dtp->u.p.sf_seen_eor && !seen_comma)
444 {
04b98fd2 445 if (n > 0)
26bda000
JD		 446 {
447 if (dtp->u.p.advance_status == ADVANCE_NO)
448 {
449 if (dtp->u.p.current_unit->pad_status == PAD_NO)
450 {
451 hit_eof (dtp);
452 return NULL;
453 }
454 else
455 dtp->u.p.eor_condition = 1;
456 }
457 else
458 dtp->u.p.at_eof = 1;
459 }
59011a60
JD		 460 else if (dtp->u.p.advance_status == ADVANCE_NO
461 || dtp->u.p.current_unit->pad_status == PAD_NO
462 || dtp->u.p.current_unit->bytes_left
463 == dtp->u.p.current_unit->recl)
464 {
465 hit_eof (dtp);
466 return NULL;
467 }
6de9cd9a 468 }
d10fb73e
JD		 469
470 done:
7812c78c
JD		 471
472 dtp->u.p.current_unit->bytes_left -= n;
6de9cd9a 473
c680ada5
JD		 474 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
475 dtp->u.p.current_unit->has_size)
476 dtp->u.p.current_unit->size_used += (GFC_IO_INT) n;
59afe4b4 477
ae01ced5
JJ		 478 /* We can't call fbuf_getptr before the loop doing fbuf_getc, because
479 fbuf_getc might reallocate the buffer. So return current pointer
480 minus all the advances, which is n plus up to two characters
481 of newline or comma. */
482 return fbuf_getptr (dtp->u.p.current_unit)
483 - n - dtp->u.p.sf_seen_eor - seen_comma;
6de9cd9a
DN		 484}
485
486
7fcb1804 487/* Function for reading the next couple of bytes from the current
f5e3ed2d 488 file, advancing the current position. We return NULL on end of record or
15877a88
JB		 489 end of file. This function is only for formatted I/O, unformatted uses
490 read_block_direct.
420aa7b8 491
7fcb1804
TS		 492 If the read is short, then it is because the current record does not
493 have enough data to satisfy the read request and the file was
494 opened with PAD=YES. The caller must assume tailing spaces for
495 short reads. */
6de9cd9a 496
7812c78c 497void *
ea99ec5b 498read_block_form (st_parameter_dt *dtp, size_t *nbytes)
6de9cd9a
DN		 499{
500 char *source;
ea99ec5b 501 size_t norig;
6de9cd9a 502
15877a88 503 if (!is_stream_io (dtp))
6de9cd9a 504 {
15877a88 505 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
6de9cd9a 506 {
91b30ee5
JD		 507 /* For preconnected units with default record length, set bytes left
508 to unit record length and proceed, otherwise error. */
509 if (dtp->u.p.current_unit->unit_number == options.stdin_unit
67c24a8b 510 && dtp->u.p.current_unit->recl == default_recl)
d7445152 511 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
91b30ee5 512 else
54ffdb12 513 {
59011a60
JD		 514 if (unlikely (dtp->u.p.current_unit->pad_status == PAD_NO)
515 && !is_internal_unit (dtp))
91b30ee5
JD		 516 {
517 /* Not enough data left. */
d74b97cc 518 generate_error (&dtp->common, LIBERROR_EOR, NULL);
7812c78c 519 return NULL;
91b30ee5
JD		 520 }
521 }
522
a5768d38 523 if (is_internal_unit(dtp))
91b30ee5 524 {
a5768d38
JD		 525 if (*nbytes > 0 && dtp->u.p.current_unit->bytes_left == 0)
526 {
527 if (dtp->u.p.advance_status == ADVANCE_NO)
528 {
529 generate_error (&dtp->common, LIBERROR_EOR, NULL);
530 return NULL;
531 }
532 }
533 }
534 else
535 {
536 if (unlikely (dtp->u.p.current_unit->bytes_left == 0))
537 {
538 hit_eof (dtp);
539 return NULL;
540 }
54ffdb12 541 }
91b30ee5 542
15877a88 543 *nbytes = dtp->u.p.current_unit->bytes_left;
6de9cd9a 544 }
97cd182d 545 }
6de9cd9a 546
97cd182d
JD		 547 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
548 (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL ||
549 dtp->u.p.current_unit->flags.access == ACCESS_STREAM))
550 {
59011a60
JD		 551 if (is_internal_unit (dtp))
552 source = read_sf_internal (dtp, nbytes);
553 else
554 source = read_sf (dtp, nbytes);
555
97cd182d 556 dtp->u.p.current_unit->strm_pos +=
15877a88 557 (gfc_offset) (*nbytes + dtp->u.p.sf_seen_eor);
7812c78c 558 return source;
97cd182d 559 }
7812c78c
JD		 560
561 /* If we reach here, we can assume it's direct access. */
562
15877a88 563 dtp->u.p.current_unit->bytes_left -= (gfc_offset) *nbytes;
91b30ee5 564
7812c78c
JD		 565 norig = *nbytes;
566 source = fbuf_read (dtp->u.p.current_unit, nbytes);
567 fbuf_seek (dtp->u.p.current_unit, *nbytes, SEEK_CUR);
91b30ee5 568
c680ada5
JD		 569 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
570 dtp->u.p.current_unit->has_size)
571 dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
cacf2b96 572
7812c78c 573 if (norig != *nbytes)
74db2a47 574 {
7812c78c 575 /* Short read, this shouldn't happen. */
00c7a3c7 576 if (dtp->u.p.current_unit->pad_status == PAD_NO)
09861cbe 577 {
d74b97cc 578 generate_error (&dtp->common, LIBERROR_EOR, NULL);
97cd182d 579 source = NULL;
09861cbe 580 }
97cd182d 581 }
6de9cd9a 582
7812c78c 583 dtp->u.p.current_unit->strm_pos += (gfc_offset) *nbytes;
6de9cd9a 584
7812c78c 585 return source;
6de9cd9a
DN		 586}
587
588
74db2a47
JD		 589/* Read a block from a character(kind=4) internal unit, to be transferred into
590 a character(kind=4) variable. Note: Portions of this code borrowed from
591 read_sf_internal. */
592void *
ea99ec5b 593read_block_form4 (st_parameter_dt *dtp, size_t *nbytes)
74db2a47
JD		 594{
595 static gfc_char4_t *empty_string[0];
596 gfc_char4_t *source;
ea99ec5b 597 size_t lorig;
74db2a47
JD		 598
599 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) *nbytes)
600 *nbytes = dtp->u.p.current_unit->bytes_left;
601
602 /* Zero size array gives internal unit len of 0. Nothing to read. */
603 if (dtp->internal_unit_len == 0
604 && dtp->u.p.current_unit->pad_status == PAD_NO)
605 hit_eof (dtp);
606
607 /* If we have seen an eor previously, return a length of 0. The
608 caller is responsible for correctly padding the input field. */
609 if (dtp->u.p.sf_seen_eor)
610 {
611 *nbytes = 0;
612 /* Just return something that isn't a NULL pointer, otherwise the
9b110be2 613 caller thinks an error occurred. */
74db2a47
JD		 614 return empty_string;
615 }
616
617 lorig = *nbytes;
618 source = (gfc_char4_t *) mem_alloc_r4 (dtp->u.p.current_unit->s, nbytes);
619
620 if (unlikely (lorig > *nbytes))
621 {
622 hit_eof (dtp);
623 return NULL;
624 }
625
626 dtp->u.p.current_unit->bytes_left -= *nbytes;
627
c680ada5
JD		 628 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
629 dtp->u.p.current_unit->has_size)
630 dtp->u.p.current_unit->size_used += (GFC_IO_INT) *nbytes;
74db2a47
JD		 631
632 return source;
633}
634
635
07b3bbf2
TK		 636/* Reads a block directly into application data space. This is for
637 unformatted files. */
0dc43461
JB		 638
639static void
f9bfed22 640read_block_direct (st_parameter_dt *dtp, void *buf, size_t nbytes)
0dc43461 641{
7812c78c
JD		 642 ssize_t to_read_record;
643 ssize_t have_read_record;
644 ssize_t to_read_subrecord;
645 ssize_t have_read_subrecord;
8a7f7fb6 646 int short_record;
0dc43461 647
8a7f7fb6 648 if (is_stream_io (dtp))
0dc43461 649 {
e73d3ca6 650 have_read_record = sread (dtp->u.p.current_unit->s, buf,
f9bfed22 651 nbytes);
7812c78c 652 if (unlikely (have_read_record < 0))
cacf2b96 653 {
d74b97cc 654 generate_error (&dtp->common, LIBERROR_OS, NULL);
cacf2b96
JD		 655 return;
656 }
657
e73d3ca6 658 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_read_record;
8a7f7fb6 659
f9bfed22 660 if (unlikely ((ssize_t) nbytes != have_read_record))
07b3bbf2 661 {
b4c811bd
TK		 662 /* Short read, e.g. if we hit EOF. For stream files,
663 we have to set the end-of-file condition. */
7812c78c 664 hit_eof (dtp);
07b3bbf2 665 }
8a7f7fb6 666 return;
0dc43461 667 }
8a7f7fb6 668
07b3bbf2 669 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
835681c8 670 {
f9bfed22 671 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes)
07b3bbf2
TK		 672 {
673 short_record = 1;
f9bfed22
JB		 674 to_read_record = dtp->u.p.current_unit->bytes_left;
675 nbytes = to_read_record;
07b3bbf2 676 }
07b3bbf2
TK		 677 else
678 {
679 short_record = 0;
f9bfed22 680 to_read_record = nbytes;
07b3bbf2
TK		 681 }
682
683 dtp->u.p.current_unit->bytes_left -= to_read_record;
684
7812c78c
JD		 685 to_read_record = sread (dtp->u.p.current_unit->s, buf, to_read_record);
686 if (unlikely (to_read_record < 0))
07b3bbf2 687 {
d74b97cc 688 generate_error (&dtp->common, LIBERROR_OS, NULL);
07b3bbf2
TK		 689 return;
690 }
691
e73d3ca6 692 if (to_read_record != (ssize_t) nbytes)
91b30ee5 693 {
b4c811bd
TK		 694 /* Short read, e.g. if we hit EOF. Apparently, we read
695 more than was written to the last record. */
91b30ee5
JD		 696 return;
697 }
07b3bbf2 698
afab92d8 699 if (unlikely (short_record))
07b3bbf2 700 {
d74b97cc 701 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
07b3bbf2
TK		 702 }
703 return;
835681c8
JD		 704 }
705
07b3bbf2
TK		 706 /* Unformatted sequential. We loop over the subrecords, reading
707 until the request has been fulfilled or the record has run out
708 of continuation subrecords. */
709
710 /* Check whether we exceed the total record length. */
711
f4072316 712 if (dtp->u.p.current_unit->flags.has_recl
743460ea 713 && ((gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left))
07b3bbf2 714 {
f9bfed22 715 to_read_record = dtp->u.p.current_unit->bytes_left;
07b3bbf2
TK		 716 short_record = 1;
717 }
8a7f7fb6
TK		 718 else
719 {
f9bfed22 720 to_read_record = nbytes;
8a7f7fb6 721 short_record = 0;
8a7f7fb6 722 }
07b3bbf2 723 have_read_record = 0;
8a7f7fb6 724
07b3bbf2 725 while(1)
0dc43461 726 {
07b3bbf2
TK		 727 if (dtp->u.p.current_unit->bytes_left_subrecord
728 < (gfc_offset) to_read_record)
729 {
f9bfed22 730 to_read_subrecord = dtp->u.p.current_unit->bytes_left_subrecord;
07b3bbf2 731 to_read_record -= to_read_subrecord;
07b3bbf2 732 }
07b3bbf2
TK		 733 else
734 {
735 to_read_subrecord = to_read_record;
736 to_read_record = 0;
737 }
738
739 dtp->u.p.current_unit->bytes_left_subrecord -= to_read_subrecord;
740
e73d3ca6 741 have_read_subrecord = sread (dtp->u.p.current_unit->s,
7812c78c 742 buf + have_read_record, to_read_subrecord);
43b594b4 743 if (unlikely (have_read_subrecord < 0))
07b3bbf2 744 {
d74b97cc 745 generate_error (&dtp->common, LIBERROR_OS, NULL);
07b3bbf2
TK		 746 return;
747 }
748
749 have_read_record += have_read_subrecord;
750
afab92d8 751 if (unlikely (to_read_subrecord != have_read_subrecord))
07b3bbf2 752 {
b4c811bd
TK		 753 /* Short read, e.g. if we hit EOF. This means the record
754 structure has been corrupted, or the trailing record
755 marker would still be present. */
756
d74b97cc 757 generate_error (&dtp->common, LIBERROR_CORRUPT_FILE, NULL);
07b3bbf2
TK		 758 return;
759 }
760
761 if (to_read_record > 0)
762 {
afab92d8 763 if (likely (dtp->u.p.current_unit->continued))
07b3bbf2
TK		 764 {
765 next_record_r_unf (dtp, 0);
766 us_read (dtp, 1);
767 }
768 else
769 {
e08e57d0
TK		 770 /* Let's make sure the file position is correctly pre-positioned
771 for the next read statement. */
b4c811bd 772
e08e57d0 773 dtp->u.p.current_unit->current_record = 0;
b4c811bd 774 next_record_r_unf (dtp, 0);
d74b97cc 775 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
07b3bbf2
TK		 776 return;
777 }
778 }
779 else
780 {
781 /* Normal exit, the read request has been fulfilled. */
782 break;
783 }
91b30ee5 784 }
0dc43461 785
07b3bbf2 786 dtp->u.p.current_unit->bytes_left -= have_read_record;
afab92d8 787 if (unlikely (short_record))
91b30ee5 788 {
d74b97cc 789 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
8a7f7fb6 790 return;
0dc43461 791 }
07b3bbf2 792 return;
0dc43461
JB		 793}
794
795
7fcb1804
TS		 796/* Function for writing a block of bytes to the current file at the
797 current position, advancing the file pointer. We are given a length
798 and return a pointer to a buffer that the caller must (completely)
799 fill in. Returns NULL on error. */
6de9cd9a
DN		 800
801void *
ea99ec5b 802write_block (st_parameter_dt *dtp, size_t length)
6de9cd9a
DN		 803{
804 char *dest;
54ffdb12 805
15877a88 806 if (!is_stream_io (dtp))
6de9cd9a 807 {
91b30ee5 808 if (dtp->u.p.current_unit->bytes_left < (gfc_offset) length)
54ffdb12 809 {
91b30ee5
JD		 810 /* For preconnected units with default record length, set bytes left
811 to unit record length and proceed, otherwise error. */
afab92d8
TK		 812 if (likely ((dtp->u.p.current_unit->unit_number
813 == options.stdout_unit
814 || dtp->u.p.current_unit->unit_number
815 == options.stderr_unit)
67c24a8b 816 && dtp->u.p.current_unit->recl == default_recl))
91b30ee5
JD		 817 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
818 else
819 {
d74b97cc 820 generate_error (&dtp->common, LIBERROR_EOR, NULL);
91b30ee5
JD		 821 return NULL;
822 }
54ffdb12 823 }
6de9cd9a 824
91b30ee5 825 dtp->u.p.current_unit->bytes_left -= (gfc_offset) length;
97cd182d 826 }
91b30ee5 827
15877a88 828 if (is_internal_unit (dtp))
91b30ee5 829 {
4a8d4422 830 if (is_char4_unit(dtp)) /* char4 internel unit. */
746e6327
JD		 831 {
832 gfc_char4_t *dest4;
833 dest4 = mem_alloc_w4 (dtp->u.p.current_unit->s, &length);
834 if (dest4 == NULL)
835 {
836 generate_error (&dtp->common, LIBERROR_END, NULL);
837 return NULL;
838 }
839 return dest4;
840 }
c7421e06
JD		 841 else
842 dest = mem_alloc_w (dtp->u.p.current_unit->s, &length);
6de9cd9a 843
c7421e06
JD		 844 if (dest == NULL)
845 {
846 generate_error (&dtp->common, LIBERROR_END, NULL);
847 return NULL;
848 }
397bc09a 849
c7421e06
JD		 850 if (unlikely (dtp->u.p.current_unit->endfile == AT_ENDFILE))
851 generate_error (&dtp->common, LIBERROR_END, NULL);
15877a88
JB		 852 }
853 else
854 {
855 dest = fbuf_alloc (dtp->u.p.current_unit, length);
856 if (dest == NULL)
74db2a47
JD		 857 {
858 generate_error (&dtp->common, LIBERROR_OS, NULL);
859 return NULL;
860 }
15877a88 861 }
e73d3ca6 862
c680ada5
JD		 863 if (((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0) ||
864 dtp->u.p.current_unit->has_size)
865 dtp->u.p.current_unit->size_used += (GFC_IO_INT) length;
91b30ee5 866
97cd182d 867 dtp->u.p.current_unit->strm_pos += (gfc_offset) length;
6de9cd9a
DN		 868
869 return dest;
870}
871
872
07b3bbf2
TK		 873/* High level interface to swrite(), taking care of errors. This is only
874 called for unformatted files. There are three cases to consider:
875 Stream I/O, unformatted direct, unformatted sequential. */
0dc43461 876
f5e3ed2d 877static bool
82b8244c 878write_buf (st_parameter_dt *dtp, void *buf, size_t nbytes)
0dc43461 879{
07b3bbf2 880
7812c78c
JD		 881 ssize_t have_written;
882 ssize_t to_write_subrecord;
07b3bbf2
TK		 883 int short_record;
884
07b3bbf2
TK		 885 /* Stream I/O. */
886
97cd182d
JD		 887 if (is_stream_io (dtp))
888 {
7812c78c
JD		 889 have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
890 if (unlikely (have_written < 0))
07b3bbf2 891 {
d74b97cc 892 generate_error (&dtp->common, LIBERROR_OS, NULL);
f5e3ed2d 893 return false;
07b3bbf2
TK		 894 }
895
e73d3ca6 896 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
07b3bbf2 897
f5e3ed2d 898 return true;
97cd182d 899 }
07b3bbf2
TK		 900
901 /* Unformatted direct access. */
902
903 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
82b8244c 904 {
afab92d8 905 if (unlikely (dtp->u.p.current_unit->bytes_left < (gfc_offset) nbytes))
54ffdb12 906 {
d74b97cc 907 generate_error (&dtp->common, LIBERROR_DIRECT_EOR, NULL);
f5e3ed2d 908 return false;
07b3bbf2
TK		 909 }
910
4152bc26 911 if (buf == NULL && nbytes == 0)
f5e3ed2d 912 return true;
4152bc26 913
e73d3ca6 914 have_written = swrite (dtp->u.p.current_unit->s, buf, nbytes);
7812c78c 915 if (unlikely (have_written < 0))
07b3bbf2 916 {
d74b97cc 917 generate_error (&dtp->common, LIBERROR_OS, NULL);
f5e3ed2d 918 return false;
91b30ee5
JD		 919 }
920
7812c78c
JD		 921 dtp->u.p.current_unit->strm_pos += (gfc_offset) have_written;
922 dtp->u.p.current_unit->bytes_left -= (gfc_offset) have_written;
07b3bbf2 923
f5e3ed2d 924 return true;
91b30ee5 925 }
0dc43461 926
07b3bbf2
TK		 927 /* Unformatted sequential. */
928
929 have_written = 0;
930
931 if (dtp->u.p.current_unit->flags.has_recl
932 && (gfc_offset) nbytes > dtp->u.p.current_unit->bytes_left)
82b8244c 933 {
07b3bbf2
TK		 934 nbytes = dtp->u.p.current_unit->bytes_left;
935 short_record = 1;
936 }
937 else
938 {
939 short_record = 0;
82b8244c 940 }
0dc43461 941
07b3bbf2
TK		 942 while (1)
943 {
944
945 to_write_subrecord =
946 (size_t) dtp->u.p.current_unit->bytes_left_subrecord < nbytes ?
947 (size_t) dtp->u.p.current_unit->bytes_left_subrecord : nbytes;
948
949 dtp->u.p.current_unit->bytes_left_subrecord -=
950 (gfc_offset) to_write_subrecord;
951
e73d3ca6 952 to_write_subrecord = swrite (dtp->u.p.current_unit->s,
7812c78c
JD		 953 buf + have_written, to_write_subrecord);
954 if (unlikely (to_write_subrecord < 0))
07b3bbf2 955 {
d74b97cc 956 generate_error (&dtp->common, LIBERROR_OS, NULL);
f5e3ed2d 957 return false;
07b3bbf2
TK		 958 }
959
e73d3ca6 960 dtp->u.p.current_unit->strm_pos += (gfc_offset) to_write_subrecord;
07b3bbf2
TK		 961 nbytes -= to_write_subrecord;
962 have_written += to_write_subrecord;
97cd182d 963
07b3bbf2
TK		 964 if (nbytes == 0)
965 break;
82b8244c 966
07b3bbf2
TK		 967 next_record_w_unf (dtp, 1);
968 us_write (dtp, 1);
969 }
970 dtp->u.p.current_unit->bytes_left -= have_written;
afab92d8 971 if (unlikely (short_record))
07b3bbf2 972 {
d74b97cc 973 generate_error (&dtp->common, LIBERROR_SHORT_RECORD, NULL);
f5e3ed2d 974 return false;
07b3bbf2 975 }
f5e3ed2d 976 return true;
0dc43461
JB		 977}
978
979
facb23dc 980/* Reverse memcpy - used for byte swapping. */
6de9cd9a
DN		 981
982static void
facb23dc 983reverse_memcpy (void *dest, const void *src, size_t n)
6de9cd9a 984{
facb23dc
JB		 985 char *d, *s;
986 size_t i;
987
988 d = (char *) dest;
989 s = (char *) src + n - 1;
990
991 /* Write with ascending order - this is likely faster
992 on modern architectures because of write combining. */
993 for (i=0; i<n; i++)
994 *(d++) = *(s--);
995}
996
997
998/* Utility function for byteswapping an array, using the bswap
999 builtins if possible. dest and src can overlap completely, or then
1000 they must point to separate objects; partial overlaps are not
1001 allowed. */
1002
1003static void
1004bswap_array (void *dest, const void *src, size_t size, size_t nelems)
1005{
e73d3ca6 1006 const char *ps;
facb23dc
JB		 1007 char *pd;
1008
1009 switch (size)
181c9f4a 1010 {
facb23dc
JB		 1011 case 1:
1012 break;
1013 case 2:
1014 for (size_t i = 0; i < nelems; i++)
1015 ((uint16_t*)dest)[i] = __builtin_bswap16 (((uint16_t*)src)[i]);
1016 break;
1017 case 4:
1018 for (size_t i = 0; i < nelems; i++)
1019 ((uint32_t*)dest)[i] = __builtin_bswap32 (((uint32_t*)src)[i]);
1020 break;
1021 case 8:
1022 for (size_t i = 0; i < nelems; i++)
1023 ((uint64_t*)dest)[i] = __builtin_bswap64 (((uint64_t*)src)[i]);
1024 break;
1025 case 12:
1026 ps = src;
1027 pd = dest;
1028 for (size_t i = 0; i < nelems; i++)
1029 {
1030 uint32_t tmp;
1031 memcpy (&tmp, ps, 4);
1032 *(uint32_t*)pd = __builtin_bswap32 (*(uint32_t*)(ps + 8));
1033 *(uint32_t*)(pd + 4) = __builtin_bswap32 (*(uint32_t*)(ps + 4));
1034 *(uint32_t*)(pd + 8) = __builtin_bswap32 (tmp);
1035 ps += size;
1036 pd += size;
1037 }
1038 break;
1039 case 16:
1040 ps = src;
1041 pd = dest;
1042 for (size_t i = 0; i < nelems; i++)
1043 {
1044 uint64_t tmp;
1045 memcpy (&tmp, ps, 8);
1046 *(uint64_t*)pd = __builtin_bswap64 (*(uint64_t*)(ps + 8));
1047 *(uint64_t*)(pd + 8) = __builtin_bswap64 (tmp);
1048 ps += size;
1049 pd += size;
1050 }
1051 break;
1052 default:
1053 pd = dest;
1054 if (dest != src)
1055 {
1056 ps = src;
1057 for (size_t i = 0; i < nelems; i++)
1058 {
1059 reverse_memcpy (pd, ps, size);
1060 ps += size;
1061 pd += size;
1062 }
1063 }
1064 else
1065 {
1066 /* In-place byte swap. */
1067 for (size_t i = 0; i < nelems; i++)
1068 {
1069 char tmp, *low = pd, *high = pd + size - 1;
1070 for (size_t j = 0; j < size/2; j++)
1071 {
1072 tmp = *low;
1073 *low = *high;
1074 *high = tmp;
1075 low++;
1076 high--;
1077 }
1078 pd += size;
1079 }
1080 }
181c9f4a 1081 }
facb23dc
JB		 1082}
1083
cea93abb 1084
facb23dc
JB		 1085/* Master function for unformatted reads. */
1086
1087static void
1088unformatted_read (st_parameter_dt *dtp, bt type,
1089 void *dest, int kind, size_t size, size_t nelems)
1090{
e73d3ca6
PT		 1091 if (type == BT_CLASS)
1092 {
1093 int unit = dtp->u.p.current_unit->unit_number;
1094 char tmp_iomsg[IOMSG_LEN] = "";
1095 char *child_iomsg;
1096 gfc_charlen_type child_iomsg_len;
1097 int noiostat;
1098 int *child_iostat = NULL;
1099
1100 /* Set iostat, intent(out). */
1101 noiostat = 0;
1102 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
1103 dtp->common.iostat : &noiostat;
1104
1105 /* Set iomsg, intent(inout). */
1106 if (dtp->common.flags & IOPARM_HAS_IOMSG)
1107 {
1108 child_iomsg = dtp->common.iomsg;
1109 child_iomsg_len = dtp->common.iomsg_len;
1110 }
1111 else
1112 {
1113 child_iomsg = tmp_iomsg;
1114 child_iomsg_len = IOMSG_LEN;
1115 }
1116
1117 /* Call the user defined unformatted READ procedure. */
1118 dtp->u.p.current_unit->child_dtio++;
1119 dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg,
1120 child_iomsg_len);
1121 dtp->u.p.current_unit->child_dtio--;
1122 return;
1123 }
1124
facb23dc
JB		 1125 if (type == BT_CHARACTER)
1126 size *= GFC_SIZE_OF_CHAR_KIND(kind);
1127 read_block_direct (dtp, dest, size * nelems);
cea93abb 1128
facb23dc
JB		 1129 if (unlikely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_SWAP)
1130 && kind != 1)
1131 {
cea93abb 1132 /* Handle wide chracters. */
facb23dc
JB		 1133 if (type == BT_CHARACTER)
1134 {
1135 nelems *= size;
1136 size = kind;
1137 }
cea93abb 1138
181c9f4a 1139 /* Break up complex into its constituent reals. */
facb23dc
JB		 1140 else if (type == BT_COMPLEX)
1141 {
1142 nelems *= 2;
1143 size /= 2;
1144 }
1145 bswap_array (dest, dest, size, nelems);
181c9f4a 1146 }
6de9cd9a
DN		 1147}
1148
0dc43461 1149
853c0ad7
JD		 1150/* Master function for unformatted writes. NOTE: For kind=10 the size is 16
1151 bytes on 64 bit machines. The unused bytes are not initialized and never
1152 used, which can show an error with memory checking analyzers like
e73d3ca6 1153 valgrind. We us BT_CLASS to denote a User Defined I/O call. */
7fcb1804 1154
6de9cd9a 1155static void
181c9f4a 1156unformatted_write (st_parameter_dt *dtp, bt type,
cea93abb 1157 void *source, int kind, size_t size, size_t nelems)
6de9cd9a 1158{
e73d3ca6
PT		 1159 if (type == BT_CLASS)
1160 {
1161 int unit = dtp->u.p.current_unit->unit_number;
1162 char tmp_iomsg[IOMSG_LEN] = "";
1163 char *child_iomsg;
1164 gfc_charlen_type child_iomsg_len;
1165 int noiostat;
1166 int *child_iostat = NULL;
1167
1168 /* Set iostat, intent(out). */
1169 noiostat = 0;
1170 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
1171 dtp->common.iostat : &noiostat;
1172
1173 /* Set iomsg, intent(inout). */
1174 if (dtp->common.flags & IOPARM_HAS_IOMSG)
1175 {
1176 child_iomsg = dtp->common.iomsg;
1177 child_iomsg_len = dtp->common.iomsg_len;
1178 }
1179 else
1180 {
1181 child_iomsg = tmp_iomsg;
1182 child_iomsg_len = IOMSG_LEN;
1183 }
1184
1185 /* Call the user defined unformatted WRITE procedure. */
1186 dtp->u.p.current_unit->child_dtio++;
1187 dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg,
1188 child_iomsg_len);
1189 dtp->u.p.current_unit->child_dtio--;
1190 return;
1191 }
1192
1193 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE)
e8189773 1194 || kind == 1)
181c9f4a 1195 {
cea93abb
JD		 1196 size_t stride = type == BT_CHARACTER ?
1197 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
1198
1199 write_buf (dtp, source, stride * nelems);
181c9f4a
TK		 1200 }
1201 else
1202 {
facb23dc
JB		 1203#define BSWAP_BUFSZ 512
1204 char buffer[BSWAP_BUFSZ];
181c9f4a 1205 char *p;
facb23dc 1206 size_t nrem;
cea93abb
JD		 1207
1208 p = source;
1209
1210 /* Handle wide chracters. */
1211 if (type == BT_CHARACTER && kind != 1)
1212 {
1213 nelems *= size;
1214 size = kind;
1215 }
e73d3ca6 1216
181c9f4a
TK		 1217 /* Break up complex into its constituent reals. */
1218 if (type == BT_COMPLEX)
1219 {
1220 nelems *= 2;
1221 size /= 2;
e73d3ca6 1222 }
181c9f4a 1223
181c9f4a 1224 /* By now, all complex variables have been split into their
80bcbc80
TB		 1225 constituent reals. */
1226
facb23dc
JB		 1227 nrem = nelems;
1228 do
181c9f4a 1229 {
facb23dc
JB		 1230 size_t nc;
1231 if (size * nrem > BSWAP_BUFSZ)
1232 nc = BSWAP_BUFSZ / size;
1233 else
1234 nc = nrem;
1235
1236 bswap_array (buffer, p, size, nc);
1237 write_buf (dtp, buffer, size * nc);
1238 p += size * nc;
1239 nrem -= nc;
181c9f4a 1240 }
facb23dc 1241 while (nrem > 0);
181c9f4a 1242 }
6de9cd9a
DN		 1243}
1244
1245
7fcb1804 1246/* Return a pointer to the name of a type. */
6de9cd9a
DN		 1247
1248const char *
1249type_name (bt type)
1250{
1251 const char *p;
1252
1253 switch (type)
1254 {
1255 case BT_INTEGER:
1256 p = "INTEGER";
1257 break;
1258 case BT_LOGICAL:
1259 p = "LOGICAL";
1260 break;
1261 case BT_CHARACTER:
1262 p = "CHARACTER";
1263 break;
1264 case BT_REAL:
1265 p = "REAL";
1266 break;
1267 case BT_COMPLEX:
1268 p = "COMPLEX";
1269 break;
e73d3ca6
PT		 1270 case BT_CLASS:
1271 p = "CLASS or DERIVED";
1272 break;
6de9cd9a 1273 default:
5e805e44 1274 internal_error (NULL, "type_name(): Bad type");
6de9cd9a
DN		 1275 }
1276
1277 return p;
1278}
1279
1280
7fcb1804
TS		 1281/* Write a constant string to the output.
1282 This is complicated because the string can have doubled delimiters
1283 in it. The length in the format node is the true length. */
6de9cd9a
DN		 1284
1285static void
5e805e44 1286write_constant_string (st_parameter_dt *dtp, const fnode *f)
6de9cd9a
DN		 1287{
1288 char c, delimiter, *p, *q;
e73d3ca6 1289 int length;
6de9cd9a
DN		 1290
1291 length = f->u.string.length;
1292 if (length == 0)
1293 return;
1294
5e805e44 1295 p = write_block (dtp, length);
6de9cd9a
DN		 1296 if (p == NULL)
1297 return;
e73d3ca6 1298
6de9cd9a
DN		 1299 q = f->u.string.p;
1300 delimiter = q[-1];
1301
1302 for (; length > 0; length--)
1303 {
1304 c = *p++ = *q++;
ec88bf8b 1305 if (c == delimiter && c != 'H' && c != 'h')
7fcb1804 1306 q++; /* Skip the doubled delimiter. */
6de9cd9a
DN		 1307 }
1308}
1309
1310
7fcb1804
TS		 1311/* Given actual and expected types in a formatted data transfer, make
1312 sure they agree. If not, an error message is generated. Returns
1313 nonzero if something went wrong. */
6de9cd9a
DN		 1314
1315static int
5e805e44 1316require_type (st_parameter_dt *dtp, bt expected, bt actual, const fnode *f)
6de9cd9a 1317{
d30fe1c5
JB		 1318#define BUFLEN 100
1319 char buffer[BUFLEN];
6de9cd9a
DN		 1320
1321 if (actual == expected)
1322 return 0;
1323
f983954d 1324 /* Adjust item_count before emitting error message. */
e73d3ca6 1325 snprintf (buffer, BUFLEN,
d30fe1c5 1326 "Expected %s for item %d in formatted transfer, got %s",
f983954d 1327 type_name (expected), dtp->u.p.item_count - 1, type_name (actual));
6de9cd9a 1328
5e805e44 1329 format_error (dtp, f, buffer);
6de9cd9a
DN		 1330 return 1;
1331}
1332
1333
dc42a736
PT		 1334/* Check that the dtio procedure required for formatted IO is present. */
1335
1336static int
1337check_dtio_proc (st_parameter_dt *dtp, const fnode *f)
1338{
1339 char buffer[BUFLEN];
1340
1341 if (dtp->u.p.fdtio_ptr != NULL)
1342 return 0;
1343
1344 snprintf (buffer, BUFLEN,
1345 "Missing DTIO procedure or intrinsic type passed for item %d "
1346 "in formatted transfer",
1347 dtp->u.p.item_count - 1);
1348
1349 format_error (dtp, f, buffer);
1350 return 1;
1351}
1352
1353
32157107
TB		 1354static int
1355require_numeric_type (st_parameter_dt *dtp, bt actual, const fnode *f)
1356{
1357#define BUFLEN 100
1358 char buffer[BUFLEN];
1359
1360 if (actual == BT_INTEGER || actual == BT_REAL || actual == BT_COMPLEX)
1361 return 0;
1362
1363 /* Adjust item_count before emitting error message. */
e73d3ca6 1364 snprintf (buffer, BUFLEN,
32157107
TB		 1365 "Expected numeric type for item %d in formatted transfer, got %s",
1366 dtp->u.p.item_count - 1, type_name (actual));
1367
1368 format_error (dtp, f, buffer);
1369 return 1;
1370}
1371
5cdc4b0e
JD		 1372static char *
1373get_dt_format (char *p, gfc_charlen_type *length)
1374{
1375 char delim = p[-1]; /* The delimiter is always the first character back. */
1376 char c, *q, *res;
1377 gfc_charlen_type len = *length; /* This length already correct, less 'DT'. */
1378
1379 res = q = xmalloc (len + 2);
1380
1381 /* Set the beginning of the string to 'DT', length adjusted below. */
1382 *q++ = 'D';
1383 *q++ = 'T';
1384
1385 /* The string may contain doubled quotes so scan and skip as needed. */
1386 for (; len > 0; len--)
1387 {
1388 c = *q++ = *p++;
1389 if (c == delim)
1390 p++; /* Skip the doubled delimiter. */
1391 }
1392
1393 /* Adjust the string length by two now that we are done. */
1394 *length += 2;
1395
1396 return res;
1397}
1398
32157107 1399
7812c78c 1400/* This function is in the main loop for a formatted data transfer
7fcb1804
TS		 1401 statement. It would be natural to implement this as a coroutine
1402 with the user program, but C makes that awkward. We loop,
8b6dba81 1403 processing format elements. When we actually have to transfer
7fcb1804 1404 data instead of just setting flags, we return control to the user
7812c78c 1405 program which calls a function that supplies the address and type
7fcb1804 1406 of the next element, then comes back here to process it. */
6de9cd9a
DN		 1407
1408static void
7812c78c
JD		 1409formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind,
1410 size_t size)
6de9cd9a 1411{
94e2b58a 1412 int pos, bytes_used;
5e805e44 1413 const fnode *f;
be0cc7e2 1414 format_token t;
a3b6aba2 1415 int n;
6de9cd9a
DN		 1416 int consume_data_flag;
1417
7fcb1804 1418 /* Change a complex data item into a pair of reals. */
6de9cd9a
DN		 1419
1420 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1421 if (type == BT_COMPLEX)
e5ef4b3b
JB		 1422 {
1423 type = BT_REAL;
1424 size /= 2;
1425 }
6de9cd9a 1426
59afe4b4
TK		 1427 /* If there's an EOR condition, we simulate finalizing the transfer
1428 by doing nothing. */
5e805e44 1429 if (dtp->u.p.eor_condition)
59afe4b4
TK		 1430 return;
1431
b14c7e14
JD		 1432 /* Set this flag so that commas in reads cause the read to complete before
1433 the entire field has been read. The next read field will start right after
1434 the comma in the stream. (Set to 0 for character reads). */
105b7136
JD		 1435 dtp->u.p.sf_read_comma =
1436 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
d7445152 1437
7812c78c
JD		 1438 for (;;)
1439 {
1440 /* If reversion has occurred and there is another real data item,
1441 then we have to move to the next record. */
1442 if (dtp->u.p.reversion_flag && n > 0)
1443 {
1444 dtp->u.p.reversion_flag = 0;
1445 next_record (dtp, 0);
1446 }
1447
1448 consume_data_flag = 1;
1449 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
1450 break;
1451
1452 f = next_format (dtp);
1453 if (f == NULL)
1454 {
1455 /* No data descriptors left. */
1456 if (unlikely (n > 0))
1457 generate_error (&dtp->common, LIBERROR_FORMAT,
1458 "Insufficient data descriptors in format after reversion");
1459 return;
1460 }
1461
1462 t = f->format;
1463
1464 bytes_used = (int)(dtp->u.p.current_unit->recl
1465 - dtp->u.p.current_unit->bytes_left);
1466
1467 if (is_stream_io(dtp))
1468 bytes_used = 0;
1469
1470 switch (t)
1471 {
1472 case FMT_I:
1473 if (n == 0)
1474 goto need_read_data;
1475 if (require_type (dtp, BT_INTEGER, type, f))
1476 return;
1477 read_decimal (dtp, f, p, kind);
1478 break;
1479
1480 case FMT_B:
1481 if (n == 0)
1482 goto need_read_data;
58fc89f6 1483 if (!(compile_options.allow_std & GFC_STD_GNU)
32157107
TB		 1484 && require_numeric_type (dtp, type, f))
1485 return;
1486 if (!(compile_options.allow_std & GFC_STD_F2008)
7812c78c
JD		 1487 && require_type (dtp, BT_INTEGER, type, f))
1488 return;
1489 read_radix (dtp, f, p, kind, 2);
1490 break;
1491
1492 case FMT_O:
1493 if (n == 0)
e73d3ca6 1494 goto need_read_data;
58fc89f6 1495 if (!(compile_options.allow_std & GFC_STD_GNU)
32157107
TB		 1496 && require_numeric_type (dtp, type, f))
1497 return;
1498 if (!(compile_options.allow_std & GFC_STD_F2008)
7812c78c
JD		 1499 && require_type (dtp, BT_INTEGER, type, f))
1500 return;
1501 read_radix (dtp, f, p, kind, 8);
1502 break;
1503
1504 case FMT_Z:
1505 if (n == 0)
1506 goto need_read_data;
58fc89f6 1507 if (!(compile_options.allow_std & GFC_STD_GNU)
32157107
TB		 1508 && require_numeric_type (dtp, type, f))
1509 return;
1510 if (!(compile_options.allow_std & GFC_STD_F2008)
7812c78c
JD		 1511 && require_type (dtp, BT_INTEGER, type, f))
1512 return;
1513 read_radix (dtp, f, p, kind, 16);
1514 break;
1515
1516 case FMT_A:
1517 if (n == 0)
1518 goto need_read_data;
1519
1520 /* It is possible to have FMT_A with something not BT_CHARACTER such
1521 as when writing out hollerith strings, so check both type
1522 and kind before calling wide character routines. */
1523 if (type == BT_CHARACTER && kind == 4)
1524 read_a_char4 (dtp, f, p, size);
1525 else
1526 read_a (dtp, f, p, size);
1527 break;
1528
1529 case FMT_L:
1530 if (n == 0)
1531 goto need_read_data;
1532 read_l (dtp, f, p, kind);
1533 break;
1534
1535 case FMT_D:
1536 if (n == 0)
1537 goto need_read_data;
1538 if (require_type (dtp, BT_REAL, type, f))
1539 return;
1540 read_f (dtp, f, p, kind);
1541 break;
1542
e73d3ca6
PT		 1543 case FMT_DT:
1544 if (n == 0)
1545 goto need_read_data;
dc42a736
PT		 1546
1547 if (check_dtio_proc (dtp, f))
1548 return;
e73d3ca6
PT		 1549 if (require_type (dtp, BT_CLASS, type, f))
1550 return;
1551 int unit = dtp->u.p.current_unit->unit_number;
1552 char dt[] = "DT";
1553 char tmp_iomsg[IOMSG_LEN] = "";
1554 char *child_iomsg;
1555 gfc_charlen_type child_iomsg_len;
1556 int noiostat;
1557 int *child_iostat = NULL;
5cdc4b0e 1558 char *iotype;
e73d3ca6
PT		 1559 gfc_charlen_type iotype_len = f->u.udf.string_len;
1560
1561 /* Build the iotype string. */
1562 if (iotype_len == 0)
1563 {
1564 iotype_len = 2;
1565 iotype = dt;
1566 }
1567 else
5cdc4b0e 1568 iotype = get_dt_format (f->u.udf.string, &iotype_len);
e73d3ca6
PT		 1569
1570 /* Set iostat, intent(out). */
1571 noiostat = 0;
1572 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
1573 dtp->common.iostat : &noiostat;
1574
1575 /* Set iomsg, intent(inout). */
1576 if (dtp->common.flags & IOPARM_HAS_IOMSG)
1577 {
1578 child_iomsg = dtp->common.iomsg;
1579 child_iomsg_len = dtp->common.iomsg_len;
1580 }
1581 else
1582 {
1583 child_iomsg = tmp_iomsg;
1584 child_iomsg_len = IOMSG_LEN;
1585 }
1586
1587 /* Call the user defined formatted READ procedure. */
1588 dtp->u.p.current_unit->child_dtio++;
1f10d710 1589 dtp->u.p.current_unit->last_char = EOF - 1;
e73d3ca6
PT		 1590 dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
1591 child_iostat, child_iomsg,
1592 iotype_len, child_iomsg_len);
1593 dtp->u.p.current_unit->child_dtio--;
1594
1595 if (f->u.udf.string_len != 0)
1596 free (iotype);
1597 /* Note: vlist is freed in free_format_data. */
1598 break;
1599
7812c78c
JD		 1600 case FMT_E:
1601 if (n == 0)
1602 goto need_read_data;
1603 if (require_type (dtp, BT_REAL, type, f))
1604 return;
1605 read_f (dtp, f, p, kind);
1606 break;
1607
1608 case FMT_EN:
1609 if (n == 0)
1610 goto need_read_data;
1611 if (require_type (dtp, BT_REAL, type, f))
1612 return;
1613 read_f (dtp, f, p, kind);
1614 break;
1615
1616 case FMT_ES:
1617 if (n == 0)
1618 goto need_read_data;
1619 if (require_type (dtp, BT_REAL, type, f))
1620 return;
1621 read_f (dtp, f, p, kind);
1622 break;
1623
1624 case FMT_F:
1625 if (n == 0)
1626 goto need_read_data;
1627 if (require_type (dtp, BT_REAL, type, f))
1628 return;
1629 read_f (dtp, f, p, kind);
1630 break;
1631
1632 case FMT_G:
1633 if (n == 0)
1634 goto need_read_data;
1635 switch (type)
1636 {
1637 case BT_INTEGER:
1638 read_decimal (dtp, f, p, kind);
1639 break;
1640 case BT_LOGICAL:
1641 read_l (dtp, f, p, kind);
1642 break;
1643 case BT_CHARACTER:
1644 if (kind == 4)
1645 read_a_char4 (dtp, f, p, size);
1646 else
1647 read_a (dtp, f, p, size);
1648 break;
1649 case BT_REAL:
1650 read_f (dtp, f, p, kind);
1651 break;
1652 default:
2b4c9065
NK		 1653 internal_error (&dtp->common,
1654 "formatted_transfer (): Bad type");
7812c78c
JD		 1655 }
1656 break;
1657
1658 case FMT_STRING:
1659 consume_data_flag = 0;
1660 format_error (dtp, f, "Constant string in input format");
1661 return;
1662
1663 /* Format codes that don't transfer data. */
1664 case FMT_X:
1665 case FMT_TR:
1666 consume_data_flag = 0;
1667 dtp->u.p.skips += f->u.n;
1668 pos = bytes_used + dtp->u.p.skips - 1;
1669 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
1670 read_x (dtp, f->u.n);
1671 break;
1672
1673 case FMT_TL:
1674 case FMT_T:
1675 consume_data_flag = 0;
1676
1677 if (f->format == FMT_TL)
1678 {
1679 /* Handle the special case when no bytes have been used yet.
1680 Cannot go below zero. */
1681 if (bytes_used == 0)
1682 {
1683 dtp->u.p.pending_spaces -= f->u.n;
1684 dtp->u.p.skips -= f->u.n;
1685 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
1686 }
1687
1688 pos = bytes_used - f->u.n;
1689 }
1690 else /* FMT_T */
1691 pos = f->u.n - 1;
1692
1693 /* Standard 10.6.1.1: excessive left tabbing is reset to the
1694 left tab limit. We do not check if the position has gone
1695 beyond the end of record because a subsequent tab could
1696 bring us back again. */
1697 pos = pos < 0 ? 0 : pos;
1698
1699 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
1700 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
1701 + pos - dtp->u.p.max_pos;
1702 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
1703 ? 0 : dtp->u.p.pending_spaces;
1704 if (dtp->u.p.skips == 0)
1705 break;
1706
1707 /* Adjust everything for end-of-record condition */
1708 if (dtp->u.p.sf_seen_eor && !is_internal_unit (dtp))
1709 {
1710 dtp->u.p.current_unit->bytes_left -= dtp->u.p.sf_seen_eor;
1711 dtp->u.p.skips -= dtp->u.p.sf_seen_eor;
1712 bytes_used = pos;
d4fc6702
JD		 1713 if (dtp->u.p.pending_spaces == 0)
1714 dtp->u.p.sf_seen_eor = 0;
7812c78c
JD		 1715 }
1716 if (dtp->u.p.skips < 0)
1717 {
e73d3ca6 1718 if (is_internal_unit (dtp))
4dadda8f 1719 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
7812c78c
JD		 1720 else
1721 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
1722 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
1723 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1724 }
1725 else
1726 read_x (dtp, dtp->u.p.skips);
1727 break;
1728
1729 case FMT_S:
1730 consume_data_flag = 0;
60674b3f 1731 dtp->u.p.sign_status = SIGN_PROCDEFINED;
7812c78c
JD		 1732 break;
1733
1734 case FMT_SS:
1735 consume_data_flag = 0;
60674b3f 1736 dtp->u.p.sign_status = SIGN_SUPPRESS;
7812c78c
JD		 1737 break;
1738
1739 case FMT_SP:
1740 consume_data_flag = 0;
60674b3f 1741 dtp->u.p.sign_status = SIGN_PLUS;
7812c78c
JD		 1742 break;
1743
1744 case FMT_BN:
1745 consume_data_flag = 0 ;
1746 dtp->u.p.blank_status = BLANK_NULL;
1747 break;
1748
1749 case FMT_BZ:
1750 consume_data_flag = 0;
1751 dtp->u.p.blank_status = BLANK_ZERO;
1752 break;
1753
1754 case FMT_DC:
1755 consume_data_flag = 0;
1756 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
1757 break;
1758
1759 case FMT_DP:
1760 consume_data_flag = 0;
1761 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
1762 break;
74db2a47 1763
379924dd
JD		 1764 case FMT_RC:
1765 consume_data_flag = 0;
1766 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
1767 break;
1768
1769 case FMT_RD:
1770 consume_data_flag = 0;
1771 dtp->u.p.current_unit->round_status = ROUND_DOWN;
1772 break;
1773
1774 case FMT_RN:
1775 consume_data_flag = 0;
1776 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
1777 break;
1778
1779 case FMT_RP:
1780 consume_data_flag = 0;
1781 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
1782 break;
1783
1784 case FMT_RU:
1785 consume_data_flag = 0;
1786 dtp->u.p.current_unit->round_status = ROUND_UP;
1787 break;
1788
1789 case FMT_RZ:
1790 consume_data_flag = 0;
1791 dtp->u.p.current_unit->round_status = ROUND_ZERO;
1792 break;
7812c78c
JD		 1793
1794 case FMT_P:
1795 consume_data_flag = 0;
1796 dtp->u.p.scale_factor = f->u.k;
1797 break;
1798
1799 case FMT_DOLLAR:
1800 consume_data_flag = 0;
1801 dtp->u.p.seen_dollar = 1;
1802 break;
1803
1804 case FMT_SLASH:
1805 consume_data_flag = 0;
1806 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
1807 next_record (dtp, 0);
1808 break;
1809
1810 case FMT_COLON:
1811 /* A colon descriptor causes us to exit this loop (in
1812 particular preventing another / descriptor from being
1813 processed) unless there is another data item to be
1814 transferred. */
1815 consume_data_flag = 0;
1816 if (n == 0)
1817 return;
1818 break;
1819
1820 default:
1821 internal_error (&dtp->common, "Bad format node");
1822 }
1823
1824 /* Adjust the item count and data pointer. */
1825
1826 if ((consume_data_flag > 0) && (n > 0))
1827 {
1828 n--;
1829 p = ((char *) p) + size;
1830 }
1831
1832 dtp->u.p.skips = 0;
1833
1834 pos = (int)(dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left);
1835 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
1836 }
1837
1838 return;
1839
1840 /* Come here when we need a data descriptor but don't have one. We
1841 push the current format node back onto the input, then return and
1842 let the user program call us back with the data. */
1843 need_read_data:
1844 unget_format (dtp, f);
1845}
1846
1847
1848static void
1849formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kind,
1850 size_t size)
1851{
ea99ec5b 1852 gfc_offset pos, bytes_used;
7812c78c
JD		 1853 const fnode *f;
1854 format_token t;
1855 int n;
1856 int consume_data_flag;
1857
1858 /* Change a complex data item into a pair of reals. */
1859
1860 n = (p == NULL) ? 0 : ((type != BT_COMPLEX) ? 1 : 2);
1861 if (type == BT_COMPLEX)
1862 {
1863 type = BT_REAL;
1864 size /= 2;
1865 }
1866
1867 /* If there's an EOR condition, we simulate finalizing the transfer
1868 by doing nothing. */
1869 if (dtp->u.p.eor_condition)
1870 return;
1871
1872 /* Set this flag so that commas in reads cause the read to complete before
1873 the entire field has been read. The next read field will start right after
1874 the comma in the stream. (Set to 0 for character reads). */
1875 dtp->u.p.sf_read_comma =
1876 dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA ? 0 : 1;
f3ed1d02 1877
6de9cd9a
DN		 1878 for (;;)
1879 {
5d3a9816 1880 /* If reversion has occurred and there is another real data item,
be0cc7e2 1881 then we have to move to the next record. */
5e805e44 1882 if (dtp->u.p.reversion_flag && n > 0)
be0cc7e2 1883 {
5e805e44
JJ		 1884 dtp->u.p.reversion_flag = 0;
1885 next_record (dtp, 0);
be0cc7e2 1886 }
5d3a9816 1887
10256cbe 1888 consume_data_flag = 1;
5e805e44 1889 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
6de9cd9a
DN		 1890 break;
1891
5e805e44 1892 f = next_format (dtp);
6de9cd9a 1893 if (f == NULL)
c4ee121a
JD		 1894 {
1895 /* No data descriptors left. */
afab92d8 1896 if (unlikely (n > 0))
d74b97cc 1897 generate_error (&dtp->common, LIBERROR_FORMAT,
c4ee121a
JD		 1898 "Insufficient data descriptors in format after reversion");
1899 return;
1900 }
be0cc7e2
PT		 1901
1902 /* Now discharge T, TR and X movements to the right. This is delayed
b6f571b7 1903 until a data producing format to suppress trailing spaces. */
e73d3ca6 1904
be0cc7e2 1905 t = f->format;
5e805e44 1906 if (dtp->u.p.mode == WRITING && dtp->u.p.skips != 0
b6f571b7
PT		 1907 && ((n>0 && ( t == FMT_I || t == FMT_B || t == FMT_O
1908 || t == FMT_Z || t == FMT_F || t == FMT_E
1909 || t == FMT_EN || t == FMT_ES || t == FMT_G
e73d3ca6
PT		 1910 || t == FMT_L || t == FMT_A || t == FMT_D
1911 || t == FMT_DT))
be0cc7e2
PT		 1912 || t == FMT_STRING))
1913 {
5e805e44 1914 if (dtp->u.p.skips > 0)
b6f571b7 1915 {
ea99ec5b 1916 gfc_offset tmp;
5e805e44 1917 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
ea99ec5b
JB		 1918 tmp = dtp->u.p.current_unit->recl
1919 - dtp->u.p.current_unit->bytes_left;
e73d3ca6 1920 dtp->u.p.max_pos =
6c540522 1921 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
6e9966e8 1922 dtp->u.p.skips = 0;
b6f571b7 1923 }
5e805e44 1924 if (dtp->u.p.skips < 0)
b6f571b7 1925 {
e73d3ca6 1926 if (is_internal_unit (dtp))
4dadda8f 1927 sseek (dtp->u.p.current_unit->s, dtp->u.p.skips, SEEK_CUR);
15877a88 1928 else
7812c78c 1929 fbuf_seek (dtp->u.p.current_unit, dtp->u.p.skips, SEEK_CUR);
5e805e44 1930 dtp->u.p.current_unit->bytes_left -= (gfc_offset) dtp->u.p.skips;
b6f571b7 1931 }
5e805e44 1932 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
be0cc7e2 1933 }
6de9cd9a 1934
ea99ec5b
JB		 1935 bytes_used = dtp->u.p.current_unit->recl
1936 - dtp->u.p.current_unit->bytes_left;
d40150cc
JD		 1937
1938 if (is_stream_io(dtp))
1939 bytes_used = 0;
94e2b58a 1940
be0cc7e2 1941 switch (t)
6de9cd9a
DN		 1942 {
1943 case FMT_I:
1944 if (n == 0)
1945 goto need_data;
5e805e44 1946 if (require_type (dtp, BT_INTEGER, type, f))
6de9cd9a 1947 return;
7812c78c 1948 write_i (dtp, f, p, kind);
6de9cd9a
DN		 1949 break;
1950
1951 case FMT_B:
1952 if (n == 0)
1953 goto need_data;
58fc89f6 1954 if (!(compile_options.allow_std & GFC_STD_GNU)
32157107
TB		 1955 && require_numeric_type (dtp, type, f))
1956 return;
1957 if (!(compile_options.allow_std & GFC_STD_F2008)
751748ff 1958 && require_type (dtp, BT_INTEGER, type, f))
6de9cd9a 1959 return;
7812c78c 1960 write_b (dtp, f, p, kind);
6de9cd9a
DN		 1961 break;
1962
1963 case FMT_O:
1964 if (n == 0)
e73d3ca6 1965 goto need_data;
58fc89f6 1966 if (!(compile_options.allow_std & GFC_STD_GNU)
32157107
TB		 1967 && require_numeric_type (dtp, type, f))
1968 return;
1969 if (!(compile_options.allow_std & GFC_STD_F2008)
751748ff
TB		 1970 && require_type (dtp, BT_INTEGER, type, f))
1971 return;
7812c78c 1972 write_o (dtp, f, p, kind);
6de9cd9a
DN		 1973 break;
1974
1975 case FMT_Z:
1976 if (n == 0)
1977 goto need_data;
58fc89f6 1978 if (!(compile_options.allow_std & GFC_STD_GNU)
32157107
TB		 1979 && require_numeric_type (dtp, type, f))
1980 return;
1981 if (!(compile_options.allow_std & GFC_STD_F2008)
751748ff
TB		 1982 && require_type (dtp, BT_INTEGER, type, f))
1983 return;
7812c78c 1984 write_z (dtp, f, p, kind);
6de9cd9a
DN		 1985 break;
1986
1987 case FMT_A:
1988 if (n == 0)
1989 goto need_data;
6de9cd9a 1990
cea93abb
JD		 1991 /* It is possible to have FMT_A with something not BT_CHARACTER such
1992 as when writing out hollerith strings, so check both type
1993 and kind before calling wide character routines. */
7812c78c
JD		 1994 if (type == BT_CHARACTER && kind == 4)
1995 write_a_char4 (dtp, f, p, size);
6de9cd9a 1996 else
7812c78c 1997 write_a (dtp, f, p, size);
6de9cd9a
DN		 1998 break;
1999
2000 case FMT_L:
2001 if (n == 0)
2002 goto need_data;
7812c78c 2003 write_l (dtp, f, p, kind);
6de9cd9a
DN		 2004 break;
2005
2006 case FMT_D:
2007 if (n == 0)
2008 goto need_data;
5e805e44 2009 if (require_type (dtp, BT_REAL, type, f))
6de9cd9a 2010 return;
67732fbc 2011 if (f->u.real.w == 0)
2b70275e 2012 write_real_w0 (dtp, p, kind, f);
67732fbc
JD		 2013 else
2014 write_d (dtp, f, p, kind);
6de9cd9a
DN		 2015 break;
2016
e73d3ca6
PT		 2017 case FMT_DT:
2018 if (n == 0)
2019 goto need_data;
2020 int unit = dtp->u.p.current_unit->unit_number;
2021 char dt[] = "DT";
2022 char tmp_iomsg[IOMSG_LEN] = "";
2023 char *child_iomsg;
2024 gfc_charlen_type child_iomsg_len;
2025 int noiostat;
2026 int *child_iostat = NULL;
5cdc4b0e 2027 char *iotype;
e73d3ca6
PT		 2028 gfc_charlen_type iotype_len = f->u.udf.string_len;
2029
2030 /* Build the iotype string. */
2031 if (iotype_len == 0)
2032 {
2033 iotype_len = 2;
2034 iotype = dt;
2035 }
2036 else
5cdc4b0e 2037 iotype = get_dt_format (f->u.udf.string, &iotype_len);
e73d3ca6
PT		 2038
2039 /* Set iostat, intent(out). */
2040 noiostat = 0;
2041 child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
2042 dtp->common.iostat : &noiostat;
2043
2044 /* Set iomsg, intent(inout). */
2045 if (dtp->common.flags & IOPARM_HAS_IOMSG)
2046 {
2047 child_iomsg = dtp->common.iomsg;
2048 child_iomsg_len = dtp->common.iomsg_len;
2049 }
2050 else
2051 {
2052 child_iomsg = tmp_iomsg;
2053 child_iomsg_len = IOMSG_LEN;
2054 }
2055
dc42a736
PT		 2056 if (check_dtio_proc (dtp, f))
2057 return;
2058
e73d3ca6
PT		 2059 /* Call the user defined formatted WRITE procedure. */
2060 dtp->u.p.current_unit->child_dtio++;
dc42a736 2061
e73d3ca6
PT		 2062 dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist,
2063 child_iostat, child_iomsg,
2064 iotype_len, child_iomsg_len);
2065 dtp->u.p.current_unit->child_dtio--;
2066
2067 if (f->u.udf.string_len != 0)
2068 free (iotype);
2069 /* Note: vlist is freed in free_format_data. */
2070 break;
2071
6de9cd9a
DN		 2072 case FMT_E:
2073 if (n == 0)
2074 goto need_data;
5e805e44 2075 if (require_type (dtp, BT_REAL, type, f))
6de9cd9a 2076 return;
67732fbc 2077 if (f->u.real.w == 0)
2b70275e 2078 write_real_w0 (dtp, p, kind, f);
67732fbc
JD		 2079 else
2080 write_e (dtp, f, p, kind);
6de9cd9a
DN		 2081 break;
2082
2083 case FMT_EN:
2084 if (n == 0)
2085 goto need_data;
5e805e44 2086 if (require_type (dtp, BT_REAL, type, f))
6de9cd9a 2087 return;
67732fbc 2088 if (f->u.real.w == 0)
2b70275e 2089 write_real_w0 (dtp, p, kind, f);
67732fbc
JD		 2090 else
2091 write_en (dtp, f, p, kind);
6de9cd9a
DN		 2092 break;
2093
2094 case FMT_ES:
2095 if (n == 0)
2096 goto need_data;
5e805e44 2097 if (require_type (dtp, BT_REAL, type, f))
6de9cd9a 2098 return;
67732fbc 2099 if (f->u.real.w == 0)
2b70275e 2100 write_real_w0 (dtp, p, kind, f);
67732fbc
JD		 2101 else
2102 write_es (dtp, f, p, kind);
6de9cd9a
DN		 2103 break;
2104
2105 case FMT_F:
2106 if (n == 0)
2107 goto need_data;
5e805e44 2108 if (require_type (dtp, BT_REAL, type, f))
6de9cd9a 2109 return;
7812c78c 2110 write_f (dtp, f, p, kind);
6de9cd9a
DN		 2111 break;
2112
2113 case FMT_G:
2114 if (n == 0)
2115 goto need_data;
7812c78c
JD		 2116 switch (type)
2117 {
6de9cd9a 2118 case BT_INTEGER:
cea93abb 2119 write_i (dtp, f, p, kind);
6de9cd9a
DN		 2120 break;
2121 case BT_LOGICAL:
74db2a47 2122 write_l (dtp, f, p, kind);
6de9cd9a
DN		 2123 break;
2124 case BT_CHARACTER:
cea93abb
JD		 2125 if (kind == 4)
2126 write_a_char4 (dtp, f, p, size);
2127 else
2128 write_a (dtp, f, p, size);
6de9cd9a
DN		 2129 break;
2130 case BT_REAL:
9355110f 2131 if (f->u.real.w == 0)
2b70275e 2132 write_real_w0 (dtp, p, kind, f);
9355110f 2133 else
cea93abb 2134 write_d (dtp, f, p, kind);
6de9cd9a
DN		 2135 break;
2136 default:
5e805e44 2137 internal_error (&dtp->common,
2b4c9065 2138 "formatted_transfer (): Bad type");
7812c78c 2139 }
6de9cd9a
DN		 2140 break;
2141
2142 case FMT_STRING:
10256cbe 2143 consume_data_flag = 0;
5e805e44 2144 write_constant_string (dtp, f);
6de9cd9a
DN		 2145 break;
2146
be0cc7e2 2147 /* Format codes that don't transfer data. */
6de9cd9a
DN		 2148 case FMT_X:
2149 case FMT_TR:
22cbc707 2150 consume_data_flag = 0;
be0cc7e2 2151
d40150cc
JD		 2152 dtp->u.p.skips += f->u.n;
2153 pos = bytes_used + dtp->u.p.skips - 1;
2154 dtp->u.p.pending_spaces = pos - dtp->u.p.max_pos + 1;
740f04ef
JD		 2155 /* Writes occur just before the switch on f->format, above, so
2156 that trailing blanks are suppressed, unless we are doing a
2157 non-advancing write in which case we want to output the blanks
2158 now. */
7812c78c 2159 if (dtp->u.p.advance_status == ADVANCE_NO)
740f04ef 2160 {
5e805e44
JJ		 2161 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
2162 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
740f04ef 2163 }
6de9cd9a
DN		 2164 break;
2165
be0cc7e2
PT		 2166 case FMT_TL:
2167 case FMT_T:
22cbc707
JD		 2168 consume_data_flag = 0;
2169
be0cc7e2 2170 if (f->format == FMT_TL)
272c35bd
JD		 2171 {
2172
2173 /* Handle the special case when no bytes have been used yet.
2174 Cannot go below zero. */
2175 if (bytes_used == 0)
2176 {
2177 dtp->u.p.pending_spaces -= f->u.n;
272c35bd
JD		 2178 dtp->u.p.skips -= f->u.n;
2179 dtp->u.p.skips = dtp->u.p.skips < 0 ? 0 : dtp->u.p.skips;
2180 }
2181
2182 pos = bytes_used - f->u.n;
2183 }
be0cc7e2 2184 else /* FMT_T */
7812c78c 2185 pos = f->u.n - dtp->u.p.pending_spaces - 1;
be0cc7e2
PT		 2186
2187 /* Standard 10.6.1.1: excessive left tabbing is reset to the
2188 left tab limit. We do not check if the position has gone
2189 beyond the end of record because a subsequent tab could
2190 bring us back again. */
2191 pos = pos < 0 ? 0 : pos;
2192
5e805e44
JJ		 2193 dtp->u.p.skips = dtp->u.p.skips + pos - bytes_used;
2194 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces
2195 + pos - dtp->u.p.max_pos;
8d917a24
JD		 2196 dtp->u.p.pending_spaces = dtp->u.p.pending_spaces < 0
2197 ? 0 : dtp->u.p.pending_spaces;
6de9cd9a
DN		 2198 break;
2199
2200 case FMT_S:
10256cbe 2201 consume_data_flag = 0;
60674b3f 2202 dtp->u.p.sign_status = SIGN_PROCDEFINED;
6de9cd9a
DN		 2203 break;
2204
2205 case FMT_SS:
10256cbe 2206 consume_data_flag = 0;
60674b3f 2207 dtp->u.p.sign_status = SIGN_SUPPRESS;
6de9cd9a
DN		 2208 break;
2209
2210 case FMT_SP:
10256cbe 2211 consume_data_flag = 0;
60674b3f 2212 dtp->u.p.sign_status = SIGN_PLUS;
6de9cd9a
DN		 2213 break;
2214
2215 case FMT_BN:
be0cc7e2 2216 consume_data_flag = 0 ;
5e805e44 2217 dtp->u.p.blank_status = BLANK_NULL;
6de9cd9a
DN		 2218 break;
2219
2220 case FMT_BZ:
10256cbe 2221 consume_data_flag = 0;
5e805e44 2222 dtp->u.p.blank_status = BLANK_ZERO;
6de9cd9a
DN		 2223 break;
2224
10256cbe
JD		 2225 case FMT_DC:
2226 consume_data_flag = 0;
105b7136 2227 dtp->u.p.current_unit->decimal_status = DECIMAL_COMMA;
10256cbe
JD		 2228 break;
2229
2230 case FMT_DP:
2231 consume_data_flag = 0;
105b7136 2232 dtp->u.p.current_unit->decimal_status = DECIMAL_POINT;
10256cbe
JD		 2233 break;
2234
379924dd
JD		 2235 case FMT_RC:
2236 consume_data_flag = 0;
2237 dtp->u.p.current_unit->round_status = ROUND_COMPATIBLE;
2238 break;
2239
2240 case FMT_RD:
2241 consume_data_flag = 0;
2242 dtp->u.p.current_unit->round_status = ROUND_DOWN;
2243 break;
2244
2245 case FMT_RN:
2246 consume_data_flag = 0;
2247 dtp->u.p.current_unit->round_status = ROUND_NEAREST;
2248 break;
2249
2250 case FMT_RP:
2251 consume_data_flag = 0;
2252 dtp->u.p.current_unit->round_status = ROUND_PROCDEFINED;
2253 break;
2254
2255 case FMT_RU:
2256 consume_data_flag = 0;
2257 dtp->u.p.current_unit->round_status = ROUND_UP;
2258 break;
2259
2260 case FMT_RZ:
2261 consume_data_flag = 0;
2262 dtp->u.p.current_unit->round_status = ROUND_ZERO;
2263 break;
2264
6de9cd9a 2265 case FMT_P:
10256cbe 2266 consume_data_flag = 0;
5e805e44 2267 dtp->u.p.scale_factor = f->u.k;
6de9cd9a
DN		 2268 break;
2269
2270 case FMT_DOLLAR:
10256cbe 2271 consume_data_flag = 0;
5e805e44 2272 dtp->u.p.seen_dollar = 1;
6de9cd9a
DN		 2273 break;
2274
2275 case FMT_SLASH:
10256cbe 2276 consume_data_flag = 0;
5e805e44
JJ		 2277 dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
2278 next_record (dtp, 0);
6de9cd9a
DN		 2279 break;
2280
2281 case FMT_COLON:
7fcb1804
TS		 2282 /* A colon descriptor causes us to exit this loop (in
2283 particular preventing another / descriptor from being
2284 processed) unless there is another data item to be
2285 transferred. */
10256cbe 2286 consume_data_flag = 0;
6de9cd9a
DN		 2287 if (n == 0)
2288 return;
2289 break;
2290
2291 default:
5e805e44 2292 internal_error (&dtp->common, "Bad format node");
6de9cd9a
DN		 2293 }
2294
7fcb1804 2295 /* Adjust the item count and data pointer. */
6de9cd9a
DN		 2296
2297 if ((consume_data_flag > 0) && (n > 0))
7812c78c
JD		 2298 {
2299 n--;
2300 p = ((char *) p) + size;
2301 }
be0cc7e2 2302
ea99ec5b 2303 pos = dtp->u.p.current_unit->recl - dtp->u.p.current_unit->bytes_left;
5e805e44 2304 dtp->u.p.max_pos = (dtp->u.p.max_pos > pos) ? dtp->u.p.max_pos : pos;
6de9cd9a
DN		 2305 }
2306
2307 return;
2308
f21edfd6
RH		 2309 /* Come here when we need a data descriptor but don't have one. We
2310 push the current format node back onto the input, then return and
2311 let the user program call us back with the data. */
2312 need_data:
5e805e44 2313 unget_format (dtp, f);
6de9cd9a
DN		 2314}
2315
f983954d
JD		 2316 /* This function is first called from data_init_transfer to initiate the loop
2317 over each item in the format, transferring data as required. Subsequent
2318 calls to this function occur for each data item foound in the READ/WRITE
2319 statement. The item_count is incremented for each call. Since the first
2320 call is from data_transfer_init, the item_count is always one greater than
2321 the actual count number of the item being transferred. */
7812c78c 2322
18623fae 2323static void
5e805e44
JJ		 2324formatted_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
2325 size_t size, size_t nelems)
18623fae
JB		 2326{
2327 size_t elem;
18623fae
JB		 2328 char *tmp;
2329
2330 tmp = (char *) p;
cea93abb
JD		 2331 size_t stride = type == BT_CHARACTER ?
2332 size * GFC_SIZE_OF_CHAR_KIND(kind) : size;
7812c78c
JD		 2333 if (dtp->u.p.mode == READING)
2334 {
2335 /* Big loop over all the elements. */
2336 for (elem = 0; elem < nelems; elem++)
2337 {
2338 dtp->u.p.item_count++;
2339 formatted_transfer_scalar_read (dtp, type, tmp + stride*elem, kind, size);
2340 }
2341 }
2342 else
18623fae 2343 {
7812c78c
JD		 2344 /* Big loop over all the elements. */
2345 for (elem = 0; elem < nelems; elem++)
2346 {
2347 dtp->u.p.item_count++;
2348 formatted_transfer_scalar_write (dtp, type, tmp + stride*elem, kind, size);
2349 }
18623fae
JB		 2350 }
2351}
2352
2b4c9065
NK		 2353/* Wrapper function for I/O of scalar types. If this should be an async I/O
2354 request, queue it. For a synchronous write on an async unit, perform the
2355 wait operation and return an error. For all synchronous writes, call the
2356 right transfer function. */
2357
2358static void
2359wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
2360 size_t size, size_t n_elem)
2361{
2362 if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
2363 {
2364 if (dtp->u.p.async)
2365 {
2366 transfer_args args;
2367 args.scalar.transfer = dtp->u.p.transfer;
2368 args.scalar.arg_bt = type;
2369 args.scalar.data = p;
2370 args.scalar.i = kind;
2371 args.scalar.s1 = size;
2372 args.scalar.s2 = n_elem;
2373 enqueue_transfer (dtp->u.p.current_unit->au, &args,
2374 AIO_TRANSFER_SCALAR);
2375 return;
2376 }
2377 }
2378 /* Come here if there was no asynchronous I/O to be scheduled. */
2379 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2380 return;
2381
2382 dtp->u.p.transfer (dtp, type, p, kind, size, 1);
2383}
2384
18623fae 2385
6de9cd9a 2386/* Data transfer entry points. The type of the data entity is
7fcb1804
TS		 2387 implicit in the subroutine call. This prevents us from having to
2388 share a common enum with the compiler. */
6de9cd9a
DN		 2389
2390void
5e805e44 2391transfer_integer (st_parameter_dt *dtp, void *p, int kind)
6de9cd9a 2392{
2b4c9065 2393 wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1);
6de9cd9a
DN		 2394}
2395
6eb6875d
TK		 2396void
2397transfer_integer_write (st_parameter_dt *dtp, void *p, int kind)
2398{
2399 transfer_integer (dtp, p, kind);
2400}
6de9cd9a
DN		 2401
2402void
5e805e44 2403transfer_real (st_parameter_dt *dtp, void *p, int kind)
6de9cd9a 2404{
e5ef4b3b 2405 size_t size;
5e805e44 2406 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
6de9cd9a 2407 return;
e5ef4b3b 2408 size = size_from_real_kind (kind);
2b4c9065 2409 wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1);
6de9cd9a
DN		 2410}
2411
6eb6875d
TK		 2412void
2413transfer_real_write (st_parameter_dt *dtp, void *p, int kind)
2414{
2415 transfer_real (dtp, p, kind);
2416}
6de9cd9a
DN		 2417
2418void
5e805e44 2419transfer_logical (st_parameter_dt *dtp, void *p, int kind)
6de9cd9a 2420{
2b4c9065 2421 wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
6de9cd9a
DN		 2422}
2423
6eb6875d
TK		 2424void
2425transfer_logical_write (st_parameter_dt *dtp, void *p, int kind)
2426{
2427 transfer_logical (dtp, p, kind);
2428}
6de9cd9a
DN		 2429
2430void
f622221a 2431transfer_character (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
6de9cd9a 2432{
e5044336
FXC		 2433 static char *empty_string[0];
2434
5e805e44 2435 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
6de9cd9a 2436 return;
e5044336
FXC		 2437
2438 /* Strings of zero length can have p == NULL, which confuses the
2439 transfer routines into thinking we need more data elements. To avoid
2440 this, we give them a nice pointer. */
2441 if (len == 0 && p == NULL)
2442 p = empty_string;
2443
cea93abb 2444 /* Set kind here to 1. */
2b4c9065 2445 wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1);
cea93abb
JD		 2446}
2447
6eb6875d 2448void
f622221a 2449transfer_character_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len)
6eb6875d
TK		 2450{
2451 transfer_character (dtp, p, len);
2452}
2453
cea93abb 2454void
f622221a 2455transfer_character_wide (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
cea93abb
JD		 2456{
2457 static char *empty_string[0];
2458
2459 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2460 return;
2461
2462 /* Strings of zero length can have p == NULL, which confuses the
2463 transfer routines into thinking we need more data elements. To avoid
2464 this, we give them a nice pointer. */
2465 if (len == 0 && p == NULL)
2466 p = empty_string;
2467
2468 /* Here we pass the actual kind value. */
2b4c9065 2469 wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1);
6de9cd9a
DN		 2470}
2471
6eb6875d 2472void
f622221a 2473transfer_character_wide_write (st_parameter_dt *dtp, void *p, gfc_charlen_type len, int kind)
6eb6875d
TK		 2474{
2475 transfer_character_wide (dtp, p, len, kind);
2476}
6de9cd9a
DN		 2477
2478void
5e805e44 2479transfer_complex (st_parameter_dt *dtp, void *p, int kind)
6de9cd9a 2480{
e5ef4b3b 2481 size_t size;
5e805e44 2482 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
6de9cd9a 2483 return;
e5ef4b3b 2484 size = size_from_complex_kind (kind);
2b4c9065 2485 wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1);
18623fae
JB		 2486}
2487
6eb6875d
TK		 2488void
2489transfer_complex_write (st_parameter_dt *dtp, void *p, int kind)
2490{
2491 transfer_complex (dtp, p, kind);
2492}
18623fae
JB		 2493
2494void
2b4c9065
NK		 2495transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2496 gfc_charlen_type charlen)
18623fae
JB		 2497{
2498 index_type count[GFC_MAX_DIMENSIONS];
2499 index_type extent[GFC_MAX_DIMENSIONS];
2500 index_type stride[GFC_MAX_DIMENSIONS];
a11930ba 2501 index_type stride0, rank, size, n;
18623fae
JB		 2502 size_t tsize;
2503 char *data;
2504 bt iotype;
2505
7fb43006 2506 /* Adjust item_count before emitting error message. */
2b4c9065 2507
5e805e44 2508 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
18623fae
JB		 2509 return;
2510
a11930ba 2511 iotype = (bt) GFC_DESCRIPTOR_TYPE (desc);
140a0bdd 2512 size = iotype == BT_CHARACTER ? charlen : GFC_DESCRIPTOR_SIZE (desc);
18623fae 2513
18623fae 2514 rank = GFC_DESCRIPTOR_RANK (desc);
7fb43006 2515
18623fae
JB		 2516 for (n = 0; n < rank; n++)
2517 {
2518 count[n] = 0;
dfb55fdc
TK		 2519 stride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(desc,n);
2520 extent[n] = GFC_DESCRIPTOR_EXTENT(desc,n);
18623fae
JB		 2521
2522 /* If the extent of even one dimension is zero, then the entire
4152bc26
JD		 2523 array section contains zero elements, so we return after writing
2524 a zero array record. */
87cd572d 2525 if (extent[n] <= 0)
4152bc26
JD		 2526 {
2527 data = NULL;
2528 tsize = 0;
2529 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2530 return;
2531 }
18623fae
JB		 2532 }
2533
2534 stride0 = stride[0];
2535
dfb55fdc 2536 /* If the innermost dimension has a stride of 1, we can do the transfer
18623fae 2537 in contiguous chunks. */
dfb55fdc 2538 if (stride0 == size)
18623fae
JB		 2539 tsize = extent[0];
2540 else
2541 tsize = 1;
2542
2543 data = GFC_DESCRIPTOR_DATA (desc);
2544
859174c8
TK		 2545 /* When reading, we need to check endfile conditions so we do not miss
2546 an END=label. Make this separate so we do not have an extra test
2547 in a tight loop when it is not needed. */
2548
2549 if (dtp->u.p.current_unit && dtp->u.p.mode == READING)
18623fae 2550 {
859174c8 2551 while (data)
18623fae 2552 {
859174c8
TK		 2553 if (unlikely (dtp->u.p.current_unit->endfile == AFTER_ENDFILE))
2554 return;
2555
2556 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2557 data += stride0 * tsize;
2558 count[0] += tsize;
2559 n = 0;
2560 while (count[n] == extent[n])
18623fae 2561 {
859174c8
TK		 2562 count[n] = 0;
2563 data -= stride[n] * extent[n];
2564 n++;
2565 if (n == rank)
2566 {
2567 data = NULL;
2568 break;
2569 }
2570 else
2571 {
2572 count[n]++;
2573 data += stride[n];
2574 }
18623fae 2575 }
859174c8
TK		 2576 }
2577 }
2578 else
2579 {
2580 while (data)
2581 {
2582 dtp->u.p.transfer (dtp, iotype, data, kind, size, tsize);
2583 data += stride0 * tsize;
2584 count[0] += tsize;
2585 n = 0;
2586 while (count[n] == extent[n])
18623fae 2587 {
859174c8
TK		 2588 count[n] = 0;
2589 data -= stride[n] * extent[n];
2590 n++;
2591 if (n == rank)
2592 {
2593 data = NULL;
2594 break;
2595 }
2596 else
2597 {
2598 count[n]++;
2599 data += stride[n];
2600 }
18623fae
JB		 2601 }
2602 }
2603 }
6de9cd9a
DN		 2604}
2605
2b4c9065
NK		 2606void
2607transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2608 gfc_charlen_type charlen)
2609{
2610 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2611 return;
2612
2613 if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
2614 {
2615 if (dtp->u.p.async)
2616 {
2617 transfer_args args;
2618 size_t sz = sizeof (gfc_array_char)
2619 + sizeof (descriptor_dimension)
2620 * GFC_DESCRIPTOR_RANK (desc);
2621 args.array.desc = xmalloc (sz);
2622 NOTE ("desc = %p", (void *) args.array.desc);
2623 memcpy (args.array.desc, desc, sz);
2624 args.array.kind = kind;
2625 args.array.charlen = charlen;
2626 enqueue_transfer (dtp->u.p.current_unit->au, &args,
2627 AIO_TRANSFER_ARRAY);
2628 return;
2629 }
2630 }
2631 /* Come here if there was no asynchronous I/O to be scheduled. */
2632 transfer_array_inner (dtp, desc, kind, charlen);
2633}
2634
2635
6eb6875d
TK		 2636void
2637transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
2638 gfc_charlen_type charlen)
2639{
2640 transfer_array (dtp, desc, kind, charlen);
2641}
6de9cd9a 2642
e73d3ca6
PT		 2643
2644/* User defined input/output iomsg. */
2645
2646#define IOMSG_LEN 256
2647
2648void
2649transfer_derived (st_parameter_dt *parent, void *dtio_source, void *dtio_proc)
2650{
2651 if (parent->u.p.current_unit)
2652 {
2653 if (parent->u.p.current_unit->flags.form == FORM_UNFORMATTED)
2654 parent->u.p.ufdtio_ptr = (unformatted_dtio) dtio_proc;
2655 else
2656 parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
2657 }
2b4c9065 2658 wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
e73d3ca6
PT		 2659}
2660
2661
7fcb1804 2662/* Preposition a sequential unformatted file while reading. */
6de9cd9a
DN		 2663
2664static void
07b3bbf2 2665us_read (st_parameter_dt *dtp, int continued)
6de9cd9a 2666{
7812c78c 2667 ssize_t n, nr;
d67ab5ee
TK		 2668 GFC_INTEGER_4 i4;
2669 GFC_INTEGER_8 i8;
08656747 2670 gfc_offset i;
6de9cd9a 2671
d67ab5ee 2672 if (compile_options.record_marker == 0)
07b3bbf2 2673 n = sizeof (GFC_INTEGER_4);
d67ab5ee
TK		 2674 else
2675 n = compile_options.record_marker;
2676
7812c78c
JD		 2677 nr = sread (dtp->u.p.current_unit->s, &i, n);
2678 if (unlikely (nr < 0))
15877a88
JB		 2679 {
2680 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
2681 return;
2682 }
7812c78c 2683 else if (nr == 0)
7b7034ea 2684 {
7812c78c 2685 hit_eof (dtp);
7b7034ea
JD		 2686 return; /* end of file */
2687 }
7812c78c 2688 else if (unlikely (n != nr))
6de9cd9a 2689 {
d74b97cc 2690 generate_error (&dtp->common, LIBERROR_BAD_US, NULL);
6de9cd9a
DN		 2691 return;
2692 }
2693
d74b97cc 2694 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
afab92d8 2695 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
d67ab5ee 2696 {
07b3bbf2 2697 switch (nr)
d67ab5ee 2698 {
d67ab5ee 2699 case sizeof(GFC_INTEGER_4):
15877a88 2700 memcpy (&i4, &i, sizeof (i4));
d67ab5ee
TK		 2701 i = i4;
2702 break;
2703
2704 case sizeof(GFC_INTEGER_8):
15877a88 2705 memcpy (&i8, &i, sizeof (i8));
d67ab5ee
TK		 2706 i = i8;
2707 break;
2708
2709 default:
2710 runtime_error ("Illegal value for record marker");
2711 break;
2712 }
2713 }
181c9f4a 2714 else
facb23dc
JB		 2715 {
2716 uint32_t u32;
2717 uint64_t u64;
07b3bbf2 2718 switch (nr)
d67ab5ee 2719 {
d67ab5ee 2720 case sizeof(GFC_INTEGER_4):
facb23dc
JB		 2721 memcpy (&u32, &i, sizeof (u32));
2722 u32 = __builtin_bswap32 (u32);
2723 memcpy (&i4, &u32, sizeof (i4));
d67ab5ee
TK		 2724 i = i4;
2725 break;
2726
2727 case sizeof(GFC_INTEGER_8):
facb23dc
JB		 2728 memcpy (&u64, &i, sizeof (u64));
2729 u64 = __builtin_bswap64 (u64);
2730 memcpy (&i8, &u64, sizeof (i8));
d67ab5ee
TK		 2731 i = i8;
2732 break;
2733
2734 default:
2735 runtime_error ("Illegal value for record marker");
2736 break;
2737 }
facb23dc 2738 }
d67ab5ee 2739
07b3bbf2
TK		 2740 if (i >= 0)
2741 {
2742 dtp->u.p.current_unit->bytes_left_subrecord = i;
2743 dtp->u.p.current_unit->continued = 0;
2744 }
2745 else
2746 {
2747 dtp->u.p.current_unit->bytes_left_subrecord = -i;
2748 dtp->u.p.current_unit->continued = 1;
2749 }
2750
2751 if (! continued)
2752 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
6de9cd9a
DN		 2753}
2754
2755
7fcb1804
TS		 2756/* Preposition a sequential unformatted file while writing. This
2757 amount to writing a bogus length that will be filled in later. */
6de9cd9a
DN		 2758
2759static void
07b3bbf2 2760us_write (st_parameter_dt *dtp, int continued)
6de9cd9a 2761{
7812c78c 2762 ssize_t nbytes;
82b8244c 2763 gfc_offset dummy;
6de9cd9a 2764
82b8244c 2765 dummy = 0;
d67ab5ee
TK		 2766
2767 if (compile_options.record_marker == 0)
07b3bbf2 2768 nbytes = sizeof (GFC_INTEGER_4);
d67ab5ee
TK		 2769 else
2770 nbytes = compile_options.record_marker ;
6de9cd9a 2771
7812c78c 2772 if (swrite (dtp->u.p.current_unit->s, &dummy, nbytes) != nbytes)
d74b97cc 2773 generate_error (&dtp->common, LIBERROR_OS, NULL);
6de9cd9a 2774
b0c6db58 2775 /* For sequential unformatted, if RECL= was not specified in the OPEN
07b3bbf2
TK		 2776 we write until we have more bytes than can fit in the subrecord
2777 markers, then we write a new subrecord. */
bf1df0a0 2778
07b3bbf2
TK		 2779 dtp->u.p.current_unit->bytes_left_subrecord =
2780 dtp->u.p.current_unit->recl_subrecord;
2781 dtp->u.p.current_unit->continued = continued;
6de9cd9a
DN		 2782}
2783
2784
7fcb1804
TS		 2785/* Position to the next record prior to transfer. We are assumed to
2786 be before the next record. We also calculate the bytes in the next
2787 record. */
6de9cd9a
DN		 2788
2789static void
5e805e44 2790pre_position (st_parameter_dt *dtp)
6de9cd9a 2791{
5e805e44 2792 if (dtp->u.p.current_unit->current_record)
7fcb1804 2793 return; /* Already positioned. */
6de9cd9a 2794
5e805e44 2795 switch (current_mode (dtp))
6de9cd9a 2796 {
91b30ee5
JD		 2797 case FORMATTED_STREAM:
2798 case UNFORMATTED_STREAM:
15877a88
JB		 2799 /* There are no records with stream I/O. If the position was specified
2800 data_transfer_init has already positioned the file. If no position
2801 was specified, we continue from where we last left off. I.e.
2802 there is nothing to do here. */
91b30ee5 2803 break;
e73d3ca6 2804
6de9cd9a 2805 case UNFORMATTED_SEQUENTIAL:
5e805e44 2806 if (dtp->u.p.mode == READING)
07b3bbf2 2807 us_read (dtp, 0);
6de9cd9a 2808 else
07b3bbf2 2809 us_write (dtp, 0);
6de9cd9a
DN		 2810
2811 break;
2812
2813 case FORMATTED_SEQUENTIAL:
2814 case FORMATTED_DIRECT:
2815 case UNFORMATTED_DIRECT:
5e805e44 2816 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
6de9cd9a 2817 break;
60674b3f
JD		 2818 case FORMATTED_UNSPECIFIED:
2819 gcc_unreachable ();
6de9cd9a
DN		 2820 }
2821
5e805e44 2822 dtp->u.p.current_unit->current_record = 1;
6de9cd9a
DN		 2823}
2824
2825
7fcb1804
TS		 2826/* Initialize things for a data transfer. This code is common for
2827 both reading and writing. */
6de9cd9a
DN		 2828
2829static void
5e805e44 2830data_transfer_init (st_parameter_dt *dtp, int read_flag)
6de9cd9a 2831{
7fcb1804 2832 unit_flags u_flags; /* Used for creating a unit if needed. */
5e805e44
JJ		 2833 GFC_INTEGER_4 cf = dtp->common.flags;
2834 namelist_info *ionml;
2b4c9065
NK		 2835 async_unit *au;
2836
2837 NOTE ("data_transfer_init");
6de9cd9a 2838
5e805e44 2839 ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
d7445152 2840
e1456843 2841 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
d7445152 2842
5e805e44
JJ		 2843 dtp->u.p.ionml = ionml;
2844 dtp->u.p.mode = read_flag ? READING : WRITING;
c4508d0a 2845 dtp->u.p.namelist_mode = 0;
0ef33d44
FR		 2846 dtp->u.p.cc.len = 0;
2847
cb13c288
JD		 2848 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
2849 return;
2850
5e805e44 2851 dtp->u.p.current_unit = get_unit (dtp, 1);
e73d3ca6 2852
c04d4ede
JB		 2853 if (dtp->u.p.current_unit == NULL)
2854 {
2855 /* This means we tried to access an external unit < 0 without
2856 having opened it first with NEWUNIT=. */
2857 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
9937c1eb
JB		 2858 "Unit number is negative and unit was not already "
2859 "opened with OPEN(NEWUNIT=...)");
c04d4ede
JB		 2860 return;
2861 }
2862 else if (dtp->u.p.current_unit->s == NULL)
c0d16890 2863 { /* Open the unit with some default flags. */
2b4c9065
NK		 2864 st_parameter_open opp;
2865 unit_convert conv;
2866 NOTE ("Open the unit with some default flags.");
c0d16890
JD		 2867 memset (&u_flags, '\0', sizeof (u_flags));
2868 u_flags.access = ACCESS_SEQUENTIAL;
2869 u_flags.action = ACTION_READWRITE;
2870
2871 /* Is it unformatted? */
2872 if (!(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
2873 | IOPARM_DT_IONML_SET)))
2874 u_flags.form = FORM_UNFORMATTED;
2875 else
2876 u_flags.form = FORM_UNSPECIFIED;
2877
2878 u_flags.delim = DELIM_UNSPECIFIED;
2879 u_flags.blank = BLANK_UNSPECIFIED;
2880 u_flags.pad = PAD_UNSPECIFIED;
2881 u_flags.decimal = DECIMAL_UNSPECIFIED;
2882 u_flags.encoding = ENCODING_UNSPECIFIED;
2883 u_flags.async = ASYNC_UNSPECIFIED;
2884 u_flags.round = ROUND_UNSPECIFIED;
2885 u_flags.sign = SIGN_UNSPECIFIED;
0ef33d44
FR		 2886 u_flags.share = SHARE_UNSPECIFIED;
2887 u_flags.cc = CC_UNSPECIFIED;
2888 u_flags.readonly = 0;
c0d16890
JD		 2889
2890 u_flags.status = STATUS_UNKNOWN;
2891
2892 conv = get_unformatted_convert (dtp->common.unit);
2893
2894 if (conv == GFC_CONVERT_NONE)
2895 conv = compile_options.convert;
2896
c0d16890
JD		 2897 switch (conv)
2898 {
d7445152
JD		 2899 case GFC_CONVERT_NATIVE:
2900 case GFC_CONVERT_SWAP:
2901 break;
e73d3ca6 2902
d7445152 2903 case GFC_CONVERT_BIG:
5675291d 2904 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
d7445152 2905 break;
e73d3ca6 2906
d7445152 2907 case GFC_CONVERT_LITTLE:
5675291d 2908 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
d7445152 2909 break;
e73d3ca6 2910
d7445152
JD		 2911 default:
2912 internal_error (&opp.common, "Illegal value for CONVERT");
2913 break;
c0d16890 2914 }
5068c625 2915
c0d16890 2916 u_flags.convert = conv;
5068c625 2917
c0d16890
JD		 2918 opp.common = dtp->common;
2919 opp.common.flags &= IOPARM_COMMON_MASK;
2920 dtp->u.p.current_unit = new_unit (&opp, dtp->u.p.current_unit, &u_flags);
2921 dtp->common.flags &= ~IOPARM_COMMON_MASK;
2922 dtp->common.flags |= (opp.common.flags & IOPARM_COMMON_MASK);
2923 if (dtp->u.p.current_unit == NULL)
2924 return;
2925 }
6de9cd9a 2926
c680ada5
JD		 2927 if (dtp->u.p.current_unit->child_dtio == 0)
2928 {
2929 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
2930 {
2931 dtp->u.p.current_unit->has_size = true;
2932 /* Initialize the count. */
2933 dtp->u.p.current_unit->size_used = 0;
2934 }
2935 else
2936 dtp->u.p.current_unit->has_size = false;
2937 }
7b39e3c2
JD		 2938 else if (dtp->u.p.current_unit->internal_unit_kind > 0)
2939 dtp->u.p.unit_is_internal = 1;
c680ada5 2940
2b4c9065
NK		 2941 if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0)
2942 {
2943 int f;
2944 f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len,
2945 async_opt, "Bad ASYNCHRONOUS in data transfer "
2946 "statement");
2947 if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES)
2948 {
2949 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
2950 "ASYNCHRONOUS transfer without "
2951 "ASYHCRONOUS='YES' in OPEN");
2952 return;
2953 }
2954 dtp->u.p.async = f == ASYNC_YES;
2955 }
2956
2957 au = dtp->u.p.current_unit->au;
2958 if (au)
2959 {
2960 if (dtp->u.p.async)
2961 {
2962 /* If this is an asynchronous I/O statement, collect errors and
2963 return if there are any. */
2964 if (collect_async_errors (&dtp->common, au))
2965 return;
2966 }
2967 else
2968 {
2969 /* Synchronous statement: Perform a wait operation for any pending
2970 asynchronous I/O. This needs to be done before all other error
2971 checks. See F2008, 9.6.4.1. */
2972 if (async_wait (&(dtp->common), au))
2973 return;
2974 }
2975 }
2976
7fcb1804 2977 /* Check the action. */
6de9cd9a 2978
5e805e44 2979 if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
e08e57d0 2980 {
d74b97cc 2981 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
e08e57d0
TK		 2982 "Cannot read from file opened for WRITE");
2983 return;
2984 }
6de9cd9a 2985
5e805e44 2986 if (!read_flag && dtp->u.p.current_unit->flags.action == ACTION_READ)
e08e57d0 2987 {
d74b97cc 2988 generate_error (&dtp->common, LIBERROR_BAD_ACTION,
e08e57d0
TK		 2989 "Cannot write to file opened for READ");
2990 return;
2991 }
6de9cd9a 2992
5e805e44
JJ		 2993 dtp->u.p.first_item = 1;
2994
7fcb1804 2995 /* Check the format. */
6de9cd9a 2996
5e805e44
JJ		 2997 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
2998 parse_format (dtp);
6de9cd9a 2999
5e805e44
JJ		 3000 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED
3001 && (cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
3002 != 0)
e08e57d0 3003 {
d74b97cc 3004 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
e08e57d0
TK		 3005 "Format present for UNFORMATTED data transfer");
3006 return;
3007 }
6de9cd9a 3008
5e805e44 3009 if ((cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0 && dtp->u.p.ionml != NULL)
6de9cd9a 3010 {
5e805e44 3011 if ((cf & IOPARM_DT_HAS_FORMAT) != 0)
1ede59e4
JD		 3012 {
3013 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
3014 "A format cannot be specified with a namelist");
3015 return;
3016 }
6de9cd9a 3017 }
5e805e44
JJ		 3018 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED &&
3019 !(cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT)))
e08e57d0 3020 {
d74b97cc 3021 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
e08e57d0 3022 "Missing format for FORMATTED data transfer");
1ede59e4 3023 return;
e08e57d0 3024 }
6de9cd9a 3025
5e805e44
JJ		 3026 if (is_internal_unit (dtp)
3027 && dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
e08e57d0 3028 {
d74b97cc 3029 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
e08e57d0
TK		 3030 "Internal file cannot be accessed by UNFORMATTED "
3031 "data transfer");
3032 return;
3033 }
6de9cd9a 3034
7812c78c 3035 /* Check the record or position number. */
6de9cd9a 3036
5e805e44
JJ		 3037 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT
3038 && (cf & IOPARM_DT_HAS_REC) == 0)
6de9cd9a 3039 {
d74b97cc 3040 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
6de9cd9a
DN		 3041 "Direct access data transfer requires record number");
3042 return;
3043 }
3044
b9983d61 3045 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
6de9cd9a 3046 {
b9983d61
JD		 3047 if ((cf & IOPARM_DT_HAS_REC) != 0)
3048 {
3049 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
3050 "Record number not allowed for sequential access "
3051 "data transfer");
3052 return;
3053 }
6de9cd9a 3054
4bfbd309
JD		 3055 if (compile_options.warn_std &&
3056 dtp->u.p.current_unit->endfile == AFTER_ENDFILE)
b9983d61
JD		 3057 {
3058 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
3059 "Sequential READ or WRITE not allowed after "
3060 "EOF marker, possibly use REWIND or BACKSPACE");
3061 return;
3062 }
b9983d61 3063 }
c08de9db 3064
7fcb1804 3065 /* Process the ADVANCE option. */
6de9cd9a 3066
5e805e44
JJ		 3067 dtp->u.p.advance_status
3068 = !(cf & IOPARM_DT_HAS_ADVANCE) ? ADVANCE_UNSPECIFIED :
3069 find_option (&dtp->common, dtp->advance, dtp->advance_len, advance_opt,
3070 "Bad ADVANCE parameter in data transfer statement");
6de9cd9a 3071
5e805e44 3072 if (dtp->u.p.advance_status != ADVANCE_UNSPECIFIED)
6de9cd9a 3073 {
5e805e44 3074 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
e08e57d0 3075 {
d74b97cc 3076 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
d7445152
JD		 3077 "ADVANCE specification conflicts with sequential "
3078 "access");
e08e57d0
TK		 3079 return;
3080 }
6de9cd9a 3081
5e805e44 3082 if (is_internal_unit (dtp))
e08e57d0 3083 {
d74b97cc 3084 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
e08e57d0
TK		 3085 "ADVANCE specification conflicts with internal file");
3086 return;
3087 }
6de9cd9a 3088
5e805e44
JJ		 3089 if ((cf & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT))
3090 != IOPARM_DT_HAS_FORMAT)
e08e57d0 3091 {
d74b97cc 3092 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
e08e57d0
TK		 3093 "ADVANCE specification requires an explicit format");
3094 return;
3095 }
6de9cd9a
DN		 3096 }
3097
1f10d710
JD		 3098 /* Child IO is non-advancing and any ADVANCE= specifier is ignored.
3099 F2008 9.6.2.4 */
3100 if (dtp->u.p.current_unit->child_dtio > 0)
3101 dtp->u.p.advance_status = ADVANCE_NO;
3102
6de9cd9a
DN		 3103 if (read_flag)
3104 {
108bc190
TK		 3105 dtp->u.p.current_unit->previous_nonadvancing_write = 0;
3106
5e805e44 3107 if ((cf & IOPARM_EOR) != 0 && dtp->u.p.advance_status != ADVANCE_NO)
e08e57d0 3108 {
d74b97cc 3109 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
e08e57d0
TK		 3110 "EOR specification requires an ADVANCE specification "
3111 "of NO");
3112 return;
3113 }
6de9cd9a 3114
e73d3ca6 3115 if ((cf & IOPARM_DT_HAS_SIZE) != 0
d7445152 3116 && dtp->u.p.advance_status != ADVANCE_NO)
e08e57d0 3117 {
d74b97cc 3118 generate_error (&dtp->common, LIBERROR_MISSING_OPTION,
d7445152
JD		 3119 "SIZE specification requires an ADVANCE "
3120 "specification of NO");
e08e57d0
TK		 3121 return;
3122 }
6de9cd9a
DN		 3123 }
3124 else
7fcb1804 3125 { /* Write constraints. */
5e805e44 3126 if ((cf & IOPARM_END) != 0)
e08e57d0 3127 {
d74b97cc 3128 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
d7445152
JD		 3129 "END specification cannot appear in a write "
3130 "statement");
e08e57d0
TK		 3131 return;
3132 }
6de9cd9a 3133
5e805e44 3134 if ((cf & IOPARM_EOR) != 0)
e08e57d0 3135 {
d74b97cc 3136 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
d7445152
JD		 3137 "EOR specification cannot appear in a write "
3138 "statement");
e08e57d0
TK		 3139 return;
3140 }
6de9cd9a 3141
5e805e44 3142 if ((cf & IOPARM_DT_HAS_SIZE) != 0)
e08e57d0 3143 {
d74b97cc 3144 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
d7445152
JD		 3145 "SIZE specification cannot appear in a write "
3146 "statement");
e08e57d0
TK		 3147 return;
3148 }
6de9cd9a
DN		 3149 }
3150
5e805e44
JJ		 3151 if (dtp->u.p.advance_status == ADVANCE_UNSPECIFIED)
3152 dtp->u.p.advance_status = ADVANCE_YES;
6de9cd9a 3153
105b7136
JD		 3154 /* Check the decimal mode. */
3155 dtp->u.p.current_unit->decimal_status
d7445152 3156 = !(cf & IOPARM_DT_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
e1456843 3157 find_option (&dtp->common, dtp->decimal, dtp->decimal_len,
d7445152
JD		 3158 decimal_opt, "Bad DECIMAL parameter in data transfer "
3159 "statement");
3160
105b7136
JD		 3161 if (dtp->u.p.current_unit->decimal_status == DECIMAL_UNSPECIFIED)
3162 dtp->u.p.current_unit->decimal_status = dtp->u.p.current_unit->flags.decimal;
d7445152 3163
379924dd
JD		 3164 /* Check the round mode. */
3165 dtp->u.p.current_unit->round_status
3166 = !(cf & IOPARM_DT_HAS_ROUND) ? ROUND_UNSPECIFIED :
3167 find_option (&dtp->common, dtp->round, dtp->round_len,
3168 round_opt, "Bad ROUND parameter in data transfer "
3169 "statement");
3170
3171 if (dtp->u.p.current_unit->round_status == ROUND_UNSPECIFIED)
3172 dtp->u.p.current_unit->round_status = dtp->u.p.current_unit->flags.round;
3173
105b7136
JD		 3174 /* Check the sign mode. */
3175 dtp->u.p.sign_status
d7445152 3176 = !(cf & IOPARM_DT_HAS_SIGN) ? SIGN_UNSPECIFIED :
e1456843 3177 find_option (&dtp->common, dtp->sign, dtp->sign_len, sign_opt,
d7445152 3178 "Bad SIGN parameter in data transfer statement");
e73d3ca6 3179
105b7136 3180 if (dtp->u.p.sign_status == SIGN_UNSPECIFIED)
d7445152
JD		 3181 dtp->u.p.sign_status = dtp->u.p.current_unit->flags.sign;
3182
105b7136
JD		 3183 /* Check the blank mode. */
3184 dtp->u.p.blank_status
d7445152 3185 = !(cf & IOPARM_DT_HAS_BLANK) ? BLANK_UNSPECIFIED :
e1456843 3186 find_option (&dtp->common, dtp->blank, dtp->blank_len,
d7445152
JD		 3187 blank_opt,
3188 "Bad BLANK parameter in data transfer statement");
e73d3ca6 3189
105b7136 3190 if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
d7445152 3191 dtp->u.p.blank_status = dtp->u.p.current_unit->flags.blank;
264a5255 3192
105b7136
JD		 3193 /* Check the delim mode. */
3194 dtp->u.p.current_unit->delim_status
d7445152 3195 = !(cf & IOPARM_DT_HAS_DELIM) ? DELIM_UNSPECIFIED :
e1456843 3196 find_option (&dtp->common, dtp->delim, dtp->delim_len,
105b7136 3197 delim_opt, "Bad DELIM parameter in data transfer statement");
75b2dba9 3198
105b7136 3199 if (dtp->u.p.current_unit->delim_status == DELIM_UNSPECIFIED)
75b2dba9
JD		 3200 {
3201 if (ionml && dtp->u.p.current_unit->flags.delim == DELIM_UNSPECIFIED)
d520fea8 3202 dtp->u.p.current_unit->delim_status = DELIM_QUOTE;
75b2dba9
JD		 3203 else
3204 dtp->u.p.current_unit->delim_status = dtp->u.p.current_unit->flags.delim;
3205 }
d7445152 3206
105b7136
JD		 3207 /* Check the pad mode. */
3208 dtp->u.p.current_unit->pad_status
d7445152 3209 = !(cf & IOPARM_DT_HAS_PAD) ? PAD_UNSPECIFIED :
e1456843 3210 find_option (&dtp->common, dtp->pad, dtp->pad_len, pad_opt,
d7445152 3211 "Bad PAD parameter in data transfer statement");
75b2dba9 3212
105b7136
JD		 3213 if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
3214 dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
7812c78c 3215
2b4c9065
NK		 3216 /* Set up the subroutine that will handle the transfers. */
3217
3218 if (read_flag)
3219 {
3220 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
3221 dtp->u.p.transfer = unformatted_read;
3222 else
3223 {
3224 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
3225 dtp->u.p.transfer = list_formatted_read;
3226 else
3227 dtp->u.p.transfer = formatted_transfer;
3228 }
3229 }
3230 else
3231 {
3232 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
3233 dtp->u.p.transfer = unformatted_write;
3234 else
3235 {
3236 if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
3237 dtp->u.p.transfer = list_formatted_write;
3238 else
3239 dtp->u.p.transfer = formatted_transfer;
3240 }
3241 }
3242
d0cbb206 3243 if (au && dtp->u.p.async)
2b4c9065
NK		 3244 {
3245 NOTE ("enqueue_data_transfer");
3246 enqueue_data_transfer_init (au, dtp, read_flag);
3247 }
3248 else
3249 {
3250 NOTE ("invoking data_transfer_init_worker");
3251 data_transfer_init_worker (dtp, read_flag);
3252 }
3253}
3254
3255void
3256data_transfer_init_worker (st_parameter_dt *dtp, int read_flag)
3257{
3258 GFC_INTEGER_4 cf = dtp->common.flags;
3259
3260 NOTE ("starting worker...");
3261
3262 if (read_flag && dtp->u.p.current_unit->flags.form != FORM_UNFORMATTED
3263 && ((cf & IOPARM_DT_LIST_FORMAT) != 0)
3264 && dtp->u.p.current_unit->child_dtio == 0)
3265 dtp->u.p.current_unit->last_char = EOF - 1;
3266
7812c78c
JD		 3267 /* Check to see if we might be reading what we wrote before */
3268
3269 if (dtp->u.p.mode != dtp->u.p.current_unit->mode
3270 && !is_internal_unit (dtp))
3271 {
3272 int pos = fbuf_reset (dtp->u.p.current_unit);
3273 if (pos != 0)
3274 sseek (dtp->u.p.current_unit->s, pos, SEEK_CUR);
3275 sflush(dtp->u.p.current_unit->s);
3276 }
3277
4c934d41
JD		 3278 /* Check the POS= specifier: that it is in range and that it is used with a
3279 unit that has been connected for STREAM access. F2003 9.5.1.10. */
e73d3ca6 3280
4c934d41
JD		 3281 if (((cf & IOPARM_DT_HAS_POS) != 0))
3282 {
3283 if (is_stream_io (dtp))
7812c78c 3284 {
e73d3ca6 3285
7812c78c
JD		 3286 if (dtp->pos <= 0)
3287 {
3288 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
3289 "POS=specifier must be positive");
3290 return;
3291 }
e73d3ca6 3292
7812c78c
JD		 3293 if (dtp->pos >= dtp->u.p.current_unit->maxrec)
3294 {
3295 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
3296 "POS=specifier too large");
3297 return;
3298 }
e73d3ca6 3299
7812c78c 3300 dtp->rec = dtp->pos;
e73d3ca6 3301
7812c78c
JD		 3302 if (dtp->u.p.mode == READING)
3303 {
3304 /* Reset the endfile flag; if we hit EOF during reading
3305 we'll set the flag and generate an error at that point
3306 rather than worrying about it here. */
3307 dtp->u.p.current_unit->endfile = NO_ENDFILE;
3308 }
e73d3ca6 3309
7812c78c
JD		 3310 if (dtp->pos != dtp->u.p.current_unit->strm_pos)
3311 {
73af0c7b
JD		 3312 fbuf_reset (dtp->u.p.current_unit);
3313 if (sseek (dtp->u.p.current_unit->s, dtp->pos - 1,
3314 SEEK_SET) < 0)
7812c78c
JD		 3315 {
3316 generate_error (&dtp->common, LIBERROR_OS, NULL);
3317 return;
3318 }
3319 dtp->u.p.current_unit->strm_pos = dtp->pos;
3320 }
3321 }
4c934d41 3322 else
7812c78c
JD		 3323 {
3324 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
3325 "POS=specifier not allowed, "
3326 "Try OPEN with ACCESS='stream'");
3327 return;
3328 }
4c934d41 3329 }
e73d3ca6 3330
d7445152 3331
7fcb1804 3332 /* Sanity checks on the record number. */
5e805e44 3333 if ((cf & IOPARM_DT_HAS_REC) != 0)
6de9cd9a 3334 {
5e805e44 3335 if (dtp->rec <= 0)
6de9cd9a 3336 {
d74b97cc 3337 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
5e805e44 3338 "Record number must be positive");
6de9cd9a
DN		 3339 return;
3340 }
3341
5e805e44 3342 if (dtp->rec >= dtp->u.p.current_unit->maxrec)
6de9cd9a 3343 {
d74b97cc 3344 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
5e805e44 3345 "Record number too large");
6de9cd9a
DN		 3346 return;
3347 }
3348
7812c78c
JD		 3349 /* Make sure format buffer is reset. */
3350 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
3351 fbuf_reset (dtp->u.p.current_unit);
55948b69 3352
6de9cd9a 3353
0ef63495
TK		 3354 /* Check whether the record exists to be read. Only
3355 a partial record needs to exist. */
3356
35077d5a 3357 if (dtp->u.p.mode == READING && (dtp->rec - 1)
3469bd86 3358 * dtp->u.p.current_unit->recl >= ssize (dtp->u.p.current_unit->s))
0ef63495 3359 {
d74b97cc 3360 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
5e805e44 3361 "Non-existing record number");
0ef63495
TK		 3362 return;
3363 }
3364
55948b69 3365 /* Position the file. */
4c934d41 3366 if (sseek (dtp->u.p.current_unit->s, (gfc_offset) (dtp->rec - 1)
e73d3ca6
PT		 3367 * dtp->u.p.current_unit->recl, SEEK_SET) < 0)
3368 {
3369 generate_error (&dtp->common, LIBERROR_OS, NULL);
3370 return;
3371 }
4c934d41 3372
9f309df2 3373 if (dtp->u.p.current_unit->flags.access == ACCESS_STREAM)
7812c78c
JD		 3374 {
3375 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
3376 "Record number not allowed for stream access "
3377 "data transfer");
3378 return;
13926b24 3379 }
6de9cd9a
DN		 3380 }
3381
159840cb 3382 /* Bugware for badly written mixed C-Fortran I/O. */
54d4b3bc
JD		 3383 if (!is_internal_unit (dtp))
3384 flush_if_preconnected(dtp->u.p.current_unit->s);
159840cb 3385
5e805e44 3386 dtp->u.p.current_unit->mode = dtp->u.p.mode;
55948b69 3387
beb6a65e
JD		 3388 /* Set the maximum position reached from the previous I/O operation. This
3389 could be greater than zero from a previous non-advancing write. */
3390 dtp->u.p.max_pos = dtp->u.p.current_unit->saved_pos;
6de9cd9a 3391
5e805e44 3392 pre_position (dtp);
e73d3ca6 3393
7fcb1804 3394 /* Make sure that we don't do a read after a nonadvancing write. */
6de9cd9a
DN		 3395
3396 if (read_flag)
3397 {
91b30ee5 3398 if (dtp->u.p.current_unit->read_bad && !is_stream_io (dtp))
6de9cd9a 3399 {
d74b97cc 3400 generate_error (&dtp->common, LIBERROR_BAD_OPTION,
6de9cd9a
DN		 3401 "Cannot READ after a nonadvancing WRITE");
3402 return;
3403 }
3404 }
3405 else
3406 {
5e805e44
JJ		 3407 if (dtp->u.p.advance_status == ADVANCE_YES && !dtp->u.p.seen_dollar)
3408 dtp->u.p.current_unit->read_bad = 1;
6de9cd9a
DN		 3409 }
3410
9cbecd06
JB		 3411 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED)
3412 {
3413#ifdef HAVE_USELOCALE
3414 dtp->u.p.old_locale = uselocale (c_locale);
3415#else
3416 __gthread_mutex_lock (&old_locale_lock);
3417 if (!old_locale_ctr++)
3418 {
3419 old_locale = setlocale (LC_NUMERIC, NULL);
3420 setlocale (LC_NUMERIC, "C");
3421 }
3422 __gthread_mutex_unlock (&old_locale_lock);
3423#endif
3424 /* Start the data transfer if we are doing a formatted transfer. */
3425 if ((cf & (IOPARM_DT_LIST_FORMAT | IOPARM_DT_HAS_NAMELIST_NAME)) == 0
3426 && dtp->u.p.ionml == NULL)
3427 formatted_transfer (dtp, 0, NULL, 0, 0, 1);
3428 }
6de9cd9a
DN		 3429}
3430
9cbecd06 3431
965eec16 3432/* Initialize an array_loop_spec given the array descriptor. The function
9370b3c0
TK		 3433 returns the index of the last element of the array, and also returns
3434 starting record, where the first I/O goes to (necessary in case of
3435 negative strides). */
e73d3ca6 3436
965eec16 3437gfc_offset
9370b3c0
TK		 3438init_loop_spec (gfc_array_char *desc, array_loop_spec *ls,
3439 gfc_offset *start_record)
965eec16
JD		 3440{
3441 int rank = GFC_DESCRIPTOR_RANK(desc);
3442 int i;
e73d3ca6 3443 gfc_offset index;
9370b3c0 3444 int empty;
965eec16 3445
9370b3c0 3446 empty = 0;
965eec16 3447 index = 1;
9370b3c0
TK		 3448 *start_record = 0;
3449
965eec16
JD		 3450 for (i=0; i<rank; i++)
3451 {
dfb55fdc
TK		 3452 ls[i].idx = GFC_DESCRIPTOR_LBOUND(desc,i);
3453 ls[i].start = GFC_DESCRIPTOR_LBOUND(desc,i);
3454 ls[i].end = GFC_DESCRIPTOR_UBOUND(desc,i);
3455 ls[i].step = GFC_DESCRIPTOR_STRIDE(desc,i);
e73d3ca6 3456 empty = empty || (GFC_DESCRIPTOR_UBOUND(desc,i)
dfb55fdc 3457 < GFC_DESCRIPTOR_LBOUND(desc,i));
9370b3c0 3458
dfb55fdc 3459 if (GFC_DESCRIPTOR_STRIDE(desc,i) > 0)
9370b3c0 3460 {
dfb55fdc
TK		 3461 index += (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
3462 * GFC_DESCRIPTOR_STRIDE(desc,i);
9370b3c0
TK		 3463 }
3464 else
3465 {
dfb55fdc
TK		 3466 index -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
3467 * GFC_DESCRIPTOR_STRIDE(desc,i);
3468 *start_record -= (GFC_DESCRIPTOR_EXTENT(desc,i) - 1)
3469 * GFC_DESCRIPTOR_STRIDE(desc,i);
9370b3c0 3470 }
965eec16 3471 }
9370b3c0
TK		 3472
3473 if (empty)
3474 return 0;
3475 else
3476 return index;
965eec16
JD		 3477}
3478
3479/* Determine the index to the next record in an internal unit array by
9370b3c0 3480 by incrementing through the array_loop_spec. */
e73d3ca6 3481
965eec16 3482gfc_offset
9370b3c0 3483next_array_record (st_parameter_dt *dtp, array_loop_spec *ls, int *finished)
965eec16
JD		 3484{
3485 int i, carry;
3486 gfc_offset index;
e73d3ca6 3487
965eec16
JD		 3488 carry = 1;
3489 index = 0;
9370b3c0 3490
5e805e44 3491 for (i = 0; i < dtp->u.p.current_unit->rank; i++)
965eec16
JD		 3492 {
3493 if (carry)
3494 {
3495 ls[i].idx++;
3496 if (ls[i].idx > ls[i].end)
3497 {
3498 ls[i].idx = ls[i].start;
3499 carry = 1;
3500 }
3501 else
3502 carry = 0;
3503 }
d4feb3d3 3504 index = index + (ls[i].idx - ls[i].start) * ls[i].step;
965eec16 3505 }
d4feb3d3 3506
9370b3c0
TK		 3507 *finished = carry;
3508
965eec16
JD		 3509 return index;
3510}
6de9cd9a 3511
07b3bbf2
TK		 3512
3513
3514/* Skip to the end of the current record, taking care of an optional
3515 record marker of size bytes. If the file is not seekable, we
3516 read chunks of size MAX_READ until we get to the right
7fcb1804 3517 position. */
6de9cd9a 3518
07b3bbf2 3519static void
2563a16d 3520skip_record (st_parameter_dt *dtp, gfc_offset bytes)
07b3bbf2 3521{
f9bfed22 3522 ssize_t rlength, readb;
581d2326 3523#define MAX_READ 4096
15877a88 3524 char p[MAX_READ];
07b3bbf2
TK		 3525
3526 dtp->u.p.current_unit->bytes_left_subrecord += bytes;
3527 if (dtp->u.p.current_unit->bytes_left_subrecord == 0)
3528 return;
3529
7d5ee219
JB		 3530 /* Direct access files do not generate END conditions,
3531 only I/O errors. */
e73d3ca6 3532 if (sseek (dtp->u.p.current_unit->s,
7d5ee219 3533 dtp->u.p.current_unit->bytes_left_subrecord, SEEK_CUR) < 0)
07b3bbf2 3534 {
7d5ee219 3535 /* Seeking failed, fall back to seeking by reading data. */
07b3bbf2
TK		 3536 while (dtp->u.p.current_unit->bytes_left_subrecord > 0)
3537 {
e73d3ca6 3538 rlength =
f9bfed22
JB		 3539 (MAX_READ < dtp->u.p.current_unit->bytes_left_subrecord) ?
3540 MAX_READ : dtp->u.p.current_unit->bytes_left_subrecord;
07b3bbf2 3541
7812c78c
JD		 3542 readb = sread (dtp->u.p.current_unit->s, p, rlength);
3543 if (readb < 0)
07b3bbf2 3544 {
d74b97cc 3545 generate_error (&dtp->common, LIBERROR_OS, NULL);
07b3bbf2
TK		 3546 return;
3547 }
3548
7812c78c 3549 dtp->u.p.current_unit->bytes_left_subrecord -= readb;
07b3bbf2 3550 }
7d5ee219 3551 return;
07b3bbf2 3552 }
7d5ee219 3553 dtp->u.p.current_unit->bytes_left_subrecord = 0;
07b3bbf2
TK		 3554}
3555
07b3bbf2
TK		 3556
3557/* Advance to the next record reading unformatted files, taking
3558 care of subrecords. If complete_record is nonzero, we loop
3559 until all subrecords are cleared. */
3560
3561static void
3562next_record_r_unf (st_parameter_dt *dtp, int complete_record)
3563{
3564 size_t bytes;
3565
3566 bytes = compile_options.record_marker == 0 ?
3567 sizeof (GFC_INTEGER_4) : compile_options.record_marker;
3568
3569 while(1)
3570 {
3571
3572 /* Skip over tail */
3573
3574 skip_record (dtp, bytes);
3575
3576 if ( ! (complete_record && dtp->u.p.current_unit->continued))
3577 return;
3578
3579 us_read (dtp, 1);
3580 }
3581}
3582
15877a88 3583
992b0aa1 3584static gfc_offset
15877a88
JB		 3585min_off (gfc_offset a, gfc_offset b)
3586{
3587 return (a < b ? a : b);
3588}
3589
3590
07b3bbf2
TK		 3591/* Space to the next record for read mode. */
3592
6de9cd9a 3593static void
59011a60 3594next_record_r (st_parameter_dt *dtp, int done)
6de9cd9a 3595{
07b3bbf2 3596 gfc_offset record;
15877a88 3597 char p;
7812c78c 3598 int cc;
6de9cd9a 3599
5e805e44 3600 switch (current_mode (dtp))
6de9cd9a 3601 {
09861cbe 3602 /* No records in unformatted STREAM I/O. */
91b30ee5
JD		 3603 case UNFORMATTED_STREAM:
3604 return;
e73d3ca6 3605
6de9cd9a 3606 case UNFORMATTED_SEQUENTIAL:
07b3bbf2 3607 next_record_r_unf (dtp, 1);
f4072316 3608 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
07b3bbf2 3609 break;
6de9cd9a
DN		 3610
3611 case FORMATTED_DIRECT:
3612 case UNFORMATTED_DIRECT:
0b4d979f 3613 skip_record (dtp, dtp->u.p.current_unit->bytes_left);
6de9cd9a
DN		 3614 break;
3615
09861cbe 3616 case FORMATTED_STREAM:
6de9cd9a 3617 case FORMATTED_SEQUENTIAL:
7812c78c
JD		 3618 /* read_sf has already terminated input because of an '\n', or
3619 we have hit EOF. */
59011a60 3620 if (dtp->u.p.sf_seen_eor)
59afe4b4 3621 {
5e805e44 3622 dtp->u.p.sf_seen_eor = 0;
59afe4b4
TK		 3623 break;
3624 }
6de9cd9a 3625
5e805e44 3626 if (is_internal_unit (dtp))
59154ed2 3627 {
5e805e44
JJ		 3628 if (is_array_io (dtp))
3629 {
9370b3c0
TK		 3630 int finished;
3631
3632 record = next_array_record (dtp, dtp->u.p.current_unit->ls,
3633 &finished);
59011a60
JD		 3634 if (!done && finished)
3635 hit_eof (dtp);
5e805e44
JJ		 3636
3637 /* Now seek to this record. */
3638 record = record * dtp->u.p.current_unit->recl;
7812c78c 3639 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
5e805e44 3640 {
d74b97cc 3641 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
5e805e44
JJ		 3642 break;
3643 }
3644 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
3645 }
e73d3ca6 3646 else
5e805e44 3647 {
2563a16d 3648 gfc_offset bytes_left = dtp->u.p.current_unit->bytes_left;
e73d3ca6 3649 bytes_left = min_off (bytes_left,
3469bd86 3650 ssize (dtp->u.p.current_unit->s)
7812c78c 3651 - stell (dtp->u.p.current_unit->s));
e73d3ca6 3652 if (sseek (dtp->u.p.current_unit->s,
7812c78c 3653 bytes_left, SEEK_CUR) < 0)
15877a88
JB		 3654 {
3655 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3656 break;
3657 }
3658 dtp->u.p.current_unit->bytes_left
3659 = dtp->u.p.current_unit->recl;
e73d3ca6 3660 }
5e805e44 3661 break;
59154ed2 3662 }
0ef33d44 3663 else if (dtp->u.p.current_unit->flags.cc != CC_NONE)
be0cc7e2 3664 {
7812c78c 3665 do
be0cc7e2 3666 {
7812c78c
JD		 3667 errno = 0;
3668 cc = fbuf_getc (dtp->u.p.current_unit);
e73d3ca6 3669 if (cc == EOF)
7812c78c
JD		 3670 {
3671 if (errno != 0)
3672 generate_error (&dtp->common, LIBERROR_OS, NULL);
6c1400dd
JD		 3673 else
3674 {
3675 if (is_stream_io (dtp)
3676 || dtp->u.p.current_unit->pad_status == PAD_NO
3677 || dtp->u.p.current_unit->bytes_left
3678 == dtp->u.p.current_unit->recl)
3679 hit_eof (dtp);
3680 }
7812c78c
JD		 3681 break;
3682 }
e73d3ca6 3683
7812c78c
JD		 3684 if (is_stream_io (dtp))
3685 dtp->u.p.current_unit->strm_pos++;
e73d3ca6 3686
7812c78c 3687 p = (char) cc;
f3ed1d02 3688 }
7812c78c 3689 while (p != '\n');
be0cc7e2 3690 }
6de9cd9a 3691 break;
60674b3f
JD		 3692 case FORMATTED_UNSPECIFIED:
3693 gcc_unreachable ();
6de9cd9a 3694 }
6de9cd9a
DN		 3695}
3696
3697
82b8244c 3698/* Small utility function to write a record marker, taking care of
d67ab5ee 3699 byte swapping and of choosing the correct size. */
82b8244c 3700
7812c78c 3701static int
82b8244c
JB		 3702write_us_marker (st_parameter_dt *dtp, const gfc_offset buf)
3703{
d67ab5ee
TK		 3704 size_t len;
3705 GFC_INTEGER_4 buf4;
3706 GFC_INTEGER_8 buf8;
d67ab5ee
TK		 3707
3708 if (compile_options.record_marker == 0)
07b3bbf2 3709 len = sizeof (GFC_INTEGER_4);
d67ab5ee
TK		 3710 else
3711 len = compile_options.record_marker;
3712
d74b97cc 3713 /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here. */
afab92d8 3714 if (likely (dtp->u.p.current_unit->flags.convert == GFC_CONVERT_NATIVE))
d67ab5ee 3715 {
07b3bbf2 3716 switch (len)
d67ab5ee 3717 {
d67ab5ee
TK		 3718 case sizeof (GFC_INTEGER_4):
3719 buf4 = buf;
7812c78c 3720 return swrite (dtp->u.p.current_unit->s, &buf4, len);
d67ab5ee
TK		 3721 break;
3722
3723 case sizeof (GFC_INTEGER_8):
3724 buf8 = buf;
7812c78c 3725 return swrite (dtp->u.p.current_unit->s, &buf8, len);
d67ab5ee
TK		 3726 break;
3727
3728 default:
3729 runtime_error ("Illegal value for record marker");
3730 break;
3731 }
3732 }
3733 else
3734 {
facb23dc
JB		 3735 uint32_t u32;
3736 uint64_t u64;
07b3bbf2 3737 switch (len)
d67ab5ee 3738 {
d67ab5ee
TK		 3739 case sizeof (GFC_INTEGER_4):
3740 buf4 = buf;
facb23dc
JB		 3741 memcpy (&u32, &buf4, sizeof (u32));
3742 u32 = __builtin_bswap32 (u32);
3743 return swrite (dtp->u.p.current_unit->s, &u32, len);
d67ab5ee
TK		 3744 break;
3745
3746 case sizeof (GFC_INTEGER_8):
3747 buf8 = buf;
facb23dc
JB		 3748 memcpy (&u64, &buf8, sizeof (u64));
3749 u64 = __builtin_bswap64 (u64);
3750 return swrite (dtp->u.p.current_unit->s, &u64, len);
d67ab5ee
TK		 3751 break;
3752
3753 default:
3754 runtime_error ("Illegal value for record marker");
3755 break;
3756 }
3757 }
3758
82b8244c
JB		 3759}
3760
07b3bbf2
TK		 3761/* Position to the next (sub)record in write mode for
3762 unformatted sequential files. */
3763
3764static void
3765next_record_w_unf (st_parameter_dt *dtp, int next_subrecord)
3766{
f9bfed22 3767 gfc_offset m, m_write, record_marker;
07b3bbf2
TK		 3768
3769 /* Bytes written. */
3770 m = dtp->u.p.current_unit->recl_subrecord
3771 - dtp->u.p.current_unit->bytes_left_subrecord;
07b3bbf2 3772
07b3bbf2
TK		 3773 if (compile_options.record_marker == 0)
3774 record_marker = sizeof (GFC_INTEGER_4);
3775 else
3776 record_marker = compile_options.record_marker;
3777
3778 /* Seek to the head and overwrite the bogus length with the real
3779 length. */
3780
e73d3ca6 3781 if (unlikely (sseek (dtp->u.p.current_unit->s, - m - record_marker,
f9bfed22 3782 SEEK_CUR) < 0))
07b3bbf2
TK		 3783 goto io_error;
3784
3785 if (next_subrecord)
3786 m_write = -m;
3787 else
3788 m_write = m;
3789
7812c78c 3790 if (unlikely (write_us_marker (dtp, m_write) < 0))
07b3bbf2
TK		 3791 goto io_error;
3792
3793 /* Seek past the end of the current record. */
3794
c033f5ae
JB		 3795 if (unlikely (sseek (dtp->u.p.current_unit->s, m, SEEK_CUR) < 0))
3796 goto io_error;
3797
3798 /* Write the length tail. If we finish a record containing
3799 subrecords, we write out the negative length. */
3800
3801 if (dtp->u.p.current_unit->continued)
3802 m_write = -m;
3803 else
3804 m_write = m;
3805
3806 if (unlikely (write_us_marker (dtp, m_write) < 0))
07b3bbf2
TK		 3807 goto io_error;
3808
3809 return;
3810
3811 io_error:
d74b97cc 3812 generate_error (&dtp->common, LIBERROR_OS, NULL);
07b3bbf2
TK		 3813 return;
3814
3815}
82b8244c 3816
7812c78c
JD		 3817
3818/* Utility function like memset() but operating on streams. Return
3819 value is same as for POSIX write(). */
3820
2563a16d
JB		 3821static gfc_offset
3822sset (stream *s, int c, gfc_offset nbyte)
7812c78c 3823{
581d2326 3824#define WRITE_CHUNK 256
7812c78c 3825 char p[WRITE_CHUNK];
2563a16d
JB		 3826 gfc_offset bytes_left;
3827 ssize_t trans;
7812c78c
JD		 3828
3829 if (nbyte < WRITE_CHUNK)
3830 memset (p, c, nbyte);
3831 else
3832 memset (p, c, WRITE_CHUNK);
3833
3834 bytes_left = nbyte;
3835 while (bytes_left > 0)
3836 {
3837 trans = (bytes_left < WRITE_CHUNK) ? bytes_left : WRITE_CHUNK;
3838 trans = swrite (s, p, trans);
93ab3a3d 3839 if (trans <= 0)
7812c78c
JD		 3840 return trans;
3841 bytes_left -= trans;
3842 }
e73d3ca6 3843
7812c78c
JD		 3844 return nbyte - bytes_left;
3845}
3846
746e6327 3847
0ef33d44
FR		 3848/* Finish up a record according to the legacy carriagecontrol type, based
3849 on the first character in the record. */
3850
3851static void
3852next_record_cc (st_parameter_dt *dtp)
3853{
3854 /* Only valid with CARRIAGECONTROL=FORTRAN. */
3855 if (dtp->u.p.current_unit->flags.cc != CC_FORTRAN)
3856 return;
3857
3858 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3859 if (dtp->u.p.cc.len > 0)
3860 {
f29876bb 3861 char *p = fbuf_alloc (dtp->u.p.current_unit, dtp->u.p.cc.len);
0ef33d44
FR		 3862 if (!p)
3863 generate_error (&dtp->common, LIBERROR_OS, NULL);
3864
3865 /* Output CR for the first character with default CC setting. */
3866 *(p++) = dtp->u.p.cc.u.end;
3867 if (dtp->u.p.cc.len > 1)
3868 *p = dtp->u.p.cc.u.end;
3869 }
3870}
3871
7fcb1804 3872/* Position to the next record in write mode. */
6de9cd9a
DN		 3873
3874static void
494ef4c2 3875next_record_w (st_parameter_dt *dtp, int done)
6de9cd9a 3876{
2563a16d 3877 gfc_offset max_pos_off;
6de9cd9a 3878
94e2b58a 3879 /* Zero counters for X- and T-editing. */
2563a16d 3880 max_pos_off = dtp->u.p.max_pos;
5e805e44 3881 dtp->u.p.max_pos = dtp->u.p.skips = dtp->u.p.pending_spaces = 0;
94e2b58a 3882
5e805e44 3883 switch (current_mode (dtp))
6de9cd9a 3884 {
09861cbe 3885 /* No records in unformatted STREAM I/O. */
91b30ee5
JD		 3886 case UNFORMATTED_STREAM:
3887 return;
3888
6de9cd9a 3889 case FORMATTED_DIRECT:
5e805e44 3890 if (dtp->u.p.current_unit->bytes_left == 0)
6de9cd9a
DN		 3891 break;
3892
7812c78c
JD		 3893 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
3894 fbuf_flush (dtp->u.p.current_unit, WRITING);
e73d3ca6
PT		 3895 if (sset (dtp->u.p.current_unit->s, ' ',
3896 dtp->u.p.current_unit->bytes_left)
7812c78c 3897 != dtp->u.p.current_unit->bytes_left)
6de9cd9a
DN		 3898 goto io_error;
3899
0fa1b65c 3900 break;
6de9cd9a 3901
0fa1b65c 3902 case UNFORMATTED_DIRECT:
fc8bc175
JD		 3903 if (dtp->u.p.current_unit->bytes_left > 0)
3904 {
2563a16d 3905 gfc_offset length = dtp->u.p.current_unit->bytes_left;
7812c78c 3906 if (sset (dtp->u.p.current_unit->s, 0, length) != length)
15877a88 3907 goto io_error;
fc8bc175 3908 }
6de9cd9a
DN		 3909 break;
3910
3911 case UNFORMATTED_SEQUENTIAL:
07b3bbf2 3912 next_record_w_unf (dtp, 0);
f4072316 3913 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
6de9cd9a
DN		 3914 break;
3915
09861cbe 3916 case FORMATTED_STREAM:
6de9cd9a 3917 case FORMATTED_SEQUENTIAL:
59154ed2 3918
5e805e44 3919 if (is_internal_unit (dtp))
59154ed2 3920 {
746e6327 3921 char *p;
2563a16d 3922 /* Internal unit, so must fit in memory. */
4135a21f 3923 size_t length, m;
ea99ec5b 3924 size_t max_pos = max_pos_off;
5e805e44 3925 if (is_array_io (dtp))
59154ed2 3926 {
9370b3c0
TK		 3927 int finished;
3928
2563a16d 3929 length = dtp->u.p.current_unit->bytes_left;
e73d3ca6 3930
494ef4c2
JD		 3931 /* If the farthest position reached is greater than current
3932 position, adjust the position and set length to pad out
3933 whats left. Otherwise just pad whats left.
3934 (for character array unit) */
3935 m = dtp->u.p.current_unit->recl
3936 - dtp->u.p.current_unit->bytes_left;
3937 if (max_pos > m)
3938 {
2563a16d 3939 length = (max_pos - m);
e73d3ca6 3940 if (sseek (dtp->u.p.current_unit->s,
7812c78c 3941 length, SEEK_CUR) < 0)
15877a88
JB		 3942 {
3943 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3944 return;
3945 }
ea99ec5b 3946 length = ((size_t) dtp->u.p.current_unit->recl - max_pos);
494ef4c2
JD		 3947 }
3948
746e6327
JD		 3949 p = write_block (dtp, length);
3950 if (p == NULL)
3951 return;
3952
3953 if (unlikely (is_char4_unit (dtp)))
3954 {
3955 gfc_char4_t *p4 = (gfc_char4_t *) p;
3956 memset4 (p4, ' ', length);
59154ed2 3957 }
746e6327
JD		 3958 else
3959 memset (p, ' ', length);
5e805e44
JJ		 3960
3961 /* Now that the current record has been padded out,
4135a21f
JB		 3962 determine where the next record in the array is.
3963 Note that this can return a negative value, so it
3964 needs to be assigned to a signed value. */
3965 gfc_offset record = next_array_record
3966 (dtp, dtp->u.p.current_unit->ls, &finished);
9370b3c0 3967 if (finished)
397bc09a 3968 dtp->u.p.current_unit->endfile = AT_ENDFILE;
e73d3ca6 3969
5e805e44 3970 /* Now seek to this record */
4135a21f 3971 record = record * dtp->u.p.current_unit->recl;
5e805e44 3972
7812c78c 3973 if (sseek (dtp->u.p.current_unit->s, record, SEEK_SET) < 0)
844234fb 3974 {
d74b97cc 3975 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
844234fb
JD		 3976 return;
3977 }
5e805e44
JJ		 3978
3979 dtp->u.p.current_unit->bytes_left = dtp->u.p.current_unit->recl;
59154ed2
JD		 3980 }
3981 else
3982 {
3983 length = 1;
494ef4c2
JD		 3984
3985 /* If this is the last call to next_record move to the farthest
3986 position reached and set length to pad out the remainder
3987 of the record. (for character scaler unit) */
3988 if (done)
3989 {
3990 m = dtp->u.p.current_unit->recl
3991 - dtp->u.p.current_unit->bytes_left;
3992 if (max_pos > m)
3993 {
2563a16d 3994 length = max_pos - m;
e73d3ca6 3995 if (sseek (dtp->u.p.current_unit->s,
7812c78c 3996 length, SEEK_CUR) < 0)
15877a88
JB		 3997 {
3998 generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
3999 return;
4000 }
ea99ec5b 4001 length = (size_t) dtp->u.p.current_unit->recl
2563a16d 4002 - max_pos;
494ef4c2
JD		 4003 }
4004 else
2563a16d 4005 length = dtp->u.p.current_unit->bytes_left;
494ef4c2 4006 }
746e6327 4007 if (length > 0)
494ef4c2 4008 {
746e6327
JD		 4009 p = write_block (dtp, length);
4010 if (p == NULL)
4011 return;
4012
4013 if (unlikely (is_char4_unit (dtp)))
4014 {
4015 gfc_char4_t *p4 = (gfc_char4_t *) p;
4016 memset4 (p4, (gfc_char4_t) ' ', length);
4017 }
4018 else
4019 memset (p, ' ', length);
494ef4c2 4020 }
59154ed2 4021 }
494ef4c2 4022 }
0ef33d44
FR		 4023 /* Handle legacy CARRIAGECONTROL line endings. */
4024 else if (dtp->u.p.current_unit->flags.cc == CC_FORTRAN)
4025 next_record_cc (dtp);
59154ed2
JD		 4026 else
4027 {
0ef33d44
FR		 4028 /* Skip newlines for CC=CC_NONE. */
4029 const int len = (dtp->u.p.current_unit->flags.cc == CC_NONE)
4030 ? 0
3c127520 4031#ifdef HAVE_CRLF
0ef33d44 4032 : 2;
3c127520 4033#else
0ef33d44 4034 : 1;
9e544d73 4035#endif
0ef33d44
FR		 4036 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
4037 if (dtp->u.p.current_unit->flags.cc != CC_NONE)
4038 {
f29876bb 4039 char *p = fbuf_alloc (dtp->u.p.current_unit, len);
0ef33d44
FR		 4040 if (!p)
4041 goto io_error;
7812c78c 4042#ifdef HAVE_CRLF
0ef33d44 4043 *(p++) = '\r';
7812c78c 4044#endif
0ef33d44
FR		 4045 *p = '\n';
4046 }
09861cbe 4047 if (is_stream_io (dtp))
e32883d1
JD		 4048 {
4049 dtp->u.p.current_unit->strm_pos += len;
35077d5a 4050 if (dtp->u.p.current_unit->strm_pos
3469bd86 4051 < ssize (dtp->u.p.current_unit->s))
7812c78c
JD		 4052 unit_truncate (dtp->u.p.current_unit,
4053 dtp->u.p.current_unit->strm_pos - 1,
4054 &dtp->common);
e32883d1 4055 }
be0cc7e2 4056 }
6de9cd9a 4057
6de9cd9a 4058 break;
60674b3f
JD		 4059 case FORMATTED_UNSPECIFIED:
4060 gcc_unreachable ();
6de9cd9a
DN		 4061
4062 io_error:
d74b97cc 4063 generate_error (&dtp->common, LIBERROR_OS, NULL);
6de9cd9a
DN		 4064 break;
4065 }
4066}
4067
7fcb1804
TS		 4068/* Position to the next record, which means moving to the end of the
4069 current record. This can happen under several different
4070 conditions. If the done flag is not set, we get ready to process
4071 the next record. */
6de9cd9a
DN		 4072
4073void
5e805e44 4074next_record (st_parameter_dt *dtp, int done)
6de9cd9a 4075{
7fcb1804 4076 gfc_offset fp; /* File position. */
6de9cd9a 4077
5e805e44 4078 dtp->u.p.current_unit->read_bad = 0;
6de9cd9a 4079
5e805e44 4080 if (dtp->u.p.mode == READING)
59011a60 4081 next_record_r (dtp, done);
6de9cd9a 4082 else
494ef4c2 4083 next_record_w (dtp, done);
6de9cd9a 4084
b89f743d
JD		 4085 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
4086
09861cbe
JD		 4087 if (!is_stream_io (dtp))
4088 {
08810e52
JB		 4089 /* Since we have changed the position, set it to unspecified so
4090 that INQUIRE(POSITION=) knows it needs to look into it. */
16d962d9 4091 if (done)
08810e52 4092 dtp->u.p.current_unit->flags.position = POSITION_UNSPECIFIED;
16d962d9 4093
09861cbe
JD		 4094 dtp->u.p.current_unit->current_record = 0;
4095 if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
4096 {
7812c78c 4097 fp = stell (dtp->u.p.current_unit->s);
09861cbe
JD		 4098 /* Calculate next record, rounding up partial records. */
4099 dtp->u.p.current_unit->last_record =
b89f743d
JD		 4100 (fp + dtp->u.p.current_unit->recl) /
4101 dtp->u.p.current_unit->recl - 1;
09861cbe
JD		 4102 }
4103 else
4104 dtp->u.p.current_unit->last_record++;
4105 }
6de9cd9a
DN		 4106
4107 if (!done)
5e805e44 4108 pre_position (dtp);
7812c78c 4109
89a862b4 4110 smarkeor (dtp->u.p.current_unit->s);
6de9cd9a
DN		 4111}
4112
4113
4114/* Finalize the current data transfer. For a nonadvancing transfer,
5615e8cd 4115 this means advancing to the next record. For internal units close the
965eec16 4116 stream associated with the unit. */
6de9cd9a
DN		 4117
4118static void
5e805e44 4119finalize_transfer (st_parameter_dt *dtp)
6de9cd9a 4120{
5e805e44 4121 GFC_INTEGER_4 cf = dtp->common.flags;
59afe4b4 4122
e73d3ca6
PT		 4123 if ((dtp->u.p.ionml != NULL)
4124 && (cf & IOPARM_DT_HAS_NAMELIST_NAME) != 0)
4125 {
8d8a25b0
HA		 4126 if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
4127 {
4128 generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
4129 "Namelist formatting for unit connected "
4130 "with FORM='UNFORMATTED");
4131 return;
4132 }
4133
c4508d0a 4134 dtp->u.p.namelist_mode = 1;
e73d3ca6
PT		 4135 if ((cf & IOPARM_DT_NAMELIST_READ_MODE) != 0)
4136 namelist_read (dtp);
4137 else
4138 namelist_write (dtp);
4139 }
4140
1f10d710
JD		 4141 if ((dtp->common.flags & IOPARM_DT_HAS_SIZE) != 0)
4142 *dtp->size = dtp->u.p.current_unit->size_used;
4143
4144 if (dtp->u.p.eor_condition)
4145 {
4146 generate_error (&dtp->common, LIBERROR_EOR, NULL);
4147 goto done;
4148 }
4149
e73d3ca6 4150 if (dtp->u.p.current_unit && (dtp->u.p.current_unit->child_dtio > 0))
bdff7e51
JD		 4151 {
4152 if (cf & IOPARM_DT_HAS_FORMAT)
4153 {
4154 free (dtp->u.p.fmt);
4155 free (dtp->format);
4156 }
4157 return;
4158 }
e73d3ca6 4159
5e805e44 4160 if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
217c4f53
JB		 4161 {
4162 if (dtp->u.p.current_unit && current_mode (dtp) == UNFORMATTED_SEQUENTIAL)
4163 dtp->u.p.current_unit->current_record = 0;
9cbecd06 4164 goto done;
217c4f53 4165 }
0e69bba9 4166
5e805e44
JJ		 4167 dtp->u.p.transfer = NULL;
4168 if (dtp->u.p.current_unit == NULL)
9cbecd06 4169 goto done;
6de9cd9a 4170
5e805e44 4171 if ((cf & IOPARM_DT_LIST_FORMAT) != 0 && dtp->u.p.mode == READING)
6de9cd9a 4172 {
97cd182d 4173 finish_list_read (dtp);
9cbecd06 4174 goto done;
6de9cd9a 4175 }
97cd182d 4176
108bc190
TK		 4177 if (dtp->u.p.mode == WRITING)
4178 dtp->u.p.current_unit->previous_nonadvancing_write
4179 = dtp->u.p.advance_status == ADVANCE_NO;
4180
97cd182d 4181 if (is_stream_io (dtp))
09861cbe 4182 {
108bc190
TK		 4183 if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
4184 && dtp->u.p.advance_status != ADVANCE_NO)
31de5c74 4185 next_record (dtp, 1);
2ea74407 4186
9cbecd06 4187 goto done;
97cd182d
JD		 4188 }
4189
4190 dtp->u.p.current_unit->current_record = 0;
4191
97cd182d
JD		 4192 if (!is_internal_unit (dtp) && dtp->u.p.seen_dollar)
4193 {
7812c78c 4194 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
97cd182d 4195 dtp->u.p.seen_dollar = 0;
9cbecd06 4196 goto done;
09861cbe 4197 }
6de9cd9a 4198
beb6a65e
JD		 4199 /* For non-advancing I/O, save the current maximum position for use in the
4200 next I/O operation if needed. */
54938c11
JD		 4201 if (dtp->u.p.advance_status == ADVANCE_NO)
4202 {
6e9966e8
JD		 4203 if (dtp->u.p.skips > 0)
4204 {
4205 int tmp;
4206 write_x (dtp, dtp->u.p.skips, dtp->u.p.pending_spaces);
4207 tmp = (int)(dtp->u.p.current_unit->recl
4208 - dtp->u.p.current_unit->bytes_left);
e73d3ca6 4209 dtp->u.p.max_pos =
6e9966e8
JD		 4210 dtp->u.p.max_pos > tmp ? dtp->u.p.max_pos : tmp;
4211 dtp->u.p.skips = 0;
4212 }
beb6a65e
JD		 4213 int bytes_written = (int) (dtp->u.p.current_unit->recl
4214 - dtp->u.p.current_unit->bytes_left);
4215 dtp->u.p.current_unit->saved_pos =
4216 dtp->u.p.max_pos > 0 ? dtp->u.p.max_pos - bytes_written : 0;
7812c78c 4217 fbuf_flush (dtp->u.p.current_unit, dtp->u.p.mode);
9cbecd06 4218 goto done;
54938c11 4219 }
e73d3ca6 4220 else if (dtp->u.p.current_unit->flags.form == FORM_FORMATTED
7812c78c 4221 && dtp->u.p.mode == WRITING && !is_internal_unit (dtp))
e73d3ca6 4222 fbuf_seek (dtp->u.p.current_unit, 0, SEEK_END);
54938c11 4223
beb6a65e 4224 dtp->u.p.current_unit->saved_pos = 0;
7f72e402 4225 dtp->u.p.current_unit->last_char = EOF - 1;
97cd182d 4226 next_record (dtp, 1);
9cbecd06
JB		 4227
4228 done:
606778c6
JD		 4229
4230 if (dtp->u.p.unit_is_internal)
4231 {
d5efbf3f
JD		 4232 /* The unit structure may be reused later so clear the
4233 internal unit kind. */
4234 dtp->u.p.current_unit->internal_unit_kind = 0;
4235
606778c6
JD		 4236 fbuf_destroy (dtp->u.p.current_unit);
4237 if (dtp->u.p.current_unit
4238 && (dtp->u.p.current_unit->child_dtio == 0)
4239 && dtp->u.p.current_unit->s)
4240 {
4241 sclose (dtp->u.p.current_unit->s);
4242 dtp->u.p.current_unit->s = NULL;
4243 }
4244 }
4245
9cbecd06
JB		 4246#ifdef HAVE_USELOCALE
4247 if (dtp->u.p.old_locale != (locale_t) 0)
4248 {
4249 uselocale (dtp->u.p.old_locale);
4250 dtp->u.p.old_locale = (locale_t) 0;
4251 }
4252#else
4253 __gthread_mutex_lock (&old_locale_lock);
4254 if (!--old_locale_ctr)
4255 {
4256 setlocale (LC_NUMERIC, old_locale);
4257 old_locale = NULL;
4258 }
4259 __gthread_mutex_unlock (&old_locale_lock);
4260#endif
6de9cd9a
DN		 4261}
4262
8750f9cd
JB		 4263/* Transfer function for IOLENGTH. It doesn't actually do any
4264 data transfer, it just updates the length counter. */
4265
4266static void
e73d3ca6 4267iolength_transfer (st_parameter_dt *dtp, bt type __attribute__((unused)),
e5ef4b3b 4268 void *dest __attribute__ ((unused)),
e73d3ca6 4269 int kind __attribute__((unused)),
e5ef4b3b 4270 size_t size, size_t nelems)
8750f9cd 4271{
5e805e44 4272 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
f9bfed22 4273 *dtp->iolength += (GFC_IO_INT) (size * nelems);
8750f9cd
JB		 4274}
4275
4276
4277/* Initialize the IOLENGTH data transfer. This function is in essence
4278 a very much simplified version of data_transfer_init(), because it
4279 doesn't have to deal with units at all. */
4280
4281static void
5e805e44 4282iolength_transfer_init (st_parameter_dt *dtp)
8750f9cd 4283{
5e805e44
JJ		 4284 if ((dtp->common.flags & IOPARM_DT_HAS_IOLENGTH) != 0)
4285 *dtp->iolength = 0;
8750f9cd 4286
5e805e44 4287 memset (&dtp->u.p, 0, sizeof (dtp->u.p));
8750f9cd
JB		 4288
4289 /* Set up the subroutine that will handle the transfers. */
4290
5e805e44 4291 dtp->u.p.transfer = iolength_transfer;
8750f9cd
JB		 4292}
4293
4294
4295/* Library entry point for the IOLENGTH form of the INQUIRE
4296 statement. The IOLENGTH form requires no I/O to be performed, but
4297 it must still be a runtime library call so that we can determine
4298 the iolength for dynamic arrays and such. */
4299
5e805e44 4300extern void st_iolength (st_parameter_dt *);
7d7b8bfe
RH		 4301export_proto(st_iolength);
4302
8750f9cd 4303void
5e805e44 4304st_iolength (st_parameter_dt *dtp)
8750f9cd 4305{
5e805e44
JJ		 4306 library_start (&dtp->common);
4307 iolength_transfer_init (dtp);
8750f9cd
JB		 4308}
4309
5e805e44 4310extern void st_iolength_done (st_parameter_dt *);
7d7b8bfe
RH		 4311export_proto(st_iolength_done);
4312
8750f9cd 4313void
5e805e44 4314st_iolength_done (st_parameter_dt *dtp __attribute__((unused)))
8750f9cd 4315{
5e805e44 4316 free_ionml (dtp);
8750f9cd
JB		 4317 library_end ();
4318}
4319
4320
7fcb1804 4321/* The READ statement. */
6de9cd9a 4322
5e805e44 4323extern void st_read (st_parameter_dt *);
7d7b8bfe
RH		 4324export_proto(st_read);
4325
6de9cd9a 4326void
5e805e44 4327st_read (st_parameter_dt *dtp)
6de9cd9a 4328{
5e805e44 4329 library_start (&dtp->common);
6de9cd9a 4330
5e805e44 4331 data_transfer_init (dtp, 1);
6de9cd9a
DN		 4332}
4333
5e805e44 4334extern void st_read_done (st_parameter_dt *);
7d7b8bfe 4335export_proto(st_read_done);
6de9cd9a
DN		 4336
4337void
2b4c9065 4338st_read_done_worker (st_parameter_dt *dtp)
6de9cd9a 4339{
5e805e44 4340 finalize_transfer (dtp);
e73d3ca6 4341
5e805e44 4342 free_ionml (dtp);
241cbc7a 4343
4a8d4422 4344 /* If this is a parent READ statement we do not need to retain the
bf498b07 4345 internal unit structure for child use. */
4a8d4422
JD		 4346 if (dtp->u.p.current_unit != NULL
4347 && dtp->u.p.current_unit->child_dtio == 0)
4348 {
7b39e3c2 4349 if (dtp->u.p.unit_is_internal)
8c098567
JD		 4350 {
4351 if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
4352 {
4353 free (dtp->u.p.current_unit->filename);
4354 dtp->u.p.current_unit->filename = NULL;
8c098567
JD		 4355 if (dtp->u.p.current_unit->ls)
4356 free (dtp->u.p.current_unit->ls);
4357 dtp->u.p.current_unit->ls = NULL;
4358 }
4359 newunit_free (dtp->common.unit);
4a8d4422 4360 }
7b39e3c2 4361 if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
4a8d4422
JD		 4362 {
4363 free_format_data (dtp->u.p.fmt);
4364 free_format (dtp);
4365 }
2b4c9065
NK		 4366 }
4367}
4368
4369void
4370st_read_done (st_parameter_dt *dtp)
4371{
4372 if (dtp->u.p.current_unit)
4373 {
4374 if (dtp->u.p.current_unit->au)
4375 {
4376 if (dtp->common.flags & IOPARM_DT_HAS_ID)
4377 *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);
4378 else
4379 {
d0cbb206
TK		 4380 if (dtp->u.p.async)
4381 enqueue_done (dtp->u.p.current_unit->au, AIO_READ_DONE);
2b4c9065
NK		 4382 }
4383 }
4384 else
4385 st_read_done_worker (dtp);
4386
4a8d4422
JD		 4387 unlock_unit (dtp->u.p.current_unit);
4388 }
e73d3ca6 4389
6de9cd9a
DN		 4390 library_end ();
4391}
4392
5e805e44 4393extern void st_write (st_parameter_dt *);
2b4c9065 4394export_proto (st_write);
6de9cd9a
DN		 4395
4396void
5e805e44 4397st_write (st_parameter_dt *dtp)
6de9cd9a 4398{
5e805e44
JJ		 4399 library_start (&dtp->common);
4400 data_transfer_init (dtp, 0);
6de9cd9a
DN		 4401}
4402
4403
4404void
2b4c9065 4405st_write_done_worker (st_parameter_dt *dtp)
6de9cd9a 4406{
5e805e44 4407 finalize_transfer (dtp);
6de9cd9a 4408
e73d3ca6 4409 if (dtp->u.p.current_unit != NULL
e73d3ca6 4410 && dtp->u.p.current_unit->child_dtio == 0)
241cbc7a 4411 {
4a8d4422
JD		 4412 /* Deal with endfile conditions associated with sequential files. */
4413 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
4414 switch (dtp->u.p.current_unit->endfile)
4415 {
4416 case AT_ENDFILE: /* Remain at the endfile record. */
4417 break;
241cbc7a 4418
4a8d4422
JD		 4419 case AFTER_ENDFILE:
4420 dtp->u.p.current_unit->endfile = AT_ENDFILE; /* Just at it now. */
4421 break;
241cbc7a 4422
4a8d4422
JD		 4423 case NO_ENDFILE:
4424 /* Get rid of whatever is after this record. */
4425 if (!is_internal_unit (dtp))
4426 unit_truncate (dtp->u.p.current_unit,
4427 stell (dtp->u.p.current_unit->s),
4428 &dtp->common);
4429 dtp->u.p.current_unit->endfile = AT_ENDFILE;
4430 break;
4431 }
e73d3ca6 4432
4a8d4422 4433 free_ionml (dtp);
54ffdb12 4434
4a8d4422 4435 /* If this is a parent WRITE statement we do not need to retain the
bf498b07 4436 internal unit structure for child use. */
7b39e3c2 4437 if (dtp->u.p.unit_is_internal)
4a8d4422 4438 {
8c098567
JD		 4439 if ((dtp->common.flags & IOPARM_DT_HAS_UDTIO) == 0)
4440 {
4441 free (dtp->u.p.current_unit->filename);
4442 dtp->u.p.current_unit->filename = NULL;
8c098567
JD		 4443 if (dtp->u.p.current_unit->ls)
4444 free (dtp->u.p.current_unit->ls);
4445 dtp->u.p.current_unit->ls = NULL;
4446 }
4447 newunit_free (dtp->common.unit);
4a8d4422 4448 }
7b39e3c2 4449 if (dtp->u.p.unit_is_internal || dtp->u.p.format_not_saved)
4a8d4422
JD		 4450 {
4451 free_format_data (dtp->u.p.fmt);
4452 free_format (dtp);
4453 }
2b4c9065
NK		 4454 }
4455}
4456
4457extern void st_write_done (st_parameter_dt *);
4458export_proto(st_write_done);
4459
4460void
4461st_write_done (st_parameter_dt *dtp)
4462{
4463 if (dtp->u.p.current_unit)
4464 {
d0cbb206 4465 if (dtp->u.p.current_unit->au && dtp->u.p.async)
2b4c9065
NK		 4466 {
4467 if (dtp->common.flags & IOPARM_DT_HAS_ID)
4468 *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au,
4469 AIO_WRITE_DONE);
4470 else
4471 {
d0cbb206
TK		 4472 /* We perform synchronous I/O on an asynchronous unit, so no need
4473 to enqueue AIO_READ_DONE. */
4474 if (dtp->u.p.async)
4475 enqueue_done (dtp->u.p.current_unit->au, AIO_WRITE_DONE);
2b4c9065
NK		 4476 }
4477 }
4478 else
4479 st_write_done_worker (dtp);
4480
4a8d4422
JD		 4481 unlock_unit (dtp->u.p.current_unit);
4482 }
2b4c9065 4483
6de9cd9a
DN		 4484 library_end ();
4485}
4486
2b4c9065
NK		 4487/* Wait operation. We need to keep around the do-nothing version
4488 of st_wait for compatibility with previous versions, which had marked
4489 the argument as unused (and thus liable to be removed).
4490
4491 TODO: remove at next bump in version number. */
10256cbe 4492
10256cbe
JD		 4493void
4494st_wait (st_parameter_wait *wtp __attribute__((unused)))
4495{
2b4c9065
NK		 4496 return;
4497}
4498
4499void
4500st_wait_async (st_parameter_wait *wtp)
4501{
4502 gfc_unit *u = find_unit (wtp->common.unit);
56f03cd1 4503 if (ASYNC_IO && u && u->au)
2b4c9065
NK		 4504 {
4505 if (wtp->common.flags & IOPARM_WAIT_HAS_ID)
4506 async_wait_id (&(wtp->common), u->au, *wtp->id);
4507 else
4508 async_wait (&(wtp->common), u->au);
4509 }
4510
4511 unlock_unit (u);
10256cbe
JD		 4512}
4513
4514
29dc5138
PT		 4515/* Receives the scalar information for namelist objects and stores it
4516 in a linked list of namelist_info types. */
6de9cd9a 4517
e73d3ca6 4518static void
f29876bb 4519set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
e73d3ca6 4520 GFC_INTEGER_4 len, gfc_charlen_type string_length,
7fb43006 4521 dtype_type dtype, void *dtio_sub, void *vtable)
6de9cd9a 4522{
29dc5138
PT		 4523 namelist_info *t1 = NULL;
4524 namelist_info *nml;
88fdfd5a 4525 size_t var_name_len = strlen (var_name);
29dc5138 4526
1a0fd3d3 4527 nml = (namelist_info*) xmalloc (sizeof (namelist_info));
29dc5138 4528
6de9cd9a 4529 nml->mem_pos = var_addr;
e73d3ca6
PT		 4530 nml->dtio_sub = dtio_sub;
4531 nml->vtable = vtable;
29dc5138 4532
1a0fd3d3 4533 nml->var_name = (char*) xmalloc (var_name_len + 1);
88fdfd5a
JB		 4534 memcpy (nml->var_name, var_name, var_name_len);
4535 nml->var_name[var_name_len] = '\0';
29dc5138
PT		 4536
4537 nml->len = (int) len;
4538 nml->string_length = (index_type) string_length;
4539
7fb43006
PT		 4540 nml->var_rank = (int) (dtype.rank);
4541 nml->size = (index_type) (dtype.elem_len);
4542 nml->type = (bt) (dtype.type);
29dc5138
PT		 4543
4544 if (nml->var_rank > 0)
3bc268e6 4545 {
29dc5138 4546 nml->dim = (descriptor_dimension*)
92e6f3a4 4547 xmallocarray (nml->var_rank, sizeof (descriptor_dimension));
965eec16 4548 nml->ls = (array_loop_spec*)
92e6f3a4 4549 xmallocarray (nml->var_rank, sizeof (array_loop_spec));
3bc268e6
VL		 4550 }
4551 else
4552 {
29dc5138
PT		 4553 nml->dim = NULL;
4554 nml->ls = NULL;
3bc268e6
VL		 4555 }
4556
6de9cd9a
DN		 4557 nml->next = NULL;
4558
5e805e44
JJ		 4559 if ((dtp->common.flags & IOPARM_DT_IONML_SET) == 0)
4560 {
4561 dtp->common.flags |= IOPARM_DT_IONML_SET;
4562 dtp->u.p.ionml = nml;
4563 }
6de9cd9a
DN		 4564 else
4565 {
5e805e44 4566 for (t1 = dtp->u.p.ionml; t1->next; t1 = t1->next);
29dc5138 4567 t1->next = nml;
6de9cd9a
DN		 4568 }
4569}
4570
e73d3ca6 4571extern void st_set_nml_var (st_parameter_dt *dtp, void *, char *,
7fb43006 4572 GFC_INTEGER_4, gfc_charlen_type, dtype_type);
e73d3ca6
PT		 4573export_proto(st_set_nml_var);
4574
4575void
f29876bb 4576st_set_nml_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
e73d3ca6 4577 GFC_INTEGER_4 len, gfc_charlen_type string_length,
7fb43006 4578 dtype_type dtype)
e73d3ca6
PT		 4579{
4580 set_nml_var (dtp, var_addr, var_name, len, string_length,
4581 dtype, NULL, NULL);
4582}
4583
4584
4585/* Essentially the same as previous but carrying the dtio procedure
4586 and the vtable as additional arguments. */
4587extern void st_set_nml_dtio_var (st_parameter_dt *dtp, void *, char *,
7fb43006 4588 GFC_INTEGER_4, gfc_charlen_type, dtype_type,
e73d3ca6
PT		 4589 void *, void *);
4590export_proto(st_set_nml_dtio_var);
4591
4592
4593void
f29876bb 4594st_set_nml_dtio_var (st_parameter_dt *dtp, void *var_addr, char *var_name,
e73d3ca6 4595 GFC_INTEGER_4 len, gfc_charlen_type string_length,
7fb43006 4596 dtype_type dtype, void *dtio_sub, void *vtable)
e73d3ca6
PT		 4597{
4598 set_nml_var (dtp, var_addr, var_name, len, string_length,
4599 dtype, dtio_sub, vtable);
4600}
4601
29dc5138 4602/* Store the dimensional information for the namelist object. */
5e805e44 4603extern void st_set_nml_var_dim (st_parameter_dt *, GFC_INTEGER_4,
6520ecac
JB		 4604 index_type, index_type,
4605 index_type);
944e86ee 4606export_proto(st_set_nml_var_dim);
7d7b8bfe 4607
6de9cd9a 4608void
5e805e44 4609st_set_nml_var_dim (st_parameter_dt *dtp, GFC_INTEGER_4 n_dim,
6520ecac
JB		 4610 index_type stride, index_type lbound,
4611 index_type ubound)
6de9cd9a 4612{
f29876bb 4613 namelist_info *nml;
29dc5138 4614 int n;
6de9cd9a 4615
29dc5138 4616 n = (int)n_dim;
6de9cd9a 4617
5e805e44 4618 for (nml = dtp->u.p.ionml; nml->next; nml = nml->next);
6de9cd9a 4619
dfb55fdc 4620 GFC_DIMENSION_SET(nml->dim[n],lbound,ubound,stride);
6de9cd9a 4621}
181c9f4a 4622
7812c78c
JD		 4623
4624/* Once upon a time, a poor innocent Fortran program was reading a
4625 file, when suddenly it hit the end-of-file (EOF). Unfortunately
4626 the OS doesn't tell whether we're at the EOF or whether we already
4627 went past it. Luckily our hero, libgfortran, keeps track of this.
4628 Call this function when you detect an EOF condition. See Section
4629 9.10.2 in F2003. */
4630
4631void
f29876bb 4632hit_eof (st_parameter_dt *dtp)
7812c78c
JD		 4633{
4634 dtp->u.p.current_unit->flags.position = POSITION_APPEND;
4635
4636 if (dtp->u.p.current_unit->flags.access == ACCESS_SEQUENTIAL)
4637 switch (dtp->u.p.current_unit->endfile)
4638 {
4639 case NO_ENDFILE:
4640 case AT_ENDFILE:
4641 generate_error (&dtp->common, LIBERROR_END, NULL);
83437e67 4642 if (!is_internal_unit (dtp) && !dtp->u.p.namelist_mode)
7812c78c
JD		 4643 {
4644 dtp->u.p.current_unit->endfile = AFTER_ENDFILE;
4645 dtp->u.p.current_unit->current_record = 0;
4646 }
4647 else
4648 dtp->u.p.current_unit->endfile = AT_ENDFILE;
4649 break;
e73d3ca6 4650
7812c78c
JD		 4651 case AFTER_ENDFILE:
4652 generate_error (&dtp->common, LIBERROR_ENDFILE, NULL);
4653 dtp->u.p.current_unit->current_record = 0;
4654 break;
4655 }
4656 else
4657 {
4658 /* Non-sequential files don't have an ENDFILE record, so we
4659 can't be at AFTER_ENDFILE. */
4660 dtp->u.p.current_unit->endfile = AT_ENDFILE;
4661 generate_error (&dtp->common, LIBERROR_END, NULL);
4662 dtp->u.p.current_unit->current_record = 0;
4663 }
4664}
Mirror of https://gcc.gnu.org/git/gcc.git