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