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