libgfortran/io/open.c

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