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