Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

1 files changed, 528 insertions, 0 deletions

diff --git a/libgfortran/io/open.c b/libgfortran/io/open.c
new file mode 100644
index 0000000..e6fa50d
--- /dev/null
+++ b/libgfortran/io/open.c
@@ -0,0 +1,528 @@
+
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfortran).
+
+Libgfortran is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2, or (at your option)
+any later version.
+
+Libgfortran is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with Libgfortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <unistd.h>
+#include <stdio.h>
+#include <string.h>
+#include "libgfortran.h"
+#include "io.h"
+
+
+static st_option access_opt[] = {
+  {"sequential", ACCESS_SEQUENTIAL},
+  {"direct", ACCESS_DIRECT},
+  {NULL}
+}, action_opt[] =
+{
+  {
+  "read", ACTION_READ}
+  ,
+  {
+  "write", ACTION_WRITE}
+  ,
+  {
+  "readwrite", ACTION_READWRITE}
+  ,
+  {
+  NULL}
+}
+
+, blank_opt[] =
+{
+  {
+  "null", BLANK_NULL}
+  ,
+  {
+  "zero", BLANK_ZERO}
+  ,
+  {
+  NULL}
+}
+
+, delim_opt[] =
+{
+  {
+  "none", DELIM_NONE}
+  ,
+  {
+  "apostrophe", DELIM_APOSTROPHE}
+  ,
+  {
+  "quote", DELIM_QUOTE}
+  ,
+  {
+  NULL}
+}
+
+, form_opt[] =
+{
+  {
+  "formatted", FORM_FORMATTED}
+  ,
+  {
+  "unformatted", FORM_UNFORMATTED}
+  ,
+  {
+  NULL}
+}
+
+, position_opt[] =
+{
+  {
+  "asis", POSITION_ASIS}
+  ,
+  {
+  "rewind", POSITION_REWIND}
+  ,
+  {
+  "append", POSITION_APPEND}
+  ,
+  {
+  NULL}
+}
+
+, status_opt[] =
+{
+  {
+  "unknown", STATUS_UNKNOWN}
+  ,
+  {
+  "old", STATUS_OLD}
+  ,
+  {
+  "new", STATUS_NEW}
+  ,
+  {
+  "replace", STATUS_REPLACE}
+  ,
+  {
+  "scratch", STATUS_SCRATCH}
+  ,
+  {
+  NULL}
+}
+
+, pad_opt[] =
+{
+  {
+  "yes", PAD_YES}
+  ,
+  {
+  "no", PAD_NO}
+  ,
+  {
+  NULL}
+};
+
+
+/* test_endfile()-- Given a unit, test to see if the file is
+ * positioned at the terminal point, and if so, change state from
+ * NO_ENDFILE flag to AT_ENDFILE.  This prevents us from changing the
+ * state from AFTER_ENDFILE to AT_ENDFILE. */
+
+void
+test_endfile (unit_t * u)
+{
+
+  if (u->endfile == NO_ENDFILE && file_length (u->s) == file_position (u->s))
+    u->endfile = AT_ENDFILE;
+}
+
+
+/* edit_modes()-- Change the modes of a file, those that are allowed
+ * to be changed. */
+
+static void
+edit_modes (unit_t * u, unit_flags * flags)
+{
+
+  /* Complain about attempts to change the unchangeable */
+
+  if (flags->status != STATUS_UNSPECIFIED &&
+      u->flags.status != flags->position)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change STATUS parameter in OPEN statement");
+
+  if (flags->access != ACCESS_UNSPECIFIED && u->flags.access != flags->access)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change ACCESS parameter in OPEN statement");
+
+  if (flags->form != FORM_UNSPECIFIED && u->flags.form != flags->form)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change FORM parameter in OPEN statement");
+
+  if (ioparm.recl_in != 0 && ioparm.recl_in != u->recl)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change RECL parameter in OPEN statement");
+
+  if (flags->action != ACTION_UNSPECIFIED && u->flags.access != flags->access)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot change ACTION parameter in OPEN statement");
+
+  /* Status must be OLD if present */
+
+  if (flags->status != STATUS_UNSPECIFIED && flags->status != STATUS_OLD)
+    generate_error (ERROR_BAD_OPTION,
+		    "OPEN statement must have a STATUS of OLD");
+
+  if (u->flags.form == FORM_UNFORMATTED)
+    {
+      if (flags->delim != DELIM_UNSPECIFIED)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"DELIM parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->blank != BLANK_UNSPECIFIED)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"BLANK parameter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+
+      if (flags->pad != PAD_UNSPECIFIED)
+	generate_error (ERROR_OPTION_CONFLICT,
+			"PAD paramter conflicts with UNFORMATTED form in "
+			"OPEN statement");
+    }
+
+  if (ioparm.library_return == LIBRARY_OK)
+    {				/* Change the changeable */
+      if (flags->blank != BLANK_UNSPECIFIED)
+	u->flags.blank = flags->blank;
+      if (flags->delim != DELIM_UNSPECIFIED)
+	u->flags.delim = flags->delim;
+      if (flags->pad != PAD_UNSPECIFIED)
+	u->flags.pad = flags->pad;
+    }
+
+  /* Reposition the file if necessary. */
+
+  switch (flags->position)
+    {
+    case POSITION_UNSPECIFIED:
+    case POSITION_ASIS:
+      break;
+
+    case POSITION_REWIND:
+      if (sseek (u->s, 0) == FAILURE)
+	goto seek_error;
+
+      u->current_record = 0;
+      u->last_record = 0;
+
+      test_endfile (u);		/* We might be at the end */
+      break;
+
+    case POSITION_APPEND:
+      if (sseek (u->s, file_length (u->s)) == FAILURE)
+	goto seek_error;
+
+      u->current_record = 0;
+      u->endfile = AT_ENDFILE;	/* We are at the end */
+      break;
+
+    seek_error:
+      generate_error (ERROR_OS, NULL);
+      break;
+    }
+}
+
+
+/* new_unit()-- Open an unused unit */
+
+void
+new_unit (unit_flags * flags)
+{
+  unit_t *u;
+  stream *s;
+  char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
+
+  /* Change unspecifieds to defaults */
+
+  if (flags->access == ACCESS_UNSPECIFIED)
+    flags->access = ACCESS_SEQUENTIAL;
+
+  if (flags->action == ACTION_UNSPECIFIED)
+    flags->action = ACTION_READWRITE;	/* Processor dependent */
+
+  if (flags->form == FORM_UNSPECIFIED)
+    flags->form = (flags->access == ACCESS_SEQUENTIAL)
+      ? FORM_FORMATTED : FORM_UNFORMATTED;
+
+
+  if (flags->delim == DELIM_UNSPECIFIED)
+    flags->delim = DELIM_NONE;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (ERROR_OPTION_CONFLICT,
+			  "DELIM parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto cleanup;
+	}
+    }
+
+  if (flags->blank == BLANK_UNSPECIFIED)
+    flags->blank = BLANK_NULL;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (ERROR_OPTION_CONFLICT,
+			  "BLANK parameter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto cleanup;
+	}
+    }
+
+  if (flags->pad == PAD_UNSPECIFIED)
+    flags->pad = PAD_YES;
+  else
+    {
+      if (flags->form == FORM_UNFORMATTED)
+	{
+	  generate_error (ERROR_OPTION_CONFLICT,
+			  "PAD paramter conflicts with UNFORMATTED form in "
+			  "OPEN statement");
+	  goto cleanup;
+	}
+    }
+
+  if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
+   {
+     generate_error (ERROR_OPTION_CONFLICT,
+                     "ACCESS parameter conflicts with SEQUENTIAL access in "
+                     "OPEN statement");
+     goto cleanup;
+   }
+  else
+   if (flags->position == POSITION_UNSPECIFIED)
+     flags->position = POSITION_ASIS;
+
+
+  if (flags->status == STATUS_UNSPECIFIED)
+    flags->status = STATUS_UNKNOWN;
+
+  /* Checks */
+
+  if (flags->access == ACCESS_DIRECT && ioparm.recl_in == 0)
+    {
+      generate_error (ERROR_MISSING_OPTION,
+		      "Missing RECL parameter in OPEN statement");
+      goto cleanup;
+    }
+
+  if (ioparm.recl_in != 0 && ioparm.recl_in <= 0)
+    {
+      generate_error (ERROR_BAD_OPTION,
+		      "RECL parameter is non-positive in OPEN statement");
+      goto cleanup;
+    }
+
+  switch (flags->status)
+    {
+    case STATUS_SCRATCH:
+      if (ioparm.file == NULL)
+	break;
+
+      generate_error (ERROR_BAD_OPTION,
+		      "FILE parameter must not be present in OPEN statement");
+      return;
+
+    case STATUS_OLD:
+    case STATUS_NEW:
+    case STATUS_REPLACE:
+    case STATUS_UNKNOWN:
+      if (ioparm.file != NULL)
+	break;
+
+      ioparm.file = tmpname;
+      ioparm.file_len = sprintf(ioparm.file, "fort.%d", ioparm.unit);
+      break;
+
+    default:
+      internal_error ("new_unit(): Bad status");
+    }
+
+  /* Make sure the file isn't already open someplace else */
+
+  if (find_file () != NULL)
+    {
+      generate_error (ERROR_ALREADY_OPEN, NULL);
+      goto cleanup;
+    }
+
+  /* Open file */
+
+  s = open_external (flags->action, flags->status);
+  if (s == NULL)
+    {
+      generate_error (ERROR_OS, NULL);
+      goto cleanup;
+    }
+
+  if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
+    flags->status = STATUS_OLD;
+
+  /* Create the unit structure */
+
+  u = get_mem (sizeof (unit_t) + ioparm.file_len);
+
+  u->unit_number = ioparm.unit;
+  u->s = s;
+  u->flags = *flags;
+
+  /* Unspecified recl ends up with a processor dependent value */
+
+  u->recl = (ioparm.recl_in != 0) ? ioparm.recl_in : DEFAULT_RECL;
+  u->last_record = 0;
+  u->current_record = 0;
+
+  /* If the file is direct access, calculate the maximum record number
+   * via a division now instead of letting the multiplication overflow
+   * later. */
+
+  if (flags->access == ACCESS_DIRECT)
+    u->maxrec = g.max_offset / u->recl;
+
+  memmove (u->file, ioparm.file, ioparm.file_len);
+  u->file_len = ioparm.file_len;
+
+  insert_unit (u);
+
+  /* The file is now connected.  Errors after this point leave the
+   * file connected.  Curiously, the standard requires that the
+   * position specifier be ignored for new files so a newly connected
+   * file starts out that the initial point.  We still need to figure
+   * out if the file is at the end or not. */
+
+  test_endfile (u);
+
+cleanup:
+
+  /* Free memory associated with a temporary filename */
+
+  if (flags->status == STATUS_SCRATCH)
+    free_mem (ioparm.file);
+}
+
+
+/* already_open()-- Open a unit which is already open.  This involves
+ * changing the modes or closing what is there now and opening the new
+ * file. */
+
+static void
+already_open (unit_t * u, unit_flags * flags)
+{
+
+  if (ioparm.file == NULL)
+    {
+      edit_modes (u, flags);
+      return;
+    }
+
+  /* If the file is connected to something else, close it and open a
+   * new unit */
+
+  if (!compare_file_filename (u->s, ioparm.file, ioparm.file_len))
+    {
+      if (close_unit (u))
+	{
+	  generate_error (ERROR_OS, "Error closing file in OPEN statement");
+	  return;
+	}
+
+      new_unit (flags);
+      return;
+    }
+
+  edit_modes (u, flags);
+}
+
+
+/*************/
+/* open file */
+
+void
+st_open (void)
+{
+  unit_flags flags;
+  unit_t *u = NULL;
+ 
+  library_start ();
+
+  /* Decode options */
+
+  flags.access = (ioparm.access == NULL) ? ACCESS_UNSPECIFIED :
+    find_option (ioparm.access, ioparm.access_len, access_opt,
+		 "Bad ACCESS parameter in OPEN statement");
+
+  flags.action = (ioparm.action == NULL) ? ACTION_UNSPECIFIED :
+    find_option (ioparm.action, ioparm.action_len, action_opt,
+		 "Bad ACTION parameter in OPEN statement");
+
+  flags.blank = (ioparm.blank == NULL) ? BLANK_UNSPECIFIED :
+    find_option (ioparm.blank, ioparm.blank_len, blank_opt,
+		 "Bad BLANK parameter in OPEN statement");
+
+  flags.delim = (ioparm.delim == NULL) ? DELIM_UNSPECIFIED :
+    find_option (ioparm.delim, ioparm.delim_len, delim_opt,
+		 "Bad DELIM parameter in OPEN statement");
+
+  flags.pad = (ioparm.pad == NULL) ? PAD_UNSPECIFIED :
+    find_option (ioparm.pad, ioparm.pad_len, pad_opt,
+		 "Bad PAD parameter in OPEN statement");
+
+  flags.form = (ioparm.form == NULL) ? FORM_UNSPECIFIED :
+    find_option (ioparm.form, ioparm.form_len, form_opt,
+		 "Bad FORM parameter in OPEN statement");
+
+  flags.position = (ioparm.position == NULL) ? POSITION_UNSPECIFIED :
+    find_option (ioparm.position, ioparm.position_len, position_opt,
+		 "Bad POSITION parameter in OPEN statement");
+
+  flags.status = (ioparm.status == NULL) ? STATUS_UNSPECIFIED :
+    find_option (ioparm.status, ioparm.status_len, status_opt,
+		 "Bad STATUS parameter in OPEN statement");
+
+  if (ioparm.unit < 0)
+    generate_error (ERROR_BAD_OPTION, "Bad unit number in OPEN statement");
+
+  if (flags.position != POSITION_UNSPECIFIED &&
+      u->flags.access == ACCESS_DIRECT)
+    generate_error (ERROR_BAD_OPTION,
+		    "Cannot use POSITION with direct access files");
+
+  if (flags.position == POSITION_UNSPECIFIED)
+    flags.position = POSITION_ASIS;
+
+  if (ioparm.library_return != LIBRARY_OK)
+    return;
+
+  u = find_unit (ioparm.unit);
+
+  if (u == NULL)
+    new_unit (&flags);
+  else
+    already_open (u, &flags);
+
+  library_end ();
+}