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