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