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