libgfortran/io/open.c

   1 /* Copyright (C) 2002-2019 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     u2 = find_file (opp->file, opp->file_len);
 520   if (u2 != NULL
 521       && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
 522       && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
 523       && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
 524     {
 525       unlock_unit (u2);
 526       generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
 527       goto cleanup;
 528     }
 529
 530   if (u2 != NULL)
 531     unlock_unit (u2);
 532
 533   /* If the unit specified is preconnected with a file specified to be open,
 534      then clear the format buffer.  */
 535   if ((opp->common.unit == options.stdin_unit ||
 536        opp->common.unit == options.stdout_unit ||
 537        opp->common.unit == options.stderr_unit)
 538       && (opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
 539     fbuf_destroy (u);
 540
 541   /* Open file.  */
 542
 543   s = open_external (opp, flags);
 544   if (s == NULL)
 545     {
 546       char errbuf[256];
 547       char *path = fc_strdup (opp->file, opp->file_len);
 548       size_t msglen = opp->file_len + 22 + sizeof (errbuf);
 549       char *msg = xmalloc (msglen);
 550       snprintf (msg, msglen, "Cannot open file '%s': %s", path,
 551                 gf_strerror (errno, errbuf, sizeof (errbuf)));
 552       generate_error (&opp->common, LIBERROR_OS, msg);
 553       free (msg);
 554       free (path);
 555       goto cleanup;
 556     }
 557
 558   if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
 559     flags->status = STATUS_OLD;
 560
 561   /* Create the unit structure.  */
 562
 563   if (u->unit_number != opp->common.unit)
 564     internal_error (&opp->common, "Unit number changed");
 565   u->s = s;
 566   u->flags = *flags;
 567   u->read_bad = 0;
 568   u->endfile = NO_ENDFILE;
 569   u->last_record = 0;
 570   u->current_record = 0;
 571   u->mode = READING;
 572   u->maxrec = 0;
 573   u->bytes_left = 0;
 574   u->saved_pos = 0;
 575
 576   if (flags->position == POSITION_APPEND)
 577     {
 578       if (sseek (u->s, 0, SEEK_END) < 0)
 579         {
 580           generate_error (&opp->common, LIBERROR_OS, NULL);
 581           goto cleanup;
 582         }
 583       u->endfile = AT_ENDFILE;
 584     }
 585
 586   /* Unspecified recl ends up with a processor dependent value.  */
 587
 588   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 589     {
 590       u->flags.has_recl = 1;
 591       u->recl = opp->recl_in;
 592       u->recl_subrecord = u->recl;
 593       u->bytes_left = u->recl;
 594     }
 595   else
 596     {
 597       u->flags.has_recl = 0;
 598       u->recl = default_recl;
 599       if (compile_options.max_subrecord_length)
 600         {
 601           u->recl_subrecord = compile_options.max_subrecord_length;
 602         }
 603       else
 604         {
 605           switch (compile_options.record_marker)
 606             {
 607             case 0:
 608               /* Fall through */
 609             case sizeof (GFC_INTEGER_4):
 610               u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
 611               break;
 612
 613             case sizeof (GFC_INTEGER_8):
 614               u->recl_subrecord = max_offset - 16;
 615               break;
 616
 617             default:
 618               runtime_error ("Illegal value for record marker");
 619               break;
 620             }
 621         }
 622     }
 623
 624   /* If the file is direct access, calculate the maximum record number
 625      via a division now instead of letting the multiplication overflow
 626      later.  */
 627
 628   if (flags->access == ACCESS_DIRECT)
 629     u->maxrec = max_offset / u->recl;
 630
 631   if (flags->access == ACCESS_STREAM)
 632     {
 633       u->maxrec = max_offset;
 634       /* F2018 (N2137) 12.10.2.26: If the connection is for stream
 635          access recl is assigned the value -2.  */
 636       u->recl = -2;
 637       u->bytes_left = 1;
 638       u->strm_pos = stell (u->s) + 1;
 639     }
 640
 641   u->filename = fc_strdup (opp->file, opp->file_len);
 642
 643   /* Curiously, the standard requires that the
 644      position specifier be ignored for new files so a newly connected
 645      file starts out at the initial point.  We still need to figure
 646      out if the file is at the end or not.  */
 647
 648   test_endfile (u);
 649
 650   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 651     free (opp->file);
 652
 653   if (flags->form == FORM_FORMATTED)
 654     {
 655       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 656         fbuf_init (u, u->recl);
 657       else
 658         fbuf_init (u, 0);
 659     }
 660   else
 661     u->fbuf = NULL;
 662
 663   /* Check if asynchrounous.  */
 664   if (flags->async == ASYNC_YES)
 665     init_async_unit (u);
 666   else
 667     u->au = NULL;
 668
 669   return u;
 670
 671  cleanup:
 672
 673   /* Free memory associated with a temporary filename.  */
 674
 675   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 676     free (opp->file);
 677
 678  fail:
 679
 680   close_unit (u);
 681   return NULL;
 682 }
 683
 684
 685 /* Open a unit which is already open.  This involves changing the
 686    modes or closing what is there now and opening the new file.  */
 687
 688 static void
 689 already_open (st_parameter_open *opp, gfc_unit *u, unit_flags *flags)
 690 {
 691   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 692     {
 693       edit_modes (opp, u, flags);
 694       return;
 695     }
 696
 697   /* If the file is connected to something else, close it and open a
 698      new unit.  */
 699
 700   if (!compare_file_filename (u, opp->file, opp->file_len))
 701     {
 702       if (sclose (u->s) == -1)
 703         {
 704           unlock_unit (u);
 705           generate_error (&opp->common, LIBERROR_OS,
 706                           "Error closing file in OPEN statement");
 707           return;
 708         }
 709
 710       u->s = NULL;
 711
 712 #if !HAVE_UNLINK_OPEN_FILE
 713       if (u->filename && u->flags.status == STATUS_SCRATCH)
 714         remove (u->filename);
 715 #endif
 716       free (u->filename);
 717       u->filename = NULL;
 718
 719       u = new_unit (opp, u, flags);
 720       if (u != NULL)
 721       unlock_unit (u);
 722       return;
 723     }
 724
 725   edit_modes (opp, u, flags);
 726 }
 727
 728
 729 /* Open file.  */
 730
 731 extern void st_open (st_parameter_open *opp);
 732 export_proto(st_open);
 733
 734 void
 735 st_open (st_parameter_open *opp)
 736 {
 737   unit_flags flags;
 738   gfc_unit *u = NULL;
 739   GFC_INTEGER_4 cf = opp->common.flags;
 740   unit_convert conv;
 741
 742   library_start (&opp->common);
 743
 744   /* Decode options.  */
 745   flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly;
 746
 747   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 748     find_option (&opp->common, opp->access, opp->access_len,
 749                  access_opt, "Bad ACCESS parameter in OPEN statement");
 750
 751   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 752     find_option (&opp->common, opp->action, opp->action_len,
 753                  action_opt, "Bad ACTION parameter in OPEN statement");
 754
 755   flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED :
 756     find_option (&opp->common, opp->cc, opp->cc_len,
 757                  cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement");
 758
 759   flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED :
 760     find_option (&opp->common, opp->share, opp->share_len,
 761                  share_opt, "Bad SHARE parameter in OPEN statement");
 762
 763   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 764     find_option (&opp->common, opp->blank, opp->blank_len,
 765                  blank_opt, "Bad BLANK parameter in OPEN statement");
 766
 767   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 768     find_option (&opp->common, opp->delim, opp->delim_len,
 769                  delim_opt, "Bad DELIM parameter in OPEN statement");
 770
 771   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 772     find_option (&opp->common, opp->pad, opp->pad_len,
 773                  pad_opt, "Bad PAD parameter in OPEN statement");
 774
 775   flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
 776     find_option (&opp->common, opp->decimal, opp->decimal_len,
 777                  decimal_opt, "Bad DECIMAL parameter in OPEN statement");
 778
 779   flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
 780     find_option (&opp->common, opp->encoding, opp->encoding_len,
 781                  encoding_opt, "Bad ENCODING parameter in OPEN statement");
 782
 783   flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
 784     find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
 785                  async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
 786
 787   flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
 788     find_option (&opp->common, opp->round, opp->round_len,
 789                  round_opt, "Bad ROUND parameter in OPEN statement");
 790
 791   flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
 792     find_option (&opp->common, opp->sign, opp->sign_len,
 793                  sign_opt, "Bad SIGN parameter in OPEN statement");
 794
 795   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 796     find_option (&opp->common, opp->form, opp->form_len,
 797                  form_opt, "Bad FORM parameter in OPEN statement");
 798
 799   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 800     find_option (&opp->common, opp->position, opp->position_len,
 801                  position_opt, "Bad POSITION parameter in OPEN statement");
 802
 803   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 804     find_option (&opp->common, opp->status, opp->status_len,
 805                  status_opt, "Bad STATUS parameter in OPEN statement");
 806
 807   /* First, we check wether the convert flag has been set via environment
 808      variable.  This overrides the convert tag in the open statement.  */
 809
 810   conv = get_unformatted_convert (opp->common.unit);
 811
 812   if (conv == GFC_CONVERT_NONE)
 813     {
 814       /* Nothing has been set by environment variable, check the convert tag.  */
 815       if (cf & IOPARM_OPEN_HAS_CONVERT)
 816         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 817                             convert_opt,
 818                             "Bad CONVERT parameter in OPEN statement");
 819       else
 820         conv = compile_options.convert;
 821     }
 822
 823   switch (conv)
 824     {
 825     case GFC_CONVERT_NATIVE:
 826     case GFC_CONVERT_SWAP:
 827       break;
 828
 829     case GFC_CONVERT_BIG:
 830       conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 831       break;
 832
 833     case GFC_CONVERT_LITTLE:
 834       conv = __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
 835       break;
 836
 837     default:
 838       internal_error (&opp->common, "Illegal value for CONVERT");
 839       break;
 840     }
 841
 842   flags.convert = conv;
 843
 844   if (flags.position != POSITION_UNSPECIFIED
 845       && flags.access == ACCESS_DIRECT)
 846     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 847                     "Cannot use POSITION with direct access files");
 848
 849   if (flags.readonly
 850       && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ)
 851     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 852                     "ACTION conflicts with READONLY in OPEN statement");
 853
 854   if (flags.access == ACCESS_APPEND)
 855     {
 856       if (flags.position != POSITION_UNSPECIFIED
 857           && flags.position != POSITION_APPEND)
 858         generate_error (&opp->common, LIBERROR_BAD_OPTION,
 859                         "Conflicting ACCESS and POSITION flags in"
 860                         " OPEN statement");
 861
 862       notify_std (&opp->common, GFC_STD_GNU,
 863                   "Extension: APPEND as a value for ACCESS in OPEN statement");
 864       flags.access = ACCESS_SEQUENTIAL;
 865       flags.position = POSITION_APPEND;
 866     }
 867
 868   if (flags.position == POSITION_UNSPECIFIED)
 869     flags.position = POSITION_ASIS;
 870
 871   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 872     {
 873       if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
 874         opp->common.unit = newunit_alloc ();
 875       else if (opp->common.unit < 0)
 876         {
 877           u = find_unit (opp->common.unit);
 878           if (u == NULL) /* Negative unit and no NEWUNIT-created unit found.  */
 879             {
 880               generate_error (&opp->common, LIBERROR_BAD_OPTION,
 881                               "Bad unit number in OPEN statement");
 882               library_end ();
 883               return;
 884             }
 885         }
 886
 887       if (u == NULL)
 888         u = find_or_create_unit (opp->common.unit);
 889       if (u->s == NULL)
 890         {
 891           u = new_unit (opp, u, &flags);
 892           if (u != NULL)
 893             unlock_unit (u);
 894         }
 895       else
 896         already_open (opp, u, &flags);
 897     }
 898
 899   if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
 900       && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 901     *opp->newunit = opp->common.unit;
 902
 903   library_end ();
 904 }