libgfortran/io/open.c

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