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", (int) 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     }
 413   else
 414     {
 415       u->flags.has_recl = 0;
 416       switch (compile_options.record_marker)
 417         {
 418         case 0:
 419           u->recl = max_offset;
 420           break;
 421
 422         case sizeof (GFC_INTEGER_4):
 423           u->recl = GFC_INTEGER_4_HUGE;
 424           break;
 425
 426         case sizeof (GFC_INTEGER_8):
 427           u->recl = max_offset;
 428           break;
 429
 430         default:
 431           runtime_error ("Illegal value for record marker");
 432           break;
 433         }
 434     }
 435
 436   /* If the file is direct access, calculate the maximum record number
 437      via a division now instead of letting the multiplication overflow
 438      later.  */
 439
 440   if (flags->access == ACCESS_DIRECT)
 441     u->maxrec = max_offset / u->recl;
 442
 443   if (flags->access == ACCESS_STREAM)
 444     {
 445       u->maxrec = max_offset;
 446       u->recl = 1;
 447       u->strm_pos = 1;
 448     }
 449
 450   memmove (u->file, opp->file, opp->file_len);
 451   u->file_len = opp->file_len;
 452
 453   /* Curiously, the standard requires that the
 454      position specifier be ignored for new files so a newly connected
 455      file starts out that the initial point.  We still need to figure
 456      out if the file is at the end or not.  */
 457
 458   test_endfile (u);
 459
 460   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 461     free_mem (opp->file);
 462   return u;
 463
 464  cleanup:
 465
 466   /* Free memory associated with a temporary filename.  */
 467
 468   if (flags->status == STATUS_SCRATCH && opp->file != NULL)
 469     free_mem (opp->file);
 470
 471  fail:
 472
 473   close_unit (u);
 474   return NULL;
 475 }
 476
 477
 478 /* Open a unit which is already open.  This involves changing the
 479    modes or closing what is there now and opening the new file.  */
 480
 481 static void
 482 already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
 483 {
 484   if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
 485     {
 486       edit_modes (opp, u, flags);
 487       return;
 488     }
 489
 490   /* If the file is connected to something else, close it and open a
 491      new unit.  */
 492
 493   if (!compare_file_filename (u, opp->file, opp->file_len))
 494     {
 495 #if !HAVE_UNLINK_OPEN_FILE
 496       char *path = NULL;
 497       if (u->file && u->flags.status == STATUS_SCRATCH)
 498         {
 499           path = (char *) gfc_alloca (u->file_len + 1);
 500           unpack_filename (path, u->file, u->file_len);
 501         }
 502 #endif
 503
 504       if (sclose (u->s) == FAILURE)
 505         {
 506           unlock_unit (u);
 507           generate_error (&opp->common, ERROR_OS,
 508                           "Error closing file in OPEN statement");
 509           return;
 510         }
 511
 512       u->s = NULL;
 513       if (u->file)
 514         free_mem (u->file);
 515       u->file = NULL;
 516       u->file_len = 0;
 517
 518 #if !HAVE_UNLINK_OPEN_FILE
 519       if (path != NULL)
 520         unlink (path);
 521 #endif
 522
 523       u = new_unit (opp, u, flags);
 524       if (u != NULL)
 525         unlock_unit (u);
 526       return;
 527     }
 528
 529   edit_modes (opp, u, flags);
 530 }
 531
 532
 533 /* Open file.  */
 534
 535 extern void st_open (st_parameter_open *opp);
 536 export_proto(st_open);
 537
 538 void
 539 st_open (st_parameter_open *opp)
 540 {
 541   unit_flags flags;
 542   gfc_unit *u = NULL;
 543   GFC_INTEGER_4 cf = opp->common.flags;
 544   unit_convert conv;
 545
 546   library_start (&opp->common);
 547
 548   /* Decode options.  */
 549
 550   flags.access = !(cf & IOPARM_OPEN_HAS_ACCESS) ? ACCESS_UNSPECIFIED :
 551     find_option (&opp->common, opp->access, opp->access_len,
 552                  access_opt, "Bad ACCESS parameter in OPEN statement");
 553
 554   flags.action = !(cf & IOPARM_OPEN_HAS_ACTION) ? ACTION_UNSPECIFIED :
 555     find_option (&opp->common, opp->action, opp->action_len,
 556                  action_opt, "Bad ACTION parameter in OPEN statement");
 557
 558   flags.blank = !(cf & IOPARM_OPEN_HAS_BLANK) ? BLANK_UNSPECIFIED :
 559     find_option (&opp->common, opp->blank, opp->blank_len,
 560                  blank_opt, "Bad BLANK parameter in OPEN statement");
 561
 562   flags.delim = !(cf & IOPARM_OPEN_HAS_DELIM) ? DELIM_UNSPECIFIED :
 563     find_option (&opp->common, opp->delim, opp->delim_len,
 564                  delim_opt, "Bad DELIM parameter in OPEN statement");
 565
 566   flags.pad = !(cf & IOPARM_OPEN_HAS_PAD) ? PAD_UNSPECIFIED :
 567     find_option (&opp->common, opp->pad, opp->pad_len,
 568                  pad_opt, "Bad PAD parameter in OPEN statement");
 569
 570   flags.form = !(cf & IOPARM_OPEN_HAS_FORM) ? FORM_UNSPECIFIED :
 571     find_option (&opp->common, opp->form, opp->form_len,
 572                  form_opt, "Bad FORM parameter in OPEN statement");
 573
 574   flags.position = !(cf & IOPARM_OPEN_HAS_POSITION) ? POSITION_UNSPECIFIED :
 575     find_option (&opp->common, opp->position, opp->position_len,
 576                  position_opt, "Bad POSITION parameter in OPEN statement");
 577
 578   flags.status = !(cf & IOPARM_OPEN_HAS_STATUS) ? STATUS_UNSPECIFIED :
 579     find_option (&opp->common, opp->status, opp->status_len,
 580                  status_opt, "Bad STATUS parameter in OPEN statement");
 581
 582   /* First, we check wether the convert flag has been set via environment
 583      variable.  This overrides the convert tag in the open statement.  */
 584
 585   conv = get_unformatted_convert (opp->common.unit);
 586
 587   if (conv == CONVERT_NONE)
 588     {
 589       /* Nothing has been set by environment variable, check the convert tag.  */
 590       if (cf & IOPARM_OPEN_HAS_CONVERT)
 591         conv = find_option (&opp->common, opp->convert, opp->convert_len,
 592                             convert_opt,
 593                             "Bad CONVERT parameter in OPEN statement");
 594       else
 595         conv = compile_options.convert;
 596     }
 597
 598   /* We use l8_to_l4_offset, which is 0 on little-endian machines
 599      and 1 on big-endian machines.  */
 600   switch (conv)
 601     {
 602     case CONVERT_NATIVE:
 603     case CONVERT_SWAP:
 604       break;
 605
 606     case CONVERT_BIG:
 607       conv = l8_to_l4_offset ? CONVERT_NATIVE : CONVERT_SWAP;
 608       break;
 609
 610     case CONVERT_LITTLE:
 611       conv = l8_to_l4_offset ? CONVERT_SWAP : CONVERT_NATIVE;
 612       break;
 613
 614     default:
 615       internal_error (&opp->common, "Illegal value for CONVERT");
 616       break;
 617     }
 618
 619   flags.convert = conv;
 620
 621   if (opp->common.unit < 0)
 622     generate_error (&opp->common, ERROR_BAD_OPTION,
 623                     "Bad unit number in OPEN statement");
 624
 625   if (flags.position != POSITION_UNSPECIFIED
 626       && flags.access == ACCESS_DIRECT)
 627     generate_error (&opp->common, ERROR_BAD_OPTION,
 628                     "Cannot use POSITION with direct access files");
 629
 630   if (flags.access == ACCESS_APPEND)
 631     {
 632       if (flags.position != POSITION_UNSPECIFIED
 633           && flags.position != POSITION_APPEND)
 634         generate_error (&opp->common, ERROR_BAD_OPTION,
 635                         "Conflicting ACCESS and POSITION flags in"
 636                         " OPEN statement");
 637
 638       notify_std (&opp->common, GFC_STD_GNU,
 639                   "Extension: APPEND as a value for ACCESS in OPEN statement");
 640       flags.access = ACCESS_SEQUENTIAL;
 641       flags.position = POSITION_APPEND;
 642     }
 643
 644   if (flags.position == POSITION_UNSPECIFIED)
 645     flags.position = POSITION_ASIS;
 646
 647   if ((opp->common.flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_OK)
 648     {
 649       u = find_or_create_unit (opp->common.unit);
 650
 651       if (u->s == NULL)
 652         {
 653           u = new_unit (opp, u, &flags);
 654           if (u != NULL)
 655             unlock_unit (u);
 656         }
 657       else
 658         already_open (opp, u, &flags);
 659     }
 660
 661   library_end ();
 662 }