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