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