libgfortran/io/open.c

   1 /* Copyright (C) 2002-2016 Free Software Foundation, Inc.
   2    Contributed by Andy Vaught
   3    F2003 I/O support contributed by Jerry DeLisle
   4
   5 This file is part of the GNU Fortran runtime library (libgfortran).
   6
   7 Libgfortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 3, or (at your option)
  10 any later version.
  11
  12 Libgfortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 Under Section 7 of GPL version 3, you are granted additional
  18 permissions described in the GCC Runtime Library Exception, version
  19 3.1, as published by the Free Software Foundation.
  20
  21 You should have received a copy of the GNU General Public License and
  22 a copy of the GCC Runtime Library Exception along with this program;
  23 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  24 <http://www.gnu.org/licenses/>.  */
  25
  26 #include "io.h"
  27 #include "fbuf.h"
  28 #include "unix.h"
  29
  30 #ifdef HAVE_UNISTD_H
  31 #include <unistd.h>
  32 #endif
  33
  34 #include <string.h>
  35 #include <errno.h>
  36 #include <stdlib.h>
  37
  38
  39 static const st_option access_opt[] = {
  40   {"sequential", ACCESS_SEQUENTIAL},
  41   {"direct", ACCESS_DIRECT},
  42   {"append", ACCESS_APPEND},
  43   {"stream", ACCESS_STREAM},
  44   {NULL, 0}
  45 };
  46
  47 static const st_option action_opt[] =
  48 {
  49   { "read", ACTION_READ},
  50   { "write", ACTION_WRITE},
  51   { "readwrite", ACTION_READWRITE},
  52   { NULL, 0}
  53 };
  54
  55 static const st_option 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 = max_offset;
 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       u->recl = 1;
 627       u->bytes_left = 1;
 628       u->strm_pos = stell (u->s) + 1;
 629     }
 630
 631   u->filename = fc_strdup (opp->file, opp->file_len);
 632
 633   /* Curiously, the standard requires that the
 634      position specifier be ignored for new files so a newly connected
 635      file starts out at the initial point.  We still need to figure
 636      out if the file is at the end or not.  */
 637
 638   test_endfile (u);
 639
 640   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 641     free (opp->file);
 642
 643   if (flags->form == FORM_FORMATTED)
 644     {
 645       if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 646         fbuf_init (u, u->recl);
 647       else
 648         fbuf_init (u, 0);
 649     }
 650   else
 651     u->fbuf = NULL;
 652
 653
 654
 655   return u;
 656
 657  cleanup:
 658
 659   /* Free memory associated with a temporary filename.  */
 660
 661   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 662     free (opp->file);
 663
 664  fail:
 665
 666   close_unit (u);
 667   return NULL;
 668 }
 669
 670
 671 /* Open a unit which is already open.  This involves changing the
 672    modes or closing what is there now and opening the new file.  */
 673
 674 static void
 675 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 676 {
 677   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 678     {
 679       edit_modes (opp, u, flags);
 680       return;
 681     }
 682
 683   /* If the file is connected to something else, close it and open a
 684      new unit.  */
 685
 686   if (!compare_file_filename (u, opp->file, opp->file_len))
 687     {
 688       if (sclose (u->s) == -1)
 689         {
 690           unlock_unit (u);
 691           generate_error (&opp->common, LIBERROR_OS,
 692                           "Error closing file in OPEN statement");
 693           return;
 694         }
 695
 696       u->s = NULL;
 697
 698 #if !HAVE_UNLINK_OPEN_FILE
 699       if (u->filename && u->flags.status == STATUS_SCRATCH)
 700         remove (u->filename);
 701 #endif
 702      free (u->filename);
 703      u->filename = NULL;
 704
 705       u = new_unit (opp, u, flags);
 706       if (u != NULL)
 707         unlock_unit (u);
 708       return;
 709     }
 710
 711   edit_modes (opp, u, flags);
 712 }
 713
 714
 715 /* Open file.  */
 716
 717 extern void st_open (st_parameter_open *opp);
 718 export_proto(st_open);
 719
 720 void
 721 st_open (st_parameter_open *opp)
 722 {
 723   unit_flags flags;
 724   gfc_unit *u = NULL;
 725   GFC_INTEGER_4 cf = opp->common.flags;
 726   unit_convert conv;
 727
 728   library_start (&opp->common);
 729
 730   /* Decode options.  */
 731   flags.readonly = !(cf & IOPARM_OPEN_HAS_READONLY) ? 0 : opp->readonly;
 732
 733   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 734     find_option (&opp->common, opp->access, opp->access_len,
 735                  access_opt, "Bad ACCESS parameter in OPEN statement");
 736
 737   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 738     find_option (&opp->common, opp->action, opp->action_len,
 739                  action_opt, "Bad ACTION parameter in OPEN statement");
 740
 741   flags.cc = !(cf & IOPARM_OPEN_HAS_CC) ? CC_UNSPECIFIED :
 742     find_option (&opp->common, opp->cc, opp->cc_len,
 743                  cc_opt, "Bad CARRIAGECONTROL parameter in OPEN statement");
 744
 745   flags.share = !(cf & IOPARM_OPEN_HAS_SHARE) ? SHARE_UNSPECIFIED :
 746     find_option (&opp->common, opp->share, opp->share_len,
 747                  share_opt, "Bad SHARE parameter in OPEN statement");
 748
 749   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 750     find_option (&opp->common, opp->blank, opp->blank_len,
 751                  blank_opt, "Bad BLANK parameter in OPEN statement");
 752
 753   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 754     find_option (&opp->common, opp->delim, opp->delim_len,
 755                  delim_opt, "Bad DELIM parameter in OPEN statement");
 756
 757   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 758     find_option (&opp->common, opp->pad, opp->pad_len,
 759                  pad_opt, "Bad PAD parameter in OPEN statement");
 760
 761   flags.decimal = !(cf & IOPARM_OPEN_HAS_DECIMAL) ? DECIMAL_UNSPECIFIED :
 762     find_option (&opp->common, opp->decimal, opp->decimal_len,
 763                  decimal_opt, "Bad DECIMAL parameter in OPEN statement");
 764
 765   flags.encoding = !(cf & IOPARM_OPEN_HAS_ENCODING) ? ENCODING_UNSPECIFIED :
 766     find_option (&opp->common, opp->encoding, opp->encoding_len,
 767                  encoding_opt, "Bad ENCODING parameter in OPEN statement");
 768
 769   flags.async = !(cf & IOPARM_OPEN_HAS_ASYNCHRONOUS) ? ASYNC_UNSPECIFIED :
 770     find_option (&opp->common, opp->asynchronous, opp->asynchronous_len,
 771                  async_opt, "Bad ASYNCHRONOUS parameter in OPEN statement");
 772
 773   flags.round = !(cf & IOPARM_OPEN_HAS_ROUND) ? ROUND_UNSPECIFIED :
 774     find_option (&opp->common, opp->round, opp->round_len,
 775                  round_opt, "Bad ROUND parameter in OPEN statement");
 776
 777   flags.sign = !(cf & IOPARM_OPEN_HAS_SIGN) ? SIGN_UNSPECIFIED :
 778     find_option (&opp->common, opp->sign, opp->sign_len,
 779                  sign_opt, "Bad SIGN parameter in OPEN statement");
 780
 781   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 782     find_option (&opp->common, opp->form, opp->form_len,
 783                  form_opt, "Bad FORM parameter in OPEN statement");
 784
 785   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 786     find_option (&opp->common, opp->position, opp->position_len,
 787                  position_opt, "Bad POSITION parameter in OPEN statement");
 788
 789   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 790     find_option (&opp->common, opp->status, opp->status_len,
 791                  status_opt, "Bad STATUS parameter in OPEN statement");
 792
 793   /* First, we check wether the convert flag has been set via environment
 794      variable.  This overrides the convert tag in the open statement.  */
 795
 796   conv = get_unformatted_convert (opp->common.unit);
 797
 798   if (conv == GFC_CONVERT_NONE)
 799     {
 800       /* Nothing has been set by environment variable, check the convert tag.  */
 801       if (cf & IOPARM_OPEN_HAS_CONVERT)
 802         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 803                             convert_opt,
 804                             "Bad CONVERT parameter in OPEN statement");
 805       else
 806         conv = compile_options.convert;
 807     }
 808
 809   /* We use big_endian, which is 0 on little-endian machines
 810      and 1 on big-endian machines.  */
 811   switch (conv)
 812     {
 813     case GFC_CONVERT_NATIVE:
 814     case GFC_CONVERT_SWAP:
 815       break;
 816
 817     case GFC_CONVERT_BIG:
 818       conv = big_endian ? GFC_CONVERT_NATIVE : GFC_CONVERT_SWAP;
 819       break;
 820
 821     case GFC_CONVERT_LITTLE:
 822       conv = big_endian ? GFC_CONVERT_SWAP : GFC_CONVERT_NATIVE;
 823       break;
 824
 825     default:
 826       internal_error (&opp->common, "Illegal value for CONVERT");
 827       break;
 828     }
 829
 830   flags.convert = conv;
 831
 832   if (flags.position != POSITION_UNSPECIFIED
 833       && flags.access == ACCESS_DIRECT)
 834     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 835                     "Cannot use POSITION with direct access files");
 836
 837   if (flags.readonly
 838       && flags.action != ACTION_UNSPECIFIED && flags.action != ACTION_READ)
 839     generate_error (&opp->common, LIBERROR_BAD_OPTION,
 840                     "ACTION conflicts with READONLY in OPEN statement");
 841
 842   if (flags.access == ACCESS_APPEND)
 843     {
 844       if (flags.position != POSITION_UNSPECIFIED
 845           && flags.position != POSITION_APPEND)
 846         generate_error (&opp->common, LIBERROR_BAD_OPTION,
 847                         "Conflicting ACCESS and POSITION flags in"
 848                         " OPEN statement");
 849
 850       notify_std (&opp->common, GFC_STD_GNU,
 851                   "Extension: APPEND as a value for ACCESS in OPEN statement");
 852       flags.access = ACCESS_SEQUENTIAL;
 853       flags.position = POSITION_APPEND;
 854     }
 855
 856   if (flags.position == POSITION_UNSPECIFIED)
 857     flags.position = POSITION_ASIS;
 858
 859   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 860     {
 861       if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT))
 862         opp->common.unit = newunit_alloc ();
 863       else if (opp->common.unit < 0)
 864         {
 865           u = find_unit (opp->common.unit);
 866           if (u == NULL) /* Negative unit and no NEWUNIT-created unit found.  */
 867             {
 868               generate_error (&opp->common, LIBERROR_BAD_OPTION,
 869                               "Bad unit number in OPEN statement");
 870               library_end ();
 871               return;
 872             }
 873         }
 874
 875       if (u == NULL)
 876         u = find_or_create_unit (opp->common.unit);
 877       if (u->s == NULL)
 878         {
 879           u = new_unit (opp, u, &flags);
 880           if (u != NULL)
 881             unlock_unit (u);
 882         }
 883       else
 884         already_open (opp, u, &flags);
 885     }
 886
 887   if ((opp->common.flags & IOPARM_OPEN_HAS_NEWUNIT)
 888       && (opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 889     *opp->newunit = opp->common.unit;
 890
 891   library_end ();
 892 }