libgfortran/io/open.c

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