libgfortran/io/open.c

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