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