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