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)
 156     {
 157       gfc_offset sz = ssize (u->s);
 158       if (sz == 0 || sz == stell (u->s))
 159         u->endfile = AT_ENDFILE;
 160     }
 161 }
 162
 163
 164 /* Change the modes of a file, those that are allowed * to be
 165    changed.  */
 166
 167 static void
 168 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 169 {
 170   /* Complain about attempts to change the unchangeable.  */
 171
 172   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
 173       u->flags.status != flags->status)
 174     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 175                     "Cannot change STATUS parameter in OPEN statement");
 176
 177   if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
 178     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 179                     "Cannot change ACCESS parameter in OPEN statement");
 180
 181   if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
 182     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 183                     "Cannot change FORM parameter in OPEN statement");
 184
 185   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
 186       && opp->recl_in != u->recl)
 187     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 188                     "Cannot change RECL parameter in OPEN statement");
 189
 190   if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
 191     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 192                     "Cannot change ACTION parameter in OPEN statement");
 193
 194   /* Status must be OLD if present.  */
 195
 196   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
 197       flags->status != STATUS_UNKNOWN)
 198     {
 199       if (flags->status == STATUS_SCRATCH)
 200         notify_std (&opp->common, GFC_STD_GNU,
 201                     "OPEN statement must have a STATUS of OLD or UNKNOWN");
 202       else
 203         generate_error (&opp->common, LIBERROR_BAD_OPTION,
 204                     "OPEN statement must have a STATUS of OLD or UNKNOWN");
 205     }
 206
 207   if (u->flags.form == FORM_UNFORMATTED)
 208     {
 209       if (flags->delim != DELIM_UNSPECIFIED)
 210         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 211                         "DELIM parameter conflicts with UNFORMATTED form in "
 212                         "OPEN statement");
 213
 214       if (flags->blank != BLANK_UNSPECIFIED)
 215         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 216                         "BLANK parameter conflicts with UNFORMATTED form in "
 217                         "OPEN statement");
 218
 219       if (flags->pad != PAD_UNSPECIFIED)
 220         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 221                         "PAD parameter conflicts with UNFORMATTED form in "
 222                         "OPEN statement");
 223
 224       if (flags->decimal != DECIMAL_UNSPECIFIED)
 225         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 226                         "DECIMAL parameter conflicts with UNFORMATTED form in "
 227                         "OPEN statement");
 228
 229       if (flags->encoding != ENCODING_UNSPECIFIED)
 230         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 231                         "ENCODING parameter conflicts with UNFORMATTED form in "
 232                         "OPEN statement");
 233
 234       if (flags->round != ROUND_UNSPECIFIED)
 235         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 236                         "ROUND parameter conflicts with UNFORMATTED form in "
 237                         "OPEN statement");
 238
 239       if (flags->sign != SIGN_UNSPECIFIED)
 240         generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 241                         "SIGN parameter conflicts with UNFORMATTED form in "
 242                         "OPEN statement");
 243     }
 244
 245   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 246     {
 247       /* Change the changeable:  */
 248       if (flags->blank != BLANK_UNSPECIFIED)
 249         u->flags.blank = flags->blank;
 250       if (flags->delim != DELIM_UNSPECIFIED)
 251         u->flags.delim = flags->delim;
 252       if (flags->pad != PAD_UNSPECIFIED)
 253         u->flags.pad = flags->pad;
 254       if (flags->decimal != DECIMAL_UNSPECIFIED)
 255         u->flags.decimal = flags->decimal;
 256       if (flags->encoding != ENCODING_UNSPECIFIED)
 257         u->flags.encoding = flags->encoding;
 258       if (flags->async != ASYNC_UNSPECIFIED)
 259         u->flags.async = flags->async;
 260       if (flags->round != ROUND_UNSPECIFIED)
 261         u->flags.round = flags->round;
 262       if (flags->sign != SIGN_UNSPECIFIED)
 263         u->flags.sign = flags->sign;
 264     }
 265
 266   /* Reposition the file if necessary.  */
 267
 268   switch (flags->position)
 269     {
 270     case POSITION_UNSPECIFIED:
 271     case POSITION_ASIS:
 272       break;
 273
 274     case POSITION_REWIND:
 275       if (sseek (u->s, 0, SEEK_SET) != 0)
 276         goto seek_error;
 277
 278       u->current_record = 0;
 279       u->last_record = 0;
 280
 281       test_endfile (u);
 282       break;
 283
 284     case POSITION_APPEND:
 285       if (sseek (u->s, 0, SEEK_END) < 0)
 286         goto seek_error;
 287
 288       if (flags->access != ACCESS_STREAM)
 289         u->current_record = 0;
 290
 291       u->endfile = AT_ENDFILE;  /* We are at the end.  */
 292       break;
 293
 294     seek_error:
 295       generate_error (&opp->common, LIBERROR_OS, NULL);
 296       break;
 297     }
 298
 299   unlock_unit (u);
 300 }
 301
 302
 303 /* Open an unused unit.  */
 304
 305 gfc_unit *
 306 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
 307 {
 308   gfc_unit *u2;
 309   stream *s;
 310   char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
 311
 312   /* Change unspecifieds to defaults.  Leave (flags->action ==
 313      ACTION_UNSPECIFIED) alone so open_external() can set it based on
 314      what type of open actually works.  */
 315
 316   if (flags->access == ACCESS_UNSPECIFIED)
 317     flags->access = ACCESS_SEQUENTIAL;
 318
 319   if (flags->form == FORM_UNSPECIFIED)
 320     flags->form = (flags->access == ACCESS_SEQUENTIAL)
 321       ? FORM_FORMATTED : FORM_UNFORMATTED;
 322
 323   if (flags->async == ASYNC_UNSPECIFIED)
 324     flags->async = ASYNC_NO;
 325
 326   if (flags->status == STATUS_UNSPECIFIED)
 327     flags->status = STATUS_UNKNOWN;
 328
 329   /* Checks.  */
 330
 331   if (flags->delim == DELIM_UNSPECIFIED)
 332     flags->delim = DELIM_NONE;
 333   else
 334     {
 335       if (flags->form == FORM_UNFORMATTED)
 336         {
 337           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 338                           "DELIM parameter conflicts with UNFORMATTED form in "
 339                           "OPEN statement");
 340           goto fail;
 341         }
 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         generate_error (&opp->common, LIBERROR_OS, NULL);
 562       u->endfile = AT_ENDFILE;
 563     }
 564
 565   /* Unspecified recl ends up with a processor dependent value.  */
 566
 567   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 568     {
 569       u->flags.has_recl = 1;
 570       u->recl = opp->recl_in;
 571       u->recl_subrecord = u->recl;
 572       u->bytes_left = u->recl;
 573     }
 574   else
 575     {
 576       u->flags.has_recl = 0;
 577       u->recl = max_offset;
 578       if (compile_options.max_subrecord_length)
 579         {
 580           u->recl_subrecord = compile_options.max_subrecord_length;
 581         }
 582       else
 583         {
 584           switch (compile_options.record_marker)
 585             {
 586             case 0:
 587               /* Fall through */
 588             case sizeof (GFC_INTEGER_4):
 589               u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
 590               break;
 591
 592             case sizeof (GFC_INTEGER_8):
 593               u->recl_subrecord = max_offset - 16;
 594               break;
 595
 596             default:
 597               runtime_error ("Illegal value for record marker");
 598               break;
 599             }
 600         }
 601     }
 602
 603   /* If the file is direct access, calculate the maximum record number
 604      via a division now instead of letting the multiplication overflow
 605      later.  */
 606
 607   if (flags->access == ACCESS_DIRECT)
 608     u->maxrec = max_offset / u->recl;
 609
 610   if (flags->access == ACCESS_STREAM)
 611     {
 612       u->maxrec = max_offset;
 613       u->recl = 1;
 614       u->bytes_left = 1;
 615       u->strm_pos = stell (u->s) + 1;
 616     }
 617
 618   memmove (u->file, opp->file, opp->file_len);
 619   u->file_len = opp->file_len;
 620
 621   /* Curiously, the standard requires that the
 622      position specifier be ignored for new files so a newly connected
 623      file starts out at the initial point.  We still need to figure
 624      out if the file is at the end or not.  */
 625
 626   test_endfile (u);
 627
 628   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 629     free (opp->file);
 630
 631   if (flags->form == FORM_FORMATTED)
 632     {
 633       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 634         fbuf_init (u, u->recl);
 635       else
 636         fbuf_init (u, 0);
 637     }
 638   else
 639     u->fbuf = NULL;
 640
 641
 642
 643   return u;
 644
 645  cleanup:
 646
 647   /* Free memory associated with a temporary filename.  */
 648
 649   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 650     free (opp->file);
 651
 652  fail:
 653
 654   close_unit (u);
 655   return NULL;
 656 }
 657
 658
 659 /* Open a unit which is already open.  This involves changing the
 660    modes or closing what is there now and opening the new file.  */
 661
 662 static void
 663 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 664 {
 665   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 666     {
 667       edit_modes (opp, u, flags);
 668       return;
 669     }
 670
 671   /* If the file is connected to something else, close it and open a
 672      new unit.  */
 673
 674   if (!compare_file_filename (u, opp->file, opp->file_len))
 675     {
 676 #if !HAVE_UNLINK_OPEN_FILE
 677       char *path = NULL;
 678       if (u->file && u->flags.status == STATUS_SCRATCH)
 679         {
 680           path = (char *) gfc_alloca (u->file_len + 1);
 681           unpack_filename (path, u->file, u->file_len);
 682         }
 683 #endif
 684
 685       if (sclose (u->s) == -1)
 686         {
 687           unlock_unit (u);
 688           generate_error (&opp->common, LIBERROR_OS,
 689                           "Error closing file in OPEN statement");
 690           return;
 691         }
 692
 693       u->s = NULL;
 694       free (u->file);
 695       u->file = NULL;
 696       u->file_len = 0;
 697
 698 #if !HAVE_UNLINK_OPEN_FILE
 699       if (path != NULL)
 700         unlink (path);
 701 #endif
 702
 703       u = new_unit (opp, u, flags);
 704       if (u != NULL)
 705         unlock_unit (u);
 706       return;
 707     }
 708
 709   edit_modes (opp, u, flags);
 710 }
 711
 712
 713 /* Open file.  */
 714
 715 extern void st_open (st_parameter_open *opp);
 716 export_proto(st_open);
 717
 718 void
 719 st_open (st_parameter_open *opp)
 720 {
 721   unit_flags flags;
 722   gfc_unit *u = NULL;
 723   GFC_INTEGER_4 cf = opp->common.flags;
 724   unit_convert conv;
 725
 726   library_start (&opp->common);
 727
 728   /* Decode options.  */
 729
 730   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 731     find_option (&opp->common, opp->access, opp->access_len,
 732                  access_opt, "Bad ACCESS parameter in OPEN statement");
 733
 734   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 735     find_option (&opp->common, opp->action, opp->action_len,
 736                  action_opt, "Bad ACTION parameter in OPEN statement");
 737
 738   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 739     find_option (&opp->common, opp->blank, opp->blank_len,
 740                  blank_opt, "Bad BLANK parameter in OPEN statement");
 741
 742   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 743     find_option (&opp->common, opp->delim, opp->delim_len,
 744                  delim_opt, "Bad DELIM parameter in OPEN statement");
 745
 746   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 747     find_option (&opp->common, opp->pad, opp->pad_len,
 748                  pad_opt, "Bad PAD parameter in OPEN statement");
 749
 750   flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
 751     find_option (&opp->common, opp->decimal, opp->decimal_len,
 752                  decimal_opt, "Bad DECIMAL parameter in OPEN statement");
 753
 754   flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
 755     find_option (&opp->common, opp->encoding, opp->encoding_len,
 756                  encoding_opt, "Bad ENCODING parameter in OPEN statement");
 757
 758   flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
 759     find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
 760                  async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
 761
 762   flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
 763     find_option (&opp->common, opp->round, opp->round_len,
 764                  round_opt, "Bad ROUND parameter in OPEN statement");
 765
 766   flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
 767     find_option (&opp->common, opp->sign, opp->sign_len,
 768                  sign_opt, "Bad SIGN parameter in OPEN statement");
 769
 770   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 771     find_option (&opp->common, opp->form, opp->form_len,
 772                  form_opt, "Bad FORM parameter in OPEN statement");
 773
 774   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 775     find_option (&opp->common, opp->position, opp->position_len,
 776                  position_opt, "Bad POSITION parameter in OPEN statement");
 777
 778   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 779     find_option (&opp->common, opp->status, opp->status_len,
 780                  status_opt, "Bad STATUS parameter in OPEN statement");
 781
 782   /* First, we check wether the convert flag has been set via environment
 783      variable.  This overrides the convert tag in the open statement.  */
 784
 785   conv = get_unformatted_convert (opp->common.unit);
 786
 787   if (conv == GFC_CONVERT_NONE)
 788     {
 789       /* Nothing has been set by environment variable, check the convert tag.  */
 790       if (cf & IOPARM_OPEN_HAS_CONVERT)
 791         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 792                             convert_opt,
 793                             "Bad CONVERT parameter in OPEN statement");
 794       else
 795         conv = compile_options.convert;
 796     }
 797
 798   /* We use big_endian, which is 0 on little-endian machines
 799      and 1 on big-endian machines.  */
 800   switch (conv)
 801     {
 802     case GFC_CONVERT_NATIVE:
 803     case GFC_CONVERT_SWAP:
 804       break;
 805
 806     case GFC_CONVERT_BIG:
 807       conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 808       break;
 809
 810     case GFC_CONVERT_LITTLE:
 811       conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
 812       break;
 813
 814     default:
 815       internal_error (&opp->common, "Illegal value for CONVERT");
 816       break;
 817     }
 818
 819   flags.convert = conv;
 820
 821   if (!(opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && opp->common.unit < 0)
 822     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 823                     "Bad unit number in OPEN statement");
 824
 825   if (flags.position != POSITION_UNSPECIFIED
 826       && flags.access == ACCESS_DIRECT)
 827     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 828                     "Cannot use POSITION with direct access files");
 829
 830   if (flags.access == ACCESS_APPEND)
 831     {
 832       if (flags.position != POSITION_UNSPECIFIED
 833           && flags.position != POSITION_APPEND)
 834         generate_error (&opp->common, LIBERROR_BAD_OPTION,
 835                         "Conflicting ACCESS and POSITION flags in"
 836                         " OPEN statement");
 837
 838       notify_std (&opp->common, GFC_STD_GNU,
 839                   "Extension: APPEND as a value for ACCESS in OPEN statement");
 840       flags.access = ACCESS_SEQUENTIAL;
 841       flags.position = POSITION_APPEND;
 842     }
 843
 844   if (flags.position == POSITION_UNSPECIFIED)
 845     flags.position = POSITION_ASIS;
 846
 847   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 848     {
 849       if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
 850         opp->common.unit = get_unique_unit_number(opp);
 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   if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
 864       && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 865     *opp->newunit = opp->common.unit;
 866
 867   library_end ();
 868 }