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