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