libgfortran/io/open.c

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