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 static const st_option convert_opt[] =
 102 {
 103   { "native", CONVERT_NATIVE},
 104   { "swap", CONVERT_SWAP},
 105   { "big_endian", CONVERT_BIG},
 106   { "little_endian", CONVERT_LITTLE},
 107   { NULL, 0}
 108 };
 109
 110 /* Given a unit, test to see if the file is positioned at the terminal
 111    point, and if so, change state from NO_ENDFILE flag to AT_ENDFILE.
 112    This prevents us from changing the state from AFTER_ENDFILE to
 113    AT_ENDFILE.  */
 114
 115 void
 116 test_endfile (gfc_unit * u)
 117 {
 118   if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
 119     u->endfile = AT_ENDFILE;
 120 }
 121
 122
 123 /* Change the modes of a file, those that are allowed * to be
 124    changed.  */
 125
 126 static void
 127 edit_modes (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 128 {
 129   /* Complain about attempts to change the unchangeable.  */
 130
 131   if (flags->status != STATUS_UNSPECIFIED &&
 132       u->flags.status != flags->status)
 133     generate_error (&opp->common, ERROR_BAD_OPTION,
 134                     "Cannot change STATUS parameter in OPEN statement");
 135
 136   if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
 137     generate_error (&opp->common, ERROR_BAD_OPTION,
 138                     "Cannot change ACCESS parameter in OPEN statement");
 139
 140   if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
 141     generate_error (&opp->common, ERROR_BAD_OPTION,
 142                     "Cannot change FORM parameter in OPEN statement");
 143
 144   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN)
 145       && opp->recl_in != u->recl)
 146     generate_error (&opp->common, ERROR_BAD_OPTION,
 147                     "Cannot change RECL parameter in OPEN statement");
 148
 149   if (flags->action != ACTION_UNSPECIFIED && u->flags.action != flags->action)
 150     generate_error (&opp->common, ERROR_BAD_OPTION,
 151                     "Cannot change ACTION parameter in OPEN statement");
 152
 153   /* Status must be OLD if present.  */
 154
 155   if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD &&
 156       flags->status != STATUS_UNKNOWN)
 157     generate_error (&opp->common, ERROR_BAD_OPTION,
 158                     "OPEN statement must have a STATUS of OLD or UNKNOWN");
 159
 160   if (u->flags.form == FORM_UNFORMATTED)
 161     {
 162       if (flags->delim != DELIM_UNSPECIFIED)
 163         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 164                         "DELIM parameter conflicts with UNFORMATTED form in "
 165                         "OPEN statement");
 166
 167       if (flags->blank != BLANK_UNSPECIFIED)
 168         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 169                         "BLANK parameter conflicts with UNFORMATTED form in "
 170                         "OPEN statement");
 171
 172       if (flags->pad != PAD_UNSPECIFIED)
 173         generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 174                         "PAD paramter conflicts with UNFORMATTED form in "
 175                         "OPEN statement");
 176     }
 177
 178   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 179     {
 180       /* Change the changeable:  */
 181       if (flags->blank != BLANK_UNSPECIFIED)
 182         u->flags.blank = flags->blank;
 183       if (flags->delim != DELIM_UNSPECIFIED)
 184         u->flags.delim = flags->delim;
 185       if (flags->pad != PAD_UNSPECIFIED)
 186         u->flags.pad = flags->pad;
 187     }
 188
 189   /* Reposition the file if necessary.  */
 190
 191   switch (flags->position)
 192     {
 193     case POSITION_UNSPECIFIED:
 194     case POSITION_ASIS:
 195       break;
 196
 197     case POSITION_REWIND:
 198       if (sseek (u->s, 0) == FAILURE)
 199         goto seek_error;
 200
 201       u->current_record = 0;
 202       u->last_record = 0;
 203
 204       test_endfile (u);         /* We might be at the end.  */
 205       break;
 206
 207     case POSITION_APPEND:
 208       if (sseek (u->s, file_length (u->s)) == FAILURE)
 209         goto seek_error;
 210
 211       u->current_record = 0;
 212       u->endfile = AT_ENDFILE;  /* We are at the end.  */
 213       break;
 214
 215     seek_error:
 216       generate_error (&opp->common, ERROR_OS, NULL);
 217       break;
 218     }
 219
 220   unlock_unit (u);
 221 }
 222
 223
 224 /* Open an unused unit.  */
 225
 226 gfc_unit *
 227 new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
 228 {
 229   gfc_unit *u2;
 230   stream *s;
 231   char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
 232
 233   /* Change unspecifieds to defaults.  Leave (flags->action ==
 234      ACTION_UNSPECIFIED) alone so open_external() can set it based on
 235      what type of open actually works.  */
 236
 237   if (flags->access == ACCESS_UNSPECIFIED)
 238     flags->access = ACCESS_SEQUENTIAL;
 239
 240   if (flags->form == FORM_UNSPECIFIED)
 241     flags->form = (flags->access == ACCESS_SEQUENTIAL)
 242       ? FORM_FORMATTED : FORM_UNFORMATTED;
 243
 244
 245   if (flags->delim == DELIM_UNSPECIFIED)
 246     flags->delim = DELIM_NONE;
 247   else
 248     {
 249       if (flags->form == FORM_UNFORMATTED)
 250         {
 251           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 252                           "DELIM parameter conflicts with UNFORMATTED form in "
 253                           "OPEN statement");
 254           goto fail;
 255         }
 256     }
 257
 258   if (flags->blank == BLANK_UNSPECIFIED)
 259     flags->blank = BLANK_NULL;
 260   else
 261     {
 262       if (flags->form == FORM_UNFORMATTED)
 263         {
 264           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 265                           "BLANK parameter conflicts with UNFORMATTED form in "
 266                           "OPEN statement");
 267           goto fail;
 268         }
 269     }
 270
 271   if (flags->pad == PAD_UNSPECIFIED)
 272     flags->pad = PAD_YES;
 273   else
 274     {
 275       if (flags->form == FORM_UNFORMATTED)
 276         {
 277           generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 278                           "PAD paramter conflicts with UNFORMATTED form in "
 279                           "OPEN statement");
 280           goto fail;
 281         }
 282     }
 283
 284   if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
 285    {
 286      generate_error (&opp->common, ERROR_OPTION_CONFLICT,
 287                      "ACCESS parameter conflicts with SEQUENTIAL access in "
 288                      "OPEN statement");
 289      goto fail;
 290    }
 291   else
 292    if (flags->position == POSITION_UNSPECIFIED)
 293      flags->position = POSITION_ASIS;
 294
 295
 296   if (flags->status == STATUS_UNSPECIFIED)
 297     flags->status = STATUS_UNKNOWN;
 298
 299   /* Checks.  */
 300
 301   if (flags->access == ACCESS_DIRECT
 302       && (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
 303     {
 304       generate_error (&opp->common, ERROR_MISSING_OPTION,
 305                       "Missing RECL parameter in OPEN statement");
 306       goto fail;
 307     }
 308
 309   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
 310     {
 311       generate_error (&opp->common, ERROR_BAD_OPTION,
 312                       "RECL parameter is non-positive in OPEN statement");
 313       goto fail;
 314     }
 315
 316   switch (flags->status)
 317     {
 318     case STATUS_SCRATCH:
 319       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 320         {
 321           opp->file = NULL;
 322           break;
 323         }
 324
 325       generate_error (&opp->common, ERROR_BAD_OPTION,
 326                       "FILE parameter must not be present in OPEN statement");
 327       goto fail;
 328
 329     case STATUS_OLD:
 330     case STATUS_NEW:
 331     case STATUS_REPLACE:
 332     case STATUS_UNKNOWN:
 333       if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
 334         break;
 335
 336       opp->file = tmpname;
 337       opp->file_len = sprintf(opp->file, "fort.%d", opp->common.unit);
 338       break;
 339
 340     default:
 341       internal_error (&opp->common, "new_unit(): Bad status");
 342     }
 343
 344   /* Make sure the file isn't already open someplace else.
 345      Do not error if opening file preconnected to stdin, stdout, stderr.  */
 346
 347   u2 = NULL;
 348   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
 349     u2 = find_file (opp->file, opp->file_len);
 350   if (u2 != NULL
 351       && (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
 352       && (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
 353       && (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
 354     {
 355       unlock_unit (u2);
 356       generate_error (&opp->common, ERROR_ALREADY_OPEN, NULL);
 357       goto cleanup;
 358     }
 359
 360   if (u2 != NULL)
 361     unlock_unit (u2);
 362
 363   /* Open file.  */
 364
 365   s = open_external (opp, flags);
 366   if (s == NULL)
 367     {
 368       generate_error (&opp->common, ERROR_OS, NULL);
 369       goto cleanup;
 370     }
 371
 372   if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
 373     flags->status = STATUS_OLD;
 374
 375   /* Create the unit structure.  */
 376
 377   u->file = get_mem (opp->file_len);
 378   if (u->unit_number != opp->common.unit)
 379     internal_error (&opp->common, "Unit number changed");
 380   u->s = s;
 381   u->flags = *flags;
 382   u->read_bad = 0;
 383   u->endfile = NO_ENDFILE;
 384   u->last_record = 0;
 385   u->current_record = 0;
 386   u->mode = READING;
 387   u->maxrec = 0;
 388   u->bytes_left = 0;
 389
 390   if (flags->position == POSITION_APPEND)
 391     {
 392       if (sseek (u->s, file_length (u->s)) == FAILURE)
 393         generate_error (&opp->common, ERROR_OS, NULL);
 394       u->endfile = AT_ENDFILE;
 395     }
 396
 397   /* Unspecified recl ends up with a processor dependent value.  */
 398
 399   if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
 400     u->recl = opp->recl_in;
 401   else
 402     {
 403       switch (compile_options.record_marker)
 404         {
 405         case 0:
 406           u->recl = max_offset;
 407           break;
 408
 409         case sizeof (GFC_INTEGER_4):
 410           u->recl = GFC_INTEGER_4_HUGE;
 411           break;
 412
 413         case sizeof (GFC_INTEGER_8):
 414           u->recl = max_offset;
 415           break;
 416
 417         default:
 418           runtime_error ("Illegal value for record marker");
 419           break;
 420         }
 421     }
 422
 423   /* If the file is direct access, calculate the maximum record number
 424      via a division now instead of letting the multiplication overflow
 425      later.  */
 426
 427   if (flags->access == ACCESS_DIRECT)
 428     u->maxrec = max_offset / u->recl;
 429
 430   memmove (u->file, opp->file, opp->file_len);
 431   u->file_len = opp->file_len;
 432
 433   /* Curiously, the standard requires that the
 434      position specifier be ignored for new files so a newly connected
 435      file starts out that the initial point.  We still need to figure
 436      out if the file is at the end or not.  */
 437
 438   test_endfile (u);
 439
 440   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 441     free_mem (opp->file);
 442   return u;
 443
 444  cleanup:
 445
 446   /* Free memory associated with a temporary filename.  */
 447
 448   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 449     free_mem (opp->file);
 450
 451  fail:
 452
 453   close_unit (u);
 454   return NULL;
 455 }
 456
 457
 458 /* Open a unit which is already open.  This involves changing the
 459    modes or closing what is there now and opening the new file.  */
 460
 461 static void
 462 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 463 {
 464   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 465     {
 466       edit_modes (opp, u, flags);
 467       return;
 468     }
 469
 470   /* If the file is connected to something else, close it and open a
 471      new unit.  */
 472
 473   if (!compare_file_filename (u, opp->file, opp->file_len))
 474     {
 475 #if !HAVE_UNLINK_OPEN_FILE
 476       char *path = NULL;
 477       if (u->file && u->flags.status == STATUS_SCRATCH)
 478         {
 479           path = (char *) gfc_alloca (u->file_len + 1);
 480           unpack_filename (path, u->file, u->file_len);
 481         }
 482 #endif
 483
 484       if (sclose (u->s) == FAILURE)
 485         {
 486           unlock_unit (u);
 487           generate_error (&opp->common, ERROR_OS,
 488                           "Error closing file in OPEN statement");
 489           return;
 490         }
 491
 492       u->s = NULL;
 493       if (u->file)
 494         free_mem (u->file);
 495       u->file = NULL;
 496       u->file_len = 0;
 497
 498 #if !HAVE_UNLINK_OPEN_FILE
 499       if (path != NULL)
 500         unlink (path);
 501 #endif
 502
 503       u = new_unit (opp, u, flags);
 504       if (u != NULL)
 505         unlock_unit (u);
 506       return;
 507     }
 508
 509   edit_modes (opp, u, flags);
 510 }
 511
 512
 513 /* Open file.  */
 514
 515 extern void st_open (st_parameter_open *opp);
 516 export_proto(st_open);
 517
 518 void
 519 st_open (st_parameter_open *opp)
 520 {
 521   unit_flags flags;
 522   gfc_unit *u = NULL;
 523   GFC_INTEGER_4 cf = opp->common.flags;
 524   unit_convert conv;
 525
 526   library_start (&opp->common);
 527
 528   /* Decode options.  */
 529
 530   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 531     find_option (&opp->common, opp->access, opp->access_len,
 532                  access_opt, "Bad ACCESS parameter in OPEN statement");
 533
 534   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 535     find_option (&opp->common, opp->action, opp->action_len,
 536                  action_opt, "Bad ACTION parameter in OPEN statement");
 537
 538   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 539     find_option (&opp->common, opp->blank, opp->blank_len,
 540                  blank_opt, "Bad BLANK parameter in OPEN statement");
 541
 542   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 543     find_option (&opp->common, opp->delim, opp->delim_len,
 544                  delim_opt, "Bad DELIM parameter in OPEN statement");
 545
 546   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 547     find_option (&opp->common, opp->pad, opp->pad_len,
 548                  pad_opt, "Bad PAD parameter in OPEN statement");
 549
 550   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 551     find_option (&opp->common, opp->form, opp->form_len,
 552                  form_opt, "Bad FORM parameter in OPEN statement");
 553
 554   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 555     find_option (&opp->common, opp->position, opp->position_len,
 556                  position_opt, "Bad POSITION parameter in OPEN statement");
 557
 558   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 559     find_option (&opp->common, opp->status, opp->status_len,
 560                  status_opt, "Bad STATUS parameter in OPEN statement");
 561
 562   /* First, we check wether the convert flag has been set via environment
 563      variable.  This overrides the convert tag in the open statement.  */
 564
 565   conv = get_unformatted_convert (opp->common.unit);
 566
 567   if (conv == CONVERT_NONE)
 568     {
 569       /* Nothing has been set by environment variable, check the convert tag.  */
 570       if (cf & IOPARM_OPEN_HAS_CONVERT)
 571         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 572                             convert_opt,
 573                             "Bad CONVERT parameter in OPEN statement");
 574       else
 575         conv = compile_options.convert;
 576     }
 577
 578   /* We use l8_to_l4_offset, which is 0 on little-endian machines
 579      and 1 on big-endian machines.  */
 580   switch (conv)
 581     {
 582     case CONVERT_NATIVE:
 583     case CONVERT_SWAP:
 584       break;
 585
 586     case CONVERT_BIG:
 587       conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
 588       break;
 589
 590     case CONVERT_LITTLE:
 591       conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
 592       break;
 593
 594     default:
 595       internal_error (&opp->common, "Illegal value for CONVERT");
 596       break;
 597     }
 598
 599   flags.convert = conv;
 600
 601   if (opp->common.unit < 0)
 602     generate_error (&opp->common, ERROR_BAD_OPTION,
 603                     "Bad unit number in OPEN statement");
 604
 605   if (flags.position != POSITION_UNSPECIFIED
 606       && flags.access == ACCESS_DIRECT)
 607     generate_error (&opp->common, ERROR_BAD_OPTION,
 608                     "Cannot use POSITION with direct access files");
 609
 610   if (flags.access == ACCESS_APPEND)
 611     {
 612       if (flags.position != POSITION_UNSPECIFIED
 613           && flags.position != POSITION_APPEND)
 614         generate_error (&opp->common, ERROR_BAD_OPTION,
 615                         "Conflicting ACCESS and POSITION flags in"
 616                         " OPEN statement");
 617
 618       notify_std (GFC_STD_GNU,
 619                   "Extension: APPEND as a value for ACCESS in OPEN statement");
 620       flags.access = ACCESS_SEQUENTIAL;
 621       flags.position = POSITION_APPEND;
 622     }
 623
 624   if (flags.position == POSITION_UNSPECIFIED)
 625     flags.position = POSITION_ASIS;
 626
 627   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 628     {
 629       u = find_or_create_unit (opp->common.unit);
 630
 631       if (u->s == NULL)
 632         {
 633           u = new_unit (opp, u, &flags);
 634           if (u != NULL)
 635             unlock_unit (u);
 636         }
 637       else
 638         already_open (opp, u, &flags);
 639     }
 640
 641   library_end ();
 642 }