Merge tree-ssa-20020619-branch into mainline.

From-SVN: r81764

10 files changed, 2256 insertions, 0 deletions

diff --git a/libgfortran/runtime/environ.c b/libgfortran/runtime/environ.c
new file mode 100644
index 0000000..7141961
--- /dev/null
+++ b/libgfortran/runtime/environ.c
@@ -0,0 +1,678 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor 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.
+
+Libgfor 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 libgfor; 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 <string.h>
+#include <stdlib.h>
+#include <ctype.h>
+
+#include "libgfortran.h"
+#include "../io/io.h"
+
+
+/* Environment scanner.  Examine the environment for controlling minor
+ * aspects of the program's execution.  Our philosophy here that the
+ * environment should not prevent the program from running, so an
+ * environment variable with a messed-up value will be interpreted in
+ * the default way.
+ *
+ * Most of the environment is checked early in the startup sequence,
+ * but other variables are checked during execution of the user's
+ * program. */
+
+options_t options;
+
+extern char **environ;
+
+typedef struct variable
+{
+  const char *name;
+  int value, *var;
+  void (*init) (struct variable *);
+  void (*show) (struct variable *);
+  const char *desc;
+  int bad;
+}
+variable;
+
+
+/* print_spaces()-- Print a particular number of spaces */
+
+static void
+print_spaces (int n)
+{
+  char buffer[80];
+  int i;
+
+  if (n <= 0)
+    return;
+
+  for (i = 0; i < n; i++)
+    buffer[i] = ' ';
+
+  buffer[i] = '\0';
+
+  st_printf (buffer);
+}
+
+
+/* var_source()-- Return a string that describes where the value of a
+ * variable comes from */
+
+static const char *
+var_source (variable * v)
+{
+
+  if (getenv (v->name) == NULL)
+    return "Default";
+
+  if (v->bad)
+    return "Bad    ";
+
+  return "Set    ";
+}
+
+
+/* init_integer()-- Initialize an integer environment variable */
+
+static void
+init_integer (variable * v)
+{
+  char *p, *q;
+
+  p = getenv (v->name);
+  if (p == NULL)
+    goto set_default;
+
+  for (q = p; *q; q++)
+    if (!isdigit (*q))
+      {
+	v->bad = 1;
+	goto set_default;
+      }
+
+  *v->var = atoi (p);
+  return;
+
+set_default:
+  *v->var = v->value;
+  return;
+}
+
+
+/* show_integer()-- Show an integer environment variable */
+
+static void
+show_integer (variable * v)
+{
+
+  st_printf ("%s  %d\n", var_source (v), *v->var);
+}
+
+
+/* init_boolean()-- Initialize a boolean environment variable.  We
+ * only look at the first letter of the variable. */
+
+static void
+init_boolean (variable * v)
+{
+  char *p;
+
+  p = getenv (v->name);
+  if (p == NULL)
+    goto set_default;
+
+  if (*p == '1' || *p == 'Y' || *p == 'y')
+    {
+      *v->var = 1;
+      return;
+    }
+
+  if (*p == '0' || *p == 'N' || *p == 'n')
+    {
+      *v->var = 0;
+      return;
+    }
+
+  v->bad = 1;
+
+set_default:
+  *v->var = v->value;
+  return;
+}
+
+
+/* show_boolean()-- Show a boolean environment variable */
+
+static void
+show_boolean (variable * v)
+{
+
+  st_printf ("%s  %s\n", var_source (v), *v->var ? "Yes" : "No");
+}
+
+
+/* init_mem()-- Initialize environment variables that have to do with
+ * how memory from an ALLOCATE statement is filled.  A single flag
+ * enables filling and a second variable gives the value that is used
+ * to initialize the memory. */
+
+static void
+init_mem (variable * v)
+{
+  int offset, n;
+  char *p;
+
+  p = getenv (v->name);
+
+  options.allocate_init_flag = 0;	/* The default */
+
+  if (p == NULL)
+    return;
+
+  if (strcasecmp (p, "NONE") == 0)
+    return;
+
+  /* IEEE-754 Quiet Not-a-Number that will work for single and double
+   * precision.  Look for the 'f95' mantissa in debug dumps. */
+
+  if (strcasecmp (p, "NaN") == 0)
+    {
+      options.allocate_init_flag = 1;
+      options.allocate_init_value = 0xfff80f95;
+      return;
+    }
+
+  /* Interpret the string as a hexadecimal constant */
+
+  n = 0;
+  while (*p)
+    {
+      if (!isxdigit (*p))
+	{
+	  v->bad = 1;
+	  return;
+	}
+
+      offset = '0';
+      if (islower (*p))
+	offset = 'a';
+      if (isupper (*p))
+	offset = 'A';
+
+      n = (n << 4) | (*p++ - offset);
+    }
+
+  options.allocate_init_flag = 1;
+  options.allocate_init_value = n;
+}
+
+
+static void
+show_mem (variable * v)
+{
+  char *p;
+
+  p = getenv (v->name);
+
+  st_printf ("%s  ", var_source (v));
+
+  if (options.allocate_init_flag)
+    st_printf ("0x%x", options.allocate_init_value);
+
+  st_printf ("\n");
+}
+
+
+static void
+init_sep (variable * v)
+{
+  int seen_comma;
+  char *p;
+
+  p = getenv (v->name);
+  if (p == NULL)
+    goto set_default;
+
+  v->bad = 1;
+  options.separator = p;
+  options.separator_len = strlen (p);
+
+  /* Make sure the separator is valid */
+
+  if (options.separator_len == 0)
+    goto set_default;
+  seen_comma = 0;
+
+  while (*p)
+    {
+      if (*p == ',')
+	{
+	  if (seen_comma)
+	    goto set_default;
+	  seen_comma = 1;
+	  p++;
+	  continue;
+	}
+
+      if (*p++ != ' ')
+	goto set_default;
+    }
+
+  v->bad = 0;
+  return;
+
+set_default:
+  options.separator = " ";
+  options.separator_len = 1;
+}
+
+
+static void
+show_sep (variable * v)
+{
+
+  st_printf ("%s  \"%s\"\n", var_source (v), options.separator);
+}
+
+
+static void
+init_string (variable * v)
+{
+}
+
+static void
+show_string (variable * v)
+{
+  const char *p;
+
+  p = getenv (v->name);
+  if (p == NULL)
+    p = "";
+
+  st_printf ("%s  \"%s\"\n", var_source (v), p);
+}
+
+
+/* Structure for associating names and values.  */
+
+typedef struct
+{
+  const char *name;
+  int value;
+}
+choice;
+
+
+enum
+{ FP_ROUND_NEAREST, FP_ROUND_UP, FP_ROUND_DOWN, FP_ROUND_ZERO };
+
+static choice rounding[] = {
+  {"NEAREST", FP_ROUND_NEAREST},
+  {"UP", FP_ROUND_UP},
+  {"DOWN", FP_ROUND_DOWN},
+  {"ZERO", FP_ROUND_ZERO},
+  {NULL}
+}, precision[] =
+{
+  {
+  "24", 1}
+  ,
+  {
+  "53", 2}
+  ,
+  {
+  "64", 0}
+  ,
+  {
+  NULL}
+}
+
+, signal_choices[] =
+{
+  {
+  "IGNORE", 1}
+  ,
+  {
+  "ABORT", 0}
+  ,
+  {
+  NULL}
+};
+
+
+static void
+init_choice (variable * v, choice * c)
+{
+  char *p;
+
+  p = getenv (v->name);
+  if (p == NULL)
+    goto set_default;
+
+  for (; c->name; c++)
+    if (strcasecmp (c->name, p) == 0)
+      break;
+
+  if (c->name == NULL)
+    {
+      v->bad = 1;
+      goto set_default;
+    }
+
+  *v->var = c->value;
+  return;
+
+set_default:
+  *v->var = v->value;
+}
+
+
+static void
+show_choice (variable * v, choice * c)
+{
+
+  st_printf ("%s  ", var_source (v));
+
+  for (; c->name; c++)
+    if (c->value == *v->var)
+      break;
+
+  if (c->name)
+    st_printf ("%s\n", c->name);
+  else
+    st_printf ("(Unknown)\n");
+
+}
+
+
+static void
+init_round (variable * v)
+{
+  init_choice (v, rounding);
+}
+static void
+show_round (variable * v)
+{
+  show_choice (v, rounding);
+}
+
+static void
+init_precision (variable * v)
+{
+  init_choice (v, precision);
+}
+static void
+show_precision (variable * v)
+{
+  show_choice (v, precision);
+}
+
+static void
+init_signal (variable * v)
+{
+  init_choice (v, signal_choices);
+}
+static void
+show_signal (variable * v)
+{
+  show_choice (v, signal_choices);
+}
+
+
+static variable variable_table[] = {
+  {"GFORTRAN_STDIN_UNIT", 5, &options.stdin_unit, init_integer, show_integer,
+   "Unit number that will be preconnected to standard input\n"
+   "(No preconnection if negative)"},
+
+  {"GFORTRAN_STDOUT_UNIT", 6, &options.stdout_unit, init_integer,
+   show_integer,
+   "Unit number that will be preconnected to standard output\n"
+   "(No preconnection if negative)"},
+
+  {"GFORTRAN_USE_STDERR", 1, &options.use_stderr, init_boolean,
+   show_boolean,
+   "Sends library output to standard error instead of standard output."},
+
+  {"GFORTRAN_TMPDIR", 0, NULL, init_string, show_string,
+   "Directory for scratch files.  Overrides the TMP environment variable\n"
+   "If TMP is not set " DEFAULT_TEMPDIR " is used."},
+
+  {"GFORTRAN_UNBUFFERED_ALL", 0, &options.all_unbuffered, init_boolean,
+   show_boolean,
+   "If TRUE, all output is unbuffered.  This will slow down large writes "
+   "but can be\nuseful for forcing data to be displayed immediately."},
+
+  {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
+   "If TRUE, print filename and line number where runtime errors happen."},
+
+/* GFORTRAN_NAME_xx (where xx is a unit number) gives the names of files
+ * preconnected to those units. */
+
+/* GFORTRAN_UNBUFFERED_xx (where xx is a unit number) gives a boolean that is used
+ * to turn off buffering for that unit. */
+
+  {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
+   "Print optional plus signs in numbers where permitted.  Default FALSE."},
+
+  {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
+   init_integer, show_integer,
+   "Default maximum record length for sequential files.  Most useful for\n"
+   "adjusting line length of preconnected units.  Default "
+   stringize (DEFAULT_RECL)},
+
+  {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
+   "Separatator to use when writing list output.  May contain any number of "
+   "spaces\nand at most one comma.  Default is a single space."},
+
+  /* Memory related controls */
+
+  {"GFORTRAN_MEM_INIT", 0, NULL, init_mem, show_mem,
+   "How to initialize allocated memory.  Default value is NONE for no "
+   "initialization\n(faster), NAN for a Not-a-Number with the mantissa "
+   "0x40f95 or a custom\nhexadecimal value"},
+
+  {"GFORTRAN_MEM_CHECK", 0, &options.mem_check, init_boolean, show_boolean,
+   "Whether memory still allocated will be reported when the program ends."},
+
+  /* Signal handling (Unix).  */
+
+  {"GFORTRAN_SIGHUP", 0, &options.sighup, init_signal, show_signal,
+   "Whether the program will IGNORE or ABORT on SIGHUP."},
+
+  {"GFORTRAN_SIGINT", 0, &options.sigint, init_signal, show_signal,
+   "Whether the program will IGNORE or ABORT on SIGINT."},
+
+  /* Floating point control */
+
+  {"GFORTRAN_FPU_ROUND", 0, &options.fpu_round, init_round, show_round,
+   "Set floating point rounding.  Values are NEAREST, UP, DOWN, ZERO."},
+
+  {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision, init_precision,
+   show_precision,
+   "Precision of intermediate results.  Values are 24, 53 and 64."},
+
+  {"GFORTRAN_FPU_INVALID", 1, &options.fpu_invalid, init_boolean,
+   show_boolean,
+   "Raise a floating point exception on invalid FP operation."},
+
+  {"GFORTRAN_FPU_DENORMAL", 1, &options.fpu_denormal, init_boolean,
+   show_boolean,
+   "Raise a floating point exception when denormal numbers are encountered."},
+
+  {"GFORTRAN_FPU_ZERO", 0, &options.fpu_zerodiv, init_boolean, show_boolean,
+   "Raise a floating point exception when dividing by zero."},
+
+  {"GFORTRAN_FPU_OVERFLOW", 0, &options.fpu_overflow, init_boolean,
+   show_boolean,
+   "Raise a floating point exception on overflow."},
+
+  {"GFORTRAN_FPU_UNDERFLOW", 0, &options.fpu_underflow, init_boolean,
+   show_boolean,
+   "Raise a floating point exception on underflow."},
+
+  {"GFORTRAN_FPU_PRECISION", 0, &options.fpu_precision_loss, init_boolean,
+   show_boolean,
+   "Raise a floating point exception on precision loss."},
+
+  {NULL}
+};
+
+
+/* init_variables()-- Initialize most runtime variables from
+ * environment variables. */
+
+void
+init_variables (void)
+{
+  variable *v;
+
+  for (v = variable_table; v->name; v++)
+    v->init (v);
+}
+
+
+/* check_buffered()-- Given an unit number n, determine if an override
+ * for the stream exists.  Returns zero for unbuffered, one for
+ * buffered or two for not set. */
+
+int
+check_buffered (int n)
+{
+  char name[40];
+  variable v;
+  int rv;
+
+  if (options.all_unbuffered)
+    return 0;
+
+  strcpy (name, "GFORTRAN_UNBUFFERED_");
+  strcat (name, itoa (n));
+
+  v.name = name;
+  v.value = 2;
+  v.var = &rv;
+
+  init_boolean (&v);
+
+  return rv;
+}
+
+
+/* pattern_scan()-- Given an environment string, check that the name
+ * has the same name as the pattern followed by an integer.  On a
+ * match, a pointer to the value is returned and the integer pointed
+ * to by n is updated.  Returns NULL on no match. */
+
+static char *
+pattern_scan (char *env, const char *pattern, int *n)
+{
+  char *p;
+  size_t len;
+
+  len = strlen (pattern);
+  if (strncasecmp (env, pattern, len) != 0)
+    return NULL;
+  p = env + len;
+
+  if (!isdigit (*p))
+    return NULL;
+
+  while (isdigit (*p))
+    p++;
+
+  if (*p != '=')
+    return NULL;
+
+  *p = '\0';
+  *n = atoi (env + len);
+  *p++ = '=';
+
+  return p;
+}
+
+
+void
+show_variables (void)
+{
+  char *p, **e;
+  variable *v;
+  int n;
+/* TODO: print version number.  */
+  st_printf ("GNU Fortran 95 runtime library version "
+	     "UNKNOWN" "\n\n");
+
+  st_printf ("Environment variables:\n");
+  st_printf ("----------------------\n");
+
+  for (v = variable_table; v->name; v++)
+    {
+      n = st_printf ("%s", v->name);
+      print_spaces (25 - n);
+
+      if (v->show == show_integer)
+	st_printf ("Integer ");
+      else if (v->show == show_boolean)
+	st_printf ("Boolean ");
+      else
+	st_printf ("String  ");
+
+      v->show (v);
+      st_printf ("%s\n\n", v->desc);
+    }
+
+  st_printf ("\nDefault unit names (GFORTRAN_NAME_x):\n");
+
+  for (e = environ; *e; e++)
+    {
+      p = pattern_scan (*e, "GFORTRAN_NAME_", &n);
+      if (p == NULL)
+	continue;
+      st_printf ("GFORTRAN_NAME_%d         %s\n", n, p);
+    }
+
+  st_printf ("\nUnit buffering overrides (GFORTRAN_UNBUFFERED_x):\n");
+  for (e = environ; *e; e++)
+    {
+      p = pattern_scan (*e, "GFORTRAN_UNBUFFERED_", &n);
+      if (p == NULL)
+	continue;
+
+      st_printf ("GFORTRAN_UNBUFFERED_%d = %s\n", n, p);
+    }
+
+  /* System error codes */
+
+  st_printf ("\nRuntime error codes:");
+  st_printf ("\n--------------------\n");
+
+  for (n = ERROR_FIRST + 1; n < ERROR_LAST; n++)
+    if (n < 0 || n > 9)
+      st_printf ("%d  %s\n", n, translate_error (n));
+    else
+      st_printf (" %d  %s\n", n, translate_error (n));
+
+  st_printf ("\nCommand line arguments:\n");
+  st_printf ("  --help               Print this list\n");
+
+  /* st_printf("  --resume <dropfile>  Resume program execution from dropfile\n"); */
+
+  sys_exit (0);
+}
diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
new file mode 100644
index 0000000..8cd980d
--- /dev/null
+++ b/libgfortran/runtime/error.c
@@ -0,0 +1,538 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor 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.
+
+Libgfor 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 libgfor; 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 <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <float.h>
+
+#include "libgfortran.h"
+#include "../io/io.h"
+
+/* Error conditions.  The tricky part here is printing a message when
+ * it is the I/O subsystem that is severely wounded.  Our goal is to
+ * try and print something making the fewest assumptions possible,
+ * then try to clean up before actually exiting.
+ *
+ * The following exit conditions are defined:
+ * 0    Normal program exit.
+ * 1    Terminated because of operating system error.
+ * 2    Error in the runtime library
+ * 3    Internal error in runtime library
+ * 4    Error during error processing (very bad)
+ *
+ * Other error returns are reserved for the STOP statement with a numeric code.
+ */
+
+/* locus variables.  These are optionally set by a caller before a
+ * library subroutine is called.  They are always cleared on exit so
+ * that files that report loci and those that do not can be linked
+ * together without reporting an erroneous position. */
+
+char *filename;
+unsigned line;
+
+static char buffer[32];		/* buffer for integer/ascii conversions */
+
+/* rtoa()-- Real to ascii conversion for base 10 and below.
+ * Returns a pointer to a static buffer.  */
+
+char *
+rtoa (double f, int length, int oprec)
+{
+  double n = f;
+  double fval, minval;
+  int negative, prec;
+  unsigned k;
+  char formats[16];
+
+  prec = 0;
+  negative = 0;
+  if (n < 0.0)
+    {
+      negative = 1;
+      n = -n;
+    }
+
+  if (length >= 8)
+    minval = FLT_MIN;
+  else
+    minval = DBL_MIN;
+
+
+  if (n <= minval)
+    {
+      buffer[0] = '0';
+      buffer[1] = '.';
+      for (k = 2; k < 28 ; k++)
+        buffer[k] = '0';
+      buffer[k+1] = '\0';
+      return buffer;
+    }
+  fval = n;
+  while (fval > 1.0)
+    {
+      fval = fval / 10.0;
+      prec ++;
+    }
+
+  prec = sizeof (buffer) - 2 - prec;
+  if (prec > 20)
+     prec = 20;
+  prec = prec > oprec ? oprec : prec ;
+
+  if (negative)
+     sprintf (formats, "-%%.%df", prec);
+  else
+     sprintf (formats, "%%.%df", prec);
+
+  sprintf (buffer, formats, n);
+  return buffer;
+}
+
+
+/* Returns a pointer to a static buffer. */
+
+char *
+itoa (int64_t n)
+{
+  int negative;
+  char *p;
+
+  if (n == 0)
+    {
+      buffer[0] = '0';
+      buffer[1] = '\0';
+      return buffer;
+    }
+
+  negative = 0;
+  if (n < 0)
+    {
+      negative = 1;
+      n = -n;
+    }
+
+  p = buffer + sizeof (buffer) - 1;
+  *p-- = '\0';
+
+  while (n != 0)
+    {
+      *p-- = '0' + (n % 10);
+      n /= 10;
+    }
+
+  if (negative)
+    *p-- = '-';
+  return ++p;
+}
+
+
+/* xtoa()-- Integer to hexadecimal conversion.  Returns a pointer to a
+ * static buffer. */
+
+char *
+xtoa (uint64_t n)
+{
+  int digit;
+  char *p;
+
+  if (n == 0)
+    {
+      buffer[0] = '0';
+      buffer[1] = '\0';
+      return buffer;
+    }
+
+  p = buffer + sizeof (buffer) - 1;
+  *p-- = '\0';
+
+  while (n != 0)
+    {
+      digit = n & 0xF;
+      if (digit > 9)
+	digit += 'A' - '0' - 10;
+
+      *p-- = '0' + digit;
+      n >>= 4;
+    }
+
+  return ++p;
+}
+
+
+/* st_printf()-- simple printf() function for streams that handles the
+ * formats %d, %s and %c.  This function handles printing of error
+ * messages that originate within the library itself, not from a user
+ * program. */
+
+int
+st_printf (const char *format, ...)
+{
+  int count, total;
+  va_list arg;
+  char *p, *q;
+  stream *s;
+
+  total = 0;
+  s = init_error_stream ();
+  va_start (arg, format);
+
+  for (;;)
+    {
+      count = 0;
+
+      while (format[count] != '%' && format[count] != '\0')
+	count++;
+
+      if (count != 0)
+	{
+	  p = salloc_w (s, &count);
+	  memmove (p, format, count);
+	  sfree (s);
+	}
+
+      total += count;
+      format += count;
+      if (*format++ == '\0')
+	break;
+
+      switch (*format)
+	{
+	case 'c':
+	  count = 1;
+
+	  p = salloc_w (s, &count);
+	  *p = (char) va_arg (arg, int);
+
+	  sfree (s);
+	  break;
+
+	case 'd':
+	  q = itoa (va_arg (arg, int));
+	  count = strlen (q);
+
+	  p = salloc_w (s, &count);
+	  memmove (p, q, count);
+	  sfree (s);
+	  break;
+
+	case 'x':
+	  q = xtoa (va_arg (arg, unsigned));
+	  count = strlen (q);
+
+	  p = salloc_w (s, &count);
+	  memmove (p, q, count);
+	  sfree (s);
+	  break;
+
+	case 's':
+	  q = va_arg (arg, char *);
+	  count = strlen (q);
+
+	  p = salloc_w (s, &count);
+	  memmove (p, q, count);
+	  sfree (s);
+	  break;
+
+	case '\0':
+	  return total;
+
+	default:
+	  count = 2;
+	  p = salloc_w (s, &count);
+	  p[0] = format[-1];
+	  p[1] = format[0];
+	  sfree (s);
+	  break;
+	}
+
+      total += count;
+      format++;
+    }
+
+  va_end (arg);
+  return total;
+}
+
+
+/* st_sprintf()-- Simple sprintf() for formatting memory buffers. */
+
+void
+st_sprintf (char *buffer, const char *format, ...)
+{
+  va_list arg;
+  char c, *p;
+  int count;
+
+  va_start (arg, format);
+
+  for (;;)
+    {
+      c = *format++;
+      if (c != '%')
+	{
+	  *buffer++ = c;
+	  if (c == '\0')
+	    break;
+	  continue;
+	}
+
+      c = *format++;
+      switch (c)
+	{
+	case 'c':
+	  *buffer++ = (char) va_arg (arg, int);
+	  break;
+
+	case 'd':
+	  p = itoa (va_arg (arg, int));
+	  count = strlen (p);
+
+	  memcpy (buffer, p, count);
+	  buffer += count;
+	  break;
+
+	case 's':
+	  p = va_arg (arg, char *);
+	  count = strlen (p);
+
+	  memcpy (buffer, p, count);
+	  buffer += count;
+	  break;
+
+	default:
+	  *buffer++ = c;
+	}
+    }
+
+  va_end (arg);
+}
+
+
+/* show_locus()-- Print a line number and filename describing where
+ * something went wrong */
+
+void
+show_locus (void)
+{
+
+  if (!options.locus || filename == NULL)
+    return;
+
+  st_printf ("At line %d of file %s\n", line, filename);
+}
+
+
+/* recursion_check()-- It's possible for additional errors to occur
+ * during fatal error processing.  We detect this condition here and
+ * exit with code 4 immediately. */
+
+#define MAGIC 0x20DE8101
+
+static void
+recursion_check (void)
+{
+  static int magic = 0;
+
+  if (magic == MAGIC)
+    sys_exit (4);		/* Don't even try to print something at this point */
+
+  magic = MAGIC;
+}
+
+
+/* os_error()-- Operating system error.  We get a message from the
+ * operating system, show it and leave.  Some operating system errors
+ * are caught and processed by the library.  If not, we come here. */
+
+void
+os_error (const char *message)
+{
+
+  recursion_check ();
+
+  show_locus ();
+  st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
+
+  sys_exit (1);
+}
+
+
+/* void runtime_error()-- These are errors associated with an
+ * invalid fortran program. */
+
+void
+runtime_error (const char *message)
+{
+
+  recursion_check ();
+
+  show_locus ();
+  st_printf ("Fortran runtime error: %s\n", message);
+
+  sys_exit (2);
+}
+
+
+/* void internal_error()-- These are this-can't-happen errors
+ * that indicate something deeply wrong. */
+
+void
+internal_error (const char *message)
+{
+
+  recursion_check ();
+
+  show_locus ();
+  st_printf ("Internal Error: %s\n", message);
+  sys_exit (3);
+}
+
+
+/* translate_error()-- Given an integer error code, return a string
+ * describing the error. */
+
+const char *
+translate_error (int code)
+{
+  const char *p;
+
+  switch (code)
+    {
+    case ERROR_EOR:
+      p = "End of record";
+      break;
+
+    case ERROR_END:
+      p = "End of file";
+      break;
+
+    case ERROR_OK:
+      p = "Successful return";
+      break;
+
+    case ERROR_OS:
+      p = "Operating system error";
+      break;
+
+    case ERROR_BAD_OPTION:
+      p = "Bad statement option";
+      break;
+
+    case ERROR_MISSING_OPTION:
+      p = "Missing statement option";
+      break;
+
+    case ERROR_OPTION_CONFLICT:
+      p = "Conflicting statement options";
+      break;
+
+    case ERROR_ALREADY_OPEN:
+      p = "File already opened in another unit";
+      break;
+
+    case ERROR_BAD_UNIT:
+      p = "Unattached unit";
+      break;
+
+    case ERROR_FORMAT:
+      p = "FORMAT error";
+      break;
+
+    case ERROR_BAD_ACTION:
+      p = "Incorrect ACTION specified";
+      break;
+
+    case ERROR_ENDFILE:
+      p = "Read past ENDFILE record";
+      break;
+
+    case ERROR_BAD_US:
+      p = "Corrupt unformatted sequential file";
+      break;
+
+    case ERROR_READ_VALUE:
+      p = "Bad value during read";
+      break;
+
+    case ERROR_READ_OVERFLOW:
+      p = "Numeric overflow on read";
+      break;
+
+    default:
+      p = "Unknown error code";
+      break;
+    }
+
+  return p;
+}
+
+
+/* generate_error()-- Come here when an error happens.  This
+ * subroutine is called if it is possible to continue on after the
+ * error.  If an IOSTAT variable exists, we set it.  If the IOSTAT or
+ * ERR label is present, we return, otherwise we terminate the program
+ * after print a message.  The error code is always required but the
+ * message parameter can be NULL, in which case a string describing
+ * the most recent operating system error is used. */
+
+void
+generate_error (int family, const char *message)
+{
+
+  if (ioparm.iostat != NULL)
+    {
+      *ioparm.iostat = family;
+      return;
+    }
+
+  switch (family)
+    {
+    case ERROR_EOR:
+      ioparm.library_return = LIBRARY_EOR;
+      if (ioparm.eor != 0)
+	return;
+      break;
+
+    case ERROR_END:
+      ioparm.library_return = LIBRARY_END;
+      if (ioparm.end != 0)
+	return;
+      break;
+
+    default:
+      ioparm.library_return = LIBRARY_ERROR;
+      break;
+    }
+
+  if (ioparm.err != 0)
+    return;
+
+  /* Terminate the program */
+
+  if (message == NULL)
+    message =
+      (family == ERROR_OS) ? get_oserror () : translate_error (family);
+
+  runtime_error (message);
+}
diff --git a/libgfortran/runtime/in_pack_generic.c b/libgfortran/runtime/in_pack_generic.c
new file mode 100644
index 0000000..8af4f3f
--- /dev/null
+++ b/libgfortran/runtime/in_pack_generic.c
@@ -0,0 +1,123 @@
+/* Generic helper function for repacking arrays.
+   Copyright 2003 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+Ligbfor 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB.  If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <stdlib.h>
+#include <assert.h>
+#include <string.h>
+#include "libgfortran.h"
+
+void *
+internal_pack (gfc_array_char * source)
+{
+  index_type count[GFC_MAX_DIMENSIONS - 1];
+  index_type extent[GFC_MAX_DIMENSIONS - 1];
+  index_type stride[GFC_MAX_DIMENSIONS - 1];
+  index_type stride0;
+  index_type dim;
+  index_type ssize;
+  const char *src;
+  char *dest;
+  void *destptr;
+  int n;
+  int packed;
+  index_type size;
+
+  if (source->dim[0].stride == 0)
+    {
+      source->dim[0].stride = 1;
+      return source->data;
+    }
+
+  size = GFC_DESCRIPTOR_SIZE (source);
+  switch (size)
+    {
+    case 4:
+      return internal_pack_4 ((gfc_array_i4 *)source);
+
+    case 8:
+      return internal_pack_8 ((gfc_array_i8 *)source);
+    }
+
+  dim = GFC_DESCRIPTOR_RANK (source);
+  ssize = 1;
+  packed = 1;
+  for (n = 0; n < dim; n++)
+    {
+      count[n] = 0;
+      stride[n] = source->dim[n].stride;
+      extent[n] = source->dim[n].ubound + 1 - source->dim[n].lbound;
+      if (extent[n] <= 0)
+        {
+          /* Do nothing.  */
+          packed = 1;
+          break;
+        }
+
+      if (ssize != stride[n])
+        packed = 0;
+
+      ssize *= extent[n];
+    }
+
+  if (packed)
+    return source->data;
+
+   /* Allocate storage for the destination.  */
+  destptr = internal_malloc_size (ssize * size);
+  dest = (char *)destptr;
+  src = source->data;
+  stride0 = stride[0] * size;
+
+  while (src)
+    {
+      /* Copy the data.  */
+      memcpy(dest, src, size);
+      /* Advance to the next element.  */
+      dest += size;
+      src += stride0;
+      count[0]++;
+      /* Advance to the next source element.  */
+      n = 0;
+      while (count[n] == extent[n])
+        {
+          /* When we get to the end of a dimension, reset it and increment
+             the next dimension.  */
+          count[n] = 0;
+          /* We could precalculate these products, but this is a less
+             frequently used path so proabably not worth it.  */
+          src -= stride[n] * extent[n] * size;
+          n++;
+          if (n == dim)
+            {
+              src = NULL;
+              break;
+            }
+          else
+            {
+              count[n]++;
+              src += stride[n] * size;
+            }
+        }
+    }
+  return destptr;
+}
+
diff --git a/libgfortran/runtime/in_unpack_generic.c b/libgfortran/runtime/in_unpack_generic.c
new file mode 100644
index 0000000..82a6771
--- /dev/null
+++ b/libgfortran/runtime/in_unpack_generic.c
@@ -0,0 +1,120 @@
+/* Generic helper function for repacking arrays.
+   Copyright 2003 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+Ligbfor 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB.  If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <stdlib.h>
+#include <assert.h>
+#include <string.h>
+#include "libgfortran.h"
+
+void
+internal_unpack (gfc_array_char * d, const void * s)
+{
+  index_type count[GFC_MAX_DIMENSIONS - 1];
+  index_type extent[GFC_MAX_DIMENSIONS - 1];
+  index_type stride[GFC_MAX_DIMENSIONS - 1];
+  index_type stride0;
+  index_type dim;
+  index_type dsize;
+  char *dest;
+  const char *src;
+  int n;
+  int size;
+
+  dest = d->data;
+  /* This check may be redundant, but do it anyway.  */
+  if (s == dest || !s)
+    return;
+
+  size = GFC_DESCRIPTOR_SIZE (d);
+  switch (size)
+    {
+    case 4:
+      internal_unpack_4 ((gfc_array_i4 *)d, (const GFC_INTEGER_4 *)s);
+      return;
+
+    case 8:
+      internal_unpack_8 ((gfc_array_i8 *)d, (const GFC_INTEGER_8 *)s);
+      return;
+    }
+
+  if (d->dim[0].stride == 0)
+    d->dim[0].stride = 1;
+
+  dim = GFC_DESCRIPTOR_RANK (d);
+  dsize = 1;
+  for (n = 0; n < dim; n++)
+    {
+      count[n] = 0;
+      stride[n] = d->dim[n].stride;
+      extent[n] = d->dim[n].ubound + 1 - d->dim[n].lbound;
+      if (extent[n] <= 0)
+        abort ();
+
+      if (dsize == stride[n])
+        dsize *= extent[n];
+      else
+        dsize = 0;
+    }
+
+  src = s;
+
+  if (dsize != 0)
+    {
+      memcpy (dest, src, dsize * size);
+      return;
+    }
+
+  stride0 = stride[0] * size;
+
+  while (dest)
+    {
+      /* Copy the data.  */
+      memcpy (dest, src, size);
+      /* Advance to the next element.  */
+      src += size;
+      dest += stride0;
+      count[0]++;
+      /* Advance to the next source element.  */
+      n = 0;
+      while (count[n] == extent[n])
+        {
+          /* When we get to the end of a dimension, reset it and increment
+             the next dimension.  */
+          count[n] = 0;
+          /* We could precalculate these products, but this is a less
+             frequently used path so proabably not worth it.  */
+          dest -= stride[n] * extent[n] * size;
+          n++;
+          if (n == dim)
+            {
+              dest = NULL;
+              break;
+            }
+          else
+            {
+              count[n]++;
+              dest += stride[n] * size;
+            }
+        }
+    }
+}
+
diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c
new file mode 100644
index 0000000..60c032b
--- /dev/null
+++ b/libgfortran/runtime/main.c
@@ -0,0 +1,113 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Andy Vaught and Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor 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.
+
+Libgfor 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 libgfor; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <stddef.h>
+
+#include "libgfortran.h"
+
+/* This is the offset (in bytes) required to cast from logical(8)* to
+   logical(4)*. and still get the same result.  Will be 0 for little-endian
+   machines and 4 for big-endian machines.  */
+int l8_to_l4_offset;
+
+
+/* Figure out endianness for this machine.  */
+
+#define detetmine_endianness	prefix(determine_endianness)
+static void
+determine_endianness (void)
+{
+  union
+  {
+    GFC_LOGICAL_8 l8;
+    GFC_LOGICAL_4 l4[2];
+  } u;
+
+  u.l8 = 1;
+  if (u.l4[0])
+    l8_to_l4_offset = 0;
+  else if (u.l4[1])
+    l8_to_l4_offset = 1;
+  else
+    runtime_error ("Unable to determine machine endianness");
+}
+
+
+static int argc_save;
+static char **argv_save;
+
+/* Set the saved values of the command line arguments.  */
+
+void
+set_args (int argc, char **argv)
+{
+  argc_save = argc;
+  argv_save = argv;
+}
+
+/* Retrieve the saved values of the command line arguments.  */
+
+void
+get_args (int *argc, char ***argv)
+{
+
+  *argc = argc_save;
+  *argv = argv_save;
+}
+
+
+/* Initialize the runtime library.  */
+
+static void __attribute__((constructor))
+init (void)
+{
+  /* Figure out the machine endianness.  */
+  determine_endianness ();
+
+  /* Must be first */
+  init_variables ();
+
+  init_units ();
+
+#ifdef DEBUG
+  /* Check for special command lines.  */
+
+  if (argc > 1 && strcmp (argv[1], "--help") == 0)
+    show_variables ();
+
+/*  if (argc > 1 && strcmp(argv[1], "--resume") == 0) resume();  */
+#endif
+
+  memory_init ();
+}
+
+
+/* Cleanup the runtime library.  */
+
+static void __attribute__((destructor))
+cleanup ()
+{
+  close_units ();
+}
+
diff --git a/libgfortran/runtime/memory.c b/libgfortran/runtime/memory.c
new file mode 100644
index 0000000..ca5eb15
--- /dev/null
+++ b/libgfortran/runtime/memory.c
@@ -0,0 +1,312 @@
+/* Memory mamagement routines.
+   Copyright 2002 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+Libgfor 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB.  If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <stdlib.h>
+#include "libgfortran.h"
+
+/* If GFC_CLEAR_MEMORY is defined, the memory allocation routines will
+   return memory that is guaranteed to be set to zero.  This can have
+   a severe efficiency penalty, so it should never be set if good
+   performance is desired, but it can help when you're debugging code.  */
+#define GFC_CLEAR_MEMORY
+
+/* If GFC_CHECK_MEMORY is defined, we do some sanity checks at runtime.
+   This causes small overhead, but again, it also helps debugging.  */
+#define GFC_CHECK_MEMORY
+
+/* We use a double linked list of these structures to keep track of
+   the memory we allocate internally.  We could also use this for user
+   allocated memory (ALLOCATE/DEALLOCATE).  This should be stored in a
+   seperate list.  */
+#define malloc_t	prefix(malloc_t)
+typedef struct malloc_t
+{
+  int magic;
+  int marker;
+  struct malloc_t *prev, *next;
+
+  /* The start of the block.  */
+  void *data;
+}
+malloc_t;
+
+/* We try to make sure we don't get memory corruption by checking for
+   a magic number.  */
+#define GFC_MALLOC_MAGIC 0x4d353941	/* "G95M" */
+
+#define HEADER_SIZE offsetof (malloc_t, data)
+#define DATA_POINTER(pheader) (&((pheader)->data))
+#define DATA_HEADER(pdata) ((malloc_t *)((char *) (pdata) - HEADER_SIZE))
+
+/* The root of the circular double linked list for compiler generated
+   malloc calls.  */
+static malloc_t mem_root;
+
+
+void
+memory_init (void)
+{
+
+  /* The root should never be used directly, so don't set the magic.  */
+  mem_root.magic = 0;
+  mem_root.next = &mem_root;
+  mem_root.prev = &mem_root;
+  mem_root.marker = 0;
+}
+
+
+/* Doesn't actually do any cleaning up, just throws an error if something
+   has got out of sync somewhere.  */
+
+void
+runtime_cleanup (void)
+{
+  /* Make sure all memory we've allocated is freed on exit.  */
+  if (mem_root.next != &mem_root)
+    runtime_error ("Unfreed memory on program termination");
+}
+
+
+
+void *
+get_mem (size_t n)
+{
+  void *p;
+
+#ifdef GFC_CLEAR_MEMORY
+  p = (void *) calloc (n, 1);
+#else
+#define temp malloc
+#undef malloc
+  p = (void *) malloc (n);
+#define malloc temp
+#undef temp
+#endif
+  if (p == NULL)
+    os_error ("Memory allocation failed");
+
+  return p;
+}
+
+
+void
+free_mem (void *p)
+{
+
+  free (p);
+}
+
+
+/* Allocates a block of memory with a size of N bytes.  N does not
+   include the size of the header.  */
+
+static malloc_t *
+malloc_with_header (size_t n)
+{
+  malloc_t *newmem;
+
+  n = n + HEADER_SIZE;
+
+  newmem = (malloc_t *) get_mem (n);
+
+  if (newmem)
+    {
+      newmem->magic = GFC_MALLOC_MAGIC;
+      newmem->marker = 0;
+    }
+
+  return newmem;
+}
+
+
+/* Allocate memory for internal (compiler generated) use.  */
+
+void *
+internal_malloc_size (size_t size)
+{
+  malloc_t *newmem;
+
+  newmem = malloc_with_header (size);
+
+  if (!newmem)
+    os_error ("Out of memory.");
+
+  /* Add to end of list.  */
+  newmem->next = &mem_root;
+  newmem->prev = mem_root.prev;
+  mem_root.prev->next = newmem;
+  mem_root.prev = newmem;
+
+  return DATA_POINTER (newmem);
+}
+
+
+void *
+internal_malloc (GFC_INTEGER_4 size)
+{
+#ifdef GFC_CHECK_MEMORY
+  /* Under normal circumstances, this is _never_ going to happen!  */
+  if (size <= 0)
+    runtime_error ("Attempt to allocate a non-positive amount of memory.");
+
+#endif
+  return internal_malloc_size ((size_t) size);
+}
+
+
+void *
+internal_malloc64 (GFC_INTEGER_8 size)
+{
+#ifdef GFC_CHECK_MEMORY
+  /* Under normal circumstances, this is _never_ going to happen!  */
+  if (size <= 0)
+    runtime_error ("Attempt to allocate a non-positive amount of memory.");
+#endif
+  return internal_malloc_size ((size_t) size);
+}
+
+
+/* Free internally allocated memory.  Pointer is NULLified.  Also used to
+   free user allocated memory.  */
+/* TODO: keep a list of previously allocated blocks and reuse them.  */
+
+void
+internal_free (void *mem)
+{
+  malloc_t *m;
+
+  if (!mem)
+    runtime_error ("Internal: Possible double free of temporary.");
+
+  m = DATA_HEADER (mem);
+
+  if (m->magic != GFC_MALLOC_MAGIC)
+    runtime_error ("Internal: No magic memblock marker.  "
+		   "Possible memory corruption");
+
+  /* Move markers up the chain, so they don't get lost.  */
+  m->prev->marker += m->marker;
+  /* Remove from list.  */
+  m->prev->next = m->next;
+  m->next->prev = m->prev;
+
+  free (m);
+}
+
+
+/* User-allocate, one call for each member of the alloc-list of an
+   ALLOCATE statement. */
+
+static void
+allocate_size (void **mem, size_t size, GFC_INTEGER_4 * stat)
+{
+  malloc_t *newmem;
+
+  if (!mem)
+    runtime_error ("Internal: NULL mem pointer in ALLOCATE.");
+
+  newmem = malloc_with_header (size);
+  if (!newmem)
+    {
+      if (stat)
+	{
+	  *stat = 1;
+	  return;
+	}
+      else
+	runtime_error ("ALLOCATE: Out of memory.");
+    }
+
+  /* We don't keep a list of these at the moment, so just link to itself. */
+  newmem->next = newmem;
+  newmem->prev = newmem;
+
+  (*mem) = DATA_POINTER (newmem);
+
+  if (stat)
+    *stat = 0;
+}
+
+
+void
+allocate (void **mem, GFC_INTEGER_4 size, GFC_INTEGER_4 * stat)
+{
+
+  if (size < 0)
+    {
+      runtime_error ("Attempt to allocate negative amount of memory.  "
+		     "Possible integer overflow");
+      abort ();
+    }
+
+  allocate_size (mem, (size_t) size, stat);
+}
+
+
+void
+allocate64 (void **mem, GFC_INTEGER_8 size, GFC_INTEGER_4 * stat)
+{
+
+  if (size < 0)
+    {
+      runtime_error
+	("ALLOCATE64: Attempt to allocate negative amount of memory. "
+	 "Possible integer overflow");
+      abort ();
+    }
+
+  allocate_size (mem, (size_t) size, stat);
+}
+
+
+/* User-deallocate; pointer is NULLified. */
+
+void
+deallocate (void **mem, GFC_INTEGER_4 * stat)
+{
+
+  if (!mem)
+    runtime_error ("Internal: NULL mem pointer in ALLOCATE.");
+
+  if (!*mem)
+    {
+      if (stat)
+	{
+	  *stat = 1;
+	  return;
+	}
+      else
+	{
+	  runtime_error
+	    ("Internal: Attempt to DEALLOCATE unallocated memory.");
+	  abort ();
+	}
+    }
+
+  /* Just use the internal routine.  */
+  internal_free (*mem);
+  *mem = NULL;
+
+  if (stat)
+    *stat = 0;
+}
+
diff --git a/libgfortran/runtime/pause.c b/libgfortran/runtime/pause.c
new file mode 100644
index 0000000..9b8447f
--- /dev/null
+++ b/libgfortran/runtime/pause.c
@@ -0,0 +1,71 @@
+/* Implementation of the STOP statement.
+   Copyright 2002 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+Libgfor 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB.  If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <string.h>
+#include <stdio.h>
+
+#include "libgfortran.h"
+
+#define pause_numeric prefix(pause_numeric)
+#define pause_string prefix(pause_string)
+
+static void
+do_pause (void)
+{
+  char buff[4];
+  st_printf ("To resume execution, type go.  "
+	     "Other input will terminate the job.\n");
+
+  fgets(buff, 4, stdin);
+  if (strncmp(buff, "go\n", 3) != 0)
+    stop_numeric (-1);
+  st_printf ("RESUMED\n");
+}
+
+/* A numeric or blank STOP statement.  */
+void
+pause_numeric (GFC_INTEGER_4 code)
+{
+  show_locus ();
+
+  if (code == -1)
+    st_printf ("PAUSE\n");
+  else
+    st_printf ("PAUSE %d\n", (int)code);
+
+  do_pause ();
+}
+
+
+void
+pause_string (char *string, GFC_INTEGER_4 len)
+{
+  show_locus ();
+
+  st_printf ("PAUSE ");
+  while (len--)
+    st_printf ("%c", *(string++));
+  st_printf ("\n");
+
+  do_pause ();
+}
+
diff --git a/libgfortran/runtime/select.c b/libgfortran/runtime/select.c
new file mode 100644
index 0000000..5ee873a
--- /dev/null
+++ b/libgfortran/runtime/select.c
@@ -0,0 +1,125 @@
+/* Implement the SELECT statement for character variables.
+   Contributed by Andy Vaught
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor 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.
+
+Libgfor 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 libgfor; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "libgfortran.h"
+
+typedef struct
+{
+  char *low;
+  int low_len;
+  char *high;
+  int high_len;
+  void *address;
+}
+select_struct;
+
+
+#define select_string prefix(select_string)
+
+
+/* select_string()-- Given a selector string and a table of
+ * select_struct structures, return the address to jump to. */
+
+void *select_string (select_struct *table, int table_len, void *default_jump,
+                    const char *selector, int selector_len)
+{
+  select_struct *t;
+  int i, low, high, mid;
+
+  if (table_len == 0)
+    return default_jump;
+
+  /* Record the default address if present */
+
+  if (table->low == NULL && table->high == NULL)
+    {
+      default_jump = table->address;
+
+      table++;
+      table_len--;
+      if (table_len == 0)
+        return default_jump;
+    }
+
+  /* Try the high and low bounds if present. */
+
+  if (table->low == NULL)
+    {
+      if (compare_string (table->high_len, table->high,
+			        selector_len, selector) >= 0)
+        return table->address;
+
+      table++;
+      table_len--;
+      if (table_len == 0)
+        return default_jump;
+    }
+
+  t = table + table_len - 1;
+
+  if (t->high == NULL)
+    {
+      if (compare_string (t->low_len, t->low,
+			        selector_len, selector) <= 0)
+        return t->address;
+
+      table_len--;
+      if (table_len == 0)
+        return default_jump;
+    }
+
+  /* At this point, the only table entries are bounded entries.  Find
+     the right entry with a binary chop. */
+
+  low = -1;
+  high = table_len;
+
+  while (low + 1 < high)
+    {
+      mid = (low + high) / 2;
+
+      t = table + mid;
+      i = compare_string (t->low_len, t->low, selector_len, selector);
+
+      if (i == 0)
+        return t->address;
+
+      if (i < 0)
+        low = mid;
+      else
+        high = mid;
+    }
+
+  /* The string now lies between the low indeces of the now-adjacent
+     high and low entries.  Because it is less than the low entry of
+     'high', it can't be that one.  If low is still -1, then no
+     entries match.  Otherwise, we have to check the high entry of
+     'low'. */
+
+  if (low == -1)
+    return default_jump;
+
+  t = table + low;
+  if (compare_string (selector_len, selector,
+			    t->high_len, t->high) <= 0)
+    return t->address;
+
+  return default_jump;
+}
diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c
new file mode 100644
index 0000000..bc901bb
--- /dev/null
+++ b/libgfortran/runtime/stop.c
@@ -0,0 +1,56 @@
+/* Implementation of the STOP statement.
+   Copyright 2002 Free Software Foundation, Inc.
+   Contributed by Paul Brook <paul@nowt.org>
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License, or (at your option) any later version.
+
+Libgfor 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 Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with libgfor; see the file COPYING.LIB.  If not,
+write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#include "config.h"
+#include <string.h>
+
+#include "libgfortran.h"
+
+#define stop_string prefix(stop_string)
+
+/* A numeric or blank STOP statement.  */
+void
+stop_numeric (GFC_INTEGER_4 code)
+{
+  show_locus ();
+
+  if (code == -1)
+    st_printf ("STOP\n");
+  else
+    st_printf ("STOP %d\n", (int)code);
+
+  sys_exit (code);
+}
+
+
+void
+stop_string (const char *string, GFC_INTEGER_4 len)
+{
+  show_locus ();
+
+  st_printf ("STOP ");
+  while (len--)
+    st_printf ("%c", *(string++));
+  st_printf ("\n");
+
+  sys_exit (0);
+}
+
diff --git a/libgfortran/runtime/string.c b/libgfortran/runtime/string.c
new file mode 100644
index 0000000..bcd6092
--- /dev/null
+++ b/libgfortran/runtime/string.c
@@ -0,0 +1,120 @@
+/* Copyright (C) 2002-2003 Free Software Foundation, Inc.
+   Contributed by Paul Brook
+
+This file is part of the GNU Fortran 95 runtime library (libgfor).
+
+Libgfor 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.
+
+Libgfor 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 libgfor; 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 <string.h>
+
+#include "libgfortran.h"
+
+
+/* Compare a C-style string with a fortran style string in a case-insensitive
+   manner.  Used for decoding string options to various statements.  Returns
+   zero if not equal, nonzero if equal.  */
+
+static int
+compare0 (const char *s1, int s1_len, const char *s2)
+{
+  int i;
+
+  if (strncasecmp (s1, s2, s1_len) != 0)
+    return 0;
+
+  /* The rest of s1 needs to be blanks for equality.  */
+
+  for (i = strlen (s2); i < s1_len; i++)
+    if (s1[i] != ' ')
+      return 0;
+
+  return 1;
+}
+
+
+/* Given a fortran string, return its length exclusive of the trailing
+   spaces.  */
+int
+fstrlen (const char *string, int len)
+{
+
+  for (len--; len >= 0; len--)
+    if (string[len] != ' ')
+      break;
+
+  return len + 1;
+}
+
+
+
+void
+fstrcpy (char *dest, int destlen, const char *src, int srclen)
+{
+
+  if (srclen >= destlen)
+    {
+      /* This will truncate if too long.  */
+      memcpy (dest, src, destlen);
+    }
+  else
+    {
+      memcpy (dest, src, srclen);
+      /* Pad with spaces.  */
+      memset (&dest[srclen], ' ', destlen - srclen);
+    }
+}
+
+
+void
+cf_strcpy (char *dest, int dest_len, const char *src)
+{
+  int src_len;
+
+  src_len = strlen (src);
+
+  if (src_len >= dest_len)
+    {
+      /* This will truncate if too long.  */
+      memcpy (dest, src, dest_len);
+    }
+  else
+    {
+      memcpy (dest, src, src_len);
+      /* Pad with spaces.  */
+      memset (&dest[src_len], ' ', dest_len - src_len);
+    }
+}
+
+
+/* Given a fortran string and an array of st_option structures, search through
+   the array to find a match.  If the option is not found, we generate an error
+   if no default is provided.  */
+
+int
+find_option (const char *s1, int s1_len, st_option * opts,
+	     const char *error_message)
+{
+
+  for (; opts->name; opts++)
+    if (compare0 (s1, s1_len, opts->name))
+      return opts->value;
+
+  generate_error (ERROR_BAD_OPTION, error_message);
+
+  return -1;
+}
+