aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/libgfortran/runtime
diff options
context:
space:
mode:
authorJing Yu <jingyu@google.com>2009-11-05 15:11:04 -0800
committerJing Yu <jingyu@google.com>2009-11-05 15:11:04 -0800
commitdf62c1c110e8532b995b23540b7e3695729c0779 (patch)
treedbbd4cbdb50ac38011e058a2533ee4c3168b0205 /gcc-4.3.1/libgfortran/runtime
parent8d401cf711539af5a2f78d12447341d774892618 (diff)
downloadtoolchain_gcc-df62c1c110e8532b995b23540b7e3695729c0779.tar.gz
toolchain_gcc-df62c1c110e8532b995b23540b7e3695729c0779.tar.bz2
toolchain_gcc-df62c1c110e8532b995b23540b7e3695729c0779.zip
Check in gcc sources for prebuilt toolchains in Eclair.
Diffstat (limited to 'gcc-4.3.1/libgfortran/runtime')
-rw-r--r--gcc-4.3.1/libgfortran/runtime/backtrace.c337
-rw-r--r--gcc-4.3.1/libgfortran/runtime/compile_options.c199
-rw-r--r--gcc-4.3.1/libgfortran/runtime/environ.c842
-rw-r--r--gcc-4.3.1/libgfortran/runtime/error.c516
-rw-r--r--gcc-4.3.1/libgfortran/runtime/fpu.c16
-rw-r--r--gcc-4.3.1/libgfortran/runtime/in_pack_generic.c156
-rw-r--r--gcc-4.3.1/libgfortran/runtime/in_unpack_generic.c153
-rw-r--r--gcc-4.3.1/libgfortran/runtime/main.c180
-rw-r--r--gcc-4.3.1/libgfortran/runtime/memory.c73
-rw-r--r--gcc-4.3.1/libgfortran/runtime/pause.c76
-rw-r--r--gcc-4.3.1/libgfortran/runtime/select.c137
-rw-r--r--gcc-4.3.1/libgfortran/runtime/stop.c60
-rw-r--r--gcc-4.3.1/libgfortran/runtime/string.c128
13 files changed, 2873 insertions, 0 deletions
diff --git a/gcc-4.3.1/libgfortran/runtime/backtrace.c b/gcc-4.3.1/libgfortran/runtime/backtrace.c
new file mode 100644
index 000000000..00605b50d
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/backtrace.c
@@ -0,0 +1,337 @@
+/* Copyright (C) 2006, 2007 Free Software Foundation, Inc.
+ Contributed by François-Xavier Coudert
+
+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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+
+#include <string.h>
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_INTTYPES_H
+#include <inttypes.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_INTPTR_T
+# define INTPTR_T intptr_t
+#else
+# define INTPTR_T int
+#endif
+
+#ifdef HAVE_EXECINFO_H
+#include <execinfo.h>
+#endif
+
+#ifdef HAVE_SYS_WAIT_H
+#include <sys/wait.h>
+#endif
+
+#include <ctype.h>
+
+
+/* Macros for common sets of capabilities: can we fork and exec, can
+ we use glibc-style backtrace functions, and can we use pipes. */
+#define CAN_FORK (defined(HAVE_FORK) && defined(HAVE_EXECVP) \
+ && defined(HAVE_WAIT))
+#define GLIBC_BACKTRACE (defined(HAVE_BACKTRACE) \
+ && defined(HAVE_BACKTRACE_SYMBOLS))
+#define CAN_PIPE (CAN_FORK && defined(HAVE_PIPE) \
+ && defined(HAVE_DUP2) && defined(HAVE_FDOPEN) \
+ && defined(HAVE_CLOSE))
+
+
+#if GLIBC_BACKTRACE && CAN_PIPE
+static char *
+local_strcasestr (const char *s1, const char *s2)
+{
+#ifdef HAVE_STRCASESTR
+ return strcasestr (s1, s2);
+#else
+
+ const char *p = s1;
+ const size_t len = strlen (s2);
+ const char u = *s2, v = isupper((int) *s2) ? tolower((int) *s2)
+ : (islower((int) *s2) ? toupper((int) *s2)
+ : *s2);
+
+ while (1)
+ {
+ while (*p != u && *p != v && *p)
+ p++;
+ if (*p == 0)
+ return NULL;
+ if (strncasecmp (p, s2, len) == 0)
+ return (char *)p;
+ }
+#endif
+}
+#endif
+
+
+#if GLIBC_BACKTRACE
+static void
+dump_glibc_backtrace (int depth, char *str[])
+{
+ int i;
+
+ for (i = 0; i < depth; i++)
+ st_printf (" + %s\n", str[i]);
+
+ free (str);
+}
+#endif
+
+/* show_backtrace displays the backtrace, currently obtained by means of
+ the glibc backtrace* functions. */
+void
+show_backtrace (void)
+{
+#if GLIBC_BACKTRACE
+
+#define DEPTH 50
+#define BUFSIZE 1024
+
+ void *trace[DEPTH];
+ char **str;
+ int depth;
+
+ depth = backtrace (trace, DEPTH);
+ if (depth <= 0)
+ return;
+
+ str = backtrace_symbols (trace, depth);
+
+#if CAN_PIPE
+
+#ifndef STDIN_FILENO
+#define STDIN_FILENO 0
+#endif
+
+#ifndef STDOUT_FILENO
+#define STDOUT_FILENO 1
+#endif
+
+#ifndef STDERR_FILENO
+#define STDERR_FILENO 2
+#endif
+
+ /* We attempt to extract file and line information from addr2line. */
+ do
+ {
+ /* Local variables. */
+ int f[2], pid, line, i;
+ FILE *output;
+ char addr_buf[DEPTH][GFC_XTOA_BUF_SIZE], func[BUFSIZE], file[BUFSIZE];
+ char *p, *end;
+ const char *addr[DEPTH];
+
+ /* Write the list of addresses in hexadecimal format. */
+ for (i = 0; i < depth; i++)
+ addr[i] = xtoa ((GFC_UINTEGER_LARGEST) (INTPTR_T) trace[i], addr_buf[i],
+ sizeof (addr_buf[i]));
+
+ /* Don't output an error message if something goes wrong, we'll simply
+ fall back to the pstack and glibc backtraces. */
+ if (pipe (f) != 0)
+ break;
+ if ((pid = fork ()) == -1)
+ break;
+
+ if (pid == 0)
+ {
+ /* Child process. */
+#define NUM_FIXEDARGS 5
+ char *arg[DEPTH+NUM_FIXEDARGS+1];
+
+ close (f[0]);
+ close (STDIN_FILENO);
+ close (STDERR_FILENO);
+
+ if (dup2 (f[1], STDOUT_FILENO) == -1)
+ _exit (0);
+ close (f[1]);
+
+ arg[0] = (char *) "addr2line";
+ arg[1] = (char *) "-e";
+ arg[2] = full_exe_path ();
+ arg[3] = (char *) "-f";
+ arg[4] = (char *) "-s";
+ for (i = 0; i < depth; i++)
+ arg[NUM_FIXEDARGS+i] = (char *) addr[i];
+ arg[NUM_FIXEDARGS+depth] = NULL;
+ execvp (arg[0], arg);
+ _exit (0);
+#undef NUM_FIXEDARGS
+ }
+
+ /* Father process. */
+ close (f[1]);
+ wait (NULL);
+ output = fdopen (f[0], "r");
+ i = -1;
+
+ if (fgets (func, sizeof(func), output))
+ {
+ st_printf ("\nBacktrace for this error:\n");
+
+ do
+ {
+ if (! fgets (file, sizeof(file), output))
+ goto fallback;
+
+ i++;
+
+ for (p = func; *p != '\n' && *p != '\r'; p++)
+ ;
+
+ *p = '\0';
+
+ /* Try to recognize the internal libgfortran functions. */
+ if (strncasecmp (func, "*_gfortran", 10) == 0
+ || strncasecmp (func, "_gfortran", 9) == 0
+ || strcmp (func, "main") == 0 || strcmp (func, "_start") == 0
+ || strcmp (func, "_gfortrani_handler") == 0)
+ continue;
+
+ if (local_strcasestr (str[i], "libgfortran.so") != NULL
+ || local_strcasestr (str[i], "libgfortran.dylib") != NULL
+ || local_strcasestr (str[i], "libgfortran.a") != NULL)
+ continue;
+
+ /* If we only have the address, use the glibc backtrace. */
+ if (func[0] == '?' && func[1] == '?' && file[0] == '?'
+ && file[1] == '?')
+ {
+ st_printf (" + %s\n", str[i]);
+ continue;
+ }
+
+ /* Extract the line number. */
+ for (end = NULL, p = file; *p; p++)
+ if (*p == ':')
+ end = p;
+ if (end != NULL)
+ {
+ *end = '\0';
+ line = atoi (++end);
+ }
+ else
+ line = -1;
+
+ if (strcmp (func, "MAIN__") == 0)
+ st_printf (" + in the main program\n");
+ else
+ st_printf (" + function %s (0x%s)\n", func, addr[i]);
+
+ if (line <= 0 && strcmp (file, "??") == 0)
+ continue;
+
+ if (line <= 0)
+ st_printf (" from file %s\n", file);
+ else
+ st_printf (" at line %d of file %s\n", line, file);
+ }
+ while (fgets (func, sizeof(func), output));
+
+ free (str);
+ return;
+
+fallback:
+ st_printf ("** Something went wrong while running addr2line. **\n"
+ "** Falling back to a simpler backtrace scheme. **\n");
+ }
+ }
+ while (0);
+
+#undef DEPTH
+#undef BUFSIZE
+
+#endif
+#endif
+
+#if CAN_FORK && defined(HAVE_GETPPID)
+ /* Try to call pstack. */
+ do
+ {
+ /* Local variables. */
+ int pid;
+
+ /* Don't output an error message if something goes wrong, we'll simply
+ fall back to the pstack and glibc backtraces. */
+ if ((pid = fork ()) == -1)
+ break;
+
+ if (pid == 0)
+ {
+ /* Child process. */
+#define NUM_ARGS 2
+ char *arg[NUM_ARGS+1];
+ char buf[20];
+
+ st_printf ("\nBacktrace for this error:\n");
+ arg[0] = (char *) "pstack";
+#ifdef HAVE_SNPRINTF
+ snprintf (buf, sizeof(buf), "%d", (int) getppid ());
+#else
+ sprintf (buf, "%d", (int) getppid ());
+#endif
+ arg[1] = buf;
+ arg[2] = NULL;
+ execvp (arg[0], arg);
+#undef NUM_ARGS
+
+ /* pstack didn't work, so we fall back to dumping the glibc
+ backtrace if we can. */
+#if GLIBC_BACKTRACE
+ dump_glibc_backtrace (depth, str);
+#else
+ st_printf (" unable to produce a backtrace, sorry!\n");
+#endif
+
+ _exit (0);
+ }
+
+ /* Father process. */
+ wait (NULL);
+ return;
+ }
+ while(0);
+#endif
+
+#if GLIBC_BACKTRACE
+ /* Fallback to the glibc backtrace. */
+ st_printf ("\nBacktrace for this error:\n");
+ dump_glibc_backtrace (depth, str);
+#endif
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/compile_options.c b/gcc-4.3.1/libgfortran/runtime/compile_options.c
new file mode 100644
index 000000000..8e0a3fe30
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/compile_options.c
@@ -0,0 +1,199 @@
+/* Handling of compile-time options that influence the library.
+ Copyright (C) 2005, 2007 Free Software Foundation, Inc.
+
+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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+
+/* Useful compile-time options will be stored in here. */
+compile_options_t compile_options;
+
+
+/* A signal handler to allow us to output a backtrace. */
+void
+handler (int signum)
+{
+ const char * name = NULL, * desc = NULL;
+
+ switch (signum)
+ {
+#if defined(SIGSEGV)
+ case SIGSEGV:
+ name = "SIGSEGV";
+ desc = "Segmentation fault";
+ break;
+#endif
+
+#if defined(SIGBUS)
+ case SIGBUS:
+ name = "SIGBUS";
+ desc = "Bus error";
+ break;
+#endif
+
+#if defined(SIGILL)
+ case SIGILL:
+ name = "SIGILL";
+ desc = "Illegal instruction";
+ break;
+#endif
+
+#if defined(SIGFPE)
+ case SIGFPE:
+ name = "SIGFPE";
+ desc = "Floating-point exception";
+ break;
+#endif
+ }
+
+ if (name)
+ st_printf ("\nProgram received signal %d (%s): %s.\n", signum, name, desc);
+ else
+ st_printf ("\nProgram received signal %d.\n", signum);
+
+ sys_exit (5);
+}
+
+
+/* Set the usual compile-time options. */
+extern void set_options (int , int []);
+export_proto(set_options);
+
+void
+set_options (int num, int options[])
+{
+ if (num >= 1)
+ compile_options.warn_std = options[0];
+ if (num >= 2)
+ compile_options.allow_std = options[1];
+ if (num >= 3)
+ compile_options.pedantic = options[2];
+ if (num >= 4)
+ compile_options.dump_core = options[3];
+ if (num >= 5)
+ compile_options.backtrace = options[4];
+ if (num >= 6)
+ compile_options.sign_zero = options[5];
+ if (num >= 7)
+ compile_options.bounds_check = options[6];
+
+ /* If backtrace is required, we set signal handlers on most common
+ signals. */
+#if defined(HAVE_SIGNAL) && (defined(SIGSEGV) || defined(SIGBUS) \
+ || defined(SIGILL) || defined(SIGFPE))
+ if (compile_options.backtrace)
+ {
+#if defined(SIGSEGV)
+ signal (SIGSEGV, handler);
+#endif
+
+#if defined(SIGBUS)
+ signal (SIGBUS, handler);
+#endif
+
+#if defined(SIGILL)
+ signal (SIGILL, handler);
+#endif
+
+#if defined(SIGFPE)
+ signal (SIGFPE, handler);
+#endif
+ }
+#endif
+
+}
+
+
+/* Default values for the compile-time options. Keep in sync with
+ gcc/fortran/options.c (gfc_init_options). */
+void
+init_compile_options (void)
+{
+ compile_options.warn_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL
+ | GFC_STD_F2003 | GFC_STD_LEGACY;
+ compile_options.allow_std = GFC_STD_F95_OBS | GFC_STD_F95_DEL
+ | GFC_STD_F2003 | GFC_STD_F95 | GFC_STD_F77 | GFC_STD_GNU | GFC_STD_LEGACY;
+ compile_options.pedantic = 0;
+ compile_options.dump_core = 0;
+ compile_options.backtrace = 0;
+ compile_options.sign_zero = 1;
+}
+
+/* Function called by the front-end to tell us the
+ default for unformatted data conversion. */
+
+extern void set_convert (int);
+export_proto (set_convert);
+
+void
+set_convert (int conv)
+{
+ compile_options.convert = conv;
+}
+
+extern void set_record_marker (int);
+export_proto (set_record_marker);
+
+
+void
+set_record_marker (int val)
+{
+
+ switch(val)
+ {
+ case 4:
+ compile_options.record_marker = sizeof (GFC_INTEGER_4);
+ break;
+
+ case 8:
+ compile_options.record_marker = sizeof (GFC_INTEGER_8);
+ break;
+
+ default:
+ runtime_error ("Invalid value for record marker");
+ break;
+ }
+}
+
+extern void set_max_subrecord_length (int);
+export_proto (set_max_subrecord_length);
+
+void set_max_subrecord_length(int val)
+{
+ if (val > GFC_MAX_SUBRECORD_LENGTH || val < 1)
+ {
+ runtime_error ("Invalid value for maximum subrecord length");
+ return;
+ }
+
+ compile_options.max_subrecord_length = val;
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/environ.c b/gcc-4.3.1/libgfortran/runtime/environ.c
new file mode 100644
index 000000000..ba8283e68
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/environ.c
@@ -0,0 +1,842 @@
+/* Copyright (C) 2002, 2003, 2005, 2007 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+
+#include <string.h>
+#include <stdlib.h>
+#include <ctype.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;
+
+
+typedef struct variable
+{
+ const char *name;
+ int value, *var;
+ void (*init) (struct variable *);
+ void (*show) (struct variable *);
+ const char *desc;
+ int bad;
+}
+variable;
+
+static void init_unformatted (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) && (p != q || *q != '-'))
+ {
+ v->bad = 1;
+ goto set_default;
+ }
+
+ *v->var = atoi (p);
+ return;
+
+ set_default:
+ *v->var = v->value;
+ return;
+}
+
+
+/* init_unsigned_integer()-- Initialize an integer environment variable
+ which has to be positive. */
+
+static void
+init_unsigned_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");
+}
+
+
+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 __attribute__ ((unused)))
+{
+}
+
+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);
+}
+
+
+static variable variable_table[] = {
+ {"GFORTRAN_STDIN_UNIT", GFC_STDIN_UNIT_NUMBER, &options.stdin_unit,
+ init_integer, show_integer,
+ "Unit number that will be preconnected to standard input\n"
+ "(No preconnection if negative)", 0},
+
+ {"GFORTRAN_STDOUT_UNIT", GFC_STDOUT_UNIT_NUMBER, &options.stdout_unit,
+ init_integer, show_integer,
+ "Unit number that will be preconnected to standard output\n"
+ "(No preconnection if negative)", 0},
+
+ {"GFORTRAN_STDERR_UNIT", GFC_STDERR_UNIT_NUMBER, &options.stderr_unit,
+ init_integer, show_integer,
+ "Unit number that will be preconnected to standard error\n"
+ "(No preconnection if negative)", 0},
+
+ {"GFORTRAN_USE_STDERR", 1, &options.use_stderr, init_boolean,
+ show_boolean,
+ "Sends library output to standard error instead of standard output.", 0},
+
+ {"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.", 0},
+
+ {"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.", 0},
+
+ {"GFORTRAN_UNBUFFERED_PRECONNECTED", 0, &options.unbuffered_preconnected,
+ init_boolean, show_boolean,
+ "If TRUE, output to preconnected units is unbuffered.", 0},
+
+ {"GFORTRAN_SHOW_LOCUS", 1, &options.locus, init_boolean, show_boolean,
+ "If TRUE, print filename and line number where runtime errors happen.", 0},
+
+ {"GFORTRAN_OPTIONAL_PLUS", 0, &options.optional_plus, init_boolean, show_boolean,
+ "Print optional plus signs in numbers where permitted. Default FALSE.", 0},
+
+ {"GFORTRAN_DEFAULT_RECL", DEFAULT_RECL, &options.default_recl,
+ init_unsigned_integer, show_integer,
+ "Default maximum record length for sequential files. Most useful for\n"
+ "adjusting line length of preconnected units. Default "
+ stringize (DEFAULT_RECL), 0},
+
+ {"GFORTRAN_LIST_SEPARATOR", 0, NULL, init_sep, show_sep,
+ "Separator to use when writing list output. May contain any number of "
+ "spaces\nand at most one comma. Default is a single space.", 0},
+
+ /* GFORTRAN_CONVERT_UNIT - Set the default data conversion for
+ unformatted I/O. */
+ {"GFORTRAN_CONVERT_UNIT", 0, 0, init_unformatted, show_string,
+ "Set format for unformatted files", 0},
+
+ /* Behaviour when encoutering a runtime error. */
+ {"GFORTRAN_ERROR_DUMPCORE", -1, &options.dump_core,
+ init_boolean, show_boolean,
+ "Dump a core file (if possible) on runtime error", -1},
+
+ {"GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace,
+ init_boolean, show_boolean,
+ "Print out a backtrace (if possible) on runtime error", -1},
+
+ {NULL, 0, NULL, NULL, NULL, NULL, 0}
+};
+
+
+/* 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);
+}
+
+
+void
+show_variables (void)
+{
+ 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);
+ }
+
+ /* System error codes */
+
+ st_printf ("\nRuntime error codes:");
+ st_printf ("\n--------------------\n");
+
+ for (n = LIBERROR_FIRST + 1; n < LIBERROR_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);
+}
+
+/* This is the handling of the GFORTRAN_CONVERT_UNITS environment variable.
+ It is called from environ.c to parse this variable, and from
+ open.c to determine if the user specified a default for an
+ unformatted file.
+ The syntax of the environment variable is, in bison grammar:
+
+ GFORTRAN_CONVERT_UNITS: mode | mode ';' exception ;
+ mode: 'native' | 'swap' | 'big_endian' | 'little_endian' ;
+ exception: mode ':' unit_list | unit_list ;
+ unit_list: unit_spec | unit_list unit_spec ;
+ unit_spec: INTEGER | INTEGER '-' INTEGER ;
+*/
+
+/* Defines for the tokens. Other valid tokens are ',', ':', '-'. */
+
+
+#define NATIVE 257
+#define SWAP 258
+#define BIG 259
+#define LITTLE 260
+/* Some space for additional tokens later. */
+#define INTEGER 273
+#define END (-1)
+#define ILLEGAL (-2)
+
+typedef struct
+{
+ int unit;
+ unit_convert conv;
+} exception_t;
+
+
+static char *p; /* Main character pointer for parsing. */
+static char *lastpos; /* Auxiliary pointer, for backing up. */
+static int unit_num; /* The last unit number read. */
+static int unit_count; /* The number of units found. */
+static int do_count; /* Parsing is done twice - first to count the number
+ of units, then to fill in the table. This
+ variable controls what to do. */
+static exception_t *elist; /* The list of exceptions to the default. This is
+ sorted according to unit number. */
+static int n_elist; /* Number of exceptions to the default. */
+
+static unit_convert endian; /* Current endianness. */
+
+static unit_convert def; /* Default as specified (if any). */
+
+/* Search for a unit number, using a binary search. The
+ first argument is the unit number to search for. The second argument
+ is a pointer to an index.
+ If the unit number is found, the function returns 1, and the index
+ is that of the element.
+ If the unit number is not found, the function returns 0, and the
+ index is the one where the element would be inserted. */
+
+static int
+search_unit (int unit, int *ip)
+{
+ int low, high, mid;
+
+ low = -1;
+ high = n_elist;
+ while (high - low > 1)
+ {
+ mid = (low + high) / 2;
+ if (unit <= elist[mid].unit)
+ high = mid;
+ else
+ low = mid;
+ }
+ *ip = high;
+ if (elist[high].unit == unit)
+ return 1;
+ else
+ return 0;
+}
+
+/* This matches a keyword. If it is found, return the token supplied,
+ otherwise return ILLEGAL. */
+
+static int
+match_word (const char *word, int tok)
+{
+ int res;
+
+ if (strncasecmp (p, word, strlen (word)) == 0)
+ {
+ p += strlen (word);
+ res = tok;
+ }
+ else
+ res = ILLEGAL;
+ return res;
+
+}
+
+/* Match an integer and store its value in unit_num. This only works
+ if p actually points to the start of an integer. The caller has
+ to ensure this. */
+
+static int
+match_integer (void)
+{
+ unit_num = 0;
+ while (isdigit (*p))
+ unit_num = unit_num * 10 + (*p++ - '0');
+ return INTEGER;
+
+}
+
+/* This reads the next token from the GFORTRAN_CONVERT_UNITS variable.
+ Returned values are the different tokens. */
+
+static int
+next_token (void)
+{
+ int result;
+
+ lastpos = p;
+ switch (*p)
+ {
+ case '\0':
+ result = END;
+ break;
+
+ case ':':
+ case ',':
+ case '-':
+ case ';':
+ result = *p;
+ p++;
+ break;
+
+ case 'b':
+ case 'B':
+ result = match_word ("big_endian", BIG);
+ break;
+
+ case 'l':
+ case 'L':
+ result = match_word ("little_endian", LITTLE);
+ break;
+
+ case 'n':
+ case 'N':
+ result = match_word ("native", NATIVE);
+ break;
+
+ case 's':
+ case 'S':
+ result = match_word ("swap", SWAP);
+ break;
+
+ case '1': case '2': case '3': case '4': case '5':
+ case '6': case '7': case '8': case '9':
+ result = match_integer ();
+ break;
+
+ default:
+ result = ILLEGAL;
+ break;
+ }
+ return result;
+}
+
+/* Back up the last token by setting back the character pointer. */
+
+static void
+push_token (void)
+{
+ p = lastpos;
+}
+
+/* This is called when a unit is identified. If do_count is nonzero,
+ increment the number of units by one. If do_count is zero,
+ put the unit into the table. */
+
+static void
+mark_single (int unit)
+{
+ int i,j;
+
+ if (do_count)
+ {
+ unit_count++;
+ return;
+ }
+ if (search_unit (unit, &i))
+ {
+ elist[unit].conv = endian;
+ }
+ else
+ {
+ for (j=n_elist; j>=i; j--)
+ elist[j+1] = elist[j];
+
+ n_elist += 1;
+ elist[i].unit = unit;
+ elist[i].conv = endian;
+ }
+}
+
+/* This is called when a unit range is identified. If do_count is
+ nonzero, increase the number of units. If do_count is zero,
+ put the unit into the table. */
+
+static void
+mark_range (int unit1, int unit2)
+{
+ int i;
+ if (do_count)
+ unit_count += abs (unit2 - unit1) + 1;
+ else
+ {
+ if (unit2 < unit1)
+ for (i=unit2; i<=unit1; i++)
+ mark_single (i);
+ else
+ for (i=unit1; i<=unit2; i++)
+ mark_single (i);
+ }
+}
+
+/* Parse the GFORTRAN_CONVERT_UNITS variable. This is called
+ twice, once to count the units and once to actually mark them in
+ the table. When counting, we don't check for double occurrences
+ of units. */
+
+static int
+do_parse (void)
+{
+ int tok;
+ int unit1;
+ int continue_ulist;
+ char *start;
+
+ unit_count = 0;
+
+ start = p;
+
+ /* Parse the string. First, let's look for a default. */
+ tok = next_token ();
+ switch (tok)
+ {
+ case NATIVE:
+ endian = GFC_CONVERT_NATIVE;
+ break;
+
+ case SWAP:
+ endian = GFC_CONVERT_SWAP;
+ break;
+
+ case BIG:
+ endian = GFC_CONVERT_BIG;
+ break;
+
+ case LITTLE:
+ endian = GFC_CONVERT_LITTLE;
+ break;
+
+ case INTEGER:
+ /* A leading digit means that we are looking at an exception.
+ Reset the position to the beginning, and continue processing
+ at the exception list. */
+ p = start;
+ goto exceptions;
+ break;
+
+ case END:
+ goto end;
+ break;
+
+ default:
+ goto error;
+ break;
+ }
+
+ tok = next_token ();
+ switch (tok)
+ {
+ case ';':
+ def = endian;
+ break;
+
+ case ':':
+ /* This isn't a default after all. Reset the position to the
+ beginning, and continue processing at the exception list. */
+ p = start;
+ goto exceptions;
+ break;
+
+ case END:
+ def = endian;
+ goto end;
+ break;
+
+ default:
+ goto error;
+ break;
+ }
+
+ exceptions:
+
+ /* Loop over all exceptions. */
+ while(1)
+ {
+ tok = next_token ();
+ switch (tok)
+ {
+ case NATIVE:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_NATIVE;
+ break;
+
+ case SWAP:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_SWAP;
+ break;
+
+ case LITTLE:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_LITTLE;
+ break;
+
+ case BIG:
+ if (next_token () != ':')
+ goto error;
+ endian = GFC_CONVERT_BIG;
+ break;
+
+ case INTEGER:
+ push_token ();
+ break;
+
+ case END:
+ goto end;
+ break;
+
+ default:
+ goto error;
+ break;
+ }
+ /* We arrive here when we want to parse a list of
+ numbers. */
+ continue_ulist = 1;
+ do
+ {
+ tok = next_token ();
+ if (tok != INTEGER)
+ goto error;
+
+ unit1 = unit_num;
+ tok = next_token ();
+ /* The number can be followed by a - and another number,
+ which means that this is a unit range, a comma
+ or a semicolon. */
+ if (tok == '-')
+ {
+ if (next_token () != INTEGER)
+ goto error;
+
+ mark_range (unit1, unit_num);
+ tok = next_token ();
+ if (tok == END)
+ goto end;
+ else if (tok == ';')
+ continue_ulist = 0;
+ else if (tok != ',')
+ goto error;
+ }
+ else
+ {
+ mark_single (unit1);
+ switch (tok)
+ {
+ case ';':
+ continue_ulist = 0;
+ break;
+
+ case ',':
+ break;
+
+ case END:
+ goto end;
+ break;
+
+ default:
+ goto error;
+ }
+ }
+ } while (continue_ulist);
+ }
+ end:
+ return 0;
+ error:
+ def = GFC_CONVERT_NONE;
+ return -1;
+}
+
+void init_unformatted (variable * v)
+{
+ char *val;
+ val = getenv (v->name);
+ def = GFC_CONVERT_NONE;
+ n_elist = 0;
+
+ if (val == NULL)
+ return;
+ do_count = 1;
+ p = val;
+ do_parse ();
+ if (do_count <= 0)
+ {
+ n_elist = 0;
+ elist = NULL;
+ }
+ else
+ {
+ elist = get_mem (unit_count * sizeof (exception_t));
+ do_count = 0;
+ p = val;
+ do_parse ();
+ }
+}
+
+/* Get the default conversion for for an unformatted unit. */
+
+unit_convert
+get_unformatted_convert (int unit)
+{
+ int i;
+
+ if (elist == NULL)
+ return def;
+ else if (search_unit (unit, &i))
+ return elist[i].conv;
+ else
+ return def;
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/error.c b/gcc-4.3.1/libgfortran/runtime/error.c
new file mode 100644
index 000000000..f0a4ff229
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/error.c
@@ -0,0 +1,516 @@
+/* Copyright (C) 2002, 2003, 2005, 2006, 2007 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+
+#include "libgfortran.h"
+#include <assert.h>
+#include <string.h>
+#include <errno.h>
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+#ifdef HAVE_STDLIB_H
+#include <stdlib.h>
+#endif
+
+#ifdef HAVE_SYS_TIME_H
+#include <sys/time.h>
+#endif
+
+/* <sys/time.h> has to be included before <sys/resource.h> to work
+ around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
+#ifdef HAVE_SYS_RESOURCE_H
+#include <sys/resource.h>
+#endif
+
+
+#ifdef __MINGW32__
+#define HAVE_GETPID 1
+#include <process.h>
+#endif
+
+
+/* sys_exit()-- Terminate the program with an exit code. */
+
+void
+sys_exit (int code)
+{
+ /* Show error backtrace if possible. */
+ if (code != 0 && code != 4
+ && (options.backtrace == 1
+ || (options.backtrace == -1 && compile_options.backtrace == 1)))
+ show_backtrace ();
+
+ /* Dump core if requested. */
+ if (code != 0
+ && (options.dump_core == 1
+ || (options.dump_core == -1 && compile_options.dump_core == 1)))
+ {
+#if defined(HAVE_GETRLIMIT) && defined(RLIMIT_CORE)
+ /* Warn if a core file cannot be produced because
+ of core size limit. */
+
+ struct rlimit core_limit;
+
+ if (getrlimit (RLIMIT_CORE, &core_limit) == 0 && core_limit.rlim_cur == 0)
+ st_printf ("** Warning: a core dump was requested, but the core size"
+ "limit\n** is currently zero.\n\n");
+#endif
+
+
+#if defined(HAVE_KILL) && defined(HAVE_GETPID) && defined(SIGQUIT)
+ kill (getpid (), SIGQUIT);
+#else
+ st_printf ("Core dump not possible, sorry.");
+#endif
+ }
+
+ exit (code);
+}
+
+
+/* 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.
+ */
+
+/* gfc_itoa()-- Integer to decimal conversion. */
+
+const char *
+gfc_itoa (GFC_INTEGER_LARGEST n, char *buffer, size_t len)
+{
+ int negative;
+ char *p;
+ GFC_UINTEGER_LARGEST t;
+
+ assert (len >= GFC_ITOA_BUF_SIZE);
+
+ if (n == 0)
+ return "0";
+
+ negative = 0;
+ t = n;
+ if (n < 0)
+ {
+ negative = 1;
+ t = -n; /*must use unsigned to protect from overflow*/
+ }
+
+ p = buffer + GFC_ITOA_BUF_SIZE - 1;
+ *p = '\0';
+
+ while (t != 0)
+ {
+ *--p = '0' + (t % 10);
+ t /= 10;
+ }
+
+ if (negative)
+ *--p = '-';
+ return p;
+}
+
+
+/* xtoa()-- Integer to hexadecimal conversion. */
+
+const char *
+xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
+{
+ int digit;
+ char *p;
+
+ assert (len >= GFC_XTOA_BUF_SIZE);
+
+ if (n == 0)
+ return "0";
+
+ p = buffer + GFC_XTOA_BUF_SIZE - 1;
+ *p = '\0';
+
+ while (n != 0)
+ {
+ digit = n & 0xF;
+ if (digit > 9)
+ digit += 'A' - '0' - 10;
+
+ *--p = '0' + digit;
+ n >>= 4;
+ }
+
+ return p;
+}
+
+/* show_locus()-- Print a line number and filename describing where
+ * something went wrong */
+
+void
+show_locus (st_parameter_common *cmp)
+{
+ static char *filename;
+
+ if (!options.locus || cmp == NULL || cmp->filename == NULL)
+ return;
+
+ if (cmp->unit > 0)
+ {
+ filename = filename_from_unit (cmp->unit);
+ if (filename != NULL)
+ {
+ st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
+ (int) cmp->line, cmp->filename, cmp->unit, filename);
+ free_mem (filename);
+ }
+ return;
+ }
+
+ st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->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;
+
+ /* Don't even try to print something at this point */
+ if (magic == MAGIC)
+ sys_exit (4);
+
+ 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 ();
+ st_printf ("Operating system error: %s\n%s\n", get_oserror (), message);
+ sys_exit (1);
+}
+iexport(os_error);
+
+
+/* void runtime_error()-- These are errors associated with an
+ * invalid fortran program. */
+
+void
+runtime_error (const char *message, ...)
+{
+ va_list ap;
+
+ recursion_check ();
+ st_printf ("Fortran runtime error: ");
+ va_start (ap, message);
+ st_vprintf (message, ap);
+ va_end (ap);
+ st_printf ("\n");
+ sys_exit (2);
+}
+iexport(runtime_error);
+
+/* void runtime_error_at()-- These are errors associated with a
+ * run time error generated by the front end compiler. */
+
+void
+runtime_error_at (const char *where, const char *message, ...)
+{
+ va_list ap;
+
+ recursion_check ();
+ st_printf ("%s\n", where);
+ st_printf ("Fortran runtime error: ");
+ va_start (ap, message);
+ st_vprintf (message, ap);
+ va_end (ap);
+ st_printf ("\n");
+ sys_exit (2);
+}
+iexport(runtime_error_at);
+
+
+/* void internal_error()-- These are this-can't-happen errors
+ * that indicate something deeply wrong. */
+
+void
+internal_error (st_parameter_common *cmp, const char *message)
+{
+ recursion_check ();
+ show_locus (cmp);
+ st_printf ("Internal Error: %s\n", message);
+
+ /* This function call is here to get the main.o object file included
+ when linking statically. This works because error.o is supposed to
+ be always linked in (and the function call is in internal_error
+ because hopefully it doesn't happen too often). */
+ stupid_function_name_for_static_linking();
+
+ 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 LIBERROR_EOR:
+ p = "End of record";
+ break;
+
+ case LIBERROR_END:
+ p = "End of file";
+ break;
+
+ case LIBERROR_OK:
+ p = "Successful return";
+ break;
+
+ case LIBERROR_OS:
+ p = "Operating system error";
+ break;
+
+ case LIBERROR_BAD_OPTION:
+ p = "Bad statement option";
+ break;
+
+ case LIBERROR_MISSING_OPTION:
+ p = "Missing statement option";
+ break;
+
+ case LIBERROR_OPTION_CONFLICT:
+ p = "Conflicting statement options";
+ break;
+
+ case LIBERROR_ALREADY_OPEN:
+ p = "File already opened in another unit";
+ break;
+
+ case LIBERROR_BAD_UNIT:
+ p = "Unattached unit";
+ break;
+
+ case LIBERROR_FORMAT:
+ p = "FORMAT error";
+ break;
+
+ case LIBERROR_BAD_ACTION:
+ p = "Incorrect ACTION specified";
+ break;
+
+ case LIBERROR_ENDFILE:
+ p = "Read past ENDFILE record";
+ break;
+
+ case LIBERROR_BAD_US:
+ p = "Corrupt unformatted sequential file";
+ break;
+
+ case LIBERROR_READ_VALUE:
+ p = "Bad value during read";
+ break;
+
+ case LIBERROR_READ_OVERFLOW:
+ p = "Numeric overflow on read";
+ break;
+
+ case LIBERROR_INTERNAL:
+ p = "Internal error in run-time library";
+ break;
+
+ case LIBERROR_INTERNAL_UNIT:
+ p = "Internal unit I/O error";
+ break;
+
+ case LIBERROR_DIRECT_EOR:
+ p = "Write exceeds length of DIRECT access record";
+ break;
+
+ case LIBERROR_SHORT_RECORD:
+ p = "I/O past end of record on unformatted file";
+ break;
+
+ case LIBERROR_CORRUPT_FILE:
+ p = "Unformatted file structure has been corrupted";
+ 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 or IOMSG variable exists, we set it. If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing 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 (st_parameter_common *cmp, int family, const char *message)
+{
+
+ /* If there was a previous error, don't mask it with another
+ error message, EOF or EOR condition. */
+
+ if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
+ return;
+
+ /* Set the error status. */
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
+
+ if (message == NULL)
+ message =
+ (family == LIBERROR_OS) ? get_oserror () : translate_error (family);
+
+ if (cmp->flags & IOPARM_HAS_IOMSG)
+ cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
+
+ /* Report status back to the compiler. */
+ cmp->flags &= ~IOPARM_LIBRETURN_MASK;
+ switch (family)
+ {
+ case LIBERROR_EOR:
+ cmp->flags |= IOPARM_LIBRETURN_EOR;
+ if ((cmp->flags & IOPARM_EOR))
+ return;
+ break;
+
+ case LIBERROR_END:
+ cmp->flags |= IOPARM_LIBRETURN_END;
+ if ((cmp->flags & IOPARM_END))
+ return;
+ break;
+
+ default:
+ cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ if ((cmp->flags & IOPARM_ERR))
+ return;
+ break;
+ }
+
+ /* Return if the user supplied an iostat variable. */
+ if ((cmp->flags & IOPARM_HAS_IOSTAT))
+ return;
+
+ /* Terminate the program */
+
+ recursion_check ();
+ show_locus (cmp);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
+}
+iexport(generate_error);
+
+/* Whether, for a feature included in a given standard set (GFC_STD_*),
+ we should issue an error or a warning, or be quiet. */
+
+notification
+notification_std (int std)
+{
+ int warning;
+
+ if (!compile_options.pedantic)
+ return SILENT;
+
+ warning = compile_options.warn_std & std;
+ if ((compile_options.allow_std & std) != 0 && !warning)
+ return SILENT;
+
+ return warning ? WARNING : ERROR;
+}
+
+
+
+/* Possibly issue a warning/error about use of a nonstandard (or deleted)
+ feature. An error/warning will be issued if the currently selected
+ standard does not contain the requested bits. */
+
+try
+notify_std (st_parameter_common *cmp, int std, const char * message)
+{
+ int warning;
+
+ if (!compile_options.pedantic)
+ return SUCCESS;
+
+ warning = compile_options.warn_std & std;
+ if ((compile_options.allow_std & std) != 0 && !warning)
+ return SUCCESS;
+
+ if (!warning)
+ {
+ recursion_check ();
+ show_locus (cmp);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
+ }
+ else
+ {
+ show_locus (cmp);
+ st_printf ("Fortran runtime warning: %s\n", message);
+ }
+ return FAILURE;
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/fpu.c b/gcc-4.3.1/libgfortran/runtime/fpu.c
new file mode 100644
index 000000000..f81a3b05a
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/fpu.c
@@ -0,0 +1,16 @@
+#include "libgfortran.h"
+
+/* We include the platform-dependent code. */
+#include "fpu-target.h"
+
+/* Function called by the front-end to tell us
+ when a FPE should be raised. */
+extern void set_fpe (int);
+export_proto(set_fpe);
+
+void
+set_fpe (int exceptions)
+{
+ options.fpe = exceptions;
+ set_fpu ();
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/in_pack_generic.c b/gcc-4.3.1/libgfortran/runtime/in_pack_generic.c
new file mode 100644
index 000000000..59205ead9
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/in_pack_generic.c
@@ -0,0 +1,156 @@
+/* Generic helper function for repacking arrays.
+ Copyright 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+#include <string.h>
+
+extern void *internal_pack (gfc_array_char *);
+export_proto(internal_pack);
+
+void *
+internal_pack (gfc_array_char * source)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS];
+ index_type stride0;
+ index_type dim;
+ index_type ssize;
+ const char *src;
+ char *dest;
+ void *destptr;
+ int n;
+ int packed;
+ index_type size;
+ int type;
+
+ if (source->dim[0].stride == 0)
+ {
+ source->dim[0].stride = 1;
+ return source->data;
+ }
+
+ type = GFC_DESCRIPTOR_TYPE (source);
+ size = GFC_DESCRIPTOR_SIZE (source);
+ switch (type)
+ {
+ case GFC_DTYPE_INTEGER:
+ case GFC_DTYPE_LOGICAL:
+ case GFC_DTYPE_REAL:
+ switch (size)
+ {
+ case 4:
+ return internal_pack_4 ((gfc_array_i4 *)source);
+
+ case 8:
+ return internal_pack_8 ((gfc_array_i8 *)source);
+ }
+ break;
+
+ case GFC_DTYPE_COMPLEX:
+ switch (size)
+ {
+ case 8:
+ return internal_pack_c4 ((gfc_array_c4 *)source);
+
+ case 16:
+ return internal_pack_c8 ((gfc_array_c8 *)source);
+ }
+ break;
+
+ default:
+ break;
+ }
+
+ 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 probably 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/gcc-4.3.1/libgfortran/runtime/in_unpack_generic.c b/gcc-4.3.1/libgfortran/runtime/in_unpack_generic.c
new file mode 100644
index 000000000..25ab64f9c
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/in_unpack_generic.c
@@ -0,0 +1,153 @@
+/* Generic helper function for repacking arrays.
+ Copyright 2003, 2004, 2005, 2007 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <assert.h>
+#include <string.h>
+
+extern void internal_unpack (gfc_array_char *, const void *);
+export_proto(internal_unpack);
+
+void
+internal_unpack (gfc_array_char * d, const void * s)
+{
+ index_type count[GFC_MAX_DIMENSIONS];
+ index_type extent[GFC_MAX_DIMENSIONS];
+ index_type stride[GFC_MAX_DIMENSIONS];
+ index_type stride0;
+ index_type dim;
+ index_type dsize;
+ char *dest;
+ const char *src;
+ int n;
+ int size;
+ int type;
+
+ dest = d->data;
+ /* This check may be redundant, but do it anyway. */
+ if (s == dest || !s)
+ return;
+
+ type = GFC_DESCRIPTOR_TYPE (d);
+ size = GFC_DESCRIPTOR_SIZE (d);
+ switch (type)
+ {
+ case GFC_DTYPE_INTEGER:
+ case GFC_DTYPE_LOGICAL:
+ case GFC_DTYPE_REAL:
+ 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;
+ }
+ break;
+
+ case GFC_DTYPE_COMPLEX:
+ switch (size)
+ {
+ case 8:
+ internal_unpack_c4 ((gfc_array_c4 *)d, (const GFC_COMPLEX_4 *)s);
+ return;
+
+ case 16:
+ internal_unpack_c8 ((gfc_array_c8 *)d, (const GFC_COMPLEX_8 *)s);
+ return;
+ }
+ default:
+ break;
+ }
+
+ 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 probably 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/gcc-4.3.1/libgfortran/runtime/main.c b/gcc-4.3.1/libgfortran/runtime/main.c
new file mode 100644
index 000000000..8632f152c
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/main.c
@@ -0,0 +1,180 @@
+/* Copyright (C) 2002-2003, 2005, 2007 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 (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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <stdlib.h>
+#include <string.h>
+#include <limits.h>
+
+
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+/* Stupid function to be sure the constructor is always linked in, even
+ in the case of static linking. See PR libfortran/22298 for details. */
+void
+stupid_function_name_for_static_linking (void)
+{
+ return;
+}
+
+/* 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 = 0;
+
+
+/* Figure out endianness for this machine. */
+
+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;
+}
+
+
+static const char *exe_path;
+static int please_free_exe_path_when_done;
+
+/* Save the path under which the program was called, for use in the
+ backtrace routines. */
+void
+store_exe_path (const char * argv0)
+{
+#ifndef PATH_MAX
+#define PATH_MAX 1024
+#endif
+
+#ifndef DIR_SEPARATOR
+#define DIR_SEPARATOR '/'
+#endif
+
+ char buf[PATH_MAX], *cwd, *path;
+
+ if (argv0[0] == '/')
+ {
+ exe_path = argv0;
+ please_free_exe_path_when_done = 0;
+ return;
+ }
+
+ memset (buf, 0, sizeof (buf));
+#ifdef HAVE_GETCWD
+ cwd = getcwd (buf, sizeof (buf));
+#else
+ cwd = "";
+#endif
+
+ /* exe_path will be cwd + "/" + argv[0] + "\0" */
+ path = malloc (strlen (cwd) + 1 + strlen (argv0) + 1);
+ sprintf (path, "%s%c%s", cwd, DIR_SEPARATOR, argv0);
+ exe_path = path;
+ please_free_exe_path_when_done = 1;
+}
+
+/* Return the full path of the executable. */
+char *
+full_exe_path (void)
+{
+ return (char *) exe_path;
+}
+
+/* Initialize the runtime library. */
+
+static void __attribute__((constructor))
+init (void)
+{
+ /* Figure out the machine endianness. */
+ determine_endianness ();
+
+ /* Must be first */
+ init_variables ();
+
+ init_units ();
+ set_fpu ();
+ init_compile_options ();
+
+#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
+
+ random_seed_i4 (NULL, NULL, NULL);
+}
+
+
+/* Cleanup the runtime library. */
+
+static void __attribute__((destructor))
+cleanup (void)
+{
+ close_units ();
+
+ if (please_free_exe_path_when_done)
+ free ((char *) exe_path);
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/memory.c b/gcc-4.3.1/libgfortran/runtime/memory.c
new file mode 100644
index 000000000..d84d32200
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/memory.c
@@ -0,0 +1,73 @@
+/* Memory management routines.
+ Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <stdlib.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 */
+
+void *
+get_mem (size_t n)
+{
+ void *p;
+
+#ifdef GFC_CLEAR_MEMORY
+ p = (void *) calloc (1, n);
+#else
+ p = (void *) malloc (n);
+#endif
+ if (p == NULL)
+ os_error ("Memory allocation failed");
+
+ return p;
+}
+
+
+void
+free_mem (void *p)
+{
+ free (p);
+}
+
+
+/* Allocate memory for internal (compiler generated) use. */
+
+void *
+internal_malloc_size (size_t size)
+{
+ if (size == 0)
+ return NULL;
+
+ return get_mem (size);
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/pause.c b/gcc-4.3.1/libgfortran/runtime/pause.c
new file mode 100644
index 000000000..8ee0e844a
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/pause.c
@@ -0,0 +1,76 @@
+/* Implementation of the STOP statement.
+ Copyright 2002, 2005, 2007 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <string.h>
+
+
+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. */
+
+extern void pause_numeric (GFC_INTEGER_4 code);
+export_proto(pause_numeric);
+
+void
+pause_numeric (GFC_INTEGER_4 code)
+{
+ if (code == -1)
+ st_printf ("PAUSE\n");
+ else
+ st_printf ("PAUSE %d\n", (int)code);
+
+ do_pause ();
+}
+
+extern void pause_string (char *string, GFC_INTEGER_4 len);
+export_proto(pause_string);
+
+void
+pause_string (char *string, GFC_INTEGER_4 len)
+{
+ st_printf ("PAUSE ");
+ while (len--)
+ st_printf ("%c", *(string++));
+ st_printf ("\n");
+
+ do_pause ();
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/select.c b/gcc-4.3.1/libgfortran/runtime/select.c
new file mode 100644
index 000000000..44c353235
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/select.c
@@ -0,0 +1,137 @@
+/* Implement the SELECT statement for character variables.
+ 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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+
+typedef struct
+{
+ char *low;
+ int low_len;
+ char *high;
+ int high_len;
+ int address;
+}
+select_struct;
+
+extern int select_string (select_struct *table, int table_len,
+ const char *selector, int selector_len);
+export_proto(select_string);
+
+
+/* select_string()-- Given a selector string and a table of
+ * select_struct structures, return the address to jump to. */
+
+int
+select_string (select_struct *table, int table_len, const char *selector,
+ int selector_len)
+{
+ select_struct *t;
+ int i, low, high, mid;
+ int default_jump = -1;
+
+ if (table_len == 0)
+ return -1;
+
+ /* 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/gcc-4.3.1/libgfortran/runtime/stop.c b/gcc-4.3.1/libgfortran/runtime/stop.c
new file mode 100644
index 000000000..4f6f90711
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/stop.c
@@ -0,0 +1,60 @@
+/* Implementation of the STOP statement.
+ Copyright 2002, 2005, 2007 Free Software Foundation, Inc.
+ Contributed by Paul Brook <paul@nowt.org>
+
+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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <string.h>
+
+/* A numeric or blank STOP statement. */
+void
+stop_numeric (GFC_INTEGER_4 code)
+{
+ if (code == -1)
+ code = 0;
+ else
+ st_printf ("STOP %d\n", (int)code);
+
+ sys_exit (code);
+}
+iexport(stop_numeric);
+
+
+extern void stop_string (const char *string, GFC_INTEGER_4 len);
+export_proto(stop_string);
+
+void
+stop_string (const char *string, GFC_INTEGER_4 len)
+{
+ st_printf ("STOP ");
+ while (len--)
+ st_printf ("%c", *(string++));
+ st_printf ("\n");
+
+ sys_exit (0);
+}
diff --git a/gcc-4.3.1/libgfortran/runtime/string.c b/gcc-4.3.1/libgfortran/runtime/string.c
new file mode 100644
index 000000000..ee7bcfb4b
--- /dev/null
+++ b/gcc-4.3.1/libgfortran/runtime/string.c
@@ -0,0 +1,128 @@
+/* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc.
+ Contributed by Paul Brook
+
+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.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+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, 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include <string.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, gfc_charlen_type s1_len, const char *s2)
+{
+ size_t len;
+
+ /* Strip trailing blanks from the Fortran string. */
+ len = fstrlen (s1, s1_len);
+ if (len != strlen(s2)) return 0; /* don't match */
+ return strncasecmp (s1, s2, len) == 0;
+}
+
+
+/* Given a fortran string, return its length exclusive of the trailing
+ spaces. */
+
+gfc_charlen_type
+fstrlen (const char *string, gfc_charlen_type len)
+{
+ for (; len > 0; len--)
+ if (string[len-1] != ' ')
+ break;
+
+ return len;
+}
+
+
+/* Copy a Fortran string (not null-terminated, hence length arguments
+ for both source and destination strings. Returns the non-padded
+ length of the destination. */
+
+gfc_charlen_type
+fstrcpy (char *dest, gfc_charlen_type destlen,
+ const char *src, gfc_charlen_type srclen)
+{
+ if (srclen >= destlen)
+ {
+ /* This will truncate if too long. */
+ memcpy (dest, src, destlen);
+ return destlen;
+ }
+ else
+ {
+ memcpy (dest, src, srclen);
+ /* Pad with spaces. */
+ memset (&dest[srclen], ' ', destlen - srclen);
+ return srclen;
+ }
+}
+
+
+/* Copy a null-terminated C string to a non-null-terminated Fortran
+ string. Returns the non-padded length of the destination string. */
+
+gfc_charlen_type
+cf_strcpy (char *dest, gfc_charlen_type dest_len, const char *src)
+{
+ size_t src_len;
+
+ src_len = strlen (src);
+
+ if (src_len >= (size_t) dest_len)
+ {
+ /* This will truncate if too long. */
+ memcpy (dest, src, dest_len);
+ return dest_len;
+ }
+ else
+ {
+ memcpy (dest, src, src_len);
+ /* Pad with spaces. */
+ memset (&dest[src_len], ' ', dest_len - src_len);
+ return 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 (st_parameter_common *cmp, const char *s1, gfc_charlen_type s1_len,
+ const st_option * opts, const char *error_message)
+{
+ for (; opts->name; opts++)
+ if (compare0 (s1, s1_len, opts->name))
+ return opts->value;
+
+ generate_error (cmp, LIBERROR_BAD_OPTION, error_message);
+
+ return -1;
+}