1 /* Copyright (C) 2002-2020 Free Software Foundation, Inc. 2 Contributed by Andy Vaught 3 F2003 I/O support contributed by Jerry DeLisle 4 5 This file is part of the GNU Fortran runtime library (libgfortran). 6 7 Libgfortran is free software; you can redistribute it and/or modify 8 it under the terms of the GNU General Public License as published by 9 the Free Software Foundation; either version 3, or (at your option) 10 any later version. 11 12 Libgfortran is distributed in the hope that it will be useful, 13 but WITHOUT ANY WARRANTY; without even the implied warranty of 14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 GNU General Public License for more details. 16 17 Under Section 7 of GPL version 3, you are granted additional 18 permissions described in the GCC Runtime Library Exception, version 19 3.1, as published by the Free Software Foundation. 20 21 You should have received a copy of the GNU General Public License and 22 a copy of the GCC Runtime Library Exception along with this program; 23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24 <http://www.gnu.org/licenses/>. */ 25 26 #include "io.h" 27 #include "fbuf.h" 28 #include "unix.h" 29 #include "async.h" 30 31 #ifdef HAVE_UNISTD_H 32 #include <unistd.h> 33 #endif 34 35 #include <string.h> 36 #include <errno.h> 37 38 39 static const st_option access_opt[] = { 40 {"sequential", ACCESS_SEQUENTIAL}, 41 {"direct", ACCESS_DIRECT}, 42 {"append", ACCESS_APPEND}, 43 {"stream", ACCESS_STREAM}, 44 {NULL, 0} 45 }; 46 47 static const st_option action_opt[] = 48 { 49 { "read", ACTION_READ}, 50 { "write", ACTION_WRITE}, 51 { "readwrite", ACTION_READWRITE}, 52 { NULL, 0} 53 }; 54 55 static const st_option share_opt[] = 56 { 57 { "denyrw", SHARE_DENYRW }, 58 { "denynone", SHARE_DENYNONE }, 59 { NULL, 0} 60 }; 61 62 static const st_option cc_opt[] = 63 { 64 { "list", CC_LIST }, 65 { "fortran", CC_FORTRAN }, 66 { "none", CC_NONE }, 67 { NULL, 0} 68 }; 69 70 static const st_option blank_opt[] = 71 { 72 { "null", BLANK_NULL}, 73 { "zero", BLANK_ZERO}, 74 { NULL, 0} 75 }; 76 77 static const st_option delim_opt[] = 78 { 79 { "none", DELIM_NONE}, 80 { "apostrophe", DELIM_APOSTROPHE}, 81 { "quote", DELIM_QUOTE}, 82 { NULL, 0} 83 }; 84 85 static const st_option form_opt[] = 86 { 87 { "formatted", FORM_FORMATTED}, 88 { "unformatted", FORM_UNFORMATTED}, 89 { NULL, 0} 90 }; 91 92 static const st_option position_opt[] = 93 { 94 { "asis", POSITION_ASIS}, 95 { "rewind", POSITION_REWIND}, 96 { "append", POSITION_APPEND}, 97 { NULL, 0} 98 }; 99 100 static const st_option status_opt[] = 101 { 102 { "unknown", STATUS_UNKNOWN}, 103 { "old", STATUS_OLD}, 104 { "new", STATUS_NEW}, 105 { "replace", STATUS_REPLACE}, 106 { "scratch", STATUS_SCRATCH}, 107 { NULL, 0} 108 }; 109 110 static const st_option pad_opt[] = 111 { 112 { "yes", PAD_YES}, 113 { "no", PAD_NO}, 114 { NULL, 0} 115 }; 116 117 static const st_option decimal_opt[] = 118 { 119 { "point", DECIMAL_POINT}, 120 { "comma", DECIMAL_COMMA}, 121 { NULL, 0} 122 }; 123 124 static const st_option encoding_opt[] = 125 { 126 { "utf-8", ENCODING_UTF8}, 127 { "default", ENCODING_DEFAULT}, 128 { NULL, 0} 129 }; 130 131 static const st_option round_opt[] = 132 { 133 { "up", ROUND_UP}, 134 { "down", ROUND_DOWN}, 135 { "zero", ROUND_ZERO}, 136 { "nearest", ROUND_NEAREST}, 137 { "compatible", ROUND_COMPATIBLE}, 138 { "processor_defined", ROUND_PROCDEFINED}, 139 { NULL, 0} 140 }; 141 142 static const st_option sign_opt[] = 143 { 144 { "plus", SIGN_PLUS}, 145 { "suppress", SIGN_SUPPRESS}, 146 { "processor_defined", SIGN_PROCDEFINED}, 147 { NULL, 0} 148 }; 149 150 static const st_option convert_opt[] = 151 { 152 { "native", GFC_CONVERT_NATIVE}, 153 { "swap", GFC_CONVERT_SWAP}, 154 { "big_endian", GFC_CONVERT_BIG}, 155 { "little_endian", GFC_CONVERT_LITTLE}, 156 { NULL, 0} 157 }; 158 159 static const st_option async_opt[] = 160 { 161 { "yes", ASYNC_YES}, 162 { "no", ASYNC_NO}, 163 { NULL, 0} 164 }; 165 166 /* Given a unit, test to see if the file is positioned at the terminal 167 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE. 168 This prevents us from changing the state from AFTER_ENDFILE to 169 AT_ENDFILE. */ 170 171 static void 172 test_endfile (gfc_unit *u) 173 { 174 if (u->endfile == NO_ENDFILE) 175 { 176 gfc_offset sz = ssize (u->s); 177 if (sz == 0 || sz == stell (u->s)) 178 u->endfile = AT_ENDFILE; 179 } 180 } 181 182 183 /* Change the modes of a file, those that are allowed * to be 184 changed. */ 185 186 static void 187 edit_modes (st_parameter_open *opp, gfc_unit *u, unit_flags *flags) 188 { 189 /* Complain about attempts to change the unchangeable. */ 190 191 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && 192 u->flags.status != flags->status) 193 generate_error (&opp->common, LIBERROR_BAD_OPTION, 194 "Cannot change STATUS parameter in OPEN statement"); 195 196 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access) 197 generate_error (&opp->common, LIBERROR_BAD_OPTION, 198 "Cannot change ACCESS parameter in OPEN statement"); 199 200 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form) 201 generate_error (&opp->common, LIBERROR_BAD_OPTION, 202 "Cannot change FORM parameter in OPEN statement"); 203 204 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) 205 && opp->recl_in != u->recl) 206 generate_error (&opp->common, LIBERROR_BAD_OPTION, 207 "Cannot change RECL parameter in OPEN statement"); 208 209 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action) 210 generate_error (&opp->common, LIBERROR_BAD_OPTION, 211 "Cannot change ACTION parameter in OPEN statement"); 212 213 if (flags->share != SHARE_UNSPECIFIED && u->flags.share != flags->share) 214 generate_error (&opp->common, LIBERROR_BAD_OPTION, 215 "Cannot change SHARE parameter in OPEN statement"); 216 217 if (flags->cc != CC_UNSPECIFIED && u->flags.cc != flags->cc) 218 generate_error (&opp->common, LIBERROR_BAD_OPTION, 219 "Cannot change CARRIAGECONTROL parameter in OPEN statement"); 220 221 /* Status must be OLD if present. */ 222 223 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && 224 flags->status != STATUS_UNKNOWN) 225 { 226 if (flags->status == STATUS_SCRATCH) 227 notify_std (&opp->common, GFC_STD_GNU, 228 "OPEN statement must have a STATUS of OLD or UNKNOWN"); 229 else 230 generate_error (&opp->common, LIBERROR_BAD_OPTION, 231 "OPEN statement must have a STATUS of OLD or UNKNOWN"); 232 } 233 234 if (u->flags.form == FORM_UNFORMATTED) 235 { 236 if (flags->delim != DELIM_UNSPECIFIED) 237 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 238 "DELIM parameter conflicts with UNFORMATTED form in " 239 "OPEN statement"); 240 241 if (flags->blank != BLANK_UNSPECIFIED) 242 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 243 "BLANK parameter conflicts with UNFORMATTED form in " 244 "OPEN statement"); 245 246 if (flags->pad != PAD_UNSPECIFIED) 247 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 248 "PAD parameter conflicts with UNFORMATTED form in " 249 "OPEN statement"); 250 251 if (flags->decimal != DECIMAL_UNSPECIFIED) 252 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 253 "DECIMAL parameter conflicts with UNFORMATTED form in " 254 "OPEN statement"); 255 256 if (flags->encoding != ENCODING_UNSPECIFIED) 257 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 258 "ENCODING parameter conflicts with UNFORMATTED form in " 259 "OPEN statement"); 260 261 if (flags->round != ROUND_UNSPECIFIED) 262 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 263 "ROUND parameter conflicts with UNFORMATTED form in " 264 "OPEN statement"); 265 266 if (flags->sign != SIGN_UNSPECIFIED) 267 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 268 "SIGN parameter conflicts with UNFORMATTED form in " 269 "OPEN statement"); 270 } 271 272 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) 273 { 274 /* Change the changeable: */ 275 if (flags->blank != BLANK_UNSPECIFIED) 276 u->flags.blank = flags->blank; 277 if (flags->delim != DELIM_UNSPECIFIED) 278 u->flags.delim = flags->delim; 279 if (flags->pad != PAD_UNSPECIFIED) 280 u->flags.pad = flags->pad; 281 if (flags->decimal != DECIMAL_UNSPECIFIED) 282 u->flags.decimal = flags->decimal; 283 if (flags->encoding != ENCODING_UNSPECIFIED) 284 u->flags.encoding = flags->encoding; 285 if (flags->async != ASYNC_UNSPECIFIED) 286 u->flags.async = flags->async; 287 if (flags->round != ROUND_UNSPECIFIED) 288 u->flags.round = flags->round; 289 if (flags->sign != SIGN_UNSPECIFIED) 290 u->flags.sign = flags->sign; 291 292 /* Reposition the file if necessary. */ 293 294 switch (flags->position) 295 { 296 case POSITION_UNSPECIFIED: 297 case POSITION_ASIS: 298 break; 299 300 case POSITION_REWIND: 301 if (sseek (u->s, 0, SEEK_SET) != 0) 302 goto seek_error; 303 304 u->current_record = 0; 305 u->last_record = 0; 306 307 test_endfile (u); 308 break; 309 310 case POSITION_APPEND: 311 if (sseek (u->s, 0, SEEK_END) < 0) 312 goto seek_error; 313 314 if (flags->access != ACCESS_STREAM) 315 u->current_record = 0; 316 317 u->endfile = AT_ENDFILE; /* We are at the end. */ 318 break; 319 320 seek_error: 321 generate_error (&opp->common, LIBERROR_OS, NULL); 322 break; 323 } 324 } 325 326 unlock_unit (u); 327 } 328 329 330 /* Open an unused unit. */ 331 332 gfc_unit * 333 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags *flags) 334 { 335 gfc_unit *u2; 336 stream *s; 337 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */]; 338 339 /* Change unspecifieds to defaults. Leave (flags->action == 340 ACTION_UNSPECIFIED) alone so open_external() can set it based on 341 what type of open actually works. */ 342 343 if (flags->access == ACCESS_UNSPECIFIED) 344 flags->access = ACCESS_SEQUENTIAL; 345 346 if (flags->form == FORM_UNSPECIFIED) 347 flags->form = (flags->access == ACCESS_SEQUENTIAL) 348 ? FORM_FORMATTED : FORM_UNFORMATTED; 349 350 if (flags->async == ASYNC_UNSPECIFIED) 351 flags->async = ASYNC_NO; 352 353 if (flags->status == STATUS_UNSPECIFIED) 354 flags->status = STATUS_UNKNOWN; 355 356 if (flags->cc == CC_UNSPECIFIED) 357 flags->cc = flags->form == FORM_UNFORMATTED ? CC_NONE : CC_LIST; 358 else if (flags->form == FORM_UNFORMATTED && flags->cc != CC_NONE) 359 { 360 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 361 "CARRIAGECONTROL parameter conflicts with UNFORMATTED form in " 362 "OPEN statement"); 363 goto fail; 364 } 365 366 /* Checks. */ 367 368 if (flags->delim != DELIM_UNSPECIFIED 369 && flags->form == FORM_UNFORMATTED) 370 { 371 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 372 "DELIM parameter conflicts with UNFORMATTED form in " 373 "OPEN statement"); 374 goto fail; 375 } 376 377 if (flags->blank == BLANK_UNSPECIFIED) 378 flags->blank = BLANK_NULL; 379 else 380 { 381 if (flags->form == FORM_UNFORMATTED) 382 { 383 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 384 "BLANK parameter conflicts with UNFORMATTED form in " 385 "OPEN statement"); 386 goto fail; 387 } 388 } 389 390 if (flags->pad == PAD_UNSPECIFIED) 391 flags->pad = PAD_YES; 392 else 393 { 394 if (flags->form == FORM_UNFORMATTED) 395 { 396 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 397 "PAD parameter conflicts with UNFORMATTED form in " 398 "OPEN statement"); 399 goto fail; 400 } 401 } 402 403 if (flags->decimal == DECIMAL_UNSPECIFIED) 404 flags->decimal = DECIMAL_POINT; 405 else 406 { 407 if (flags->form == FORM_UNFORMATTED) 408 { 409 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 410 "DECIMAL parameter conflicts with UNFORMATTED form " 411 "in OPEN statement"); 412 goto fail; 413 } 414 } 415 416 if (flags->encoding == ENCODING_UNSPECIFIED) 417 flags->encoding = ENCODING_DEFAULT; 418 else 419 { 420 if (flags->form == FORM_UNFORMATTED) 421 { 422 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 423 "ENCODING parameter conflicts with UNFORMATTED form in " 424 "OPEN statement"); 425 goto fail; 426 } 427 } 428 429 /* NB: the value for ROUND when it's not specified by the user does not 430 have to be PROCESSOR_DEFINED; the standard says that it is 431 processor dependent, and requires that it is one of the 432 possible value (see F2003, 9.4.5.13). */ 433 if (flags->round == ROUND_UNSPECIFIED) 434 flags->round = ROUND_PROCDEFINED; 435 else 436 { 437 if (flags->form == FORM_UNFORMATTED) 438 { 439 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 440 "ROUND parameter conflicts with UNFORMATTED form in " 441 "OPEN statement"); 442 goto fail; 443 } 444 } 445 446 if (flags->sign == SIGN_UNSPECIFIED) 447 flags->sign = SIGN_PROCDEFINED; 448 else 449 { 450 if (flags->form == FORM_UNFORMATTED) 451 { 452 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 453 "SIGN parameter conflicts with UNFORMATTED form in " 454 "OPEN statement"); 455 goto fail; 456 } 457 } 458 459 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT) 460 { 461 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 462 "ACCESS parameter conflicts with SEQUENTIAL access in " 463 "OPEN statement"); 464 goto fail; 465 } 466 else 467 if (flags->position == POSITION_UNSPECIFIED) 468 flags->position = POSITION_ASIS; 469 470 if (flags->access == ACCESS_DIRECT 471 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0) 472 { 473 generate_error (&opp->common, LIBERROR_MISSING_OPTION, 474 "Missing RECL parameter in OPEN statement"); 475 goto fail; 476 } 477 478 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0) 479 { 480 generate_error (&opp->common, LIBERROR_BAD_OPTION, 481 "RECL parameter is non-positive in OPEN statement"); 482 goto fail; 483 } 484 485 switch (flags->status) 486 { 487 case STATUS_SCRATCH: 488 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0) 489 { 490 opp->file = NULL; 491 break; 492 } 493 494 generate_error (&opp->common, LIBERROR_BAD_OPTION, 495 "FILE parameter must not be present in OPEN statement"); 496 goto fail; 497 498 case STATUS_OLD: 499 case STATUS_NEW: 500 case STATUS_REPLACE: 501 case STATUS_UNKNOWN: 502 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE)) 503 break; 504 505 opp->file = tmpname; 506 opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d", 507 (int) opp->common.unit); 508 break; 509 510 default: 511 internal_error (&opp->common, "new_unit(): Bad status"); 512 } 513 514 /* Make sure the file isn't already open someplace else. 515 Do not error if opening file preconnected to stdin, stdout, stderr. */ 516 517 u2 = NULL; 518 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0 519 && !(compile_options.allow_std & GFC_STD_F2018)) 520 u2 = find_file (opp->file, opp->file_len); 521 if (u2 != NULL 522 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit) 523 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit) 524 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit)) 525 { 526 unlock_unit (u2); 527 generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL); 528 goto cleanup; 529 } 530 531 if (u2 != NULL) 532 unlock_unit (u2); 533 534 /* If the unit specified is preconnected with a file specified to be open, 535 then clear the format buffer. */ 536 if ((opp->common.unit == options.stdin_unit || 537 opp->common.unit == options.stdout_unit || 538 opp->common.unit == options.stderr_unit) 539 && (opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0) 540 fbuf_destroy (u); 541 542 /* Open file. */ 543 544 s = open_external (opp, flags); 545 if (s == NULL) 546 { 547 char errbuf[256]; 548 char *path = fc_strdup (opp->file, opp->file_len); 549 size_t msglen = opp->file_len + 22 + sizeof (errbuf); 550 char *msg = xmalloc (msglen); 551 snprintf (msg, msglen, "Cannot open file '%s': %s", path, 552 gf_strerror (errno, errbuf, sizeof (errbuf))); 553 generate_error (&opp->common, LIBERROR_OS, msg); 554 free (msg); 555 free (path); 556 goto cleanup; 557 } 558 559 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE) 560 flags->status = STATUS_OLD; 561 562 /* Create the unit structure. */ 563 564 if (u->unit_number != opp->common.unit) 565 internal_error (&opp->common, "Unit number changed"); 566 u->s = s; 567 u->flags = *flags; 568 u->read_bad = 0; 569 u->endfile = NO_ENDFILE; 570 u->last_record = 0; 571 u->current_record = 0; 572 u->mode = READING; 573 u->maxrec = 0; 574 u->bytes_left = 0; 575 u->saved_pos = 0; 576 577 if (flags->position == POSITION_APPEND) 578 { 579 if (sseek (u->s, 0, SEEK_END) < 0) 580 { 581 generate_error (&opp->common, LIBERROR_OS, NULL); 582 goto cleanup; 583 } 584 u->endfile = AT_ENDFILE; 585 } 586 587 /* Unspecified recl ends up with a processor dependent value. */ 588 589 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) 590 { 591 u->flags.has_recl = 1; 592 u->recl = opp->recl_in; 593 u->recl_subrecord = u->recl; 594 u->bytes_left = u->recl; 595 } 596 else 597 { 598 u->flags.has_recl = 0; 599 u->recl = default_recl; 600 if (compile_options.max_subrecord_length) 601 { 602 u->recl_subrecord = compile_options.max_subrecord_length; 603 } 604 else 605 { 606 switch (compile_options.record_marker) 607 { 608 case 0: 609 /* Fall through */ 610 case sizeof (GFC_INTEGER_4): 611 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH; 612 break; 613 614 case sizeof (GFC_INTEGER_8): 615 u->recl_subrecord = max_offset - 16; 616 break; 617 618 default: 619 runtime_error ("Illegal value for record marker"); 620 break; 621 } 622 } 623 } 624 625 /* If the file is direct access, calculate the maximum record number 626 via a division now instead of letting the multiplication overflow 627 later. */ 628 629 if (flags->access == ACCESS_DIRECT) 630 u->maxrec = max_offset / u->recl; 631 632 if (flags->access == ACCESS_STREAM) 633 { 634 u->maxrec = max_offset; 635 /* F2018 (N2137) 12.10.2.26: If the connection is for stream 636 access recl is assigned the value -2. */ 637 u->recl = -2; 638 u->bytes_left = 1; 639 u->strm_pos = stell (u->s) + 1; 640 } 641 642 u->filename = fc_strdup (opp->file, opp->file_len); 643 644 /* Curiously, the standard requires that the 645 position specifier be ignored for new files so a newly connected 646 file starts out at the initial point. We still need to figure 647 out if the file is at the end or not. */ 648 649 test_endfile (u); 650 651 if (flags->status == STATUS_SCRATCH && opp->file != NULL) 652 free (opp->file); 653 654 if (flags->form == FORM_FORMATTED) 655 { 656 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) 657 fbuf_init (u, u->recl); 658 else 659 fbuf_init (u, 0); 660 } 661 else 662 u->fbuf = NULL; 663 664 /* Check if asynchrounous. */ 665 if (flags->async == ASYNC_YES) 666 init_async_unit (u); 667 else 668 u->au = NULL; 669 670 return u; 671 672 cleanup: 673 674 /* Free memory associated with a temporary filename. */ 675 676 if (flags->status == STATUS_SCRATCH && opp->file != NULL) 677 free (opp->file); 678 679 fail: 680 681 close_unit (u); 682 return NULL; 683 } 684 685 686 /* Open a unit which is already open. This involves changing the 687 modes or closing what is there now and opening the new file. */ 688 689 static void 690 already_open (st_parameter_open *opp, gfc_unit *u, unit_flags *flags) 691 { 692 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0) 693 { 694 edit_modes (opp, u, flags); 695 return; 696 } 697 698 /* If the file is connected to something else, close it and open a 699 new unit. */ 700 701 if (!compare_file_filename (u, opp->file, opp->file_len)) 702 { 703 if (sclose (u->s) == -1) 704 { 705 unlock_unit (u); 706 generate_error (&opp->common, LIBERROR_OS, 707 "Error closing file in OPEN statement"); 708 return; 709 } 710 711 u->s = NULL; 712 713 #if !HAVE_UNLINK_OPEN_FILE 714 if (u->filename && u->flags.status == STATUS_SCRATCH) 715 remove (u->filename); 716 #endif 717 free (u->filename); 718 u->filename = NULL; 719 720 u = new_unit (opp, u, flags); 721 if (u != NULL) 722 unlock_unit (u); 723 return; 724 } 725 726 edit_modes (opp, u, flags); 727 } 728 729 730 /* Open file. */ 731 732 extern void st_open (st_parameter_open *opp); 733 export_proto(st_open); 734 735 void 736 st_open (st_parameter_open *opp) 737 { 738 unit_flags flags; 739 gfc_unit *u = NULL; 740 GFC_INTEGER_4 cf = opp->common.flags; 741 unit_convert conv; 742 743 library_start (&opp->common); 744 745 /* Decode options. */ 746 flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly; 747 748 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED : 749 find_option (&opp->common, opp->access, opp->access_len, 750 access_opt, "Bad ACCESS parameter in OPEN statement"); 751 752 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED : 753 find_option (&opp->common, opp->action, opp->action_len, 754 action_opt, "Bad ACTION parameter in OPEN statement"); 755 756 flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED : 757 find_option (&opp->common, opp->cc, opp->cc_len, 758 cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement"); 759 760 flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED : 761 find_option (&opp->common, opp->share, opp->share_len, 762 share_opt, "Bad SHARE parameter in OPEN statement"); 763 764 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED : 765 find_option (&opp->common, opp->blank, opp->blank_len, 766 blank_opt, "Bad BLANK parameter in OPEN statement"); 767 768 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED : 769 find_option (&opp->common, opp->delim, opp->delim_len, 770 delim_opt, "Bad DELIM parameter in OPEN statement"); 771 772 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED : 773 find_option (&opp->common, opp->pad, opp->pad_len, 774 pad_opt, "Bad PAD parameter in OPEN statement"); 775 776 flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED : 777 find_option (&opp->common, opp->decimal, opp->decimal_len, 778 decimal_opt, "Bad DECIMAL parameter in OPEN statement"); 779 780 flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED : 781 find_option (&opp->common, opp->encoding, opp->encoding_len, 782 encoding_opt, "Bad ENCODING parameter in OPEN statement"); 783 784 flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED : 785 find_option (&opp->common, opp->asynchronous, opp->asynchronous_len, 786 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement"); 787 788 flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED : 789 find_option (&opp->common, opp->round, opp->round_len, 790 round_opt, "Bad ROUND parameter in OPEN statement"); 791 792 flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED : 793 find_option (&opp->common, opp->sign, opp->sign_len, 794 sign_opt, "Bad SIGN parameter in OPEN statement"); 795 796 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED : 797 find_option (&opp->common, opp->form, opp->form_len, 798 form_opt, "Bad FORM parameter in OPEN statement"); 799 800 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED : 801 find_option (&opp->common, opp->position, opp->position_len, 802 position_opt, "Bad POSITION parameter in OPEN statement"); 803 804 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED : 805 find_option (&opp->common, opp->status, opp->status_len, 806 status_opt, "Bad STATUS parameter in OPEN statement"); 807 808 /* First, we check wether the convert flag has been set via environment 809 variable. This overrides the convert tag in the open statement. */ 810 811 conv = get_unformatted_convert (opp->common.unit); 812 813 if (conv == GFC_CONVERT_NONE) 814 { 815 /* Nothing has been set by environment variable, check the convert tag. */ 816 if (cf & IOPARM_OPEN_HAS_CONVERT) 817 conv = find_option (&opp->common, opp->convert, opp->convert_len, 818 convert_opt, 819 "Bad CONVERT parameter in OPEN statement"); 820 else 821 conv = compile_options.convert; 822 } 823 824 switch (conv) 825 { 826 case GFC_CONVERT_NATIVE: 827 case GFC_CONVERT_SWAP: 828 break; 829 830 case GFC_CONVERT_BIG: 831 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; 832 break; 833 834 case GFC_CONVERT_LITTLE: 835 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; 836 break; 837 838 default: 839 internal_error (&opp->common, "Illegal value for CONVERT"); 840 break; 841 } 842 843 flags.convert = conv; 844 845 if (flags.position != POSITION_UNSPECIFIED 846 && flags.access == ACCESS_DIRECT) 847 generate_error (&opp->common, LIBERROR_BAD_OPTION, 848 "Cannot use POSITION with direct access files"); 849 850 if (flags.readonly 851 && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ) 852 generate_error (&opp->common, LIBERROR_BAD_OPTION, 853 "ACTION conflicts with READONLY in OPEN statement"); 854 855 if (flags.access == ACCESS_APPEND) 856 { 857 if (flags.position != POSITION_UNSPECIFIED 858 && flags.position != POSITION_APPEND) 859 generate_error (&opp->common, LIBERROR_BAD_OPTION, 860 "Conflicting ACCESS and POSITION flags in" 861 " OPEN statement"); 862 863 notify_std (&opp->common, GFC_STD_GNU, 864 "Extension: APPEND as a value for ACCESS in OPEN statement"); 865 flags.access = ACCESS_SEQUENTIAL; 866 flags.position = POSITION_APPEND; 867 } 868 869 if (flags.position == POSITION_UNSPECIFIED) 870 flags.position = POSITION_ASIS; 871 872 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) 873 { 874 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)) 875 opp->common.unit = newunit_alloc (); 876 else if (opp->common.unit < 0) 877 { 878 u = find_unit (opp->common.unit); 879 if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */ 880 { 881 generate_error (&opp->common, LIBERROR_BAD_OPTION, 882 "Bad unit number in OPEN statement"); 883 library_end (); 884 return; 885 } 886 } 887 888 if (u == NULL) 889 u = find_or_create_unit (opp->common.unit); 890 if (u->s == NULL) 891 { 892 u = new_unit (opp, u, &flags); 893 if (u != NULL) 894 unlock_unit (u); 895 } 896 else 897 already_open (opp, u, &flags); 898 } 899 900 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) 901 && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) 902 *opp->newunit = opp->common.unit; 903 904 library_end (); 905 } 906