1 /* Copyright (C) 2002-2022 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 #ifdef HAVE_GFC_REAL_17 157 /* Rather than write a special parsing routine, enumerate all the 158 possibilities here. */ 159 { "r16_ieee", GFC_CONVERT_R16_IEEE}, 160 { "r16_ibm", GFC_CONVERT_R16_IBM}, 161 { "native,r16_ieee", GFC_CONVERT_R16_IEEE}, 162 { "native,r16_ibm", GFC_CONVERT_R16_IBM}, 163 { "r16_ieee,native", GFC_CONVERT_R16_IEEE}, 164 { "r16_ibm,native", GFC_CONVERT_R16_IBM}, 165 { "swap,r16_ieee", GFC_CONVERT_R16_IEEE_SWAP}, 166 { "swap,r16_ibm", GFC_CONVERT_R16_IBM_SWAP}, 167 { "r16_ieee,swap", GFC_CONVERT_R16_IEEE_SWAP}, 168 { "r16_ibm,swap", GFC_CONVERT_R16_IBM_SWAP}, 169 { "big_endian,r16_ieee", GFC_CONVERT_R16_IEEE_BIG}, 170 { "big_endian,r16_ibm", GFC_CONVERT_R16_IBM_BIG}, 171 { "r16_ieee,big_endian", GFC_CONVERT_R16_IEEE_BIG}, 172 { "r16_ibm,big_endian", GFC_CONVERT_R16_IBM_BIG}, 173 { "little_endian,r16_ieee", GFC_CONVERT_R16_IEEE_LITTLE}, 174 { "little_endian,r16_ibm", GFC_CONVERT_R16_IBM_LITTLE}, 175 { "r16_ieee,little_endian", GFC_CONVERT_R16_IEEE_LITTLE}, 176 { "r16_ibm,little_endian", GFC_CONVERT_R16_IBM_LITTLE}, 177 #endif 178 { NULL, 0} 179 }; 180 181 static const st_option async_opt[] = 182 { 183 { "yes", ASYNC_YES}, 184 { "no", ASYNC_NO}, 185 { NULL, 0} 186 }; 187 188 /* Given a unit, test to see if the file is positioned at the terminal 189 point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE. 190 This prevents us from changing the state from AFTER_ENDFILE to 191 AT_ENDFILE. */ 192 193 static void 194 test_endfile (gfc_unit *u) 195 { 196 if (u->endfile == NO_ENDFILE) 197 { 198 gfc_offset sz = ssize (u->s); 199 if (sz == 0 || sz == stell (u->s)) 200 u->endfile = AT_ENDFILE; 201 } 202 } 203 204 205 /* Change the modes of a file, those that are allowed * to be 206 changed. */ 207 208 static void 209 edit_modes (st_parameter_open *opp, gfc_unit *u, unit_flags *flags) 210 { 211 /* Complain about attempts to change the unchangeable. */ 212 213 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && 214 u->flags.status != flags->status) 215 generate_error (&opp->common, LIBERROR_BAD_OPTION, 216 "Cannot change STATUS parameter in OPEN statement"); 217 218 if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access) 219 generate_error (&opp->common, LIBERROR_BAD_OPTION, 220 "Cannot change ACCESS parameter in OPEN statement"); 221 222 if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form) 223 generate_error (&opp->common, LIBERROR_BAD_OPTION, 224 "Cannot change FORM parameter in OPEN statement"); 225 226 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) 227 && opp->recl_in != u->recl) 228 generate_error (&opp->common, LIBERROR_BAD_OPTION, 229 "Cannot change RECL parameter in OPEN statement"); 230 231 if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action) 232 generate_error (&opp->common, LIBERROR_BAD_OPTION, 233 "Cannot change ACTION parameter in OPEN statement"); 234 235 if (flags->share != SHARE_UNSPECIFIED && u->flags.share != flags->share) 236 generate_error (&opp->common, LIBERROR_BAD_OPTION, 237 "Cannot change SHARE parameter in OPEN statement"); 238 239 if (flags->cc != CC_UNSPECIFIED && u->flags.cc != flags->cc) 240 generate_error (&opp->common, LIBERROR_BAD_OPTION, 241 "Cannot change CARRIAGECONTROL parameter in OPEN statement"); 242 243 /* Status must be OLD if present. */ 244 245 if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD && 246 flags->status != STATUS_UNKNOWN) 247 { 248 if (flags->status == STATUS_SCRATCH) 249 notify_std (&opp->common, GFC_STD_GNU, 250 "OPEN statement must have a STATUS of OLD or UNKNOWN"); 251 else 252 generate_error (&opp->common, LIBERROR_BAD_OPTION, 253 "OPEN statement must have a STATUS of OLD or UNKNOWN"); 254 } 255 256 if (u->flags.form == FORM_UNFORMATTED) 257 { 258 if (flags->delim != DELIM_UNSPECIFIED) 259 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 260 "DELIM parameter conflicts with UNFORMATTED form in " 261 "OPEN statement"); 262 263 if (flags->blank != BLANK_UNSPECIFIED) 264 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 265 "BLANK parameter conflicts with UNFORMATTED form in " 266 "OPEN statement"); 267 268 if (flags->pad != PAD_UNSPECIFIED) 269 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 270 "PAD parameter conflicts with UNFORMATTED form in " 271 "OPEN statement"); 272 273 if (flags->decimal != DECIMAL_UNSPECIFIED) 274 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 275 "DECIMAL parameter conflicts with UNFORMATTED form in " 276 "OPEN statement"); 277 278 if (flags->encoding != ENCODING_UNSPECIFIED) 279 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 280 "ENCODING parameter conflicts with UNFORMATTED form in " 281 "OPEN statement"); 282 283 if (flags->round != ROUND_UNSPECIFIED) 284 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 285 "ROUND parameter conflicts with UNFORMATTED form in " 286 "OPEN statement"); 287 288 if (flags->sign != SIGN_UNSPECIFIED) 289 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 290 "SIGN parameter conflicts with UNFORMATTED form in " 291 "OPEN statement"); 292 } 293 294 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) 295 { 296 /* Change the changeable: */ 297 if (flags->blank != BLANK_UNSPECIFIED) 298 u->flags.blank = flags->blank; 299 if (flags->delim != DELIM_UNSPECIFIED) 300 u->flags.delim = flags->delim; 301 if (flags->pad != PAD_UNSPECIFIED) 302 u->flags.pad = flags->pad; 303 if (flags->decimal != DECIMAL_UNSPECIFIED) 304 u->flags.decimal = flags->decimal; 305 if (flags->encoding != ENCODING_UNSPECIFIED) 306 u->flags.encoding = flags->encoding; 307 if (flags->async != ASYNC_UNSPECIFIED) 308 u->flags.async = flags->async; 309 if (flags->round != ROUND_UNSPECIFIED) 310 u->flags.round = flags->round; 311 if (flags->sign != SIGN_UNSPECIFIED) 312 u->flags.sign = flags->sign; 313 314 /* Reposition the file if necessary. */ 315 316 switch (flags->position) 317 { 318 case POSITION_UNSPECIFIED: 319 case POSITION_ASIS: 320 break; 321 322 case POSITION_REWIND: 323 if (sseek (u->s, 0, SEEK_SET) != 0) 324 goto seek_error; 325 326 u->current_record = 0; 327 u->last_record = 0; 328 329 test_endfile (u); 330 break; 331 332 case POSITION_APPEND: 333 if (sseek (u->s, 0, SEEK_END) < 0) 334 goto seek_error; 335 336 if (flags->access != ACCESS_STREAM) 337 u->current_record = 0; 338 339 u->endfile = AT_ENDFILE; /* We are at the end. */ 340 break; 341 342 seek_error: 343 generate_error (&opp->common, LIBERROR_OS, NULL); 344 break; 345 } 346 } 347 348 unlock_unit (u); 349 } 350 351 352 /* Open an unused unit. */ 353 354 gfc_unit * 355 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags *flags) 356 { 357 gfc_unit *u2; 358 stream *s; 359 char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */]; 360 361 /* Change unspecifieds to defaults. Leave (flags->action == 362 ACTION_UNSPECIFIED) alone so open_external() can set it based on 363 what type of open actually works. */ 364 365 if (flags->access == ACCESS_UNSPECIFIED) 366 flags->access = ACCESS_SEQUENTIAL; 367 368 if (flags->form == FORM_UNSPECIFIED) 369 flags->form = (flags->access == ACCESS_SEQUENTIAL) 370 ? FORM_FORMATTED : FORM_UNFORMATTED; 371 372 if (flags->async == ASYNC_UNSPECIFIED) 373 flags->async = ASYNC_NO; 374 375 if (flags->status == STATUS_UNSPECIFIED) 376 flags->status = STATUS_UNKNOWN; 377 378 if (flags->cc == CC_UNSPECIFIED) 379 flags->cc = flags->form == FORM_UNFORMATTED ? CC_NONE : CC_LIST; 380 else if (flags->form == FORM_UNFORMATTED && flags->cc != CC_NONE) 381 { 382 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 383 "CARRIAGECONTROL parameter conflicts with UNFORMATTED form in " 384 "OPEN statement"); 385 goto fail; 386 } 387 388 /* Checks. */ 389 390 if (flags->delim != DELIM_UNSPECIFIED 391 && flags->form == FORM_UNFORMATTED) 392 { 393 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 394 "DELIM parameter conflicts with UNFORMATTED form in " 395 "OPEN statement"); 396 goto fail; 397 } 398 399 if (flags->blank == BLANK_UNSPECIFIED) 400 flags->blank = BLANK_NULL; 401 else 402 { 403 if (flags->form == FORM_UNFORMATTED) 404 { 405 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 406 "BLANK parameter conflicts with UNFORMATTED form in " 407 "OPEN statement"); 408 goto fail; 409 } 410 } 411 412 if (flags->pad == PAD_UNSPECIFIED) 413 flags->pad = PAD_YES; 414 else 415 { 416 if (flags->form == FORM_UNFORMATTED) 417 { 418 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 419 "PAD parameter conflicts with UNFORMATTED form in " 420 "OPEN statement"); 421 goto fail; 422 } 423 } 424 425 if (flags->decimal == DECIMAL_UNSPECIFIED) 426 flags->decimal = DECIMAL_POINT; 427 else 428 { 429 if (flags->form == FORM_UNFORMATTED) 430 { 431 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 432 "DECIMAL parameter conflicts with UNFORMATTED form " 433 "in OPEN statement"); 434 goto fail; 435 } 436 } 437 438 if (flags->encoding == ENCODING_UNSPECIFIED) 439 flags->encoding = ENCODING_DEFAULT; 440 else 441 { 442 if (flags->form == FORM_UNFORMATTED) 443 { 444 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 445 "ENCODING parameter conflicts with UNFORMATTED form in " 446 "OPEN statement"); 447 goto fail; 448 } 449 } 450 451 /* NB: the value for ROUND when it's not specified by the user does not 452 have to be PROCESSOR_DEFINED; the standard says that it is 453 processor dependent, and requires that it is one of the 454 possible value (see F2003, 9.4.5.13). */ 455 if (flags->round == ROUND_UNSPECIFIED) 456 flags->round = ROUND_PROCDEFINED; 457 else 458 { 459 if (flags->form == FORM_UNFORMATTED) 460 { 461 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 462 "ROUND parameter conflicts with UNFORMATTED form in " 463 "OPEN statement"); 464 goto fail; 465 } 466 } 467 468 if (flags->sign == SIGN_UNSPECIFIED) 469 flags->sign = SIGN_PROCDEFINED; 470 else 471 { 472 if (flags->form == FORM_UNFORMATTED) 473 { 474 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 475 "SIGN parameter conflicts with UNFORMATTED form in " 476 "OPEN statement"); 477 goto fail; 478 } 479 } 480 481 if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT) 482 { 483 generate_error (&opp->common, LIBERROR_OPTION_CONFLICT, 484 "ACCESS parameter conflicts with SEQUENTIAL access in " 485 "OPEN statement"); 486 goto fail; 487 } 488 else 489 if (flags->position == POSITION_UNSPECIFIED) 490 flags->position = POSITION_ASIS; 491 492 if (flags->access == ACCESS_DIRECT 493 && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0) 494 { 495 generate_error (&opp->common, LIBERROR_MISSING_OPTION, 496 "Missing RECL parameter in OPEN statement"); 497 goto fail; 498 } 499 500 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0) 501 { 502 generate_error (&opp->common, LIBERROR_BAD_OPTION, 503 "RECL parameter is non-positive in OPEN statement"); 504 goto fail; 505 } 506 507 switch (flags->status) 508 { 509 case STATUS_SCRATCH: 510 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0) 511 { 512 opp->file = NULL; 513 break; 514 } 515 516 generate_error (&opp->common, LIBERROR_BAD_OPTION, 517 "FILE parameter must not be present in OPEN statement"); 518 goto fail; 519 520 case STATUS_OLD: 521 case STATUS_NEW: 522 case STATUS_REPLACE: 523 case STATUS_UNKNOWN: 524 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE)) 525 break; 526 527 opp->file = tmpname; 528 opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d", 529 (int) opp->common.unit); 530 break; 531 532 default: 533 internal_error (&opp->common, "new_unit(): Bad status"); 534 } 535 536 /* Make sure the file isn't already open someplace else. 537 Do not error if opening file preconnected to stdin, stdout, stderr. */ 538 539 u2 = NULL; 540 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0 541 && !(compile_options.allow_std & GFC_STD_F2018)) 542 u2 = find_file (opp->file, opp->file_len); 543 if (u2 != NULL 544 && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit) 545 && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit) 546 && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit)) 547 { 548 unlock_unit (u2); 549 generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL); 550 goto cleanup; 551 } 552 553 if (u2 != NULL) 554 unlock_unit (u2); 555 556 /* If the unit specified is preconnected with a file specified to be open, 557 then clear the format buffer. */ 558 if ((opp->common.unit == options.stdin_unit || 559 opp->common.unit == options.stdout_unit || 560 opp->common.unit == options.stderr_unit) 561 && (opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0) 562 fbuf_destroy (u); 563 564 /* Open file. */ 565 566 s = open_external (opp, flags); 567 if (s == NULL) 568 { 569 char errbuf[256]; 570 char *path = fc_strdup (opp->file, opp->file_len); 571 size_t msglen = opp->file_len + 22 + sizeof (errbuf); 572 char *msg = xmalloc (msglen); 573 snprintf (msg, msglen, "Cannot open file '%s': %s", path, 574 gf_strerror (errno, errbuf, sizeof (errbuf))); 575 generate_error (&opp->common, LIBERROR_OS, msg); 576 free (msg); 577 free (path); 578 goto cleanup; 579 } 580 581 if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE) 582 flags->status = STATUS_OLD; 583 584 /* Create the unit structure. */ 585 586 if (u->unit_number != opp->common.unit) 587 internal_error (&opp->common, "Unit number changed"); 588 u->s = s; 589 u->flags = *flags; 590 u->read_bad = 0; 591 u->endfile = NO_ENDFILE; 592 u->last_record = 0; 593 u->current_record = 0; 594 u->mode = READING; 595 u->maxrec = 0; 596 u->bytes_left = 0; 597 u->saved_pos = 0; 598 599 if (flags->position == POSITION_APPEND) 600 { 601 if (sseek (u->s, 0, SEEK_END) < 0) 602 { 603 generate_error (&opp->common, LIBERROR_OS, NULL); 604 goto cleanup; 605 } 606 u->endfile = AT_ENDFILE; 607 } 608 609 /* Unspecified recl ends up with a processor dependent value. */ 610 611 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) 612 { 613 u->flags.has_recl = 1; 614 u->recl = opp->recl_in; 615 u->recl_subrecord = u->recl; 616 u->bytes_left = u->recl; 617 } 618 else 619 { 620 u->flags.has_recl = 0; 621 u->recl = default_recl; 622 if (compile_options.max_subrecord_length) 623 { 624 u->recl_subrecord = compile_options.max_subrecord_length; 625 } 626 else 627 { 628 switch (compile_options.record_marker) 629 { 630 case 0: 631 /* Fall through */ 632 case sizeof (GFC_INTEGER_4): 633 u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH; 634 break; 635 636 case sizeof (GFC_INTEGER_8): 637 u->recl_subrecord = max_offset - 16; 638 break; 639 640 default: 641 runtime_error ("Illegal value for record marker"); 642 break; 643 } 644 } 645 } 646 647 /* If the file is direct access, calculate the maximum record number 648 via a division now instead of letting the multiplication overflow 649 later. */ 650 651 if (flags->access == ACCESS_DIRECT) 652 u->maxrec = max_offset / u->recl; 653 654 if (flags->access == ACCESS_STREAM) 655 { 656 u->maxrec = max_offset; 657 /* F2018 (N2137) 12.10.2.26: If the connection is for stream 658 access recl is assigned the value -2. */ 659 u->recl = -2; 660 u->bytes_left = 1; 661 u->strm_pos = stell (u->s) + 1; 662 } 663 664 u->filename = fc_strdup (opp->file, opp->file_len); 665 666 /* Curiously, the standard requires that the 667 position specifier be ignored for new files so a newly connected 668 file starts out at the initial point. We still need to figure 669 out if the file is at the end or not. */ 670 671 test_endfile (u); 672 673 if (flags->status == STATUS_SCRATCH && opp->file != NULL) 674 free (opp->file); 675 676 if (flags->form == FORM_FORMATTED) 677 { 678 if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)) 679 fbuf_init (u, u->recl); 680 else 681 fbuf_init (u, 0); 682 } 683 else 684 u->fbuf = NULL; 685 686 /* Check if asynchrounous. */ 687 if (flags->async == ASYNC_YES) 688 init_async_unit (u); 689 else 690 u->au = NULL; 691 692 return u; 693 694 cleanup: 695 696 /* Free memory associated with a temporary filename. */ 697 698 if (flags->status == STATUS_SCRATCH && opp->file != NULL) 699 free (opp->file); 700 701 fail: 702 703 close_unit (u); 704 return NULL; 705 } 706 707 708 /* Open a unit which is already open. This involves changing the 709 modes or closing what is there now and opening the new file. */ 710 711 static void 712 already_open (st_parameter_open *opp, gfc_unit *u, unit_flags *flags) 713 { 714 if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0) 715 { 716 edit_modes (opp, u, flags); 717 return; 718 } 719 720 /* If the file is connected to something else, close it and open a 721 new unit. */ 722 723 if (!compare_file_filename (u, opp->file, opp->file_len)) 724 { 725 if (sclose (u->s) == -1) 726 { 727 unlock_unit (u); 728 generate_error (&opp->common, LIBERROR_OS, 729 "Error closing file in OPEN statement"); 730 return; 731 } 732 733 u->s = NULL; 734 735 #if !HAVE_UNLINK_OPEN_FILE 736 if (u->filename && u->flags.status == STATUS_SCRATCH) 737 remove (u->filename); 738 #endif 739 free (u->filename); 740 u->filename = NULL; 741 742 u = new_unit (opp, u, flags); 743 if (u != NULL) 744 unlock_unit (u); 745 return; 746 } 747 748 edit_modes (opp, u, flags); 749 } 750 751 752 /* Open file. */ 753 754 extern void st_open (st_parameter_open *opp); 755 export_proto(st_open); 756 757 void 758 st_open (st_parameter_open *opp) 759 { 760 unit_flags flags; 761 gfc_unit *u = NULL; 762 GFC_INTEGER_4 cf = opp->common.flags; 763 unit_convert conv; 764 765 library_start (&opp->common); 766 767 /* Decode options. */ 768 flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly; 769 770 flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED : 771 find_option (&opp->common, opp->access, opp->access_len, 772 access_opt, "Bad ACCESS parameter in OPEN statement"); 773 774 flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED : 775 find_option (&opp->common, opp->action, opp->action_len, 776 action_opt, "Bad ACTION parameter in OPEN statement"); 777 778 flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED : 779 find_option (&opp->common, opp->cc, opp->cc_len, 780 cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement"); 781 782 flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED : 783 find_option (&opp->common, opp->share, opp->share_len, 784 share_opt, "Bad SHARE parameter in OPEN statement"); 785 786 flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED : 787 find_option (&opp->common, opp->blank, opp->blank_len, 788 blank_opt, "Bad BLANK parameter in OPEN statement"); 789 790 flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED : 791 find_option (&opp->common, opp->delim, opp->delim_len, 792 delim_opt, "Bad DELIM parameter in OPEN statement"); 793 794 flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED : 795 find_option (&opp->common, opp->pad, opp->pad_len, 796 pad_opt, "Bad PAD parameter in OPEN statement"); 797 798 flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED : 799 find_option (&opp->common, opp->decimal, opp->decimal_len, 800 decimal_opt, "Bad DECIMAL parameter in OPEN statement"); 801 802 flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED : 803 find_option (&opp->common, opp->encoding, opp->encoding_len, 804 encoding_opt, "Bad ENCODING parameter in OPEN statement"); 805 806 flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED : 807 find_option (&opp->common, opp->asynchronous, opp->asynchronous_len, 808 async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement"); 809 810 flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED : 811 find_option (&opp->common, opp->round, opp->round_len, 812 round_opt, "Bad ROUND parameter in OPEN statement"); 813 814 flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED : 815 find_option (&opp->common, opp->sign, opp->sign_len, 816 sign_opt, "Bad SIGN parameter in OPEN statement"); 817 818 flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED : 819 find_option (&opp->common, opp->form, opp->form_len, 820 form_opt, "Bad FORM parameter in OPEN statement"); 821 822 flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED : 823 find_option (&opp->common, opp->position, opp->position_len, 824 position_opt, "Bad POSITION parameter in OPEN statement"); 825 826 flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED : 827 find_option (&opp->common, opp->status, opp->status_len, 828 status_opt, "Bad STATUS parameter in OPEN statement"); 829 830 /* First, we check wether the convert flag has been set via environment 831 variable. This overrides the convert tag in the open statement. */ 832 833 conv = get_unformatted_convert (opp->common.unit); 834 835 if (conv == GFC_CONVERT_NONE) 836 { 837 /* Nothing has been set by environment variable, check the convert tag. */ 838 if (cf & IOPARM_OPEN_HAS_CONVERT) 839 conv = find_option (&opp->common, opp->convert, opp->convert_len, 840 convert_opt, 841 "Bad CONVERT parameter in OPEN statement"); 842 else 843 conv = compile_options.convert; 844 } 845 846 flags.convert = 0; 847 848 #ifdef HAVE_GFC_REAL_17 849 flags.convert = conv & (GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM); 850 conv &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM); 851 #endif 852 853 switch (conv) 854 { 855 case GFC_CONVERT_NATIVE: 856 case GFC_CONVERT_SWAP: 857 break; 858 859 case GFC_CONVERT_BIG: 860 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP; 861 break; 862 863 case GFC_CONVERT_LITTLE: 864 conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE; 865 break; 866 867 default: 868 internal_error (&opp->common, "Illegal value for CONVERT"); 869 break; 870 } 871 872 flags.convert |= conv; 873 874 if (flags.position != POSITION_UNSPECIFIED 875 && flags.access == ACCESS_DIRECT) 876 generate_error (&opp->common, LIBERROR_BAD_OPTION, 877 "Cannot use POSITION with direct access files"); 878 879 if (flags.readonly 880 && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ) 881 generate_error (&opp->common, LIBERROR_BAD_OPTION, 882 "ACTION conflicts with READONLY in OPEN statement"); 883 884 if (flags.access == ACCESS_APPEND) 885 { 886 if (flags.position != POSITION_UNSPECIFIED 887 && flags.position != POSITION_APPEND) 888 generate_error (&opp->common, LIBERROR_BAD_OPTION, 889 "Conflicting ACCESS and POSITION flags in" 890 " OPEN statement"); 891 892 notify_std (&opp->common, GFC_STD_GNU, 893 "Extension: APPEND as a value for ACCESS in OPEN statement"); 894 flags.access = ACCESS_SEQUENTIAL; 895 flags.position = POSITION_APPEND; 896 } 897 898 if (flags.position == POSITION_UNSPECIFIED) 899 flags.position = POSITION_ASIS; 900 901 if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) 902 { 903 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)) 904 opp->common.unit = newunit_alloc (); 905 else if (opp->common.unit < 0) 906 { 907 u = find_unit (opp->common.unit); 908 if (u == NULL) /* Negative unit and no NEWUNIT-created unit found. */ 909 { 910 generate_error (&opp->common, LIBERROR_BAD_OPTION, 911 "Bad unit number in OPEN statement"); 912 library_end (); 913 return; 914 } 915 } 916 917 if (u == NULL) 918 u = find_or_create_unit (opp->common.unit); 919 if (u->s == NULL) 920 { 921 u = new_unit (opp, u, &flags); 922 if (u != NULL) 923 unlock_unit (u); 924 } 925 else 926 already_open (opp, u, &flags); 927 } 928 929 if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) 930 && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK) 931 *opp->newunit = opp->common.unit; 932 933 library_end (); 934 } 935