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