libgfortran/io/open.c

   1 /* Copyright (C) 2002-2017 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 = max_offset;
 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       u->recl = 1;
 626       u->bytes_left = 1;
 627       u->strm_pos = stell (u->s) + 1;
 628     }
 629
 630   u->filename = fc_strdup (opp->file, opp->file_len);
 631
 632   /* Curiously, the standard requires that the
 633      position specifier be ignored for new files so a newly connected
 634      file starts out at the initial point.  We still need to figure
 635      out if the file is at the end or not.  */
 636
 637   test_endfile (u);
 638
 639   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 640     free (opp->file);
 641
 642   if (flags->form == FORM_FORMATTED)
 643     {
 644       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 645         fbuf_init (u, u->recl);
 646       else
 647         fbuf_init (u, 0);
 648     }
 649   else
 650     u->fbuf = NULL;
 651
 652
 653
 654   return u;
 655
 656  cleanup:
 657
 658   /* Free memory associated with a temporary filename.  */
 659
 660   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 661     free (opp->file);
 662
 663  fail:
 664
 665   close_unit (u);
 666   return NULL;
 667 }
 668
 669
 670 /* Open a unit which is already open.  This involves changing the
 671    modes or closing what is there now and opening the new file.  */
 672
 673 static void
 674 already_open (st_parameter_open *opp, gfc_unit *u, unit_flags *flags)
 675 {
 676   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 677     {
 678       edit_modes (opp, u, flags);
 679       return;
 680     }
 681
 682   /* If the file is connected to something else, close it and open a
 683      new unit.  */
 684
 685   if (!compare_file_filename (u, opp->file, opp->file_len))
 686     {
 687       if (sclose (u->s) == -1)
 688         {
 689           unlock_unit (u);
 690           generate_error (&opp->common, LIBERROR_OS,
 691                           "Error closing file in OPEN statement");
 692           return;
 693         }
 694
 695       u->s = NULL;
 696
 697 #if !HAVE_UNLINK_OPEN_FILE
 698       if (u->filename && u->flags.status == STATUS_SCRATCH)
 699         remove (u->filename);
 700 #endif
 701      free (u->filename);
 702      u->filename = NULL;
 703
 704       u = new_unit (opp, u, flags);
 705       if (u != NULL)
 706         unlock_unit (u);
 707       return;
 708     }
 709
 710   edit_modes (opp, u, flags);
 711 }
 712
 713
 714 /* Open file.  */
 715
 716 extern void st_open (st_parameter_open *opp);
 717 export_proto(st_open);
 718
 719 void
 720 st_open (st_parameter_open *opp)
 721 {
 722   unit_flags flags;
 723   gfc_unit *u = NULL;
 724   GFC_INTEGER_4 cf = opp->common.flags;
 725   unit_convert conv;
 726
 727   library_start (&opp->common);
 728
 729   /* Decode options.  */
 730   flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly;
 731
 732   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 733     find_option (&opp->common, opp->access, opp->access_len,
 734                  access_opt, "Bad ACCESS parameter in OPEN statement");
 735
 736   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 737     find_option (&opp->common, opp->action, opp->action_len,
 738                  action_opt, "Bad ACTION parameter in OPEN statement");
 739
 740   flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED :
 741     find_option (&opp->common, opp->cc, opp->cc_len,
 742                  cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement");
 743
 744   flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED :
 745     find_option (&opp->common, opp->share, opp->share_len,
 746                  share_opt, "Bad SHARE parameter in OPEN statement");
 747
 748   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 749     find_option (&opp->common, opp->blank, opp->blank_len,
 750                  blank_opt, "Bad BLANK parameter in OPEN statement");
 751
 752   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 753     find_option (&opp->common, opp->delim, opp->delim_len,
 754                  delim_opt, "Bad DELIM parameter in OPEN statement");
 755
 756   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 757     find_option (&opp->common, opp->pad, opp->pad_len,
 758                  pad_opt, "Bad PAD parameter in OPEN statement");
 759
 760   flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
 761     find_option (&opp->common, opp->decimal, opp->decimal_len,
 762                  decimal_opt, "Bad DECIMAL parameter in OPEN statement");
 763
 764   flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
 765     find_option (&opp->common, opp->encoding, opp->encoding_len,
 766                  encoding_opt, "Bad ENCODING parameter in OPEN statement");
 767
 768   flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
 769     find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
 770                  async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
 771
 772   flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
 773     find_option (&opp->common, opp->round, opp->round_len,
 774                  round_opt, "Bad ROUND parameter in OPEN statement");
 775
 776   flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
 777     find_option (&opp->common, opp->sign, opp->sign_len,
 778                  sign_opt, "Bad SIGN parameter in OPEN statement");
 779
 780   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 781     find_option (&opp->common, opp->form, opp->form_len,
 782                  form_opt, "Bad FORM parameter in OPEN statement");
 783
 784   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 785     find_option (&opp->common, opp->position, opp->position_len,
 786                  position_opt, "Bad POSITION parameter in OPEN statement");
 787
 788   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 789     find_option (&opp->common, opp->status, opp->status_len,
 790                  status_opt, "Bad STATUS parameter in OPEN statement");
 791
 792   /* First, we check wether the convert flag has been set via environment
 793      variable.  This overrides the convert tag in the open statement.  */
 794
 795   conv = get_unformatted_convert (opp->common.unit);
 796
 797   if (conv == GFC_CONVERT_NONE)
 798     {
 799       /* Nothing has been set by environment variable, check the convert tag.  */
 800       if (cf & IOPARM_OPEN_HAS_CONVERT)
 801         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 802                             convert_opt,
 803                             "Bad CONVERT parameter in OPEN statement");
 804       else
 805         conv = compile_options.convert;
 806     }
 807
 808   /* We use big_endian, which is 0 on little-endian machines
 809      and 1 on big-endian machines.  */
 810   switch (conv)
 811     {
 812     case GFC_CONVERT_NATIVE:
 813     case GFC_CONVERT_SWAP:
 814       break;
 815
 816     case GFC_CONVERT_BIG:
 817       conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 818       break;
 819
 820     case GFC_CONVERT_LITTLE:
 821       conv = 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 }