git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Imported from mainline FSF repositories 

From-SVN: r94600
This commit is contained in:
Nick Clifton 2005-02-02 19:06:59 +00:00
parent 55967ba27b
commit b919490c9c
152 changed files with 132562 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/config/dsp16xx/dsp16xx-modes.def Normal file
View File

@ -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);

86
gcc/config/dsp16xx/dsp16xx-protos.h Normal file
View File

@ -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);

2632
gcc/config/dsp16xx/dsp16xx.c Normal file
View File

File diff suppressed because it is too large Load Diff

1768
gcc/config/dsp16xx/dsp16xx.h Normal file
View File

File diff suppressed because it is too large Load Diff

3049
gcc/config/dsp16xx/dsp16xx.md Normal file
View File

File diff suppressed because it is too large Load Diff

125
gcc/config/i370/README Normal file
View File

@ -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

64
gcc/config/i370/i370-c.c Normal file
View File

@ -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

55
gcc/config/i370/i370-protos.h Normal file
View File

@ -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 */

1514
gcc/config/i370/i370.c Normal file
View File

File diff suppressed because it is too large Load Diff

1863
gcc/config/i370/i370.h Normal file
View File

File diff suppressed because it is too large Load Diff

4739
gcc/config/i370/i370.md Normal file
View File

File diff suppressed because it is too large Load Diff

113
gcc/config/i370/linux.h Normal file
View File

@ -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 */

49
gcc/config/i370/mvs.h Normal file
View File

@ -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

53
gcc/config/i370/oe.h Normal file
View File

@ -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)

3
gcc/config/i370/t-i370 Normal file
View File

@ -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

117
gcc/config/i960/i960-c.c Normal file
View File

@ -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;
}

43
gcc/config/i960/i960-coff.h Normal file
View File

@ -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 */

33
gcc/config/i960/i960-modes.def Normal file
View File

@ -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);

102
gcc/config/i960/i960-protos.h Normal file
View File

@ -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 */

2917
gcc/config/i960/i960.c Normal file
View File

File diff suppressed because it is too large Load Diff

1404
gcc/config/i960/i960.h Normal file
View File

File diff suppressed because it is too large Load Diff

2818
gcc/config/i960/i960.md Normal file
View File

File diff suppressed because it is too large Load Diff

29
gcc/config/i960/rtems.h Normal file
View File

@ -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)

30
gcc/config/i960/t-960bare Normal file
View File

@ -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

7315
gcc/f/ChangeLog Normal file
View File

File diff suppressed because it is too large Load Diff

4806
gcc/f/ChangeLog.0 Normal file
View File

File diff suppressed because it is too large Load Diff

516
gcc/f/Make-lang.in Normal file
View File

@ -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)

5
gcc/f/RELEASE-PREP Normal file
View File

@ -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.

190
gcc/f/ansify.c Normal file
View File

@ -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;
}

537
gcc/f/bad.c Normal file
View File

@ -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);
}

1103
gcc/f/bad.def Normal file
View File

File diff suppressed because it is too large Load Diff

106
gcc/f/bad.h Normal file
View File

@ -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 */

200
gcc/f/bit.c Normal file
View File

@ -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;
}
}

84
gcc/f/bit.h Normal file
View File

@ -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 */

69
gcc/f/bld-op.def Normal file
View File

@ -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)

3135
gcc/f/bld.c Normal file
View File

File diff suppressed because it is too large Load Diff

748
gcc/f/bld.h Normal file
View File

@ -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 */

260
gcc/f/bugs.texi Normal file
View File

@ -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

9
gcc/f/bugs0.texi Normal file
View File

@ -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

289
gcc/f/com-rt.def Normal file
View File

@ -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)

16525
gcc/f/com.c Normal file
View File

File diff suppressed because it is too large Load Diff

290
gcc/f/com.h Normal file
View File

@ -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 */

36
gcc/f/config-lang.in Normal file
View File

@ -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"

1877
gcc/f/data.c Normal file
View File

File diff suppressed because it is too large Load Diff

74
gcc/f/data.h Normal file
View File

@ -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 */

1484
gcc/f/equiv.c Normal file
View File

File diff suppressed because it is too large Load Diff

100
gcc/f/equiv.h Normal file
View File

@ -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 */

18571
gcc/f/expr.c Normal file
View File

File diff suppressed because it is too large Load Diff

194
gcc/f/expr.h Normal file
View File

@ -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 */

2063
gcc/f/ffe.texi Normal file
View File

File diff suppressed because it is too large Load Diff

772
gcc/f/fini.c Normal file
View File

@ -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]);
}

11848
gcc/f/g77.texi Normal file
View File

File diff suppressed because it is too large Load Diff

541
gcc/f/g77spec.c Normal file
View File

@ -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 }
};

1586
gcc/f/global.c Normal file
View File

File diff suppressed because it is too large Load Diff

193
gcc/f/global.h Normal file
View File

@ -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 */

383
gcc/f/implic.c Normal file
View File

@ -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)
{
}

74
gcc/f/implic.h Normal file
View File

@ -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 */

36
gcc/f/info-b.def Normal file
View File

@ -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", "~")

41
gcc/f/info-k.def Normal file
View File

@ -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", "~")

41
gcc/f/info-w.def Normal file
View File

@ -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", "~")

303
gcc/f/info.c Normal file
View File

@ -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

186
gcc/f/info.h Normal file
View File

@ -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 */

1325
gcc/f/intdoc.c Normal file
View File

File diff suppressed because it is too large Load Diff

2705
gcc/f/intdoc.in Normal file
View File

File diff suppressed because it is too large Load Diff

10931
gcc/f/intdoc.texi Normal file
View File

File diff suppressed because it is too large Load Diff

2119
gcc/f/intrin.c Normal file
View File

File diff suppressed because it is too large Load Diff

3358
gcc/f/intrin.def Normal file
View File

File diff suppressed because it is too large Load Diff

135
gcc/f/intrin.h Normal file
View File

@ -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 */

2233
gcc/f/invoke.texi Normal file
View File

File diff suppressed because it is too large Load Diff

157
gcc/f/lab.c Normal file
View File

@ -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;
}

152
gcc/f/lab.h Normal file
View File

@ -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 */

47
gcc/f/lang-specs.h Normal file
View File

@ -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},

402
gcc/f/lang.opt Normal file
View File

@ -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.

10
gcc/testsuite/g77.f-torture/execute/io1.f Normal file
View File

@ -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

13
gcc/testsuite/g77.f-torture/execute/io1.x Normal file
View File

@ -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

57
gcc/testsuite/g77.f-torture/execute/labug1.f Normal file
View File

@ -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

3
gcc/testsuite/g77.f-torture/execute/large_vec.f Normal file
View File

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

29
gcc/testsuite/g77.f-torture/execute/le.f Normal file
View File

@ -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

173
gcc/testsuite/g77.f-torture/execute/select.f Normal file
View File

@ -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

57
gcc/testsuite/g77.f-torture/execute/short.f Normal file
View File

@ -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

421
gcc/testsuite/g77.f-torture/execute/u77-test.f Normal file
View File

@ -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

12
gcc/testsuite/g77.f-torture/execute/u77-test.x Normal file
View File

@ -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

89
gcc/testsuite/g77.f-torture/noncompile/19981216-0.f Normal file
View File

@ -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

13
gcc/testsuite/g77.f-torture/noncompile/19990218-1.f Normal file
View File

@ -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

648
gcc/testsuite/g77.f-torture/noncompile/19990826-4.f Normal file
View File

@ -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)

8
gcc/testsuite/g77.f-torture/noncompile/19990905-1.f Normal file
View File

@ -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

7
gcc/testsuite/g77.f-torture/noncompile/9263.f Normal file
View File

@ -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

4
gcc/testsuite/g77.f-torture/noncompile/970626-2.f Normal file
View File

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

10
gcc/testsuite/g77.f-torture/noncompile/980615-0.f Normal file
View File

@ -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)

8
gcc/testsuite/g77.f-torture/noncompile/980616-0.f Normal file
View File

@ -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)

11
gcc/testsuite/g77.f-torture/noncompile/check0.f Normal file
View File

@ -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

36
gcc/testsuite/g77.f-torture/noncompile/noncompile.exp Normal file
View File

@ -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

10
gcc/testsuite/g77.f-torture/noncompile/select_no_compile.f Normal file
View File

@ -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

996
libjava/doc/cni.sgml Normal file
View File

@ -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>

74
libjava/gnu/javax/rmi/CORBA/DelegateFactory.java Normal file
View File

@ -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);
}
}
}

58
libjava/gnu/javax/rmi/CORBA/GetDelegateInstanceException.java Normal file
View File

@ -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);
}
}

133
libjava/gnu/javax/rmi/CORBA/PortableRemoteObjectDelegateImpl.java Normal file
View File

@ -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);
}
}

113
libjava/gnu/javax/rmi/CORBA/StubDelegateImpl.java Normal file
View File

@ -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");
}
}

152
libjava/gnu/javax/rmi/CORBA/UtilDelegateImpl.java Normal file
View File

@ -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");
}
}

82
libjava/gnu/javax/rmi/CORBA/ValueHandlerImpl.java Normal file
View File

@ -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");
}
}

Some files were not shown because too many files have changed in this diff Show More