libgfortran/io/open.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
   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 && file_length (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 #ifdef HAVE_SNPRINTF
 471       opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
 472                                (int) opp->common.unit);
 473 #else
 474       opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
 475 #endif
 476       break;
 477
 478     default:
 479       internal_error (&opp->common, "new_unit(): Bad status");
 480     }
 481
 482   /* Make sure the file isn't already open someplace else.
 483      Do not error if opening file preconnected to stdin, stdout, stderr.  */
 484
 485   u2 = NULL;
 486   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
 487     u2 = find_file (opp->file, opp->file_len);
 488   if (u2 != NULL
 489       && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
 490       && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
 491       && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
 492     {
 493       unlock_unit (u2);
 494       generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
 495       goto cleanup;
 496     }
 497
 498   if (u2 != NULL)
 499     unlock_unit (u2);
 500
 501   /* Open file.  */
 502
 503   s = open_external (opp, flags);
 504   if (s == NULL)
 505     {
 506       char *path, *msg;
 507       path = (char *) gfc_alloca (opp->file_len + 1);
 508       msg = (char *) gfc_alloca (opp->file_len + 51);
 509       unpack_filename (path, opp->file, opp->file_len);
 510
 511       switch (errno)
 512         {
 513         case ENOENT:
 514           sprintf (msg, "File '%s' does not exist", path);
 515           break;
 516
 517         case EEXIST:
 518           sprintf (msg, "File '%s' already exists", path);
 519           break;
 520
 521         case EACCES:
 522           sprintf (msg, "Permission denied trying to open file '%s'", path);
 523           break;
 524
 525         case EISDIR:
 526           sprintf (msg, "'%s' is a directory", path);
 527           break;
 528
 529         default:
 530           msg = NULL;
 531         }
 532
 533       generate_error (&opp->common, LIBERROR_OS, msg);
 534       goto cleanup;
 535     }
 536
 537   if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
 538     flags->status = STATUS_OLD;
 539
 540   /* Create the unit structure.  */
 541
 542   u->file = get_mem (opp->file_len);
 543   if (u->unit_number != opp->common.unit)
 544     internal_error (&opp->common, "Unit number changed");
 545   u->s = s;
 546   u->flags = *flags;
 547   u->read_bad = 0;
 548   u->endfile = NO_ENDFILE;
 549   u->last_record = 0;
 550   u->current_record = 0;
 551   u->mode = READING;
 552   u->maxrec = 0;
 553   u->bytes_left = 0;
 554   u->saved_pos = 0;
 555
 556   if (flags->position == POSITION_APPEND)
 557     {
 558       if (file_size (opp->file, opp->file_len) > 0 && sseek (u->s, 0, SEEK_END) < 0)
 559         generate_error (&opp->common, LIBERROR_OS, NULL);
 560       u->endfile = AT_ENDFILE;
 561     }
 562
 563   /* Unspecified recl ends up with a processor dependent value.  */
 564
 565   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 566     {
 567       u->flags.has_recl = 1;
 568       u->recl = opp->recl_in;
 569       u->recl_subrecord = u->recl;
 570       u->bytes_left = u->recl;
 571     }
 572   else
 573     {
 574       u->flags.has_recl = 0;
 575       u->recl = max_offset;
 576       if (compile_options.max_subrecord_length)
 577         {
 578           u->recl_subrecord = compile_options.max_subrecord_length;
 579         }
 580       else
 581         {
 582           switch (compile_options.record_marker)
 583             {
 584             case 0:
 585               /* Fall through */
 586             case sizeof (GFC_INTEGER_4):
 587               u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
 588               break;
 589
 590             case sizeof (GFC_INTEGER_8):
 591               u->recl_subrecord = max_offset - 16;
 592               break;
 593
 594             default:
 595               runtime_error ("Illegal value for record marker");
 596               break;
 597             }
 598         }
 599     }
 600
 601   /* If the file is direct access, calculate the maximum record number
 602      via a division now instead of letting the multiplication overflow
 603      later.  */
 604
 605   if (flags->access == ACCESS_DIRECT)
 606     u->maxrec = max_offset / u->recl;
 607
 608   if (flags->access == ACCESS_STREAM)
 609     {
 610       u->maxrec = max_offset;
 611       u->recl = 1;
 612       u->bytes_left = 1;
 613       u->strm_pos = stell (u->s) + 1;
 614     }
 615
 616   memmove (u->file, opp->file, opp->file_len);
 617   u->file_len = opp->file_len;
 618
 619   /* Curiously, the standard requires that the
 620      position specifier be ignored for new files so a newly connected
 621      file starts out at the initial point.  We still need to figure
 622      out if the file is at the end or not.  */
 623
 624   test_endfile (u);
 625
 626   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 627     free (opp->file);
 628
 629   if (flags->form == FORM_FORMATTED)
 630     {
 631       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 632         fbuf_init (u, u->recl);
 633       else
 634         fbuf_init (u, 0);
 635     }
 636   else
 637     u->fbuf = NULL;
 638
 639
 640
 641   return u;
 642
 643  cleanup:
 644
 645   /* Free memory associated with a temporary filename.  */
 646
 647   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 648     free (opp->file);
 649
 650  fail:
 651
 652   close_unit (u);
 653   return NULL;
 654 }
 655
 656
 657 /* Open a unit which is already open.  This involves changing the
 658    modes or closing what is there now and opening the new file.  */
 659
 660 static void
 661 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 662 {
 663   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 664     {
 665       edit_modes (opp, u, flags);
 666       return;
 667     }
 668
 669   /* If the file is connected to something else, close it and open a
 670      new unit.  */
 671
 672   if (!compare_file_filename (u, opp->file, opp->file_len))
 673     {
 674 #if !HAVE_UNLINK_OPEN_FILE
 675       char *path = NULL;
 676       if (u->file && u->flags.status == STATUS_SCRATCH)
 677         {
 678           path = (char *) gfc_alloca (u->file_len + 1);
 679           unpack_filename (path, u->file, u->file_len);
 680         }
 681 #endif
 682
 683       if (sclose (u->s) == -1)
 684         {
 685           unlock_unit (u);
 686           generate_error (&opp->common, LIBERROR_OS,
 687                           "Error closing file in OPEN statement");
 688           return;
 689         }
 690
 691       u->s = NULL;
 692       if (u->file)
 693         free (u->file);
 694       u->file = NULL;
 695       u->file_len = 0;
 696
 697 #if !HAVE_UNLINK_OPEN_FILE
 698       if (path != NULL)
 699         unlink (path);
 700 #endif
 701
 702       u = new_unit (opp, u, flags);
 703       if (u != NULL)
 704         unlock_unit (u);
 705       return;
 706     }
 707
 708   edit_modes (opp, u, flags);
 709 }
 710
 711
 712 /* Open file.  */
 713
 714 extern void st_open (st_parameter_open *opp);
 715 export_proto(st_open);
 716
 717 void
 718 st_open (st_parameter_open *opp)
 719 {
 720   unit_flags flags;
 721   gfc_unit *u = NULL;
 722   GFC_INTEGER_4 cf = opp->common.flags;
 723   unit_convert conv;
 724
 725   library_start (&opp->common);
 726
 727   /* Decode options.  */
 728
 729   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 730     find_option (&opp->common, opp->access, opp->access_len,
 731                  access_opt, "Bad ACCESS parameter in OPEN statement");
 732
 733   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 734     find_option (&opp->common, opp->action, opp->action_len,
 735                  action_opt, "Bad ACTION parameter in OPEN statement");
 736
 737   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 738     find_option (&opp->common, opp->blank, opp->blank_len,
 739                  blank_opt, "Bad BLANK parameter in OPEN statement");
 740
 741   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 742     find_option (&opp->common, opp->delim, opp->delim_len,
 743                  delim_opt, "Bad DELIM parameter in OPEN statement");
 744
 745   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 746     find_option (&opp->common, opp->pad, opp->pad_len,
 747                  pad_opt, "Bad PAD parameter in OPEN statement");
 748
 749   flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
 750     find_option (&opp->common, opp->decimal, opp->decimal_len,
 751                  decimal_opt, "Bad DECIMAL parameter in OPEN statement");
 752
 753   flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
 754     find_option (&opp->common, opp->encoding, opp->encoding_len,
 755                  encoding_opt, "Bad ENCODING parameter in OPEN statement");
 756
 757   flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
 758     find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
 759                  async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
 760
 761   flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
 762     find_option (&opp->common, opp->round, opp->round_len,
 763                  round_opt, "Bad ROUND parameter in OPEN statement");
 764
 765   flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
 766     find_option (&opp->common, opp->sign, opp->sign_len,
 767                  sign_opt, "Bad SIGN parameter in OPEN statement");
 768
 769   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 770     find_option (&opp->common, opp->form, opp->form_len,
 771                  form_opt, "Bad FORM parameter in OPEN statement");
 772
 773   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 774     find_option (&opp->common, opp->position, opp->position_len,
 775                  position_opt, "Bad POSITION parameter in OPEN statement");
 776
 777   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 778     find_option (&opp->common, opp->status, opp->status_len,
 779                  status_opt, "Bad STATUS parameter in OPEN statement");
 780
 781   /* First, we check wether the convert flag has been set via environment
 782      variable.  This overrides the convert tag in the open statement.  */
 783
 784   conv = get_unformatted_convert (opp->common.unit);
 785
 786   if (conv == GFC_CONVERT_NONE)
 787     {
 788       /* Nothing has been set by environment variable, check the convert tag.  */
 789       if (cf & IOPARM_OPEN_HAS_CONVERT)
 790         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 791                             convert_opt,
 792                             "Bad CONVERT parameter in OPEN statement");
 793       else
 794         conv = compile_options.convert;
 795     }
 796
 797   /* We use big_endian, which is 0 on little-endian machines
 798      and 1 on big-endian machines.  */
 799   switch (conv)
 800     {
 801     case GFC_CONVERT_NATIVE:
 802     case GFC_CONVERT_SWAP:
 803       break;
 804
 805     case GFC_CONVERT_BIG:
 806       conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 807       break;
 808
 809     case GFC_CONVERT_LITTLE:
 810       conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
 811       break;
 812
 813     default:
 814       internal_error (&opp->common, "Illegal value for CONVERT");
 815       break;
 816     }
 817
 818   flags.convert = conv;
 819
 820   if (!(opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT) && opp->common.unit < 0)
 821     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 822                     "Bad unit number in OPEN statement");
 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         {
 850           *opp->newunit = get_unique_unit_number(opp);
 851           opp->common.unit = *opp->newunit;
 852         }
 853
 854       u = find_or_create_unit (opp->common.unit);
 855       if (u->s == NULL)
 856         {
 857           u = new_unit (opp, u, &flags);
 858           if (u != NULL)
 859             unlock_unit (u);
 860         }
 861       else
 862         already_open (opp, u, &flags);
 863     }
 864
 865   library_end ();
 866 }