libgfortran/io/open.c

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