Imported from mainline FSF repositories

From-SVN: r94600

gcc/config/dsp16xx/dsp16xx-modes.def

@@ -0,0 +1,23 @@
+/* DSP16xx extra modes.
+   Copyright (C) 2003 Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* HFmode is the DSP16xx's equivalent of SFmode.
+   FIXME: What format is this anyway? */ 
+FLOAT_MODE (HF, 2, 0);

gcc/config/dsp16xx/dsp16xx-protos.h

@@ -0,0 +1,86 @@
+/* Definitions of target machine for GNU compiler.  AT&T DSP1600.
+   Copyright (C) 2000 Free Software Foundation, Inc.
+   Contributed by Michael Collison (collison@world.std.com).
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#ifdef RTX_CODE
+extern struct rtx_def *gen_compare_reg (enum rtx_code, rtx, rtx);
+extern int call_address_operand (rtx, enum machine_mode);
+extern int arith_reg_operand (rtx, enum machine_mode);
+extern int symbolic_address_operand (rtx, enum machine_mode);
+extern int Y_address_operand (rtx, enum machine_mode);
+extern int sp_operand (rtx, enum machine_mode);
+extern int sp_operand2 (rtx, enum machine_mode);
+extern int nonmemory_arith_operand (rtx, enum machine_mode);
+extern int dsp16xx_comparison_operator (rtx, enum machine_mode);
+extern int unx_comparison_operator (rtx, enum machine_mode);
+extern int signed_comparison_operator (rtx, enum machine_mode);
+
+extern void notice_update_cc (rtx);
+extern void double_reg_from_memory (rtx[]);
+extern void double_reg_to_memory (rtx[]);
+extern enum rtx_code next_cc_user_code (rtx);
+extern int next_cc_user_unsigned (rtx);
+extern struct rtx_def *gen_tst_reg (rtx);
+extern const char *output_block_move (rtx[]);
+extern enum reg_class preferred_reload_class (rtx, enum reg_class);
+extern enum reg_class secondary_reload_class (enum reg_class,
+					      enum machine_mode, rtx);
+extern int emit_move_sequence (rtx *, enum machine_mode);
+extern void print_operand (FILE *, rtx, int);
+extern void print_operand_address (FILE *, rtx);
+extern void output_dsp16xx_float_const (rtx *);
+extern void emit_1600_core_shift (enum rtx_code, rtx *, int);
+extern int symbolic_address_p (rtx);
+extern int uns_comparison_operator (rtx, enum machine_mode);
+#endif /* RTX_CODE */
+
+
+#ifdef TREE_CODE
+extern struct rtx_def *dsp16xx_function_arg (CUMULATIVE_ARGS,
+					     enum machine_mode,
+					     tree, int);
+extern void dsp16xx_function_arg_advance (CUMULATIVE_ARGS *,
+					  enum machine_mode,
+					  tree, int);
+#endif /* TREE_CODE */
+
+extern void dsp16xx_invalid_register_for_compare (void);
+extern int class_max_nregs (enum reg_class, enum machine_mode);
+extern enum reg_class limit_reload_class (enum reg_class, enum machine_mode);
+extern int dsp16xx_register_move_cost (enum reg_class, enum reg_class);
+extern int dsp16xx_makes_calls (void);
+extern long compute_frame_size (int);
+extern int dsp16xx_call_saved_register (int);
+extern int dsp16xx_call_saved_register (int);
+extern void init_emulation_routines (void);
+extern int ybase_regs_ever_used (void);
+extern void override_options (void);
+extern int dsp16xx_starting_frame_offset (void);
+extern int initial_frame_pointer_offset (void);
+extern void asm_output_common (FILE *, const char *, int, int);
+extern void asm_output_local (FILE *, const char *, int, int);
+extern void asm_output_float (FILE *, double);
+extern bool dsp16xx_compare_gen;
+extern int hard_regno_mode_ok (int, enum machine_mode);
+extern enum reg_class dsp16xx_reg_class_from_letter (int);
+extern int regno_reg_class (int);
+extern void function_prologue (FILE *, int);
+extern void function_epilogue (FILE *, int);
+extern int num_1600_core_shifts (int);

gcc/config/i370/README

@@ -0,0 +1,125 @@
+
+This directory contains code for building a compiler for the
+32-bit ESA/390 architecture.  It supports three different styles 
+of assembly:
+
+-- MVS for use with the HLASM assembler
+-- Open Edition (USS Unix System Services) 
+-- ELF/Linux for use with the binutils/gas GNU assembler.
+
+
+Cross-compiling Hints
+---------------------
+When building a cross-compiler on AIX, set the environment variable CC
+and be sure to set the -ma and -qcpluscmt flags; i.e.
+
+   export CC="cc -ma -qcpluscmt"
+
+do this *before* running configure, e.g.
+
+   configure --target=i370-ibm-linux --prefix=/where/to/install/usr
+
+The Objective-C and FORTRAN front ends don't build.  To avoid looking at
+errors, do only 
+
+   make LANGUAGES=c
+
+
+OpenEdition Hints
+-----------------
+The shell script "install" is handy for users of OpenEdition.
+
+
+The ELF ABI
+-----------
+This compiler, in conjunction with the gas/binutils assembler, defines
+a defacto ELF-based ABI for the ESA/390 architecture.  Be warned: this 
+ABI has several major faults.  It should be fixed.  As it is fixed,
+it is subject to change without warning.  You should not commit to major
+software systems without further exploring and fixing these problems.
+Here are some of the problems:
+
+-- No support for shared libraries or dynamically loadable objects.
+   This is because the compiler currently places address literals in 
+   the text section.  Although the GAS assembler supports a syntax for 
+   USING that will place address literals in the data section, this forces
+   the use of two base registers, one for branches and one for the literal 
+   pool. Work is needed to redesign the function prologue, epilogue and the 
+   base register reloads to minimize the currently excessive use of reserved 
+   registers. 
+
+   I beleive the best solution would be to add a toc or plt, and extending
+   the meaning of the USING directive to encompass this.  This would 
+   allow the continued use of the human-readable and familiar practice
+   of using =A() and =F'' to denote address literals, as opposed to more 
+   difficult jump-table notation.
+
+-- the stackframe is almost twice as big as it needs to be.
+
+-- currently, r15 is used to return 32-bit values.  Because this is the
+   last register, it prevents 64-bit ints and small structures from being 
+   returned in registers, forcing return in memory.  It would be more
+   efficient to use r14 to return 32-bit values, and r14+r15 to return
+   64-bit values.
+
+-- all arguments are currently passed in memory.  It would be more efficient 
+   to pass arguments in registers.
+
+
+
+
+ChangeLog
+---------
+Oct98-Dec98 -- add ELF back end; work on getting ABI more or less functional.
+98.12.05 -- fix numerous MVC bugs
+99.02.06 -- multiply insn sometimes not generated when needed.
+         -- extendsidi bugs, bad literal values printed
+         -- remove broken adddi subdi patterns
+99.02.15 -- add clrstrsi pattern
+         -- fix -O2 divide bug
+99.03.04 -- base & index reg usage bugs
+99.03.15 -- fixes for returning long longs and structs (struct value return)
+99.03.29 -- fix handling & alignment of shorts
+99.03.31 -- clobbered register 14 is not always clobbered
+99.04.02 -- operand constraints for cmphi
+99.04.07 -- function pointer fixes for call, call_value patterns,
+            function pointers derefed once too often.
+99.04.14 -- add pattern to print double-wide int
+         -- check intval<4096 for misc operands
+         -- add clrstrsi pattern
+         -- movstrsi fixes
+99.04.16 -- use r2 to pass args into r11 in subroutine call.
+         -- fixes to movsi; some operand combinations impossible;
+            rework constraints
+         -- start work on forward jump optimization
+         -- char alignment bug
+99.04.25 -- add untyped_call pattern so that builtin_apply works
+99.04.27 -- fixes to compare logical under mask
+99.04.28 -- reg 2 is clobbered by calls
+99.04.30 -- fix rare mulsi bug
+99.04.30 -- add constraints so that all RS, SI, SS forms insns have valid
+            addressing modes
+99.04.30 -- major condition code fixes. The old code was just way off 
+            w.r.t. which insns set condition code, and the codes that
+            were set.  The extent of this damage was unbeleivable.
+99.05.01 -- restructuring of operand constraints on many patterns,
+            many lead to invalid instructions being genned.
+99.05.02 -- float pt fixes
+         -- fix movdi issue bugs
+99.05.03 -- fix divide insn; was dividing incorrectly
+99.05.05 -- fix sign extension problems on andhi
+         -- deprecate some constraints
+99.05.06 -- add set_attr insn lengths; fix misc litpool sizes
+         -- add notes about how unsigned jumps work (i.e. 
+            arithmetic vs. logical vs. signed vs unsigned).
+99.05.11 -- use insn length to predict forward branch target;
+            use relative branchining where possible,
+            remove un-needed base register reload.
+99.05.15 -- fix movstrsi, clrstrsi, cmpstrsi patterns as per conversation 
+            w/ Richard Henderson
+
+
+
+
+
+

gcc/config/i370/i370-c.c

@@ -0,0 +1,64 @@
+/* Subroutines for the C front end for System/370.
+   Copyright (C) 1989, 1993, 1995, 1997, 1998, 1999, 2000
+   Free Software Foundation, Inc.
+   Contributed by Jan Stein (jan@cd.chalmers.se).
+   Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
+   Hacked for Linux-ELF/390 by Linas Vepstas (linas@linas.org) 
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; 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 "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "tree.h"
+#include "toplev.h"
+#include "cpplib.h"
+#include "c-pragma.h"
+#include "tm_p.h"
+
+#ifdef TARGET_HLASM
+
+/* #pragma map (name, alias) -
+   In this implementation both name and alias are required to be
+   identifiers.  The older code seemed to be more permissive.  Can
+   anyone clarify?  */
+
+void
+i370_pr_map (pfile)
+     cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+  tree name, alias, x;
+
+  if (c_lex (&x)        == CPP_OPEN_PAREN
+      && c_lex (&name)  == CPP_NAME
+      && c_lex (&x)     == CPP_COMMA
+      && c_lex (&alias) == CPP_NAME
+      && c_lex (&x)     == CPP_CLOSE_PAREN)
+    {
+      if (c_lex (&x) != CPP_EOF)
+	warning ("junk at end of #pragma map");
+
+      mvs_add_alias (IDENTIFIER_POINTER (name), IDENTIFIER_POINTER (alias), 1);
+      return;
+    }
+
+  warning ("malformed #pragma map, ignored");
+}
+
+#endif

gcc/config/i370/i370-protos.h

@@ -0,0 +1,55 @@
+/* Definitions of target machine for GNU compiler.  System/370 version.
+   Copyright (C) 2000 Free Software Foundation, Inc.
+   Contributed by Jan Stein (jan@cd.chalmers.se).
+   Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
+   Hacked for Linux-ELF/390 by Linas Vepstas (linas@linas.org)
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#ifndef GCC_I370_PROTOS_H
+#define GCC_I370_PROTOS_H
+
+extern void override_options (void);
+
+#ifdef RTX_CODE
+extern int i370_branch_dest (rtx);
+extern int i370_branch_length (rtx);
+extern int i370_short_branch (rtx);
+extern int s_operand (rtx, enum machine_mode);
+extern int r_or_s_operand (rtx, enum machine_mode);
+extern int unsigned_jump_follows_p (rtx);
+#endif /* RTX_CODE */
+
+#ifdef TREE_CODE
+extern int handle_pragma (int (*)(void), void (*)(int), const char *);
+#endif /* TREE_CODE */
+
+extern void mvs_add_label (int);
+extern int mvs_check_label (int);
+extern int mvs_check_page (FILE *, int, int);
+extern int mvs_function_check (const char *);
+extern void mvs_add_alias (const char *, const char *, int);
+extern int mvs_need_alias (const char *);
+extern int mvs_get_alias (const char *, char *);
+extern int mvs_check_alias (const char *, char *);
+extern void check_label_emit (void);
+extern void mvs_free_label_list (void);
+
+extern void i370_pr_map (struct cpp_reader *);
+
+#endif /* ! GCC_I370_PROTOS_H */

gcc/config/i370/linux.h

@@ -0,0 +1,113 @@
+/* Definitions of target machine for GNU compiler.  System/370 version.
+   Copyright (C) 1989, 1993, 1995, 1996, 1997, 2003
+   Free Software Foundation, Inc.
+   Contributed by Jan Stein (jan@cd.chalmers.se).
+   Modified for Linux/390 by Linas Vepstas (linas@linas.org)
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+
+#define TARGET_VERSION fprintf (stderr, " (i370 GNU/Linux with ELF)");
+
+/* Specify that we're generating code for a Linux port to 370 */
+
+#define TARGET_ELF_ABI
+
+/* Target OS preprocessor built-ins.  */
+#define TARGET_OS_CPP_BUILTINS() LINUX_TARGET_OS_CPP_BUILTINS()
+
+/* Options for this target machine.  */
+
+#define LIBGCC_SPEC "libgcc.a%s"
+
+#ifdef SOME_FUTURE_DAY
+ 
+#define CPP_SPEC "%{posix: -D_POSIX_SOURCE} %(cpp_sysv) %(cpp_endian_big) \
+%{mcall-linux: %(cpp_os_linux) } \
+%{!mcall-linux: %(cpp_os_default) }"
+
+#define LIB_SPEC "\
+%{mcall-linux: %(lib_linux) } \
+%{!mcall-linux:%(lib_default) }"
+
+#define STARTFILE_SPEC "\
+%{mcall-linux: %(startfile_linux) } \
+%{!mcall-linux: %(startfile_default) }"
+
+#define ENDFILE_SPEC "\
+%{mcall-linux: %(endfile_linux) } \
+%{!mcall-linux: %(endfile_default) }"
+
+/* GNU/Linux support.  */
+#ifndef LIB_LINUX_SPEC
+#define LIB_LINUX_SPEC "%{mnewlib: --start-group -llinux -lc --end-group } %{!mnewlib: -lc }"
+#endif
+
+#ifndef STARTFILE_LINUX_SPEC
+#define STARTFILE_LINUX_SPEC "\
+%{!shared: %{pg:gcrt1.o%s} %{!pg:%{p:gcrt1.o%s} %{!p:crt1.o%s}}} \
+%{mnewlib: ecrti.o%s} \
+%{!mnewlib: crti.o%s %{!shared:crtbegin.o%s} %{shared:crtbeginS.o%s}}"
+#endif
+
+#ifndef ENDFILE_LINUX_SPEC
+#define ENDFILE_LINUX_SPEC "\
+%{mnewlib: ecrtn.o%s} \
+%{!mnewlib: %{!shared:crtend.o%s} %{shared:crtendS.o%s} crtn.o%s}"
+#endif
+
+#ifndef LINK_START_LINUX_SPEC
+#define LINK_START_LINUX_SPEC "-Ttext 0x10000"
+#endif
+
+#ifndef LINK_OS_LINUX_SPEC
+#define LINK_OS_LINUX_SPEC ""
+#endif
+
+#ifndef CPP_OS_LINUX_SPEC
+#define CPP_OS_LINUX_SPEC "-D__unix__ -D__gnu_linux__ -D__linux__ \
+%{!ansi: -Dunix -Dlinux } \
+-Asystem=unix -Asystem=linux"
+#endif
+
+#ifndef CPP_OS_LINUX_SPEC
+#define CPP_OS_LINUX_SPEC ""
+#endif
+
+
+/* Define any extra SPECS that the compiler needs to generate.  */
+#undef  SUBTARGET_EXTRA_SPECS
+#define SUBTARGET_EXTRA_SPECS                                           \
+  { "lib_linux",                LIB_LINUX_SPEC },                       \
+  { "lib_default",              LIB_DEFAULT_SPEC },                     \
+  { "startfile_linux",          STARTFILE_LINUX_SPEC },                 \
+  { "startfile_default",        STARTFILE_DEFAULT_SPEC },               \
+  { "endfile_linux",            ENDFILE_LINUX_SPEC },                   \
+  { "endfile_default",          ENDFILE_DEFAULT_SPEC },                 \
+  { "link_shlib",               LINK_SHLIB_SPEC },                      \
+  { "link_target",              LINK_TARGET_SPEC },                     \
+  { "link_start",               LINK_START_SPEC },                      \
+  { "link_start_linux",         LINK_START_LINUX_SPEC },                \
+  { "link_os",                  LINK_OS_SPEC },                         \
+  { "link_os_linux",            LINK_OS_LINUX_SPEC },                   \
+  { "link_os_default",          LINK_OS_DEFAULT_SPEC },                 \
+  { "cpp_endian_big",           CPP_ENDIAN_BIG_SPEC },                  \
+  { "cpp_os_linux",             CPP_OS_LINUX_SPEC },                    \
+  { "cpp_os_default",           CPP_OS_DEFAULT_SPEC },
+
+#endif /* SOME_FUTURE_DAY */

gcc/config/i370/mvs.h

@@ -0,0 +1,49 @@
+/* Definitions of target machine for GNU compiler.  System/370 version.
+   Copyright (C) 1989, 1993, 1995, 1996, 1997, 2003
+   Free Software Foundation, Inc.
+   Contributed by Jan Stein (jan@cd.chalmers.se).
+   Modified for OS/390 LanguageEnvironment C by Dave Pitts (dpitts@cozx.com)
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#define TARGET_VERSION printf (" (370/MVS)");
+
+/* Specify that we're generating code for the Language Environment */
+
+#define LE370 1
+#define TARGET_EBCDIC 1
+#define TARGET_HLASM 1
+
+/* Options for the preprocessor for this target machine.  */
+
+#define CPP_SPEC "-trigraphs"
+
+/* Target OS preprocessor built-ins.  */
+#define TARGET_OS_CPP_BUILTINS()		\
+    do {					\
+	builtin_define_std ("MVS");		\
+	builtin_define_std ("mvs");		\
+	MAYBE_LE370_MACROS();			\
+	builtin_assert ("system=mvs");		\
+    } while (0)
+
+#if defined(LE370)
+# define MAYBE_LE370_MACROS() do {builtin_define_std ("LE370");} while (0)
+#else
+# define MAYBE_LE370_MACROS()
+#endif

gcc/config/i370/oe.h

@@ -0,0 +1,53 @@
+/* Definitions of target machine for GNU compiler.  System/370 version.
+   Copyright (C) 1989, 1993, 1995, 1996, 1997, 2003
+   Free Software Foundation, Inc.
+   Contributed by Jan Stein (jan@cd.chalmers.se).
+   Modified for OS/390 OpenEdition by Dave Pitts (dpitts@cozx.com)
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#define TARGET_VERSION printf (" (370/OpenEdition)");
+
+/* Specify that we're generating code for the Language Environment */
+
+#define LE370 1
+#define LONGEXTERNAL 1
+#define TARGET_EBCDIC 1
+#define TARGET_HLASM 1
+
+/* Options for the preprocessor for this target machine.  */
+
+#define CPP_SPEC "-trigraphs"
+
+/* Options for this target machine.  */
+
+#define LIB_SPEC ""
+#define LIBGCC_SPEC ""
+#define STARTFILE_SPEC "/usr/local/lib/gccmain.o"
+
+/* Target OS preprocessor built-ins.  */
+#define TARGET_OS_CPP_BUILTINS()		\
+    do {					\
+	builtin_define_std ("unix");		\
+	builtin_define_std ("UNIX");		\
+	builtin_define_std ("openedition");	\
+	builtin_define ("__i370__");		\
+	builtin_assert ("system=openedition");	\
+	builtin_assert ("system=unix");		\
+    } while (0)
+

gcc/config/i370/t-i370

@@ -0,0 +1,3 @@
+i370-c.o: $(srcdir)/config/i370/i370-c.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \
+  $(TM_H) $(TREE_H) toplev.h $(CPPLIB_H) c-pragma.h $(TM_P_H)
+	$(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)/config/i370/i370-c.c

gcc/config/i960/i960-c.c

@@ -0,0 +1,117 @@
+/* Intel 80960 specific, C compiler specific functions.
+   Copyright (C) 1992, 1995, 1996, 1997, 1998, 1999, 2000
+   Free Software Foundation, Inc.
+   Contributed by Steven McGeady, Intel Corp.
+   Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
+   Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; 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 "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "cpplib.h"
+#include "tree.h"
+#include "c-pragma.h"
+#include "toplev.h"
+#include "ggc.h"
+#include "tm_p.h"
+
+/* Handle pragmas for compatibility with Intel's compilers.  */
+
+/* NOTE: ic960 R3.0 pragma align definition:
+
+   #pragma align [(size)] | (identifier=size[,...])
+   #pragma noalign [(identifier)[,...]]
+     
+   (all parens are optional)
+     
+   - size is [1,2,4,8,16]
+   - noalign means size==1
+   - applies only to component elements of a struct (and union?)
+   - identifier applies to structure tag (only)
+   - missing identifier means next struct
+     
+   - alignment rules for bitfields need more investigation.
+
+   This implementation only handles the case of no identifiers.  */
+
+void
+i960_pr_align (pfile)
+     cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+  tree number;
+  enum cpp_ttype type;
+  int align;
+
+  type = c_lex (&number);
+  if (type == CPP_OPEN_PAREN)
+    type = c_lex (&number);
+  if (type == CPP_NAME)
+    {
+      warning ("sorry, not implemented: #pragma align NAME=SIZE");
+      return;
+    }
+  if (type != CPP_NUMBER)
+    {
+      warning ("malformed #pragma align - ignored");
+      return;
+    }
+
+  align = TREE_INT_CST_LOW (number);
+  switch (align)
+    {
+    case 0:
+      /* Return to last alignment.  */
+      align = i960_last_maxbitalignment / 8;
+      /* Fall through.  */
+    case 16:
+    case 8:
+    case 4:
+    case 2:
+    case 1:
+      i960_last_maxbitalignment = i960_maxbitalignment;
+      i960_maxbitalignment = align * 8;
+      break;
+      
+    default:
+      /* Silently ignore bad values.  */
+      break;
+    }
+}
+
+void
+i960_pr_noalign (pfile)
+     cpp_reader *pfile ATTRIBUTE_UNUSED;
+{
+  enum cpp_ttype type;
+  tree number;
+
+  type = c_lex (&number);
+  if (type == CPP_OPEN_PAREN)
+    type = c_lex (&number);
+  if (type == CPP_NAME)
+    {
+      warning ("sorry, not implemented: #pragma noalign NAME");
+      return;
+    }
+
+  i960_last_maxbitalignment = i960_maxbitalignment;
+  i960_maxbitalignment = 8;
+}

gcc/config/i960/i960-coff.h

@@ -0,0 +1,43 @@
+/* Definitions of target machine for GNU compiler, for "naked" Intel
+   80960 using coff object format and coff debugging symbols.
+   Copyright (C) 1988, 1989, 1991, 1996, 2000 Free Software Foundation.
+   Contributed by Steven McGeady (mcg@omepd.intel.com)
+   Additional work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
+   Converted to GCC 2.0 by Michael Tiemann, Cygnus Support.
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Support -gstabs using stabs in COFF sections.  */
+
+/* Generate SDB_DEBUGGING_INFO by default.  */
+#undef PREFERRED_DEBUGGING_TYPE
+#define PREFERRED_DEBUGGING_TYPE SDB_DEBUG
+
+/* This is intended to be used with Cygnus's newlib library, so we want to
+   use the standard definition of LIB_SPEC.  */
+#undef LIB_SPEC
+
+/* Emit a .file directive.  */
+#define TARGET_ASM_FILE_START_FILE_DIRECTIVE true
+
+/* Support the ctors and dtors sections for g++.  */
+
+#define CTORS_SECTION_ASM_OP	"\t.section\t.ctors,\"x\""
+#define DTORS_SECTION_ASM_OP	"\t.section\t.dtors,\"x\""
+
+/* end of i960-coff.h */

gcc/config/i960/i960-modes.def

@@ -0,0 +1,33 @@
+/* Definitions of target machine for GNU compiler, for Intel 80960
+   Copyright (C) 2002 Free Software Foundation, Inc.
+   Contributed by Steven McGeady, Intel Corp.
+   Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
+   Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* long double */
+FLOAT_MODE (TF, 16, ieee_extended_intel_128_format);
+
+/* Add any extra modes needed to represent the condition code.
+
+   Also, signed and unsigned comparisons are distinguished, as
+   are operations which are compatible with chkbit insns.  */
+
+CC_MODE (CC_UNS);
+CC_MODE (CC_CHK);

gcc/config/i960/i960-protos.h

@@ -0,0 +1,102 @@
+/* Definitions of target machine for GNU compiler, for Intel 80960
+   Copyright (C) 2000
+   Free Software Foundation, Inc.
+   Contributed by Steven McGeady, Intel Corp.
+   Additional Work by Glenn Colon-Bonet, Jonathan Shapiro, Andy Wilson
+   Converted to GCC 2.0 by Jim Wilson and Michael Tiemann, Cygnus Support.
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+#ifndef GCC_I960_PROTOS_H
+#define GCC_I960_PROTOS_H
+
+#ifdef RTX_CODE
+extern struct rtx_def *legitimize_address (rtx, rtx, enum machine_mode);
+/* Define the function that build the compare insn for scc and bcc.  */
+
+extern struct rtx_def *gen_compare_reg (enum rtx_code, rtx, rtx);
+
+/* Define functions in i960.c and used in insn-output.c.  */
+
+extern const char *i960_output_ldconst (rtx, rtx);
+extern const char *i960_output_call_insn (rtx, rtx, rtx, rtx);
+extern const char *i960_output_ret_insn (rtx);
+extern const char *i960_output_move_double (rtx, rtx);
+extern const char *i960_output_move_double_zero (rtx);
+extern const char *i960_output_move_quad (rtx, rtx);
+extern const char *i960_output_move_quad_zero (rtx);
+
+extern int literal (rtx, enum machine_mode);
+extern int hard_regno_mode_ok (int, enum machine_mode);
+extern int fp_literal (rtx, enum machine_mode);
+extern int signed_literal (rtx, enum machine_mode);
+extern int legitimate_address_p (enum machine_mode, rtx, int);
+extern void i960_print_operand (FILE *, rtx, int);
+extern int fpmove_src_operand (rtx, enum machine_mode);
+extern int arith_operand (rtx, enum machine_mode);
+extern int logic_operand (rtx, enum machine_mode);
+extern int fp_arith_operand (rtx, enum machine_mode);
+extern int signed_arith_operand (rtx, enum machine_mode);
+extern int fp_literal_one (rtx, enum machine_mode);
+extern int fp_literal_zero (rtx, enum machine_mode);
+extern int symbolic_memory_operand (rtx, enum machine_mode);
+extern int eq_or_neq (rtx, enum machine_mode);
+extern int arith32_operand (rtx, enum machine_mode);
+extern int power2_operand (rtx, enum machine_mode);
+extern int cmplpower2_operand (rtx, enum machine_mode);
+extern enum machine_mode select_cc_mode (RTX_CODE, rtx);
+extern int emit_move_sequence (rtx *, enum machine_mode);
+extern int i960_bypass (rtx, rtx, rtx, int);
+extern void i960_print_operand_addr (FILE *, rtx);
+extern int i960_expr_alignment (rtx, int);
+extern int i960_improve_align (rtx, rtx, int);
+extern int i960_si_ti (rtx, rtx);
+extern int i960_si_di (rtx, rtx);
+#ifdef TREE_CODE
+extern struct rtx_def *i960_function_arg (CUMULATIVE_ARGS *,
+					  enum machine_mode,
+					  tree, int);
+extern rtx i960_va_arg (tree, tree);
+extern void i960_va_start (tree, rtx);
+#endif /* TREE_CODE */
+extern enum reg_class secondary_reload_class (enum reg_class, enum machine_mode, rtx);
+#endif /* RTX_CODE */
+
+#ifdef TREE_CODE
+extern void i960_function_name_declare (FILE *, const char *, tree);
+extern void i960_function_arg_advance (CUMULATIVE_ARGS *, enum machine_mode, tree, int);
+extern int i960_round_align (int, tree);
+extern void i960_setup_incoming_varargs (CUMULATIVE_ARGS *, enum machine_mode, tree, int *, int);
+extern int i960_final_reg_parm_stack_space (int, tree);
+extern int i960_reg_parm_stack_space (tree);
+#endif /* TREE_CODE */
+
+extern int process_pragma (int(*)(void), void(*)(int), const char *);
+extern int i960_object_bytes_bitalign (int);
+extern void i960_initialize (void);
+extern int bitpos (unsigned int);
+extern int is_mask (unsigned int);
+extern int bitstr (unsigned int, int *, int *);
+extern int compute_frame_size (int);
+extern void output_function_profiler (FILE *, int);
+extern void i960_scan_opcode (const char *);
+
+extern void i960_pr_align (struct cpp_reader *);
+extern void i960_pr_noalign (struct cpp_reader *);
+
+#endif /* ! GCC_I960_PROTOS_H  */

gcc/config/i960/rtems.h

@@ -0,0 +1,29 @@
+/* Definitions for rtems targeting an Intel i960.
+   Copyright (C) 1996, 1997, 2000, 2002 Free Software Foundation, Inc.
+   Contributed by Joel Sherrill (joel@OARcorp.com).
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* Target OS builtins.  */
+#define TARGET_OS_CPP_BUILTINS()		\
+  do						\
+    {						\
+	builtin_define ("__rtems__");		\
+	builtin_assert ("system=rtems");	\
+    }						\
+  while (0)

gcc/config/i960/t-960bare

@@ -0,0 +1,30 @@
+LIB2FUNCS_EXTRA = xp-bit.c
+
+# We want fine grained libraries, so use the new code to build the
+# floating point emulation libraries.
+FPBIT = fp-bit.c
+DPBIT = dp-bit.c
+
+dp-bit.c: $(srcdir)/config/fp-bit.c
+	echo '#define FLOAT_BIT_ORDER_MISMATCH' > dp-bit.c
+	cat $(srcdir)/config/fp-bit.c >> dp-bit.c
+
+fp-bit.c: $(srcdir)/config/fp-bit.c
+	echo '#define FLOAT' > fp-bit.c
+	echo '#define FLOAT_BIT_ORDER_MISMATCH' >> fp-bit.c
+	cat $(srcdir)/config/fp-bit.c >> fp-bit.c
+
+xp-bit.c: $(srcdir)/config/fp-bit.c
+	echo '#define EXTENDED_FLOAT_STUBS' > xp-bit.c
+	cat $(srcdir)/config/fp-bit.c >> xp-bit.c
+
+i960-c.o: $(srcdir)/config/i960/i960-c.c $(CONFIG_H) $(SYSTEM_H) \
+  coretypes.h $(TM_H) $(CPPLIB_H) $(TREE_H) c-pragma.h toplev.h $(GGC_H) $(TM_P_H)
+	$(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $(srcdir)/config/i960/i960-c.c
+
+MULTILIB_OPTIONS=mnumerics/msoft-float mlong-double-64
+MULTILIB_DIRNAMES=float soft-float ld64
+MULTILIB_MATCHES=mnumerics=msb mnumerics=msc mnumerics=mkb mnumerics=mkc mnumerics=mmc mnumerics=mcb mnumerics=mcc mnumerics=mjf msoft-float=msa msoft-float=mka msoft-float=mca msoft-float=mcf
+
+LIBGCC = stmp-multilib
+INSTALL_LIBGCC = install-multilib

gcc/f/Make-lang.in

@@ -0,0 +1,516 @@
+# Top level -*- makefile -*- fragment for GNU Fortran.
+#   Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
+
+#This file is part of GNU Fortran.
+
+#GNU Fortran 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.
+
+#GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# This file provides the language dependent support in the main Makefile.
+# Each language makefile fragment must provide the following targets:
+#
+# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
+# foo.install-normal, foo.install-common, foo.install-man,
+# foo.uninstall,
+# foo.mostlyclean, foo.clean, foo.distclean,
+# foo.maintainer-clean, foo.stage1, foo.stage2, foo.stage3, foo.stage4
+#
+# where `foo' is the name of the language.
+#
+# It should also provide rules for:
+#
+# - making any compiler driver (eg: g++)
+# - the compiler proper (eg: cc1plus)
+# - define the names for selecting the language in LANGUAGES.
+#
+# $(srcdir) must be set to the gcc/ source directory (not gcc/f/).
+#
+# Actual name to use when installing a native compiler.
+G77_INSTALL_NAME := $(shell echo g77|sed '$(program_transform_name)')
+
+# Some versions of `touch' (such as the version on Solaris 2.8) 
+# do not correctly set the timestamp due to buggy versions of `utime'
+# in the kernel.  So, we use `echo' instead. 
+STAMP = echo timestamp >
+
+#
+# Define the names for selecting f77 in LANGUAGES.
+# Note that it would be nice to move the dependency on g77
+# into the F77 rule, but that needs a little bit of work
+# to do the right thing within all.cross.
+F77 f77: f771$(exeext)
+
+# Tell GNU make to ignore these if they exist.
+.PHONY: F77 f77 f77.all.build f77.all.cross \
+  f77.start.encap f77.rest.encap f77.dvi \
+  f77.install-normal \
+  f77.install-common f77.install-man \
+  f77.uninstall f77.mostlyclean f77.clean f77.distclean \
+  f77.maintainer-clean \
+  f77.stage1 f77.stage2 f77.stage3 f77.stage4 \
+  f77.stageprofile f77.stagefeedback
+
+g77spec.o: $(srcdir)/f/g77spec.c $(SYSTEM_H) coretypes.h $(TM_H) $(GCC_H) \
+	$(CONFIG_H) intl.h
+	(SHLIB_LINK='$(SHLIB_LINK)' \
+	SHLIB_MULTILIB='$(SHLIB_MULTILIB)'; \
+	$(CC) -c $(ALL_CFLAGS) $(ALL_CPPFLAGS) $(DRIVER_DEFINES) \
+		$(INCLUDES) $(srcdir)/f/g77spec.c)
+
+# Create the compiler driver for g77.
+g77$(exeext): gcc.o g77spec.o version.o prefix.o intl.o \
+  $(LIBDEPS) $(EXTRA_GCC_OBJS)
+	$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ gcc.o g77spec.o \
+	   version.o prefix.o intl.o $(EXTRA_GCC_OBJS) $(LIBS)
+
+# Create a version of the g77 driver which calls the cross-compiler.
+g77-cross$(exeext): g77$(exeext)
+	rm -f g77-cross$(exeext); \
+	cp g77$(exeext) g77-cross$(exeext)
+
+# The compiler itself.
+
+F77_OBJS = f/bad.o f/bit.o f/bld.o f/com.o f/data.o f/equiv.o f/expr.o \
+ f/global.o f/implic.o f/info.o f/intrin.o f/lab.o f/lex.o f/malloc.o \
+ f/name.o f/parse.o f/src.o f/st.o f/sta.o f/stb.o f/stc.o \
+ f/std.o f/ste.o f/storag.o f/stp.o f/str.o f/sts.o f/stt.o f/stu.o \
+ f/stv.o f/stw.o f/symbol.o f/target.o f/top.o f/type.o f/where.o
+
+# Use loose warnings for this front end.
+f-warn = $(WERROR)
+
+f771$(exeext): $(F77_OBJS) $(BACKEND) $(LIBDEPS)
+	rm -f f771$(exeext)
+	$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ $(F77_OBJS) $(BACKEND) $(LIBS)
+
+# Keyword tables.
+f/stamp-str: f/str-1t.h f/str-1t.j f/str-2t.h f/str-2t.j \
+ f/str-fo.h f/str-fo.j f/str-io.h f/str-io.j f/str-nq.h  f/str-nq.j \
+ f/str-op.h f/str-op.j f/str-ot.h f/str-ot.j
+	$(STAMP) f/stamp-str
+
+f/str-1t.h f/str-1t.j: f/fini$(build_exeext) f/str-1t.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-1t.fin f/str-1t.j f/str-1t.h
+
+f/str-2t.h f/str-2t.j: f/fini$(build_exeext) f/str-2t.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-2t.fin f/str-2t.j f/str-2t.h
+
+f/str-fo.h f/str-fo.j: f/fini$(build_exeext) f/str-fo.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-fo.fin f/str-fo.j f/str-fo.h
+
+f/str-io.h f/str-io.j: f/fini$(build_exeext) f/str-io.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-io.fin f/str-io.j f/str-io.h
+
+f/str-nq.h f/str-nq.j: f/fini$(build_exeext) f/str-nq.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-nq.fin f/str-nq.j f/str-nq.h
+
+f/str-op.h f/str-op.j: f/fini$(build_exeext) f/str-op.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-op.fin f/str-op.j f/str-op.h
+
+f/str-ot.h f/str-ot.j: f/fini$(build_exeext) f/str-ot.fin
+	./f/fini$(build_exeext) $(srcdir)/f/str-ot.fin f/str-ot.j f/str-ot.h
+
+f/fini$(build_exeext): f/fini.o $(BUILD_LIBDEPS)
+	$(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) -o f/fini$(build_exeext) \
+		f/fini.o $(BUILD_LIBS)
+
+f/fini.o:
+	$(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_CPPFLAGS) $(INCLUDES) \
+	      -c $(srcdir)/f/fini.c $(OUTPUT_OPTION)
+
+gt-f-lex.h gt-f-where.h gt-f-com.h gt-f-ste.h gtype-f.h : s-gtype; @true
+
+#
+# Build hooks:
+
+f77.all.build: g77$(exeext)
+f77.all.cross: g77-cross$(exeext)
+f77.start.encap: g77$(exeext)
+f77.rest.encap:
+
+f77.srcinfo: doc/g77.info
+	-cp -p $^ $(srcdir)/doc
+f77.srcman: doc/g77.1
+	-cp -p $^ $(srcdir)/doc
+f77.srcextra: f/BUGS f/NEWS 
+	-cp -p $^ $(srcdir)/f
+
+f77.tags: force
+	cd $(srcdir)/f; etags -o TAGS.sub *.c *.h; \
+	etags --include TAGS.sub --include ../TAGS.sub
+
+f77.info: doc/g77.info
+dvi:: doc/g77.dvi
+f77.man: doc/g77.1
+
+check-f77 : check-g77
+lang_checks += check-g77
+
+# g77 documentation.
+TEXI_G77_FILES = f/g77.texi f/bugs.texi f/ffe.texi f/invoke.texi \
+		 f/news.texi f/root.texi $(docdir)/include/fdl.texi \
+		 $(docdir)/include/gpl.texi $(docdir)/include/funding.texi \
+		 $(docdir)/include/gcc-common.texi $(srcdir)/f/intdoc.texi
+
+doc/g77.info: $(TEXI_G77_FILES)
+	if test "x$(BUILD_INFO)" = xinfo; then \
+	  rm -f $(@)*; \
+	  $(MAKEINFO) $(MAKEINFOFLAGS) -I$(docdir)/include -I$(srcdir)/f \
+            -o$@ $<; \
+	else true; fi
+
+doc/g77.dvi: $(TEXI_G77_FILES)
+	$(TEXI2DVI) -I $(srcdir)/f -I $(abs_docdir)/include -I $(objdir)/f -o $@ $<
+
+.INTERMEDIATE: g77.pod
+g77.pod: f/invoke.texi
+	-$(TEXI2POD) < $< > $@
+
+# This dance is all about producing accurate documentation for g77's
+# intrinsics with minimum fuss.  f/ansify appends "\n\" to C strings
+# so ANSI C compilers can compile f/intdoc.h -- gcc can compile f/intdoc.in
+# directly, if f/intdoc.c #include'd that, but we don't want to force
+# people to install gcc just to build the documentation.  We use the
+# C format for f/intdoc.in in the first place to allow a fairly "free",
+# but widely known format for documentation -- basically anyone who knows
+# how to write texinfo source and enclose it in C constants can handle
+# it, and f/ansify allows them to not even end lines with "\n\".  So,
+# essentially, the C preprocessor and compiler are used to enter the
+# document snippets into a data base via name lookup, rather than duplicating
+# that kind of code here.  And we use f/intdoc.c instead of straight
+# texinfo in the first place so that as much information as possible
+# contained in f/intrin.def can be inserted directly and reliably into
+# the documentation.  That's better than replicating it, because it
+# reduces the likelihood of discrepancies between the docs and the compiler
+# itself, which uses f/intrin.def; in fact, many bugs in f/intrin.def have
+# been found only upon reading the documentation that was automatically
+# produced from it.
+
+# If the documentation files depended on executables in the build
+# tree, there'd be no way to ship a source tree with the documentation
+# already generated such that `make' wouldn't attempt to rebuild it.
+# So, we punt and arrange for the documentation files to depend on the
+# dependencies of the executables, not on the executables themselves.
+# But then, we have to build the executables explicitly in their build
+# rules.
+
+INTDOC_DEPS = f/intdoc.c f/intrin.h f/intrin.def
+
+$(srcdir)/f/intdoc.texi: $(INTDOC_DEPS) f/intdoc.in
+	$(MAKE) f/intdoc$(build_exeext)
+	f/intdoc$(build_exeext) > $(srcdir)/f/intdoc.texi
+
+f/intdoc$(build_exeext): $(INTDOC_DEPS) f/intdoc.h0 bconfig.h \
+  $(SYSTEM_H) coretypes.h $(TM_H) $(BUILD_LIBDEPS)
+	$(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) $(INCLUDES) $< \
+	  $(BUILD_LIBS) -o $@
+
+f/intdoc.h0: f/intdoc.in f/ansify$(build_exeext)
+	f/ansify$(build_exeext) $< < $< > $@
+
+f/ansify$(build_exeext): f/ansify.c bconfig.h $(SYSTEM_H) coretypes.h $(TM_H)
+	  $(CC_FOR_BUILD) $(BUILD_CFLAGS) $(BUILD_LDFLAGS) $(INCLUDES) $< \
+	  -o $@
+
+f/BUGS: f/bugs0.texi f/bugs.texi f/root.texi
+	if [ x$(BUILD_INFO) = xinfo ]; then \
+	  rm -f $(@)*; \
+	  $(MAKEINFO) $(MAKEINFOFLAGS) -D BUGSONLY --no-header --no-split \
+           --no-validate -I$(docdir)/include -I$(srcdir)/f -o $@ bugs0.texi; \
+	else true; fi
+
+f/NEWS: f/news0.texi f/news.texi f/root.texi
+	if [ x$(BUILD_INFO) = xinfo ]; then \
+	  rm -f $(@)*; \
+	  $(MAKEINFO) $(MAKEINFOFLAGS) -D NEWSONLY --no-header --no-split \
+           --no-validate -I$(docdir)/include -I$(srcdir)/f -o $@ news0.texi; \
+	else true; fi
+
+#
+# Install hooks:
+# f771 is installed elsewhere as part of $(COMPILERS).
+
+f77.install-normal:
+
+# Install the driver program as $(target)-g77
+# and also as either g77 (if native) or $(tooldir)/bin/g77.
+f77.install-common: installdirs
+	-if [ -f f771$(exeext) ] ; then \
+	  rm -f $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
+	  $(INSTALL_PROGRAM) g77$(exeext) $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
+	  chmod a+x $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
+	else true; fi
+	@if [ -f f77-install-ok -o -f $(srcdir)/f77-install-ok ]; then \
+	  echo ''; \
+	  echo 'Warning: gcc no longer installs an f77 command.'; \
+	  echo '         You must do so yourself.  For more information,'; \
+	  echo '         read "Distributing Binaries" in the g77 docs.'; \
+	  echo '         (To turn off this warning, delete the file'; \
+	  echo '         f77-install-ok in the source or build directory.)'; \
+	  echo ''; \
+	else true; fi
+
+install-info:: $(DESTDIR)$(infodir)/g77.info
+
+f77.install-man: installdirs $(DESTDIR)$(man1dir)/$(G77_INSTALL_NAME)$(man1ext)
+
+$(DESTDIR)$(man1dir)/$(G77_INSTALL_NAME)$(man1ext): doc/g77.1
+	-rm -f $@
+	-$(INSTALL_DATA) $< $@
+	-chmod a-x $@
+
+f77.uninstall: installdirs
+	if $(SHELL) -c 'install-info --version | sed 1q | fgrep -s -v -i debian' >/dev/null 2>&1; then \
+	  echo " install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/g77.info"; \
+	  install-info --delete --info-dir=$(DESTDIR)$(infodir) $(DESTDIR)$(infodir)/g77.info || : ; \
+	else : ; fi
+	rm -rf $(DESTDIR)$(bindir)/$(G77_INSTALL_NAME)$(exeext); \
+	rm -rf $(DESTDIR)$(man1dir)/$(G77_INSTALL_NAME)$(man1ext); \
+	rm -rf $(DESTDIR)$(infodir)/g77.info*
+#
+# Clean hooks:
+# A lot of the ancillary files are deleted by the main makefile.
+# We just have to delete files specific to us.
+
+f77.mostlyclean:
+	-rm -f f/*$(objext)
+	-rm -f f/*$(coverageexts)
+	-rm -f f/fini$(build_exeext) f/stamp-str f/str-*.h f/str-*.j
+	-rm -f f/BUGS f/NEWS
+	-rm -f g77.aux g77.cps g77.ky g77.toc g77.vr g77.fn g77.kys \
+	       g77.pg g77.tp g77.vrs g77.cp g77.fns g77.log g77.pgs g77.tps 
+f77.clean:
+	-rm -f g77spec.o
+f77.distclean:
+	-rm -f f/Makefile
+f77.maintainer-clean:
+	-rm -f $(srcdir)/f/BUGS $(srcdir)/f/TAGS $(srcdir)/f/TAGS.SUB
+	-rm -f $(srcdir)/f/NEWS $(srcdir)/f/intdoc.texi
+#
+# Stage hooks:
+# The main makefile has already created stage?/f.
+
+G77STAGESTUFF = f/*$(objext) f/fini$(build_exeext) f/stamp-str \
+  f/str-*.h f/str-*.j g77spec.o
+
+f77.stage1: stage1-start
+	-mv -f $(G77STAGESTUFF) stage1/f
+
+f77.stage2: stage2-start
+	-mv -f $(G77STAGESTUFF) stage2/f
+
+f77.stage3: stage3-start
+	-mv -f $(G77STAGESTUFF) stage3/f
+
+f77.stage4: stage4-start
+	-mv -f $(G77STAGESTUFF) stage4/f
+
+f77.stageprofile: stageprofile-start
+	-mv -f $(G77STAGESTUFF) stageprofile/f
+
+f77.stagefeedback: stageprofile-start
+	-mv -f $(G77STAGESTUFF) stagefeedback/f
+#
+# .o: .h dependencies.
+
+f/bad.o: f/bad.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bad.h f/bad.def f/where.h \
+ glimits.h f/top.h f/malloc.h flags.h f/com.h f/com-rt.def $(TREE_H) f/bld.h \
+ f/bld-op.def f/bit.h f/info.h f/info-b.def f/info-k.def f/info-w.def \
+ f/target.h f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h \
+ f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h toplev.h intl.h \
+ diagnostic.h coretypes.h $(TM_H)
+f/bit.o: f/bit.c f/proj.h $(CONFIG_H) $(SYSTEM_H) glimits.h f/bit.h \
+ f/malloc.h coretypes.h $(TM_H)
+f/bld.o: f/bld.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bld.h f/bld-op.def f/bit.h \
+ f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
+ f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h f/top.h f/lex.h \
+ f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h f/global.h \
+ f/name.h f/intrin.h f/intrin.def real.h coretypes.h $(TM_H)
+f/com.o: f/com.c f/proj.h $(CONFIG_H) $(SYSTEM_H) flags.h $(RTL_H) $(TREE_H) \
+ output.h convert.h f/com.h f/com-rt.def f/bld.h f/bld-op.def f/bit.h \
+ f/malloc.h f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
+ f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/intrin.h \
+ f/intrin.def f/lab.h f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h \
+ f/name.h f/expr.h f/implic.h f/src.h f/st.h $(GGC_H) toplev.h diagnostic.h \
+ $(LANGHOOKS_DEF) langhooks.h intl.h real.h debug.h gt-f-com.h gtype-f.h \
+ coretypes.h $(TM_H)
+f/data.o: f/data.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/data.h f/bld.h f/bld-op.def \
+ f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
+ f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h \
+ f/global.h f/name.h f/intrin.h f/intrin.def f/expr.h f/st.h coretypes.h $(TM_H)
+f/equiv.o: f/equiv.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/equiv.h f/bld.h \
+ f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h \
+ glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \
+ f/global.h f/name.h f/intrin.h f/intrin.def f/data.h coretypes.h $(TM_H)
+f/expr.o: f/expr.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/expr.h f/bld.h f/bld-op.def \
+ f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
+ f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h \
+ f/global.h f/name.h f/intrin.h f/intrin.def f/implic.h f/src.h f/st.h \
+ f/stamp-str real.h coretypes.h $(TM_H)
+f/fini.o: f/fini.c f/proj.h bconfig.h $(SYSTEM_H) f/malloc.h coretypes.h $(TM_H)
+f/global.o: f/global.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/global.h f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/type.h f/name.h f/symbol.h \
+ f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h \
+ f/storag.h f/intrin.h f/intrin.def f/equiv.h coretypes.h $(TM_H)
+f/implic.o: f/implic.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/implic.h f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/type.h f/symbol.h \
+ f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h \
+ f/storag.h f/intrin.h f/intrin.def f/equiv.h f/global.h f/name.h f/src.h \
+ coretypes.h $(TM_H)
+f/info.o: f/info.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h $(TREE_H) f/bad.h f/bad.def f/where.h \
+ glimits.h f/top.h f/malloc.h f/lex.h f/type.h coretypes.h $(TM_H)
+f/intrin.o: f/intrin.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/intrin.h \
+ f/intrin.def f/bld.h f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def \
+ $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
+ f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h \
+ f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/expr.h f/src.h \
+ coretypes.h $(TM_H)
+f/lab.o: f/lab.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/lab.h f/com.h f/com-rt.def \
+ $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/malloc.h f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
+ f/top.h f/lex.h f/type.h f/intrin.h f/intrin.def f/symbol.h f/symbol.def \
+ f/equiv.h f/storag.h f/global.h f/name.h coretypes.h $(TM_H)
+f/lex.o: f/lex.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/top.h f/malloc.h f/where.h \
+ glimits.h f/bad.h f/bad.def f/com.h f/com-rt.def $(TREE_H) f/bld.h \
+ f/bld-op.def f/bit.h f/info.h f/info-b.def f/info-k.def f/info-w.def \
+ f/target.h f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h \
+ f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h f/src.h flags.h \
+ debug.h input.h toplev.h output.h $(GGC_H) gt-f-lex.h coretypes.h $(TM_H)
+f/malloc.o: f/malloc.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/malloc.h \
+ coretypes.h $(TM_H)
+f/name.o: f/name.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bad.h f/bad.def f/where.h \
+ glimits.h f/top.h f/malloc.h f/name.h f/global.h f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h $(TREE_H) f/lex.h f/type.h f/symbol.h \
+ f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def f/lab.h \
+ f/storag.h f/intrin.h f/intrin.def f/equiv.h f/src.h coretypes.h $(TM_H)
+f/parse.o: f/parse.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/top.h f/malloc.h \
+ f/where.h glimits.h f/com.h f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def \
+ f/bit.h f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
+ f/bad.def f/lex.h f/type.h f/intrin.h f/intrin.def f/lab.h f/symbol.h \
+ f/symbol.def f/equiv.h f/storag.h f/global.h f/name.h version.h flags.h \
+ coretypes.h $(TM_H)
+f/src.o: f/src.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/src.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h coretypes.h $(TM_H)
+f/st.o: f/st.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/st.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/symbol.h f/symbol.def \
+ f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h \
+ f/storag.h f/intrin.h f/intrin.def f/equiv.h f/global.h f/name.h f/sta.h \
+ f/stamp-str f/stb.h f/expr.h f/stp.h f/stt.h f/stc.h f/std.h \
+ f/stv.h f/stw.h f/ste.h f/sts.h f/stu.h coretypes.h $(TM_H)
+f/sta.o: f/sta.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/sta.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/lex.h f/stamp-str f/symbol.h \
+ f/symbol.def f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def $(TREE_H) \
+ f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/type.h f/lab.h \
+ f/storag.h f/intrin.h f/intrin.def f/equiv.h f/global.h f/name.h f/implic.h \
+ f/stb.h f/expr.h f/stp.h f/stt.h f/stc.h f/std.h f/stv.h f/stw.h coretypes.h \
+ $(TM_H)
+f/stb.o: f/stb.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stb.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/expr.h f/bld.h f/bld-op.def f/bit.h \
+ f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
+ f/info-w.def f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
+ f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h \
+ f/stt.h f/stamp-str f/src.h f/sta.h f/stc.h coretypes.h $(TM_H)
+f/stc.o: f/stc.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stc.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/bld.h f/bld-op.def f/bit.h f/com.h \
+ f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def \
+ f/target.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def \
+ f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/expr.h f/stp.h \
+ f/stt.h f/stamp-str f/data.h f/implic.h f/src.h f/sta.h f/std.h f/stv.h \
+ f/stw.h coretypes.h $(TM_H)
+f/std.o: f/std.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/std.h f/bld.h f/bld-op.def \
+ f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h \
+ f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h f/symbol.def f/equiv.h \
+ f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h f/stt.h f/stamp-str \
+ f/stv.h f/stw.h f/sta.h f/ste.h f/sts.h coretypes.h $(TM_H)
+f/ste.o: f/ste.c f/proj.h $(CONFIG_H) $(SYSTEM_H) $(RTL_H) toplev.h f/ste.h \
+ f/bld.h f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H)	\
+ f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
+ f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def f/stp.h \
+ f/stt.h f/stamp-str f/sts.h f/stv.h f/stw.h f/expr.h f/sta.h $(GGC_H) \
+ gt-f-ste.h coretypes.h $(TM_H)
+f/storag.o: f/storag.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/storag.h f/bld.h  \
+ f/bld-op.def f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) \
+ f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
+ f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h \
+ f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
+ f/intrin.def f/data.h coretypes.h $(TM_H)
+f/stp.o: f/stp.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stp.h f/bld.h f/bld-op.def \
+ f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h \
+ f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
+ f/intrin.def f/stt.h coretypes.h $(TM_H)
+f/str.o: f/str.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/src.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/malloc.h f/stamp-str f/lex.h coretypes.h $(TM_H)
+f/sts.o: f/sts.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/sts.h f/malloc.h f/com.h \
+ f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/lex.h f/type.h f/intrin.h f/intrin.def \
+ f/lab.h f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h \
+ f/name.h coretypes.h $(TM_H)
+f/stt.o: f/stt.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stt.h f/top.h f/malloc.h \
+ f/where.h glimits.h f/bld.h f/bld-op.def f/bit.h f/com.h f/com-rt.def \
+ $(TREE_H) f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h \
+ f/bad.h f/bad.def f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
+ f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def \
+ f/stp.h f/expr.h f/sta.h f/stamp-str coretypes.h $(TM_H)
+f/stu.o: f/stu.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/bld.h f/bld-op.def f/bit.h \
+ f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h f/info-b.def \
+ f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def f/where.h \
+ glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h f/symbol.h \
+ f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h f/intrin.def \
+ f/implic.h f/stu.h f/sta.h f/stamp-str coretypes.h $(TM_H)
+f/stv.o: f/stv.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stv.h f/lab.h f/com.h \
+ f/com-rt.def $(TREE_H) f/bld.h f/bld-op.def f/bit.h f/malloc.h \
+ f/info.h f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h \
+ f/bad.def f/where.h glimits.h f/top.h f/lex.h f/type.h f/intrin.h \
+ f/intrin.def f/symbol.h f/symbol.def f/equiv.h f/storag.h f/global.h \
+ f/name.h coretypes.h $(TM_H)
+f/stw.o: f/stw.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/stw.h f/bld.h f/bld-op.def \
+ f/bit.h f/malloc.h f/com.h f/com-rt.def $(TREE_H) f/info.h \
+ f/info-b.def f/info-k.def f/info-w.def f/target.h f/bad.h f/bad.def \
+ f/where.h glimits.h f/top.h f/lex.h f/type.h f/lab.h f/storag.h \
+ f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
+ f/intrin.def f/stv.h f/sta.h f/stamp-str coretypes.h $(TM_H)
+f/symbol.o: f/symbol.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/symbol.h \
+ f/symbol.def f/bld.h f/bld-op.def f/bit.h f/malloc.h f/com.h \
+ f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
+ f/info-w.def f/target.h f/bad.h f/bad.def f/where.h glimits.h f/top.h \
+ f/lex.h f/type.h f/lab.h f/storag.h f/intrin.h f/intrin.def f/equiv.h \
+ f/global.h f/name.h f/src.h f/st.h coretypes.h $(TM_H)
+f/target.o: f/target.c f/proj.h $(CONFIG_H) $(SYSTEM_H) glimits.h f/target.h \
+ $(TREE_H) f/bad.h f/bad.def f/where.h f/top.h f/malloc.h f/info.h real.h \
+ f/info-b.def f/info-k.def f/info-w.def f/type.h f/lex.h diagnostic.h \
+ coretypes.h $(TM_H) toplev.h
+f/top.o: f/top.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/top.h f/malloc.h f/where.h \
+ glimits.h f/bad.h f/bad.def f/bit.h f/bld.h f/bld-op.def f/com.h \
+ f/com-rt.def $(TREE_H) f/info.h f/info-b.def f/info-k.def \
+ f/info-w.def f/target.h f/lex.h f/type.h f/lab.h f/storag.h \
+ f/symbol.h f/symbol.def f/equiv.h f/global.h f/name.h f/intrin.h \
+ f/intrin.def f/data.h f/expr.h f/implic.h f/src.h f/st.h flags.h \
+ toplev.h coretypes.h $(TM_H) opts.h options.h
+f/type.o: f/type.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/type.h f/malloc.h \
+ coretypes.h $(TM_H)
+f/where.o: f/where.c f/proj.h $(CONFIG_H) $(SYSTEM_H) f/where.h glimits.h \
+ f/top.h f/malloc.h f/lex.h $(GGC_H) gt-f-where.h coretypes.h $(TM_H)

gcc/f/RELEASE-PREP

@@ -0,0 +1,5 @@
+1999-03-13  RELEASE-PREP
+
+Things to do to prepare a g77 release.
+
+-  Update root.texi: clear DEVELOPMENT flag, set version info.

gcc/f/ansify.c

@@ -0,0 +1,190 @@
+/* ansify.c
+   Copyright (C) 1997, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.  */
+
+#include "bconfig.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+
+#define die_unless(c) \
+  do if (!(c)) \
+    { \
+      fprintf (stderr, "%s:%lu: %s\n", argv[1], lineno, #c); \
+      die (); \
+    } \
+  while(0)
+
+static void ATTRIBUTE_NORETURN
+die (void)
+{
+  exit (1);
+}
+
+int
+main(int argc, char **argv)
+{
+  int c;
+  static unsigned long lineno = 1;
+
+  die_unless (argc == 2);
+
+  printf ("\
+/* This file is automatically generated from `%s',\n\
+   which you should modify instead.  */\n\
+#line 1 \"%s\"\n\
+",
+	  argv[1], argv[1]);
+
+  while ((c = getchar ()) != EOF)
+    {
+      switch (c)
+	{
+	default:
+	  putchar (c);
+	  break;
+
+	case '\n':
+	  ++lineno;
+	  putchar (c);
+	  break;
+
+	case '"':
+	  putchar (c);
+	  for (;;)
+	    {
+	      c = getchar ();
+	      die_unless (c != EOF);
+	      switch (c)
+		{
+		case '"':
+		  putchar (c);
+		  goto next_char;
+
+		case '\n':
+		  putchar ('\\');
+		  putchar ('n');
+		  putchar ('\\');
+		  putchar ('\n');
+		  ++lineno;
+		  break;
+
+		case '\\':
+		  putchar (c);
+		  c = getchar ();
+		  die_unless (c != EOF);
+		  putchar (c);
+		  if (c == '\n')
+		    ++lineno;
+		  break;
+		  
+		default:
+		  putchar (c);
+		  break;
+		}
+	    }
+	  break;
+
+	case '\'':
+	  putchar (c);
+	  for (;;)
+	    {
+	      c = getchar ();
+	      die_unless (c != EOF);
+	      switch (c)
+		{
+		case '\'':
+		  putchar (c);
+		  goto next_char;
+		  
+		case '\n':
+		  putchar ('\\');
+		  putchar ('n');
+		  putchar ('\\');
+		  putchar ('\n');
+		  ++lineno;
+		  break;
+		  
+		case '\\':
+		  putchar (c);
+		  c = getchar ();
+		  die_unless (c != EOF);
+		  putchar (c);
+		  if (c == '\n')
+		    ++lineno;
+		  break;
+		  
+		default:
+		  putchar (c);
+		  break;
+		}
+	    }
+	  break;
+
+	case '/':
+	  putchar (c);
+	  c = getchar ();
+	  putchar (c);
+	  if (c != '*')
+	    break;
+	  for (;;)
+	    {
+	      c = getchar ();
+	      die_unless (c != EOF);
+
+	      switch (c)
+		{
+		case '\n':
+		  ++lineno;
+		  putchar (c);
+		  break;
+		  
+		case '*':
+		  c = getchar ();
+		  die_unless (c != EOF);
+		  if (c == '/')
+		    {
+		      putchar ('*');
+		      putchar ('/');
+		      goto next_char;
+		    }
+		  if (c == '\n')
+		    {
+		      ++lineno;
+		      putchar (c);
+		    }
+		  break;
+		  
+		default:
+		  /* Don't bother outputting content of comments.  */
+		  break;
+		}
+	    }
+	  break;
+	}
+      
+    next_char:
+      ;
+    }
+
+  die_unless (c == EOF);
+
+  return 0;
+}

gcc/f/bad.c

@@ -0,0 +1,537 @@
+/* bad.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Related Modules:
+      None
+
+   Description:
+      Handles the displaying of diagnostic messages regarding the user's source
+      files.
+
+   Modifications:
+*/
+
+/* If there's a %E or %4 in the messages, set this to at least 5,
+   for example.  */
+
+#define FFEBAD_MAX_ 6
+
+/* Include files. */
+
+#include "proj.h"
+#include "bad.h"
+#include "flags.h"
+#include "com.h"
+#include "toplev.h"
+#include "where.h"
+#include "intl.h"
+#include "diagnostic.h"
+
+/* Externals defined here. */
+
+bool ffebad_is_inhibited_ = FALSE;
+
+/* Simple definitions and enumerations. */
+
+#define FFEBAD_LONG_MSGS_ 1	/* 0 to use short (or same) messages. */
+
+/* Internal typedefs. */
+
+
+/* Private include files. */
+
+
+/* Internal structure definitions. */
+
+struct _ffebad_message_
+  {
+    const ffebadSeverity severity;
+    const char *const message;
+  };
+
+/* Static objects accessed by functions in this module.	 */
+
+static const struct _ffebad_message_ ffebad_messages_[]
+=
+{
+#define FFEBAD_MSG(kwd,sev,msgid) { sev, msgid },
+#if FFEBAD_LONG_MSGS_ == 0
+#define LONG(m)
+#define SHORT(m) m
+#else
+#define LONG(m) m
+#define SHORT(m)
+#endif
+#include "bad.def"
+#undef FFEBAD_MSG
+#undef LONG
+#undef SHORT
+};
+
+static struct
+  {
+    ffewhereLine line;
+    ffewhereColumn col;
+    ffebadIndex tag;
+  }
+
+ffebad_here_[FFEBAD_MAX_];
+static const char *ffebad_string_[FFEBAD_MAX_];
+static ffebadIndex ffebad_order_[FFEBAD_MAX_];
+static ffebad ffebad_errnum_;
+static ffebadSeverity ffebad_severity_;
+static const char *ffebad_message_;
+static unsigned char ffebad_index_;
+static ffebadIndex ffebad_places_;
+static bool ffebad_is_temp_inhibited_;	/* Effective setting of
+					   _is_inhibited_ for this
+					   _start/_finish invocation. */
+
+/* Static functions (internal). */
+
+static int ffebad_bufputs_ (char buf[], int bufi, const char *s);
+
+/* Internal macros. */
+
+#define ffebad_bufflush_(buf, bufi) \
+  (((buf)[bufi] = '\0'), fputs ((buf), stderr), 0)
+#define ffebad_bufputc_(buf, bufi, c) \
+  (((bufi) == ARRAY_SIZE (buf)) \
+   ? (ffebad_bufflush_ ((buf), (bufi)), ((buf)[0] = (c)), 1) \
+   : (((buf)[bufi] = (c)), (bufi) + 1))
+
+
+static int
+ffebad_bufputs_ (char buf[], int bufi, const char *s)
+{
+  for (; *s != '\0'; ++s)
+    bufi = ffebad_bufputc_ (buf, bufi, *s);
+  return bufi;
+}
+
+/* ffebad_init_0 -- Initialize
+
+   ffebad_init_0();  */
+
+void
+ffebad_init_0 (void)
+{
+  assert (FFEBAD == ARRAY_SIZE (ffebad_messages_));
+}
+
+ffebadSeverity
+ffebad_severity (ffebad errnum)
+{
+  return ffebad_messages_[errnum].severity;
+}
+
+/* ffebad_start_ -- Start displaying an error message
+
+   ffebad_start(FFEBAD_SOME_ERROR_CODE);
+
+   Call ffebad_start to establish the message, ffebad_here and ffebad_string
+   to send run-time data to it as necessary, then ffebad_finish when through
+   to actually get it to print (to stderr).
+
+   Note: ffebad_start(errnum) turns into ffebad_start_(FALSE,errnum).  No
+   outside caller should call ffebad_start_ directly (as indicated by the
+   trailing underscore).
+
+   Call ffebad_start to start a normal message, one that might be inhibited
+   by the current state of statement guessing.	Call ffebad_start_lex
+   instead to start a message that is global to all statement guesses and
+   happens only once for all guesses (i.e. the lexer).
+
+   sev and message are overrides for the severity and messages when errnum
+   is FFEBAD, meaning the caller didn't want to have to put a message in
+   bad.def to produce a diagnostic.  */
+
+bool
+ffebad_start_ (bool lex_override, ffebad errnum, ffebadSeverity sev,
+	       const char *msgid)
+{
+  unsigned char i;
+
+  if (ffebad_is_inhibited_ && !lex_override)
+    {
+      ffebad_is_temp_inhibited_ = TRUE;
+      return FALSE;
+    }
+
+  if (errnum != FFEBAD)
+    {
+      ffebad_severity_ = ffebad_messages_[errnum].severity;
+      ffebad_message_ = gettext (ffebad_messages_[errnum].message);
+    }
+  else
+    {
+      ffebad_severity_ = sev;
+      ffebad_message_ = gettext (msgid);
+    }
+
+  switch (ffebad_severity_)
+    {				/* Tell toplev.c about this message. */
+    case FFEBAD_severityINFORMATIONAL:
+    case FFEBAD_severityTRIVIAL:
+      if (inhibit_warnings)
+	{			/* User wants no warnings. */
+	  ffebad_is_temp_inhibited_ = TRUE;
+	  return FALSE;
+	}
+      /* Fall through.  */
+    case FFEBAD_severityWARNING:
+    case FFEBAD_severityPECULIAR:
+    case FFEBAD_severityPEDANTIC:
+      if ((ffebad_severity_ != FFEBAD_severityPEDANTIC)
+	  || !flag_pedantic_errors)
+	{
+	  if (!diagnostic_report_warnings_p ())
+	    {			/* User wants no warnings. */
+	      ffebad_is_temp_inhibited_ = TRUE;
+	      return FALSE;
+	    }
+	  diagnostic_kind_count (global_dc, DK_WARNING)++;
+	  break;
+	}
+      /* Fall through (PEDANTIC && flag_pedantic_errors).  */
+    case FFEBAD_severityFATAL:
+    case FFEBAD_severityWEIRD:
+    case FFEBAD_severitySEVERE:
+    case FFEBAD_severityDISASTER:
+      diagnostic_kind_count (global_dc, DK_ERROR)++;
+      break;
+
+    default:
+      break;
+    }
+
+  ffebad_is_temp_inhibited_ = FALSE;
+  ffebad_errnum_ = errnum;
+  ffebad_index_ = 0;
+  ffebad_places_ = 0;
+  for (i = 0; i < FFEBAD_MAX_; ++i)
+    {
+      ffebad_string_[i] = NULL;
+      ffebad_here_[i].line = ffewhere_line_unknown ();
+      ffebad_here_[i].col = ffewhere_column_unknown ();
+    }
+
+  return TRUE;
+}
+
+/* ffebad_here -- Establish source location of some diagnostic concern
+
+   ffebad_here(ffebadIndex i,ffewhereLine line,ffewhereColumn col);
+
+   Call ffebad_start to establish the message, ffebad_here and ffebad_string
+   to send run-time data to it as necessary, then ffebad_finish when through
+   to actually get it to print (to stderr).  */
+
+void
+ffebad_here (ffebadIndex index, ffewhereLine line, ffewhereColumn col)
+{
+  ffewhereLineNumber line_num;
+  ffewhereLineNumber ln;
+  ffewhereColumnNumber col_num;
+  ffewhereColumnNumber cn;
+  ffebadIndex i;
+  ffebadIndex j;
+
+  if (ffebad_is_temp_inhibited_)
+    return;
+
+  assert (index < FFEBAD_MAX_);
+  ffebad_here_[index].line = ffewhere_line_use (line);
+  ffebad_here_[index].col = ffewhere_column_use (col);
+  if (ffewhere_line_is_unknown (line)
+      || ffewhere_column_is_unknown (col))
+    {
+      ffebad_here_[index].tag = FFEBAD_MAX_;
+      return;
+    }
+  ffebad_here_[index].tag = 0;	/* For now, though it shouldn't matter. */
+
+  /* Sort the source line/col points into the order they occur in the source
+     file.  Deal with duplicates appropriately. */
+
+  line_num = ffewhere_line_number (line);
+  col_num = ffewhere_column_number (col);
+
+  /* Determine where in the ffebad_order_ array this new place should go. */
+
+  for (i = 0; i < ffebad_places_; ++i)
+    {
+      ln = ffewhere_line_number (ffebad_here_[ffebad_order_[i]].line);
+      cn = ffewhere_column_number (ffebad_here_[ffebad_order_[i]].col);
+      if (line_num < ln)
+	break;
+      if (line_num == ln)
+	{
+	  if (col_num == cn)
+	    {
+	      ffebad_here_[index].tag = i;
+	      return;		/* Shouldn't go in, has equivalent. */
+	    }
+	  else if (col_num < cn)
+	    break;
+	}
+    }
+
+  /* Before putting new place in ffebad_order_[i], first increment all tags
+     that are i or greater. */
+
+  if (i != ffebad_places_)
+    {
+      for (j = 0; j < FFEBAD_MAX_; ++j)
+	{
+	  if (ffebad_here_[j].tag >= i)
+	    ++ffebad_here_[j].tag;
+	}
+    }
+
+  /* Then slide all ffebad_order_[] entries at and above i up one entry. */
+
+  for (j = ffebad_places_; j > i; --j)
+    ffebad_order_[j] = ffebad_order_[j - 1];
+
+  /* Finally can put new info in ffebad_order_[i]. */
+
+  ffebad_order_[i] = index;
+  ffebad_here_[index].tag = i;
+  ++ffebad_places_;
+}
+
+/* Establish string for next index (always in order) of message
+
+   ffebad_string(const char *string);
+
+   Call ffebad_start to establish the message, ffebad_here and ffebad_string
+   to send run-time data to it as necessary, then ffebad_finish when through
+   to actually get it to print (to stderr).  Note: don't trash the string
+   until after calling ffebad_finish, since we just maintain a pointer to
+   the argument passed in until then.  */
+
+void
+ffebad_string (const char *string)
+{
+  if (ffebad_is_temp_inhibited_)
+    return;
+
+  assert (ffebad_index_ != FFEBAD_MAX_);
+  ffebad_string_[ffebad_index_++] = string;
+}
+
+/* ffebad_finish -- Display error message with where & run-time info
+
+   ffebad_finish();
+
+   Call ffebad_start to establish the message, ffebad_here and ffebad_string
+   to send run-time data to it as necessary, then ffebad_finish when through
+   to actually get it to print (to stderr).  */
+
+void
+ffebad_finish (void)
+{
+#define MAX_SPACES 132
+  static const char *const spaces
+  = "...>\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\040\
+\040\040\040";			/* MAX_SPACES - 1 spaces. */
+  ffewhereLineNumber last_line_num;
+  ffewhereLineNumber ln;
+  ffewhereLineNumber rn;
+  ffewhereColumnNumber last_col_num;
+  ffewhereColumnNumber cn;
+  ffewhereColumnNumber cnt;
+  ffewhereLine l;
+  ffebadIndex bi;
+  unsigned short i;
+  char pointer;
+  unsigned char c;
+  unsigned const char *s;
+  const char *fn;
+  static char buf[1024];
+  int bufi;
+  int index;
+
+  if (ffebad_is_temp_inhibited_)
+    return;
+
+  switch (ffebad_severity_)
+    {
+    case FFEBAD_severityINFORMATIONAL:
+      s = _("note:");
+      break;
+
+    case FFEBAD_severityWARNING:
+      s = _("warning:");
+      break;
+
+    case FFEBAD_severitySEVERE:
+      s = _("fatal:");
+      break;
+
+    default:
+      s = "";
+      break;
+    }
+
+  /* Display the annoying source references. */
+
+  last_line_num = 0;
+  last_col_num = 0;
+
+  for (bi = 0; bi < ffebad_places_; ++bi)
+    {
+      if (ffebad_places_ == 1)
+	pointer = '^';
+      else
+	pointer = '1' + bi;
+
+      l = ffebad_here_[ffebad_order_[bi]].line;
+      ln = ffewhere_line_number (l);
+      rn = ffewhere_line_filelinenum (l);
+      cn = ffewhere_column_number (ffebad_here_[ffebad_order_[bi]].col);
+      fn = ffewhere_line_filename (l);
+      if (ln != last_line_num)
+	{
+	  if (bi != 0)
+	    fputc ('\n', stderr);
+	  diagnostic_report_current_function (global_dc);
+	  fprintf (stderr,
+		   /* the trailing space on the <file>:<line>: line
+		      fools emacs19 compilation mode into finding the
+		      report */
+		   "%s:%" ffewhereLineNumber_f "u: %s\n   %s\n   %s%c",
+		   fn, rn,
+		   s,
+		   ffewhere_line_content (l),
+		   &spaces[cn > MAX_SPACES ? 0 : MAX_SPACES - cn + 4],
+		   pointer);
+	  last_line_num = ln;
+	  last_col_num = cn;
+	  s = _("(continued):");
+	}
+      else
+	{
+	  cnt = cn - last_col_num;
+	  fprintf (stderr,
+		   "%s%c", &spaces[cnt > MAX_SPACES
+				   ? 0 : MAX_SPACES - cnt + 4],
+		   pointer);
+	  last_col_num = cn;
+	}
+    }
+  if (ffebad_places_ == 0)
+    {
+      /* Didn't output "warning:" string, capitalize it for message.  */
+      if (s[0] != '\0')
+	{
+	  char c;
+
+	  c = TOUPPER (s[0]);
+	  fprintf (stderr, "%c%s ", c, &s[1]);
+	}
+      else if (s[0] != '\0')
+	fprintf (stderr, "%s ", s);
+    }
+  else
+    fputc ('\n', stderr);
+
+  /* Release the ffewhere info. */
+
+  for (bi = 0; bi < FFEBAD_MAX_; ++bi)
+    {
+      ffewhere_line_kill (ffebad_here_[bi].line);
+      ffewhere_column_kill (ffebad_here_[bi].col);
+    }
+
+  /* Now display the message. */
+
+  bufi = 0;
+  for (i = 0; (c = ffebad_message_[i]) != '\0'; ++i)
+    {
+      if (c == '%')
+	{
+	  c = ffebad_message_[++i];
+	  if (ISUPPER (c))
+	    {
+	      index = c - 'A';
+
+	      if ((index < 0) || (index >= FFEBAD_MAX_))
+		{
+		  bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!] %"));
+		  bufi = ffebad_bufputc_ (buf, bufi, c);
+		}
+	      else
+		{
+		  s = ffebad_string_[index];
+		  if (s == NULL)
+		    bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!]"));
+		  else
+		    bufi = ffebad_bufputs_ (buf, bufi, s);
+		}
+	    }
+	  else if (ISDIGIT (c))
+	    {
+	      index = c - '0';
+
+	      if ((index < 0) || (index >= FFEBAD_MAX_))
+		{
+		  bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!] %"));
+		  bufi = ffebad_bufputc_ (buf, bufi, c);
+		}
+	      else
+		{
+		  pointer = ffebad_here_[index].tag + '1';
+		  if (pointer == FFEBAD_MAX_ + '1')
+		    pointer = '?';
+		  else if (ffebad_places_ == 1)
+		    pointer = '^';
+		  bufi = ffebad_bufputc_ (buf, bufi, '(');
+		  bufi = ffebad_bufputc_ (buf, bufi, pointer);
+		  bufi = ffebad_bufputc_ (buf, bufi, ')');
+		}
+	    }
+	  else if (c == '\0')
+	    break;
+	  else if (c == '%')
+	    bufi = ffebad_bufputc_ (buf, bufi, '%');
+	  else
+	    {
+	      bufi = ffebad_bufputs_ (buf, bufi, _("[REPORT BUG!!]"));
+	      bufi = ffebad_bufputc_ (buf, bufi, '%');
+	      bufi = ffebad_bufputc_ (buf, bufi, c);
+	    }
+	}
+      else
+	bufi = ffebad_bufputc_ (buf, bufi, c);
+    }
+  bufi = ffebad_bufputc_ (buf, bufi, '\n');
+  bufi = ffebad_bufflush_ (buf, bufi);
+}

gcc/f/bad.h

@@ -0,0 +1,106 @@
+/* bad.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 2002 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      bad.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_BAD_H
+#define GCC_F_BAD_H
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+#define FFEBAD_MSG(KWD,SEV,MSG) KWD,
+#include "bad.def"
+#undef FFEBAD_MSG
+    FFEBAD
+  } ffebad;
+
+typedef enum
+  {
+
+    /* Order important; must be increasing severity. */
+
+    FFEBAD_severityINFORMATIONAL,	/* User notice. */
+    FFEBAD_severityTRIVIAL,	/* Internal notice. */
+    FFEBAD_severityWARNING,	/* User warning. */
+    FFEBAD_severityPECULIAR,	/* Internal warning. */
+    FFEBAD_severityPEDANTIC,	/* Pedantic, could be warning or error. */
+    FFEBAD_severityFATAL,	/* User error. */
+    FFEBAD_severityWEIRD,	/* Internal error. */
+    FFEBAD_severitySEVERE,	/* User error, cannot continue. */
+    FFEBAD_severityDISASTER,	/* Internal error, cannot continue. */
+    FFEBAD_severity
+  } ffebadSeverity;
+
+/* Typedefs. */
+
+typedef unsigned char ffebadIndex;
+
+/* Include files needed by this one. */
+
+#include "where.h"
+
+/* Structure definitions. */
+
+
+/* Global objects accessed by users of this module. */
+
+extern bool ffebad_is_inhibited_;
+
+/* Declare functions with prototypes. */
+
+void ffebad_finish (void);
+void ffebad_here (ffebadIndex i, ffewhereLine wl, ffewhereColumn wc);
+void ffebad_init_0 (void);
+bool ffebad_is_fatal (ffebad errnum);
+ffebadSeverity ffebad_severity (ffebad errnum);
+bool ffebad_start_ (bool lex_override, ffebad errnum, ffebadSeverity sev,
+		    const char *msgid);
+void ffebad_string (const char *string);
+
+/* Define macros. */
+
+#define ffebad_inhibit() (ffebad_is_inhibited_)
+#define ffebad_init_1()
+#define ffebad_init_2()
+#define ffebad_init_3()
+#define ffebad_init_4()
+#define ffebad_set_inhibit(f) (ffebad_is_inhibited_ = (f))
+#define ffebad_start(e) ffebad_start_ (FALSE, (e), FFEBAD_severity, NULL)
+#define ffebad_start_lex(e) ffebad_start_ (TRUE, (e), FFEBAD_severity, NULL)
+#define ffebad_start_msg(msgid,s) ffebad_start_ (FALSE, FFEBAD, (s), (msgid))
+#define ffebad_start_msg_lex(msgid,s) ffebad_start_ (TRUE, FFEBAD, (s), (msgid))
+#define ffebad_terminate_0()
+#define ffebad_terminate_1()
+#define ffebad_terminate_2()
+#define ffebad_terminate_3()
+#define ffebad_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_BAD_H */

gcc/f/bit.c

@@ -0,0 +1,200 @@
+/* bit.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Related Modules:
+      None
+
+   Description:
+      Tracks arrays of booleans in useful ways.
+
+   Modifications:
+*/
+
+/* Include files. */
+
+#include "proj.h"
+#include "bit.h"
+#include "malloc.h"
+
+/* Externals defined here. */
+
+
+/* Simple definitions and enumerations. */
+
+
+/* Internal typedefs. */
+
+
+/* Private include files. */
+
+
+/* Internal structure definitions. */
+
+
+/* Static objects accessed by functions in this module. */
+
+
+/* Static functions (internal). */
+
+
+/* Internal macros. */
+
+
+/* ffebit_count -- Count # of bits set a particular way
+
+   ffebit b;  // the ffebit object
+   ffebitCount offset;	// 0..size-1
+   bool value;	// FALSE (0), TRUE (1)
+   ffebitCount range;  // # bits to test
+   ffebitCount number;	// # bits equal to value
+   ffebit_count(b,offset,value,range,&number);
+
+   Sets <number> to # bits at <offset> through <offset + range - 1> set to
+   <value>.  If <range> is 0, <number> is set to 0.  */
+
+void
+ffebit_count (ffebit b, ffebitCount offset, bool value, ffebitCount range,
+	      ffebitCount *number)
+{
+  ffebitCount element;
+  ffebitCount bitno;
+
+  assert (offset + range <= b->size);
+
+  for (*number = 0; range != 0; --range, ++offset)
+    {
+      element = offset / CHAR_BIT;
+      bitno = offset % CHAR_BIT;
+      if (value
+	  == ((b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE))
+	++ * number;
+    }
+}
+
+/* ffebit_new -- Create a new ffebit object
+
+   ffebit b;
+   ffebit_kill(b);
+
+   Destroys an ffebit object obtained via ffebit_new.  */
+
+void
+ffebit_kill (ffebit b)
+{
+  malloc_kill_ks (b->pool, b,
+		  offsetof (struct _ffebit_, bits)
+		  + (b->size + CHAR_BIT - 1) / CHAR_BIT);
+}
+
+/* ffebit_new -- Create a new ffebit object
+
+   ffebit b;
+   mallocPool pool;
+   ffebitCount size;
+   b = ffebit_new(pool,size);
+
+   Allocates an ffebit object that holds the values of <size> bits in pool
+   <pool>.  */
+
+ffebit
+ffebit_new (mallocPool pool, ffebitCount size)
+{
+  ffebit b;
+
+  b = malloc_new_zks (pool, "ffebit",
+		      offsetof (struct _ffebit_, bits)
+		      + (size + CHAR_BIT - 1) / CHAR_BIT,
+		      0);
+  b->pool = pool;
+  b->size = size;
+
+  return b;
+}
+
+/* ffebit_set -- Set value of # of bits
+
+   ffebit b;  // the ffebit object
+   ffebitCount offset;	// 0..size-1
+   bool value;	// FALSE (0), TRUE (1)
+   ffebitCount length;	// # bits to set starting at offset (usually 1)
+   ffebit_set(b,offset,value,length);
+
+   Sets bit #s <offset> through <offset + length - 1> to <value>.  */
+
+void
+ffebit_set (ffebit b, ffebitCount offset, bool value, ffebitCount length)
+{
+  ffebitCount i;
+  ffebitCount element;
+  ffebitCount bitno;
+
+  assert (offset + length <= b->size);
+
+  for (i = 0; i < length; ++i, ++offset)
+    {
+      element = offset / CHAR_BIT;
+      bitno = offset % CHAR_BIT;
+      b->bits[element] = (((unsigned char) (value ? 1 : 0)) << bitno)
+	| (b->bits[element] & ~((unsigned char) 1 << bitno));
+    }
+}
+
+/* ffebit_test -- Test value of # of bits
+
+   ffebit b;  // the ffebit object
+   ffebitCount offset;	// 0..size-1
+   bool value;	// FALSE (0), TRUE (1)
+   ffebitCount length;	// # bits with same value
+   ffebit_test(b,offset,&value,&length);
+
+   Returns value of bits at <offset> through <offset + length - 1> in
+   <value>.  If <offset> is already at the end of the bit array (if
+   offset == ffebit_size(b)), <length> is set to 0 and <value> is
+   undefined.  */
+
+void
+ffebit_test (ffebit b, ffebitCount offset, bool *value, ffebitCount *length)
+{
+  ffebitCount i;
+  ffebitCount element;
+  ffebitCount bitno;
+
+  if (offset >= b->size)
+    {
+      assert (offset == b->size);
+      *length = 0;
+      return;
+    }
+
+  element = offset / CHAR_BIT;
+  bitno = offset % CHAR_BIT;
+  *value = (b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE;
+  *length = 1;
+
+  for (i = b->size - offset - 1, ++offset; i != 0; --i, ++offset, ++*length)
+    {
+      element = offset / CHAR_BIT;
+      bitno = offset % CHAR_BIT;
+      if (*value
+	  != ((b->bits[element] & ((unsigned char) 1 << bitno)) == 0 ? FALSE : TRUE))
+	break;
+    }
+}

gcc/f/bit.h

@@ -0,0 +1,84 @@
+/* bit.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      bit.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_BIT_H
+#define GCC_F_BIT_H
+
+/* Simple definitions and enumerations. */
+
+
+/* Typedefs. */
+
+typedef struct _ffebit_ *ffebit;
+typedef unsigned long ffebitCount;
+#define ffebitCount_f "l"
+
+/* Include files needed by this one. */
+
+#include "malloc.h"
+
+/* Structure definitions. */
+
+struct _ffebit_
+  {
+    mallocPool pool;
+    ffebitCount size;
+    unsigned char bits[1];
+  };
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+void ffebit_count (ffebit b, ffebitCount offset, bool value, ffebitCount range,
+		   ffebitCount *number);
+void ffebit_kill (ffebit b);
+ffebit ffebit_new (mallocPool pool, ffebitCount size);
+void ffebit_set (ffebit b, ffebitCount offset, bool value, ffebitCount length);
+void ffebit_test (ffebit b, ffebitCount offset, bool *value, ffebitCount *length);
+
+/* Define macros. */
+
+#define ffebit_init_0()
+#define ffebit_init_1()
+#define ffebit_init_2()
+#define ffebit_init_3()
+#define ffebit_init_4()
+#define ffebit_pool(b) ((b)->pool)
+#define ffebit_size(b) ((b)->size)
+#define ffebit_terminate_0()
+#define ffebit_terminate_1()
+#define ffebit_terminate_2()
+#define ffebit_terminate_3()
+#define ffebit_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_BIT_H */

gcc/f/bld-op.def

@@ -0,0 +1,69 @@
+/* bld-op.def -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      bad.c
+
+   Modifications:
+*/
+
+FFEBLD_OP (FFEBLD_opANY, "ANY", 0)
+FFEBLD_OP (FFEBLD_opSTAR, "STAR", 0)	/* For adjustable arrays, alternate return dummies, etc. */
+FFEBLD_OP (FFEBLD_opCONTER, "CONTER", 0)
+FFEBLD_OP (FFEBLD_opARRTER, "ARRTER", 0)	/* Array of constants (DATA...). */
+FFEBLD_OP (FFEBLD_opACCTER, "ACCTER", 0)	/* Accreting ARRTER. */
+FFEBLD_OP (FFEBLD_opSYMTER, "SYMTER", 0)
+FFEBLD_OP (FFEBLD_opITEM, "ITEM", 0)
+FFEBLD_OP (FFEBLD_opUPLUS, "UPLUS", 1)
+FFEBLD_OP (FFEBLD_opUMINUS, "UMINUS", 1)
+FFEBLD_OP (FFEBLD_opADD, "ADD", 2)
+FFEBLD_OP (FFEBLD_opSUBTRACT, "SUBTRACT", 2)
+FFEBLD_OP (FFEBLD_opMULTIPLY, "MULTIPLY", 2)
+FFEBLD_OP (FFEBLD_opDIVIDE, "DIVIDE", 2)
+FFEBLD_OP (FFEBLD_opPOWER, "POWER", 2)
+FFEBLD_OP (FFEBLD_opCONCATENATE, "CONCATENATE", 2)
+FFEBLD_OP (FFEBLD_opNOT, "NOT", 1)
+FFEBLD_OP (FFEBLD_opLT, "LT", 2)
+FFEBLD_OP (FFEBLD_opLE, "LE", 2)
+FFEBLD_OP (FFEBLD_opEQ, "EQ", 2)
+FFEBLD_OP (FFEBLD_opNE, "NE", 2)
+FFEBLD_OP (FFEBLD_opGT, "GT", 2)
+FFEBLD_OP (FFEBLD_opGE, "GE", 2)
+FFEBLD_OP (FFEBLD_opAND, "AND", 2)
+FFEBLD_OP (FFEBLD_opOR, "OR", 2)
+FFEBLD_OP (FFEBLD_opXOR, "XOR", 2)
+FFEBLD_OP (FFEBLD_opEQV, "EQV", 2)
+FFEBLD_OP (FFEBLD_opNEQV, "NEQV", 2)
+FFEBLD_OP (FFEBLD_opPAREN, "PAREN", 1)
+FFEBLD_OP (FFEBLD_opPERCENT_LOC, "%LOC", 1)
+FFEBLD_OP (FFEBLD_opPERCENT_VAL, "%VAL", 1)
+FFEBLD_OP (FFEBLD_opPERCENT_REF, "%REF", 1)
+FFEBLD_OP (FFEBLD_opPERCENT_DESCR, "%DESCR", 1)
+FFEBLD_OP (FFEBLD_opCONVERT, "CONVERT", 1)
+FFEBLD_OP (FFEBLD_opREPEAT, "REPEAT", 2)
+FFEBLD_OP (FFEBLD_opBOUNDS, "BOUNDS", 2)	/* For low:high in dimension lists. */
+FFEBLD_OP (FFEBLD_opFUNCREF, "FUNCREF", 2)
+FFEBLD_OP (FFEBLD_opSUBRREF, "SUBRREF", 2)
+FFEBLD_OP (FFEBLD_opARRAYREF, "ARRAYREF", 2)
+FFEBLD_OP (FFEBLD_opSUBSTR, "SUBSTR", 2)
+FFEBLD_OP (FFEBLD_opLABTER, "LABTER", 0)
+FFEBLD_OP (FFEBLD_opLABTOK, "LABTOK", 0)	/* Like LABTER but contains ffelexToken instead. */
+FFEBLD_OP (FFEBLD_opIMPDO, "IMPDO", 2)

gcc/f/bld.h

@@ -0,0 +1,748 @@
+/* bld.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 1996, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      bld.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_BLD_H
+#define GCC_F_BLD_H
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+    FFEBLD_constNONE,
+    FFEBLD_constINTEGER1,
+    FFEBLD_constINTEGER2,
+    FFEBLD_constINTEGER3,
+    FFEBLD_constINTEGER4,
+    FFEBLD_constINTEGER5,
+    FFEBLD_constINTEGER6,
+    FFEBLD_constINTEGER7,
+    FFEBLD_constINTEGER8,
+    FFEBLD_constLOGICAL1,
+    FFEBLD_constLOGICAL2,
+    FFEBLD_constLOGICAL3,
+    FFEBLD_constLOGICAL4,
+    FFEBLD_constLOGICAL5,
+    FFEBLD_constLOGICAL6,
+    FFEBLD_constLOGICAL7,
+    FFEBLD_constLOGICAL8,
+    FFEBLD_constREAL1,
+    FFEBLD_constREAL2,
+    FFEBLD_constREAL3,
+    FFEBLD_constREAL4,
+    FFEBLD_constREAL5,
+    FFEBLD_constREAL6,
+    FFEBLD_constREAL7,
+    FFEBLD_constREAL8,
+    FFEBLD_constCOMPLEX1,
+    FFEBLD_constCOMPLEX2,
+    FFEBLD_constCOMPLEX3,
+    FFEBLD_constCOMPLEX4,
+    FFEBLD_constCOMPLEX5,
+    FFEBLD_constCOMPLEX6,
+    FFEBLD_constCOMPLEX7,
+    FFEBLD_constCOMPLEX8,
+    FFEBLD_constCHARACTER1,
+    FFEBLD_constCHARACTER2,
+    FFEBLD_constCHARACTER3,
+    FFEBLD_constCHARACTER4,
+    FFEBLD_constCHARACTER5,
+    FFEBLD_constCHARACTER6,
+    FFEBLD_constCHARACTER7,
+    FFEBLD_constCHARACTER8,
+    FFEBLD_constHOLLERITH,
+    FFEBLD_constTYPELESS_FIRST,
+    FFEBLD_constBINARY_MIL = FFEBLD_constTYPELESS_FIRST,
+    FFEBLD_constBINARY_VXT,
+    FFEBLD_constOCTAL_MIL,
+    FFEBLD_constOCTAL_VXT,
+    FFEBLD_constHEX_X_MIL,
+    FFEBLD_constHEX_X_VXT,
+    FFEBLD_constHEX_Z_MIL,
+    FFEBLD_constHEX_Z_VXT,
+    FFEBLD_constTYPELESS_LAST = FFEBLD_constHEX_Z_VXT,
+    FFEBLD_const
+  } ffebldConst;
+
+typedef enum
+  {
+#define FFEBLD_OP(KWD,NAME,ARITY) KWD,
+#include "bld-op.def"
+#undef FFEBLD_OP
+    FFEBLD_op
+  } ffebldOp;
+
+/* Typedefs. */
+
+typedef struct _ffebld_ *ffebld;
+typedef unsigned char ffebldArity;
+typedef union _ffebld_constant_array_ ffebldConstantArray;
+typedef struct _ffebld_constant_ *ffebldConstant;
+typedef union _ffebld_constant_union_ ffebldConstantUnion;
+typedef ffebld *ffebldListBottom;
+typedef unsigned int ffebldListLength;
+#define ffebldListLength_f ""
+typedef struct _ffebld_pool_stack_ *ffebldPoolstack_;
+
+/* Include files needed by this one. */
+
+#include "bit.h"
+#include "com.h"
+#include "info.h"
+#include "intrin.h"
+#include "lab.h"
+#include "lex.h"
+#include "malloc.h"
+#include "symbol.h"
+#include "target.h"
+
+#define FFEBLD_whereconstPROGUNIT_ 1
+#define FFEBLD_whereconstFILE_ 2
+
+#define FFEBLD_whereconstCURRENT_ FFEBLD_whereconstFILE_
+
+/* Structure definitions. */
+
+#define FFEBLD_constINTEGERDEFAULT FFEBLD_constINTEGER1
+#define FFEBLD_constLOGICALDEFAULT FFEBLD_constLOGICAL1
+#define FFEBLD_constREALDEFAULT FFEBLD_constREAL1
+#define FFEBLD_constREALDOUBLE FFEBLD_constREAL2
+#define FFEBLD_constREALQUAD FFEBLD_constREAL3
+#define FFEBLD_constCOMPLEX FFEBLD_constCOMPLEX1
+#define FFEBLD_constCOMPLEXDOUBLE FFEBLD_constCOMPLEX2
+#define FFEBLD_constCOMPLEXQUAD FFEBLD_constCOMPLEX3
+#define FFEBLD_constCHARACTERDEFAULT FFEBLD_constCHARACTER1
+
+union _ffebld_constant_union_
+  {
+    ffetargetTypeless typeless;
+    ffetargetHollerith hollerith;
+#if FFETARGET_okINTEGER1
+    ffetargetInteger1 integer1;
+#endif
+#if FFETARGET_okINTEGER2
+    ffetargetInteger2 integer2;
+#endif
+#if FFETARGET_okINTEGER3
+    ffetargetInteger3 integer3;
+#endif
+#if FFETARGET_okINTEGER4
+    ffetargetInteger4 integer4;
+#endif
+#if FFETARGET_okLOGICAL1
+    ffetargetLogical1 logical1;
+#endif
+#if FFETARGET_okLOGICAL2
+    ffetargetLogical2 logical2;
+#endif
+#if FFETARGET_okLOGICAL3
+    ffetargetLogical3 logical3;
+#endif
+#if FFETARGET_okLOGICAL4
+    ffetargetLogical4 logical4;
+#endif
+#if FFETARGET_okREAL1
+    ffetargetReal1 real1;
+#endif
+#if FFETARGET_okREAL2
+    ffetargetReal2 real2;
+#endif
+#if FFETARGET_okREAL3
+    ffetargetReal3 real3;
+#endif
+#if FFETARGET_okCOMPLEX1
+    ffetargetComplex1 complex1;
+#endif
+#if FFETARGET_okCOMPLEX2
+    ffetargetComplex2 complex2;
+#endif
+#if FFETARGET_okCOMPLEX3
+    ffetargetComplex3 complex3;
+#endif
+#if FFETARGET_okCHARACTER1
+    ffetargetCharacter1 character1;
+#endif
+  };
+
+union _ffebld_constant_array_
+  {
+#if FFETARGET_okINTEGER1
+    ffetargetInteger1 *integer1;
+#endif
+#if FFETARGET_okINTEGER2
+    ffetargetInteger2 *integer2;
+#endif
+#if FFETARGET_okINTEGER3
+    ffetargetInteger3 *integer3;
+#endif
+#if FFETARGET_okINTEGER4
+    ffetargetInteger4 *integer4;
+#endif
+#if FFETARGET_okLOGICAL1
+    ffetargetLogical1 *logical1;
+#endif
+#if FFETARGET_okLOGICAL2
+    ffetargetLogical2 *logical2;
+#endif
+#if FFETARGET_okLOGICAL3
+    ffetargetLogical3 *logical3;
+#endif
+#if FFETARGET_okLOGICAL4
+    ffetargetLogical4 *logical4;
+#endif
+#if FFETARGET_okREAL1
+    ffetargetReal1 *real1;
+#endif
+#if FFETARGET_okREAL2
+    ffetargetReal2 *real2;
+#endif
+#if FFETARGET_okREAL3
+    ffetargetReal3 *real3;
+#endif
+#if FFETARGET_okCOMPLEX1
+    ffetargetComplex1 *complex1;
+#endif
+#if FFETARGET_okCOMPLEX2
+    ffetargetComplex2 *complex2;
+#endif
+#if FFETARGET_okCOMPLEX3
+    ffetargetComplex3 *complex3;
+#endif
+#if FFETARGET_okCHARACTER1
+    ffetargetCharacterUnit1 *character1;
+#endif
+  };
+
+struct _ffebld_
+  {
+    ffebldOp op;
+    ffeinfo info;		/* Not used or valid for
+				   op=={STAR,ITEM,BOUNDS,REPEAT,LABTER,
+				   LABTOK,IMPDO}. */
+    union
+      {
+	struct
+	  {
+	    ffebld left;
+	    ffebld right;
+	    ffecomNonter hook;	/* Whatever the compiler/backend wants! */
+	  }
+	nonter;
+	struct
+	  {
+	    ffebld head;
+	    ffebld trail;
+	  }
+	item;
+	struct
+	  {
+	    ffebldConstant expr;
+	    ffebld orig;	/* Original expression, or NULL if none. */
+	    ffetargetAlign pad;	/* Initial padding (for DATA, etc.). */
+	  }
+	conter;
+	struct
+	  {
+	    ffebldConstantArray array;
+	    ffetargetOffset size;
+	    ffetargetAlign pad;	/* Initial padding (for DATA, etc.). */
+	  }
+	arrter;
+	struct
+	  {
+	    ffebldConstantArray array;
+	    ffebit bits;
+	    ffetargetAlign pad;	/* Initial padding (for DATA, etc.). */
+	  }
+	accter;
+	struct
+	  {
+	    ffesymbol symbol;
+	    ffeintrinGen generic;	/* Id for generic intrinsic. */
+	    ffeintrinSpec specific;	/* Id for specific intrinsic. */
+	    ffeintrinImp implementation;	/* Id for implementation. */
+	    bool do_iter;	/* TRUE if this ref is a read-only ref by
+				   definition (ref within DO loop using this
+				   var as iterator). */
+	  }
+	symter;
+	ffelab labter;
+	ffelexToken labtok;
+      }
+    u;
+  };
+
+struct _ffebld_constant_
+  {
+    ffebldConstant rlink;
+    ffebldConstant llink;
+    ffebldConstant first_complex;	/* First complex const with me as
+					   real. */
+    ffebldConst consttype;
+    ffecomConstant hook;	/* Whatever the compiler/backend wants! */
+    bool numeric;		/* A numeric kind of constant. */
+    ffebldConstantUnion u;
+  };
+
+struct _ffebld_pool_stack_
+  {
+    ffebldPoolstack_ next;
+    mallocPool pool;
+  };
+
+/* Global objects accessed by users of this module. */
+
+extern const ffebldArity ffebld_arity_op_[(int) FFEBLD_op];
+extern struct _ffebld_pool_stack_ ffebld_pool_stack_;
+
+/* Declare functions with prototypes. */
+
+int ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2);
+bool ffebld_constant_is_magical (ffebldConstant c);
+bool ffebld_constant_is_zero (ffebldConstant c);
+#if FFETARGET_okCHARACTER1
+ffebldConstant ffebld_constant_new_character1 (ffelexToken t);
+ffebldConstant ffebld_constant_new_character1_val (ffetargetCharacter1 val);
+#endif
+#if FFETARGET_okCOMPLEX1
+ffebldConstant ffebld_constant_new_complex1 (ffebldConstant real,
+					     ffebldConstant imaginary);
+ffebldConstant ffebld_constant_new_complex1_val (ffetargetComplex1 val);
+#endif
+#if FFETARGET_okCOMPLEX2
+ffebldConstant ffebld_constant_new_complex2 (ffebldConstant real,
+					     ffebldConstant imaginary);
+ffebldConstant ffebld_constant_new_complex2_val (ffetargetComplex2 val);
+#endif
+#if FFETARGET_okCOMPLEX3
+ffebldConstant ffebld_constant_new_complex3 (ffebldConstant real,
+					     ffebldConstant imaginary);
+ffebldConstant ffebld_constant_new_complex3_val (ffetargetComplex3 val);
+#endif
+ffebldConstant ffebld_constant_new_hollerith (ffelexToken t);
+ffebldConstant ffebld_constant_new_hollerith_val (ffetargetHollerith val);
+#if FFETARGET_okINTEGER1
+ffebldConstant ffebld_constant_new_integer1 (ffelexToken t);
+ffebldConstant ffebld_constant_new_integer1_val (ffetargetInteger1 val);
+#endif
+#if FFETARGET_okINTEGER2
+ffebldConstant ffebld_constant_new_integer2 (ffelexToken t);
+ffebldConstant ffebld_constant_new_integer2_val (ffetargetInteger2 val);
+#endif
+#if FFETARGET_okINTEGER3
+ffebldConstant ffebld_constant_new_integer3 (ffelexToken t);
+ffebldConstant ffebld_constant_new_integer3_val (ffetargetInteger3 val);
+#endif
+#if FFETARGET_okINTEGER4
+ffebldConstant ffebld_constant_new_integer4 (ffelexToken t);
+ffebldConstant ffebld_constant_new_integer4_val (ffetargetInteger4 val);
+#endif
+ffebldConstant ffebld_constant_new_integerbinary (ffelexToken t);
+ffebldConstant ffebld_constant_new_integerhex (ffelexToken t);
+ffebldConstant ffebld_constant_new_integeroctal (ffelexToken t);
+#if FFETARGET_okLOGICAL1
+ffebldConstant ffebld_constant_new_logical1 (bool truth);
+ffebldConstant ffebld_constant_new_logical1_val (ffetargetLogical1 val);
+#endif
+#if FFETARGET_okLOGICAL2
+ffebldConstant ffebld_constant_new_logical2 (bool truth);
+ffebldConstant ffebld_constant_new_logical2_val (ffetargetLogical2 val);
+#endif
+#if FFETARGET_okLOGICAL3
+ffebldConstant ffebld_constant_new_logical3 (bool truth);
+ffebldConstant ffebld_constant_new_logical3_val (ffetargetLogical3 val);
+#endif
+#if FFETARGET_okLOGICAL4
+ffebldConstant ffebld_constant_new_logical4 (bool truth);
+ffebldConstant ffebld_constant_new_logical4_val (ffetargetLogical4 val);
+#endif
+#if FFETARGET_okREAL1
+ffebldConstant ffebld_constant_new_real1 (ffelexToken integer,
+	    ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
+		    ffelexToken exponent_sign, ffelexToken exponent_digits);
+ffebldConstant ffebld_constant_new_real1_val (ffetargetReal1 val);
+#endif
+#if FFETARGET_okREAL2
+ffebldConstant ffebld_constant_new_real2 (ffelexToken integer,
+	    ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
+		    ffelexToken exponent_sign, ffelexToken exponent_digits);
+ffebldConstant ffebld_constant_new_real2_val (ffetargetReal2 val);
+#endif
+#if FFETARGET_okREAL3
+ffebldConstant ffebld_constant_new_real3 (ffelexToken integer,
+	    ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
+		    ffelexToken exponent_sign, ffelexToken exponent_digits);
+ffebldConstant ffebld_constant_new_real3_val (ffetargetReal3 val);
+#endif
+ffebldConstant ffebld_constant_new_typeless_bm (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_bv (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_hxm (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_hxv (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_hzm (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_hzv (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_om (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_ov (ffelexToken t);
+ffebldConstant ffebld_constant_new_typeless_val (ffebldConst type,
+						 ffetargetTypeless val);
+ffebldConstant ffebld_constant_negated (ffebldConstant c);
+ffebldConstantUnion ffebld_constantarray_get (ffebldConstantArray array,
+	   ffeinfoBasictype bt, ffeinfoKindtype kt, ffetargetOffset offset);
+void ffebld_constantarray_kill (ffebldConstantArray array, ffeinfoBasictype bt,
+				ffeinfoKindtype kt, ffetargetOffset size);
+ffebldConstantArray ffebld_constantarray_new (ffeinfoBasictype bt,
+				  ffeinfoKindtype kt, ffetargetOffset size);
+void ffebld_constantarray_prepare (void **aptr, void **cptr, size_t *size,
+       ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
+		      ffetargetOffset offset, ffebldConstantUnion *constant,
+				 ffeinfoBasictype cbt, ffeinfoKindtype ckt);
+void ffebld_constantarray_preparray (void **aptr, void **cptr, size_t *size,
+       ffebldConstantArray array, ffeinfoBasictype abt, ffeinfoKindtype akt,
+		   ffetargetOffset offset, ffebldConstantArray source_array,
+				 ffeinfoBasictype cbt, ffeinfoKindtype ckt);
+void ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
+  ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant);
+void ffebld_init_0 (void);
+void ffebld_init_1 (void);
+void ffebld_init_2 (void);
+ffebldListLength ffebld_list_length (ffebld l);
+ffebld ffebld_new_accter (ffebldConstantArray array, ffebit b);
+ffebld ffebld_new_arrter (ffebldConstantArray array, ffetargetOffset size);
+ffebld ffebld_new_conter_with_orig (ffebldConstant c, ffebld orig);
+ffebld ffebld_new_item (ffebld head, ffebld trail);
+ffebld ffebld_new_labter (ffelab l);
+ffebld ffebld_new_labtok (ffelexToken t);
+ffebld ffebld_new_none (ffebldOp o);
+ffebld ffebld_new_symter (ffesymbol s, ffeintrinGen gen, ffeintrinSpec spec,
+			  ffeintrinImp imp);
+ffebld ffebld_new_one (ffebldOp o, ffebld left);
+ffebld ffebld_new_two (ffebldOp o, ffebld left, ffebld right);
+const char *ffebld_op_string (ffebldOp o);
+void ffebld_pool_pop (void);
+void ffebld_pool_push (mallocPool pool);
+ffetargetCharacterSize ffebld_size_max (ffebld b);
+
+/* Define macros. */
+
+#define ffebld_accter(b) ((b)->u.accter.array)
+#define ffebld_accter_bits(b) ((b)->u.accter.bits)
+#define ffebld_accter_pad(b) ((b)->u.accter.pad)
+#define ffebld_accter_set_bits(b,bt) ((b)->u.accter.bits = (bt))
+#define ffebld_accter_set_pad(b,p) ((b)->u.accter.pad = (p))
+#define ffebld_accter_size(b) ffebit_size((b)->u.accter.bits)
+#define ffebld_append_item(b,i) (**(b) = ffebld_new_item((i),NULL),	      \
+				 *(b) = &((**(b))->u.item.trail))
+#define ffebld_arity(b) ffebld_arity_op(ffebld_op(b))
+#define ffebld_arity_op(o) (ffebld_arity_op_[o])
+#define ffebld_arrter(b) ((b)->u.arrter.array)
+#define ffebld_arrter_pad(b) ((b)->u.arrter.pad)
+#define ffebld_arrter_set_pad(b,p) ((b)->u.arrter.pad = (p))
+#define ffebld_arrter_set_size(b,s) ((b)->u.arrter.size = (s))
+#define ffebld_arrter_size(b) ((b)->u.arrter.size)
+#define ffebld_basictype(b) (ffeinfo_basictype (ffebld_info ((b))))
+#if FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstPROGUNIT_
+#define ffebld_constant_pool() ffe_pool_program_unit()
+#elif FFEBLD_whereconstCURRENT_ == FFEBLD_whereconstFILE_
+#define ffebld_constant_pool() ffe_pool_file()
+#else
+#error
+#endif
+#define ffebld_constant_character1(c) ((c)->u.character1)
+#define ffebld_constant_character2(c) ((c)->u.character2)
+#define ffebld_constant_character3(c) ((c)->u.character3)
+#define ffebld_constant_character4(c) ((c)->u.character4)
+#define ffebld_constant_character5(c) ((c)->u.character5)
+#define ffebld_constant_character6(c) ((c)->u.character6)
+#define ffebld_constant_character7(c) ((c)->u.character7)
+#define ffebld_constant_character8(c) ((c)->u.character8)
+#define ffebld_constant_characterdefault ffebld_constant_character1
+#define ffebld_constant_complex1(c) ((c)->u.complex1)
+#define ffebld_constant_complex2(c) ((c)->u.complex2)
+#define ffebld_constant_complex3(c) ((c)->u.complex3)
+#define ffebld_constant_complex4(c) ((c)->u.complex4)
+#define ffebld_constant_complex5(c) ((c)->u.complex5)
+#define ffebld_constant_complex6(c) ((c)->u.complex6)
+#define ffebld_constant_complex7(c) ((c)->u.complex7)
+#define ffebld_constant_complex8(c) ((c)->u.complex8)
+#define ffebld_constant_complexdefault ffebld_constant_complex1
+#define ffebld_constant_complexdouble ffebld_constant_complex2
+#define ffebld_constant_complexquad ffebld_constant_complex3
+#define ffebld_constant_copy(c) (c)
+#define ffebld_constant_hollerith(c) ((c)->u.hollerith)
+#define ffebld_constant_hook(c) ((c)->hook)
+#define ffebld_constant_integer1(c) ((c)->u.integer1)
+#define ffebld_constant_integer2(c) ((c)->u.integer2)
+#define ffebld_constant_integer3(c) ((c)->u.integer3)
+#define ffebld_constant_integer4(c) ((c)->u.integer4)
+#define ffebld_constant_integer5(c) ((c)->u.integer5)
+#define ffebld_constant_integer6(c) ((c)->u.integer6)
+#define ffebld_constant_integer7(c) ((c)->u.integer7)
+#define ffebld_constant_integer8(c) ((c)->u.integer8)
+#define ffebld_constant_integerdefault ffebld_constant_integer1
+#define ffebld_constant_is_numeric(c) ((c)->numeric)
+#define ffebld_constant_logical1(c) ((c)->u.logical1)
+#define ffebld_constant_logical2(c) ((c)->u.logical2)
+#define ffebld_constant_logical3(c) ((c)->u.logical3)
+#define ffebld_constant_logical4(c) ((c)->u.logical4)
+#define ffebld_constant_logical5(c) ((c)->u.logical5)
+#define ffebld_constant_logical6(c) ((c)->u.logical6)
+#define ffebld_constant_logical7(c) ((c)->u.logical7)
+#define ffebld_constant_logical8(c) ((c)->u.logical8)
+#define ffebld_constant_logicaldefault ffebld_constant_logical1
+#define ffebld_constant_new_characterdefault ffebld_constant_new_character1
+#define ffebld_constant_new_characterdefault_val ffebld_constant_new_character1_val
+#define ffebld_constant_new_complexdefault ffebld_constant_new_complex1
+#define ffebld_constant_new_complexdefault_val ffebld_constant_new_complex1_val
+#define ffebld_constant_new_complexdouble ffebld_constant_new_complex2
+#define ffebld_constant_new_complexdouble_val ffebld_constant_new_complex2_val
+#define ffebld_constant_new_complexquad ffebld_constant_new_complex3
+#define ffebld_constant_new_complexquad_valffebld_constant_new_complex3_val
+#define ffebld_constant_new_integerdefault ffebld_constant_new_integer1
+#define ffebld_constant_new_integerdefault_val ffebld_constant_new_integer1_val
+#define ffebld_constant_new_logicaldefault ffebld_constant_new_logical1
+#define ffebld_constant_new_logicaldefault_val ffebld_constant_new_logical1_val
+#define ffebld_constant_new_realdefault ffebld_constant_new_real1
+#define ffebld_constant_new_realdefault_val ffebld_constant_new_real1_val
+#define ffebld_constant_new_realdouble ffebld_constant_new_real2
+#define ffebld_constant_new_realdouble_val ffebld_constant_new_real2_val
+#define ffebld_constant_new_realquad ffebld_constant_new_real3
+#define ffebld_constant_new_realquad_val ffebld_constant_new_real3_val
+#define ffebld_constant_ptr_to_union(c) (&(c)->u)
+#define ffebld_constant_real1(c) ((c)->u.real1)
+#define ffebld_constant_real2(c) ((c)->u.real2)
+#define ffebld_constant_real3(c) ((c)->u.real3)
+#define ffebld_constant_real4(c) ((c)->u.real4)
+#define ffebld_constant_real5(c) ((c)->u.real5)
+#define ffebld_constant_real6(c) ((c)->u.real6)
+#define ffebld_constant_real7(c) ((c)->u.real7)
+#define ffebld_constant_real8(c) ((c)->u.real8)
+#define ffebld_constant_realdefault ffebld_constant_real1
+#define ffebld_constant_realdouble ffebld_constant_real2
+#define ffebld_constant_realquad ffebld_constant_real3
+#define ffebld_constant_set_hook(c,h) ((c)->hook = (h))
+#define ffebld_constant_set_union(c,un) ((c)->u = (un))
+#define ffebld_constant_type(c) ((c)->consttype)
+#define ffebld_constant_typeless(c) ((c)->u.typeless)
+#define ffebld_constant_union(c) ((c)->u)
+#define ffebld_conter(b) ((b)->u.conter.expr)
+#define ffebld_conter_orig(b) ((b)->u.conter.orig)
+#define ffebld_conter_pad(b) ((b)->u.conter.pad)
+#define ffebld_conter_set_orig(b,o) ((b)->u.conter.orig = (o))
+#define ffebld_conter_set_pad(b,p) ((b)->u.conter.pad = (p))
+#define ffebld_copy(b) (b)	/* ~~~Someday really make a copy. */
+#define ffebld_cu_ptr_typeless(u) &(u).typeless
+#define ffebld_cu_ptr_hollerith(u) &(u).hollerith
+#define ffebld_cu_ptr_integer1(u) &(u).integer1
+#define ffebld_cu_ptr_integer2(u) &(u).integer2
+#define ffebld_cu_ptr_integer3(u) &(u).integer3
+#define ffebld_cu_ptr_integer4(u) &(u).integer4
+#define ffebld_cu_ptr_integer5(u) &(u).integer5
+#define ffebld_cu_ptr_integer6(u) &(u).integer6
+#define ffebld_cu_ptr_integer7(u) &(u).integer7
+#define ffebld_cu_ptr_integer8(u) &(u).integer8
+#define ffebld_cu_ptr_integerdefault ffebld_cu_ptr_integer1
+#define ffebld_cu_ptr_logical1(u) &(u).logical1
+#define ffebld_cu_ptr_logical2(u) &(u).logical2
+#define ffebld_cu_ptr_logical3(u) &(u).logical3
+#define ffebld_cu_ptr_logical4(u) &(u).logical4
+#define ffebld_cu_ptr_logical5(u) &(u).logical5
+#define ffebld_cu_ptr_logical6(u) &(u).logical6
+#define ffebld_cu_ptr_logical7(u) &(u).logical7
+#define ffebld_cu_ptr_logical8(u) &(u).logical8
+#define ffebld_cu_ptr_logicaldefault ffebld_cu_ptr_logical1
+#define ffebld_cu_ptr_real1(u) &(u).real1
+#define ffebld_cu_ptr_real2(u) &(u).real2
+#define ffebld_cu_ptr_real3(u) &(u).real3
+#define ffebld_cu_ptr_real4(u) &(u).real4
+#define ffebld_cu_ptr_real5(u) &(u).real5
+#define ffebld_cu_ptr_real6(u) &(u).real6
+#define ffebld_cu_ptr_real7(u) &(u).real7
+#define ffebld_cu_ptr_real8(u) &(u).real8
+#define ffebld_cu_ptr_realdefault ffebld_cu_ptr_real1
+#define ffebld_cu_ptr_realdouble ffebld_cu_ptr_real2
+#define ffebld_cu_ptr_realquad ffebld_cu_ptr_real3
+#define ffebld_cu_ptr_complex1(u) &(u).complex1
+#define ffebld_cu_ptr_complex2(u) &(u).complex2
+#define ffebld_cu_ptr_complex3(u) &(u).complex3
+#define ffebld_cu_ptr_complex4(u) &(u).complex4
+#define ffebld_cu_ptr_complex5(u) &(u).complex5
+#define ffebld_cu_ptr_complex6(u) &(u).complex6
+#define ffebld_cu_ptr_complex7(u) &(u).complex7
+#define ffebld_cu_ptr_complex8(u) &(u).complex8
+#define ffebld_cu_ptr_complexdefault ffebld_cu_ptr_complex1
+#define ffebld_cu_ptr_complexdouble ffebld_cu_ptr_complex2
+#define ffebld_cu_ptr_complexquad ffebld_cu_ptr_complex3
+#define ffebld_cu_ptr_character1(u) &(u).character1
+#define ffebld_cu_ptr_character2(u) &(u).character2
+#define ffebld_cu_ptr_character3(u) &(u).character3
+#define ffebld_cu_ptr_character4(u) &(u).character4
+#define ffebld_cu_ptr_character5(u) &(u).character5
+#define ffebld_cu_ptr_character6(u) &(u).character6
+#define ffebld_cu_ptr_character7(u) &(u).character7
+#define ffebld_cu_ptr_character8(u) &(u).character8
+#define ffebld_cu_val_typeless(u) (u).typeless
+#define ffebld_cu_val_hollerith(u) (u).hollerith
+#define ffebld_cu_val_integer1(u) (u).integer1
+#define ffebld_cu_val_integer2(u) (u).integer2
+#define ffebld_cu_val_integer3(u) (u).integer3
+#define ffebld_cu_val_integer4(u) (u).integer4
+#define ffebld_cu_val_integer5(u) (u).integer5
+#define ffebld_cu_val_integer6(u) (u).integer6
+#define ffebld_cu_val_integer7(u) (u).integer7
+#define ffebld_cu_val_integer8(u) (u).integer8
+#define ffebld_cu_val_integerdefault ffebld_cu_val_integer1
+#define ffebld_cu_val_logical1(u) (u).logical1
+#define ffebld_cu_val_logical2(u) (u).logical2
+#define ffebld_cu_val_logical3(u) (u).logical3
+#define ffebld_cu_val_logical4(u) (u).logical4
+#define ffebld_cu_val_logical5(u) (u).logical5
+#define ffebld_cu_val_logical6(u) (u).logical6
+#define ffebld_cu_val_logical7(u) (u).logical7
+#define ffebld_cu_val_logical8(u) (u).logical8
+#define ffebld_cu_val_logicaldefault ffebld_cu_val_logical
+#define ffebld_cu_val_real1(u) (u).real1
+#define ffebld_cu_val_real2(u) (u).real2
+#define ffebld_cu_val_real3(u) (u).real3
+#define ffebld_cu_val_real4(u) (u).real4
+#define ffebld_cu_val_real5(u) (u).real5
+#define ffebld_cu_val_real6(u) (u).real6
+#define ffebld_cu_val_real7(u) (u).real7
+#define ffebld_cu_val_real8(u) (u).real8
+#define ffebld_cu_val_realdefault ffebld_cu_val_real1
+#define ffebld_cu_val_realdouble ffebld_cu_val_real2
+#define ffebld_cu_val_realquad ffebld_cu_val_real3
+#define ffebld_cu_val_complex1(u) (u).complex1
+#define ffebld_cu_val_complex2(u) (u).complex2
+#define ffebld_cu_val_complex3(u) (u).complex3
+#define ffebld_cu_val_complex4(u) (u).complex4
+#define ffebld_cu_val_complex5(u) (u).complex5
+#define ffebld_cu_val_complex6(u) (u).complex6
+#define ffebld_cu_val_complex7(u) (u).complex7
+#define ffebld_cu_val_complex8(u) (u).complex8
+#define ffebld_cu_val_complexdefault ffebld_cu_val_complex1
+#define ffebld_cu_val_complexdouble ffebld_cu_val_complex2
+#define ffebld_cu_val_complexquad ffebld_cu_val_complex3
+#define ffebld_cu_val_character1(u) (u).character1
+#define ffebld_cu_val_character2(u) (u).character2
+#define ffebld_cu_val_character3(u) (u).character3
+#define ffebld_cu_val_character4(u) (u).character4
+#define ffebld_cu_val_character5(u) (u).character5
+#define ffebld_cu_val_character6(u) (u).character6
+#define ffebld_cu_val_character7(u) (u).character7
+#define ffebld_cu_val_character8(u) (u).character8
+#define ffebld_end_list(b) (*(b) = NULL)
+#define ffebld_head(b) ((b)->u.item.head)
+#define ffebld_info(b) ((b)->info)
+#define ffebld_init_3()
+#define ffebld_init_4()
+#define ffebld_init_list(l,b) (*(l) = NULL, *(b) = (l))
+#define ffebld_item_hook(b) ((b)->u.item.hook)
+#define ffebld_item_set_hook(b,h) ((b)->u.item.hook = (h))
+#define ffebld_kind(b) (ffeinfo_kind (ffebld_info ((b))))
+#define ffebld_kindtype(b) (ffeinfo_kindtype (ffebld_info ((b))))
+#define ffebld_labter(b) ((b)->u.labter)
+#define ffebld_labtok(b) ((b)->u.labtok)
+#define ffebld_left(b) ((b)->u.nonter.left)
+#define ffebld_name_string(n) ((n)->name)
+#define ffebld_new()							      \
+  ((ffebld) malloc_new_kp(ffebld_pool(), "FFEBLD",sizeof(struct _ffebld_)))
+#define ffebld_new_any() ffebld_new_none(FFEBLD_opANY)
+#define ffebld_new_conter(c) ffebld_new_conter_with_orig((c),NULL)
+#define ffebld_new_star() ffebld_new_none(FFEBLD_opSTAR)
+#define ffebld_new_uplus(l) ffebld_new_one(FFEBLD_opUPLUS,(l))
+#define ffebld_new_uminus(l) ffebld_new_one(FFEBLD_opUMINUS,(l))
+#define ffebld_new_add(l,r) ffebld_new_two(FFEBLD_opADD,(l),(r))
+#define ffebld_new_subtract(l,r) ffebld_new_two(FFEBLD_opSUBTRACT,(l),(r))
+#define ffebld_new_multiply(l,r) ffebld_new_two(FFEBLD_opMULTIPLY,(l),(r))
+#define ffebld_new_divide(l,r) ffebld_new_two(FFEBLD_opDIVIDE,(l),(r))
+#define ffebld_new_power(l,r) ffebld_new_two(FFEBLD_opPOWER,(l),(r))
+#define ffebld_new_bounds(l,r) ffebld_new_two(FFEBLD_opBOUNDS,(l),(r))
+#define ffebld_new_concatenate(l,r) ffebld_new_two(FFEBLD_opCONCATENATE,(l),(r))
+#define ffebld_new_not(l) ffebld_new_one(FFEBLD_opNOT,(l))
+#define ffebld_new_lt(l,r) ffebld_new_two(FFEBLD_opLT,(l),(r))
+#define ffebld_new_le(l,r) ffebld_new_two(FFEBLD_opLE,(l),(r))
+#define ffebld_new_eq(l,r) ffebld_new_two(FFEBLD_opEQ,(l),(r))
+#define ffebld_new_ne(l,r) ffebld_new_two(FFEBLD_opNE,(l),(r))
+#define ffebld_new_gt(l,r) ffebld_new_two(FFEBLD_opGT,(l),(r))
+#define ffebld_new_ge(l,r) ffebld_new_two(FFEBLD_opGE,(l),(r))
+#define ffebld_new_and(l,r) ffebld_new_two(FFEBLD_opAND,(l),(r))
+#define ffebld_new_or(l,r) ffebld_new_two(FFEBLD_opOR,(l),(r))
+#define ffebld_new_xor(l,r) ffebld_new_two(FFEBLD_opXOR,(l),(r))
+#define ffebld_new_eqv(l,r) ffebld_new_two(FFEBLD_opEQV,(l),(r))
+#define ffebld_new_neqv(l,r) ffebld_new_two(FFEBLD_opNEQV,(l),(r))
+#define ffebld_new_paren(l) ffebld_new_one(FFEBLD_opPAREN,(l))
+#define ffebld_new_repeat(l,r) ffebld_new_two(FFEBLD_opREPEAT,(l),(r))
+#define ffebld_new_percent_descr(l) ffebld_new_one(FFEBLD_opPERCENT_DESCR,(l))
+#define ffebld_new_percent_loc(l) ffebld_new_one(FFEBLD_opPERCENT_LOC,(l))
+#define ffebld_new_percent_ref(l) ffebld_new_one(FFEBLD_opPERCENT_REF,(l))
+#define ffebld_new_percent_val(l) ffebld_new_one(FFEBLD_opPERCENT_VAL,(l))
+#define ffebld_new_complex(l,r) ffebld_new_two(FFEBLD_opCOMPLEX,(l),(r))
+#define ffebld_new_convert(l) ffebld_new_one(FFEBLD_opCONVERT,(l))
+#define ffebld_new_funcref(l,r) ffebld_new_two(FFEBLD_opFUNCREF,(l),(r))
+#define ffebld_new_subrref(l,r) ffebld_new_two(FFEBLD_opSUBRREF,(l),(r))
+#define ffebld_new_arrayref(l,r) ffebld_new_two(FFEBLD_opARRAYREF,(l),(r))
+#define ffebld_new_substr(l,r) ffebld_new_two(FFEBLD_opSUBSTR,(l),(r))
+#define ffebld_new_impdo(l,r) ffebld_new_two(FFEBLD_opIMPDO,(l),(r))
+#define ffebld_nonter_hook(b) ((b)->u.nonter.hook)
+#define ffebld_nonter_set_hook(b,h) ((b)->u.nonter.hook = (h))
+#define ffebld_op(b) ((b)->op)
+#define ffebld_pool() (ffebld_pool_stack_.pool)
+#define ffebld_rank(b) (ffeinfo_rank (ffebld_info ((b))))
+#define ffebld_right(b) ((b)->u.nonter.right)
+#define ffebld_set_accter(b,a) ((b)->u.accter.array = (a))
+#define ffebld_set_arrter(b,a) ((b)->u.arrter.array = (a))
+#define ffebld_set_conter(b,c) ((b)->u.conter.expr = (c))
+#define ffebld_set_info(b,i) ((b)->info = (i))
+#define ffebld_set_labter(b,l) ((b)->u.labter = (l))
+#define ffebld_set_op(b,o) ((b)->op = (o))
+#define ffebld_set_head(b,h) ((b)->u.item.head = (h))
+#define ffebld_set_left(b,l) ((b)->u.nonter.left = (l))
+#define ffebld_set_right(b,r) ((b)->u.nonter.right = (r))
+#define ffebld_set_trail(b,t) ((b)->u.item.trail = (t))
+#define ffebld_size(b) (ffeinfo_size (ffebld_info ((b))))
+#define ffebld_size_known(b) ffebld_size((b))
+#define ffebld_symter(b) ((b)->u.symter.symbol)
+#define ffebld_symter_generic(b) ((b)->u.symter.generic)
+#define ffebld_symter_doiter(b) ((b)->u.symter.do_iter)
+#define ffebld_symter_implementation(b) ((b)->u.symter.implementation)
+#define ffebld_symter_specific(b) ((b)->u.symter.specific)
+#define ffebld_symter_set_generic(b,g) ((b)->u.symter.generic = (g))
+#define ffebld_symter_set_implementation(b,i) \
+  ((b)->u.symter.implementation = (i))
+#define ffebld_symter_set_is_doiter(b,f) ((b)->u.symter.do_iter = (f))
+#define ffebld_symter_set_specific(b,s) ((b)->u.symter.specific = (s))
+#define ffebld_terminate_0()
+#define ffebld_terminate_1()
+#define ffebld_terminate_2()
+#define ffebld_terminate_3()
+#define ffebld_terminate_4()
+#define ffebld_trail(b) ((b)->u.item.trail)
+#define ffebld_where(b) (ffeinfo_where (ffebld_info ((b))))
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_BLD_H */

gcc/f/bugs.texi

@@ -0,0 +1,260 @@
+@c Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004 Free Software Foundation, Inc.
+@c This is part of the G77 manual.
+@c For copying conditions, see the file g77.texi.
+
+@c The text of this file appears in the file BUGS
+@c in the G77 distribution, as well as in the G77 manual.
+
+@c Keep this the same as the dates above, since it's used
+@c in the standalone derivations of this file (e.g. BUGS).
+@set copyrights-bugs 1995,1996,1997,1998,1999,2000,2001,2002,2004
+
+@set last-update-bugs 2004-05-18
+
+@ifset DOC-BUGS
+@include root.texi
+@c The immediately following lines apply to the BUGS file
+@c which is derived from this file.
+@emph{Note:} This file is automatically generated from the files
+@file{bugs0.texi} and @file{bugs.texi}.
+@file{BUGS} is @emph{not} a source file,
+although it is normally included within source distributions.
+
+This file lists known bugs in the @value{which-g77} version
+of the GNU Fortran compiler.
+Copyright (C) @value{copyrights-bugs} Free Software Foundation, Inc.
+You may copy, distribute, and modify it freely as long as you preserve
+this copyright notice and permission notice.
+
+@node Top,,, (dir)
+@chapter Known Bugs In GNU Fortran
+@end ifset
+
+@ifset DOC-G77
+@node Known Bugs
+@section Known Bugs In GNU Fortran
+@end ifset
+
+This section identifies bugs that @code{g77} @emph{users}
+might run into in the @value{which-g77} version
+of @code{g77}.
+This includes bugs that are actually in the @code{gcc}
+back end (GBE) or in @code{libf2c}, because those
+sets of code are at least somewhat under the control
+of (and necessarily intertwined with) @code{g77},
+so it isn't worth separating them out.
+
+@ifset DOC-G77
+For information on bugs in @emph{other} versions of @code{g77},
+see @ref{News,,News About GNU Fortran}.
+There, lists of bugs fixed in various versions of @code{g77}
+can help determine what bugs existed in prior versions.
+@end ifset
+
+@ifset DOC-BUGS
+For information on bugs in @emph{other} versions of @code{g77},
+see @file{@value{path-g77}/NEWS}.
+There, lists of bugs fixed in various versions of @code{g77}
+can help determine what bugs existed in prior versions.
+@end ifset
+
+@ifset DEVELOPMENT
+@emph{Warning:} The information below is still under development,
+and might not accurately reflect the @code{g77} code base
+of which it is a part.
+Efforts are made to keep it somewhat up-to-date,
+but they are particularly concentrated
+on any version of this information
+that is distributed as part of a @emph{released} @code{g77}.
+
+In particular, while this information is intended to apply to
+the @value{which-g77} version of @code{g77},
+only an official @emph{release} of that version
+is expected to contain documentation that is
+most consistent with the @code{g77} product in that version.
+@end ifset
+
+The following information was last updated on @value{last-update-bugs}:
+
+@itemize @bullet
+@item
+@code{g77} fails to warn about
+use of a ``live'' iterative-DO variable
+as an implied-DO variable
+in a @code{WRITE} or @code{PRINT} statement
+(although it does warn about this in a @code{READ} statement).
+
+@item
+Something about @code{g77}'s straightforward handling of
+label references and definitions sometimes prevents the GBE
+from unrolling loops.
+Until this is solved, try inserting or removing @code{CONTINUE}
+statements as the terminal statement, using the @code{END DO}
+form instead, and so on.
+
+@item
+Some confusion in diagnostics concerning failing @code{INCLUDE}
+statements from within @code{INCLUDE}'d or @code{#include}'d files.
+
+@cindex integer constants
+@cindex constants, integer
+@item
+@code{g77} assumes that @code{INTEGER(KIND=1)} constants range
+from @samp{-2**31} to @samp{2**31-1} (the range for
+two's-complement 32-bit values),
+instead of determining their range from the actual range of the
+type for the configuration (and, someday, for the constant).
+
+Further, it generally doesn't implement the handling
+of constants very well in that it makes assumptions about the
+configuration that it no longer makes regarding variables (types).
+
+Included with this item is the fact that @code{g77} doesn't recognize
+that, on IEEE-754/854-compliant systems, @samp{0./0.} should produce a NaN
+and no warning instead of the value @samp{0.} and a warning.
+
+@cindex compiler speed
+@cindex speed, of compiler
+@cindex compiler memory usage
+@cindex memory usage, of compiler
+@cindex large aggregate areas
+@cindex initialization, bug
+@cindex DATA statement
+@cindex statements, DATA
+@item
+@code{g77} uses way too much memory and CPU time to process large aggregate
+areas having any initialized elements.
+
+For example, @samp{REAL A(1000000)} followed by @samp{DATA A(1)/1/}
+takes up way too much time and space, including
+the size of the generated assembler file.
+
+Version 0.5.18 improves cases like this---specifically,
+cases of @emph{sparse} initialization that leave large, contiguous
+areas uninitialized---significantly.
+However, even with the improvements, these cases still
+require too much memory and CPU time.
+
+(Version 0.5.18 also improves cases where the initial values are
+zero to a much greater degree, so if the above example
+ends with @samp{DATA A(1)/0/}, the compile-time performance
+will be about as good as it will ever get, aside from unrelated
+improvements to the compiler.)
+
+Note that @code{g77} does display a warning message to
+notify the user before the compiler appears to hang.
+@ifset DOC-G77
+A warning message is issued when @code{g77} sees code that provides
+initial values (e.g. via @code{DATA}) to an aggregate area (@code{COMMON}
+or @code{EQUIVALENCE}, or even a large enough array or @code{CHARACTER}
+variable)
+that is large enough to increase @code{g77}'s compile time by roughly
+a factor of 10.
+
+This size currently is quite small, since @code{g77}
+currently has a known bug requiring too much memory
+and time to handle such cases.
+In @file{@value{path-g77}/data.c}, the macro
+@code{FFEDATA_sizeTOO_BIG_INIT_} is defined
+to the minimum size for the warning to appear.
+The size is specified in storage units,
+which can be bytes, words, or whatever, on a case-by-case basis.
+
+After changing this macro definition, you must
+(of course) rebuild and reinstall @code{g77} for
+the change to take effect.
+
+Note that, as of version 0.5.18, improvements have
+reduced the scope of the problem for @emph{sparse}
+initialization of large arrays, especially those
+with large, contiguous uninitialized areas.
+However, the warning is issued at a point prior to
+when @code{g77} knows whether the initialization is sparse,
+and delaying the warning could mean it is produced
+too late to be helpful.
+
+Therefore, the macro definition should not be adjusted to
+reflect sparse cases.
+Instead, adjust it to generate the warning when densely
+initialized arrays begin to cause responses noticeably slower
+than linear performance would suggest.
+@end ifset
+
+@cindex code, displaying main source
+@cindex displaying main source code
+@cindex debugging main source code
+@cindex printing main source
+@item
+When debugging, after starting up the debugger but before being able
+to see the source code for the main program unit, the user must currently
+set a breakpoint at @code{MAIN__} (or @code{MAIN___} or @code{MAIN_} if
+@code{MAIN__} doesn't exist)
+and run the program until it hits the breakpoint.
+At that point, the
+main program unit is activated and about to execute its first
+executable statement, but that's the state in which the debugger should
+start up, as is the case for languages like C.
+
+@cindex debugger
+@item
+Debugging @code{g77}-compiled code using debuggers other than
+@code{gdb} is likely not to work.
+
+Getting @code{g77} and @code{gdb} to work together is a known
+problem---getting @code{g77} to work properly with other
+debuggers, for which source code often is unavailable to @code{g77}
+developers, seems like a much larger, unknown problem,
+and is a lower priority than making @code{g77} and @code{gdb}
+work together properly.
+
+On the other hand, information about problems other debuggers
+have with @code{g77} output might make it easier to properly
+fix @code{g77}, and perhaps even improve @code{gdb}, so it
+is definitely welcome.
+Such information might even lead to all relevant products
+working together properly sooner.
+
+@cindex Alpha, support
+@cindex support, Alpha
+@item
+@code{g77} doesn't work perfectly on 64-bit configurations
+such as the Digital Semiconductor (``DEC'') Alpha.
+
+This problem is largely resolved as of version 0.5.23.
+
+@cindex padding
+@cindex structures
+@cindex common blocks
+@cindex equivalence areas
+@item
+@code{g77} currently inserts needless padding for things like
+@samp{COMMON A,IPAD} where @samp{A} is @code{CHARACTER*1} and @samp{IPAD}
+is @code{INTEGER(KIND=1)} on machines like x86,
+because the back end insists that @samp{IPAD}
+be aligned to a 4-byte boundary,
+but the processor has no such requirement
+(though it is usually good for performance).
+
+The @code{gcc} back end needs to provide a wider array
+of specifications of alignment requirements and preferences for targets,
+and front ends like @code{g77} should take advantage of this
+when it becomes available.
+
+@cindex complex performance
+@cindex aliasing
+@item
+The @code{libf2c} routines that perform some run-time
+arithmetic on @code{COMPLEX} operands
+were modified circa version 0.5.20 of @code{g77}
+to work properly even in the presence of aliased operands.
+
+While the @code{g77} and @code{netlib} versions of @code{libf2c}
+differ on how this is accomplished,
+the main differences are that we believe
+the @code{g77} version works properly
+even in the presence of @emph{partially} aliased operands.
+
+However, these modifications have reduced performance
+on targets such as x86,
+due to the extra copies of operands involved.
+@end itemize

gcc/f/bugs0.texi

@@ -0,0 +1,9 @@
+\input texinfo  @c -*-texinfo-*-
+@c %**start of header
+@setfilename BUGS
+@c %**end of header
+
+@c This tells bugs.texi that it's generating just the BUGS file.
+@set DOC-BUGS
+@include bugs.texi
+@bye

gcc/f/com-rt.def

@@ -0,0 +1,289 @@
+/* com-rt.def -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      com.c
+
+   Modifications:
+*/
+
+/* DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX,CONST):
+
+   CODE -- the #define name to use to refer to the function in g77 code
+
+   NAME -- the name as seen by the back end and, with whatever massaging
+	   is normal, the linker
+
+   TYPE -- a code for the tree for the type, assigned when first encountered
+	   (NOTE: There's a distinction made between the semantic return
+	   value for the function, and the actual return mechanism; e.g.
+	   `r_abs()' computes a single-precision `float' return value
+	   but returns it as a `double'.  This distinction is important
+	   and is flagged via the _F2C_ versus _GNU_ suffix.)
+
+   ARGS -- a string of codes representing the types of the arguments; the
+           last type specifies the type for that and all following args,
+           and the null pointer (0) means the same as "0":
+
+               0  Not applicable at and beyond this point
+               &  Pointer to type that follows
+               a  char
+               c  complex
+               d  doublereal
+               e  doublecomplex
+               f  real
+               i  integer
+               j  longint
+
+   VOLATILE -- TRUE if the function never returns (gen's emit_barrier in
+	       g77 back end)
+
+   COMPLEX -- TRUE if the return value is COMPLEX or DOUBLE COMPLEX and
+	      thus might need to be returned as ptr-to-1st-arg
+
+   CONST -- TRUE if the function is const
+            (does not have side effects and only depends on its arguments).
+
+*/
+
+DEFGFRT (FFECOM_gfrtCAT, "s_cat", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCMP, "s_cmp", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCOPY, "s_copy", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPAUSE, "s_paus", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSTOP, "s_stop", FFECOM_rttypeVOID_, 0, TRUE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtRANGE, "s_rnge", FFECOM_rttypeINTEGER_, 0, TRUE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtSRDUE, "s_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERDUE, "e_rdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRSUE, "s_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERSUE, "e_rsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRDFE, "s_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERDFE, "e_rdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRSFI, "s_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERSFI, "e_rsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRSFE, "s_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERSFE, "e_rsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRSLI, "s_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERSLI, "e_rsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRSLE, "s_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERSLE, "e_rsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRSNE, "s_rsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtSWDUE, "s_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWDUE, "e_wdue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWSUE, "s_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWSUE, "e_wsue", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWDFE, "s_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWDFE, "e_wdfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWSFI, "s_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWSFI, "e_wsfi", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWSFE, "s_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWSFE, "e_wsfe", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWSLI, "s_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWSLI, "e_wsli", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWSLE, "s_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEWSLE, "e_wsle", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSWSNE, "s_wsne", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtDOFIO, "do_fio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDOLIO, "do_lio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDOUIO, "do_uio", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtFOPEN, "f_open", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFCLOS, "f_clos", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFINQU, "f_inqu", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtFBACK, "f_back", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFEND, "f_end", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFREW, "f_rew", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtABORT, "G77_abort_0", FFECOM_rttypeVOID_, 0, TRUE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtABS, "r_abs", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtACCESS, "G77_access_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtACOS, "r_acos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtAIMAG, "r_imag", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtAINT, "r_int", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtALARM, "G77_alarm_0", FFECOM_rttypeINTEGER_, "&i0", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtALOG, "r_log", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtALOG10, "r_lg10", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtAMOD, "r_mod", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtANINT, "r_nint", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtASIN, "r_asin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtATAN, "r_atan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtATAN2, "r_atn2", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCABS, "c_abs", FFECOM_rttypeREAL_F2C_, "&c", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCCOS, "c_cos", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCEXP, "c_exp", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCHDIR, "G77_chdir_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCLOG, "c_log", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCHMOD, "G77_chmod_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCONJG, "r_cnjg", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCOS, "r_cos", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCOSH, "r_cosh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCSIN, "c_sin", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCSQRT, "c_sqrt", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCTIME, "G77_ctime_0", FFECOM_rttypeCHARACTER_, "&j", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDABS, "d_abs", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDACOS, "d_acos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDASIN, "d_asin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDATAN, "d_atan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDATAN2, "d_atn2", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDATE, "G77_date_y2kbug_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDATE_AND_TIME, "G77_date_and_time_0", FFECOM_rttypeVOID_, "&a&a&a&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtL_BESJ0, "j0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_BESJ1, "j1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_BESJN, "jn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_BESY0, "y0", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_BESY1, "y1", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_BESYN, "yn", FFECOM_rttypeDOUBLE_, "id", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtDCOS, "d_cos", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDCOSH, "d_cosh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDDIM, "d_dim", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDERF, "G77_derf_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDERFC, "G77_derfc_0", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDEXP, "d_exp", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDIM, "r_dim", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDINT, "d_int", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDLOG, "d_log", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDLOG10, "d_lg10", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDMOD, "d_mod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDNINT, "d_nint", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDPROD, "d_prod", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDSIGN, "d_sign", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDSIN, "d_sin", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDSINH, "d_sinh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDSQRT, "d_sqrt", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDTAN, "d_tan", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDTANH, "d_tanh", FFECOM_rttypeDOUBLE_, "&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtDTIME, "G77_dtime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERF, "G77_erf_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtERFC, "G77_erfc_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtETIME, "G77_etime_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEXIT, "G77_exit_0", FFECOM_rttypeVOID_, "&i", TRUE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtEXP, "r_exp", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFDATE, "G77_fdate_0", FFECOM_rttypeCHARACTER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFGET, "G77_fget_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFGETC, "G77_fgetc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFLUSH, "G77_flush_0", FFECOM_rttypeVOID_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFLUSH1, "G77_flush1_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFNUM, "G77_fnum_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFPUT, "G77_fput_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFPUTC, "G77_fputc_0", FFECOM_rttypeINTEGER_, "&i&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFSTAT, "G77_fstat_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFTELL, "G77_ftell_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtFSEEK, "G77_fseek_0", FFECOM_rttypeINTEGER_, "&i&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGERROR, "G77_gerror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETARG, "G77_getarg_0", FFECOM_rttypeVOID_, "&i&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETCWD, "G77_getcwd_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETGID, "G77_getgid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETLOG, "G77_getlog_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETPID, "G77_getpid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETUID, "G77_getuid_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGETENV, "G77_getenv_0", FFECOM_rttypeVOID_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtGMTIME, "G77_gmtime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtHOSTNM, "G77_hostnm_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIABS, "i_abs", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIARGC, "G77_iargc_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIDATE, "G77_idate_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIDIM, "i_dim", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIDNINT, "i_dnnt", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIERRNO, "G77_ierrno_0", FFECOM_rttypeINTEGER_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtINDEX, "i_indx", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtIRAND, "G77_irand_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtISIGN, "i_sign", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtISATTY, "G77_isatty_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtITIME, "G77_itime_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtKILL, "G77_kill_0", FFECOM_rttypeINTEGER_, "&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLEN, "i_len", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtLGE, "l_ge", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLGT, "l_gt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLINK, "G77_link_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLLE, "l_le", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLLT, "l_lt", FFECOM_rttypeLOGICAL_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLNBLNK, "G77_lnblnk_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLSTAT, "G77_lstat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtLTIME, "G77_ltime_0", FFECOM_rttypeVOID_, "&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtMCLOCK, "G77_mclock_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtMOD, "i_mod", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtNINT, "i_nint", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPERROR, "G77_perror_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtRAND, "G77_rand_0", FFECOM_rttypeREAL_F2C_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtRENAME, "G77_rename_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSECNDS, "G77_secnds_0", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSECOND, "G77_second_0", FFECOM_rttypeREAL_F2C_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSIGN, "r_sign", FFECOM_rttypeREAL_F2C_, "&f&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtL_SIGNAL, "G77_signal_0", FFECOM_rttypeVOIDSTAR_, "&i0", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSIN, "r_sin", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSINH, "r_sinh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSLEEP, "G77_sleep_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSQRT, "r_sqrt", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSRAND, "G77_srand_0", FFECOM_rttypeVOID_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSTAT, "G77_stat_0", FFECOM_rttypeINTEGER_, "&a&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSYMLNK, "G77_symlnk_0", FFECOM_rttypeINTEGER_, "&a&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSYSTEM, "G77_system_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtSYSTEM_CLOCK, "G77_system_clock_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtTAN, "r_tan", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtTANH, "r_tanh", FFECOM_rttypeREAL_F2C_, "&f", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtTIME, "G77_time_0", FFECOM_rttypeLONGINT_, 0, FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtTTYNAM, "G77_ttynam_0", FFECOM_rttypeCHARACTER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtUNLINK, "G77_unlink_0", FFECOM_rttypeINTEGER_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtUMASK, "G77_umask_0", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtVXTIDATE, "G77_vxtidate_y2kbug_0", FFECOM_rttypeVOID_, "&i&i&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtVXTTIME, "G77_vxttime_0", FFECOM_rttypeVOID_, "&a", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCDABS, "z_abs", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtCDCOS, "z_cos", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCDEXP, "z_exp", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCDLOG, "z_log", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtDCONJG, "d_cnjg", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCDSIN, "z_sin", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtCDSQRT, "z_sqrt", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtDIMAG, "d_imag", FFECOM_rttypeDOUBLE_, "&e", FALSE, FALSE, FALSE)
+
+DEFGFRT (FFECOM_gfrtL_ACOS, "acos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_ASIN, "asin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_ATAN, "__builtin_atan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_ATAN2, "__builtin_atan2", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_COS, "__builtin_cos", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_COSH, "cosh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_ERF, "erf", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_ERFC, "erfc", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_EXP, "__builtin_exp", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_FLOOR, "__builtin_floor", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_FMOD, "__builtin_fmod", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_LOG, "__builtin_log", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_LOG10, "log10", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_POW, "__builtin_pow", FFECOM_rttypeDOUBLE_, "dd", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_SIN, "__builtin_sin", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_SINH, "sinh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_SQRT, "__builtin_sqrt", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_TAN, "__builtin_tan", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+DEFGFRT (FFECOM_gfrtL_TANH, "tanh", FFECOM_rttypeDOUBLE_, "d", FALSE, FALSE, TRUE)
+
+DEFGFRT (FFECOM_gfrtPOW_CI, "pow_ci", FFECOM_rttypeCOMPLEX_F2C_, "&c&i", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_DD, "pow_dd", FFECOM_rttypeDOUBLE_, "&d&d", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_DI, "pow_di", FFECOM_rttypeDOUBLE_, "&d&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_II, "pow_ii", FFECOM_rttypeINTEGER_, "&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_QQ, "pow_qq", FFECOM_rttypeLONGINT_, "&j&j", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_RI, "pow_ri", FFECOM_rttypeREAL_F2C_, "&f&i", FALSE, FALSE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_ZI, "pow_zi", FFECOM_rttypeDBLCMPLX_F2C_, "&e&i", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtPOW_ZZ, "pow_zz", FFECOM_rttypeDBLCMPLX_F2C_, "&e&e", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtDIV_CC, "c_div", FFECOM_rttypeCOMPLEX_F2C_, "&c", FALSE, TRUE, FALSE)
+DEFGFRT (FFECOM_gfrtDIV_ZZ, "z_div", FFECOM_rttypeDBLCMPLX_F2C_, "&e", FALSE, TRUE, FALSE)

gcc/f/com.h

@@ -0,0 +1,290 @@
+/* com.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 1996, 1997, 2000, 2003, 2004
+   Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      com.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_COM_H
+#define GCC_F_COM_H
+
+/* Simple definitions and enumerations. */
+
+#define FFECOM_dimensionsMAX 7	/* Max # dimensions (quick hack). */
+
+#define FFECOM_SIZE_UNIT "byte"	/* Singular form. */
+#define FFECOM_SIZE_UNITS "bytes"	/* Plural form. */
+
+#define FFECOM_constantNULL NULL_TREE
+#define FFECOM_nonterNULL NULL_TREE
+#define FFECOM_globalNULL NULL_TREE
+#define FFECOM_labelNULL NULL_TREE
+#define FFECOM_storageNULL NULL_TREE
+#define FFECOM_symbolNULL ffecom_symbol_null_
+
+/* Shorthand for types used in f2c.h and that g77 perhaps allows some
+   flexibility regarding in the section below.  I.e. the actual numbers
+   below aren't important, as long as they're unique.  */
+
+#define FFECOM_f2ccodeCHAR 1
+#define FFECOM_f2ccodeSHORT 2
+#define FFECOM_f2ccodeINT 3
+#define FFECOM_f2ccodeLONG 4
+#define FFECOM_f2ccodeLONGLONG 5
+#define FFECOM_f2ccodeCHARPTR 6		/* char * */
+#define FFECOM_f2ccodeFLOAT 7
+#define FFECOM_f2ccodeDOUBLE 8
+#define FFECOM_f2ccodeLONGDOUBLE 9
+#define FFECOM_f2ccodeTWOREALS 10
+#define FFECOM_f2ccodeTWODOUBLEREALS 11
+
+#if FFECOM_DETERMINE_TYPES	/* only for com.c and configure */
+
+/* Begin f2c.h information.  This must match the info in the f2c.h used
+   to build the libf2c with which g77-generated code is linked, or there
+   will probably be bugs, some of them difficult to detect or even trigger.  */
+
+/* The C front-end provides __g77_integer and __g77_uinteger types so that
+   the appropriately-sized signed and unsigned integer types are available
+   for libf2c.  If you change this, also the definitions of those types
+   in ../c-decl.c. */
+#define FFECOM_f2cINTEGER			\
+  (LONG_TYPE_SIZE == FLOAT_TYPE_SIZE		\
+   ? FFECOM_f2ccodeLONG				\
+   : (INT_TYPE_SIZE == FLOAT_TYPE_SIZE		\
+      ? FFECOM_f2ccodeINT			\
+      : (abort (), -1)))
+
+#define FFECOM_f2cLOGICAL FFECOM_f2cINTEGER
+
+/* The C front-end provides __g77_longint and __g77_ulongint types so that
+   the appropriately-sized signed and unsigned integer types are available
+   for libf2c.  If you change this, also the definitions of those types
+   in ../c-decl.c. */
+#define FFECOM_f2cLONGINT				\
+ (LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2)		\
+  ? FFECOM_f2ccodeLONG					\
+  : (LONG_LONG_TYPE_SIZE == (FLOAT_TYPE_SIZE * 2)	\
+     ? FFECOM_f2ccodeLONGLONG				\
+     : (abort (), -1)))
+
+#define FFECOM_f2cADDRESS FFECOM_f2ccodeCHARPTR
+#define FFECOM_f2cSHORTINT FFECOM_f2ccodeSHORT
+#define FFECOM_f2cREAL FFECOM_f2ccodeFLOAT
+#define FFECOM_f2cDOUBLEREAL FFECOM_f2ccodeDOUBLE
+#define FFECOM_f2cCOMPLEX FFECOM_f2ccodeTWOREALS
+#define FFECOM_f2cDOUBLECOMPLEX FFECOM_f2ccodeTWODOUBLEREALS
+#define FFECOM_f2cSHORTLOGICAL FFECOM_f2ccodeSHORT
+#define FFECOM_f2cLOGICAL1 FFECOM_f2ccodeCHAR
+#define FFECOM_f2cINTEGER1 FFECOM_f2ccodeCHAR
+
+/* These must be f2c's INTEGER type, to match runtime/f2c.h.in.  */
+
+#define FFECOM_f2cFLAG FFECOM_f2cINTEGER
+#define FFECOM_f2cFTNINT FFECOM_f2cINTEGER
+#define FFECOM_f2cFTNLEN FFECOM_f2cINTEGER
+
+#endif	/* #if FFECOM_DETERMINE_TYPES */
+
+/* Everything else in f2c.h, specifically the structures used in
+   interfacing compiled code with the library, must remain exactly
+   as delivered, or g77 internals (mostly com.c and ste.c) must
+   be modified accordingly to compensate.  Or there will be...trouble.  */
+
+typedef enum
+  {
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CODE,
+#include "com-rt.def"
+#undef DEFGFRT
+    FFECOM_gfrt
+  } ffecomGfrt;
+
+/* Typedefs. */
+
+#ifndef TREE_CODE
+#include "tree.h"
+#endif
+
+typedef tree ffecomConstant;
+typedef tree ffecomNonter;
+typedef tree ffecomLabel;
+typedef tree ffecomGlobal;
+typedef tree ffecomStorage;
+typedef struct _ffecom_symbol_ ffecomSymbol;
+
+struct _ffecom_symbol_
+  {
+    tree decl_tree;
+    tree length_tree;		/* For CHARACTER dummies. */
+    tree vardesc_tree;		/* For NAMELIST. */
+    tree assign_tree;		/* For ASSIGN'ed vars. */
+    bool addr;			/* Is address of item instead of item. */
+  };
+
+/* Include files needed by this one. */
+
+#include "bld.h"
+#include "info.h"
+#include "lab.h"
+#include "storag.h"
+#include "symbol.h"
+
+extern int global_bindings_p (void);
+extern tree getdecls (void);
+extern void pushlevel (int);
+extern tree poplevel (int,int, int);
+extern void insert_block (tree);
+extern void set_block (tree);
+extern tree pushdecl (tree);
+
+/* Global objects accessed by users of this module. */
+
+extern GTY(()) tree string_type_node;
+extern GTY(()) tree ffecom_integer_type_node;
+extern GTY(()) tree ffecom_integer_zero_node;
+extern GTY(()) tree ffecom_integer_one_node;
+extern GTY(()) tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
+extern ffecomSymbol ffecom_symbol_null_;
+extern ffeinfoKindtype ffecom_pointer_kind_;
+extern ffeinfoKindtype ffecom_label_kind_;
+
+extern int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
+extern GTY(()) tree ffecom_f2c_integer_type_node;
+extern GTY(()) tree ffecom_f2c_address_type_node;
+extern GTY(()) tree ffecom_f2c_real_type_node;
+extern GTY(()) tree ffecom_f2c_doublereal_type_node;
+extern GTY(()) tree ffecom_f2c_complex_type_node;
+extern GTY(()) tree ffecom_f2c_doublecomplex_type_node;
+extern GTY(()) tree ffecom_f2c_longint_type_node;
+extern GTY(()) tree ffecom_f2c_logical_type_node;
+extern GTY(()) tree ffecom_f2c_flag_type_node;
+extern GTY(()) tree ffecom_f2c_ftnlen_type_node;
+extern GTY(()) tree ffecom_f2c_ftnlen_zero_node;
+extern GTY(()) tree ffecom_f2c_ftnlen_one_node;
+extern GTY(()) tree ffecom_f2c_ftnlen_two_node;
+extern GTY(()) tree ffecom_f2c_ptr_to_ftnlen_type_node;
+extern GTY(()) tree ffecom_f2c_ftnint_type_node;
+extern GTY(()) tree ffecom_f2c_ptr_to_ftnint_type_node;
+
+/* Declare functions with prototypes. */
+
+tree ffecom_1 (enum tree_code code, tree type, tree node);
+tree ffecom_1_fn (tree node);
+tree ffecom_2 (enum tree_code code, tree type, tree node1, tree node2);
+bool ffecom_2pass_advise_entrypoint (ffesymbol entry);
+void ffecom_2pass_do_entrypoint (ffesymbol entry);
+tree ffecom_2s (enum tree_code code, tree type, tree node1, tree node2);
+tree ffecom_3 (enum tree_code code, tree type, tree node1, tree node2,
+	       tree node3);
+tree ffecom_3s (enum tree_code code, tree type, tree node1, tree node2,
+		tree node3);
+tree ffecom_arg_expr (ffebld expr, tree *length);
+tree ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length);
+tree ffecom_arg_ptr_to_expr (ffebld expr, tree *length);
+tree ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook);
+tree ffecom_constantunion_with_type (ffebldConstantUnion *cu, 
+		            tree tree_type,ffebldConst ct);
+tree ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
+			   ffeinfoKindtype kt, tree tree_type);
+tree ffecom_const_expr (ffebld expr);
+tree ffecom_decl_field (tree context, tree prevfield, const char *name,
+			tree type);
+void ffecom_close_include (FILE *f);
+void ffecom_decode_include_option (const char *dir);
+tree ffecom_end_compstmt (void);
+void ffecom_end_transition (void);
+void ffecom_exec_transition (void);
+void ffecom_expand_let_stmt (ffebld dest, ffebld source);
+tree ffecom_expr (ffebld expr);
+tree ffecom_expr_assign (ffebld expr);
+tree ffecom_expr_assign_w (ffebld expr);
+tree ffecom_expr_rw (tree type, ffebld expr);
+tree ffecom_expr_w (tree type, ffebld expr);
+void ffecom_finish_compile (void);
+void ffecom_finish_decl (tree decl, tree init, bool is_top_level);
+void ffecom_finish_progunit (void);
+tree ffecom_get_invented_identifier (const char *pattern, ...)
+  ATTRIBUTE_PRINTF_1;
+ffeinfoBasictype ffecom_gfrt_basictype (ffecomGfrt ix);
+ffeinfoKindtype ffecom_gfrt_kindtype (ffecomGfrt ix);
+void ffecom_init_0 (void);
+void ffecom_init_2 (void);
+tree ffecom_list_expr (ffebld list);
+tree ffecom_list_ptr_to_expr (ffebld list);
+tree ffecom_lookup_label (ffelab label);
+tree ffecom_make_tempvar (const char *commentary, tree type,
+			  ffetargetCharacterSize size, int elements);
+tree ffecom_modify (tree newtype, tree lhs, tree rhs);
+void ffecom_save_tree_forever (tree t);
+void ffecom_file (const char *name);
+void ffecom_notify_init_storage (ffestorag st);
+void ffecom_notify_init_symbol (ffesymbol s);
+void ffecom_notify_primary_entry (ffesymbol fn);
+FILE *ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c);
+void ffecom_prepare_arg_ptr_to_expr (ffebld expr);
+bool ffecom_prepare_end (void);
+void ffecom_prepare_expr_ (ffebld expr, ffebld dest);
+void ffecom_prepare_expr_rw (tree type, ffebld expr);
+void ffecom_prepare_expr_w (tree type, ffebld expr);
+void ffecom_prepare_ptr_to_expr (ffebld expr);
+void ffecom_prepare_return_expr (ffebld expr);
+tree ffecom_ptr_to_const_expr (ffebld expr);
+tree ffecom_ptr_to_expr (ffebld expr);
+tree ffecom_return_expr (ffebld expr);
+tree ffecom_save_tree (tree t);
+void ffecom_start_compstmt (void);
+tree ffecom_start_decl (tree decl, bool is_init);
+void ffecom_sym_commit (ffesymbol s);
+ffesymbol ffecom_sym_end_transition (ffesymbol s);
+ffesymbol ffecom_sym_exec_transition (ffesymbol s);
+ffesymbol ffecom_sym_learned (ffesymbol s);
+void ffecom_sym_retract (ffesymbol s);
+tree ffecom_temp_label (void);
+tree ffecom_truth_value (tree expr);
+tree ffecom_truth_value_invert (tree expr);
+tree ffecom_type_expr (ffebld expr);
+tree ffecom_which_entrypoint_decl (void);
+void ffe_parse_file (int);
+
+/* Define macros. */
+
+#define ffecom_f2c_typecode(bt,kt) ffecom_f2c_typecode_[(bt)][(kt)]
+#define ffecom_label_kind() ffecom_label_kind_
+#define ffecom_pointer_kind() ffecom_pointer_kind_
+#define ffecom_prepare_expr(e) ffecom_prepare_expr_ ((e), NULL)
+
+#define ffecom_init_1()
+#define ffecom_init_3()
+#define ffecom_init_4()
+#define ffecom_terminate_0()
+#define ffecom_terminate_1()
+#define ffecom_terminate_2()
+#define ffecom_terminate_3()
+#define ffecom_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_COM_H */

gcc/f/config-lang.in

@@ -0,0 +1,36 @@
+# Top level configure fragment for GNU FORTRAN.
+#   Copyright (C) 1995, 1996, 1997, 2000, 2001, 2002 Free Software Foundation, Inc.
+
+#This file is part of GNU Fortran.
+
+#GNU Fortran 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.
+
+#GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+#02111-1307, USA.
+
+# Configure looks for the existence of this file to auto-config each language.
+# We define several parameters used by configure:
+#
+# language	- name of language as it would appear in $(LANGUAGES)
+# compilers	- value to add to $(COMPILERS)
+# stagestuff	- files to add to $(STAGESTUFF)
+
+language="f77"
+
+compilers="f771\$(exeext)"
+
+stagestuff="g77\$(exeext) g77-cross\$(exeext) f771\$(exeext)"
+
+target_libs=target-libf2c
+
+gtfiles="\$(srcdir)/f/com.c \$(srcdir)/f/com.h \$(srcdir)/f/ste.c \$(srcdir)/f/where.h \$(srcdir)/f/where.c \$(srcdir)/f/lex.c"

gcc/f/data.h

@@ -0,0 +1,74 @@
+/* data.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      data.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_DATA_H
+#define GCC_F_DATA_H
+
+/* Simple definitions and enumerations. */
+
+
+/* Typedefs. */
+
+
+/* Include files needed by this one. */
+
+#include "bld.h"
+#include "lex.h"
+#include "storag.h"
+
+/* Structure definitions. */
+
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+void ffedata_begin (ffebld list);
+bool ffedata_end (bool report_errors, ffelexToken t);
+void ffedata_gather (ffestorag st);
+bool ffedata_value (ffetargetIntegerDefault rpt, ffebld value,
+		    ffelexToken value_token);
+
+/* Define macros. */
+
+#define ffedata_init_0()
+#define ffedata_init_1()
+#define ffedata_init_2()
+#define ffedata_init_3()
+#define ffedata_init_4()
+#define ffedata_terminate_0()
+#define ffedata_terminate_1()
+#define ffedata_terminate_2()
+#define ffedata_terminate_3()
+#define ffedata_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_DATA_H */

gcc/f/equiv.h

@@ -0,0 +1,100 @@
+/* equiv.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      equiv.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_EQUIV_H
+#define GCC_F_EQUIV_H
+
+/* Simple definitions and enumerations. */
+
+
+/* Typedefs. */
+
+typedef struct _ffeequiv_ *ffeequiv;
+
+/* Include files needed by this one. */
+
+#include "bld.h"
+#include "lex.h"
+#include "storag.h"
+#include "symbol.h"
+
+/* Structure definitions. */
+
+struct _ffeequiv_
+  {
+    ffeequiv next;
+    ffeequiv previous;
+    ffesymbol common;		/* Common area for this equiv, if any. */
+    ffebld list;		/* List of lists of equiv exprs. */
+    bool is_save;		/* Any SAVEd members? */
+    bool is_init;		/* Any initialized members? */
+  };
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+void ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t);
+void ffeequiv_exec_transition (void);
+void ffeequiv_init_2 (void);
+void ffeequiv_kill (ffeequiv victim);
+bool ffeequiv_layout_cblock (ffestorag st);
+ffeequiv ffeequiv_merge (ffeequiv eq1, ffeequiv eq2, ffelexToken t);
+ffeequiv ffeequiv_new (void);
+ffesymbol ffeequiv_symbol (ffebld expr);
+void ffeequiv_update_init (ffeequiv eq);
+void ffeequiv_update_save (ffeequiv eq);
+
+/* Define macros. */
+
+#define ffeequiv_common(e) ((e)->common)
+#define ffeequiv_init_0()
+#define ffeequiv_init_1()
+#define ffeequiv_init_3()
+#define ffeequiv_init_4()
+#define ffeequiv_is_init(e) ((e)->is_init)
+#define ffeequiv_is_save(e) ((e)->is_save)
+#define ffeequiv_list(e) ((e)->list)
+#define ffeequiv_next(e) ((e)->next)
+#define ffeequiv_previous(e) ((e)->previous)
+#define ffeequiv_set_common(e,c) ((e)->common = (c))
+#define ffeequiv_set_init(e,i) ((e)->init = (i))
+#define ffeequiv_set_is_init(e,in) ((e)->is_init = (in))
+#define ffeequiv_set_is_save(e,sa) ((e)->is_save = (sa))
+#define ffeequiv_set_list(e,l) ((e)->list = (l))
+#define ffeequiv_terminate_0()
+#define ffeequiv_terminate_1()
+#define ffeequiv_terminate_2()
+#define ffeequiv_terminate_3()
+#define ffeequiv_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_EQUIV_H */

gcc/f/expr.h

@@ -0,0 +1,194 @@
+/* expr.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 1996 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      expr.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_EXPR_H
+#define GCC_F_EXPR_H
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+    FFEEXPR_contextLET,
+    FFEEXPR_contextASSIGN,
+    FFEEXPR_contextIOLIST,
+    FFEEXPR_contextPARAMETER,
+    FFEEXPR_contextSUBROUTINEREF,
+    FFEEXPR_contextDATA,
+    FFEEXPR_contextIF,
+    FFEEXPR_contextARITHIF,
+    FFEEXPR_contextDO,
+    FFEEXPR_contextDOWHILE,
+    FFEEXPR_contextFORMAT,
+    FFEEXPR_contextAGOTO,
+    FFEEXPR_contextCGOTO,
+    FFEEXPR_contextCHARACTERSIZE,
+    FFEEXPR_contextEQUIVALENCE,
+    FFEEXPR_contextSTOP,
+    FFEEXPR_contextRETURN,
+    FFEEXPR_contextSFUNCDEF,
+    FFEEXPR_contextINCLUDE,
+    FFEEXPR_contextWHERE,
+    FFEEXPR_contextSELECTCASE,
+    FFEEXPR_contextCASE,
+    FFEEXPR_contextDIMLIST,
+    FFEEXPR_contextDIMLISTCOMMON,	/* Dim list in COMMON stmt. */
+    FFEEXPR_contextFILEASSOC,	/* ASSOCIATEVARIABLE=. */
+    FFEEXPR_contextFILEINT,	/* IOSTAT=. */
+    FFEEXPR_contextFILEDFINT,	/* NEXTREC=. */
+    FFEEXPR_contextFILELOG,	/* NAMED=. */
+    FFEEXPR_contextFILENUM,	/* Numerical expression. */
+    FFEEXPR_contextFILECHAR,	/* Character expression. */
+    FFEEXPR_contextFILENUMCHAR,	/* READ KEYxyz=. */
+    FFEEXPR_contextFILEDFCHAR,	/* Default kind character expression. */
+    FFEEXPR_contextFILEKEY,	/* OPEN KEY=. */
+    FFEEXPR_contextFILEEXTFUNC,	/* USEROPEN=. */
+    FFEEXPR_contextFILEUNIT,	/* READ/WRITE UNIT=. */
+    FFEEXPR_contextFILEUNIT_DF,	/* DEFINE FILE unit (no "(" after it). */
+    FFEEXPR_contextFILEFORMATNML,	/* [FMT=] or [NML=]. */
+    FFEEXPR_contextFILEFORMAT,	/* FMT=. */
+    FFEEXPR_contextFILENAMELIST,/* NML=. */
+    FFEEXPR_contextFILENUMAMBIG,/* BACKSPACE, ENDFILE, REWIND, UNLOCK...
+				   where at e.g. BACKSPACE(, if COMMA seen
+				   before ), it is ok. */
+    FFEEXPR_contextFILEUNITAMBIG,	/* READ(, if COMMA seen before ), ok. */
+    FFEEXPR_contextFILEVXTCODE,	/* ENCODE/DECODE third arg (scalar/array). */
+    FFEEXPR_contextALLOCATE,	/* ALLOCATE objects (weird). */
+    FFEEXPR_contextDEALLOCATE,	/* DEALLOCATE objects (weird). */
+    FFEEXPR_contextHEAPSTAT,	/* ALLOCATE/DEALLOCATE STAT= variable. */
+    FFEEXPR_contextKINDTYPE,	/* KIND=. */
+    FFEEXPR_contextINITVAL,	/* R426 =initialization-expr. */
+    FFEEXPR_contextNULLIFY,	/* Pointer names only (F90) or pointers. */
+    FFEEXPR_contextIOLISTDF,	/* IOLIST w/internal file (V112 9-14 30,31). */
+    FFEEXPR_contextINDEX_,	/* Element dimension or substring value. */
+    FFEEXPR_contextEQVINDEX_,	/* EQUIVALENCE element dimension. */
+    FFEEXPR_contextDATAIMPDOINDEX_,	/* INDEX in DATAIMPDO context. */
+    FFEEXPR_contextIMPDOITEM_,
+    FFEEXPR_contextIMPDOITEMDF_,/* to ...ITEM_ as IOLISTDF is to IOLIST. */
+    FFEEXPR_contextIMPDOCTRL_,
+    FFEEXPR_contextDATAIMPDOITEM_,
+    FFEEXPR_contextDATAIMPDOCTRL_,
+    FFEEXPR_contextLOC_,
+    FFEEXPR_contextACTUALARG_,	/* Actual arg to function or subroutine;
+				   turns into ACTUALARGEXPR_ if tokens not
+				   NAME (CLOSE_PAREN/COMMA) or PERCENT.... */
+    FFEEXPR_contextACTUALARGEXPR_,	/* Like LET but disallow CHAR*(*)
+					   concats. */
+    FFEEXPR_contextINDEXORACTUALARG_,	/* "CHARACTER FOO; PRINT *,FOO(?". */
+    FFEEXPR_contextINDEXORACTUALARGEXPR_,	/* ? not NAME
+						   (CLOSE_PAREN/COMMA). */
+    FFEEXPR_contextSFUNCDEFINDEX_,	/* INDEX_ within stmt-func def. */
+    FFEEXPR_contextSFUNCDEFACTUALARG_,
+    FFEEXPR_contextSFUNCDEFACTUALARGEXPR_,
+    FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_,
+    FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_,
+    FFEEXPR_contextPAREN_,	/* Rhs paren except in LET context. */
+    FFEEXPR_contextPARENFILENUM_,	/* Either PAREN or FILENUM context. */
+    FFEEXPR_contextPARENFILEUNIT_,	/* Either PAREN or FILEUNIT context. */
+    FFEEXPR_context
+  } ffeexprContext;
+
+/* Typedefs. */
+
+
+/* Include files needed by this one. */
+
+#include "bld.h"
+#include "lex.h"
+#include "malloc.h"
+
+/* Structure definitions. */
+
+typedef ffelexHandler (*ffeexprCallback) (ffelexToken ft, ffebld expr,
+					  ffelexToken t);
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+ffebld ffeexpr_collapse_convert (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_paren (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_uplus (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_uminus (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_not (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_add (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_subtract (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_multiply (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_divide (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_power (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_lt (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_le (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_eq (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_ne (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_gt (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_ge (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_and (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_or (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_xor (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_eqv (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_neqv (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_symter (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_funcref (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t);
+ffebld ffeexpr_collapse_substr (ffebld expr, ffelexToken t);
+ffebld ffeexpr_convert (ffebld source, ffelexToken source_token,
+	    ffelexToken dest_token, ffeinfoBasictype bt, ffeinfoKindtype kt,
+			ffeinfoRank rk, ffetargetCharacterSize sz,
+			ffeexprContext context);
+ffebld ffeexpr_convert_expr (ffebld source, ffelexToken source_token,
+			     ffebld dest, ffelexToken dest_token,
+			     ffeexprContext context);
+ffebld ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
+			       ffesymbol dest, ffelexToken dest_token);
+void ffeexpr_init_2 (void);
+ffelexHandler ffeexpr_rhs (mallocPool pool, ffeexprContext context,
+			   ffeexprCallback callback);
+ffelexHandler ffeexpr_lhs (mallocPool pool, ffeexprContext context,
+			   ffeexprCallback callback);
+void ffeexpr_terminate_2 (void);
+void ffeexpr_type_combine (ffeinfoBasictype *nbt, ffeinfoKindtype *nkt,
+			   ffeinfoBasictype lbt, ffeinfoKindtype lkt,
+			   ffeinfoBasictype rbt, ffeinfoKindtype rkt,
+			   ffelexToken t);
+
+/* Define macros. */
+
+#define ffeexpr_init_0()
+#define ffeexpr_init_1()
+#define ffeexpr_init_3()
+#define ffeexpr_init_4()
+#define ffeexpr_terminate_0()
+#define ffeexpr_terminate_1()
+#define ffeexpr_terminate_3()
+#define ffeexpr_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_EXPR_H */

gcc/f/fini.c

@@ -0,0 +1,772 @@
+/* fini.c
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.  */
+
+#define USE_BCONFIG
+
+#include "proj.h"
+#include "malloc.h"
+
+#undef MAXNAMELEN
+#define MAXNAMELEN 100
+
+typedef struct _name_ *name;
+
+struct _name_
+  {
+    name next;
+    name previous;
+    name next_alpha;
+    name previous_alpha;
+    int namelen;
+    int kwlen;
+    char kwname[MAXNAMELEN];
+    char name_uc[MAXNAMELEN];
+    char name_lc[MAXNAMELEN];
+    char name_ic[MAXNAMELEN];
+  };
+
+struct _name_root_
+  {
+    name first;
+    name last;
+  };
+
+struct _name_alpha_
+  {
+    name ign1;
+    name ign2;
+    name first;
+    name last;
+  };
+
+static FILE *in;
+static FILE *out;
+static char prefix[32];
+static char postfix[32];
+static char storage[32];
+static const char *const xspaces[]
+=
+{
+  "",				/* 0 */
+  " ",				/* 1 */
+  "  ",				/* 2 */
+  "   ",			/* 3 */
+  "    ",			/* 4 */
+  "     ",			/* 5 */
+  "      ",			/* 6 */
+  "       ",			/* 7 */
+  "\t",				/* 8 */
+  "\t ",			/* 9 */
+  "\t  ",			/* 10 */
+  "\t   ",			/* 11 */
+  "\t    ",			/* 12 */
+  "\t     ",			/* 13 */
+  "\t      ",			/* 14 */
+  "\t       ",			/* 15 */
+  "\t\t",			/* 16 */
+  "\t\t ",			/* 17 */
+  "\t\t  ",			/* 18 */
+  "\t\t   ",			/* 19 */
+  "\t\t    ",			/* 20 */
+  "\t\t     ",			/* 21 */
+  "\t\t      ",			/* 22 */
+  "\t\t       ",		/* 23 */
+  "\t\t\t",			/* 24 */
+  "\t\t\t ",			/* 25 */
+  "\t\t\t  ",			/* 26 */
+  "\t\t\t   ",			/* 27 */
+  "\t\t\t    ",			/* 28 */
+  "\t\t\t     ",		/* 29 */
+  "\t\t\t      ",		/* 30 */
+  "\t\t\t       ",		/* 31 */
+  "\t\t\t\t",			/* 32 */
+  "\t\t\t\t ",			/* 33 */
+  "\t\t\t\t  ",			/* 34 */
+  "\t\t\t\t   ",		/* 35 */
+  "\t\t\t\t    ",		/* 36 */
+  "\t\t\t\t     ",		/* 37 */
+  "\t\t\t\t      ",		/* 38 */
+  "\t\t\t\t       ",		/* 39 */
+  "\t\t\t\t\t",			/* 40 */
+  "\t\t\t\t\t ",		/* 41 */
+  "\t\t\t\t\t  ",		/* 42 */
+  "\t\t\t\t\t   ",		/* 43 */
+  "\t\t\t\t\t    ",		/* 44 */
+  "\t\t\t\t\t     ",		/* 45 */
+  "\t\t\t\t\t      ",		/* 46 */
+  "\t\t\t\t\t       ",		/* 47 */
+  "\t\t\t\t\t\t",		/* 48 */
+  "\t\t\t\t\t\t ",		/* 49 */
+  "\t\t\t\t\t\t  ",		/* 50 */
+  "\t\t\t\t\t\t   ",		/* 51 */
+  "\t\t\t\t\t\t    ",		/* 52 */
+  "\t\t\t\t\t\t     ",		/* 53 */
+  "\t\t\t\t\t\t      ",		/* 54 */
+  "\t\t\t\t\t\t       ",	/* 55 */
+  "\t\t\t\t\t\t\t",		/* 56 */
+  "\t\t\t\t\t\t\t ",		/* 57 */
+  "\t\t\t\t\t\t\t  ",		/* 58 */
+  "\t\t\t\t\t\t\t   ",		/* 59 */
+  "\t\t\t\t\t\t\t    ",		/* 60 */
+  "\t\t\t\t\t\t\t     ",	/* 61 */
+  "\t\t\t\t\t\t\t      ",	/* 62 */
+  "\t\t\t\t\t\t\t       ",	/* 63 */
+  "\t\t\t\t\t\t\t\t",		/* 64 */
+  "\t\t\t\t\t\t\t\t ",		/* 65 */
+  "\t\t\t\t\t\t\t\t  ",		/* 66 */
+  "\t\t\t\t\t\t\t\t   ",	/* 67 */
+  "\t\t\t\t\t\t\t\t    ",	/* 68 */
+  "\t\t\t\t\t\t\t\t     ",	/* 69 */
+  "\t\t\t\t\t\t\t\t      ",	/* 70 */
+  "\t\t\t\t\t\t\t\t       ",	/* 71 */
+  "\t\t\t\t\t\t\t\t\t",		/* 72 */
+  "\t\t\t\t\t\t\t\t\t ",	/* 73 */
+  "\t\t\t\t\t\t\t\t\t  ",	/* 74 */
+  "\t\t\t\t\t\t\t\t\t   ",	/* 75 */
+  "\t\t\t\t\t\t\t\t\t    ",	/* 76 */
+  "\t\t\t\t\t\t\t\t\t     ",	/* 77 */
+  "\t\t\t\t\t\t\t\t\t      ",	/* 78 */
+  "\t\t\t\t\t\t\t\t\t       ",	/* 79 */
+  "\t\t\t\t\t\t\t\t\t\t",	/* 80 */
+  "\t\t\t\t\t\t\t\t\t\t ",	/* 81 */
+  "\t\t\t\t\t\t\t\t\t\t  ",	/* 82 */
+  "\t\t\t\t\t\t\t\t\t\t   ",	/* 83 */
+  "\t\t\t\t\t\t\t\t\t\t    ",	/* 84 */
+  "\t\t\t\t\t\t\t\t\t\t     ",	/* 85 */
+  "\t\t\t\t\t\t\t\t\t\t      ",	/* 86 */
+  "\t\t\t\t\t\t\t\t\t\t       ",/* 87 */
+  "\t\t\t\t\t\t\t\t\t\t\t",	/* 88 */
+  "\t\t\t\t\t\t\t\t\t\t\t ",	/* 89 */
+  "\t\t\t\t\t\t\t\t\t\t\t  ",	/* 90 */
+  "\t\t\t\t\t\t\t\t\t\t\t   ",	/* 91 */
+  "\t\t\t\t\t\t\t\t\t\t\t    ",	/* 92 */
+  "\t\t\t\t\t\t\t\t\t\t\t     ",/* 93 */
+  "\t\t\t\t\t\t\t\t\t\t\t      ",	/* 94 */
+  "\t\t\t\t\t\t\t\t\t\t\t       ",	/* 95 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t",	/* 96 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 97 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 98 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t   ",/* 99 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 100 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 101 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 102 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 103 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 104 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t ",/* 105 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 106 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 107 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 108 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 109 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 110 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 111 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 112 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 113 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 114 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 115 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 116 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 117 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 118 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 119 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 120 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 121 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 122 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 123 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 124 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 125 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 126 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 127 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 128 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 129 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 130 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 131 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 132 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 133 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 134 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 135 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 136 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 137 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 138 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 139 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 140 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 141 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 142 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 143 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 144 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 145 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 146 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 147 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 148 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 149 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 150 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 151 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t",	/* 152 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t ",	/* 153 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t  ",	/* 154 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t   ",	/* 155 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t    ",	/* 156 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t     ",	/* 157 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t      ",	/* 158 */
+  "\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t       ",	/* 159 */
+};
+
+void testname (bool nested, int indent, name first, name last);
+void testnames (bool nested, int indent, int len, name first, name last);
+
+int
+main (int argc, char **argv)
+{
+  char buf[MAXNAMELEN];
+  char last_buf[MAXNAMELEN];
+  char kwname[MAXNAMELEN];
+  char routine[32];
+  char type[32];
+  int i;
+  int count;
+  int len;
+  struct _name_root_ names[200];
+  struct _name_alpha_ names_alpha;
+  name n;
+  name newname;
+  char *input_name;
+  char *output_name;
+  char *include_name;
+  FILE *incl;
+  int fixlengths;
+  int total_length;
+  int do_name;			/* TRUE if token may be NAME. */
+  int do_names;			/* TRUE if token may be NAMES. */
+  int cc;
+  bool do_exit = FALSE;
+
+  last_buf[0] = '\0';
+  
+  for (i = 0; ((size_t) i) < ARRAY_SIZE (names); ++i)
+    {				/* Initialize length/name ordered list roots. */
+      names[i].first = (name) &names[i];
+      names[i].last = (name) &names[i];
+    }
+  names_alpha.first = (name) &names_alpha;	/* Initialize name order. */
+  names_alpha.last = (name) &names_alpha;
+
+  if (argc != 4)
+    {
+      fprintf (stderr, "Command form: fini input output-code output-include\n");
+      return (1);
+    }
+
+  input_name = argv[1];
+  output_name = argv[2];
+  include_name = argv[3];
+
+  in = fopen (input_name, "r");
+  if (in == NULL)
+    {
+      fprintf (stderr, "Cannot open \"%s\"\n", input_name);
+      return (1);
+    }
+  out = fopen (output_name, "w");
+  if (out == NULL)
+    {
+      fclose (in);
+      fprintf (stderr, "Cannot open \"%s\"\n", output_name);
+      return (1);
+    }
+  incl = fopen (include_name, "w");
+  if (incl == NULL)
+    {
+      fclose (in);
+      fprintf (stderr, "Cannot open \"%s\"\n", include_name);
+      return (1);
+    }
+
+  /* Get past the initial block-style comment (man, this parsing code is just
+     _so_ lame, but I'm too lazy to improve it).  */
+
+  for (;;)
+    {
+      cc = getc (in);
+      if (cc == '{')
+	{
+	  while (((cc = getc (in)) != '}') && (cc != EOF))
+	    ;
+	}
+      else if (cc != EOF)
+	{
+	  while (((cc = getc (in)) != EOF) && (! ISALNUM (cc)))
+	    ;
+	  ungetc (cc, in);
+	  break;
+	}
+      else
+	{
+	  assert ("EOF too soon!" == NULL);
+	  return (1);
+	}
+    }
+
+  fscanf (in, "%s %s %s %s %s %d %d", prefix, postfix, storage, type, routine,
+	  &do_name, &do_names);
+
+  if (storage[0] == '\0')
+    storage[1] = '\0';
+  else
+    /* Assume string is quoted somehow, replace ending quote with space. */
+    {
+      if (storage[2] == '\0')
+	storage[1] = '\0';
+      else
+	storage[strlen (storage) - 1] = ' ';
+    }
+
+  if (postfix[0] == '\0')
+    postfix[1] = '\0';
+  else				/* Assume string is quoted somehow, strip off
+				   ending quote. */
+    postfix[strlen (postfix) - 1] = '\0';
+
+  for (i = 1; storage[i] != '\0'; ++i)
+    storage[i - 1] = storage[i];
+  storage[i - 1] = '\0';
+
+  for (i = 1; postfix[i] != '\0'; ++i)
+    postfix[i - 1] = postfix[i];
+  postfix[i - 1] = '\0';
+
+  fixlengths = strlen (prefix) + strlen (postfix);
+
+  while (TRUE)
+    {
+      count = fscanf (in, "%s %s", buf, kwname);
+      if (count == EOF)
+	break;
+      len = strlen (buf);
+      if (len == 0)
+	continue;		/* Skip empty lines. */
+      if (buf[0] == ';')
+	continue;		/* Skip commented-out lines. */
+      for (i = strlen (buf) - 1; i > 0; --i)
+	cc = buf[i];
+
+      /* Make new name object to store name and its keyword. */
+
+      newname = xmalloc (sizeof (*newname));
+      newname->namelen = strlen (buf);
+      newname->kwlen = strlen (kwname);
+      total_length = newname->kwlen + fixlengths;
+      if (total_length >= 32)	/* Else resulting keyword name too long. */
+	{
+	  fprintf (stderr, "%s: %s%s%s is 31+%d chars long\n", input_name,
+		   prefix, kwname, postfix, total_length - 31);
+	  do_exit = TRUE;
+	}
+      strcpy (newname->kwname, kwname);
+      for (i = 0; i < newname->namelen; ++i)
+	{
+	  cc = buf[i];
+	  newname->name_uc[i] = TOUPPER (cc);
+	  newname->name_lc[i] = TOLOWER (cc);
+	  newname->name_ic[i] = cc;
+	}
+      newname->name_uc[i] = newname->name_lc[i] = newname->name_ic[i] = '\0';
+
+      /* Warn user if names aren't alphabetically ordered. */
+
+      if ((last_buf[0] != '\0')
+	  && (strcmp (last_buf, newname->name_uc) >= 0))
+	{
+	  fprintf (stderr, "%s: \"%s\" precedes \"%s\"\n", input_name,
+		   last_buf, newname->name_uc);
+	  do_exit = TRUE;
+	}
+      strcpy (last_buf, newname->name_uc);
+
+      /* Append name to end of alpha-sorted list (assumes names entered in
+	 alpha order wrt name, not kwname, even though kwname is output from
+	 this list). */
+
+      n = names_alpha.last;
+      newname->next_alpha = n->next_alpha;
+      newname->previous_alpha = n;
+      n->next_alpha->previous_alpha = newname;
+      n->next_alpha = newname;
+
+      /* Insert name in appropriate length/name ordered list. */
+
+      n = (name) &names[len];
+      while ((n->next != (name) &names[len])
+	     && (strcmp (buf, n->next->name_uc) > 0))
+	n = n->next;
+      if (strcmp (buf, n->next->name_uc) == 0)
+	{
+	  fprintf (stderr, "%s: extraneous \"%s\"\n", input_name, buf);
+	  do_exit = TRUE;
+	}
+      newname->next = n->next;
+      newname->previous = n;
+      n->next->previous = newname;
+      n->next = newname;
+    }
+
+#if 0
+  for (len = 0; len < ARRAY_SIZE (name); ++len)
+    {
+      if (names[len].first == (name) &names[len])
+	continue;
+      printf ("Length %d:\n", len);
+      for (n = names[len].first; n != (name) &names[len]; n = n->next)
+	printf ("    %s %s %s\n", n->name_uc, n->name_lc, n->name_ic);
+    }
+#endif
+
+  if (do_exit)
+    return (1);
+
+  /* First output the #include file. */
+
+  for (n = names_alpha.first; n != (name) &names_alpha; n = n->next_alpha)
+    {
+      fprintf (incl, "#define %sl%s%s %d\n", prefix, n->kwname, postfix,
+	       n->namelen);
+    }
+
+  fprintf (incl,
+	   "\
+\n\
+enum %s_\n\
+{\n\
+%sNone%s,\n\
+",
+	   type, prefix, postfix);
+
+  for (n = names_alpha.first; n != (name) &names_alpha; n = n->next_alpha)
+    {
+      fprintf (incl,
+	       "\
+%s%s%s,\n\
+",
+	       prefix, n->kwname, postfix);
+    }
+
+  fprintf (incl,
+	   "\
+%s%s\n\
+};\n\
+typedef enum %s_ %s;\n\
+",
+	   prefix, postfix, type, type);
+
+  /* Now output the C program. */
+
+  fprintf (out,
+	   "\
+%s%s\n\
+%s (ffelexToken t)\n\
+%c\n\
+  char *p;\n\
+  int c;\n\
+\n\
+  p = ffelex_token_text (t);\n\
+\n\
+",
+	   storage, type, routine, '{');
+
+  if (do_name)
+    {
+      if (do_names)
+	fprintf (out,
+		 "\
+  if (ffelex_token_type (t) == FFELEX_typeNAME)\n\
+    {\n\
+      switch (ffelex_token_length (t))\n\
+\t{\n\
+"
+	  );
+      else
+	fprintf (out,
+		 "\
+  assert (ffelex_token_type (t) == FFELEX_typeNAME);\n\
+\n\
+  switch (ffelex_token_length (t))\n\
+    {\n\
+"
+	  );
+
+/* Now output the length as a case, followed by the binary search within that length.  */
+
+      for (len = 0; ((size_t) len) < ARRAY_SIZE (names); ++len)
+	{
+	  if (names[len].first != (name) &names[len])
+	    {
+	      if (do_names)
+		fprintf (out,
+			 "\
+\tcase %d:\n\
+",
+			 len);
+	      else
+		fprintf (out,
+			 "\
+    case %d:\n\
+",
+			 len);
+	      testname (FALSE, do_names ? 10 : 6, names[len].first, names[len].last);
+	      if (do_names)
+		fprintf (out,
+			 "\
+\t  break;\n\
+"
+		  );
+	      else
+		fprintf (out,
+			 "\
+      break;\n\
+"
+		  );
+	    }
+	}
+
+      if (do_names)
+	fprintf (out,
+		 "\
+\t}\n\
+      return %sNone%s;\n\
+    }\n\
+\n\
+",
+		 prefix, postfix);
+      else
+	fprintf (out,
+		 "\
+    }\n\
+\n\
+  return %sNone%s;\n\
+}\n\
+",
+		 prefix, postfix);
+    }
+
+  if (do_names)
+    {
+      fputs ("\
+  assert (ffelex_token_type (t) == FFELEX_typeNAMES);\n\
+\n\
+  switch (ffelex_token_length (t))\n\
+    {\n\
+    default:\n\
+",
+	     out);
+
+      /* Find greatest non-empty length list. */
+
+      for (len = ARRAY_SIZE (names) - 1;
+	   names[len].first == (name) &names[len];
+	   --len)
+	;
+
+/* Now output the length as a case, followed by the binary search within that length. */
+
+      if (len > 0)
+	{
+	  for (; len != 0; --len)
+	    {
+	      fprintf (out,
+		       "\
+    case %d:\n\
+",
+		       len);
+	      if (names[len].first != (name) &names[len])
+		testnames (FALSE, 6, len, names[len].first, names[len].last);
+	    }
+	  if (names[1].first == (name) &names[1])
+	    fprintf (out,
+		     "\
+      ;\n\
+"
+	      );		/* Need empty statement after an empty case
+				   1:  */
+	}
+
+      fprintf (out,
+	       "\
+    }\n\
+\n\
+  return %sNone%s;\n\
+}\n\
+",
+	       prefix, postfix);
+    }
+
+  if (out != stdout)
+    fclose (out);
+  if (incl != stdout)
+    fclose (incl);
+  if (in != stdin)
+    fclose (in);
+  return (0);
+}
+
+void
+testname (bool nested, int indent, name first, name last)
+{
+  name n;
+  name nhalf;
+  int num;
+  int numhalf;
+
+  assert (!nested || indent >= 2);
+  assert (((size_t) indent) + 4 < ARRAY_SIZE (xspaces));
+
+  num = 0;
+  numhalf = 0;
+  for (n = first, nhalf = first; n != last->next; n = n->next)
+    {
+      if ((++num & 1) == 0)
+	{
+	  nhalf = nhalf->next;
+	  ++numhalf;
+	}
+    }
+
+  if (nested)
+    fprintf (out,
+	     "\
+%s{\n\
+",
+	     xspaces[indent - 2]);
+
+  fprintf (out,
+	   "\
+%sif ((c = ffesrc_strcmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\")) == 0)\n\
+%sreturn %s%s%s;\n\
+",
+	   xspaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic,
+	   xspaces[indent + 2], prefix, nhalf->kwname, postfix);
+
+  if (num != 1)
+    {
+      fprintf (out,
+	       "\
+%selse if (c < 0)\n\
+",
+	       xspaces[indent]);
+
+      if (numhalf == 0)
+	fprintf (out,
+		 "\
+%s;\n\
+",
+		 xspaces[indent + 2]);
+      else
+	testname (TRUE, indent + 4, first, nhalf->previous);
+
+      if (num - numhalf > 1)
+	{
+	  fprintf (out,
+		   "\
+%selse\n\
+",
+		   xspaces[indent]);
+
+	  testname (TRUE, indent + 4, nhalf->next, last);
+	}
+    }
+
+  if (nested)
+    fprintf (out,
+	     "\
+%s}\n\
+",
+	     xspaces[indent - 2]);
+}
+
+void
+testnames (bool nested, int indent, int len, name first, name last)
+{
+  name n;
+  name nhalf;
+  int num;
+  int numhalf;
+
+  assert (!nested || indent >= 2);
+  assert (((size_t) indent) + 4 < ARRAY_SIZE (xspaces));
+
+  num = 0;
+  numhalf = 0;
+  for (n = first, nhalf = first; n != last->next; n = n->next)
+    {
+      if ((++num & 1) == 0)
+	{
+	  nhalf = nhalf->next;
+	  ++numhalf;
+	}
+    }
+
+  if (nested)
+    fprintf (out,
+	     "\
+%s{\n\
+",
+	     xspaces[indent - 2]);
+
+  fprintf (out,
+	   "\
+%sif ((c = ffesrc_strncmp_2c (ffe_case_match (), p, \"%s\", \"%s\", \"%s\", %d)) == 0)\n\
+%sreturn %s%s%s;\n\
+",
+	   xspaces[indent], nhalf->name_uc, nhalf->name_lc, nhalf->name_ic,
+	   len, xspaces[indent + 2], prefix, nhalf->kwname, postfix);
+
+  if (num != 1)
+    {
+      fprintf (out,
+	       "\
+%selse if (c < 0)\n\
+",
+	       xspaces[indent]);
+
+      if (numhalf == 0)
+	fprintf (out,
+		 "\
+%s;\n\
+",
+		 xspaces[indent + 2]);
+      else
+	testnames (TRUE, indent + 4, len, first, nhalf->previous);
+
+      if (num - numhalf > 1)
+	{
+	  fprintf (out,
+		   "\
+%selse\n\
+",
+		   xspaces[indent]);
+
+	  testnames (TRUE, indent + 4, len, nhalf->next, last);
+	}
+    }
+
+  if (nested)
+    fprintf (out,
+	     "\
+%s}\n\
+",
+	     xspaces[indent - 2]);
+}

gcc/f/g77spec.c

@@ -0,0 +1,541 @@
+/* Specific flags and argument handling of the Fortran front-end.
+   Copyright (C) 1997, 1999, 2000, 2001, 2002, 2003, 2004
+   Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC 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.
+
+GCC 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 GCC; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330,
+Boston, MA 02111-1307, USA.  */
+
+/* This file contains a filter for the main `gcc' driver, which is
+   replicated for the `g77' driver by adding this filter.  The purpose
+   of this filter is to be basically identical to gcc (in that
+   it faithfully passes all of the original arguments to gcc) but,
+   unless explicitly overridden by the user in certain ways, ensure
+   that the needs of the language supported by this wrapper are met.
+
+   For GNU Fortran (g77), we do the following to the argument list
+   before passing it to `gcc':
+
+   1.  Make sure `-lg2c -lm' is at the end of the list.
+
+   2.  Make sure each time `-lg2c' or `-lm' is seen, it forms
+       part of the series `-lg2c -lm'.
+
+   #1 and #2 are not done if `-nostdlib' or any option that disables
+   the linking phase is present, or if `-xfoo' is in effect.  Note that
+   a lack of source files or -l options disables linking.
+
+   This program was originally made out of gcc/cp/g++spec.c, but the
+   way it builds the new argument list was rewritten so it is much
+   easier to maintain, improve the way it decides to add or not add
+   extra arguments, etc.  And several improvements were made in the
+   handling of arguments, primarily to make it more consistent with
+   `gcc' itself.  */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "tm.h"
+#include "gcc.h"
+#include "intl.h"
+
+#ifndef MATH_LIBRARY
+#define MATH_LIBRARY "-lm"
+#endif
+
+#ifndef FORTRAN_INIT
+#define FORTRAN_INIT "-lfrtbegin"
+#endif
+
+#ifndef FORTRAN_LIBRARY
+#define FORTRAN_LIBRARY "-lg2c"
+#endif
+
+/* Options this driver needs to recognize, not just know how to
+   skip over.  */
+typedef enum
+{
+  OPTION_b,			/* Aka --prefix. */
+  OPTION_B,			/* Aka --target. */
+  OPTION_c,			/* Aka --compile. */
+  OPTION_driver,		/* Wrapper-specific option. */
+  OPTION_E,			/* Aka --preprocess. */
+  OPTION_help,			/* --help. */
+  OPTION_i,			/* -imacros, -include, -include-*. */
+  OPTION_l,
+  OPTION_L,			/* Aka --library-directory. */
+  OPTION_M,			/* Aka --dependencies. */
+  OPTION_MM,			/* Aka --user-dependencies. */
+  OPTION_nostdlib,		/* Aka --no-standard-libraries, or
+				   -nodefaultlibs. */
+  OPTION_o,			/* Aka --output. */
+  OPTION_S,			/* Aka --assemble. */
+  OPTION_syntax_only,		/* -fsyntax-only. */
+  OPTION_v,			/* Aka --verbose. */
+  OPTION_version,		/* --version. */
+  OPTION_V,			/* Aka --use-version. */
+  OPTION_x,			/* Aka --language. */
+  OPTION_			/* Unrecognized or unimportant. */
+} Option;
+
+/* The original argument list and related info is copied here.  */
+static int g77_xargc;
+static const char *const *g77_xargv;
+static void lookup_option (Option *, int *, const char **, const char *);
+static void append_arg (const char *);
+
+/* The new argument list will be built here.  */
+static int g77_newargc;
+static const char **g77_newargv;
+
+#ifndef SWITCH_TAKES_ARG
+#define SWITCH_TAKES_ARG(CHAR) DEFAULT_SWITCH_TAKES_ARG(CHAR)
+#endif
+
+#ifndef WORD_SWITCH_TAKES_ARG
+#define WORD_SWITCH_TAKES_ARG(STR) DEFAULT_WORD_SWITCH_TAKES_ARG (STR)
+#endif
+
+/* Assumes text[0] == '-'.  Returns number of argv items that belong to
+   (and follow) this one, an option id for options important to the
+   caller, and a pointer to the first char of the arg, if embedded (else
+   returns NULL, meaning no arg or it's the next argv).
+
+   Note that this also assumes gcc.c's pass converting long options
+   to short ones, where available, has already been run.  */
+
+static void
+lookup_option (Option *xopt, int *xskip, const char **xarg, const char *text)
+{
+  Option opt = OPTION_;
+  int skip;
+  const char *arg = NULL;
+
+  if ((skip = SWITCH_TAKES_ARG (text[1])))
+    skip -= (text[2] != '\0');	/* See gcc.c. */
+
+  if (text[1] == 'B')
+    opt = OPTION_B, skip = (text[2] == '\0'), arg = text + 2;
+  else if (text[1] == 'b')
+    opt = OPTION_b, skip = (text[2] == '\0'), arg = text + 2;
+  else if ((text[1] == 'c') && (text[2] == '\0'))
+    opt = OPTION_c, skip = 0;
+  else if ((text[1] == 'E') && (text[2] == '\0'))
+    opt = OPTION_E, skip = 0;
+  else if (text[1] == 'i')
+    opt = OPTION_i, skip = 0;
+  else if (text[1] == 'l')
+    opt = OPTION_l;
+  else if (text[1] == 'L')
+    opt = OPTION_L, arg = text + 2;
+  else if (text[1] == 'o')
+    opt = OPTION_o;
+  else if ((text[1] == 'S') && (text[2] == '\0'))
+    opt = OPTION_S, skip = 0;
+  else if (text[1] == 'V')
+    opt = OPTION_V, skip = (text[2] == '\0');
+  else if ((text[1] == 'v') && (text[2] == '\0'))
+    opt = OPTION_v, skip = 0;
+  else if (text[1] == 'x')
+    opt = OPTION_x, arg = text + 2;
+  else
+    {
+      if ((skip = WORD_SWITCH_TAKES_ARG (text + 1)) != 0)  /* See gcc.c. */
+	;
+      else if (! strncmp (text, "-fdriver", 8))  /* Really --driver!! */
+	opt = OPTION_driver;	/* Never mind arg, this is unsupported. */
+      else if (! strcmp (text, "-fhelp"))  /* Really --help!! */
+	opt = OPTION_help;
+      else if (! strcmp (text, "-M"))
+	opt = OPTION_M;
+      else if (! strcmp (text, "-MM"))
+	opt = OPTION_MM;
+      else if (! strcmp (text, "-nostdlib")
+	       || ! strcmp (text, "-nodefaultlibs"))
+	opt = OPTION_nostdlib;
+      else if (! strcmp (text, "-fsyntax-only"))
+	opt = OPTION_syntax_only;
+      else if (! strcmp (text, "-dumpversion"))
+	opt = OPTION_version;
+      else if (! strcmp (text, "-fversion"))  /* Really --version!! */
+	opt = OPTION_version;
+      else if (! strcmp (text, "-Xlinker")
+	       || ! strcmp (text, "-specs"))
+	skip = 1;
+      else
+	skip = 0;
+    }
+
+  if (xopt != NULL)
+    *xopt = opt;
+  if (xskip != NULL)
+    *xskip = skip;
+  if (xarg != NULL)
+    {
+      if ((arg != NULL)
+	  && (arg[0] == '\0'))
+	*xarg = NULL;
+      else
+	*xarg = arg;
+    }
+}
+
+/* Append another argument to the list being built.  As long as it is
+   identical to the corresponding arg in the original list, just increment
+   the new arg count.  Otherwise allocate a new list, etc.  */
+
+static void
+append_arg (const char *arg)
+{
+  static int newargsize;
+
+#if 0
+  fprintf (stderr, "`%s'\n", arg);
+#endif
+
+  if (g77_newargv == g77_xargv
+      && g77_newargc < g77_xargc
+      && (arg == g77_xargv[g77_newargc]
+	  || ! strcmp (arg, g77_xargv[g77_newargc])))
+    {
+      ++g77_newargc;
+      return;			/* Nothing new here. */
+    }
+
+  if (g77_newargv == g77_xargv)
+    {				/* Make new arglist. */
+      int i;
+
+      newargsize = (g77_xargc << 2) + 20;	/* This should handle all. */
+      g77_newargv = xmalloc (newargsize * sizeof (char *));
+
+      /* Copy what has been done so far.  */
+      for (i = 0; i < g77_newargc; ++i)
+	g77_newargv[i] = g77_xargv[i];
+    }
+
+  if (g77_newargc == newargsize)
+    fatal ("overflowed output arg list for `%s'", arg);
+
+  g77_newargv[g77_newargc++] = arg;
+}
+
+void
+lang_specific_driver (int *in_argc, const char *const **in_argv,
+		      int *in_added_libraries ATTRIBUTE_UNUSED)
+{
+  int argc = *in_argc;
+  const char *const *argv = *in_argv;
+  int i;
+  int verbose = 0;
+  Option opt;
+  int skip;
+  const char *arg;
+
+  /* This will be NULL if we encounter a situation where we should not
+     link in libf2c.  */
+  const char *library = FORTRAN_LIBRARY;
+
+  /* 0 => -xnone in effect.
+     1 => -xfoo in effect.  */
+  int saw_speclang = 0;
+
+  /* 0 => initial/reset state
+     1 => last arg was -l<library>
+     2 => last two args were -l<library> -lm.  */
+  int saw_library = 0;
+
+  /* 0 => initial/reset state
+     1 => FORTRAN_INIT linked in */
+  int use_init = 0;
+  /* By default, we throw on the math library if we have one.  */
+  int need_math = (MATH_LIBRARY[0] != '\0');
+
+  /* The number of input and output files in the incoming arg list.  */
+  int n_infiles = 0;
+  int n_outfiles = 0;
+
+#if 0
+  fprintf (stderr, "Incoming:");
+  for (i = 0; i < argc; i++)
+    fprintf (stderr, " %s", argv[i]);
+  fprintf (stderr, "\n");
+#endif
+
+  g77_xargc = argc;
+  g77_xargv = argv;
+  g77_newargc = 0;
+  g77_newargv = (const char **) argv;
+
+  /* First pass through arglist.
+
+     If -nostdlib or a "turn-off-linking" option is anywhere in the
+     command line, don't do any library-option processing (except
+     relating to -x).  Also, if -v is specified, but no other options
+     that do anything special (allowing -V version, etc.), remember
+     to add special stuff to make gcc command actually invoke all
+     the different phases of the compilation process so all the version
+     numbers can be seen.
+
+     Also, here is where all problems with missing arguments to options
+     are caught.  If this loop is exited normally, it means all options
+     have the appropriate number of arguments as far as the rest of this
+     program is concerned.  */
+
+  for (i = 1; i < argc; ++i)
+    {
+      if ((argv[i][0] == '+') && (argv[i][1] == 'e'))
+	{
+	  continue;
+	}
+
+      if ((argv[i][0] != '-') || (argv[i][1] == '\0'))
+	{
+	  ++n_infiles;
+	  continue;
+	}
+
+      lookup_option (&opt, &skip, NULL, argv[i]);
+
+      switch (opt)
+	{
+	case OPTION_nostdlib:
+	case OPTION_c:
+	case OPTION_S:
+	case OPTION_syntax_only:
+	case OPTION_E:
+	case OPTION_M:
+	case OPTION_MM:
+	  /* These options disable linking entirely or linking of the
+	     standard libraries.  */
+	  library = 0;
+	  break;
+
+	case OPTION_l:
+	  ++n_infiles;
+	  break;
+
+	case OPTION_o:
+	  ++n_outfiles;
+	  break;
+
+	case OPTION_v:
+	  verbose = 1;
+	  break;
+
+	case OPTION_b:
+	case OPTION_B:
+	case OPTION_L:
+	case OPTION_i:
+	case OPTION_V:
+	  /* These options are useful in conjunction with -v to get
+	     appropriate version info.  */
+	  break;
+
+	case OPTION_version:
+	  printf ("GNU Fortran (GCC) %s\n", version_string);
+	  printf ("Copyright %s 2004 Free Software Foundation, Inc.\n",
+		  _("(C)"));
+	  printf ("\n");
+	  printf (_("\
+GNU Fortran comes with NO WARRANTY, to the extent permitted by law.\n\
+You may redistribute copies of GNU Fortran\n\
+under the terms of the GNU General Public License.\n\
+For more information about these matters, see the file named COPYING\n\
+or type the command `info -f g77 Copying'.\n\
+"));
+	  exit (0);
+	  break;
+
+	case OPTION_help:
+	  /* Let gcc.c handle this, as it has a really
+	     cool facility for handling --help and --verbose --help.  */
+	  return;
+
+	case OPTION_driver:
+	  fatal ("--driver no longer supported");
+	  break;
+
+	default:
+	  break;
+	}
+
+      /* This is the one place we check for missing arguments in the
+	 program.  */
+
+      if (i + skip < argc)
+	i += skip;
+      else
+	fatal ("argument to `%s' missing", argv[i]);
+    }
+
+  if ((n_outfiles != 0) && (n_infiles == 0))
+    fatal ("no input files; unwilling to write output files");
+
+  /* If there are no input files, no need for the library.  */
+  if (n_infiles == 0)
+    library = 0;
+
+  /* Second pass through arglist, transforming arguments as appropriate.  */
+
+  append_arg (argv[0]);	/* Start with command name, of course. */
+
+  for (i = 1; i < argc; ++i)
+    {
+      if (argv[i][0] == '\0')
+	{
+	  append_arg (argv[i]);	/* Interesting.  Just append as is. */
+	  continue;
+	}
+
+      if ((argv[i][0] == '-') && (argv[i][1] != 'l'))
+	{
+	  /* Not a filename or library. */
+
+	 if (saw_library == 1 && need_math)    /* -l<library>. */
+	    append_arg (MATH_LIBRARY);
+
+	  saw_library = 0;
+
+	  lookup_option (&opt, &skip, &arg, argv[i]);
+
+	  if (argv[i][1] == '\0')
+	    {
+	      append_arg (argv[i]);	/* "-" == Standard input. */
+	      continue;
+	    }
+
+	  if (opt == OPTION_x)
+	    {
+	      /* Track input language. */
+	      const char *lang;
+
+	      if (arg == NULL)
+		lang = argv[i+1];
+	      else
+		lang = arg;
+
+	      saw_speclang = (strcmp (lang, "none") != 0);
+	    }
+
+	  append_arg (argv[i]);
+
+	  for (; skip != 0; --skip)
+	    append_arg (argv[++i]);
+
+	  continue;
+	}
+
+      /* A filename/library, not an option. */
+
+      if (saw_speclang)
+	saw_library = 0;	/* -xfoo currently active. */
+      else
+	{			/* -lfoo or filename. */
+	  if (strcmp (argv[i], MATH_LIBRARY) == 0)
+	    {
+	      if (saw_library == 1)
+		saw_library = 2;	/* -l<library> -lm. */
+	      else
+		{
+		  if (0 == use_init)
+		    {
+		      append_arg (FORTRAN_INIT);
+		      use_init = 1;
+		    }
+		  append_arg (FORTRAN_LIBRARY);
+		}
+	    }
+	  else if (strcmp (argv[i], FORTRAN_LIBRARY) == 0)
+	    saw_library = 1;	/* -l<library>. */
+	  else
+	    {		/* Other library, or filename. */
+	     if (saw_library == 1 && need_math)
+		append_arg (MATH_LIBRARY);
+	      saw_library = 0;
+	    }
+	}
+      append_arg (argv[i]);
+    }
+
+  /* Append `-lg2c -lm' as necessary.  */
+
+  if (library)
+    {				/* Doing a link and no -nostdlib. */
+      if (saw_speclang)
+	append_arg ("-xnone");
+
+      switch (saw_library)
+	{
+	case 0:
+	  if (0 == use_init)
+	    {
+	      append_arg (FORTRAN_INIT);
+	      use_init = 1;
+	    }
+	  append_arg (library);
+	case 1:
+	 if (need_math)
+	   append_arg (MATH_LIBRARY);
+	default:
+	  break;
+	}
+    }
+
+#ifdef ENABLE_SHARED_LIBGCC
+  if (library)
+    {
+      int i;
+
+      for (i = 1; i < g77_newargc; i++)
+	if (g77_newargv[i][0] == '-')
+	  if (strcmp (g77_newargv[i], "-static-libgcc") == 0
+	      || strcmp (g77_newargv[i], "-static") == 0)
+	    break;
+    
+      if (i == g77_newargc)
+	append_arg ("-shared-libgcc");
+    }
+  
+#endif
+
+  if (verbose
+      && g77_newargv != g77_xargv)
+    {
+      fprintf (stderr, "Driving:");
+      for (i = 0; i < g77_newargc; i++)
+	fprintf (stderr, " %s", g77_newargv[i]);
+      fprintf (stderr, "\n");
+    }
+
+  *in_argc = g77_newargc;
+  *in_argv = g77_newargv;
+}
+
+/* Called before linking.  Returns 0 on success and -1 on failure. */
+int lang_specific_pre_link (void)  /* Not used for F77. */
+{
+  return 0;
+}
+
+/* Number of extra output files that lang_specific_pre_link may generate. */
+int lang_specific_extra_outfiles = 0;  /* Not used for F77. */
+
+/* Table of language-specific spec functions.  */ 
+const struct spec_function lang_specific_spec_functions[] =
+{
+  { 0, 0 }
+};

gcc/f/global.h

@@ -0,0 +1,193 @@
+/* global.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 1997, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      global.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_GLOBAL_H
+#define GCC_F_GLOBAL_H
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+    FFEGLOBAL_typeNONE,
+    FFEGLOBAL_typeMAIN,
+    FFEGLOBAL_typeEXT,		/* EXTERNAL is all we know. */
+    FFEGLOBAL_typeSUBR,
+    FFEGLOBAL_typeFUNC,
+    FFEGLOBAL_typeBDATA,
+    FFEGLOBAL_typeCOMMON,
+    FFEGLOBAL_typeANY,		/* Confusion reigns, so just ignore. */
+    FFEGLOBAL_type
+  } ffeglobalType;
+
+typedef enum
+  {
+    FFEGLOBAL_argsummaryNONE,	/* No arg present. */
+    FFEGLOBAL_argsummaryVAL,	/* Pass-by-value. */
+    FFEGLOBAL_argsummaryREF,	/* Pass-by-reference. */
+    FFEGLOBAL_argsummaryDESCR,	/* Pass-by-descriptor. */
+    FFEGLOBAL_argsummaryPROC,	/* Procedure (intrinsic, external). */
+    FFEGLOBAL_argsummarySUBR,	/* Subroutine (intrinsic, external). */
+    FFEGLOBAL_argsummaryFUNC,	/* Function (intrinsic, external). */
+    FFEGLOBAL_argsummaryALTRTN,	/* Alternate-return (label). */
+    FFEGLOBAL_argsummaryANY,
+    FFEGLOBAL_argsummary
+  } ffeglobalArgSummary;
+
+/* Typedefs. */
+
+typedef struct _ffeglobal_arginfo_ *ffeglobalArgInfo_;
+typedef struct _ffeglobal_ *ffeglobal;
+
+/* Include files needed by this one. */
+
+#include "info.h"
+#include "lex.h"
+#include "name.h"
+#include "symbol.h"
+#include "target.h"
+#include "top.h"
+
+/* Structure definitions. */
+
+struct _ffeglobal_arginfo_
+{
+  ffelexToken t;	/* Different from master token when difference is important. */
+  char *name;		/* Name of dummy arg, or NULL if not yet known. */
+  ffeglobalArgSummary as;
+  ffeinfoBasictype bt;
+  ffeinfoKindtype kt;
+  bool array;
+};
+
+struct _ffeglobal_
+{
+  ffelexToken t;
+  ffename n;
+  ffecomGlobal hook;
+  ffeCounter tick;		/* Recent transition in this progunit. */
+  ffeglobalType type;
+  bool intrinsic;		/* Known as intrinsic? */
+  bool explicit_intrinsic;	/* Explicit intrinsic? */
+  union {
+    struct {
+      ffelexToken initt;	/* First initial value. */
+      bool have_pad;		/* Padding info avail for COMMON? */
+      ffetargetAlign pad;	/* Initial padding for COMMON. */
+      ffewhereLine pad_where_line;
+      ffewhereColumn pad_where_col;
+      bool have_save;		/* Save info avail for COMMON? */
+      bool save;		/* Save info for COMMON. */
+      ffewhereLine save_where_line;
+      ffewhereColumn save_where_col;
+      bool have_size;		/* Size info avail for COMMON? */
+      ffetargetOffset size;	/* Size info for COMMON. */
+      bool blank;		/* TRUE if blank COMMON. */
+    } common;
+    struct {
+      bool defined;		/* Seen actual code yet? */
+      ffeinfoBasictype bt;	/* NONE for non-function. */
+      ffeinfoKindtype kt;	/* NONE for non-function. */
+      ffetargetCharacterSize sz;
+      int n_args;		/* 0 for main/blockdata. */
+      ffelexToken other_t;	/* Location of reference. */
+      ffeglobalArgInfo_ arg_info;	/* Info on each argument. */
+    } proc;
+  } u;
+};
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+void ffeglobal_drive (ffeglobal (*fn) (ffeglobal));
+void ffeglobal_init_1 (void);
+void ffeglobal_init_common (ffesymbol s, ffelexToken t);
+void ffeglobal_new_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type);
+void ffeglobal_new_common (ffesymbol s, ffelexToken t, bool blank);
+void ffeglobal_pad_common (ffesymbol s, ffetargetAlign pad, ffewhereLine wl,
+			   ffewhereColumn wc);
+void ffeglobal_proc_def_arg (ffesymbol s, int argno, const char *name, ffeglobalArgSummary as,
+			     ffeinfoBasictype bt, ffeinfoKindtype kt,
+			     bool array);
+void ffeglobal_proc_def_nargs (ffesymbol s, int n_args);
+bool ffeglobal_proc_ref_arg (ffesymbol s, int argno, ffeglobalArgSummary as,
+			     ffeinfoBasictype bt, ffeinfoKindtype kt,
+			     bool array, ffelexToken t);
+bool ffeglobal_proc_ref_nargs (ffesymbol s, int n_args, ffelexToken t);
+ffeglobal ffeglobal_promoted (ffesymbol s);
+void ffeglobal_ref_intrinsic (ffesymbol s, ffelexToken t, bool explicit);
+bool ffeglobal_ref_progunit_ (ffesymbol s, ffelexToken t, ffeglobalType type);
+void ffeglobal_save_common (ffesymbol s, bool save, ffewhereLine wl,
+			    ffewhereColumn wc);
+bool ffeglobal_size_common (ffesymbol s, ffetargetOffset size);
+void ffeglobal_terminate_1 (void);
+
+/* Define macros. */
+
+#define FFEGLOBAL_ENABLED 1
+
+#define ffeglobal_common_init(g) ((g)->tick != 0)
+#define ffeglobal_common_have_pad(g) ((g)->u.common.have_pad)
+#define ffeglobal_common_have_size(g) ((g)->u.common.have_size)
+#define ffeglobal_common_pad(g) ((g)->u.common.pad)
+#define ffeglobal_common_size(g) ((g)->u.common.size)
+#define ffeglobal_hook(g) ((g)->hook)
+#define ffeglobal_init_0()
+#define ffeglobal_init_2()
+#define ffeglobal_init_3()
+#define ffeglobal_init_4()
+#define ffeglobal_new_blockdata(s,t) \
+      ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeBDATA)
+#define ffeglobal_new_function(s,t) \
+      ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeFUNC)
+#define ffeglobal_new_program(s,t) \
+      ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeMAIN)
+#define ffeglobal_new_subroutine(s,t) \
+      ffeglobal_new_progunit_(s,t,FFEGLOBAL_typeSUBR)
+#define ffeglobal_ref_blockdata(s,t) \
+      ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeBDATA)
+#define ffeglobal_ref_external(s,t) \
+      ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeEXT)
+#define ffeglobal_ref_function(s,t) \
+      ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeFUNC)
+#define ffeglobal_ref_subroutine(s,t) \
+      ffeglobal_ref_progunit_(s,t,FFEGLOBAL_typeSUBR)
+#define ffeglobal_set_hook(g,h) ((g)->hook = (h))
+#define ffeglobal_terminate_0()
+#define ffeglobal_terminate_2()
+#define ffeglobal_terminate_3()
+#define ffeglobal_terminate_4()
+#define ffeglobal_text(g) ffename_text((g)->n)
+#define ffeglobal_type(g) ((g)->type)
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_GLOBAL_H */
+

gcc/f/implic.c

@@ -0,0 +1,383 @@
+/* implic.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Related Modules:
+      None.
+
+   Description:
+      The GNU Fortran Front End.
+
+   Modifications:
+*/
+
+/* Include files. */
+
+#include "proj.h"
+#include "implic.h"
+#include "info.h"
+#include "src.h"
+#include "symbol.h"
+#include "target.h"
+
+/* Externals defined here. */
+
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+    FFEIMPLIC_stateINITIAL_,
+    FFEIMPLIC_stateASSUMED_,
+    FFEIMPLIC_stateESTABLISHED_,
+    FFEIMPLIC_state
+  } ffeimplicState_;
+
+/* Internal typedefs. */
+
+typedef struct _ffeimplic_ *ffeimplic_;
+
+/* Private include files. */
+
+
+/* Internal structure definitions. */
+
+struct _ffeimplic_
+  {
+    ffeimplicState_ state;
+    ffeinfo info;
+  };
+
+/* Static objects accessed by functions in this module. */
+
+/* NOTE: This is definitely ASCII-specific!!  */
+
+static struct _ffeimplic_ ffeimplic_table_['z' - 'A' + 1];
+
+/* Static functions (internal). */
+
+static ffeimplic_ ffeimplic_lookup_ (unsigned char c);
+
+/* Internal macros. */
+
+
+/* ffeimplic_lookup_ -- Look up implicit descriptor for initial character
+
+   ffeimplic_ imp;
+   if ((imp = ffeimplic_lookup_('A')) == NULL)
+       // error
+
+   Returns a pointer to an implicit descriptor block based on the character
+   passed, or NULL if it is not a valid initial character for an implicit
+   data type.  */
+
+static ffeimplic_
+ffeimplic_lookup_ (unsigned char c)
+{
+  /* NOTE: This is definitely ASCII-specific!!  */
+  if (ISIDST (c))
+    return &ffeimplic_table_[c - 'A'];
+  return NULL;
+}
+
+/* ffeimplic_establish_initial -- Establish type of implicit initial letter
+
+   ffesymbol s;
+   if (!ffeimplic_establish_initial(s))
+       // error
+
+   Assigns implicit type information to the symbol based on the first
+   character of the symbol's name.  */
+
+bool
+ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
+		     ffeinfoKindtype kind_type, ffetargetCharacterSize size)
+{
+  ffeimplic_ imp;
+
+  imp = ffeimplic_lookup_ (c);
+  if (imp == NULL)
+    return FALSE;		/* Character not A-Z or some such thing. */
+  if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
+    return FALSE;		/* IMPLICIT NONE in effect here. */
+
+  switch (imp->state)
+    {
+    case FFEIMPLIC_stateINITIAL_:
+      imp->info = ffeinfo_new (basic_type,
+			       kind_type,
+			       0,
+			       FFEINFO_kindNONE,
+			       FFEINFO_whereNONE,
+			       size);
+      imp->state = FFEIMPLIC_stateESTABLISHED_;
+      return TRUE;
+
+    case FFEIMPLIC_stateASSUMED_:
+      if ((ffeinfo_basictype (imp->info) != basic_type)
+	  || (ffeinfo_kindtype (imp->info) != kind_type)
+	  || (ffeinfo_size (imp->info) != size))
+	return FALSE;
+      imp->state = FFEIMPLIC_stateESTABLISHED_;
+      return TRUE;
+
+    case FFEIMPLIC_stateESTABLISHED_:
+      return FALSE;
+
+    default:
+      assert ("Weird state for implicit object" == NULL);
+      return FALSE;
+    }
+}
+
+/* ffeimplic_establish_symbol -- Establish implicit type of a symbol
+
+   ffesymbol s;
+   if (!ffeimplic_establish_symbol(s))
+       // error
+
+   Assigns implicit type information to the symbol based on the first
+   character of the symbol's name.
+
+   If symbol already has a type, return TRUE.
+   Get first character of symbol's name.
+   Get ffeimplic_ object for it (return FALSE if NULL returned).
+   Return FALSE if object has no assigned type (IMPLICIT NONE).
+   Copy the type information from the object to the symbol.
+   If the object is state "INITIAL", set to state "ASSUMED" so no
+       subsequent IMPLICIT statement may change the state.
+   Return TRUE.	 */
+
+bool
+ffeimplic_establish_symbol (ffesymbol s)
+{
+  char c;
+  ffeimplic_ imp;
+
+  if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
+    return TRUE;
+
+  c = *(ffesymbol_text (s));
+  imp = ffeimplic_lookup_ (c);
+  if (imp == NULL)
+    return FALSE;		/* First character not A-Z or some such
+				   thing. */
+  if (ffeinfo_basictype (imp->info) == FFEINFO_basictypeNONE)
+    return FALSE;		/* IMPLICIT NONE in effect here. */
+
+  ffesymbol_signal_change (s);	/* Gonna change, save existing? */
+
+  /* Establish basictype, kindtype, size; preserve rank, kind, where. */
+
+  ffesymbol_set_info (s,
+		      ffeinfo_new (ffeinfo_basictype (imp->info),
+				   ffeinfo_kindtype (imp->info),
+				   ffesymbol_rank (s),
+				   ffesymbol_kind (s),
+				   ffesymbol_where (s),
+				   ffeinfo_size (imp->info)));
+
+  if (imp->state == FFEIMPLIC_stateINITIAL_)
+    imp->state = FFEIMPLIC_stateASSUMED_;
+
+  if (ffe_is_warn_implicit ())
+    {
+      /* xgettext:no-c-format */
+      ffebad_start_msg ("Implicit declaration of `%A' at %0",
+			FFEBAD_severityWARNING);
+      ffebad_here (0, ffesymbol_where_line (s),
+		   ffesymbol_where_column (s));
+      ffebad_string (ffesymbol_text (s));
+      ffebad_finish ();
+    }
+
+  return TRUE;
+}
+
+/* ffeimplic_init_2 -- Initialize table
+
+   ffeimplic_init_2();
+
+   Assigns initial type information to all initial letters.
+
+   Allows for holes in the sequence of letters (i.e. EBCDIC).  */
+
+void
+ffeimplic_init_2 (void)
+{
+  ffeimplic_ imp;
+  char c;
+
+  for (c = 'A'; c <= 'z'; ++c)
+    {
+      imp = &ffeimplic_table_[c - 'A'];
+      imp->state = FFEIMPLIC_stateINITIAL_;
+      switch (c)
+	{
+	case 'A':
+	case 'B':
+	case 'C':
+	case 'D':
+	case 'E':
+	case 'F':
+	case 'G':
+	case 'H':
+	case 'O':
+	case 'P':
+	case 'Q':
+	case 'R':
+	case 'S':
+	case 'T':
+	case 'U':
+	case 'V':
+	case 'W':
+	case 'X':
+	case 'Y':
+	case 'Z':
+	case '_':
+	case 'a':
+	case 'b':
+	case 'c':
+	case 'd':
+	case 'e':
+	case 'f':
+	case 'g':
+	case 'h':
+	case 'o':
+	case 'p':
+	case 'q':
+	case 'r':
+	case 's':
+	case 't':
+	case 'u':
+	case 'v':
+	case 'w':
+	case 'x':
+	case 'y':
+	case 'z':
+	  imp->info = ffeinfo_new (FFEINFO_basictypeREAL,
+				   FFEINFO_kindtypeREALDEFAULT,
+				   0,
+				   FFEINFO_kindNONE,
+				   FFEINFO_whereNONE,
+				   FFETARGET_charactersizeNONE);
+	  break;
+
+	case 'I':
+	case 'J':
+	case 'K':
+	case 'L':
+	case 'M':
+	case 'N':
+	case 'i':
+	case 'j':
+	case 'k':
+	case 'l':
+	case 'm':
+	case 'n':
+	  imp->info = ffeinfo_new (FFEINFO_basictypeINTEGER,
+				   FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindNONE, FFEINFO_whereNONE,
+				   FFETARGET_charactersizeNONE);
+	  break;
+
+	default:
+	  imp->info = ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0,
+	  FFEINFO_kindNONE, FFEINFO_whereNONE, FFETARGET_charactersizeNONE);
+	  break;
+	}
+    }
+}
+
+/* ffeimplic_none -- Implement IMPLICIT NONE statement
+
+   ffeimplic_none();
+
+   Assigns null type information to all initial letters.  */
+
+void
+ffeimplic_none (void)
+{
+  ffeimplic_ imp;
+
+  for (imp = &ffeimplic_table_[0];
+       imp != &ffeimplic_table_[ARRAY_SIZE (ffeimplic_table_)];
+       imp++)
+    {
+      imp->info = ffeinfo_new (FFEINFO_basictypeNONE,
+			       FFEINFO_kindtypeNONE,
+			       0,
+			       FFEINFO_kindNONE,
+			       FFEINFO_whereNONE,
+			       FFETARGET_charactersizeNONE);
+    }
+}
+
+/* ffeimplic_peek_symbol_type -- Determine implicit type of a symbol
+
+   ffesymbol s;
+   const char *name; // name for s in case it is NULL, or NULL if s never NULL
+   if (ffeimplic_peek_symbol_type(s,name) == FFEINFO_basictypeCHARACTER)
+       // is or will be a CHARACTER-typed name
+
+   Like establish_symbol, but doesn't change anything.
+
+   If symbol is non-NULL and already has a type, return it.
+   Get first character of symbol's name or from name arg if symbol is NULL.
+   Get ffeimplic_ object for it (return FALSE if NULL returned).
+   Return NONE if object has no assigned type (IMPLICIT NONE).
+   Return the data type indicated in the object.
+
+   24-Oct-91  JCB  2.0
+      Take a char * instead of ffelexToken, since the latter isn't always
+      needed anyway (as when ffecom calls it).	*/
+
+ffeinfoBasictype
+ffeimplic_peek_symbol_type (ffesymbol s, const char *name)
+{
+  char c;
+  ffeimplic_ imp;
+
+  if (s == NULL)
+    c = *name;
+  else
+    {
+      if (ffesymbol_basictype (s) != FFEINFO_basictypeNONE)
+	return ffesymbol_basictype (s);
+
+      c = *(ffesymbol_text (s));
+    }
+
+  imp = ffeimplic_lookup_ (c);
+  if (imp == NULL)
+    return FFEINFO_basictypeNONE;	/* First character not A-Z or
+					   something. */
+  return ffeinfo_basictype (imp->info);
+}
+
+/* ffeimplic_terminate_2 -- Terminate table
+
+   ffeimplic_terminate_2();
+
+   Kills info object for each entry in table.  */
+
+void
+ffeimplic_terminate_2 (void)
+{
+}

gcc/f/implic.h

@@ -0,0 +1,74 @@
+/* implic.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      implic.c
+
+   Modifications:
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_IMPLIC_H
+#define GCC_F_IMPLIC_H
+
+/* Simple definitions and enumerations. */
+
+
+/* Typedefs. */
+
+
+/* Include files needed by this one. */
+
+#include "info.h"
+#include "symbol.h"
+#include "target.h"
+
+/* Structure definitions. */
+
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+bool ffeimplic_establish_initial (char c, ffeinfoBasictype basic_type,
+		    ffeinfoKindtype kind_type, ffetargetCharacterSize size);
+bool ffeimplic_establish_symbol (ffesymbol s);
+void ffeimplic_init_2 (void);
+void ffeimplic_none (void);
+ffeinfoBasictype ffeimplic_peek_symbol_type (ffesymbol s, const char *name);
+void ffeimplic_terminate_2 (void);
+
+/* Define macros. */
+
+#define ffeimplic_init_0()
+#define ffeimplic_init_1()
+#define ffeimplic_init_3()
+#define ffeimplic_init_4()
+#define ffeimplic_terminate_0()
+#define ffeimplic_terminate_1()
+#define ffeimplic_terminate_3()
+#define ffeimplic_terminate_4()
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_IMPLIC_H */

gcc/f/info-b.def

@@ -0,0 +1,36 @@
+/* info-b.def -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      info.c
+
+   Modifications:
+*/
+
+FFEINFO_BASICTYPE (FFEINFO_basictypeNONE, "None", "")
+FFEINFO_BASICTYPE (FFEINFO_basictypeINTEGER, "INTEGER", "i")
+FFEINFO_BASICTYPE (FFEINFO_basictypeLOGICAL, "LOGICAL", "l")
+FFEINFO_BASICTYPE (FFEINFO_basictypeREAL, "REAL", "r")
+FFEINFO_BASICTYPE (FFEINFO_basictypeCOMPLEX, "COMPLEX", "c")
+FFEINFO_BASICTYPE (FFEINFO_basictypeCHARACTER, "CHARACTER", "a")
+FFEINFO_BASICTYPE (FFEINFO_basictypeHOLLERITH, "Hollerith", "h")
+FFEINFO_BASICTYPE (FFEINFO_basictypeTYPELESS, "Typeless", "t")
+FFEINFO_BASICTYPE (FFEINFO_basictypeANY, "Any", "~")

gcc/f/info-k.def

@@ -0,0 +1,41 @@
+/* info-k.def -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 2002 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      info.c
+
+   Modifications:
+*/
+
+#
+/* Kind messages are used in diagnostic location reports of the
+   form "<file>: In function `foo': <error message>". */
+
+FFEINFO_KIND (FFEINFO_kindNONE, "In unknown kind", "")
+FFEINFO_KIND (FFEINFO_kindENTITY, "In entity", "e")
+FFEINFO_KIND (FFEINFO_kindFUNCTION, "In function", "f")
+FFEINFO_KIND (FFEINFO_kindSUBROUTINE, "In subroutine", "u")
+FFEINFO_KIND (FFEINFO_kindPROGRAM, "In program", "p")
+FFEINFO_KIND (FFEINFO_kindBLOCKDATA, "In block-data unit", "b")
+FFEINFO_KIND (FFEINFO_kindCOMMON, "In common block", "c")
+FFEINFO_KIND (FFEINFO_kindCONSTRUCT, "In construct", ":")
+FFEINFO_KIND (FFEINFO_kindNAMELIST, "In namelist", "n")
+FFEINFO_KIND (FFEINFO_kindANY, "In anything", "~")

gcc/f/info-w.def

@@ -0,0 +1,41 @@
+/* info-w.def -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      info.c
+
+   Modifications:
+*/
+
+FFEINFO_WHERE (FFEINFO_whereNONE, "None", "")
+FFEINFO_WHERE (FFEINFO_whereLOCAL, "Local", "l")	/* Defined locally. */
+FFEINFO_WHERE (FFEINFO_whereCOMMON, "Common", "c")	/* In a common area. */
+FFEINFO_WHERE (FFEINFO_whereDUMMY, "Dummy", "d")	/* A dummy argument. */
+FFEINFO_WHERE (FFEINFO_whereGLOBAL, "Global", "g")	/* Reference to external global like FUNCTION, SUBR. */
+FFEINFO_WHERE (FFEINFO_whereRESULT, "Result", "r")	/* Result of this function. */
+FFEINFO_WHERE (FFEINFO_whereFLEETING, "Fleeting", "f")		/* Result of "X*Y", "FUNCREF(5,1.3)", "ARRAY(X)", etc. */
+FFEINFO_WHERE (FFEINFO_whereFLEETING_CADDR, "Fleet-Const", "fp")	/* "A(3)", "CHARS(4:5)". */
+FFEINFO_WHERE (FFEINFO_whereFLEETING_IADDR, "Fleet-Immed", "fi")	/* A(IX) in "DATA (A(IX),IX=1,100)/.../". */
+FFEINFO_WHERE (FFEINFO_whereIMMEDIATE, "Immediate", "i")	/* IX in "DATA (A(IX),IX=1,100)/.../". */
+FFEINFO_WHERE (FFEINFO_whereINTRINSIC, "Intrinsic", "b")
+FFEINFO_WHERE (FFEINFO_whereCONSTANT, "Constant", "p")		/* For kindFUNCTION, means statement function! */
+FFEINFO_WHERE (FFEINFO_whereCONSTANT_SUBOBJECT, "Const-subobj", "q")	/* As in "'FOO'(I:J)". */
+FFEINFO_WHERE (FFEINFO_whereANY, "Any", "~")

gcc/f/info.c

@@ -0,0 +1,303 @@
+/* info.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995, 2002, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Related Modules:
+      None
+
+   Description:
+      An abstraction for information maintained on a per-operator and per-
+      operand basis in expression trees.
+
+   Modifications:
+      30-Aug-90	 JCB  2.0
+	 Extensive rewrite for new cleaner approach.
+*/
+
+/* Include files. */
+
+#include "proj.h"
+#include "info.h"
+#include "target.h"
+#include "type.h"
+
+/* Externals defined here. */
+
+
+/* Simple definitions and enumerations. */
+
+
+/* Internal typedefs. */
+
+
+/* Private include files. */
+
+
+/* Internal structure definitions. */
+
+
+/* Static objects accessed by functions in this module.	 */
+
+static const char *const ffeinfo_basictype_string_[]
+=
+{
+#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) SNAM,
+#include "info-b.def"
+#undef FFEINFO_BASICTYPE
+};
+static const char *const ffeinfo_kind_message_[]
+=
+{
+#define FFEINFO_KIND(kwd,msgid,snam) msgid,
+#include "info-k.def"
+#undef FFEINFO_KIND
+};
+static const char *const ffeinfo_kind_string_[]
+=
+{
+#define FFEINFO_KIND(KWD,LNAM,SNAM) SNAM,
+#include "info-k.def"
+#undef FFEINFO_KIND
+};
+static ffeinfoBasictype ffeinfo_combine_[FFEINFO_basictype][FFEINFO_basictype];
+static const char *const ffeinfo_kindtype_string_[]
+=
+{
+  "",
+  "1",
+  "2",
+  "3",
+  "4",
+  "5",
+  "6",
+  "7",
+  "8",
+  "*",
+};
+static const char *const ffeinfo_where_string_[]
+=
+{
+#define FFEINFO_WHERE(KWD,LNAM,SNAM) SNAM,
+#include "info-w.def"
+#undef FFEINFO_WHERE
+};
+static ffetype ffeinfo_types_[FFEINFO_basictype][FFEINFO_kindtype];
+
+/* Static functions (internal). */
+
+
+/* Internal macros. */
+
+
+/* ffeinfo_basictype_combine -- Combine two basictypes into highest rank type
+
+   ffeinfoBasictype i, j, k;
+   k = ffeinfo_basictype_combine(i,j);
+
+   Returns a type based on "standard" operation between two given types.  */
+
+ffeinfoBasictype
+ffeinfo_basictype_combine (ffeinfoBasictype l, ffeinfoBasictype r)
+{
+  assert (l < FFEINFO_basictype);
+  assert (r < FFEINFO_basictype);
+  return ffeinfo_combine_[l][r];
+}
+
+/* ffeinfo_basictype_string -- Return tiny string showing the basictype
+
+   ffeinfoBasictype i;
+   printf("%s",ffeinfo_basictype_string(dt));
+
+   Returns the string based on the basic type.	*/
+
+const char *
+ffeinfo_basictype_string (ffeinfoBasictype basictype)
+{
+  if (basictype >= ARRAY_SIZE (ffeinfo_basictype_string_))
+    return "?\?\?";
+  return ffeinfo_basictype_string_[basictype];
+}
+
+/* ffeinfo_init_0 -- Initialize
+
+   ffeinfo_init_0();  */
+
+void
+ffeinfo_init_0 (void)
+{
+  ffeinfoBasictype i;
+  ffeinfoBasictype j;
+
+  assert (FFEINFO_basictype == ARRAY_SIZE (ffeinfo_basictype_string_));
+  assert (FFEINFO_kind == ARRAY_SIZE (ffeinfo_kind_message_));
+  assert (FFEINFO_kind == ARRAY_SIZE (ffeinfo_kind_string_));
+  assert (FFEINFO_kindtype == ARRAY_SIZE (ffeinfo_kindtype_string_));
+  assert (FFEINFO_where == ARRAY_SIZE (ffeinfo_where_string_));
+
+  /* Make array that, given two basic types, produces resulting basic type. */
+
+  for (i = 0; i < FFEINFO_basictype; ++i)
+    for (j = 0; j < FFEINFO_basictype; ++j)
+      if ((i == FFEINFO_basictypeANY) || (j == FFEINFO_basictypeANY))
+	ffeinfo_combine_[i][j] = FFEINFO_basictypeANY;
+      else
+	ffeinfo_combine_[i][j] = FFEINFO_basictypeNONE;
+
+#define same(bt) ffeinfo_combine_[bt][bt] = bt
+#define use2(bt1,bt2) ffeinfo_combine_[bt1][bt2]  \
+      = ffeinfo_combine_[bt2][bt1] = bt2
+
+  same (FFEINFO_basictypeINTEGER);
+  same (FFEINFO_basictypeLOGICAL);
+  same (FFEINFO_basictypeREAL);
+  same (FFEINFO_basictypeCOMPLEX);
+  same (FFEINFO_basictypeCHARACTER);
+  use2 (FFEINFO_basictypeINTEGER, FFEINFO_basictypeREAL);
+  use2 (FFEINFO_basictypeINTEGER, FFEINFO_basictypeCOMPLEX);
+  use2 (FFEINFO_basictypeREAL, FFEINFO_basictypeCOMPLEX);
+
+#undef same
+#undef use2
+}
+
+/* ffeinfo_kind_message -- Return helpful string showing the kind
+
+   ffeinfoKind kind;
+   printf("%s",ffeinfo_kind_message(kind));
+
+   Returns the string based on the kind.  */
+
+const char *
+ffeinfo_kind_message (ffeinfoKind kind)
+{
+  if (kind >= ARRAY_SIZE (ffeinfo_kind_message_))
+    return "?\?\?";
+  return ffeinfo_kind_message_[kind];
+}
+
+/* ffeinfo_kind_string -- Return tiny string showing the kind
+
+   ffeinfoKind kind;
+   printf("%s",ffeinfo_kind_string(kind));
+
+   Returns the string based on the kind.  */
+
+const char *
+ffeinfo_kind_string (ffeinfoKind kind)
+{
+  if (kind >= ARRAY_SIZE (ffeinfo_kind_string_))
+    return "?\?\?";
+  return ffeinfo_kind_string_[kind];
+}
+
+ffeinfoKindtype
+ffeinfo_kindtype_max(ffeinfoBasictype bt,
+		     ffeinfoKindtype k1,
+		     ffeinfoKindtype k2)
+{
+  if ((bt == FFEINFO_basictypeANY)
+      || (k1 == FFEINFO_kindtypeANY)
+      || (k2 == FFEINFO_kindtypeANY))
+    return FFEINFO_kindtypeANY;
+
+  if (ffetype_size (ffeinfo_types_[bt][k1])
+      > ffetype_size (ffeinfo_types_[bt][k2]))
+    return k1;
+  return k2;
+}
+
+/* ffeinfo_kindtype_string -- Return tiny string showing the kind type
+
+   ffeinfoKindtype kind_type;
+   printf("%s",ffeinfo_kindtype_string(kind));
+
+   Returns the string based on the kind type.  */
+
+const char *
+ffeinfo_kindtype_string (ffeinfoKindtype kind_type)
+{
+  if (kind_type >= ARRAY_SIZE (ffeinfo_kindtype_string_))
+    return "?\?\?";
+  return ffeinfo_kindtype_string_[kind_type];
+}
+
+void
+ffeinfo_set_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
+		  ffetype type)
+{
+  assert (basictype < FFEINFO_basictype);
+  assert (kindtype < FFEINFO_kindtype);
+  assert (ffeinfo_types_[basictype][kindtype] == NULL);
+
+  ffeinfo_types_[basictype][kindtype] = type;
+}
+
+ffetype
+ffeinfo_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype)
+{
+  assert (basictype < FFEINFO_basictype);
+  assert (kindtype < FFEINFO_kindtype);
+
+  return ffeinfo_types_[basictype][kindtype];
+}
+
+/* ffeinfo_where_string -- Return tiny string showing the where
+
+   ffeinfoWhere where;
+   printf("%s",ffeinfo_where_string(where));
+
+   Returns the string based on the where.  */
+
+const char *
+ffeinfo_where_string (ffeinfoWhere where)
+{
+  if (where >= ARRAY_SIZE (ffeinfo_where_string_))
+    return "?\?\?";
+  return ffeinfo_where_string_[where];
+}
+
+/* ffeinfo_new -- Return object representing datatype, kind, and where info
+
+   ffeinfo i;
+   i = ffeinfo_new(FFEINFO_datatypeINTEGER,FFEINFO_kindSCALAR,
+       FFEINFO_whereLOCAL);
+
+   Returns the string based on the data type.  */
+
+#ifndef __GNUC__
+ffeinfo
+ffeinfo_new (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
+	     ffeinfoRank rank, ffeinfoKind kind, ffeinfoWhere where,
+	     ffetargetCharacterSize size)
+{
+  ffeinfo i;
+
+  i.basictype = basictype;
+  i.kindtype = kindtype;
+  i.rank = rank;
+  i.size = size;
+  i.kind = kind;
+  i.where = where;
+  i.size = size;
+
+  return i;
+}
+#endif

gcc/f/info.h

@@ -0,0 +1,186 @@
+/* info.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      info.c
+
+   Modifications:
+      30-Aug-90	 JCB  2.0
+	 Extensive rewrite for new cleaner approach.
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_INFO_H
+#define GCC_F_INFO_H
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+#define FFEINFO_BASICTYPE(KWD,LNAM,SNAM) KWD,
+#include "info-b.def"
+#undef FFEINFO_BASICTYPE
+    FFEINFO_basictype
+  } ffeinfoBasictype;
+
+typedef enum
+  {				/* If these kindtypes aren't in size order,
+				   change _kindtype_max. */
+    FFEINFO_kindtypeNONE,
+    FFEINFO_kindtypeINTEGER1,
+    FFEINFO_kindtypeINTEGER2,
+    FFEINFO_kindtypeINTEGER3,
+    FFEINFO_kindtypeINTEGER4,
+    FFEINFO_kindtypeINTEGER5,
+    FFEINFO_kindtypeINTEGER6,
+    FFEINFO_kindtypeINTEGER7,
+    FFEINFO_kindtypeINTEGER8,
+    FFEINFO_kindtypeLOGICAL1 = 1,	/* Ok to omit, but ok to overlap. */
+    FFEINFO_kindtypeLOGICAL2,
+    FFEINFO_kindtypeLOGICAL3,
+    FFEINFO_kindtypeLOGICAL4,
+    FFEINFO_kindtypeLOGICAL5,
+    FFEINFO_kindtypeLOGICAL6,
+    FFEINFO_kindtypeLOGICAL7,
+    FFEINFO_kindtypeLOGICAL8,
+    FFEINFO_kindtypeREAL1 = 1,	/* Ok to omit, but ok to overlap. */
+    FFEINFO_kindtypeREAL2,
+    FFEINFO_kindtypeREAL3,
+    FFEINFO_kindtypeREAL4,
+    FFEINFO_kindtypeREAL5,
+    FFEINFO_kindtypeREAL6,
+    FFEINFO_kindtypeREAL7,
+    FFEINFO_kindtypeREAL8,
+    FFEINFO_kindtypeCHARACTER1 = 1,	/* Ok to omit, but ok to overlap. */
+    FFEINFO_kindtypeCHARACTER2,
+    FFEINFO_kindtypeCHARACTER3,
+    FFEINFO_kindtypeCHARACTER4,
+    FFEINFO_kindtypeCHARACTER5,
+    FFEINFO_kindtypeCHARACTER6,
+    FFEINFO_kindtypeCHARACTER7,
+    FFEINFO_kindtypeCHARACTER8,
+    FFEINFO_kindtypeANY,
+    FFEINFO_kindtype
+  } ffeinfoKindtype;
+
+typedef enum
+  {
+#define FFEINFO_KIND(KWD,LNAM,SNAM) KWD,
+#include "info-k.def"
+#undef FFEINFO_KIND
+    FFEINFO_kind
+  } ffeinfoKind;
+
+typedef enum
+  {
+#define FFEINFO_WHERE(KWD,LNAM,SNAM) KWD,
+#include "info-w.def"
+#undef FFEINFO_WHERE
+    FFEINFO_where
+  } ffeinfoWhere;
+
+/* Typedefs. */
+
+typedef struct _ffeinfo_ ffeinfo;
+typedef char ffeinfoRank;
+
+/* Include files needed by this one. */
+
+#include "target.h"
+#include "type.h"
+
+/* Structure definitions. */
+
+struct _ffeinfo_
+  {
+    ffeinfoBasictype basictype;
+    ffeinfoKindtype kindtype;
+    ffeinfoRank rank;
+    ffeinfoKind kind;
+    ffeinfoWhere where;
+    ffetargetCharacterSize size;
+  };
+
+/* Global objects accessed by users of this module. */
+
+
+/* Declare functions with prototypes. */
+
+ffeinfoBasictype ffeinfo_basictype_combine (ffeinfoBasictype l,
+					    ffeinfoBasictype r);
+const char *ffeinfo_basictype_string (ffeinfoBasictype basictype);
+void ffeinfo_init_0 (void);
+const char *ffeinfo_kind_message (ffeinfoKind kind);
+const char *ffeinfo_kind_string (ffeinfoKind kind);
+ffeinfoKindtype ffeinfo_kindtype_max(ffeinfoBasictype bt,
+				     ffeinfoKindtype k1,
+				     ffeinfoKindtype k2);
+const char *ffeinfo_kindtype_string (ffeinfoKindtype kind_type);
+const char *ffeinfo_where_string (ffeinfoWhere where);
+ffeinfo ffeinfo_new (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
+		     ffeinfoRank rank, ffeinfoKind kind, ffeinfoWhere where,
+		     ffetargetCharacterSize size);
+void ffeinfo_set_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype,
+		       ffetype type);
+ffetype ffeinfo_type (ffeinfoBasictype basictype, ffeinfoKindtype kindtype);
+
+/* Define macros. */
+
+#define ffeinfo_basictype(i) (i.basictype)
+#define ffeinfo_init_1()
+#define ffeinfo_init_2()
+#define ffeinfo_init_3()
+#define ffeinfo_init_4()
+#define ffeinfo_kind(i) (i.kind)
+#define ffeinfo_kindtype(i) (i.kindtype)
+#ifdef __GNUC__
+#define ffeinfo_new(bt,kt,r,k,w,sz) \
+  ((ffeinfo) {(bt), (kt), (r), (k), (w), (sz)})
+#endif
+#define ffeinfo_new_any()						      \
+  ffeinfo_new (FFEINFO_basictypeANY, FFEINFO_kindtypeANY, 0,		      \
+	       FFEINFO_kindANY, FFEINFO_whereANY,			      \
+	       FFETARGET_charactersizeNONE)
+#define ffeinfo_new_null()						      \
+  ffeinfo_new (FFEINFO_basictypeNONE, FFEINFO_kindtypeNONE, 0,		      \
+	       FFEINFO_kindNONE, FFEINFO_whereNONE,			      \
+	       FFETARGET_charactersizeNONE)
+#define ffeinfo_rank(i) (i.rank)
+#define ffeinfo_size(i) (i.size)
+#define ffeinfo_terminate_0()
+#define ffeinfo_terminate_1()
+#define ffeinfo_terminate_2()
+#define ffeinfo_terminate_3()
+#define ffeinfo_terminate_4()
+#define ffeinfo_use(i) i
+#define ffeinfo_where(i) (i.where)
+
+#define FFEINFO_kindtypeINTEGERDEFAULT FFEINFO_kindtypeINTEGER1
+#define FFEINFO_kindtypeLOGICALDEFAULT FFEINFO_kindtypeLOGICAL1
+#define FFEINFO_kindtypeREALDEFAULT FFEINFO_kindtypeREAL1
+#define FFEINFO_kindtypeREALDOUBLE FFEINFO_kindtypeREAL2
+#define FFEINFO_kindtypeREALQUAD FFEINFO_kindtypeREAL3
+#define FFEINFO_kindtypeCHARACTERDEFAULT FFEINFO_kindtypeCHARACTER1
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_INFO_H */

gcc/f/intrin.h

@@ -0,0 +1,135 @@
+/* intrin.h -- Public interface for intrin.c
+   Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+*/
+
+#ifndef GCC_F_INTRIN_H
+#define GCC_F_INTRIN_H
+
+#ifndef FFEINTRIN_DOC
+#define FFEINTRIN_DOC 0	/* 1 means intrinsic documentation only (intdoc.c). */
+#endif
+
+typedef enum
+  {
+    FFEINTRIN_familyNONE,	/* Not in any family. */
+    FFEINTRIN_familyF77,	/* ANSI FORTRAN 77. */
+    FFEINTRIN_familyGNU,	/* GNU Fortran intrinsics. */
+    FFEINTRIN_familyF2C,	/* f2c intrinsics. */
+    FFEINTRIN_familyF90,	/* Fortran 90. */
+    FFEINTRIN_familyF95 = FFEINTRIN_familyF90,
+    FFEINTRIN_familyVXT,	/* VAX/VMS FORTRAN. */
+    FFEINTRIN_familyMIL,	/* MIL STD 1753 (MVBITS, etc), in mil, vxt, and f90. */
+    FFEINTRIN_familyASC,	/* ASCII-related (ACHAR, IACHAR), both f2c and f90. */
+    FFEINTRIN_familyFVZ,	/* in both f2c and VAX/VMS FORTRAN. */
+    FFEINTRIN_familyF2U,	/* libf2c/libU77 UNIX system intrinsics. */
+    FFEINTRIN_familyBADU77,	/* libU77 UNIX system intrinsics with bad form. */
+    FFEINTRIN_family
+  } ffeintrinFamily;
+
+typedef enum
+  {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2) FFEINTRIN_gen ## CODE,
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
+#include "intrin.def"
+#undef DEFNAME
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+    FFEINTRIN_gen
+  } ffeintrinGen;
+
+typedef enum
+  {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) FFEINTRIN_spec ## CODE,
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
+#include "intrin.def"
+#undef DEFNAME
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+    FFEINTRIN_spec
+  } ffeintrinSpec;
+
+typedef enum
+  {
+#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
+#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
+#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
+#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
+    FFEINTRIN_imp ## CODE,
+#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
+    FFEINTRIN_imp ## CODE,
+#include "intrin.def"
+#undef DEFNAME
+#undef DEFGEN
+#undef DEFSPEC
+#undef DEFIMP
+#undef DEFIMPY
+    FFEINTRIN_imp
+  } ffeintrinImp;
+
+#if !FFEINTRIN_DOC
+
+#include "bld.h"
+#include "info.h"
+
+ffeinfoBasictype ffeintrin_basictype (ffeintrinSpec spec);
+ffeintrinFamily ffeintrin_family (ffeintrinSpec spec);
+void ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t);
+void ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
+				 bool *check_intrin, ffelexToken t);
+ffecomGfrt ffeintrin_gfrt_direct (ffeintrinImp imp);
+ffecomGfrt ffeintrin_gfrt_indirect (ffeintrinImp imp);
+void ffeintrin_init_0 (void);
+#define ffeintrin_init_1()
+#define ffeintrin_init_2()
+#define ffeintrin_init_3()
+#define ffeintrin_init_4()
+bool ffeintrin_is_actualarg (ffeintrinSpec spec);
+bool ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
+			     ffeintrinGen *gen, ffeintrinSpec *spec,
+			     ffeintrinImp *imp);
+bool ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec);
+ffeinfoKindtype ffeintrin_kindtype (ffeintrinSpec spec);
+const char *ffeintrin_name_generic (ffeintrinGen gen);
+const char *ffeintrin_name_implementation (ffeintrinImp imp);
+const char *ffeintrin_name_specific (ffeintrinSpec spec);
+ffeIntrinsicState ffeintrin_state_family (ffeintrinFamily family);
+#define ffeintrin_terminate_0()
+#define ffeintrin_terminate_1()
+#define ffeintrin_terminate_2()
+#define ffeintrin_terminate_3()
+#define ffeintrin_terminate_4()
+
+#endif	/* !FFEINTRIN_DOC */
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_INTRIN_H */

gcc/f/lab.c

@@ -0,0 +1,157 @@
+/* lab.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Related Modules:
+
+   Description:
+      Complex data abstraction for Fortran labels.  Maintains a single master
+      list for all labels; it is expected initialization and termination of
+      this list will occur on program-unit boundaries.
+
+   Modifications:
+      22-Aug-89	 JCB  1.1
+	 Change ffelab_new for new ffewhere interface.
+*/
+
+/* Include files. */
+
+#include "proj.h"
+#include "lab.h"
+#include "malloc.h"
+
+/* Externals defined here. */
+
+ffelab ffelab_list_;
+ffelabNumber ffelab_num_news_;
+
+/* Simple definitions and enumerations. */
+
+
+/* Internal typedefs. */
+
+
+/* Private include files. */
+
+
+/* Internal structure definitions. */
+
+
+/* Static objects accessed by functions in this module. */
+
+
+/* Static functions (internal). */
+
+
+/* Internal macros. */
+
+
+/* ffelab_find -- Find the ffelab object having the desired label value
+
+   ffelab l;
+   ffelabValue v;
+   l = ffelab_find(v);
+
+   If the desired ffelab object doesn't exist, returns NULL.
+
+   Straightforward search of list of ffelabs.  */
+
+ffelab
+ffelab_find (ffelabValue v)
+{
+  ffelab l;
+
+  for (l = ffelab_list_; (l != NULL) && (ffelab_value (l) != v); l = l->next)
+    ;
+
+  return l;
+}
+
+/* ffelab_finish -- Shut down label management
+
+   ffelab_finish();
+
+   At the end of processing a program unit, call this routine to shut down
+   label management.
+
+   Kill all the labels on the list.  */
+
+void
+ffelab_finish (void)
+{
+  ffelab l;
+  ffelab pl;
+
+  for (pl = NULL, l = ffelab_list_; l != NULL; pl = l, l = l->next)
+    if (pl != NULL)
+      malloc_kill_ks (ffe_pool_any_unit (), pl, sizeof (*pl));
+
+  if (pl != NULL)
+    malloc_kill_ks (ffe_pool_any_unit (), pl, sizeof (*pl));
+}
+
+/* ffelab_init_3 -- Initialize label management system
+
+   ffelab_init_3();
+
+   Initialize the label management system.  Do this before a new program
+   unit is going to be processed.  */
+
+void
+ffelab_init_3 (void)
+{
+  ffelab_list_ = NULL;
+  ffelab_num_news_ = 0;
+}
+
+/* ffelab_new -- Create an ffelab object.
+
+   ffelab l;
+   ffelabValue v;
+   l = ffelab_new(v);
+
+   Create a label having a given value.	 If the value isn't known, pass
+   FFELAB_valueNONE, and set it later with ffelab_set_value.
+
+   Allocate, initialize, and stick at top of label list.
+
+   22-Aug-89  JCB  1.1
+      Change for new ffewhere interface.  */
+
+ffelab
+ffelab_new (ffelabValue v)
+{
+  ffelab l;
+
+  ++ffelab_num_news_;
+  l = malloc_new_ks (ffe_pool_any_unit (), "FFELAB label", sizeof (*l));
+  l->next = ffelab_list_;
+  l->hook = FFECOM_labelNULL;
+  l->value = v;
+  l->firstref_line = ffewhere_line_unknown ();
+  l->firstref_col = ffewhere_column_unknown ();
+  l->doref_line = ffewhere_line_unknown ();
+  l->doref_col = ffewhere_column_unknown ();
+  l->definition_line = ffewhere_line_unknown ();
+  l->definition_col = ffewhere_column_unknown ();
+  l->type = FFELAB_typeUNKNOWN;
+  ffelab_list_ = l;
+  return l;
+}

gcc/f/lab.h

@@ -0,0 +1,152 @@
+/* lab.h -- Public #include File (module.h template V1.0)
+   Copyright (C) 1995, 2003 Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+   Owning Modules:
+      lab.c
+
+   Modifications:
+      22-Aug-89	 JCB  1.1
+	 Change for new ffewhere interface.
+*/
+
+/* Allow multiple inclusion to work. */
+
+#ifndef GCC_F_LAB_H
+#define GCC_F_LAB_H
+
+/* Simple definitions and enumerations. */
+
+typedef enum
+  {
+    FFELAB_typeUNKNOWN,		/* No info yet on label. */
+    FFELAB_typeANY,		/* Label valid for anything, no msgs. */
+    FFELAB_typeUSELESS,		/* No valid way to reference this label. */
+    FFELAB_typeASSIGNABLE,	/* Target of ASSIGN: so FORMAT or BRANCH. */
+    FFELAB_typeFORMAT,		/* FORMAT label. */
+    FFELAB_typeLOOPEND,		/* Target of a labeled DO statement. */
+    FFELAB_typeNOTLOOP,		/* Branch target statement not valid DO
+				   target. */
+    FFELAB_typeENDIF,		/* END IF label. */
+    FFELAB_type
+  } ffelabType;
+
+#define FFELAB_valueNONE 0
+#define FFELAB_valueMAX 99999
+
+/* Typedefs. */
+
+typedef struct _ffelab_ *ffelab;
+typedef ffelab ffelabHandle;
+typedef unsigned long ffelabNumber;	/* Count of new labels. */
+#define ffelabNumber_f "l"
+typedef unsigned long ffelabValue;
+#define ffelabValue_f "l"
+
+/* Include files needed by this one. */
+
+#include "com.h"
+#include "where.h"
+
+/* Structure definitions. */
+
+struct _ffelab_
+  {
+    ffelab next;
+    ffecomLabel hook;
+    ffelabValue value;		/* 1 through 99999, or 100000+ for temp
+				   labels. */
+    unsigned long blocknum;	/* Managed entirely by user of module. */
+    ffewhereLine firstref_line;
+    ffewhereColumn firstref_col;
+    ffewhereLine doref_line;
+    ffewhereColumn doref_col;
+    ffewhereLine definition_line;	/* ffewhere_line_unknown() if not
+					   defined. */
+    ffewhereColumn definition_col;
+    ffelabType type;
+  };
+
+/* Global objects accessed by users of this module. */
+
+extern ffelab ffelab_list_;
+extern ffelabNumber ffelab_num_news_;
+
+/* Declare functions with prototypes. */
+
+ffelab ffelab_find (ffelabValue v);
+void ffelab_finish (void);
+void ffelab_init_3 (void);
+ffelab ffelab_new (ffelabValue v);
+
+/* Define macros. */
+
+#define ffelab_blocknum(l) ((l)->blocknum)
+#define ffelab_definition_column(l) ((l)->definition_col)
+#define ffelab_definition_filename(l) \
+      ffewhere_line_filename((l)->definition_line)
+#define ffelab_definition_filelinenum(l) \
+      ffewhere_line_filelinenum((l)->definition_line)
+#define ffelab_definition_line(l) ((l)->definition_line)
+#define ffelab_definition_line_number(l) \
+      ffewhere_line_number((l)->definition_line)
+#define ffelab_doref_column(l) ((l)->doref_col)
+#define ffelab_doref_filename(l) ffewhere_line_filename((l)->doref_line)
+#define ffelab_doref_filelinenum(l) ffewhere_line_filelinenum((l)->doref_line)
+#define ffelab_doref_line(l) ((l)->doref_line)
+#define ffelab_doref_line_number(l) ffewhere_line_number((l)->doref_line)
+#define ffelab_firstref_column(l) ((l)->firstref_col)
+#define ffelab_firstref_filename(l) ffewhere_line_filename((l)->firstref_line)
+#define ffelab_firstref_filelinenum(l) \
+      ffewhere_line_filelinenum((l)->firstref_line)
+#define ffelab_firstref_line(l) ((l)->firstref_line)
+#define ffelab_firstref_line_number(l) ffewhere_line_number((l)->firstref_line)
+#define ffelab_handle_done(h)
+#define ffelab_handle_first() ((ffelabHandle) ffelab_list_)
+#define ffelab_handle_next(h) ((ffelabHandle) (((ffelab) h)->next))
+#define ffelab_handle_target(h) ((ffelab) h)
+#define ffelab_hook(l) ((l)->hook)
+#define ffelab_init_0()
+#define ffelab_init_1()
+#define ffelab_init_2()
+#define ffelab_init_4()
+#define ffelab_kill(l) ffelab_set_value(l,FFELAB_valueNONE);
+#define ffelab_new_generated() (ffelab_new(ffelab_generated_++))
+#define ffelab_number() (ffelab_num_news_)
+#define ffelab_set_blocknum(l,b) ((l)->blocknum = (b))
+#define ffelab_set_definition_column(l,cn) ((l)->definition_col = (cn))
+#define ffelab_set_definition_line(l,ln) ((l)->definition_line = (ln))
+#define ffelab_set_doref_column(l,cn) ((l)->doref_col = (cn))
+#define ffelab_set_doref_line(l,ln) ((l)->doref_line = (ln))
+#define ffelab_set_firstref_column(l,cn) ((l)->firstref_col = (cn))
+#define ffelab_set_firstref_line(l,ln) ((l)->firstref_line = (ln))
+#define ffelab_set_hook(l,h) ((l)->hook = (h))
+#define ffelab_set_type(l,t) ((l)->type = (t))
+#define ffelab_terminate_0()
+#define ffelab_terminate_1()
+#define ffelab_terminate_2()
+#define ffelab_terminate_3()
+#define ffelab_terminate_4()
+#define ffelab_type(l) ((l)->type)
+#define ffelab_value(l) ((l)->value)
+
+/* End of #include file. */
+
+#endif /* ! GCC_F_LAB_H */

gcc/f/lang-specs.h

@@ -0,0 +1,47 @@
+/* lang-specs.h file for Fortran
+   Copyright (C) 1995, 1996, 1997, 1999, 2000, 2002, 2003
+   Free Software Foundation, Inc.
+   Contributed by James Craig Burley.
+
+This file is part of GNU Fortran.
+
+GNU Fortran 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.
+
+GNU Fortran 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 GNU Fortran; see the file COPYING.  If not, write to
+the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+02111-1307, USA.
+
+*/
+
+/* This is the contribution to the `default_compilers' array in gcc.c for
+   g77.  */
+
+  {".F",   "@f77-cpp-input", 0},
+  {".fpp", "@f77-cpp-input", 0},
+  {".FPP", "@f77-cpp-input", 0},
+  {"@f77-cpp-input",
+   "cc1 -E -traditional-cpp -D_LANGUAGE_FORTRAN %(cpp_options) \
+        %{E|M|MM:%(cpp_debug_options)}\
+        %{!M:%{!MM:%{!E: -o %|.f |\n\
+    f771 %|.f %(cc1_options) %{I*} %{!fsyntax-only:%(invoke_as)}}}}", 0},
+  {".r", "@ratfor", 0},
+  {"@ratfor",
+   "%{C:%{!E:%eGCC does not support -C without using -E}}\
+    %{CC:%{!E:%eGCC does not support -CC without using -E}}\
+    ratfor %{C} %{CC} %{v} %{E:%W{o*}} %{!E: %{!pipe:-o %g.f} %i |\n\
+    f771 %m.f %(cc1_options) %{I*} %{!fsyntax-only:%(invoke_as)}}", 0},
+  {".f",   "@f77", 0},
+  {".for", "@f77", 0},
+  {".FOR", "@f77", 0},
+  {"@f77",
+   "%{!M:%{!MM:%{!E:f771 %i %(cc1_options) %{I*}\
+	%{!fsyntax-only:%(invoke_as)}}}}", 0},

gcc/f/lang.opt

@@ -0,0 +1,402 @@
+; Options for the Fortran 77 front end.
+; Copyright (C) 2003 Free Software Foundation, Inc.
+;
+; This file is part of GCC.
+;
+; GCC 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.
+; 
+; GCC 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 GCC; see the file COPYING.  If not, write to the Free
+; Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+; 02111-1307, USA.
+
+; See c.opt for a description of this file's format.
+
+; Please try to keep this file in ASCII collating order.
+
+Language
+F77
+
+I
+F77 Joined
+Add a directory for INCLUDE searching
+
+Wall
+F77
+; Documented in C
+
+Wcomment
+F77
+
+Wcomments
+F77
+
+Wglobals
+F77
+Enable warnings about inter-procedural problems
+
+Wimplicit
+F77
+
+Wimport
+F77
+
+Wsurprising
+F77
+Warn about constructs with surprising meanings
+
+Wtrigraphs
+F77
+
+fautomatic
+F77
+Do not treat local variables and COMMON blocks as if they were named in SAVE statements
+
+fbackslash
+F77
+Backslashes in character and hollerith constants are special (not C-style)
+
+fbadu77-intrinsics-delete
+F77 RejectNegative
+Delete libU77 intrinsics with bad interfaces
+
+fbadu77-intrinsics-disable
+F77 RejectNegative
+Disable libU77 intrinsics with bad interfaces
+
+fbadu77-intrinsics-enable
+F77 RejectNegative
+Enable libU77 intrinsics with bad interfaces
+
+fbadu77-intrinsics-hide
+F77 RejectNegative
+Hide libU77 intrinsics with bad interfaces
+
+fcase-initcap
+F77 RejectNegative
+Program written in strict mixed-case
+
+fcase-lower
+F77 RejectNegative
+Compile as if program written in lowercase
+
+fcase-preserve
+F77 RejectNegative
+Preserve case used in program
+
+fcase-strict-lower
+F77 RejectNegative
+Program written in lowercase
+
+fcase-strict-upper
+F77 RejectNegative
+Program written in uppercase
+
+fcase-upper
+F77 RejectNegative
+Compile as if program written in uppercase
+
+fdebug-kludge
+F77
+Emit special debugging information for COMMON and EQUIVALENCE (disabled)
+
+fdollar-ok
+F77
+Allow '$' in symbol names
+
+femulate-complex
+F77
+Have front end emulate COMPLEX arithmetic to avoid bugs
+
+ff2c
+F77
+f2c-compatible code can be generated
+
+ff2c-intrinsics-delete
+F77 RejectNegative
+Delete non-FORTRAN-77 intrinsics f2c supports
+
+ff2c-intrinsics-disable
+F77 RejectNegative
+Disable non-FORTRAN-77 intrinsics f2c supports
+
+ff2c-intrinsics-enable
+F77 RejectNegative
+Enable non-FORTRAN-77 intrinsics f2c supports
+
+ff2c-intrinsics-hide
+F77 RejectNegative
+Hide non-FORTRAN-77 intrinsics f2c supports
+
+ff2c-library
+F77
+Unsupported; generate libf2c-calling code
+
+ff66
+F77
+Program is written in typical FORTRAN 66 dialect
+
+ff77
+F77
+Program is written in typical Unix-f77 dialect
+
+ff90
+F77
+Program is written in Fortran-90-ish dialect
+
+ff90-intrinsics-delete
+F77 RejectNegative
+Delete non-FORTRAN-77 intrinsics F90 supports
+
+ff90-intrinsics-disable
+F77 RejectNegative
+Disable non-FORTRAN-77 intrinsics F90 supports
+
+ff90-intrinsics-enable
+F77 RejectNegative
+Enable non-FORTRAN-77 intrinsics F90 supports
+
+ff90-intrinsics-hide
+F77 RejectNegative
+Hide non-FORTRAN-77 intrinsics F90 supports
+
+ff90-not-vxt
+F77 RejectNegative
+
+ffixed-form
+F77
+
+ffixed-line-length-
+F77 Joined
+ffixed-line-length-<number>	Set the maximum line length to <number>
+
+fflatten-arrays
+F77
+Unsupported; affects code generation of arrays
+
+ffortran-bounds-check
+F77
+Generate code to check subscript and substring bounds
+
+ffree-form
+F77
+Program is written in Fortran-90-ish free form
+
+fglobals
+F77
+Enable fatal diagnostics about inter-procedural problems
+
+fgnu-intrinsics-delete
+F77 RejectNegative
+Delete non-FORTRAN-77 intrinsics g77 supports
+
+fgnu-intrinsics-disable
+F77 RejectNegative
+Disable non-FORTRAN 77 intrinsics F90 supports
+
+fgnu-intrinsics-enable
+F77 RejectNegative
+Enable non-FORTRAN 77 intrinsics F90 supports
+
+fgnu-intrinsics-hide
+F77 RejectNegative
+Hide non-FORTRAN 77 intrinsics F90 supports
+
+finit-local-zero
+F77
+Initialize local vars and arrays to zero
+
+fintrin-case-any
+F77 RejectNegative
+Intrinsics letters in arbitrary cases
+
+fintrin-case-initcap
+F77 RejectNegative
+Intrinsics spelled as e.g. SqRt
+
+fintrin-case-lower
+F77 RejectNegative
+Intrinsics in lowercase
+
+fintrin-case-upper
+F77 RejectNegative
+Intrinsics in uppercase
+
+fmatch-case-any
+F77 RejectNegative
+Language keyword letters in arbitrary cases
+
+fmatch-case-initcap
+F77 RejectNegative
+Language keywords spelled as e.g. IOStat
+
+fmatch-case-lower
+F77 RejectNegative
+Language keywords in lowercase
+
+fmatch-case-upper
+F77 RejectNegative
+Language keywords in uppercase
+
+fmil-intrinsics-delete
+F77 RejectNegative
+Delete MIL-STD 1753 intrinsics
+
+fmil-intrinsics-disable
+F77 RejectNegative
+Disable MIL-STD 1753 intrinsics
+
+fmil-intrinsics-enable
+F77 RejectNegative
+Enable MIL-STD 1753 intrinsics
+
+fmil-intrinsics-hide
+F77 RejectNegative
+Hide MIL-STD 1753 intrinsics
+
+fonetrip
+F77
+Take at least one trip through each iterative DO loop
+
+fpedantic
+F77
+Warn about use of (only a few for now) Fortran extensions
+
+fpreprocessed
+F77
+
+fsecond-underscore
+F77
+Allow appending a second underscore to externals
+
+fsilent
+F77
+Do not print names of program units as they are compiled
+
+fsource-case-lower
+F77 RejectNegative
+Internally convert most source to lowercase
+
+fsource-case-preserve
+F77 RejectNegative
+Internally preserve source case
+
+fsource-case-upper
+F77 RejectNegative
+Internally convert most source to uppercase
+
+fsymbol-case-any
+F77 RejectNegative
+
+fsymbol-case-initcap
+F77 RejectNegative
+Symbol names spelled in mixed case
+
+fsymbol-case-lower
+F77 RejectNegative
+Symbol names in lowercase
+
+fsymbol-case-upper
+F77 RejectNegative
+Symbol names in uppercase
+
+ftypeless-boz
+F77
+Make prefix-radix non-decimal constants be typeless
+
+fugly
+F77
+Allow all ugly features
+
+fugly-args
+F77
+Hollerith and typeless can be passed as arguments
+
+fugly-assign
+F77
+Allow ordinary copying of ASSIGN'ed vars
+
+fugly-assumed
+F77
+Dummy array dimensioned to (1) is assumed-size
+
+fugly-comma
+F77
+Trailing comma in procedure call denotes null argument
+
+fugly-complex
+F77
+Allow REAL(Z) and AIMAG(Z) given DOUBLE COMPLEX Z
+
+fugly-init
+F77
+Initialization via DATA and PARAMETER is not type-compatible
+
+fugly-logint
+F77
+Allow INTEGER and LOGICAL interchangeability
+
+funderscoring
+F77
+Append underscores to externals
+
+funix-intrinsics-delete
+F77 RejectNegative
+Delete libU77 intrinsics
+
+funix-intrinsics-disable
+F77 RejectNegative
+Disable libU77 intrinsics
+
+funix-intrinsics-enable
+F77 RejectNegative
+Enable libU77 intrinsics
+
+funix-intrinsics-hide
+F77 RejectNegative
+Hide libU77 intrinsics
+
+fversion
+F77 RejectNegative
+Print g77-specific version information and run internal tests
+
+fvxt
+F77
+Program is written in VXT (Digital-like) FORTRAN
+
+fvxt-intrinsics-delete
+F77 RejectNegative
+Delete non-FORTRAN-77 intrinsics VXT FORTRAN supports
+
+fvxt-intrinsics-disable
+F77 RejectNegative
+Disable non-FORTRAN-77 intrinsics VXT FORTRAN supports
+
+fvxt-intrinsics-enable
+F77 RejectNegative
+Enable non-FORTRAN-77 intrinsics VXT FORTRAN supports
+
+fvxt-intrinsics-hide
+F77 RejectNegative
+Hide non-FORTRAN-77 intrinsics VXT FORTRAN supports
+
+fvxt-not-f90
+F77 RejectNegative
+
+fxyzzy
+F77
+Print internal debugging-related information
+
+fzeros
+F77
+Treat initial values of 0 like non-zero values
+
+; This comment is to ensure we retain the blank line above.

gcc/testsuite/g77.f-torture/execute/io1.f

@@ -0,0 +1,10 @@
+*     Fixed by 1998-09-28 libI77/open.c change.
+      open(90,status='scratch')
+      write(90, '(1X, I1 / 1X, I1)') 1, 2
+      rewind 90
+      write(90, '(1X, I1)') 1
+      rewind 90                 ! implicit ENDFILE expected
+      read(90, *) i
+      read(90, *, end=10) j
+      call abort()
+ 10   end

gcc/testsuite/g77.f-torture/execute/io1.x

@@ -0,0 +1,13 @@
+# Scratch files aren't implemented for mmixware
+# (_stat is a stub and files can't be deleted).
+# Similar restrictions exist for most simulators.
+
+if { [istarget "mmix-knuth-mmixware"]
+     || [istarget "arm*-*-elf"]
+     || [istarget "strongarm*-*-elf"]
+     || [istarget "xscale*-*-elf"]
+     || [istarget "cris-*-elf"] } {
+	set torture_execute_xfail [istarget]
+}
+
+return 0

gcc/testsuite/g77.f-torture/execute/labug1.f

@@ -0,0 +1,57 @@
+      PROGRAM LABUG1
+
+*  This program core dumps on mips-sgi-irix6.2 when compiled
+*  with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots
+*  with -O2
+*
+*  Originally derived from LAPACK test suite.
+*  Almost any change allows it to run.
+*
+*  David Billinghurst, (David.Billinghurst@riotinto.com.au)
+*  25 November 1998
+* 
+*     .. Parameters ..
+      INTEGER   LDA, LDE
+      PARAMETER ( LDA = 2500, LDE = 50  )
+      COMPLEX   CZERO 
+      PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+
+      INTEGER   I, J, M, N
+      REAL      V
+      COMPLEX   A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE)  
+      COMPLEX   Z
+
+      N=2
+      M=1
+*
+      do i = 1, m
+         do j = 1, n
+            e(i,j) = czero
+            f(i,j) = czero
+        end do
+      end do
+*
+      DO J = 1, N
+         DO I = 1, M
+            V =  ABS( E(I,J) - F(I,J) )
+         END DO
+      END DO
+ 
+      CALL SUB2(M,Z)
+
+      END
+
+      subroutine SUB2(I,A)
+      integer i
+      complex a
+      end
+
+
+
+
+
+
+
+
+
+

gcc/testsuite/g77.f-torture/execute/large_vec.f

@@ -0,0 +1,3 @@
+      parameter (nmax=165000)
+      double precision x(nmax)
+      end

gcc/testsuite/g77.f-torture/execute/le.f

@@ -0,0 +1,29 @@
+      program fool
+
+      real     foo
+      integer  n
+      logical  t
+
+      foo = 2.5
+      n = 5
+
+      t = (n > foo)
+      if (t .neqv. .true.) call abort
+      t = (n >= foo)
+      if (t .neqv. .true.) call abort
+      t = (n < foo)
+      if (t .neqv. .false.) call abort
+      t = (n <= 5)
+      if (t .neqv. .true.) call abort
+      t = (n >= 5 )
+      if (t .neqv. .true.) call abort
+      t = (n == 5)
+      if (t .neqv. .true.) call abort
+      t = (n /= 5)
+      if (t .neqv. .false.) call abort
+      t = (n /= foo)
+      if (t .neqv. .true.) call abort
+      t = (n == foo)
+      if (t .neqv. .false.) call abort
+
+      end

gcc/testsuite/g77.f-torture/execute/select.f

@@ -0,0 +1,173 @@
+C   integer byte case with integer byte parameters as case(s)
+        subroutine ib
+        integer *1 a /1/
+        integer *1  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal ib'
+        end
+C   integer halfword case with integer halfword parameters
+        subroutine ih
+        integer *2 a /1/
+        integer *2  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal ih'
+        end
+C   integer case with integer parameters
+        subroutine iw
+        integer *4 a /1/
+        integer *4  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal iw'
+        end
+C   integer double case with integer double parameters
+        subroutine id
+        integer *8 a /1/
+        integer *8  one,two,three
+        parameter (one=1,two=2,three=3)
+        select case (a)
+        case (one)
+        case (two)
+           call abort
+        case (three)
+           call abort
+        case default
+           call abort
+        end select
+        print*,'normal id'
+        end
+C   integer byte select with integer case
+       subroutine ib_mixed
+       integer*1 s /1/
+       select case (s)
+       case (1)
+       case (2)
+         call abort
+       end select
+       print*,'ib ok'
+       end
+C   integer halfword with integer case
+       subroutine ih_mixed
+       integer*2 s /1/
+       select case (s)
+       case (1)
+       case default
+         call abort
+       end select
+       print*,'ih ok'
+       end
+C   integer word with integer case
+       subroutine iw_mixed
+       integer s /5/
+       select case (s)
+       case (1)
+          call abort
+       case (2)
+          call abort
+       case (3)
+          call abort
+       case (4)
+          call abort
+       case (5)
+C                   
+       case (6)
+           call abort
+       case default
+           call abort
+       end select
+       print*,'iw ok'
+       end
+C   integer doubleword with integer case
+       subroutine id_mixed
+       integer *8 s /1024/
+       select case (s)
+       case (1)
+           call abort
+       case (1023)
+           call abort
+       case (1025)
+           call abort
+       case (1024)
+C
+       end select
+       print*,'i8 ok'
+       end
+       subroutine l1_mixed
+       logical*1 s /.TRUE./
+       select case (s)
+       case (.TRUE.)
+       case (.FALSE.)
+          call abort
+       end select
+       print*,'l1 ok'
+       end
+       subroutine l2_mixed
+       logical*2 s /.FALSE./
+       select case (s)
+       case (.TRUE.)
+           call abort
+       case (.FALSE.)
+       end select
+       print*,'lh ok'
+       end
+       subroutine l4_mixed
+       logical*4 s /.TRUE./
+       select case (s)
+       case (.FALSE.)
+         call abort
+       case (.TRUE.)
+       end select
+       print*,'lw ok'
+       end
+       subroutine l8_mixed
+       logical*8 s /.TRUE./
+       select case (s)
+       case (.TRUE.)
+       case (.FALSE.)
+          call abort
+       end select
+       print*,'ld ok'
+       end
+C   main
+C -- regression cases
+        call ib
+        call ih
+        call iw
+        call id
+C -- new functionality
+        call ib_mixed
+        call ih_mixed
+        call iw_mixed
+        call id_mixed
+        end
+        
+
+
+
+

gcc/testsuite/g77.f-torture/execute/short.f

@@ -0,0 +1,57 @@
+      program short
+
+      parameter   (   N=2  )
+      common /chb/    pi,sig(0:N)
+      common /parm/   h(2,2)
+
+c  initialize some variables
+      h(2,2) = 1117
+      h(2,1) = 1178
+      h(1,2) = 1568
+      h(1,1) = 1621
+      sig(0) = -1.
+      sig(1) = 0.
+      sig(2) = 1.
+
+      call printout
+      stop
+      end
+
+c ******************************************************************
+
+      subroutine printout
+      parameter   (   N=2  )
+      common /chb/    pi,sig(0:N)
+      common /parm/   h(2,2)
+      dimension       yzin1(0:N), yzin2(0:N)
+
+c  function subprograms
+      z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.)
+
+c  a four-way average of rhobar
+      do 260  k=0,N
+        yzin1(k) = 0.25 * 
+     &       ( z(2,2,k) + z(1,2,k) +
+     &         z(2,1,k) + z(1,1,k) )
+  260       continue
+
+c  another four-way average of rhobar
+      do 270  k=0,N
+	rtmp1 = z(2,2,k)
+	rtmp2 = z(1,2,k)
+	rtmp3 = z(2,1,k)
+	rtmp4 = z(1,1,k)
+        yzin2(k) = 0.25 * 
+     &       ( rtmp1 + rtmp2 + rtmp3 + rtmp4 )
+  270       continue
+
+      do k=0,N
+	if (yzin1(k) .ne. yzin2(k)) call abort
+      enddo
+      if (yzin1(0) .ne. -1371.) call abort
+      if (yzin1(1) .ne. -685.5) call abort
+      if (yzin1(2) .ne. 0.) call abort
+
+      return
+      end
+

gcc/testsuite/g77.f-torture/execute/u77-test.f

@@ -0,0 +1,421 @@
+***   Some random stuff for testing libU77.  Should be done better.  It's
+*     hard to test things where you can't guarantee the result.  Have a
+*     good squint at what it prints, though detected errors will cause 
+*     starred messages.
+*
+* Currently not tested:
+*   ALARM
+*   CHDIR (func)
+*   CHMOD (func)
+*   FGET (func/subr)
+*   FGETC (func)
+*   FPUT (func/subr)
+*   FPUTC (func)
+*   FSTAT (subr)
+*   GETCWD (subr)
+*   HOSTNM (subr)
+*   IRAND
+*   KILL
+*   LINK (func)
+*   LSTAT (subr)
+*   RENAME (func/subr)
+*   SIGNAL (subr)
+*   SRAND
+*   STAT (subr)
+*   SYMLNK (func/subr)
+*   UMASK (func)
+*   UNLINK (func)
+*
+* NOTE! This is the testsuite version, so it should compile and
+* execute on all targets, and either run to completion (with
+* success status) or fail (by calling abort).  The *other* version,
+* which is a bit more interactive and tests a couple of things
+* this one cannot, should be generally the same, and is in
+* libf2c/libU77/u77-test.f.  Please keep it up-to-date.
+
+      implicit none
+
+      external hostnm
+*     intrinsic hostnm
+      integer hostnm
+
+      integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
+     +     pid, mask
+      real tarray1(2), tarray2(2), r1, r2
+      double precision d1
+      integer(kind=2) bigi
+      logical issum
+      intrinsic getpid, getuid, getgid, ierrno, gerror, time8,
+     +     fnum, isatty, getarg, access, unlink, fstat, iargc,
+     +     stat, lstat, getcwd, gmtime, etime, chmod, itime, date,
+     +     chdir, fgetc, fputc, system_clock, second, idate, secnds,
+     +     time, ctime, fdate, ttynam, date_and_time, mclock, mclock8,
+     +     cpu_time, dtime, ftell, abort
+      external lenstr, ctrlc
+      integer lenstr
+      logical l
+      character gerr*80, c*1
+      character ctim*25, line*80, lognam*20, wd*1000, line2*80, 
+     +     ddate*8, ttime*10, zone*5, ctim2*25
+      integer fstatb (13), statb (13)
+      integer *2 i2zero
+      integer values(8)
+      integer(kind=7) sigret
+
+      i = time ()
+      ctim = ctime (i)
+      WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim))
+      write (6,'(A,I3,'', '',I3)')
+     +     ' Logical units 5 and 6 correspond (FNUM) to'
+     +     // ' Unix i/o units ', fnum(5), fnum(6)
+      if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then
+        print *, 'LNBLNK or LEN_TRIM failed'
+        call abort
+      end if
+
+      bigi = time8 ()
+
+      call ctime (i, ctim2)
+      if (ctim .ne. ctim2) then
+        write (6, *) '*** CALL CTIME disagrees with CTIME(): ',
+     +    ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim))
+        call doabort
+      end if
+
+      j = time ()
+      if (i .gt. bigi .or. bigi .gt. j) then
+        write (6, *) '*** TIME/TIME8/TIME sequence failures: ',
+     +    i, bigi, j
+        call doabort
+      end if
+
+      print *, 'Command-line arguments: ', iargc ()
+      do i = 0, iargc ()
+         call getarg (i, line)
+         print *, 'Arg ', i, ' is: ', line(:lenstr (line))
+      end do
+
+      l= isatty(6)
+      line2 = ttynam(6)
+      if (l) then
+        line = 'and 6 is a tty device (ISATTY) named '//line2
+      else
+        line = 'and 6 isn''t a tty device (ISATTY)'
+      end if
+      write (6,'(1X,A)') line(:lenstr(line))
+      call ttynam (6, line)
+      if (line .ne. line2) then
+        print *, '*** CALL TTYNAM disagrees with TTYNAM: ',
+     +    line(:lenstr (line))
+        call doabort
+      end if
+
+*     regression test for compiler crash fixed by JCB 1998-08-04 com.c
+      sigret = signal(2, ctrlc)
+
+      pid = getpid()
+      WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
+      WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
+      WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
+      WRITE (6, *) 'If you have the `id'' program, the following call'
+      write (6, *) 'of SYSTEM should agree with the above:'
+      call flush(6)
+      CALL SYSTEM ('echo " " `id`')
+      call flush
+
+      lognam = 'blahblahblah'
+      call getlog (lognam)
+      write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam))
+
+      wd = 'blahblahblah'
+      call getenv ('LOGNAME', wd)
+      write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd))
+
+      call umask(0, mask)
+      write(6,*) 'UMASK returns', mask
+      call umask(mask)
+
+      ctim = fdate()
+      write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim))
+      call fdate (ctim)
+      write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim))
+
+      j=time()
+      call ltime (j, ltarray)
+      write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray
+      call gmtime (j, ltarray)
+      write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
+
+      call system_clock(count)  ! omitting optional args
+      call system_clock(count, rate, count_max)
+      write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
+
+      call date_and_time(ddate)  ! omitting optional args
+      call date_and_time(ddate, ttime, zone, values)
+      write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ',
+     +     zone, ' ', values
+
+      write (6,*) 'Sleeping for 1 second (SLEEP) ...'
+      call sleep (1)
+
+c consistency-check etime vs. dtime for first call
+      r1 = etime (tarray1)
+      r2 = dtime (tarray2)
+      if (abs (r1-r2).gt.1.0) then
+        write (6,*)
+     +       'Results of ETIME and DTIME differ by more than a second:',
+     +       r1, r2
+        call doabort
+      end if
+      if (.not. issum (r1, tarray1(1), tarray1(2))) then
+        write (6,*) '*** ETIME didn''t return sum of the array: ',
+     +       r1, ' /= ', tarray1(1), '+', tarray1(2)
+        call doabort
+      end if
+      if (.not. issum (r2, tarray2(1), tarray2(2))) then
+        write (6,*) '*** DTIME didn''t return sum of the array: ',
+     +       r2, ' /= ', tarray2(1), '+', tarray2(2)
+        call doabort
+      end if
+      write (6, '(A,3F10.3)')
+     +     ' Elapsed total, user, system time (ETIME): ',
+     +     r1, tarray1
+
+c now try to get times to change enough to see in etime/dtime
+      write (6,*) 'Looping until clock ticks at least once...'
+      do i = 1,1000
+      do j = 1,1000
+      end do
+      call dtime (tarray2, r2)
+      if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
+      end do
+      call etime (tarray1, r1)
+      if (.not. issum (r1, tarray1(1), tarray1(2))) then
+        write (6,*) '*** ETIME didn''t return sum of the array: ',
+     +       r1, ' /= ', tarray1(1), '+', tarray1(2)
+        call doabort
+      end if
+      if (.not. issum (r2, tarray2(1), tarray2(2))) then
+        write (6,*) '*** DTIME didn''t return sum of the array: ',
+     +       r2, ' /= ', tarray2(1), '+', tarray2(2)
+        call doabort
+      end if
+      write (6, '(A,3F10.3)')
+     +     ' Differences in total, user, system time (DTIME): ',
+     +     r2, tarray2
+      write (6, '(A,3F10.3)')
+     +     ' Elapsed total, user, system time (ETIME): ',
+     +     r1, tarray1
+      write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
+
+      call idate (i,j,k)
+      call idate (idat)
+      write (6,*) 'IDATE (date,month,year): ',idat
+      print *,  '... and the VXT version (month,date,year): ', i,j,k
+      if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then
+        print *, '*** VXT and U77 versions don''t agree'
+        call doabort
+      end if
+
+      call date (ctim)
+      write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim))
+
+      call itime (idat)
+      write (6,*) 'ITIME (hour,minutes,seconds): ', idat
+
+      call time(line(:8))
+      print *, 'TIME: ', line(:8)
+
+      write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
+
+      write (6,*) 'SECOND returns: ', second()
+      call dumdum(r1)
+      call second(r1)
+      write (6,*) 'CALL SECOND returns: ', r1
+
+*     compiler crash fixed by 1998-10-01 com.c change
+      if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then
+        write (6,*) '*** rand(0) error'
+        call doabort()
+      end if
+
+      i = getcwd(wd)
+      if (i.ne.0) then
+        call perror ('*** getcwd')
+        call doabort
+      else
+        write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
+      end if
+      call chdir ('.',i)
+      if (i.ne.0) then
+        write (6,*) '***CHDIR to ".": ', i
+        call doabort
+      end if
+
+      i=hostnm(wd)
+      if(i.ne.0) then
+        call perror ('*** hostnm')
+        call doabort
+      else
+        write (6,*) 'Host name is ', wd(:lenstr(wd))
+      end if
+
+      i = access('/dev/null ', 'rw')
+      if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i
+      write (6,*) 'Creating file "foo" for testing...'
+      open (3,file='foo',status='UNKNOWN')
+      rewind 3
+      call fputc(3, 'c',i)
+      call fputc(3, 'd',j)      
+      if (i+j.ne.0) write(6,*) '***FPUTC: ', i
+C     why is it necessary to reopen?  (who wrote this?)
+C     the better to test with, my dear!  (-- burley)
+      close(3)
+      open(3,file='foo',status='old')
+      call fseek(3,0,0,*10)
+      go to 20
+ 10   write(6,*) '***FSEEK failed'
+      call doabort
+ 20   call fgetc(3, c,i)
+      if (i.ne.0) then
+        write(6,*) '***FGETC: ', i
+        call doabort
+      end if
+      if (c.ne.'c') then
+        write(6,*) '***FGETC read the wrong thing: ', ichar(c)
+        call doabort
+      end if
+      i= ftell(3)
+      if (i.ne.1) then
+        write(6,*) '***FTELL offset: ', i
+        call doabort
+      end if
+      call ftell(3, i)
+      if (i.ne.1) then
+        write(6,*) '***CALL FTELL offset: ', i
+        call doabort
+      end if
+      call chmod ('foo', 'a+w',i)
+      if (i.ne.0) then
+        write (6,*) '***CHMOD of "foo": ', i
+        call doabort
+      end if
+      i = fstat (3, fstatb)
+      if (i.ne.0) then
+        write (6,*) '***FSTAT of "foo": ', i
+        call doabort
+      end if
+      i = stat ('foo', statb)
+      if (i.ne.0) then
+        write (6,*) '***STAT of "foo": ', i
+        call doabort
+      end if
+      write (6,*) '  with stat array ', statb
+      if (statb(6) .ne. getgid ()) then
+        write (6,*) 'Note: FSTAT gid wrong (happens on some systems).'
+      end if
+      if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then
+        write (6,*) '*** FSTAT uid or nlink is wrong'
+        call doabort
+      end if
+      do i=1,13
+        if (fstatb (i) .ne. statb (i)) then
+          write (6,*) '*** FSTAT and STAT don''t agree on '// '
+     +         array element ', i, ' value ', fstatb (i), statb (i)
+          call abort
+        end if
+      end do
+      i = lstat ('foo', fstatb)
+      do i=1,13
+        if (fstatb (i) .ne. statb (i)) then
+          write (6,*) '*** LSTAT and STAT don''t agree on '//
+     +         'array element ', i, ' value ', fstatb (i), statb (i)
+          call abort
+        end if
+      end do
+
+C     in case it exists already:
+      call unlink ('bar',i)
+      call link ('foo ', 'bar ',i)
+      if (i.ne.0) then
+        write (6,*) '***LINK "foo" to "bar" failed: ', i
+        call doabort
+      end if
+      call unlink ('foo',i)
+      if (i.ne.0) then
+        write (6,*) '***UNLINK "foo" failed: ', i
+        call doabort
+      end if
+      call unlink ('foo',i)
+      if (i.eq.0) then
+        write (6,*) '***UNLINK "foo" again: ', i
+        call doabort
+      end if
+
+      call gerror (gerr)
+      i = ierrno()
+      write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
+     +     i,
+     +     ' and the corresponding message is:', gerr(:lenstr(gerr))
+      write (6,*) 'This is sent to stderr prefixed by the program name'
+      call getarg (0, line)
+      call perror (line (:lenstr (line)))
+      call unlink ('bar')
+
+      print *, 'MCLOCK returns ', mclock ()
+      print *, 'MCLOCK8 returns ', mclock8 ()
+
+      call cpu_time (d1)
+      print *, 'CPU_TIME returns ', d1
+
+C     WRITE (6,*) 'You should see exit status 1'
+      CALL EXIT(0)
+ 99   END
+
+* Return length of STR not including trailing blanks, but always > 0.
+      integer function lenstr (str)
+      character*(*) str
+      if (str.eq.' ') then
+        lenstr=1
+      else
+        lenstr = lnblnk (str)
+      end if
+      end
+
+* Just make sure SECOND() doesn't "magically" work the second time.
+      subroutine dumdum(r)
+      r = 3.14159
+      end
+
+* Test whether sum is approximately left+right.
+      logical function issum (sum, left, right)
+      implicit none
+      real sum, left, right
+      real mysum, delta, width
+      mysum = left + right
+      delta = abs (mysum - sum)
+      width = abs (left) + abs (right)
+      issum = (delta .le. .0001 * width)
+      end
+
+* Signal handler
+      subroutine ctrlc
+      print *, 'Got ^C'
+      call doabort
+      end
+
+* A problem has been noticed, so maybe abort the test.
+      subroutine doabort
+* For this version, call the ABORT intrinsic.
+      intrinsic abort
+      call abort
+      end
+
+* Testsuite version only.
+* Don't actually reference the HOSTNM intrinsic, because some targets
+* need -lsocket, which we don't have a mechanism for supplying.
+      integer function hostnm(nm)
+      character*(*) nm
+      nm = 'not determined by this version of u77-test.f'
+      hostnm = 0
+      end

gcc/testsuite/g77.f-torture/execute/u77-test.x

@@ -0,0 +1,12 @@
+# Various intrinsics not implemented and not implementable; will fail at
+# link time.
+
+if { [istarget "mmix-knuth-mmixware"]
+     || [istarget "arm*-*-elf"]
+     || [istarget "strongarm*-*-elf"]
+     || [istarget "xscale*-*-elf"]
+     || [istarget "cris-*-elf"] } {
+	set torture_compile_xfail [istarget]
+}
+
+return 0

gcc/testsuite/g77.f-torture/noncompile/19981216-0.f

@@ -0,0 +1,89 @@
+* Resent-From: Craig Burley <burley@gnu.org>
+* Resent-To: craig@jcb-sc.com
+* X-Delivered: at request of burley on mescaline.gnu.org
+* Date: Wed, 16 Dec 1998 18:31:24 +0100
+* From: Dieter Stueken <stueken@conterra.de>
+* Organization: con terra GmbH
+* To: fortran@gnu.org
+* Subject: possible bug
+* Content-Type: text/plain; charset=iso-8859-1
+* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085
+* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2
+* 
+* Hi,
+* 
+* I'm about to compile a very old, very ugly Fortran program.
+* For one part I got:
+* 
+* f77: Internal compiler error: program f771 got fatal signal 6
+* 
+* instead of any detailed error message. I was able to break down the
+* problem to the following source fragment:
+* 
+* -------------------------------------------
+        PROGRAM WAP
+
+        integer*2  ios
+        character*80  name
+
+        name = 'blah'
+        open(unit=8,status='unknown',file=name,form='formatted',
+     F       iostat=ios)
+
+      END
+* -------------------------------------------
+* 
+* The problem seems to be caused by the "integer*2 ios" declaration.
+* So far I solved it by simply using a plain integer instead.
+* 
+* I'm running gcc on a Linux system compiled/installed
+* with no special options:
+* 
+* -> g77 -v
+* g77 version 0.5.23
+* Driving: g77 -v -c -xf77-version /dev/null -xnone
+* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs
+* gcc version 2.8.1
+*  /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef
+* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__
+* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional
+* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__
+* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null
+* /dev/null
+* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF)
+* #include "..." search starts here:
+* #include <...> search starts here:
+*  /usr/local/include
+*  /usr/i686-pc-linux-gnulibc1/include
+*  /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include
+*  /usr/include
+* End of search list.
+*  /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version
+* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s
+* /dev/null
+* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version
+* 2.8.1.
+* GNU Fortran Front End version 0.5.23
+*  as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s
+* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1
+*  ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911
+* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o
+* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc
+* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o
+* /usr/lib/crtn.o
+*  /tmp/cca24911
+* __G77_LIBF77_VERSION__: 0.5.23
+* @(#)LIBF77 VERSION 19970919
+* __G77_LIBI77_VERSION__: 0.5.23
+* @(#) LIBI77 VERSION pjw,dmg-mods 19980405
+* __G77_LIBU77_VERSION__: 0.5.23
+* @(#) LIBU77 VERSION 19970919
+* 
+* 
+* Regards, Dieter.
+* -- 
+* Dieter Stüken, con terra GmbH, Münster
+*     stueken@conterra.de         stueken@qgp.uni-muenster.de
+*     http://www.conterra.de/     http://qgp.uni-muenster.de/~stueken
+*     (0)251-980-2027             (0)251-83-334974

gcc/testsuite/g77.f-torture/noncompile/19990218-1.f

@@ -0,0 +1,13 @@
+        double precision function fun(a,b)
+        double precision a,b
+        print*,'in sub: a,b=',a,b
+        fun=a*b
+        print*,'in sub: fun=',fun
+        return
+        end
+        program test
+        double precision a,b,c
+        data a,b/1.0d-46,1.0d0/
+        c=fun(a,b)
+        print*,'in main: fun=',c
+        end

gcc/testsuite/g77.f-torture/noncompile/19990826-4.f

@@ -0,0 +1,648 @@
+* Culled from 970528-1.f in Burley's g77 test suite.  Copyright
+* status not clear.  Feel free to chop down if the bug is still
+* reproducible (see end of test case for how bug shows up in gdb
+* run of f771).  No particular reason it should be a noncompile
+* case, other than that I didn't want to spend time "fixing" it
+* to compile cleanly (with -O0, which works) while making sure the
+* ICE remained reproducible.  -- burley 1999-08-26
+
+* Date: Mon, 26 May 1997 13:00:19 +0200 (GMT+0200)
+* From: "D. O'Donoghue" <dod@da.saao.ac.za>
+* To: Craig Burley <burley@gnu.ai.mit.edu>
+* Cc: fortran@gnu.ai.mit.edu
+* Subject: Re: g77 problems
+
+	program dophot
+	parameter (napple = 4)
+        common /window/nwindo,ixwin(50),iywin(50),iboxwin(50),itype(50)
+        common/io/luout,ludebg
+	common/search/nstot,thresh
+	common /fitparms / acc(npmax),alim(npmax),mit,mpar,mfit1,
+     +                     mfit2,ind(npmax)
+	common /starlist/ starpar(npmax,nsmax), imtype(nsmax),
+	1shadow(npmax,nsmax),shaderr(npmax,nsmax),idstr(nsmax)
+	common /aperlist/ apple(napple ,nsmax)
+	common /parpred / ava(npmax)
+	common /unitize / ufactor
+	common /undergnd/ nfast, nslow
+	common/bzero/ scale,zero
+	common /ctimes / chiimp, apertime, filltime, addtime
+	common / drfake / needit 
+	common /mfit/ psfpar(npmax),starx(nfmax),stary(nfmax),xlim,ylim
+	common /vers/ version
+ 	logical needit,screen,isub,loop,comd,burn,wrtres,fixedxy
+	logical fixed,piped,debug,ex,clinfo
+	character header*5760,rhead*2880
+	character yn*1,version*40,ccd*4,infile*20
+	character*30 numf,odir,record*80
+	integer*2 instr(8)
+	character*800 line
+	external pseud0d, pseud2d, pseud4d, pseudmd, shape
+C
+C	Initialization
+	data burn,   fixedxy,fixed,  piped 
+     +     /.false.,.false.,.false.,.false./
+	data needit,screen,comd,isub
+     + /.true.,.false.,.true.,.false. /
+	data acc / .01, -.03, -.03, .01, .03, .1, .03 /
+	data alim / -1.0e8, 2*-1.0e3, -1.0e8, 3*-1.0e3 /
+C
+	version = 'DoPHOT Version 1.0 LINUX May 97 '
+        debug=.false.
+        clinfo=.false.
+	line(1:800) = ' '
+	odir = ' '
+C
+C
+C	Read default tuneable parameters 
+	call tuneup ( nccd, ccd, piped, debug )
+	version(33:36) = ccd(1:4)
+C
+      
+        ludebg=6
+        if(piped)then
+          yn='n'
+        else
+	  write(*,'(''****************************************'')')
+	  write(*,1000) version
+	  write(*,'(''****************************************''//)')           
+C                                                             
+          write(*,'(''Screen output (y/[n])? '',$)')             
+	  read(*,1000) yn
+        end if
+	if(yn.eq.'y'.or.yn.eq.'Y') then
+          screen=.true.                
+          luout=6
+        else
+          luout=2
+        end if
+C
+        if(piped)then
+          yn='y'
+        else
+          write(*,'(''Batch mode ([y]/n)? '',$)')
+          read(*,1000) yn
+        end if
+	if(yn.eq.'n'.or.yn.eq.'N') comd = .false.
+C                                          
+	if(.not.comd) then                                     
+          write(*,
+     *         '(''Do you want windowing ([y]/n)? '',$)')
+          read(*,1000)yn
+          iwindo=1
+          if(yn.eq.'n'.or.yn.eq.'N')then
+            nwindo=0
+            iwindo=0
+          end if
+C
+          write(*,
+     *       '(''Star classification info (y/[n]) ?'',$)')
+          read(*,1000)yn
+          clinfo=.false.
+          if(yn.eq.'y'.or.yn.eq.'Y')clinfo=.true.
+C
+	  write(*,
+     *        '(''Create a star-subtracted frame (y/[n])? '',$)')
+	  read(*,1000) yn                                     
+ 	  if(yn.eq.'y'.or.yn.eq.'Y') isub = .true.
+C               
+	  write(*,'(''Apply after-burner (y/[n])? '',$)')
+	  read(*,1000) yn
+	  if ( yn.eq.'y'.or.yn.eq.'Y' ) burn = .true.
+	  wrtres = burn
+C
+	  write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)')
+	  read(*,1000) yn
+	  if ( yn.eq.'y'.or.yn.eq.'Y' ) then
+	    fixedxy = .true.
+	    fixed = .true.
+	    burn = .true.
+	    wrtres = .true.
+	  endif
+	endif         
+        iopen=0
+C
+C       This is the start of the loop over the input files
+c
+        iframe=0
+        open(10,file='timing',status='unknown',access='append')
+
+1	ifit = 0
+	iapr = 0
+	itmn = 0
+	model = 1
+	xc = 0.0
+	yc = 0.0
+	rc = 0.0
+	ibr = 0
+	ixy = 0
+C	
+        iframe=iframe+1
+        tgetpar=0.0
+        tsearch=0.0
+        tshape=0.0
+        timprove=0.0
+C
+C	Batch mode ...
+
+	if ( comd ) then
+          if(iopen.eq.0)then
+            iopen=1
+            open(11,file='dophot.bat',status='old',err=995)
+          end if
+          read(11,1000,end=999)infile
+c         now read in the parameter instructions. these are:
+c         instr(1) : if 1, specifies uncrowded field, otherwise crowded 
+c         instr(2) : if 1, specifies sequential frames of same field
+c                          with a window around the stars of interest -
+c                          all other objects are ignored
+c         instr(3) : if 0, takes cmin from dophot.inp (via tuneup)
+c                    if>0, sets cmin=instr(3)
+c         instr(4) : if 0, does nothing
+c                    if 1, then opens a file called classifications
+c                    sets clinfo to .true. and writes out the star
+c                    typing info to this file
+c         instr(5) : Delete the shd.nnnnnnn file
+c         instr(6) : Delete the out.nnnnnnn file
+c         instr(7) : Delete the input frame
+c         instr(8) : Create a star-subtracted frame 
+          read(11,*)instr
+          read(11,*)ifit,iapr,tmn,model,xc,yc,rc,ibr,ixy
+          nocrwd = instr(1)
+          iwindo=instr(2)
+          if(iwindo.eq.0)nwindo=0
+          itmn=tmn
+          if ( instr(3).gt.0 ) cmin=instr(3)
+          clinfo=.false.
+          if ( instr(4).gt.0 )then
+            clinfo=.true.
+            open(12,file='classifications',status='unknown')
+            ludebg=12
+          end if
+ 	  if ( instr(8).ne.0 ) then
+	    isub = .true.            
+	  else
+	    isub = .false.
+	  endif
+C
+	  if(ibr.ne.0) burn = .true.
+	  if(ixy.ne.0) then
+	    fixedxy = .true.
+	    fixed = .true.
+	    burn = .true.
+	    goto 20
+          endif
+          if(iwindo.eq.0)then
+            write(6,10)iframe,infile(1:15)
+   10       format('  ***** DoPHOT-ing frame ',i4,': ',a)
+            if(ludebg.eq.12)write(ludebg,11)iframe,infile(1:15)
+   11       format(////'  ',62('*')/
+     *                 '  *     DoPHOT-ing frame ',i4,': ',a,
+     *                 '                 *'/'  ',62('*'))
+          end if
+          if(iwindo.eq.1)then
+            write(6,12)iframe,infile(1:15)
+   12       format('  ***** DoPHOT-ing frame ',i4,': ',a,
+     *             '   - Windowed *****')
+            if(ludebg.eq.12)write(ludebg,13)iframe,infile(1:15)
+   13       format(////'  ',62('*')/
+     *                 '  *     DoPHOT-ing frame ',i4,': ',a,
+     *                 '   - Windowed    *'/2x,62('*'))
+          end if
+C
+C	Interactive...
+	else
+	  write(*,'(''Image name: '',$)')
+	  read(*,1000) infile
+	  if(infile(1:1).eq.' ') goto 999                     
+1000	  format(a)                          
+          write(*,'(''Crowded field mode ([y]/n) ? '',$)')
+          read(*,1000)yn
+          nocrwd=0
+          if(yn.eq.'n'.or.yn.eq.'N')nocrwd=1
+	  if(.not.fixed) then
+	    write(*,1001)
+1001        format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$)
+            read(*,1000)record
+            if(record.ne.' ')then
+	      read(record,*) model
+            else
+              model=1
+            end if
+	  else         
+	    burn=.true.
+	    goto 20           
+	  endif
+	endif
+C
+C       if windowing, open the file and read the window
+        if(iwindo.eq.1)then
+          inquire(file='windows',exist=ex)
+          if(.not.ex)go to 997
+          if(iframe.eq.1)open(9,file='windows',status='old')
+          nwindo=0
+    2     read(9,*,end=3)intype,inx,iny,inbox
+          nwindo=nwindo+1
+          if(nwindo.gt.50)then
+            print *,'too many windows - max = 50'
+            stop
+          end if
+          ixwin(nwindo)=inx
+          iywin(nwindo)=iny
+          iboxwin(nwindo)=inbox
+          itype(nwindo)=intype
+          go to 2
+
+    3     rewind 9
+          if(screen)print 4,(itype(j),ixwin(j),iywin(j),iboxwin(j),
+     *                       j=1,nwindo)
+    4     format(' Windows: Type   X    Y   Size'/
+     *           (I13,i6,i5,i5))
+        end if
+
+	t1 = cputime(0.0)
+C
+C	Read FITS frame.
+	call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line,ccd)
+C
+C	Ignore frame if not the correct chip
+	if(nc.lt.0) goto 900
+C                     
+C	Estimate starting PSF parameters.
+   15   call getparams(nfast,nslow,gxwid,gywid,skyval,tmin,tmax,
+     *                 iframe)
+        tgetpar = cputime(t1) + tgetpar
+        if(debug)write(ludebg,16)iframe,skyval,gxwid,gywid,tmin,tmax
+   16   format(' Getparams on frame ',i4,'  sky ',f6.1,'  gxwid ',f5.1,
+     *         '  gywid ',f5.1,'  tmin ',f5.1,'  tmax ',f5.1)
+C
+C	Initialize
+	do j=1,nsmax
+	  imtype(j) = 0
+	  do i=1,npmax  
+	    shadow(i,j)=0.                               
+	    shaderr(i,j)=0.
+	  enddo
+	enddo
+C              
+	skyguess=skyval
+	tfac = 1.0            
+C	Use 4.5 X SD as fitting width       
+	fitr=fitfac*(gxwid*asprat*gywid)**0.25 + 0.5                      
+	i=fitr
+	irect(1)=i
+	irect(2)=fitr/asprat 
+C	Use 4/3 X FitFac X SD as aperture width
+	gmax = asprat*gywid
+ 	if(gxwid.gt.gmax) gmax=gxwid
+	aprw = 1.33*fitfac*sqrt(gmax) + 0.5
+	i = aprw
+	arect(1) = i
+	i = aprw/asprat + 0.1
+	arect(2) = i          
+C                                     
+	if(irect(1).gt.50) irect(1)=50
+	if(irect(2).gt.50) irect(2)=50  
+	if(arect(1).gt.45.) arect(1)=45.
+	if(arect(2).gt.45.) arect(2)=45.
+C
+	if (screen) call htype(line,skyval,.false.,fitr,ngr,ncon)
+C
+C       Prompt for further information         
+	if ( .not.comd ) then
+          write(*,1002)
+ 1002     format(/'The above are the inital parameters DoPHOT'/
+     *            'has found. You can change them now or accept'/
+     *            'the values in [ ] by pressing enter'/)
+
+          write(*,1004)tmin
+ 1004     format('Enter Tmin: threshold for star detection',
+     *           ' [',f5.1,']  ',$)
+          read(*,1000)record
+          if(record.ne.' ')read(record,*)tmin
+
+          write(*,1005)cmin
+ 1005     format('Enter Cmin: threshold for PSF stars',
+     *           '      [',f5.1,']  ',$)
+          read(*,1000)record
+          if(record.ne.' ')read(record,*)cmin
+
+          write(*,1006)
+ 1006     format('Do you want to fix the aperture mag size ?',
+     *           ' (y/[n]) ')
+          read(*,1000)record
+          if(record.eq.'y'.or.record.eq.'Y')then
+            write(*,1007)
+ 1007       format('Enter the size in pixels: ',$)
+            read(*,*)iapr
+ 	    if(iapr.gt.0) then          
+              arect(1)=iapr
+              i = iapr/asprat + 0.1
+              arect(2)=i
+            end if
+	  endif                     
+C
+	  write(*,1008)
+ 1008     format('Satisfied with other input parameters ? ([y]/n)?',$)
+	  read(*,1000) yn        
+          if(yn.eq.'n'.or.yn.eq.'N')then
+            yn='n'
+          else
+            yn='y'
+          end if
+	  if(.not.(yn.eq.'y'.or.yn.eq.'Y') ) call input
+	else
+	  if ( ifit.ne.0 ) then
+	    irect(1)=ifit
+	    irect(2)=(ifit/asprat + 0.1)
+	  endif              
+	  if ( iapr.ne.0 ) then
+	    arect(1)=iapr
+	    i = iapr/asprat + 0.1
+	    arect(2)=i
+	  endif                                       
+	  if ( itmn.ne.0 ) tmin = itmn
+ 	  if ( .not.(xc.eq.0.0.and.yc.eq.0.0) ) then
+	    xcen = xc
+ 	    ycen = yc
+          endif
+	endif          
+C
+C--------------------------------
+C
+C
+	call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
+     +nfast, nslow )
+C
+C       if the uncrowded field option has been chosen, jump
+C       straight to the minimum threshold
+C
+        if(nocrwd.eq.1)tmax=tmin
+C             
+C	Adjust tfac so that thresh ends precisely on Tmin.
+	if(tmin/tmax .gt. 0.999) then
+	  thresh = tmin
+	  tfac = 1.          
+	else                                                     
+	  thresh = tmax
+	  xnum = alog10(tmax/tmin)/alog10(2.**tfac)
+	  if(xnum.gt.1.5) then
+	    xnum = float(nint(xnum))
+	  else if(xnum.ge.1) then               
+	    xnum = 2.0
+	  else             
+	    xnum = 1.0             
+	  endif                                         
+	  tfac = alog10(tmax/tmin)/alog10(2.)/xnum                   
+	endif
+C                       
+C------------------------------------------------------------------------
+C                            
+C         This is the BIG LOOP which searches the frame for stars
+C               with intensities > thresh.                
+C        
+C-----------------------------------------------------------------------
+C                           
+	loop = .true.
+	nstot = 0
+	do while ( loop )   
+	  loop = thresh/tmin .ge. 1.01
+	  write(luout,1050) thresh
+1050	  format(/20('-')/'THRESHOLD: ', f10.3)
+	  if(ludebg.eq.12)write(ludebg,1050) thresh
+C
+C         Fit given model to sky values.
+C
+          call varipar(nstot, nfast, nslow )            
+	  t1 = cputime(0.0)
+C               
+C         Identifies potential objects in cleaned array IMG
+ 	  nstar = isearch( pseud2d, nfast, nslow , clinfo)
+	  tsearch = cputime(t1) + tsearch
+C                                                                   
+    	  if ( (nstar .ne. 0).or.(xnum.lt.1.5) ) then
+C                                           
+C           Performs 7-parameter PSF fit and determines nature of object.
+	    t1 = cputime(0.0)
+	    call shape(pseud2d,pseud4d,nfast,nslow,clinfo)
+	    tshape = cputime(t1) + tshape
+C                           
+C           Computes average sky values etc from star list
+ 	    call paravg
+  	    t1 = cputime(0.0)
+C                                                          
+C           Computes 4-parameter fits for all stellar objects using 
+C           new average shape parameters.  
+  	    call improve(pseud2d,nfast,nslow,clinfo)
+	    timprove = cputime(t1) + timprove
+	  end if                         
+C
+C         Calculate aperture photometry on last pass.
+	  if(.not.loop) call aper ( pseud2d, nstot, nfast, nslow )
+C             
+ 	  totaltime = (tgetpar+tsearch+tshape+timprove)
+	  write(3,1060) totaltime
+ 	  write(4,1060) totaltime
+	  write(luout,1060) totaltime
+1060	  format('Total CPU time consumed:',F10.2,' seconds.')
+          write(10,1070)infile,tgetpar,tsearch,tshape,timprove,
+     *                  totaltime
+1070      format(a20,'   T(getp/f)',f5.1,'  T(search)',f5.1,
+     *               '  T(shape)',f5.1,'  T(improve)',f5.1,
+     *               '  Total',f6.1)
+	  call title (line,skyval,.false.,fitr,ngr,ncon,strint,ztot,nums)
+	  rewind(2)          
+ 	  rewind(3)                              
+  	  rewind(4)
+C
+	  call output ( line )
+C
+C         Now reduce the threshold and loop back
+C
+	  thresh = thresh/2.**tfac
+  	end do                   
+C                              
+C--------- END OF BIG LOOP ---------------------------------------
+C                      
+C	If after-burner required, residuals from analytic PSF are computed
+C	and stored in RES.
+C	
+20	if ( burn ) then
+C 	
+C	If using a fixed (X,Y) coordinate list, read it.
+	 if (fixed) then
+C	 Read the image frame
+ 	  call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line)
+C
+C	 Initialize arrays, open files etc.
+	  call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
+     +nfast, nslow )
+C
+C	 Read the XY list                                 
+	  write(luout,'(''Reading XY list ...'')')
+	  call xylist(numf, nc, ios )
+	  if(ios.ne.0) then
+	   fixed = .false.
+	   write(luout,'(''SXY file absent or incorrect...'')')
+	   goto 15
+	  endif
+C
+	  call htype(line,skyval,.false.,fitr,ngr,ncon)
+C
+C	 Remove good stars
+	  write(luout,'(''Cleaning frame of stars: '',i8)') nstot
+	  call clean ( pseud2d, nstot, nfast, nslow, -1)
+C             
+C	Calculate aperture photometry
+C	  call aper ( pseud2d, nstot, nfast, nslow )
+	 else            
+	   rewind(3)
+	   rewind(4)         
+	 endif 
+C             
+C-----------------------
+C	Flag all stars close together in groups.  Keep making the distance
+C	criterion FITR smaller until the maximum number in a group is less
+C	than NFMAX         
+C                      
+	 fitr = amax1(arect(1),arect(2))
+	 fitr = fitr + 2.0      
+	 nmax = 10000 
+	 write(*,'(''Regrouping ...'')')
+C              
+	 do while ( nmax.gt.nfmax )
+  	  fitr = fitr - 1.0       
+	  write(luout,'(''Min distance ='',f8.1)') fitr
+	  call regroup( fitr, ngr, nmax )     
+	 enddo
+C
+	 xlim = irect(1)/2 
+	 ylim = irect(2)/2
+C
+C	Calculate normalized PSF residual from PSEUD2D
+	 call getres (pseud0d,pseud2d,strint,rmn,rmx,nfast,nslow,irect,
+     +arect,ztot,nums)
+	 if(nums.eq.0) then
+	  write(luout,'(''No suitable PSF stars!'')')
+	  goto 30
+	 endif
+C
+	 write(luout,'(/''AFTERBURNER tuned ON!'')')
+C
+C	Fit multiple stars in a group with enhanced PSF using box size IRECT.
+	 call mulfit( pseud2d,pseudmd,ngr,ncon,nfast,nslow,irect )        
+C
+C	Re-calculate aperture photometry
+	 call aperm ( pseudmd, nstot, nfast, nslow )
+C
+	 call skyadj ( nstot )
+C
+ 	 call title (line,skyval,.true.,fitr,ngr,ncon,strint,ztot,nums)
+	 call output ( line )
+	endif 
+C---------------------                                                
+C
+C-----  This section skipped if PSF residual not written out ------
+C                     
+30	if( isub ) then
+C
+C	Write final Cleaned array.
+ 	 infile = 'x'//numf(1:nc)//'.fits'
+	 call putfits(2,infile,header,nhead,nfast,nslow)
+	 close(2)                 
+C             
+C	If afterburner used, then residual array also written out.
+C	Find suitable scale for writing residual PSF to FITS "R" file.
+C
+ 	 if ( wrtres ) then
+	  scale=20000.0/(rmx-rmn)
+	  zero=-scale*rmn   
+	  do j=-nres,nres
+  	   jj=nres+j+1   
+	   do i=-nres,nres
+  	    ii=nres+i+1                                  
+	    big(ii,jj)=scale*res(i,j)+zero
+	   enddo
+	  enddo
+	  nx=2*nres+1  
+C
+	  infile = 'r'//numf(1:nc)//'.fits'
+  	  zer=-zero/scale
+ 	  scl=1.0/scale            
+C                                           
+C	Create a FITS header for the normalized PSF residual image    
+	  call sethead(rhead,numf,nx,nx,zer,scl)
+ 	  scale=1.0             
+	  zero=0.0    
+C	Write the normalized PSF residual image
+	  call putfits(2,infile,rhead,1,nx,nx)
+	  close(2)
+	 endif
+C                        
+	end if
+C                     
+C                     
+900	close(1)
+	close(3)                                 
+ 	close(4)
+	if ( .not.screen ) close(luout)
+	if(comd) then
+          if(instr(5).eq.1)call system('rm shd.'//numf(1:nc))
+          if(instr(6).eq.1)call system('rm out.'//numf(1:nc))
+          n=1
+          do while(infile(n:n).ne.' ')
+            n=n+1
+          end do
+          if(instr(7).eq.1)call system('rm '//infile(1:n-1))
+        end if
+	fixed = fixedxy
+	goto 1
+C
+995     print 996
+996     format(/'*** Fatal error ***'/
+     *          'You asked for batch processing but'/
+     *          'I cant open the "dophot.bat" file.'/
+     *          'Please make one (using batchdophot)'/
+     *          'and restart DoPHOT'/)
+        go to 999
+
+C
+997     print 998
+998     format(/'*** Fatal error ***'/
+     *          'You asked for "windowed" processing'/
+     *          'but I cant open the "windows" file.'/
+     *          'Please make one and restart DoPHOT'/)
+
+999	call exit(0)
+	end
+
+* (gdb) r
+* Starting program: /home3/craig/gnu/f77-e/gcc/f771 -quiet < ../../play/19990826-4.f -O
+* [...]
+* Breakpoint 2, fancy_abort (
+*     file=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line=4399,
+*     function=0x82860df "output_fp_cc0_set") at ../../g77-e/gcc/rtl.c:1010
+* (gdb) up
+* #1  0x8222fab in output_fp_cc0_set (insn=0x8382324)
+*     at ../../g77-e/gcc/config/i386/i386.c:4399
+* (gdb) p insn
+* $1 = 0x3a
+* (gdb) up
+* #2  0x8222b81 in output_float_compare (insn=0x8382324, operands=0x82acc60)
+*     at ../../g77-e/gcc/config/i386/i386.c:4205
+* (gdb) p insn
+* $2 = 0x8382324
+* (gdb) whatis insn
+* type = rtx
+* (gdb) pr
+* (insn 2181 2180 2191 (parallel[
+*             (set (cc0)
+*                 (compare (reg:SF 8 %st(0))
+*                     (mem:SF (plus:SI (reg:SI 6 %ebp)
+*                             (const_int -9948 [0xffffd924])) 0)))
+*             (clobber (reg:HI 0 %ax))
+*         ] ) 29 {*cmpsf_cc_1} (insn_list 2173 (insn_list 2173 (nil)))
+*     (expr_list:REG_DEAD (reg:DF 8 %st(0))
+*         (expr_list:REG_UNUSED (reg:HI 0 %ax)
+*             (nil))))
+* (gdb)

gcc/testsuite/g77.f-torture/noncompile/19990905-1.f

@@ -0,0 +1,8 @@
+* =foo7.f in Burley's g77 test suite.
+      subroutine x
+      real a(n)
+      common /foo/n
+      continue
+      entry y(a)
+      call foo(a(1))
+      end

gcc/testsuite/g77.f-torture/noncompile/9263.f

@@ -0,0 +1,7 @@
+      PARAMETER (Q=1)
+      PARAMETER (P=10)
+      INTEGER C(10),D(10),E(10),F(10)
+      DATA (C(I),I=1,P)      /10*10/  ! TERMINAL NOT INTEGER
+      DATA (D(I),I=Q,10)     /10*10/  ! START NOT INTEGER
+      DATA (E(I),I=1,10,Q)   /10*10/  ! INCREMENT NOT INTEGER
+      END

gcc/testsuite/g77.f-torture/noncompile/970626-2.f

@@ -0,0 +1,4 @@
+      SUBROUTINE A(A,ALPHA,IA)
+      COMPLEX  A(IA,*), ALPHA(*)
+      ALPHA(I)=A(I,I).ZERO)
+      END

gcc/testsuite/g77.f-torture/noncompile/980615-0.f

@@ -0,0 +1,10 @@
+* Fixed by JCB 1998-07-25 change to stc.c.
+
+* Date: Thu, 11 Jun 1998 22:35:20 -0500
+* From: Ian A Watson <WATSON_IAN_A@lilly.com>
+* Subject: crash
+* 
+      CaLL foo(W)
+      END
+      SUBROUTINE foo(W)
+      yy(I)=A(I)Q(X)

gcc/testsuite/g77.f-torture/noncompile/980616-0.f

@@ -0,0 +1,8 @@
+* Fixed by 1998-07-11 equiv.c change.
+* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER'
+
+* Date: Mon, 15 Jun 1998 21:54:32 -0500
+* From: Ian A Watson <WATSON_IAN_A@lilly.com>
+* Subject: Mangler Crash
+      EQUIVALENCE(I,glerf(P))
+      COMMON /foo/ glerf(3)

gcc/testsuite/g77.f-torture/noncompile/check0.f

@@ -0,0 +1,11 @@
+CCC Abort fixed by:
+CCC1998-04-21  Jim Wilson  <wilson@cygnus.com>
+CCC
+CCC        * stmt.c (check_seenlabel): When search for line number note for
+CCC        warning, handle case where there is no such note.
+      logical l(10)
+      integer i(10)
+      goto (10,20),l
+      goto (10,20),i
+ 10   stop
+ 20   end

gcc/testsuite/g77.f-torture/noncompile/noncompile.exp

@@ -0,0 +1,36 @@
+#   Copyright (C) 1988, 90, 91, 92, 97, 1998 Free Software Foundation, Inc.
+
+# This program 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.
+# 
+# This program 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 this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
+
+# This file was written by Jeff Law. (law@cs.utah.edu)
+
+#
+# These tests come from Torbjorn Granlund (tege@cygnus.com)
+# C torture test suite.
+#
+
+load_lib mike-g77.exp
+
+# Test check0.f
+prebase
+
+set src_code check0.f
+# Not really sure what the error should be here...
+set compiler_output ".*:8.*:9"
+
+set groups {passed gcc-noncompile}
+
+postbase $src_code $run $groups
+

gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f

@@ -0,0 +1,10 @@
+       integer*1 one
+       integer*2 two
+       parameter (one=1)
+       parameter (two=2)
+       select case (I)
+       case (one)
+       case (two)
+       end select
+       end
+    

libjava/doc/cni.sgml

@@ -0,0 +1,996 @@
+<!DOCTYPE article PUBLIC "-//Davenport//DTD DocBook V3.0//EN">
+<article>
+<artheader>
+<title>The Cygnus Native Interface for C++/Java Integration</title>
+<subtitle>Writing native Java methods in natural C++</subtitle>
+<authorgroup>
+<corpauthor>Cygnus Solutions</corpauthor>
+</authorgroup>
+<date>March, 2000</date>
+</artheader>
+
+<abstract><para>
+This documents CNI, the Cygnus Native Interface,
+which is is a convenient way to write Java native methods using C++.
+This is a more efficient, more convenient, but less portable
+alternative to the standard JNI (Java Native Interface).</para>
+</abstract>
+
+<sect1><title>Basic Concepts</title>
+<para>
+In terms of languages features, Java is mostly a subset
+of C++.  Java has a few important extensions, plus a powerful standard
+class library, but on the whole that does not change the basic similarity.
+Java is a hybrid object-oriented language, with a few native types,
+in addition to class types.  It is class-based, where a class may have
+static as well as per-object fields, and static as well as instance methods.
+Non-static methods may be virtual, and may be overloaded.  Overloading is
+resolved at compile time by matching the actual argument types against
+the parameter types.  Virtual methods are implemented using indirect calls
+through a dispatch table (virtual function table).  Objects are
+allocated on the heap, and initialized using a constructor method.
+Classes are organized in a package hierarchy.
+</para>
+<para>
+All of the listed attributes are also true of C++, though C++ has
+extra features (for example in C++ objects may be allocated not just
+on the heap, but also statically or in a local stack frame).  Because
+<acronym>gcj</acronym> uses the same compiler technology as
+<acronym>g++</acronym> (the GNU C++ compiler), it is possible
+to make the intersection of the two languages use the same
+<acronym>ABI</acronym> (object representation and calling conventions).
+The key idea in <acronym>CNI</acronym> is that Java objects are C++ objects,
+and all Java classes are C++ classes (but not the other way around).
+So the most important task in integrating Java and C++ is to
+remove gratuitous incompatibilities.
+</para>
+<para>
+You write CNI code as a regular C++ source file.  (You do have to use
+a Java/CNI-aware C++ compiler, specifically a recent version of G++.)</para>
+<para>
+You start with:
+<programlisting>
+#include &lt;gcj/cni.h&gt;
+</programlisting></para>
+
+<para>
+You then include header files for the various Java classes you need
+to use:
+<programlisting>
+#include &lt;java/lang/Character.h&gt;
+#include &lt;java/util/Date.h&gt;
+#include &lt;java/lang/IndexOutOfBoundsException.h&gt;
+</programlisting></para>
+
+<para>
+In general, <acronym>CNI</acronym> functions and macros start with the
+`<literal>Jv</literal>' prefix, for example the function
+`<literal>JvNewObjectArray</literal>'.  This convention is used to
+avoid conflicts with other libraries.
+Internal functions in <acronym>CNI</acronym> start with the prefix
+`<literal>_Jv_</literal>'.  You should not call these;
+if you find a need to, let us know and we will try to come up with an
+alternate solution.  (This manual lists <literal>_Jv_AllocBytes</literal>
+as an example;  <acronym>CNI</acronym> should instead provide
+a <literal>JvAllocBytes</literal> function.)</para>
+<para>
+These header files are automatically generated by <command>gcjh</command>.
+</para>
+</sect1>
+
+<sect1><title>Packages</title>
+<para>
+The only global names in Java are class names, and packages.
+A <firstterm>package</firstterm> can contain zero or more classes, and
+also zero or more sub-packages.
+Every class belongs to either an unnamed package or a package that
+has a hierarchical and globally unique name.
+</para>
+<para>
+A Java package is mapped to a C++ <firstterm>namespace</firstterm>.
+The Java class <literal>java.lang.String</literal>
+is in the package <literal>java.lang</literal>, which is a sub-package
+of <literal>java</literal>.  The C++ equivalent is the
+class <literal>java::lang::String</literal>,
+which is in the namespace <literal>java::lang</literal>,
+which is in the namespace <literal>java</literal>.
+</para>
+<para>
+Here is how you could express this:
+<programlisting>
+// Declare the class(es), possibly in a header file:
+namespace java {
+  namespace lang {
+    class Object;
+    class String;
+    ...
+  }
+}
+
+class java::lang::String : public java::lang::Object
+{
+  ...
+};
+</programlisting>
+</para>
+<para>
+The <literal>gcjh</literal> tool automatically generates the
+nessary namespace declarations.</para>
+
+<sect2><title>Nested classes as a substitute for namespaces</title>
+<para>
+<!-- FIXME the next line reads poorly jsm -->
+It is not that long since g++ got complete namespace support,
+and it was very recent (end of February 1999) that <literal>libgcj</literal>
+was changed to uses namespaces.  Releases before then used
+nested classes, which are the C++ equivalent of Java inner classes.
+They provide similar (though less convenient) functionality.
+The old syntax is:
+<programlisting>
+class java {
+  class lang {
+    class Object;
+    class String;
+  };
+};
+</programlisting>
+The obvious difference is the use of <literal>class</literal> instead
+of <literal>namespace</literal>.  The more important difference is
+that all the members of a nested class have to be declared inside
+the parent class definition, while namespaces can be defined in
+multiple places in the source.  This is more convenient, since it
+corresponds more closely to how Java packages are defined.
+The main difference is in the declarations; the syntax for
+using a nested class is the same as with namespaces:
+<programlisting>
+class java::lang::String : public java::lang::Object
+{ ... }
+</programlisting>
+Note that the generated code (including name mangling)
+using nested classes is the same as that using namespaces.</para>
+</sect2>
+
+<sect2><title>Leaving out package names</title>
+<para>
+<!-- FIXME next line reads poorly jsm -->
+Having to always type the fully-qualified class name is verbose.
+It also makes it more difficult to change the package containing a class.
+The Java <literal>package</literal> declaration specifies that the
+following class declarations are in the named package, without having
+to explicitly name the full package qualifiers.
+The <literal>package</literal> declaration can be followed by zero or
+more <literal>import</literal> declarations, which allows either
+a single class or all the classes in a package to be named by a simple
+identifier.  C++ provides something similar
+with the <literal>using</literal> declaration and directive.
+</para>
+<para>
+A Java simple-type-import declaration:
+<programlisting>
+import <replaceable>PackageName</replaceable>.<replaceable>TypeName</replaceable>;
+</programlisting>
+allows using <replaceable>TypeName</replaceable> as a shorthand for
+<literal><replaceable>PackageName</replaceable>.<replaceable>TypeName</replaceable></literal>.
+The C++ (more-or-less) equivalent is a <literal>using</literal>-declaration:
+<programlisting>
+using <replaceable>PackageName</replaceable>::<replaceable>TypeName</replaceable>;
+</programlisting>
+</para>
+<para>
+A Java import-on-demand declaration:
+<programlisting>
+import <replaceable>PackageName</replaceable>.*;
+</programlisting>
+allows using <replaceable>TypeName</replaceable> as a shorthand for
+<literal><replaceable>PackageName</replaceable>.<replaceable>TypeName</replaceable></literal>
+The C++ (more-or-less) equivalent is a <literal>using</literal>-directive:
+<programlisting>
+using namespace <replaceable>PackageName</replaceable>;
+</programlisting>
+</para>
+</sect2>
+</sect1>
+
+<sect1><title>Primitive types</title>
+<para>
+Java provides 8 <quote>primitives</quote> types:
+<literal>byte</literal>, <literal>short</literal>, <literal>int</literal>,
+<literal>long</literal>, <literal>float</literal>, <literal>double</literal>,
+<literal>char</literal>, and <literal>boolean</literal>.
+These are the same as the following C++ <literal>typedef</literal>s
+(which are defined by <literal>gcj/cni.h</literal>):
+<literal>jbyte</literal>, <literal>jshort</literal>, <literal>jint</literal>,
+<literal>jlong</literal>, <literal>jfloat</literal>,
+<literal>jdouble</literal>,
+<literal>jchar</literal>, and <literal>jboolean</literal>.
+You should use the C++ typenames
+(<ForeignPhrase><Abbrev>e.g.</Abbrev></ForeignPhrase> <literal>jint</literal>),
+and not the Java types names
+(<ForeignPhrase><Abbrev>e.g.</Abbrev></ForeignPhrase> <literal>int</literal>),
+even if they are <quote>the same</quote>.
+This is because there is no guarantee that the C++ type
+<literal>int</literal> is a 32-bit type, but <literal>jint</literal>
+<emphasis>is</emphasis> guaranteed to be a 32-bit type.
+
+<informaltable frame="all" colsep="1" rowsep="0">
+<tgroup cols="3">
+<thead>
+<row>
+<entry>Java type</entry>
+<entry>C/C++ typename</entry>
+<entry>Description</entry>
+</thead>
+<tbody>
+<row>
+<entry>byte</entry>
+<entry>jbyte</entry>
+<entry>8-bit signed integer</entry>
+</row>
+<row>
+<entry>short</entry>
+<entry>jshort</entry>
+<entry>16-bit signed integer</entry>
+</row>
+<row>
+<entry>int</entry>
+<entry>jint</entry>
+<entry>32-bit signed integer</entry>
+</row>
+<row>
+<entry>long</entry>
+<entry>jlong</entry>
+<entry>64-bit signed integer</entry>
+</row>
+<row>
+<entry>float</entry>
+<entry>jfloat</entry>
+<entry>32-bit IEEE floating-point number</entry>
+</row>
+<row>
+<entry>double</entry>
+<entry>jdouble</entry>
+<entry>64-bit IEEE floating-point number</entry>
+</row>
+<row>
+<entry>char</entry>
+<entry>jchar</entry>
+<entry>16-bit Unicode character</entry>
+</row>
+<row>
+<entry>boolean</entry>
+<entry>jboolean</entry>
+<entry>logical (Boolean) values</entry>
+</row>
+<row>
+<entry>void</entry>
+<entry>void</entry>
+<entry>no value</entry>
+</row>
+</tbody></tgroup>
+</informaltable>
+</para>
+
+<para>
+<funcsynopsis>
+<funcdef><function>JvPrimClass</function></funcdef>
+<paramdef><parameter>primtype</parameter></paramdef>
+</funcsynopsis>
+This is a macro whose argument should be the name of a primitive
+type, <ForeignPhrase><Abbrev>e.g.</Abbrev></ForeignPhrase>
+<literal>byte</literal>.
+The macro expands to a pointer to the <literal>Class</literal> object
+corresponding to the primitive type.
+<ForeignPhrase><Abbrev>E.g.</Abbrev></ForeignPhrase>,
+<literal>JvPrimClass(void)</literal>
+has the same value as the Java expression
+<literal>Void.TYPE</literal> (or <literal>void.class</literal>).
+</para>
+
+</sect1>
+
+<sect1><title>Objects and Classes</title>
+<sect2><title>Classes</title>
+<para>
+All Java classes are derived from <literal>java.lang.Object</literal>.
+C++ does not have a unique <quote>root</quote>class, but we use
+a C++ <literal>java::lang::Object</literal> as the C++ version
+of the <literal>java.lang.Object</literal> Java class.  All
+other Java classes are mapped into corresponding C++ classes
+derived from <literal>java::lang::Object</literal>.</para>
+<para>
+Interface inheritance (the <quote><literal>implements</literal></quote>
+keyword) is currently not reflected in the C++ mapping.</para>
+</sect2>
+<sect2><title>Object references</title>
+<para>
+We implement a Java object reference as a pointer to the start
+of the referenced object.  It maps to a C++ pointer.
+(We cannot use C++ references for Java references, since
+once a C++ reference has been initialized, you cannot change it to
+point to another object.)
+The <literal>null</literal> Java reference maps to the <literal>NULL</literal>
+C++ pointer.
+</para>
+<para>
+Note that in some Java implementations an object reference is implemented as
+a pointer to a two-word <quote>handle</quote>.  One word of the handle
+points to the fields of the object, while the other points
+to a method table.  Gcj does not use this extra indirection.
+</para>
+</sect2>
+<sect2><title>Object fields</title>
+<para>
+Each object contains an object header, followed by the instance
+fields of the class, in order.  The object header consists of
+a single pointer to a dispatch or virtual function table.
+(There may be extra fields <quote>in front of</quote> the object,
+for example for
+memory management, but this is invisible to the application, and
+the reference to the object points to the dispatch table pointer.)
+</para>
+<para>
+The fields are laid out in the same order, alignment, and size
+as in C++.  Specifically, 8-bite and 16-bit native types
+(<literal>byte</literal>, <literal>short</literal>, <literal>char</literal>,
+and <literal>boolean</literal>) are <emphasis>not</emphasis>
+widened to 32 bits.
+Note that the Java VM does extend 8-bit and 16-bit types to 32 bits
+when on the VM stack or temporary registers.</para>
+<para>
+If you include the <literal>gcjh</literal>-generated header for a
+class, you can access fields of Java classes in the <quote>natural</quote>
+way.  Given the following Java class:
+<programlisting>
+public class Int
+{
+  public int i;
+  public Integer (int i) { this.i = i; }
+  public static zero = new Integer(0);
+}
+</programlisting>
+you can write:
+<programlisting>
+#include &lt;gcj/cni.h&gt;
+#include &lt;Int.h&gt;
+Int*
+mult (Int *p, jint k)
+{
+  if (k == 0)
+    return Int::zero;  // static member access.
+  return new Int(p->i * k);
+}
+</programlisting>
+</para>
+<para>
+<acronym>CNI</acronym> does not strictly enforce the Java access
+specifiers, because Java permissions cannot be directly mapped
+into C++ permission.  Private Java fields and methods are mapped
+to private C++ fields and methods, but other fields and methods
+are mapped to public fields and methods.
+</para>
+</sect2>
+</sect1>
+
+<sect1><title>Arrays</title>
+<para>
+While in many ways Java is similar to C and C++,
+it is quite different in its treatment of arrays.
+C arrays are based on the idea of pointer arithmetic,
+which would be incompatible with Java's security requirements.
+Java arrays are true objects (array types inherit from
+<literal>java.lang.Object</literal>).  An array-valued variable
+is one that contains a reference (pointer) to an array object.
+</para>
+<para>
+Referencing a Java array in C++ code is done using the
+<literal>JArray</literal> template, which as defined as follows:
+<programlisting>
+class __JArray : public java::lang::Object
+{
+public:
+  int length;
+};
+
+template&lt;class T&gt;
+class JArray : public __JArray
+{
+  T data[0];
+public:
+  T&amp; operator[](jint i) { return data[i]; }
+};
+</programlisting></para>
+<para>
+<funcsynopsis> 
+   <funcdef>template&lt;class T&gt;  T *<function>elements</function></funcdef>
+   <paramdef>JArray&lt;T&gt; &amp;<parameter>array</parameter></paramdef>
+</funcsynopsis>
+   This template function can be used to get a pointer to the
+   elements of the <parameter>array</parameter>.
+   For instance, you can fetch a pointer
+   to the integers that make up an <literal>int[]</literal> like so:
+<programlisting>
+extern jintArray foo;
+jint *intp = elements (foo);
+</programlisting>
+The name of this function may change in the future.</para>
+<para>
+There are a number of typedefs which correspond to typedefs from JNI.
+Each is the type of an array holding objects of the appropriate type:
+<programlisting>
+typedef __JArray *jarray;
+typedef JArray&lt;jobject&gt; *jobjectArray;
+typedef JArray&lt;jboolean&gt; *jbooleanArray;
+typedef JArray&lt;jbyte&gt; *jbyteArray;
+typedef JArray&lt;jchar&gt; *jcharArray;
+typedef JArray&lt;jshort&gt; *jshortArray;
+typedef JArray&lt;jint&gt; *jintArray;
+typedef JArray&lt;jlong&gt; *jlongArray;
+typedef JArray&lt;jfloat&gt; *jfloatArray;
+typedef JArray&lt;jdouble&gt; *jdoubleArray;
+</programlisting>
+</para>
+<para>
+ You can create an array of objects using this function:
+<funcsynopsis> 
+   <funcdef>jobjectArray <function>JvNewObjectArray</function></funcdef>
+   <paramdef>jint <parameter>length</parameter></paramdef>
+   <paramdef>jclass <parameter>klass</parameter></paramdef>
+   <paramdef>jobject <parameter>init</parameter></paramdef>
+   </funcsynopsis>
+   Here <parameter>klass</parameter> is the type of elements of the array;
+   <parameter>init</parameter> is the initial
+   value to be put into every slot in the array.
+</para>
+<para>
+For each primitive type there is a function which can be used
+   to create a new array holding that type.  The name of the function
+   is of the form
+   `<literal>JvNew&lt;<replaceable>Type</replaceable>&gt;Array</literal>',
+   where `&lt;<replaceable>Type</replaceable>&gt;' is the name of
+   the primitive type, with its initial letter in upper-case.  For
+   instance, `<literal>JvNewBooleanArray</literal>' can be used to create
+   a new array of booleans.
+   Each such function follows this example:
+<funcsynopsis>  
+   <funcdef>jbooleanArray <function>JvNewBooleanArray</function></funcdef> 
+   <paramdef>jint <parameter>length</parameter></paramdef>
+</funcsynopsis>
+</para>
+<para>
+<funcsynopsis>
+   <funcdef>jsize <function>JvGetArrayLength</function></funcdef>
+   <paramdef>jarray <parameter>array</parameter></paramdef> 
+   </funcsynopsis>
+   Returns the length of <parameter>array</parameter>.</para>
+</sect1>
+
+<sect1><title>Methods</title>
+
+<para>
+Java methods are mapped directly into C++ methods.
+The header files generated by <literal>gcjh</literal>
+include the appropriate method definitions.
+Basically, the generated methods have the same names and
+<quote>corresponding</quote> types as the Java methods,
+and are called in the natural manner.</para>
+
+<sect2><title>Overloading</title>
+<para>
+Both Java and C++ provide method overloading, where multiple
+methods in a class have the same name, and the correct one is chosen
+(at compile time) depending on the argument types.
+The rules for choosing the correct method are (as expected) more complicated
+in C++ than in Java, but given a set of overloaded methods
+generated by <literal>gcjh</literal> the C++ compiler will choose
+the expected one.</para>
+<para>
+Common assemblers and linkers are not aware of C++ overloading,
+so the standard implementation strategy is to encode the
+parameter types of a method into its assembly-level name.
+This encoding is called <firstterm>mangling</firstterm>,
+and the encoded name is the <firstterm>mangled name</firstterm>.
+The same mechanism is used to implement Java overloading.
+For C++/Java interoperability, it is important that both the Java
+and C++ compilers use the <emphasis>same</emphasis> encoding scheme.
+</para>
+</sect2>
+
+<sect2><title>Static methods</title>
+<para>
+Static Java methods are invoked in <acronym>CNI</acronym> using the standard
+C++ syntax, using the `<literal>::</literal>' operator rather
+than the `<literal>.</literal>' operator.  For example:
+</para>
+<programlisting>
+jint i = java::lang::Math::round((jfloat) 2.3);
+</programlisting>
+<para>
+<!-- FIXME this next sentence seems ungammatical jsm -->
+Defining a static native method uses standard C++ method
+definition syntax.  For example:
+<programlisting>
+#include &lt;java/lang/Integer.h&gt;
+java::lang::Integer*
+java::lang::Integer::getInteger(jstring str)
+{
+  ...
+}
+</programlisting>
+</sect2>
+
+<sect2><title>Object Constructors</title>
+<para>
+Constructors are called implicitly as part of object allocation
+using the <literal>new</literal> operator.  For example:
+<programlisting> 
+java::lang::Int x = new java::lang::Int(234);
+</programlisting> 
+</para>
+<para>
+<!-- FIXME rewrite needed here, mine may not be good jsm -->
+Java does not allow a constructor to be a native method.
+Instead, you could define a private method which
+you can have the constructor call.
+</para>
+</sect2>
+
+<sect2><title>Instance methods</title>
+<para>
+<!-- FIXME next para week, I would remove a few words from some sentences jsm -->
+Virtual method dispatch is handled essentially the same way
+in C++ and Java -- <abbrev>i.e.</abbrev> by doing an
+indirect call through a function pointer stored in a per-class virtual
+function table.  C++ is more complicated because it has to support
+multiple inheritance, but this does not effect Java classes.
+However, G++ has historically used a different calling convention
+that is not compatible with the one used by <acronym>gcj</acronym>.
+During 1999, G++ will switch to a new ABI that is compatible with
+<acronym>gcj</acronym>.  Some platforms (including Linux) have already
+changed.  On other platforms, you will have to pass
+the <literal>-fvtable-thunks</literal> flag to g++ when
+compiling <acronym>CNI</acronym> code.  Note that you must also compile
+your C++ source code with <literal>-fno-rtti</literal>.
+</para>
+<para>
+Calling a Java instance method in <acronym>CNI</acronym> is done
+using the standard C++ syntax.  For example:
+<programlisting>
+  java::lang::Number *x;
+  if (x-&gt;doubleValue() &gt; 0.0) ...
+</programlisting>
+</para>
+<para>
+Defining a Java native instance method is also done the natural way:
+<programlisting>
+#include &lt;java/lang/Integer.h&gt;
+jdouble
+java::lang:Integer::doubleValue()
+{
+  return (jdouble) value;
+}
+</programlisting>
+</para>
+</sect2>
+
+<sect2><title>Interface method calls</title>
+<para>
+In Java you can call a method using an interface reference.
+This is not yet supported in <acronym>CNI</acronym>.</para>
+</sect2>
+</sect1>
+
+<sect1><title>Object allocation</title>
+
+<para>
+New Java objects are allocated using a
+<firstterm>class-instance-creation-expression</firstterm>:
+<programlisting>
+new <replaceable>Type</replaceable> ( <replaceable>arguments</replaceable> )
+</programlisting>
+The same syntax is used in C++.  The main difference is that
+C++ objects have to be explicitly deleted; in Java they are
+automatically deleted by the garbage collector.
+Using <acronym>CNI</acronym>, you can allocate a new object
+using standard C++ syntax.  The C++ compiler is smart enough to
+realize the class is a Java class, and hence it needs to allocate
+memory from the garbage collector.  If you have overloaded
+constructors, the compiler will choose the correct one
+using standard C++ overload resolution rules.  For example:
+<programlisting>
+java::util::Hashtable *ht = new java::util::Hashtable(120);
+</programlisting>
+</para>
+<para>
+<funcsynopsis>
+  <funcdef>void *<function>_Jv_AllocBytes</function></funcdef>
+  <paramdef>jsize <parameter>size</parameter></paramdef>
+</funcsynopsis>
+   Allocate <parameter>size</parameter> bytes.  This memory is not
+   scanned by the garbage collector.  However, it will be freed by
+the GC if no references to it are discovered.
+</para>
+</sect1>
+
+<sect1><title>Interfaces</title>
+<para>
+A Java class can <firstterm>implement</firstterm> zero or more
+<firstterm>interfaces</firstterm>, in addition to inheriting from
+a single base class. 
+An interface is a collection of constants and method specifications;
+it is similar to the <firstterm>signatures</firstterm> available
+as a G++ extension.  An interface provides a subset of the
+functionality of C++ abstract virtual base classes, but they
+are currently implemented differently.
+CNI does not currently provide any support for interfaces,
+or calling methods from an interface pointer.
+This is partly because we are planning to re-do how
+interfaces are implemented in <acronym>gcj</acronym>.
+</para>
+</sect1>
+
+<sect1><title>Strings</title>
+<para>
+<acronym>CNI</acronym> provides a number of utility functions for
+working with Java <literal>String</literal> objects.
+The names and interfaces are analogous to those of <acronym>JNI</acronym>.
+</para>
+
+<para>
+<funcsynopsis>
+  <funcdef>jstring <function>JvNewString</function></funcdef>
+  <paramdef>const jchar *<parameter>chars</parameter></paramdef>
+  <paramdef>jsize <parameter>len</parameter></paramdef>
+  </funcsynopsis>
+  Creates a new Java String object, where
+  <parameter>chars</parameter> are the contents, and
+  <parameter>len</parameter> is the number of characters.
+</para>
+
+<para>
+<funcsynopsis>
+  <funcdef>jstring <function>JvNewStringLatin1</function></funcdef>
+  <paramdef>const char *<parameter>bytes</parameter></paramdef>
+  <paramdef>jsize <parameter>len</parameter></paramdef>
+ </funcsynopsis>
+  Creates a new Java String object, where <parameter>bytes</parameter>
+  are the Latin-1 encoded
+  characters, and <parameter>len</parameter> is the length of
+  <parameter>bytes</parameter>, in bytes.
+</para>
+
+<para>
+<funcsynopsis>
+  <funcdef>jstring <function>JvNewStringLatin1</function></funcdef>
+  <paramdef>const char *<parameter>bytes</parameter></paramdef>
+  </funcsynopsis>
+  Like the first JvNewStringLatin1, but computes <parameter>len</parameter>
+  using <literal>strlen</literal>.
+</para>
+
+<para>
+<funcsynopsis>
+  <funcdef>jstring <function>JvNewStringUTF</function></funcdef>
+  <paramdef>const char *<parameter>bytes</parameter></paramdef>
+  </funcsynopsis>
+   Creates a new Java String object, where <parameter>bytes</parameter> are
+   the UTF-8 encoded characters of the string, terminated by a null byte.
+</para>
+
+<para>
+<funcsynopsis>
+   <funcdef>jchar *<function>JvGetStringChars</function></funcdef>
+  <paramdef>jstring <parameter>str</parameter></paramdef>
+  </funcsynopsis>
+   Returns a pointer to the array of characters which make up a string.
+</para>
+
+<para>
+<funcsynopsis>
+   <funcdef> int <function>JvGetStringUTFLength</function></funcdef>
+  <paramdef>jstring <parameter>str</parameter></paramdef>
+  </funcsynopsis>
+   Returns number of bytes required to encode contents
+   of <parameter>str</parameter> as UTF-8.
+</para>
+
+<para>
+<funcsynopsis>
+  <funcdef> jsize <function>JvGetStringUTFRegion</function></funcdef>
+  <paramdef>jstring <parameter>str</parameter></paramdef>
+  <paramdef>jsize <parameter>start</parameter></paramdef>
+  <paramdef>jsize <parameter>len</parameter></paramdef>
+  <paramdef>char *<parameter>buf</parameter></paramdef>
+  </funcsynopsis>
+  This puts the UTF-8 encoding of a region of the
+  string <parameter>str</parameter> into
+  the buffer <parameter>buf</parameter>.
+  The region of the string to fetch is specifued by
+  <parameter>start</parameter> and <parameter>len</parameter>.
+   It is assumed that <parameter>buf</parameter> is big enough
+   to hold the result.  Note
+   that <parameter>buf</parameter> is <emphasis>not</emphasis> null-terminated.
+</para>
+</sect1>
+
+<sect1><title>Class Initialization</title>
+<para>
+Java requires that each class be automatically initialized at the time 
+of the first active use.  Initializing a class involves 
+initializing the static fields, running code in class initializer 
+methods, and initializing base classes.  There may also be 
+some implementation specific actions, such as allocating 
+<classname>String</classname> objects corresponding to string literals in
+the code.</para>
+<para>
+The Gcj compiler inserts calls to <literal>JvInitClass</literal> (actually
+<literal>_Jv_InitClass</literal>) at appropriate places to ensure that a
+class is initialized when required.  The C++ compiler does not
+insert these calls automatically - it is the programmer's
+responsibility to make sure classes are initialized.  However,
+this is fairly painless because of the conventions assumed by the Java
+system.</para>
+<para>
+First, <literal>libgcj</literal> will make sure a class is initialized
+before an instance of that object is created.  This is one
+of the responsibilities of the <literal>new</literal> operation.  This is
+taken care of both in Java code, and in C++ code.  (When the G++
+compiler sees a <literal>new</literal> of a Java class, it will call
+a routine in <literal>libgcj</literal> to allocate the object, and that
+routine will take care of initializing the class.)  It follows that you can
+access an instance field, or call an instance (non-static)
+method and be safe in the knowledge that the class and all
+of its base classes have been initialized.</para>
+<para>
+Invoking a static method is also safe.  This is because the
+Java compiler adds code to the start of a static method to make sure
+the class is initialized.  However, the C++ compiler does not
+add this extra code.  Hence, if you write a native static method
+using CNI, you are responsible for calling <literal>JvInitClass</literal>
+before doing anything else in the method (unless you are sure
+it is safe to leave it out).</para>
+<para>
+Accessing a static field also requires the class of the
+field to be initialized.  The Java compiler will generate code
+to call <literal>_Jv_InitClass</literal> before getting or setting the field.
+However, the C++ compiler will not generate this extra code,
+so it is your responsibility to make sure the class is
+initialized before you access a static field.</para>
+</sect1>
+<sect1><title>Exception Handling</title>
+<para>
+While C++ and Java share a common exception handling framework,
+things are not yet perfectly integrated.  The main issue is that the
+<quote>run-time type information</quote> facilities of the two
+languages are not integrated.</para>
+<para>
+Still, things work fairly well.  You can throw a Java exception from
+C++ using the ordinary <literal>throw</literal> construct, and this
+exception can be caught by Java code.  Similarly, you can catch an
+exception thrown from Java using the C++ <literal>catch</literal>
+construct.
+<para>
+Note that currently you cannot mix C++ catches and Java catches in
+a single C++ translation unit.  We do intend to fix this eventually.
+</para>
+<para>
+Here is an example:
+<programlisting>
+if (i >= count)
+   throw new java::lang::IndexOutOfBoundsException();
+</programlisting>
+</para>
+<para>
+Normally, GNU C++ will automatically detect when you are writing C++
+code that uses Java exceptions, and handle them appropriately.
+However, if C++ code only needs to execute destructors when Java
+exceptions are thrown through it, GCC will guess incorrectly.  Sample
+problematic code:
+<programlisting>
+  struct S { ~S(); };
+  extern void bar();    // is implemented in Java and may throw exceptions
+  void foo()
+  {
+    S s;
+    bar();
+  }
+</programlisting>
+The usual effect of an incorrect guess is a link failure, complaining of
+a missing routine called <literal>__gxx_personality_v0</literal>.
+</para>
+<para>
+You can inform the compiler that Java exceptions are to be used in a
+translation unit, irrespective of what it might think, by writing
+<literal>#pragma GCC java_exceptions</literal> at the head of the
+file.  This <literal>#pragma</literal> must appear before any
+functions that throw or catch exceptions, or run destructors when
+exceptions are thrown through them.</para>
+</sect1>
+
+<sect1><title>Synchronization</title>
+<para>
+Each Java object has an implicit monitor.
+The Java VM uses the instruction <literal>monitorenter</literal> to acquire
+and lock a monitor, and <literal>monitorexit</literal> to release it.
+The JNI has corresponding methods <literal>MonitorEnter</literal>
+and <literal>MonitorExit</literal>.  The corresponding CNI macros
+are <literal>JvMonitorEnter</literal> and <literal>JvMonitorExit</literal>.
+</para>
+<para>
+The Java source language does not provide direct access to these primitives.
+Instead, there is a <literal>synchronized</literal> statement that does an
+implicit <literal>monitorenter</literal> before entry to the block,
+and does a <literal>monitorexit</literal> on exit from the block.
+Note that the lock has to be released even the block is abnormally
+terminated by an exception, which means there is an implicit
+<literal>try</literal>-<literal>finally</literal>.
+</para>
+<para>
+From C++, it makes sense to use a destructor to release a lock.
+CNI defines the following utility class.
+<programlisting>
+class JvSynchronize() {
+  jobject obj;
+  JvSynchronize(jobject o) { obj = o; JvMonitorEnter(o); }
+  ~JvSynchronize() { JvMonitorExit(obj); }
+};
+</programlisting>
+The equivalent of Java's:
+<programlisting>
+synchronized (OBJ) { CODE; }
+</programlisting>
+can be simply expressed:
+<programlisting>
+{ JvSynchronize dummy(OBJ); CODE; }
+</programlisting>
+</para>
+<para>
+Java also has methods with the <literal>synchronized</literal> attribute.
+This is equivalent to wrapping the entire method body in a
+<literal>synchronized</literal> statement.
+(Alternatively, an implementation could require the caller to do
+the synchronization.  This is not practical for a compiler, because
+each virtual method call would have to test at run-time if
+synchronization is needed.)  Since in <literal>gcj</literal>
+the <literal>synchronized</literal> attribute is handled by the
+method implementation, it is up to the programmer
+of a synchronized native method to handle the synchronization
+(in the C++ implementation of the method).
+In otherwords, you need to manually add <literal>JvSynchronize</literal>
+in a <literal>native synchornized</literal> method.</para>
+</sect1>
+
+<sect1><title>Reflection</title>
+<para>The types <literal>jfieldID</literal> and <literal>jmethodID</literal>
+are as in JNI.</para>
+<para>
+The function <literal>JvFromReflectedField</literal>,
+<literal>JvFromReflectedMethod</literal>,
+<literal>JvToReflectedField</literal>, and
+<literal>JvToFromReflectedMethod</literal> (as in Java 2 JNI)
+will be added shortly, as will other functions corresponding to JNI.</para>
+
+<sect1><title>Using gcjh</title>
+<para>
+      The <command>gcjh</command> is used to generate C++ header files from
+      Java class files.  By default, <command>gcjh</command> generates
+      a relatively straightforward C++ header file.  However, there
+      are a few caveats to its use, and a few options which can be
+      used to change how it operates:
+</para>
+<variablelist>
+<varlistentry>
+<term><literal>--classpath</literal> <replaceable>path</replaceable></term>
+<term><literal>--CLASSPATH</literal> <replaceable>path</replaceable></term>
+<term><literal>-I</literal> <replaceable>dir</replaceable></term>
+<listitem><para>
+        These options can be used to set the class path for gcjh.
+        Gcjh searches the class path the same way the compiler does;
+	these options have their familiar meanings.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry>
+<term><literal>-d <replaceable>directory</replaceable></literal></term>
+<listitem><para>
+Puts the generated <literal>.h</literal> files
+beneath <replaceable>directory</replaceable>.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry>
+<term><literal>-o <replaceable>file</replaceable></literal></term>
+<listitem><para>
+        Sets the name of the <literal>.h</literal> file to be generated.
+        By default the <literal>.h</literal> file is named after the class.
+        This option only really makes sense if just a single class file
+        is specified.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry>
+<term><literal>--verbose</literal></term>
+<listitem><para>
+        gcjh will print information to stderr as it works.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry>
+<term><literal>-M</literal></term>
+<term><literal>-MM</literal></term>
+<term><literal>-MD</literal></term>
+<term><literal>-MMD</literal></term>
+<listitem><para>
+        These options can be used to generate dependency information
+        for the generated header file.  They work the same way as the
+        corresponding compiler options.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry>
+<term><literal>-prepend <replaceable>text</replaceable></literal></term>
+<listitem><para>
+This causes the <replaceable>text</replaceable> to be put into the generated
+        header just after class declarations (but before declaration
+        of the current class).  This option should be used with caution.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry> 
+<term><literal>-friend <replaceable>text</replaceable></literal></term>
+<listitem><para>
+This causes the <replaceable>text</replaceable> to be put into the class
+declaration after a <literal>friend</literal> keyword.
+This can be used to declare some
+        other class or function to be a friend of this class.
+        This option should be used with caution.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry>  
+<term><literal>-add <replaceable>text</replaceable></literal></term>
+<listitem><para>
+The <replaceable>text</replaceable> is inserted into the class declaration.
+This option should be used with caution.</para>
+</listitem>
+</varlistentry>
+
+<varlistentry> 
+<term><literal>-append <replaceable>text</replaceable></literal></term>
+<listitem><para>
+The <replaceable>text</replaceable> is inserted into the header file
+after the class declaration.  One use for this is to generate
+inline functions.  This option should be used with caution.
+</listitem>
+</varlistentry>
+</variablelist>
+<para>
+All other options not beginning with a <literal>-</literal> are treated
+as the names of classes for which headers should be generated.</para>
+<para>
+gcjh will generate all the required namespace declarations and
+<literal>#include</literal>'s for the header file.
+In some situations, gcjh will generate simple inline member
+functions.  Note that, while gcjh puts <literal>#pragma
+interface</literal> in the generated header file, you should
+<emphasis>not</emphasis> put <literal>#pragma implementation</literal>
+into your C++ source file.  If you do, duplicate definitions of
+inline functions will sometimes be created, leading to link-time
+errors.
+</para>
+<para>
+There are a few cases where gcjh will fail to work properly:</para>
+<para>
+gcjh assumes that all the methods and fields of a class have ASCII
+names.  The C++ compiler cannot correctly handle non-ASCII
+identifiers.  gcjh does not currently diagnose this problem.</para>
+<para>
+gcjh also cannot fully handle classes where a field and a method have
+the same name.  If the field is static, an error will result.
+Otherwise, the field will be renamed in the generated header; `__'
+will be appended to the field name.</para>
+<para>
+Eventually we hope to change the C++ compiler so that these
+restrictions can be lifted.</para>
+</sect1>
+
+</article>

libjava/gnu/javax/rmi/CORBA/DelegateFactory.java

@@ -0,0 +1,74 @@
+/* DelegateFactory.java -- 
+   Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath 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.
+
+GNU Classpath 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 GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package gnu.javax.rmi.CORBA;
+
+import java.util.HashMap;
+import javax.rmi.CORBA.Util;
+
+public class DelegateFactory
+{
+  private static HashMap cache = new HashMap(4);
+    
+  public static synchronized Object getInstance(String type)
+    throws GetDelegateInstanceException
+  {
+    Object r = cache.get(type);
+    if (r != null)
+      return r;
+    String dcname = System.getProperty("javax.rmi.CORBA." + type + "Class");
+    if (dcname == null)
+      {
+	//throw new DelegateException
+	//  ("no javax.rmi.CORBA.XXXClass property sepcified.");
+	dcname = "gnu.javax.rmi.CORBA." + type + "DelegateImpl";
+      }
+    try
+      {
+	Class dclass = Class.forName(dcname);
+	r = dclass.newInstance();
+	cache.put(type, r);
+	return r;
+      }
+    catch(Exception e)
+      {
+	throw new GetDelegateInstanceException
+	  ("Exception when trying to get delegate instance:" + dcname, e);
+      }
+  }
+}

libjava/gnu/javax/rmi/CORBA/GetDelegateInstanceException.java

@@ -0,0 +1,58 @@
+/* GetDelegateInstanceException.java -- 
+   Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath 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.
+
+GNU Classpath 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 GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package gnu.javax.rmi.CORBA;
+
+import java.io.PrintStream;
+import java.io.PrintWriter;
+
+public class GetDelegateInstanceException
+  extends Exception
+{
+  private Throwable next;
+  
+  public GetDelegateInstanceException(String msg)
+  {
+    super(msg);
+  }
+  
+  public GetDelegateInstanceException(String msg, Throwable next)
+  {
+    super(msg, next);
+  }
+}

libjava/gnu/javax/rmi/CORBA/PortableRemoteObjectDelegateImpl.java

@@ -0,0 +1,133 @@
+/* PortableRemoteObjectDelegateImpl.java -- 
+   Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath 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.
+
+GNU Classpath 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 GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package gnu.javax.rmi.CORBA;
+
+import java.rmi.*;
+import java.rmi.server.*;
+import gnu.javax.rmi.*;
+import javax.rmi.CORBA.*;
+
+public class PortableRemoteObjectDelegateImpl
+  implements PortableRemoteObjectDelegate
+{
+    
+  public PortableRemoteObjectDelegateImpl()
+  {
+  }
+
+  public void connect(Remote remote, Remote remote1)
+    throws RemoteException
+  {
+    throw new Error("Not implemented for PortableRemoteObjectDelegateImpl");
+  }
+        
+  public void exportObject(Remote obj)
+    throws RemoteException
+  {
+    PortableServer.exportObject(obj);
+  }
+
+  public Object narrow(Object narrowFrom, Class narrowTo)
+    throws ClassCastException
+  {
+    if (narrowTo == null)
+      throw new ClassCastException("Can't narrow to null class");
+    if (narrowFrom == null)
+      return null;
+
+    Class fromClass = narrowFrom.getClass();
+    Object result = null;
+        
+    try
+      {
+	if (narrowTo.isAssignableFrom(fromClass))
+	  result = narrowFrom;
+	else
+	  {
+	    System.out.println("We still haven't implement this case: narrow "
+			       + narrowFrom + " of type " + fromClass + " to "
+			       + narrowTo);
+	    Class[] cs = fromClass.getInterfaces();
+	    for (int i = 0; i < cs.length; i++)
+	      System.out.println(cs[i]);
+	    Exception e1 = new Exception();
+	    try
+	      {
+		throw e1;
+	      }
+	    catch(Exception ee)
+	      {
+		ee.printStackTrace();
+	      }
+	    System.exit(2);
+	    //throw new Error("We still haven't implement this case: narrow "
+	    //                + narrowFrom + " of type " + fromClass + " to "
+	    //                + narrowTo);
+	    /*
+	      ObjectImpl objimpl = (ObjectImpl)narrowFrom;
+	      if(objimpl._is_a(PortableServer.getTypeName(narrowTo)))
+	      result = PortableServer.getStubFromObjectImpl(objimpl, narrowTo);
+	    */
+	  }
+      }
+    catch(Exception e)
+      {
+	result = null;
+      }
+        
+    if (result == null)
+      throw new ClassCastException("Can't narrow from "
+				   + fromClass + " to " + narrowTo);
+            
+    return result;
+  }
+        
+  public Remote toStub(Remote obj)
+    throws NoSuchObjectException
+  {
+    return PortableServer.toStub(obj);
+  }
+
+  public void unexportObject(Remote obj)
+    throws NoSuchObjectException
+  {
+    PortableServer.unexportObject(obj);
+  }
+
+}

libjava/gnu/javax/rmi/CORBA/StubDelegateImpl.java

@@ -0,0 +1,113 @@
+/* StubDelegateImpl.java -- 
+   Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath 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.
+
+GNU Classpath 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 GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package gnu.javax.rmi.CORBA;
+
+import java.io.IOException;
+import java.io.ObjectInputStream;
+import java.io.ObjectOutputStream;
+//import org.omg.CORBA.portable.Delegate;
+//import org.omg.CORBA.portable.InputStream;
+//import org.omg.CORBA.portable.OutputStream;
+//import org.omg.CORBA_2_3.portable.ObjectImpl;
+//import org.omg.CORBA.portable.ObjectImpl;
+//import org.omg.CORBA.BAD_OPERATION;
+//import org.omg.CORBA.ORB;
+import java.rmi.RemoteException;
+import javax.rmi.CORBA.Stub;
+import javax.rmi.CORBA.StubDelegate;
+import javax.rmi.CORBA.Tie;
+import javax.rmi.CORBA.StubDelegate;
+
+public class StubDelegateImpl
+  implements StubDelegate
+{
+
+  private int hashCode;
+    
+  public StubDelegateImpl(){
+    hashCode = 0;   
+  }
+  // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
+  public void connect(Stub self, javax.rmi.ORB orb)
+    throws RemoteException
+  {
+    throw new Error("Not implemented for StubDelegate");
+  }
+
+  public boolean equals(Stub self, Object obj)
+  {
+    if(self == null || obj == null)
+      return self == obj;
+    if(!(obj instanceof Stub))
+      return false;
+    return self.hashCode() == ((Stub)obj).hashCode();
+  }
+
+  public int hashCode(Stub self)
+  {
+    //FIX ME
+    return hashCode;
+  }
+
+  public String toString(Stub self)
+  {
+    try
+      {
+	return self._orb().object_to_string(self);
+      }
+    // XXX javax.rmi.BAD_OPERATION -> org.omg.CORBA.BAD_OPERATION
+    catch(javax.rmi.BAD_OPERATION bad_operation)
+      {
+	return null;
+      }
+  }
+
+  public void readObject(Stub self, ObjectInputStream s)
+    throws IOException, ClassNotFoundException
+  {
+    throw new Error("Not implemented for StubDelegate");
+  }
+
+  public void writeObject(Stub self, ObjectOutputStream s)
+    throws IOException
+  {
+    throw new Error("Not implemented for StubDelegate");
+  }
+    
+}

libjava/gnu/javax/rmi/CORBA/UtilDelegateImpl.java

@@ -0,0 +1,152 @@
+/* UtilDelegateImpl.java -- 
+   Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath 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.
+
+GNU Classpath 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 GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package gnu.javax.rmi.CORBA;
+
+import java.rmi.Remote;
+import java.rmi.RemoteException;
+import java.rmi.server.RMIClassLoader;
+import java.net.MalformedURLException;
+import java.io.*;
+//import org.omg.CORBA.ORB;
+//import org.omg.CORBA.SystemException;
+//import org.omg.CORBA.portable.InputStream;
+//import org.omg.CORBA.portable.OutputStream;
+import javax.rmi.CORBA.*;
+
+public class UtilDelegateImpl
+  implements UtilDelegate
+{
+  // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
+  public Object copyObject(Object obj, javax.rmi.ORB orb)
+    throws RemoteException
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+
+  // XXX javax.rmi.ORB -> org.omg.CORBA.ORB
+  public Object[] copyObjects(Object obj[], javax.rmi.ORB orb)
+    throws RemoteException
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+
+  public ValueHandler createValueHandler()
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public String getCodebase(Class clz)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public Tie getTie(Remote target)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public boolean isLocal(Stub stub)
+    throws RemoteException
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+
+  public Class loadClass(String className, String remoteCodebase,
+		  	 ClassLoader loader)
+    throws ClassNotFoundException
+  {
+    try{
+      if (remoteCodebase == null)
+	return RMIClassLoader.loadClass(className);
+      else
+	return RMIClassLoader.loadClass(remoteCodebase, className);
+    }
+    catch (MalformedURLException e1)
+      {
+	throw new ClassNotFoundException(className, e1);
+      }
+    catch(ClassNotFoundException e2)
+      {
+	if(loader != null)
+	  return loader.loadClass(className);
+	else
+	  return null;
+      }
+  }
+
+  public RemoteException mapSystemException(SystemException ex)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+
+  public Object readAny(InputStream in)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+
+  public void registerTarget(Tie tie, Remote target)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public void unexportObject(Remote target)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public RemoteException wrapException(Throwable orig)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public void writeAbstractObject(OutputStream out, Object obj)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+    
+  public void writeAny(OutputStream out, Object obj)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+
+  public void writeRemoteObject(OutputStream out, Object obj)
+  {
+    throw new Error("Not implemented for UtilDelegate");
+  }
+}

libjava/gnu/javax/rmi/CORBA/ValueHandlerImpl.java

@@ -0,0 +1,82 @@
+/* ValueHandlerImpl.java -- 
+   Copyright (C) 2002 Free Software Foundation, Inc.
+
+This file is part of GNU Classpath.
+
+GNU Classpath 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.
+
+GNU Classpath 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 GNU Classpath; see the file COPYING.  If not, write to the
+Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+02111-1307 USA.
+
+Linking this library statically or dynamically with other modules is
+making a combined work based on this library.  Thus, the terms and
+conditions of the GNU General Public License cover the whole
+combination.
+
+As a special exception, the copyright holders of this library give you
+permission to link this library with independent modules to produce an
+executable, regardless of the license terms of these independent
+modules, and to copy and distribute the resulting executable under
+terms of your choice, provided that you also meet, for each linked
+independent module, the terms and conditions of the license of that
+module.  An independent module is a module which is not derived from
+or based on this library.  If you modify this library, you may extend
+this exception to your version of the library, but you are not
+obligated to do so.  If you do not wish to do so, delete this
+exception statement from your version. */
+
+
+package gnu.javax.rmi.CORBA;
+
+import java.io.*;
+//import org.omg.CORBA.portable.InputStream;
+//import org.omg.CORBA.portable.OutputStream;
+//import org.omg.SendingContext.RunTime;
+import javax.rmi.CORBA.ValueHandler;
+
+public class ValueHandlerImpl
+  implements ValueHandler
+{
+
+  public String getRMIRepositoryID(Class clz)
+  {
+    throw new Error("Not implemented for ValueHandler");
+  }
+
+  // XXX - Runtime -> RunTime
+  public Runtime getRunTimeCodeBase()
+  {
+    throw new Error("Not implemented for ValueHandler");
+  }
+    
+  public boolean isCustomMarshaled(Class clz)
+  {
+    throw new Error("Not implemented for ValueHandler");
+  }   
+    
+  // XXX - Runtime -> RunTime
+  public Serializable readValue(InputStream in, int offset, Class clz, String repositoryID, Runtime sender)
+  {
+    throw new Error("Not implemented for ValueHandler");
+  }
+    
+  public Serializable writeReplace(Serializable value)
+  {
+    throw new Error("Not implemented for ValueHandler");
+  }
+    
+  public void writeValue(OutputStream out, Serializable value)
+  {
+    throw new Error("Not implemented for ValueHandler");
+  }
+}