libgfortran/io/open.c

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