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