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   /* TODO { "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->async != ASYNC_UNSPECIFIED)
 258         u->flags.async = flags->async;
 259       if (flags->round != ROUND_UNSPECIFIED)
 260         u->flags.round = flags->round;
 261       if (flags->sign != SIGN_UNSPECIFIED)
 262         u->flags.sign = flags->sign;
 263     }
 264
 265   /* Reposition the file if necessary.  */
 266
 267   switch (flags->position)
 268     {
 269     case POSITION_UNSPECIFIED:
 270     case POSITION_ASIS:
 271       break;
 272
 273     case POSITION_REWIND:
 274       if (sseek (u->s, 0) == FAILURE)
 275         goto seek_error;
 276
 277       u->current_record = 0;
 278       u->last_record = 0;
 279
 280       test_endfile (u);
 281       break;
 282
 283     case POSITION_APPEND:
 284       if (sseek (u->s, file_length (u->s)) == FAILURE)
 285         goto seek_error;
 286
 287       if (flags->access != ACCESS_STREAM)
 288         u->current_record = 0;
 289
 290       u->endfile = AT_ENDFILE;  /* We are at the end.  */
 291       break;
 292
 293     seek_error:
 294       generate_error (&opp->common, LIBERROR_OS, NULL);
 295       break;
 296     }
 297
 298   unlock_unit (u);
 299 }
 300
 301
 302 /* Open an unused unit.  */
 303
 304 gfc_unit *
 305 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
 306 {
 307   gfc_unit *u2;
 308   stream *s;
 309   char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
 310
 311   /* Change unspecifieds to defaults.  Leave (flags->action ==
 312      ACTION_UNSPECIFIED) alone so open_external() can set it based on
 313      what type of open actually works.  */
 314
 315   if (flags->access == ACCESS_UNSPECIFIED)
 316     flags->access = ACCESS_SEQUENTIAL;
 317
 318   if (flags->form == FORM_UNSPECIFIED)
 319     flags->form = (flags->access == ACCESS_SEQUENTIAL)
 320       ? FORM_FORMATTED : FORM_UNFORMATTED;
 321
 322   if (flags->async == ASYNC_UNSPECIFIED)
 323     flags->async = ASYNC_NO;
 324
 325   if (flags->status == STATUS_UNSPECIFIED)
 326     flags->status = STATUS_UNKNOWN;
 327
 328   /* Checks.  */
 329
 330   if (flags->delim == DELIM_UNSPECIFIED)
 331     flags->delim = DELIM_NONE;
 332   else
 333     {
 334       if (flags->form == FORM_UNFORMATTED)
 335         {
 336           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 337                           "DELIM parameter conflicts with UNFORMATTED form in "
 338                           "OPEN statement");
 339           goto fail;
 340         }
 341     }
 342
 343   if (flags->blank == BLANK_UNSPECIFIED)
 344     flags->blank = BLANK_NULL;
 345   else
 346     {
 347       if (flags->form == FORM_UNFORMATTED)
 348         {
 349           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 350                           "BLANK parameter conflicts with UNFORMATTED form in "
 351                           "OPEN statement");
 352           goto fail;
 353         }
 354     }
 355
 356   if (flags->pad == PAD_UNSPECIFIED)
 357     flags->pad = PAD_YES;
 358   else
 359     {
 360       if (flags->form == FORM_UNFORMATTED)
 361         {
 362           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 363                           "PAD parameter conflicts with UNFORMATTED form in "
 364                           "OPEN statement");
 365           goto fail;
 366         }
 367     }
 368
 369   if (flags->decimal == DECIMAL_UNSPECIFIED)
 370     flags->decimal = DECIMAL_POINT;
 371   else
 372     {
 373       if (flags->form == FORM_UNFORMATTED)
 374         {
 375           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 376                           "DECIMAL parameter conflicts with UNFORMATTED form "
 377                           "in OPEN statement");
 378           goto fail;
 379         }
 380     }
 381
 382   if (flags->encoding == ENCODING_UNSPECIFIED)
 383     flags->encoding = ENCODING_DEFAULT;
 384   else
 385     {
 386       if (flags->form == FORM_UNFORMATTED)
 387         {
 388           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 389                           "ENCODING parameter conflicts with UNFORMATTED form in "
 390                           "OPEN statement");
 391           goto fail;
 392         }
 393     }
 394
 395   /* NB: the value for ROUND when it's not specified by the user does not
 396          have to be PROCESSOR_DEFINED; the standard says that it is
 397          processor dependent, and requires that it is one of the
 398          possible value (see F2003, 9.4.5.13).  */
 399   if (flags->round == ROUND_UNSPECIFIED)
 400     flags->round = ROUND_PROCDEFINED;
 401   else
 402     {
 403       if (flags->form == FORM_UNFORMATTED)
 404         {
 405           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 406                           "ROUND parameter conflicts with UNFORMATTED form in "
 407                           "OPEN statement");
 408           goto fail;
 409         }
 410     }
 411
 412   if (flags->sign == SIGN_UNSPECIFIED)
 413     flags->sign = SIGN_PROCDEFINED;
 414   else
 415     {
 416       if (flags->form == FORM_UNFORMATTED)
 417         {
 418           generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 419                           "SIGN parameter conflicts with UNFORMATTED form in "
 420                           "OPEN statement");
 421           goto fail;
 422         }
 423     }
 424
 425   if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
 426    {
 427      generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
 428                      "ACCESS parameter conflicts with SEQUENTIAL access in "
 429                      "OPEN statement");
 430      goto fail;
 431    }
 432   else
 433    if (flags->position == POSITION_UNSPECIFIED)
 434      flags->position = POSITION_ASIS;
 435
 436   if (flags->access == ACCESS_DIRECT
 437       && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
 438     {
 439       generate_error (&opp->common, LIBERROR_MISSING_OPTION,
 440                       "Missing RECL parameter in OPEN statement");
 441       goto fail;
 442     }
 443
 444   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
 445     {
 446       generate_error (&opp->common, LIBERROR_BAD_OPTION,
 447                       "RECL parameter is non-positive in OPEN statement");
 448       goto fail;
 449     }
 450
 451   switch (flags->status)
 452     {
 453     case STATUS_SCRATCH:
 454       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 455         {
 456           opp->file = NULL;
 457           break;
 458         }
 459
 460       generate_error (&opp->common, LIBERROR_BAD_OPTION,
 461                       "FILE parameter must not be present in OPEN statement");
 462       goto fail;
 463
 464     case STATUS_OLD:
 465     case STATUS_NEW:
 466     case STATUS_REPLACE:
 467     case STATUS_UNKNOWN:
 468       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
 469         break;
 470
 471       opp->file = tmpname;
 472 #ifdef HAVE_SNPRINTF
 473       opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
 474                                (int) opp->common.unit);
 475 #else
 476       opp->file_len = sprintf(opp->file, "fort.%d", (int) opp->common.unit);
 477 #endif
 478       break;
 479
 480     default:
 481       internal_error (&opp->common, "new_unit(): Bad status");
 482     }
 483
 484   /* Make sure the file isn't already open someplace else.
 485      Do not error if opening file preconnected to stdin, stdout, stderr.  */
 486
 487   u2 = NULL;
 488   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
 489     u2 = find_file (opp->file, opp->file_len);
 490   if (u2 != NULL
 491       && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
 492       && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
 493       && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
 494     {
 495       unlock_unit (u2);
 496       generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
 497       goto cleanup;
 498     }
 499
 500   if (u2 != NULL)
 501     unlock_unit (u2);
 502
 503   /* Open file.  */
 504
 505   s = open_external (opp, flags);
 506   if (s == NULL)
 507     {
 508       char *path, *msg;
 509       path = (char *) gfc_alloca (opp->file_len + 1);
 510       msg = (char *) gfc_alloca (opp->file_len + 51);
 511       unpack_filename (path, opp->file, opp->file_len);
 512
 513       switch (errno)
 514         {
 515         case ENOENT:
 516           sprintf (msg, "File '%s' does not exist", path);
 517           break;
 518
 519         case EEXIST:
 520           sprintf (msg, "File '%s' already exists", path);
 521           break;
 522
 523         case EACCES:
 524           sprintf (msg, "Permission denied trying to open file '%s'", path);
 525           break;
 526
 527         case EISDIR:
 528           sprintf (msg, "'%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 = get_mem (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, file_length (u->s)) == FAILURE)
 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->strm_pos = file_position (u->s) + 1;
 615     }
 616
 617   memmove (u->file, opp->file, opp->file_len);
 618   u->file_len = opp->file_len;
 619
 620   /* Curiously, the standard requires that the
 621      position specifier be ignored for new files so a newly connected
 622      file starts out at the initial point.  We still need to figure
 623      out if the file is at the end or not.  */
 624
 625   test_endfile (u);
 626
 627   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 628     free_mem (opp->file);
 629
 630   if (flags->form == FORM_FORMATTED && (flags->action != ACTION_READ))
 631     {
 632       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 633         fbuf_init (u, u->recl);
 634       else
 635         fbuf_init (u, 0);
 636     }
 637   else
 638     u->fbuf = NULL;
 639
 640
 641
 642   return u;
 643
 644  cleanup:
 645
 646   /* Free memory associated with a temporary filename.  */
 647
 648   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 649     free_mem (opp->file);
 650
 651  fail:
 652
 653   close_unit (u);
 654   return NULL;
 655 }
 656
 657
 658 /* Open a unit which is already open.  This involves changing the
 659    modes or closing what is there now and opening the new file.  */
 660
 661 static void
 662 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 663 {
 664   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 665     {
 666       edit_modes (opp, u, flags);
 667       return;
 668     }
 669
 670   /* If the file is connected to something else, close it and open a
 671      new unit.  */
 672
 673   if (!compare_file_filename (u, opp->file, opp->file_len))
 674     {
 675 #if !HAVE_UNLINK_OPEN_FILE
 676       char *path = NULL;
 677       if (u->file && u->flags.status == STATUS_SCRATCH)
 678         {
 679           path = (char *) gfc_alloca (u->file_len + 1);
 680           unpack_filename (path, u->file, u->file_len);
 681         }
 682 #endif
 683
 684       if (sclose (u->s) == FAILURE)
 685         {
 686           unlock_unit (u);
 687           generate_error (&opp->common, LIBERROR_OS,
 688                           "Error closing file in OPEN statement");
 689           return;
 690         }
 691
 692       u->s = NULL;
 693       if (u->file)
 694         free_mem (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 l8_to_l4_offset, 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 = l8_to_l4_offset ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 808       break;
 809
 810     case GFC_CONVERT_LITTLE:
 811       conv = l8_to_l4_offset ? 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.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       u = find_or_create_unit (opp->common.unit);
 850
 851       if (u->s == NULL)
 852         {
 853           u = new_unit (opp, u, &flags);
 854           if (u != NULL)
 855             unlock_unit (u);
 856         }
 857       else
 858         already_open (opp, u, &flags);
 859     }
 860
 861   library_end ();
 862 }