libgfortran/io/open.c

   1 /* Copyright (C) 2002, 2003, 2004, 2005
   2    Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of the GNU Fortran 95 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 2, or (at your option)
  10 any later version.
  11
  12 In addition to the permissions in the GNU General Public License, the
  13 Free Software Foundation gives you unlimited permission to link the
  14 compiled version of this file into combinations with other programs,
  15 and to distribute those combinations without any restriction coming
  16 from the use of this file.  (The General Public License restrictions
  17 do apply in other respects; for example, they cover modification of
  18 the file, and distribution when not linked into a combine
  19 executable.)
  20
  21 Libgfortran is distributed in the hope that it will be useful,
  22 but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24 GNU General Public License for more details.
  25
  26 You should have received a copy of the GNU General Public License
  27 along with Libgfortran; see the file COPYING.  If not, write to
  28 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
  29 Boston, MA 02110-1301, USA.  */
  30
  31 #include "config.h"
  32 #include <unistd.h>
  33 #include <stdio.h>
  34 #include <string.h>
  35 #include "libgfortran.h"
  36 #include "io.h"
  37
  38
  39 static const st_option access_opt[] = {
  40   {"sequential", ACCESS_SEQUENTIAL},
  41   {"direct", ACCESS_DIRECT},
  42   {"append", ACCESS_APPEND},
  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 blank_opt[] =
  55 {
  56   { "null", BLANK_NULL},
  57   { "zero", BLANK_ZERO},
  58   { NULL, 0}
  59 };
  60
  61 static const st_option delim_opt[] =
  62 {
  63   { "none", DELIM_NONE},
  64   { "apostrophe", DELIM_APOSTROPHE},
  65   { "quote", DELIM_QUOTE},
  66   { NULL, 0}
  67 };
  68
  69 static const st_option form_opt[] =
  70 {
  71   { "formatted", FORM_FORMATTED},
  72   { "unformatted", FORM_UNFORMATTED},
  73   { NULL, 0}
  74 };
  75
  76 static const st_option position_opt[] =
  77 {
  78   { "asis", POSITION_ASIS},
  79   { "rewind", POSITION_REWIND},
  80   { "append", POSITION_APPEND},
  81   { NULL, 0}
  82 };
  83
  84 static const st_option status_opt[] =
  85 {
  86   { "unknown", STATUS_UNKNOWN},
  87   { "old", STATUS_OLD},
  88   { "new", STATUS_NEW},
  89   { "replace", STATUS_REPLACE},
  90   { "scratch", STATUS_SCRATCH},
  91   { NULL, 0}
  92 };
  93
  94 static const st_option pad_opt[] =
  95 {
  96   { "yes", PAD_YES},
  97   { "no", PAD_NO},
  98   { NULL, 0}
  99 };
 100
 101
 102 /* Given a unit, test to see if the file is positioned at the terminal
 103    point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
 104    This prevents us from changing the state from AFTER_ENDFILE to
 105    AT_ENDFILE.  */
 106
 107 void
 108 test_endfile (gfc_unit * u)
 109 {
 110   if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
 111     u->endfile = AT_ENDFILE;
 112 }
 113
 114
 115 /* Change the modes of a file, those that are allowed * to be
 116    changed.  */
 117
 118 static void
 119 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 120 {
 121   /* Complain about attempts to change the unchangeable.  */
 122
 123   if (flags->status != STATUS_UNSPECIFIED &&
 124       u->flags.status != flags->status)
 125     generate_error (&opp->common, ERROR_BAD_OPTION,
 126                     "Cannot change STATUS parameter in OPEN statement");
 127
 128   if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
 129     generate_error (&opp->common, ERROR_BAD_OPTION,
 130                     "Cannot change ACCESS parameter in OPEN statement");
 131
 132   if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
 133     generate_error (&opp->common, ERROR_BAD_OPTION,
 134                     "Cannot change FORM parameter in OPEN statement");
 135
 136   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
 137       && opp->recl_in != u->recl)
 138     generate_error (&opp->common, ERROR_BAD_OPTION,
 139                     "Cannot change RECL parameter in OPEN statement");
 140
 141   if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access)
 142     generate_error (&opp->common, ERROR_BAD_OPTION,
 143                     "Cannot change ACTION parameter in OPEN statement");
 144
 145   /* Status must be OLD if present.  */
 146
 147   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
 148       flags->status != STATUS_UNKNOWN)
 149     generate_error (&opp->common, ERROR_BAD_OPTION,
 150                     "OPEN statement must have a STATUS of OLD or UNKNOWN");
 151
 152   if (u->flags.form == FORM_UNFORMATTED)
 153     {
 154       if (flags->delim != DELIM_UNSPECIFIED)
 155         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 156                         "DELIM parameter conflicts with UNFORMATTED form in "
 157                         "OPEN statement");
 158
 159       if (flags->blank != BLANK_UNSPECIFIED)
 160         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 161                         "BLANK parameter conflicts with UNFORMATTED form in "
 162                         "OPEN statement");
 163
 164       if (flags->pad != PAD_UNSPECIFIED)
 165         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 166                         "PAD paramter conflicts with UNFORMATTED form in "
 167                         "OPEN statement");
 168     }
 169
 170   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 171     {
 172       /* Change the changeable:  */
 173       if (flags->blank != BLANK_UNSPECIFIED)
 174         u->flags.blank = flags->blank;
 175       if (flags->delim != DELIM_UNSPECIFIED)
 176         u->flags.delim = flags->delim;
 177       if (flags->pad != PAD_UNSPECIFIED)
 178         u->flags.pad = flags->pad;
 179     }
 180
 181   /* Reposition the file if necessary.  */
 182
 183   switch (flags->position)
 184     {
 185     case POSITION_UNSPECIFIED:
 186     case POSITION_ASIS:
 187       break;
 188
 189     case POSITION_REWIND:
 190       if (sseek (u->s, 0) == FAILURE)
 191         goto seek_error;
 192
 193       u->current_record = 0;
 194       u->last_record = 0;
 195
 196       test_endfile (u);         /* We might be at the end.  */
 197       break;
 198
 199     case POSITION_APPEND:
 200       if (sseek (u->s, file_length (u->s)) == FAILURE)
 201         goto seek_error;
 202
 203       u->current_record = 0;
 204       u->endfile = AT_ENDFILE;  /* We are at the end.  */
 205       break;
 206
 207     seek_error:
 208       generate_error (&opp->common, ERROR_OS, NULL);
 209       break;
 210     }
 211
 212   unlock_unit (u);
 213 }
 214
 215
 216 /* Open an unused unit.  */
 217
 218 gfc_unit *
 219 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
 220 {
 221   gfc_unit *u2;
 222   stream *s;
 223   char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
 224
 225   /* Change unspecifieds to defaults.  Leave (flags->action ==
 226      ACTION_UNSPECIFIED) alone so open_external() can set it based on
 227      what type of open actually works.  */
 228
 229   if (flags->access == ACCESS_UNSPECIFIED)
 230     flags->access = ACCESS_SEQUENTIAL;
 231
 232   if (flags->form == FORM_UNSPECIFIED)
 233     flags->form = (flags->access == ACCESS_SEQUENTIAL)
 234       ? FORM_FORMATTED : FORM_UNFORMATTED;
 235
 236
 237   if (flags->delim == DELIM_UNSPECIFIED)
 238     flags->delim = DELIM_NONE;
 239   else
 240     {
 241       if (flags->form == FORM_UNFORMATTED)
 242         {
 243           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 244                           "DELIM parameter conflicts with UNFORMATTED form in "
 245                           "OPEN statement");
 246           goto fail;
 247         }
 248     }
 249
 250   if (flags->blank == BLANK_UNSPECIFIED)
 251     flags->blank = BLANK_NULL;
 252   else
 253     {
 254       if (flags->form == FORM_UNFORMATTED)
 255         {
 256           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 257                           "BLANK parameter conflicts with UNFORMATTED form in "
 258                           "OPEN statement");
 259           goto fail;
 260         }
 261     }
 262
 263   if (flags->pad == PAD_UNSPECIFIED)
 264     flags->pad = PAD_YES;
 265   else
 266     {
 267       if (flags->form == FORM_UNFORMATTED)
 268         {
 269           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 270                           "PAD paramter conflicts with UNFORMATTED form in "
 271                           "OPEN statement");
 272           goto fail;
 273         }
 274     }
 275
 276   if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
 277    {
 278      generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 279                      "ACCESS parameter conflicts with SEQUENTIAL access in "
 280                      "OPEN statement");
 281      goto fail;
 282    }
 283   else
 284    if (flags->position == POSITION_UNSPECIFIED)
 285      flags->position = POSITION_ASIS;
 286
 287
 288   if (flags->status == STATUS_UNSPECIFIED)
 289     flags->status = STATUS_UNKNOWN;
 290
 291   /* Checks.  */
 292
 293   if (flags->access == ACCESS_DIRECT
 294       && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
 295     {
 296       generate_error (&opp->common, ERROR_MISSING_OPTION,
 297                       "Missing RECL parameter in OPEN statement");
 298       goto fail;
 299     }
 300
 301   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
 302     {
 303       generate_error (&opp->common, ERROR_BAD_OPTION,
 304                       "RECL parameter is non-positive in OPEN statement");
 305       goto fail;
 306     }
 307
 308   switch (flags->status)
 309     {
 310     case STATUS_SCRATCH:
 311       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 312         {
 313           opp->file = NULL;
 314           break;
 315         }
 316
 317       generate_error (&opp->common, ERROR_BAD_OPTION,
 318                       "FILE parameter must not be present in OPEN statement");
 319       goto fail;
 320
 321     case STATUS_OLD:
 322     case STATUS_NEW:
 323     case STATUS_REPLACE:
 324     case STATUS_UNKNOWN:
 325       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
 326         break;
 327
 328       opp->file = tmpname;
 329       opp->file_len = sprintf(opp->file, "fort.%d", opp->common.unit);
 330       break;
 331
 332     default:
 333       internal_error (&opp->common, "new_unit(): Bad status");
 334     }
 335
 336   /* Make sure the file isn't already open someplace else.
 337      Do not error if opening file preconnected to stdin, stdout, stderr.  */
 338
 339   u2 = NULL;
 340   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
 341     u2 = find_file (opp->file, opp->file_len);
 342   if (u2 != NULL
 343       && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
 344       && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
 345       && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
 346     {
 347       unlock_unit (u2);
 348       generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
 349       goto cleanup;
 350     }
 351
 352   if (u2 != NULL)
 353     unlock_unit (u2);
 354
 355   /* Open file.  */
 356
 357   s = open_external (opp, flags);
 358   if (s == NULL)
 359     {
 360       generate_error (&opp->common, ERROR_OS, NULL);
 361       goto cleanup;
 362     }
 363
 364   if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
 365     flags->status = STATUS_OLD;
 366
 367   /* Create the unit structure.  */
 368
 369   u->file = get_mem (opp->file_len);
 370   if (u->unit_number != opp->common.unit)
 371     internal_error (&opp->common, "Unit number changed");
 372   u->s = s;
 373   u->flags = *flags;
 374   u->read_bad = 0;
 375   u->endfile = NO_ENDFILE;
 376   u->last_record = 0;
 377   u->current_record = 0;
 378   u->mode = READING;
 379   u->maxrec = 0;
 380   u->bytes_left = 0;
 381
 382   if (flags->position == POSITION_APPEND)
 383     {
 384       if (sseek (u->s, file_length (u->s)) == FAILURE)
 385         generate_error (&opp->common, ERROR_OS, NULL);
 386       u->endfile = AT_ENDFILE;
 387     }
 388
 389   /* Unspecified recl ends up with a processor dependent value.  */
 390
 391   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 392     u->recl = opp->recl_in;
 393   else
 394     u->recl = max_offset;
 395
 396   /* If the file is direct access, calculate the maximum record number
 397      via a division now instead of letting the multiplication overflow
 398      later.  */
 399
 400   if (flags->access == ACCESS_DIRECT)
 401     u->maxrec = max_offset / u->recl;
 402
 403   memmove (u->file, opp->file, opp->file_len);
 404   u->file_len = opp->file_len;
 405
 406   /* Curiously, the standard requires that the
 407      position specifier be ignored for new files so a newly connected
 408      file starts out that the initial point.  We still need to figure
 409      out if the file is at the end or not.  */
 410
 411   test_endfile (u);
 412
 413   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 414     free_mem (opp->file);
 415   return u;
 416
 417  cleanup:
 418
 419   /* Free memory associated with a temporary filename.  */
 420
 421   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 422     free_mem (opp->file);
 423
 424  fail:
 425
 426   close_unit (u);
 427   return NULL;
 428 }
 429
 430
 431 /* Open a unit which is already open.  This involves changing the
 432    modes or closing what is there now and opening the new file.  */
 433
 434 static void
 435 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 436 {
 437   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 438     {
 439       edit_modes (opp, u, flags);
 440       return;
 441     }
 442
 443   /* If the file is connected to something else, close it and open a
 444      new unit.  */
 445
 446   if (!compare_file_filename (u, opp->file, opp->file_len))
 447     {
 448 #if !HAVE_UNLINK_OPEN_FILE
 449       char *path = NULL;
 450       if (u->file && u->flags.status == STATUS_SCRATCH)
 451         {
 452           path = (char *) gfc_alloca (u->file_len + 1);
 453           unpack_filename (path, u->file, u->file_len);
 454         }
 455 #endif
 456
 457       if (sclose (u->s) == FAILURE)
 458         {
 459           unlock_unit (u);
 460           generate_error (&opp->common, ERROR_OS,
 461                           "Error closing file in OPEN statement");
 462           return;
 463         }
 464
 465       u->s = NULL;
 466       if (u->file)
 467         free_mem (u->file);
 468       u->file = NULL;
 469       u->file_len = 0;
 470
 471 #if !HAVE_UNLINK_OPEN_FILE
 472       if (path != NULL)
 473         unlink (path);
 474 #endif
 475
 476       u = new_unit (opp, u, flags);
 477       if (u != NULL)
 478         unlock_unit (u);
 479       return;
 480     }
 481
 482   edit_modes (opp, u, flags);
 483 }
 484
 485
 486 /* Open file.  */
 487
 488 extern void st_open (st_parameter_open *opp);
 489 export_proto(st_open);
 490
 491 void
 492 st_open (st_parameter_open *opp)
 493 {
 494   unit_flags flags;
 495   gfc_unit *u = NULL;
 496   GFC_INTEGER_4 cf = opp->common.flags;
 497
 498   library_start (&opp->common);
 499
 500   /* Decode options.  */
 501
 502   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 503     find_option (&opp->common, opp->access, opp->access_len,
 504                  access_opt, "Bad ACCESS parameter in OPEN statement");
 505
 506   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 507     find_option (&opp->common, opp->action, opp->action_len,
 508                  action_opt, "Bad ACTION parameter in OPEN statement");
 509
 510   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 511     find_option (&opp->common, opp->blank, opp->blank_len,
 512                  blank_opt, "Bad BLANK parameter in OPEN statement");
 513
 514   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 515     find_option (&opp->common, opp->delim, opp->delim_len,
 516                  delim_opt, "Bad DELIM parameter in OPEN statement");
 517
 518   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 519     find_option (&opp->common, opp->pad, opp->pad_len,
 520                  pad_opt, "Bad PAD parameter in OPEN statement");
 521
 522   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 523     find_option (&opp->common, opp->form, opp->form_len,
 524                  form_opt, "Bad FORM parameter in OPEN statement");
 525
 526   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 527     find_option (&opp->common, opp->position, opp->position_len,
 528                  position_opt, "Bad POSITION parameter in OPEN statement");
 529
 530   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 531     find_option (&opp->common, opp->status, opp->status_len,
 532                  status_opt, "Bad STATUS parameter in OPEN statement");
 533
 534   if (opp->common.unit < 0)
 535     generate_error (&opp->common, ERROR_BAD_OPTION,
 536                     "Bad unit number in OPEN statement");
 537
 538   if (flags.position != POSITION_UNSPECIFIED
 539       && flags.access == ACCESS_DIRECT)
 540     generate_error (&opp->common, ERROR_BAD_OPTION,
 541                     "Cannot use POSITION with direct access files");
 542
 543   if (flags.access == ACCESS_APPEND)
 544     {
 545       if (flags.position != POSITION_UNSPECIFIED
 546           && flags.position != POSITION_APPEND)
 547         generate_error (&opp->common, ERROR_BAD_OPTION,
 548                         "Conflicting ACCESS and POSITION flags in"
 549                         " OPEN statement");
 550
 551       notify_std (GFC_STD_GNU,
 552                   "Extension: APPEND as a value for ACCESS in OPEN statement");
 553       flags.access = ACCESS_SEQUENTIAL;
 554       flags.position = POSITION_APPEND;
 555     }
 556
 557   if (flags.position == POSITION_UNSPECIFIED)
 558     flags.position = POSITION_ASIS;
 559
 560   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 561     {
 562       u = find_or_create_unit (opp->common.unit);
 563
 564       if (u->s == NULL)
 565         {
 566           u = new_unit (opp, u, &flags);
 567           if (u != NULL)
 568             unlock_unit (u);
 569         }
 570       else
 571         already_open (opp, u, &flags);
 572     }
 573
 574   library_end ();
 575 }