libgfortran/io/open.c

   1 /* Copyright (C) 2002-2021 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 }