libgfortran/io/open.c

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