/* com.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995-1997 Free Software Foundation, Inc.
- Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
+ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+ Free Software Foundation, Inc.
+ Contributed by James Craig Burley.
This file is part of GNU Fortran.
when it comes to building decls:
Internal Function (one we define, not just declare as extern):
- int yes;
- yes = suspend_momentary ();
if (is_nested) push_f_function_context ();
start_function (get_identifier ("function_name"), function_type,
is_nested, is_public);
// for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
store_parm_decls (is_main_program);
- ffecom_start_compstmt_ ();
+ ffecom_start_compstmt ();
// for stmts and decls inside function, do appropriate things;
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
finish_function (is_nested);
if (is_nested) pop_f_function_context ();
- if (is_nested) resume_momentary (yes);
Everything Else:
- int yes;
tree d;
tree init;
- yes = suspend_momentary ();
// fill in external, public, static, &c for decl, and
// set DECL_INITIAL to error_mark_node if going to initialize
// set is_top_level TRUE only if not at top level and decl
d = start_decl (decl, is_top_level);
init = ...; // if have initializer
finish_decl (d, init, is_top_level);
- resume_momentary (yes);
*/
/* Include files. */
+#include "proj.h"
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#include "config.j"
-#include "flags.j"
-#include "rtl.j"
-#include "tree.j"
-#include "convert.j"
+#include "flags.h"
+#include "rtl.h"
+#include "toplev.h"
+#include "tree.h"
+#include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
+#include "convert.h"
+#include "ggc.h"
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
# endif
#endif
-#ifndef RLIMIT_STACK
-# include <time.h>
-#else
-# if TIME_WITH_SYS_TIME
-# include <sys/time.h>
-# include <time.h>
-# else
-# if HAVE_SYS_TIME_H
-# include <sys/time.h>
-# else
-# include <time.h>
-# endif
-# endif
+#ifdef RLIMIT_STACK
# include <sys/resource.h>
#endif
char *getenv ();
#endif
-char *index ();
-char *rindex ();
-
#if HAVE_UNISTD_H
# include <unistd.h>
#endif
typedef struct { unsigned :16, :16, :16; } vms_ino_t;
#define ino_t vms_ino_t
#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
-#ifdef __GNUC__
-#define BSTRING /* VMS/GCC supplies the bstring routines */
-#endif /* __GNUC__ */
#endif /* VMS */
#ifndef O_RDONLY
/* END stuff from gcc/cccp.c. */
-#include "proj.h"
#define FFECOM_DETERMINE_TYPES 1 /* for com.h */
#include "com.h"
#include "bad.h"
/* Externals defined here. */
-#define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */
-
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-/* tree.h declares a bunch of stuff that it expects the front end to
- define. Here are the definitions, which in the C front end are
- found in the file c-decl.c. */
+/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
+ reference it. */
-tree integer_zero_node;
-tree integer_one_node;
-tree null_pointer_node;
-tree error_mark_node;
-tree void_type_node;
-tree integer_type_node;
-tree unsigned_type_node;
-tree char_type_node;
-tree current_function_decl;
+const char * const language_string = "GNU F77";
-/* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
- it. */
-
-char *language_string = "GNU F77";
+/* Stream for reading from the input file. */
+FILE *finput;
/* These definitions parallel those in c-decl.c so that code from that
module can be used pretty much as is. Much of these defs aren't
"static") are those that ste.c and such might use (directly
or by using com macros that reference them in their definitions). */
-static tree short_integer_type_node;
-tree long_integer_type_node;
-static tree long_long_integer_type_node;
-
-static tree short_unsigned_type_node;
-static tree long_unsigned_type_node;
-static tree long_long_unsigned_type_node;
-
-static tree unsigned_char_type_node;
-static tree signed_char_type_node;
-
-static tree float_type_node;
-static tree double_type_node;
-static tree complex_float_type_node;
-tree complex_double_type_node;
-static tree long_double_type_node;
-static tree complex_integer_type_node;
-static tree complex_long_double_type_node;
-
tree string_type_node;
-static tree double_ftype_double;
-static tree float_ftype_float;
-static tree ldouble_ftype_ldouble;
-
/* The rest of these are inventions for g77, though there might be
similar things in the C front end. As they are found, these
inventions should be renamed to be canonical. Note that only
the ones currently required to be global are so. */
static tree ffecom_tree_fun_type_void;
-static tree ffecom_tree_ptr_to_fun_type_void;
tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
NULL_TREE,
NULL_TREE,
NULL_TREE,
+ NULL_TREE,
+ false
};
ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
typedef enum
{
FFECOM_rttypeVOID_,
+ FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
typedef struct _ffecom_concat_list_ ffecomConcatList_;
-typedef struct _ffecom_temp_ *ffecomTemp_;
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Private include files. */
ffetargetCharacterSize minlen;
ffetargetCharacterSize maxlen;
};
-
-struct _ffecom_temp_
- {
- ffecomTemp_ next;
- tree type; /* Base type (w/o size/array applied). */
- tree t;
- ffetargetCharacterSize size;
- int elements;
- bool in_use;
- bool auto_pop;
- };
-
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Static functions (internal). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree ffecom_arglist_expr_ (char *argstring, ffebld args);
+static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
static tree ffecom_widest_expr_type_ (ffebld list);
static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
tree dest_size, tree source_tree,
static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
tree args, tree callee_commons,
bool scalar_args);
-static tree ffecom_build_f2c_string_ (int i, char *s);
+static tree ffecom_build_f2c_string_ (int i, const char *s);
static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
bool is_f2c_complex, tree type,
tree args, tree dest_tree,
ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args);
+ tree callee_commons, bool scalar_args, tree hook);
static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
bool is_f2c_complex, tree type,
ffebld left, ffebld right,
tree dest_tree, ffebld dest,
bool *dest_used, tree callee_commons,
- bool scalar_args);
-static void ffecom_char_args_ (tree *xitem, tree *length,
- ffebld expr);
+ bool scalar_args, bool ref, tree hook);
+static void ffecom_char_args_x_ (tree *xitem, tree *length,
+ ffebld expr, bool with_null);
static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
static ffecomConcatList_
static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
ffetargetCharacterSize max);
-static void ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member,
- tree member_type, ffetargetOffset offset);
+static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
+ ffesymbol member, tree member_type,
+ ffetargetOffset offset);
static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
-static tree ffecom_expr_ (ffebld expr, tree type_tree, tree dest_tree,
- ffebld dest, bool *dest_used,
- bool assignp);
+static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
+ bool *dest_used, bool assignp, bool widenp);
static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
ffebld dest, bool *dest_used);
-static tree ffecom_expr_power_integer_ (ffebld left, ffebld right);
+static tree ffecom_expr_power_integer_ (ffebld expr);
static void ffecom_expr_transform_ (ffebld expr);
-static void ffecom_f2c_make_type_ (tree *type, int tcode, char *name);
+static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
int code);
static ffeglobal ffecom_finish_global_ (ffeglobal global);
static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
-static tree ffecom_get_appended_identifier_ (char us, char *text);
+static tree ffecom_get_appended_identifier_ (char us, const char *text);
static tree ffecom_get_external_identifier_ (ffesymbol s);
-static tree ffecom_get_identifier_ (char *text);
+static tree ffecom_get_identifier_ (const char *text);
static tree ffecom_gen_sfuncdef_ (ffesymbol s,
ffeinfoBasictype bt,
ffeinfoKindtype kt);
-static char *ffecom_gfrt_args_ (ffecomGfrt ix);
+static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
static tree ffecom_init_zero_ (tree decl);
static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
ffebld source);
static void ffecom_make_gfrt_ (ffecomGfrt ix);
static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
-#endif
+static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
+ ffebld source);
static void ffecom_push_dummy_decls_ (ffebld dumlist,
bool stmtfunc);
static void ffecom_start_progunit_ (void);
tree *size, tree tree);
static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
tree dest_tree, ffebld dest,
- bool *dest_used);
+ bool *dest_used, tree hook);
static tree ffecom_type_localvar_ (ffesymbol s,
ffeinfoBasictype bt,
ffeinfoKindtype kt);
static tree ffecom_type_namelist_ (void);
-#if 0
-static tree ffecom_type_permanent_copy_ (tree t);
-#endif
static tree ffecom_type_vardesc_ (void);
static tree ffecom_vardesc_ (ffebld expr);
static tree ffecom_vardesc_array_ (ffesymbol s);
static tree ffecom_vardesc_dims_ (ffesymbol s);
+static tree ffecom_convert_narrow_ (tree type, tree expr);
+static tree ffecom_convert_widen_ (tree type, tree expr);
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* These are static functions that parallel those found in the C front
end and thus have the same names. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void bison_rule_compstmt_ (void);
+static tree bison_rule_compstmt_ (void);
static void bison_rule_pushlevel_ (void);
-static tree builtin_function (char *name, tree type,
- enum built_in_function function_code,
- char *library_name);
+static void delete_block (tree block);
static int duplicate_decls (tree newdecl, tree olddecl);
static void finish_decl (tree decl, tree init, bool is_top_level);
static void finish_function (int nested);
-static char *lang_printable_name (tree decl, int v);
+static const char *lang_printable_name (tree decl, int v);
static tree lookup_name_current_level (tree name);
static struct binding_level *make_binding_level (void);
static void pop_f_function_context (void);
static void push_f_function_context (void);
static void push_parm_decl (tree parm);
static tree pushdecl_top_level (tree decl);
+static int kept_level_p (void);
static tree storedecls (tree decls);
static void store_parm_decls (int is_main_program);
static tree start_decl (tree decl, bool is_top_level);
static void start_function (tree name, tree type, int nested, int public);
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
#if FFECOM_GCC_INCLUDE
-static void ffecom_file_ (char *name);
+static void ffecom_file_ (const char *name);
static void ffecom_initialize_char_syntax_ (void);
static void ffecom_close_include_ (FILE *f);
static int ffecom_decode_include_option_ (char *spec);
static tree ffecom_outer_function_decl_;
static tree ffecom_previous_function_decl_;
static tree ffecom_which_entrypoint_decl_;
-static ffecomTemp_ ffecom_latest_temp_;
-static int ffecom_pending_calls_ = 0;
static tree ffecom_float_zero_ = NULL_TREE;
static tree ffecom_float_half_ = NULL_TREE;
static tree ffecom_double_zero_ = NULL_TREE;
static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
static bool ffecom_doing_entry_ = FALSE;
static bool ffecom_transform_only_dummies_ = FALSE;
+static int ffecom_typesize_pointer_;
+static int ffecom_typesize_integer1_;
/* Holds pointer-to-function expressions. */
static tree ffecom_gfrt_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
#include "com-rt.def"
#undef DEFGFRT
};
/* Holds the external names of the functions. */
-static char *ffecom_gfrt_name_[FFECOM_gfrt]
+static const char *ffecom_gfrt_name_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
#include "com-rt.def"
#undef DEFGFRT
};
static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
#include "com-rt.def"
#undef DEFGFRT
};
static bool ffecom_gfrt_complex_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
+#include "com-rt.def"
+#undef DEFGFRT
+};
+
+/* Whether the function is const
+ (i.e., has no side effects and only depends on its arguments). */
+
+static bool ffecom_gfrt_const_[FFECOM_gfrt]
+=
+{
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
#include "com-rt.def"
#undef DEFGFRT
};
static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
#include "com-rt.def"
#undef DEFGFRT
};
/* String of codes for the function's arguments. */
-static char *ffecom_gfrt_argstring_[FFECOM_gfrt]
+static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
=
{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
+#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
#include "com-rt.def"
#undef DEFGFRT
};
it would be best to do something here to figure out automatically
from other information what type to use. */
-/* NOTE: g77 currently doesn't use these; see setting of sizetype and
- change that if you need to. -- jcb 09/01/91. */
-
#ifndef SIZE_TYPE
#define SIZE_TYPE "long unsigned int"
#endif
-#ifndef WCHAR_TYPE
-#define WCHAR_TYPE "int"
-#endif
-
#define ffecom_concat_list_count_(catlist) ((catlist).count)
#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
-#define ffecom_start_compstmt_ bison_rule_pushlevel_
-#define ffecom_end_compstmt_ bison_rule_compstmt_
+#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
+#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
/* For each binding contour we allocate a binding_level structure
* which records the names defined in that contour.
struct binding_level
{
- /* A chain of _DECL nodes for all variables, constants, functions, and
- typedef types. These are in the reverse of the order supplied. */
+ /* A chain of _DECL nodes for all variables, constants, functions,
+ and typedef types. These are in the reverse of the order supplied.
+ */
tree names;
- /* For each level (except not the global one), a chain of BLOCK nodes for
- all the levels that were entered and exited one level down. */
+ /* For each level (except not the global one),
+ a chain of BLOCK nodes for all the levels
+ that were entered and exited one level down. */
tree blocks;
- /* The BLOCK node for this level, if one has been preallocated. If 0, the
- BLOCK is allocated (if needed) when the level is popped. */
+ /* The BLOCK node for this level, if one has been preallocated.
+ If 0, the BLOCK is allocated (if needed) when the level is popped. */
tree this_block;
/* The binding level which this one is contained in (inherits from). */
struct binding_level *level_chain;
+
+ /* 0: no ffecom_prepare_* functions called at this level yet;
+ 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
+ 2: ffecom_prepare_end called. */
+ int prep_state;
};
#define NULL_BINDING_LEVEL (struct binding_level *) NULL
static struct binding_level clear_binding_level
=
-{NULL, NULL, NULL, NULL_BINDING_LEVEL};
+{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
/* Language-dependent contents of an identifier. */
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
+/* Return the subscript expression, modified to do range-checking.
+
+ `array' is the array to be checked against.
+ `element' is the subscript expression to check.
+ `dim' is the dimension number (starting at 0).
+ `total_dims' is the total number of dimensions (0 for CHARACTER substring).
+*/
+
+static tree
+ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
+ const char *array_name)
+{
+ tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
+ tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
+ tree cond;
+ tree die;
+ tree args;
+
+ if (element == error_mark_node)
+ return element;
+
+ if (TREE_TYPE (low) != TREE_TYPE (element))
+ {
+ if (TYPE_PRECISION (TREE_TYPE (low))
+ > TYPE_PRECISION (TREE_TYPE (element)))
+ element = convert (TREE_TYPE (low), element);
+ else
+ {
+ low = convert (TREE_TYPE (element), low);
+ if (high)
+ high = convert (TREE_TYPE (element), high);
+ }
+ }
+
+ element = ffecom_save_tree (element);
+ cond = ffecom_2 (LE_EXPR, integer_type_node,
+ low,
+ element);
+ if (high)
+ {
+ cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
+ cond,
+ ffecom_2 (LE_EXPR, integer_type_node,
+ element,
+ high));
+ }
+
+ {
+ int len;
+ char *proc;
+ char *var;
+ tree arg3;
+ tree arg2;
+ tree arg1;
+ tree arg4;
+
+ switch (total_dims)
+ {
+ case 0:
+ var = xmalloc (strlen (array_name) + 20);
+ sprintf (var, "%s[%s-substring]",
+ array_name,
+ dim ? "end" : "start");
+ len = strlen (var) + 1;
+ arg1 = build_string (len, var);
+ free (var);
+ break;
+
+ case 1:
+ len = strlen (array_name) + 1;
+ arg1 = build_string (len, array_name);
+ break;
+
+ default:
+ var = xmalloc (strlen (array_name) + 40);
+ sprintf (var, "%s[subscript-%d-of-%d]",
+ array_name,
+ dim + 1, total_dims);
+ len = strlen (var) + 1;
+ arg1 = build_string (len, var);
+ free (var);
+ break;
+ }
+
+ TREE_TYPE (arg1)
+ = build_type_variant (build_array_type (char_type_node,
+ build_range_type
+ (integer_type_node,
+ integer_one_node,
+ build_int_2 (len, 0))),
+ 1, 0);
+ TREE_CONSTANT (arg1) = 1;
+ TREE_STATIC (arg1) = 1;
+ arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
+ arg1);
+
+ /* s_rnge adds one to the element to print it, so bias against
+ that -- want to print a faithful *subscript* value. */
+ arg2 = convert (ffecom_f2c_ftnint_type_node,
+ ffecom_2 (MINUS_EXPR,
+ TREE_TYPE (element),
+ element,
+ convert (TREE_TYPE (element),
+ integer_one_node)));
+
+ proc = xmalloc ((len = strlen (input_filename)
+ + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
+ + 2));
+
+ sprintf (&proc[0], "%s/%s",
+ input_filename,
+ IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
+ arg3 = build_string (len, proc);
+
+ free (proc);
+
+ TREE_TYPE (arg3)
+ = build_type_variant (build_array_type (char_type_node,
+ build_range_type
+ (integer_type_node,
+ integer_one_node,
+ build_int_2 (len, 0))),
+ 1, 0);
+ TREE_CONSTANT (arg3) = 1;
+ TREE_STATIC (arg3) = 1;
+ arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
+ arg3);
+
+ arg4 = convert (ffecom_f2c_ftnint_type_node,
+ build_int_2 (lineno, 0));
+
+ arg1 = build_tree_list (NULL_TREE, arg1);
+ arg2 = build_tree_list (NULL_TREE, arg2);
+ arg3 = build_tree_list (NULL_TREE, arg3);
+ arg4 = build_tree_list (NULL_TREE, arg4);
+ TREE_CHAIN (arg3) = arg4;
+ TREE_CHAIN (arg2) = arg3;
+ TREE_CHAIN (arg1) = arg2;
+
+ args = arg1;
+ }
+ die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
+ args, NULL_TREE);
+ TREE_SIDE_EFFECTS (die) = 1;
+
+ element = ffecom_3 (COND_EXPR,
+ TREE_TYPE (element),
+ cond,
+ element,
+ die);
+
+ return element;
+}
+
+/* Return the computed element of an array reference.
+
+ `item' is NULL_TREE, or the transformed pointer to the array.
+ `expr' is the original opARRAYREF expression, which is transformed
+ if `item' is NULL_TREE.
+ `want_ptr' is non-zero if a pointer to the element, instead of
+ the element itself, is to be returned. */
+
+static tree
+ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
+{
+ ffebld dims[FFECOM_dimensionsMAX];
+ int i;
+ int total_dims;
+ int flatten = ffe_is_flatten_arrays ();
+ int need_ptr;
+ tree array;
+ tree element;
+ tree tree_type;
+ tree tree_type_x;
+ const char *array_name;
+ ffetype type;
+ ffebld list;
+
+ if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
+ array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
+ else
+ array_name = "[expr?]";
+
+ /* Build up ARRAY_REFs in reverse order (since we're column major
+ here in Fortran land). */
+
+ for (i = 0, list = ffebld_right (expr);
+ list != NULL;
+ ++i, list = ffebld_trail (list))
+ {
+ dims[i] = ffebld_head (list);
+ type = ffeinfo_type (ffebld_basictype (dims[i]),
+ ffebld_kindtype (dims[i]));
+ if (! flatten
+ && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
+ && ffetype_size (type) > ffecom_typesize_integer1_)
+ /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
+ pointers and 32-bit integers. Do the full 64-bit pointer
+ arithmetic, for codes using arrays for nonstandard heap-like
+ work. */
+ flatten = 1;
+ }
+
+ total_dims = i;
+
+ need_ptr = want_ptr || flatten;
+
+ if (! item)
+ {
+ if (need_ptr)
+ item = ffecom_ptr_to_expr (ffebld_left (expr));
+ else
+ item = ffecom_expr (ffebld_left (expr));
+
+ if (item == error_mark_node)
+ return item;
+
+ if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
+ && ! mark_addressable (item))
+ return error_mark_node;
+ }
+
+ if (item == error_mark_node)
+ return item;
+
+ if (need_ptr)
+ {
+ tree min;
+
+ for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
+ i >= 0;
+ --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
+ {
+ min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
+ element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
+ if (flag_bounds_check)
+ element = ffecom_subscript_check_ (array, element, i, total_dims,
+ array_name);
+ if (element == error_mark_node)
+ return element;
+
+ /* Widen integral arithmetic as desired while preserving
+ signedness. */
+ tree_type = TREE_TYPE (element);
+ tree_type_x = tree_type;
+ if (tree_type
+ && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
+ && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
+ tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
+
+ if (TREE_TYPE (min) != tree_type_x)
+ min = convert (tree_type_x, min);
+ if (TREE_TYPE (element) != tree_type_x)
+ element = convert (tree_type_x, element);
+
+ item = ffecom_2 (PLUS_EXPR,
+ build_pointer_type (TREE_TYPE (array)),
+ item,
+ size_binop (MULT_EXPR,
+ size_in_bytes (TREE_TYPE (array)),
+ convert (sizetype,
+ fold (build (MINUS_EXPR,
+ tree_type_x,
+ element, min)))));
+ }
+ if (! want_ptr)
+ {
+ item = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
+ item);
+ }
+ }
+ else
+ {
+ for (--i;
+ i >= 0;
+ --i)
+ {
+ array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
+
+ element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
+ if (flag_bounds_check)
+ element = ffecom_subscript_check_ (array, element, i, total_dims,
+ array_name);
+ if (element == error_mark_node)
+ return element;
+
+ /* Widen integral arithmetic as desired while preserving
+ signedness. */
+ tree_type = TREE_TYPE (element);
+ tree_type_x = tree_type;
+ if (tree_type
+ && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
+ && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
+ tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
+
+ element = convert (tree_type_x, element);
+
+ item = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
+ item,
+ element);
+ }
+ }
+
+ return item;
+}
/* This is like gcc's stabilize_reference -- in fact, most of the code
comes from that -- but it handles the situation where the reference
break;
case RTL_EXPR:
- result = build1 (INDIRECT_REF, TREE_TYPE (ref),
- save_expr (build1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ref)),
- ref)));
- break;
+ abort ();
default:
TREE_READONLY (result) = TREE_READONLY (ref);
TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
- TREE_RAISES (result) = TREE_RAISES (ref);
return result;
}
assert (code != ENUMERAL_TYPE);
if (code == INTEGER_TYPE)
{
- assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE);
- assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
+ assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
+ && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
+ || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
+ && (TYPE_PRECISION (type)
+ == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
return fold (convert_to_integer (type, e));
}
if (code == POINTER_TYPE)
if (code == RECORD_TYPE)
{
assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
+ /* Check that at least the first field name agrees. */
+ assert (DECL_NAME (TYPE_FIELDS (type))
+ == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
<= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
+ if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
+ == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
+ return e;
return fold (ffecom_convert_to_complex_ (type, e));
}
assert (code != ENUMERAL_TYPE);
if (code == INTEGER_TYPE)
{
- assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE);
- assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
+ assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
+ && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
+ || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
+ && (TYPE_PRECISION (type)
+ == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
return fold (convert_to_integer (type, e));
}
if (code == POINTER_TYPE)
if (code == RECORD_TYPE)
{
assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
+ /* Check that at least the first field name agrees. */
+ assert (DECL_NAME (TYPE_FIELDS (type))
+ == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
>= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
+ if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
+ == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
+ return e;
return fold (ffecom_convert_to_complex_ (type, e));
}
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_arglist_expr_ (char *c, ffebld expr)
+ffecom_arglist_expr_ (const char *c, ffebld expr)
{
tree list;
tree *plist = &list;
tree item;
bool ptr = FALSE;
tree wanted = NULL_TREE;
+ static char zed[] = "0";
+
+ if (c == NULL)
+ c = &zed[0];
while (expr != NULL)
{
}
}
+ /* We've run out of args in the call; if the implementation expects
+ more, supply null pointers for them, which the implementation can
+ check to see if an arg was omitted. */
+
+ while (*c != '\0' && *c != '0')
+ {
+ if (*c == '&')
+ ++c;
+ else
+ assert ("missing arg to run-time routine!" == NULL);
+
+ switch (*(c++))
+ {
+ case '\0':
+ case 'a':
+ case 'c':
+ case 'd':
+ case 'e':
+ case 'f':
+ case 'i':
+ case 'j':
+ break;
+
+ default:
+ assert ("bad arg string code" == NULL);
+ break;
+ }
+ *plist
+ = build_tree_list (NULL_TREE,
+ null_pointer_node);
+ plist = &TREE_CHAIN (*plist);
+ }
+
*plist = trail;
return list;
}
#endif
+/* Check whether a partial overlap between two expressions is possible.
+
+ Can *starting* to write a portion of expr1 change the value
+ computed (perhaps already, *partially*) by expr2?
+
+ Currently, this is a concern only for a COMPLEX expr1. But if it
+ isn't in COMMON or local EQUIVALENCE, since we don't support
+ aliasing of arguments, it isn't a concern. */
+
+static bool
+ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
+{
+ ffesymbol sym;
+ ffestorag st;
+
+ switch (ffebld_op (expr1))
+ {
+ case FFEBLD_opSYMTER:
+ sym = ffebld_symter (expr1);
+ break;
+
+ case FFEBLD_opARRAYREF:
+ if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
+ return FALSE;
+ sym = ffebld_symter (ffebld_left (expr1));
+ break;
+
+ default:
+ return FALSE;
+ }
+
+ if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
+ && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
+ || ! (st = ffesymbol_storage (sym))
+ || ! ffestorag_parent (st)))
+ return FALSE;
+
+ /* It's in COMMON or local EQUIVALENCE. */
+
+ return TRUE;
+}
+
/* Check whether dest and source might overlap. ffebld versions of these
might or might not be passed, will be NULL if not.
return TRUE;
source_decl = source_tree;
- source_offset = size_zero_node;
+ source_offset = bitsize_zero_node;
source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
break;
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_build_f2c_string_ (int i, char *s)
+ffecom_build_f2c_string_ (int i, const char *s)
{
if (!ffe_is_f2c_library ())
return build_string (i, s);
{
char *tmp;
- char *p;
+ const char *p;
char *q;
char space[34];
tree t;
tmp = &space[0];
for (p = s, q = tmp; *p != '\0'; ++p, ++q)
- *q = ffesrc_toupper (*p);
+ *q = TOUPPER (*p);
*q = '\0';
t = build_string (i, tmp);
ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
tree type, tree args, tree dest_tree,
ffebld dest, bool *dest_used, tree callee_commons,
- bool scalar_args)
+ bool scalar_args, tree hook)
{
tree item;
tree tempvar;
callee_commons,
scalar_args))
{
- tempvar = ffecom_push_tempvar (ffecom_tree_type
+#ifdef HOHO
+ tempvar = ffecom_make_tempvar (ffecom_tree_type
[FFEINFO_basictypeCOMPLEX][kt],
FFETARGET_charactersizeNONE,
- -1, TRUE);
+ -1);
+#else
+ tempvar = hook;
+ assert (tempvar);
+#endif
}
else
{
item
= build_tree_list (NULL_TREE,
ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (tempvar)),
+ build_pointer_type (TREE_TYPE (tempvar)),
tempvar));
TREE_CHAIN (item) = args;
ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
tree type, ffebld left, ffebld right,
tree dest_tree, ffebld dest, bool *dest_used,
- tree callee_commons, bool scalar_args)
+ tree callee_commons, bool scalar_args, bool ref, tree hook)
{
tree left_tree;
tree right_tree;
tree left_length;
tree right_length;
- ffecom_push_calltemps ();
- left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
- right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
- ffecom_pop_calltemps ();
+ if (ref)
+ {
+ /* Pass arguments by reference. */
+ left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
+ right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
+ }
+ else
+ {
+ /* Pass arguments by value. */
+ left_tree = ffecom_arg_expr (left, &left_length);
+ right_tree = ffecom_arg_expr (right, &right_length);
+ }
+
left_tree = build_tree_list (NULL_TREE, left_tree);
right_tree = build_tree_list (NULL_TREE, right_tree);
return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
dest_tree, dest, dest_used, callee_commons,
- scalar_args);
+ scalar_args, hook);
}
#endif
-/* ffecom_char_args_ -- Return ptr/length args for char subexpression
-
- tree ptr_arg;
- tree length_arg;
- ffebld expr;
- ffecom_char_args_(&ptr_arg,&length_arg,expr);
+/* Return ptr/length args for char subexpression
Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
subexpressions by constructing the appropriate trees for the ptr-to-
character-text and length-of-character-text arguments in a calling
- sequence. */
+ sequence.
+
+ Note that if with_null is TRUE, and the expression is an opCONTER,
+ a null byte is appended to the string. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
-ffecom_char_args_ (tree *xitem, tree *length, ffebld expr)
+ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
{
tree item;
tree high;
ffetargetCharacter1 val;
+ ffetargetCharacterSize newlen;
switch (ffebld_op (expr))
{
case FFEBLD_opCONTER:
val = ffebld_constant_character1 (ffebld_conter (expr));
- *length = build_int_2 (ffetarget_length_character1 (val), 0);
+ newlen = ffetarget_length_character1 (val);
+ if (with_null)
+ {
+ /* Begin FFETARGET-NULL-KLUDGE. */
+ if (newlen != 0)
+ ++newlen;
+ }
+ *length = build_int_2 (newlen, 0);
TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- high = build_int_2 (ffetarget_length_character1 (val),
- 0);
+ high = build_int_2 (newlen, 0);
TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
- item = build_string (ffetarget_length_character1 (val),
+ item = build_string (newlen,
ffetarget_text_character1 (val));
+ /* End FFETARGET-NULL-KLUDGE. */
TREE_TYPE (item)
= build_type_variant
(build_array_type
}
else if (item == error_mark_node)
*length = error_mark_node;
- else /* FFEINFO_kindFUNCTION: */
+ else
+ /* FFEINFO_kindFUNCTION. */
*length = NULL_TREE;
if (!ffesymbol_hook (s).addr
&& (item != error_mark_node))
case FFEBLD_opARRAYREF:
{
- ffebld dims[FFECOM_dimensionsMAX];
- tree array;
- int i;
-
- ffecom_push_calltemps ();
ffecom_char_args_ (&item, length, ffebld_left (expr));
- ffecom_pop_calltemps ();
if (item == error_mark_node || *length == error_mark_node)
{
break;
}
- /* Build up ARRAY_REFs in reverse order (since we're column major
- here in Fortran land). */
-
- for (i = 0, expr = ffebld_right (expr);
- expr != NULL;
- expr = ffebld_trail (expr))
- dims[i++] = ffebld_head (expr);
-
- for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
- i >= 0;
- --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
- {
- item = ffecom_2 (PLUS_EXPR, build_pointer_type (TREE_TYPE (array)),
- item,
- size_binop (MULT_EXPR,
- size_in_bytes (TREE_TYPE (array)),
- size_binop (MINUS_EXPR,
- ffecom_expr (dims[i]),
- TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
- }
+ item = ffecom_arrayref_ (item, expr, 1);
}
break;
ffebld thing = ffebld_right (expr);
tree start_tree;
tree end_tree;
+ const char *char_name;
+ ffebld left_symter;
+ tree array;
assert (ffebld_op (thing) == FFEBLD_opITEM);
start = ffebld_head (thing);
assert (ffebld_trail (thing) == NULL);
end = ffebld_head (thing);
- ffecom_push_calltemps ();
+ /* Determine name for pretty-printing range-check errors. */
+ for (left_symter = ffebld_left (expr);
+ left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
+ left_symter = ffebld_left (left_symter))
+ ;
+ if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
+ char_name = ffesymbol_text (ffebld_symter (left_symter));
+ else
+ char_name = "[expr?]";
+
ffecom_char_args_ (&item, length, ffebld_left (expr));
- ffecom_pop_calltemps ();
if (item == error_mark_node || *length == error_mark_node)
{
break;
}
+ array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
+
+ /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
+
if (start == NULL)
{
if (end == NULL)
;
else
{
+ end_tree = ffecom_expr (end);
+ if (flag_bounds_check)
+ end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
+ char_name);
end_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (end));
+ end_tree);
if (end_tree == error_mark_node)
{
}
else
{
+ start_tree = ffecom_expr (start);
+ if (flag_bounds_check)
+ start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
+ char_name);
start_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (start));
+ start_tree);
if (start_tree == error_mark_node)
{
}
else
{
+ end_tree = ffecom_expr (end);
+ if (flag_bounds_check)
+ end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
+ char_name);
end_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (end));
+ end_tree);
if (end_tree == error_mark_node)
{
ffecomGfrt ix;
if (size == FFETARGET_charactersizeNONE)
- size = 24; /* ~~~~ Kludge alert! This should someday be fixed. */
+ /* ~~Kludge alert! This should someday be fixed. */
+ size = 24;
*length = build_int_2 (size, 0);
TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
== FFEINFO_whereINTRINSIC)
{
if (size == 1)
- { /* Invocation of an intrinsic returning CHARACTER*1. */
+ {
+ /* Invocation of an intrinsic returning CHARACTER*1. */
item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
NULL, NULL);
break;
item = ffecom_1_fn (item);
}
- assert (ffecom_pending_calls_ != 0);
+#ifdef HOHO
tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
+#else
+ tempvar = ffebld_nonter_hook (expr);
+ assert (tempvar);
+#endif
tempvar = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (tempvar)),
tempvar);
- ffecom_push_calltemps ();
-
args = build_tree_list (NULL_TREE, tempvar);
if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
item, args, NULL_TREE);
item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
tempvar);
-
- ffecom_pop_calltemps ();
}
break;
case FFEBLD_opCONVERT:
- ffecom_push_calltemps ();
ffecom_char_args_ (&item, length, ffebld_left (expr));
- ffecom_pop_calltemps ();
if (item == error_mark_node || *length == error_mark_node)
{
tree args;
tree newlen;
- assert (ffecom_pending_calls_ != 0);
- tempvar = ffecom_push_tempvar (char_type_node,
- ffebld_size (expr), -1, TRUE);
+#ifdef HOHO
+ tempvar = ffecom_make_tempvar (char_type_node,
+ ffebld_size (expr), -1);
+#else
+ tempvar = ffebld_nonter_hook (expr);
+ assert (tempvar);
+#endif
tempvar = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (tempvar)),
tempvar);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
= build_tree_list (NULL_TREE, *length);
- item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args);
+ item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
TREE_SIDE_EFFECTS (item) = 1;
item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
tempvar);
return type;
if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
- || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
- || TREE_OVERFLOW (TYPE_SIZE (type)))
+ || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
+ || TREE_OVERFLOW (TYPE_SIZE (type)))))
{
ffebad_start (FFEBAD_ARRAY_LARGE);
ffebad_string (ffesymbol_text (s));
{
if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
tlen = ffecom_get_invented_identifier ("__g77_length_%s",
- ffesymbol_text (s), 0);
+ ffesymbol_text (s));
else
- tlen = ffecom_get_invented_identifier ("__g77_%s",
- "length", 0);
+ tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
#if BUILT_FOR_270
DECL_ARTIFICIAL (tlen) = 1;
if (sz == FFETARGET_charactersizeNONE)
{
assert (tlen != NULL_TREE);
- highval = tlen;
+ highval = variable_size (tlen);
}
else
{
case FFEBLD_opARRAYREF:
case FFEBLD_opFUNCREF:
case FFEBLD_opSUBSTR:
- break; /* ~~Do useful truncations here. */
+ /* ~~Do useful truncations here. */
+ break;
default:
assert ("op changed or inconsistent switches!" == NULL);
}
#endif
-/* ffecom_concat_list_new_ -- Make list of concatenated string exprs
-
- ffecomConcatList_ catlist;
- ffebld expr; // Root expr of CHARACTER basictype.
- ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
- catlist = ffecom_concat_list_new_(expr,max);
+/* Make list of concatenated string exprs.
Returns a flattened list of concatenated subexpressions given a
tree of such expressions. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
-ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member,
+ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
tree member_type UNUSED, ffetargetOffset offset)
{
tree value;
bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
bool multi; /* Master fn has multiple return types. */
bool altreturning = FALSE; /* This entry point has alternate returns. */
- int yes;
-
- /* c-parse.y indeed does call suspend_momentary and not only ignores the
- return value, but also never calls resume_momentary, when starting an
- outer function (see "fndef:", "setspecs:", and so on). So g77 does the
- same thing. It shouldn't be a problem since start_function calls
- temporary_allocation, but it might be necessary. If it causes a problem
- here, then maybe there's a bug lurking in gcc. NOTE: This identical
- comment appears twice in thist file. */
+ int old_lineno = lineno;
+ const char *old_input_filename = input_filename;
- suspend_momentary ();
+ input_filename = ffesymbol_where_filename (fn);
+ lineno = ffesymbol_where_filelinenum (fn);
ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
/* Build dummy arg list for this entry point. */
- yes = suspend_momentary ();
-
if (charfunc || cmplxfunc)
{ /* Prepend arg for where result goes. */
tree type;
else
type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
/* Make length arg _and_ enhance type info for CHAR arg itself. */
ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
- resume_momentary (yes);
-
store_parm_decls (0);
- ffecom_start_compstmt_ ();
+ ffecom_start_compstmt ();
+ /* Disallow temp vars at this level. */
+ current_binding_level->prep_state = 2;
/* Make local var to hold return type for multi-type master fn. */
if (multi)
{
- yes = suspend_momentary ();
-
multi_retval = ffecom_get_invented_identifier ("__g77_%s",
- "multi_retval", 0);
+ "multi_retval");
multi_retval = build_decl (VAR_DECL, multi_retval,
ffecom_multi_type_node_);
multi_retval = start_decl (multi_retval, FALSE);
finish_decl (multi_retval, NULL_TREE, FALSE);
-
- resume_momentary (yes);
}
else
multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
if (ffebld_op (arg) != FFEBLD_opSYMTER)
continue;
s = ffebld_symter (arg);
- if (ffesymbol_hook (s).decl_tree == NULL_TREE)
+ if (ffesymbol_hook (s).decl_tree == NULL_TREE
+ || ffesymbol_hook (s).decl_tree == error_mark_node)
actarg = null_pointer_node; /* We don't have this arg. */
else
actarg = ffesymbol_hook (s).decl_tree;
continue; /* Only looking for CHARACTER arguments. */
if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
continue; /* Only looking for variables and arrays. */
- if (ffesymbol_hook (s).length_tree == NULL_TREE)
+ if (ffesymbol_hook (s).length_tree == NULL_TREE
+ || ffesymbol_hook (s).length_tree == error_mark_node)
actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
else
actarg = ffesymbol_hook (s).length_tree;
call));
expand_return (result);
}
-
- clear_momentary ();
}
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
finish_function (0);
+ lineno = old_lineno;
+ input_filename = old_input_filename;
+
ffecom_doing_entry_ = FALSE;
}
Recursive descent on expr while making corresponding tree nodes and
attaching type info and such. If destination supplied and compatible
with temporary that would be made in certain cases, temporary isn't
- made, destination used instead, and dest_used flag set TRUE.
-
- If TREE_TYPE is non-null, it overrides the type that the expression
- would normally be computed in. This is most useful for array indices
- which should be done in sizetype for efficiency. */
+ made, destination used instead, and dest_used flag set TRUE. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_expr_ (ffebld expr, tree tree_type_x, tree dest_tree,
- ffebld dest, bool *dest_used,
- bool assignp)
+ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
+ bool *dest_used, bool assignp, bool widenp)
{
tree item;
tree list;
ffeinfoKindtype kt;
tree t;
tree dt; /* decl_tree for an ffesymbol. */
- tree tree_type;
+ tree tree_type, tree_type_x;
tree left, right;
ffesymbol s;
enum tree_code code;
kt = ffeinfo_kindtype (ffebld_info (expr));
tree_type = ffecom_tree_type[bt][kt];
+ /* Widen integral arithmetic as desired while preserving signedness. */
+ tree_type_x = NULL_TREE;
+ if (widenp && tree_type
+ && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
+ && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
+ tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
+
switch (ffebld_op (expr))
{
case FFEBLD_opACCTER:
ffebitCount i;
ffebit bits = ffebld_accter_bits (expr);
ffetargetOffset source_offset = 0;
- size_t size;
+ ffetargetOffset dest_offset = ffebld_accter_pad (expr);
tree purpose;
- size = ffetype_size (ffeinfo_type (bt, kt));
+ assert (dest_offset == 0
+ || (bt == FFEINFO_basictypeCHARACTER
+ && kt == FFEINFO_kindtypeCHARACTER1));
list = item = NULL;
for (;;)
t = ffecom_constantunion (&cu, bt, kt, tree_type);
- if (i == 0)
- purpose = build_int_2 (source_offset, 0);
+ if (i == 0
+ && dest_offset != 0)
+ purpose = build_int_2 (dest_offset, 0);
else
purpose = NULL_TREE;
}
}
source_offset += length;
+ dest_offset += length;
}
}
- item = build_int_2 (ffebld_accter_size (expr), 0);
+ item = build_int_2 ((ffebld_accter_size (expr)
+ + ffebld_accter_pad (expr)) - 1, 0);
ffebit_kill (ffebld_accter_bits (expr));
TREE_TYPE (item) = ffecom_integer_type_node;
item
{
ffetargetOffset i;
- list = item = NULL_TREE;
+ list = NULL_TREE;
+ if (ffebld_arrter_pad (expr) == 0)
+ item = NULL_TREE;
+ else
+ {
+ assert (bt == FFEINFO_basictypeCHARACTER
+ && kt == FFEINFO_kindtypeCHARACTER1);
+
+ /* Becomes PURPOSE first time through loop. */
+ item = build_int_2 (ffebld_arrter_pad (expr), 0);
+ }
+
for (i = 0; i < ffebld_arrter_size (expr); ++i)
{
ffebldConstantUnion cu
t = ffecom_constantunion (&cu, bt, kt, tree_type);
if (list == NULL_TREE)
- list = item = build_tree_list (NULL_TREE, t);
+ /* Assume item is PURPOSE first time through loop. */
+ list = item = build_tree_list (item, t);
else
{
TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
}
}
- item = build_int_2 (ffebld_arrter_size (expr), 0);
+ item = build_int_2 ((ffebld_arrter_size (expr)
+ + ffebld_arrter_pad (expr)) - 1, 0);
TREE_TYPE (item) = ffecom_integer_type_node;
item
= build_array_type
(tree_type,
build_range_type (ffecom_integer_type_node,
- ffecom_integer_one_node,
+ ffecom_integer_zero_node,
item));
list = build (CONSTRUCTOR, item, NULL_TREE, list);
TREE_CONSTANT (list) = 1;
return list;
case FFEBLD_opCONTER:
+ assert (ffebld_conter_pad (expr) == 0);
item
= ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
bt, kt, tree_type);
return t;
case FFEBLD_opARRAYREF:
- {
- ffebld dims[FFECOM_dimensionsMAX];
-#if FFECOM_FASTER_ARRAY_REFS
- tree array;
-#endif
- int i;
-
-#if FFECOM_FASTER_ARRAY_REFS
- t = ffecom_ptr_to_expr (ffebld_left (expr));
-#else
- t = ffecom_expr (ffebld_left (expr));
-#endif
- if (t == error_mark_node)
- return t;
-
- if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
- && !mark_addressable (t))
- return error_mark_node; /* Make sure non-const ref is to
- non-reg. */
-
- /* Build up ARRAY_REFs in reverse order (since we're column major
- here in Fortran land). */
-
- for (i = 0, expr = ffebld_right (expr);
- expr != NULL;
- expr = ffebld_trail (expr))
- dims[i++] = ffebld_head (expr);
-
-#if FFECOM_FASTER_ARRAY_REFS
- for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t)));
- i >= 0;
- --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
- t = ffecom_2 (PLUS_EXPR,
- build_pointer_type (TREE_TYPE (array)),
- t,
- size_binop (MULT_EXPR,
- size_in_bytes (TREE_TYPE (array)),
- size_binop (MINUS_EXPR,
- ffecom_expr (dims[i]),
- TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
- t = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
- t);
-#else
- while (i > 0)
- t = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
- t,
- ffecom_expr_ (dims[--i], sizetype, NULL, NULL,
- NULL, FALSE));
-#endif
-
- return t;
- }
+ return ffecom_arrayref_ (NULL_TREE, expr, 0);
case FFEBLD_opUPLUS:
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
return ffecom_1 (NOP_EXPR, tree_type, left);
- case FFEBLD_opPAREN: /* ~~~Make sure Fortran rules respected here */
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ case FFEBLD_opPAREN:
+ /* ~~~Make sure Fortran rules respected here */
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
return ffecom_1 (NOP_EXPR, tree_type, left);
case FFEBLD_opUMINUS:
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
if (tree_type_x)
{
tree_type = tree_type_x;
return ffecom_1 (NEGATE_EXPR, tree_type, left);
case FFEBLD_opADD:
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
- right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
+ right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
if (tree_type_x)
{
tree_type = tree_type_x;
return ffecom_2 (PLUS_EXPR, tree_type, left, right);
case FFEBLD_opSUBTRACT:
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
- right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
+ right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
if (tree_type_x)
{
tree_type = tree_type_x;
return ffecom_2 (MINUS_EXPR, tree_type, left, right);
case FFEBLD_opMULTIPLY:
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
- right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
+ right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
if (tree_type_x)
{
tree_type = tree_type_x;
return ffecom_2 (MULT_EXPR, tree_type, left, right);
case FFEBLD_opDIVIDE:
- left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
- right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
- NULL, FALSE);
+ left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
+ right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
if (tree_type_x)
{
tree_type = tree_type_x;
right = convert (tree_type, right);
}
return ffecom_tree_divide_ (tree_type, left, right,
- dest_tree, dest, dest_used);
+ dest_tree, dest, dest_used,
+ ffebld_nonter_hook (expr));
case FFEBLD_opPOWER:
{
ffebld right = ffebld_right (expr);
ffecomGfrt code;
ffeinfoKindtype rtkt;
+ ffeinfoKindtype ltkt;
+ bool ref = TRUE;
switch (ffeinfo_basictype (ffebld_info (right)))
{
+
case FFEINFO_basictypeINTEGER:
if (1 || optimize)
{
- item = ffecom_expr_power_integer_ (left, right);
+ item = ffecom_expr_power_integer_ (expr);
if (item != NULL_TREE)
return item;
}
== FFEINFO_kindtypeINTEGER4))
{
code = FFECOM_gfrtPOW_QQ;
+ ltkt = FFEINFO_kindtypeINTEGER4;
rtkt = FFEINFO_kindtypeINTEGER4;
}
else
- code = FFECOM_gfrtPOW_II;
+ {
+ code = FFECOM_gfrtPOW_II;
+ ltkt = FFEINFO_kindtypeINTEGER1;
+ }
break;
case FFEINFO_basictypeREAL:
if (ffeinfo_kindtype (ffebld_info (left))
== FFEINFO_kindtypeREAL1)
- code = FFECOM_gfrtPOW_RI;
+ {
+ code = FFECOM_gfrtPOW_RI;
+ ltkt = FFEINFO_kindtypeREAL1;
+ }
else
- code = FFECOM_gfrtPOW_DI;
+ {
+ code = FFECOM_gfrtPOW_DI;
+ ltkt = FFEINFO_kindtypeREAL2;
+ }
break;
case FFEINFO_basictypeCOMPLEX:
if (ffeinfo_kindtype (ffebld_info (left))
== FFEINFO_kindtypeREAL1)
- code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
+ {
+ code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
+ ltkt = FFEINFO_kindtypeREAL1;
+ }
else
- code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
+ {
+ code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
+ ltkt = FFEINFO_kindtypeREAL2;
+ }
break;
default:
assert ("bad pow_*i" == NULL);
code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
+ ltkt = FFEINFO_kindtypeREAL1;
break;
}
- if (ffeinfo_kindtype (ffebld_info (left)) != rtkt)
+ if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
left = ffeexpr_convert (left, NULL, NULL,
- FFEINFO_basictypeINTEGER,
- rtkt, 0,
+ ffeinfo_basictype (ffebld_info (left)),
+ ltkt, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
FFEINFO_kindtypeREALDOUBLE, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
- code = FFECOM_gfrtPOW_DD;
+ /* We used to call FFECOM_gfrtPOW_DD here,
+ which passes arguments by reference. */
+ code = FFECOM_gfrtL_POW;
+ /* Pass arguments by value. */
+ ref = FALSE;
break;
case FFEINFO_basictypeCOMPLEX:
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
+ ref = TRUE; /* Pass arguments by reference. */
break;
default:
&& ffecom_gfrt_complex_[code]),
tree_type, left, right,
dest_tree, dest, dest_used,
- NULL_TREE, FALSE);
+ NULL_TREE, FALSE, ref,
+ ffebld_nonter_hook (expr));
}
case FFEBLD_opNOT:
else
item = ffecom_1_fn (dt);
- ffecom_push_calltemps ();
if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
args = ffecom_list_expr (ffebld_right (expr));
else
args = ffecom_list_ptr_to_expr (ffebld_right (expr));
- ffecom_pop_calltemps ();
+
+ if (args == error_mark_node)
+ return error_mark_node;
item = ffecom_call_ (item, kt,
ffesymbol_is_f2c (s)
tree_type,
args,
dest_tree, dest, dest_used,
- error_mark_node, FALSE);
+ error_mark_node, FALSE,
+ ffebld_nonter_hook (expr));
TREE_SIDE_EFFECTS (item) = 1;
return item;
}
case FFEINFO_basictypeCHARACTER:
- ffecom_push_calltemps (); /* Even though we might not call. */
-
{
ffebld left = ffebld_left (expr);
ffebld right = ffebld_right (expr);
if (left_tree == error_mark_node || left_length == error_mark_node
|| right_tree == error_mark_node
|| right_length == error_mark_node)
- {
- ffecom_pop_calltemps ();
- return error_mark_node;
- }
+ return error_mark_node;
if ((ffebld_size_known (left) == 1)
&& (ffebld_size_known (right) == 1))
left_length);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
= build_tree_list (NULL_TREE, right_length);
- item = ffecom_call_gfrt (FFECOM_gfrtCMP, item);
+ item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
item = ffecom_2 (code, integer_type_node,
item,
convert (TREE_TYPE (item),
item = convert (tree_type, item);
}
- ffecom_pop_calltemps ();
return item;
default:
case FFEINTRIN_impAINT:
case FFEINTRIN_impDINT:
-#if 0 /* ~~ someday implement FIX_TRUNC_EXPR
- yielding same type as arg */
+#if 0
+ /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
#else /* in the meantime, must use floor to avoid range problems with ints */
/* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
build_tree_list (NULL_TREE,
convert (double_type_node,
- saved_expr1))),
+ saved_expr1)),
+ NULL_TREE),
ffecom_1 (NEGATE_EXPR, double_type_node,
ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
build_tree_list (NULL_TREE,
convert (double_type_node,
ffecom_1 (NEGATE_EXPR,
arg1_type,
- saved_expr1))))
+ saved_expr1))),
+ NULL_TREE)
))
);
#endif
arg1_type,
saved_expr1,
convert (arg1_type,
- ffecom_float_half_))))),
+ ffecom_float_half_)))),
+ NULL_TREE),
ffecom_1 (NEGATE_EXPR, double_type_node,
ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
build_tree_list (NULL_TREE,
arg1_type,
convert (arg1_type,
ffecom_float_half_),
- saved_expr1)))))
+ saved_expr1))),
+ NULL_TREE))
)
);
#endif
case FFEINTRIN_impCHAR:
case FFEINTRIN_impACHAR:
- assert (ffecom_pending_calls_ != 0);
- tempvar = ffecom_push_tempvar (char_type_node,
- 1, -1, TRUE);
+#ifdef HOHO
+ tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
+#else
+ tempvar = ffebld_nonter_hook (expr);
+ assert (tempvar);
+#endif
{
tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
break; /* Already picked one, stick with it. */
if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtALOG10;
+ /* We used to call FFECOM_gfrtALOG10 here. */
+ gfrt = FFECOM_gfrtL_LOG10;
else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtDLOG10;
+ /* We used to call FFECOM_gfrtDLOG10 here. */
+ gfrt = FFECOM_gfrtL_LOG10;
break;
case FFEINTRIN_impMAX:
convert (tree_type, ffecom_expr (arg2)));
if (kt == FFEINFO_kindtypeREAL1)
- gfrt = FFECOM_gfrtAMOD;
+ /* We used to call FFECOM_gfrtAMOD here. */
+ gfrt = FFECOM_gfrtL_FMOD;
else if (kt == FFEINFO_kindtypeREAL2)
- gfrt = FFECOM_gfrtDMOD;
+ /* We used to call FFECOM_gfrtDMOD here. */
+ gfrt = FFECOM_gfrtL_FMOD;
break;
case FFEINTRIN_impNINT:
case FFEINTRIN_impIDNINT:
-#if 0 /* ~~ ideally FIX_ROUND_EXPR would be
- implemented, but it ain't yet */
+#if 0
+ /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
#else
/* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
tree prep_arg4;
tree arg5_plus_arg3;
- ffecom_push_calltemps ();
-
arg2_tree = convert (integer_type_node,
ffecom_expr (arg2));
arg3_tree = ffecom_save_tree (convert (integer_type_node,
ffecom_expr (arg3)));
- arg4_tree = ffecom_expr_rw (arg4);
+ arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
arg4_type = TREE_TYPE (arg4_tree);
arg1_tree = ffecom_save_tree (convert (arg4_type,
arg5_tree = ffecom_save_tree (convert (integer_type_node,
ffecom_expr (arg5)));
- ffecom_pop_calltemps ();
-
prep_arg1
= ffecom_2 (LSHIFT_EXPR, arg4_type,
ffecom_2 (BIT_AND_EXPR, arg4_type,
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
arg2_tree);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
TREE_CHAIN (arg1_tree) = arg2_tree;
NULL_TREE :
tree_type),
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE)
expr_tree
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
arg2_tree);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
TREE_CHAIN (arg1_tree) = arg2_tree;
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE)
expr_tree
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
if (arg2 != NULL)
- arg2_tree = ffecom_expr_rw (arg2);
+ arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
else
arg2_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
TREE_CHAIN (arg1_tree) = arg1_len;
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg2_tree != NULL_TREE)
expr_tree
FALSE,
void_type_node,
expr_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
case FFEINTRIN_impFLUSH:
if (arg1 == NULL)
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE)
expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
convert (TREE_TYPE (arg3_tree),
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
arg2_tree = ffecom_ptr_to_expr (arg2);
if (arg3 != NULL)
- arg3_tree = ffecom_expr_rw (arg3);
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
else
arg3_tree = NULL_TREE;
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE)
expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
convert (TREE_TYPE (arg3_tree),
tree arg2_len = integer_zero_node;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
arg1_tree);
arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
- arg3_tree = ffecom_expr_rw (arg3);
-
- ffecom_pop_calltemps ();
+ if (arg3 != NULL)
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
+ else
+ arg3_tree = NULL_TREE;
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
- expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
- convert (TREE_TYPE (arg3_tree),
- expr_tree));
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
+ if (arg3_tree != NULL_TREE)
+ expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
+ convert (TREE_TYPE (arg3_tree),
+ expr_tree));
}
return expr_tree;
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
if (arg3 == NULL)
arg3_tree = NULL_TREE;
else
- arg3_tree = ffecom_expr_rw (arg3);
-
- ffecom_pop_calltemps ();
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE) {
expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
convert (TREE_TYPE (arg3_tree),
tree arg2_tree;
tree arg3_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
if (arg3 == NULL)
arg3_tree = NULL_TREE;
else
- arg3_tree = ffecom_expr_rw (arg3);
-
- ffecom_pop_calltemps ();
+ arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
if (arg3_tree != NULL_TREE) {
expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
convert (TREE_TYPE (arg3_tree),
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
- arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
+ arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
- arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ?
+ arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
ffecom_f2c_longint_type_node :
ffecom_f2c_integer_type_node),
- ffecom_expr (arg2));
+ ffecom_expr (arg1));
arg2_tree = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (arg2_tree)),
arg2_tree);
- ffecom_pop_calltemps ();
-
arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
arg1_len = build_tree_list (NULL_TREE, arg1_len);
arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
FALSE,
NULL_TREE,
arg1_tree,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
}
return expr_tree;
FALSE,
((codegen_imp == FFEINTRIN_impIRAND) ?
ffecom_f2c_integer_type_node :
- ffecom_f2c_doublereal_type_node),
+ ffecom_f2c_real_type_node),
arg1_tree,
dest_tree, dest, dest_used,
- NULL_TREE, TRUE);
+ NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
}
return expr_tree;
tree arg1_tree;
tree arg2_tree;
- ffecom_push_calltemps ();
-
arg1_tree = convert (ffecom_f2c_integer_type_node,
ffecom_expr (arg1));
arg1_tree = ffecom_1 (ADDR_EXPR,
if (arg2 == NULL)
arg2_tree = NULL_TREE;
else
- arg2_tree = ffecom_expr_rw (arg2);
-
- ffecom_pop_calltemps ();
+ arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
ffecom_gfrt_kindtype (gfrt),
NULL_TREE,
build_tree_list (NULL_TREE, arg1_tree),
NULL_TREE, NULL, NULL, NULL_TREE,
- TRUE);
+ TRUE,
+ ffebld_nonter_hook (expr));
if (arg2_tree != NULL_TREE) {
expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
convert (TREE_TYPE (arg2_tree),
{
tree arg1_tree;
- ffecom_push_calltemps ();
-
- arg1_tree = ffecom_expr_rw (arg1);
-
- ffecom_pop_calltemps ();
+ arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
FALSE,
NULL_TREE,
NULL_TREE,
- NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
+ NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
expr_tree
= ffecom_modify (NULL_TREE, arg1_tree,
case FFEINTRIN_impETIME_subr:
{
tree arg1_tree;
- tree arg2_tree;
-
- ffecom_push_calltemps ();
+ tree result_tree;
- arg1_tree = ffecom_expr_rw (arg1);
+ result_tree = ffecom_expr_w (NULL_TREE, arg2);
- arg2_tree = ffecom_ptr_to_expr (arg2);
-
- ffecom_pop_calltemps ();
+ arg1_tree = ffecom_ptr_to_expr (arg1);
expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
ffecom_gfrt_kindtype (gfrt),
FALSE,
NULL_TREE,
- build_tree_list (NULL_TREE, arg2_tree),
+ build_tree_list (NULL_TREE, arg1_tree),
NULL_TREE, NULL, NULL, NULL_TREE,
- TRUE);
- expr_tree = ffecom_modify (NULL_TREE, arg1_tree,
- convert (TREE_TYPE (arg1_tree),
+ TRUE,
+ ffebld_nonter_hook (expr));
+ expr_tree = ffecom_modify (NULL_TREE, result_tree,
+ convert (TREE_TYPE (result_tree),
expr_tree));
}
return expr_tree;
- /* Straightforward calls of libf2c routines: */
+ /* Straightforward calls of libf2c routines: */
case FFEINTRIN_impABORT:
case FFEINTRIN_impACCESS:
case FFEINTRIN_impBESJ0:
case FFEINTRIN_impCHDIR_func:
case FFEINTRIN_impCHMOD_func:
case FFEINTRIN_impDATE:
+ case FFEINTRIN_impDATE_AND_TIME:
case FFEINTRIN_impDBESJ0:
case FFEINTRIN_impDBESJ1:
case FFEINTRIN_impDBESJN:
assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
- ffecom_push_calltemps ();
expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
ffebld_right (expr));
- ffecom_pop_calltemps ();
return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
(ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
tree_type,
expr_tree, dest_tree, dest, dest_used,
- NULL_TREE, TRUE);
+ NULL_TREE, TRUE,
+ ffebld_nonter_hook (expr));
- /**INDENT* (Do not reformat this comment even with -fca option.)
- Data-gathering files: Given the source file listed below, compiled with
- f2c I obtained the output file listed after that, and from the output
- file I derived the above code.
-
--------- (begin input file to f2c)
- implicit none
- character*10 A1,A2
- complex C1,C2
- integer I1,I2
- real R1,R2
- double precision D1,D2
-C
- call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
-c /
- call fooI(I1/I2)
- call fooR(R1/I1)
- call fooD(D1/I1)
- call fooC(C1/I1)
- call fooR(R1/R2)
- call fooD(R1/D1)
- call fooD(D1/D2)
- call fooD(D1/R1)
- call fooC(C1/C2)
- call fooC(C1/R1)
- call fooZ(C1/D1)
-c **
- call fooI(I1**I2)
- call fooR(R1**I1)
- call fooD(D1**I1)
- call fooC(C1**I1)
- call fooR(R1**R2)
- call fooD(R1**D1)
- call fooD(D1**D2)
- call fooD(D1**R1)
- call fooC(C1**C2)
- call fooC(C1**R1)
- call fooZ(C1**D1)
-c FFEINTRIN_impABS
- call fooR(ABS(R1))
-c FFEINTRIN_impACOS
- call fooR(ACOS(R1))
-c FFEINTRIN_impAIMAG
- call fooR(AIMAG(C1))
-c FFEINTRIN_impAINT
- call fooR(AINT(R1))
-c FFEINTRIN_impALOG
- call fooR(ALOG(R1))
-c FFEINTRIN_impALOG10
- call fooR(ALOG10(R1))
-c FFEINTRIN_impAMAX0
- call fooR(AMAX0(I1,I2))
-c FFEINTRIN_impAMAX1
- call fooR(AMAX1(R1,R2))
-c FFEINTRIN_impAMIN0
- call fooR(AMIN0(I1,I2))
-c FFEINTRIN_impAMIN1
- call fooR(AMIN1(R1,R2))
-c FFEINTRIN_impAMOD
- call fooR(AMOD(R1,R2))
-c FFEINTRIN_impANINT
- call fooR(ANINT(R1))
-c FFEINTRIN_impASIN
- call fooR(ASIN(R1))
-c FFEINTRIN_impATAN
- call fooR(ATAN(R1))
-c FFEINTRIN_impATAN2
- call fooR(ATAN2(R1,R2))
-c FFEINTRIN_impCABS
- call fooR(CABS(C1))
-c FFEINTRIN_impCCOS
- call fooC(CCOS(C1))
-c FFEINTRIN_impCEXP
- call fooC(CEXP(C1))
-c FFEINTRIN_impCHAR
- call fooA(CHAR(I1))
-c FFEINTRIN_impCLOG
- call fooC(CLOG(C1))
-c FFEINTRIN_impCONJG
- call fooC(CONJG(C1))
-c FFEINTRIN_impCOS
- call fooR(COS(R1))
-c FFEINTRIN_impCOSH
- call fooR(COSH(R1))
-c FFEINTRIN_impCSIN
- call fooC(CSIN(C1))
-c FFEINTRIN_impCSQRT
- call fooC(CSQRT(C1))
-c FFEINTRIN_impDABS
- call fooD(DABS(D1))
-c FFEINTRIN_impDACOS
- call fooD(DACOS(D1))
-c FFEINTRIN_impDASIN
- call fooD(DASIN(D1))
-c FFEINTRIN_impDATAN
- call fooD(DATAN(D1))
-c FFEINTRIN_impDATAN2
- call fooD(DATAN2(D1,D2))
-c FFEINTRIN_impDCOS
- call fooD(DCOS(D1))
-c FFEINTRIN_impDCOSH
- call fooD(DCOSH(D1))
-c FFEINTRIN_impDDIM
- call fooD(DDIM(D1,D2))
-c FFEINTRIN_impDEXP
- call fooD(DEXP(D1))
-c FFEINTRIN_impDIM
- call fooR(DIM(R1,R2))
-c FFEINTRIN_impDINT
- call fooD(DINT(D1))
-c FFEINTRIN_impDLOG
- call fooD(DLOG(D1))
-c FFEINTRIN_impDLOG10
- call fooD(DLOG10(D1))
-c FFEINTRIN_impDMAX1
- call fooD(DMAX1(D1,D2))
-c FFEINTRIN_impDMIN1
- call fooD(DMIN1(D1,D2))
-c FFEINTRIN_impDMOD
- call fooD(DMOD(D1,D2))
-c FFEINTRIN_impDNINT
- call fooD(DNINT(D1))
-c FFEINTRIN_impDPROD
- call fooD(DPROD(R1,R2))
-c FFEINTRIN_impDSIGN
- call fooD(DSIGN(D1,D2))
-c FFEINTRIN_impDSIN
- call fooD(DSIN(D1))
-c FFEINTRIN_impDSINH
- call fooD(DSINH(D1))
-c FFEINTRIN_impDSQRT
- call fooD(DSQRT(D1))
-c FFEINTRIN_impDTAN
- call fooD(DTAN(D1))
-c FFEINTRIN_impDTANH
- call fooD(DTANH(D1))
-c FFEINTRIN_impEXP
- call fooR(EXP(R1))
-c FFEINTRIN_impIABS
- call fooI(IABS(I1))
-c FFEINTRIN_impICHAR
- call fooI(ICHAR(A1))
-c FFEINTRIN_impIDIM
- call fooI(IDIM(I1,I2))
-c FFEINTRIN_impIDNINT
- call fooI(IDNINT(D1))
-c FFEINTRIN_impINDEX
- call fooI(INDEX(A1,A2))
-c FFEINTRIN_impISIGN
- call fooI(ISIGN(I1,I2))
-c FFEINTRIN_impLEN
- call fooI(LEN(A1))
-c FFEINTRIN_impLGE
- call fooL(LGE(A1,A2))
-c FFEINTRIN_impLGT
- call fooL(LGT(A1,A2))
-c FFEINTRIN_impLLE
- call fooL(LLE(A1,A2))
-c FFEINTRIN_impLLT
- call fooL(LLT(A1,A2))
-c FFEINTRIN_impMAX0
- call fooI(MAX0(I1,I2))
-c FFEINTRIN_impMAX1
- call fooI(MAX1(R1,R2))
-c FFEINTRIN_impMIN0
- call fooI(MIN0(I1,I2))
-c FFEINTRIN_impMIN1
- call fooI(MIN1(R1,R2))
-c FFEINTRIN_impMOD
- call fooI(MOD(I1,I2))
-c FFEINTRIN_impNINT
- call fooI(NINT(R1))
-c FFEINTRIN_impSIGN
- call fooR(SIGN(R1,R2))
-c FFEINTRIN_impSIN
- call fooR(SIN(R1))
-c FFEINTRIN_impSINH
- call fooR(SINH(R1))
-c FFEINTRIN_impSQRT
- call fooR(SQRT(R1))
-c FFEINTRIN_impTAN
- call fooR(TAN(R1))
-c FFEINTRIN_impTANH
- call fooR(TANH(R1))
-c FFEINTRIN_imp_CMPLX_C
- call fooC(cmplx(C1,C2))
-c FFEINTRIN_imp_CMPLX_D
- call fooZ(cmplx(D1,D2))
-c FFEINTRIN_imp_CMPLX_I
- call fooC(cmplx(I1,I2))
-c FFEINTRIN_imp_CMPLX_R
- call fooC(cmplx(R1,R2))
-c FFEINTRIN_imp_DBLE_C
- call fooD(dble(C1))
-c FFEINTRIN_imp_DBLE_D
- call fooD(dble(D1))
-c FFEINTRIN_imp_DBLE_I
- call fooD(dble(I1))
-c FFEINTRIN_imp_DBLE_R
- call fooD(dble(R1))
-c FFEINTRIN_imp_INT_C
- call fooI(int(C1))
-c FFEINTRIN_imp_INT_D
- call fooI(int(D1))
-c FFEINTRIN_imp_INT_I
- call fooI(int(I1))
-c FFEINTRIN_imp_INT_R
- call fooI(int(R1))
-c FFEINTRIN_imp_REAL_C
- call fooR(real(C1))
-c FFEINTRIN_imp_REAL_D
- call fooR(real(D1))
-c FFEINTRIN_imp_REAL_I
- call fooR(real(I1))
-c FFEINTRIN_imp_REAL_R
- call fooR(real(R1))
-c
-c FFEINTRIN_imp_INT_D:
-c
-c FFEINTRIN_specIDINT
- call fooI(IDINT(D1))
-c
-c FFEINTRIN_imp_INT_R:
-c
-c FFEINTRIN_specIFIX
- call fooI(IFIX(R1))
-c FFEINTRIN_specINT
- call fooI(INT(R1))
-c
-c FFEINTRIN_imp_REAL_D:
-c
-c FFEINTRIN_specSNGL
- call fooR(SNGL(D1))
-c
-c FFEINTRIN_imp_REAL_I:
-c
-c FFEINTRIN_specFLOAT
- call fooR(FLOAT(I1))
-c FFEINTRIN_specREAL
- call fooR(REAL(I1))
-c
- end
--------- (end input file to f2c)
-
--------- (begin output from providing above input file as input to:
--------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
--------- -e "s:^#.*$::g"')
-
-// -- translated by f2c (version 19950223).
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
-//
-
-
-// f2c.h -- Standard Fortran to C header file //
-
-/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
-
- - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
+ /* See bottom of this file for f2c transforms used to determine
+ many of the above implementations. The info seems to confuse
+ Emacs's C mode indentation, which is why it's been moved to
+ the bottom of this source file. */
+}
+#endif
+/* For power (exponentiation) where right-hand operand is type INTEGER,
+ generate in-line code to do it the fast way (which, if the operand
+ is a constant, might just mean a series of multiplies). */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_expr_power_integer_ (ffebld expr)
+{
+ tree l = ffecom_expr (ffebld_left (expr));
+ tree r = ffecom_expr (ffebld_right (expr));
+ tree ltype = TREE_TYPE (l);
+ tree rtype = TREE_TYPE (r);
+ tree result = NULL_TREE;
+ if (l == error_mark_node
+ || r == error_mark_node)
+ return error_mark_node;
-// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
-// we assume short, float are OK //
-typedef long int // long int // integer;
-typedef char *address;
-typedef short int shortint;
-typedef float real;
-typedef double doublereal;
-typedef struct { real r, i; } complex;
-typedef struct { doublereal r, i; } doublecomplex;
-typedef long int // long int // logical;
-typedef short int shortlogical;
-typedef char logical1;
-typedef char integer1;
-// typedef long long longint; // // system-dependent //
+ if (TREE_CODE (r) == INTEGER_CST)
+ {
+ int sgn = tree_int_cst_sgn (r);
+ if (sgn == 0)
+ return convert (ltype, integer_one_node);
+ if ((TREE_CODE (ltype) == INTEGER_TYPE)
+ && (sgn < 0))
+ {
+ /* Reciprocal of integer is either 0, -1, or 1, so after
+ calculating that (which we leave to the back end to do
+ or not do optimally), don't bother with any multiplying. */
+ result = ffecom_tree_divide_ (ltype,
+ convert (ltype, integer_one_node),
+ l,
+ NULL_TREE, NULL, NULL, NULL_TREE);
+ r = ffecom_1 (NEGATE_EXPR,
+ rtype,
+ r);
+ if ((TREE_INT_CST_LOW (r) & 1) == 0)
+ result = ffecom_1 (ABS_EXPR, rtype,
+ result);
+ }
-// Extern is for use with -E //
+ /* Generate appropriate series of multiplies, preceded
+ by divide if the exponent is negative. */
+ l = save_expr (l);
+ if (sgn < 0)
+ {
+ l = ffecom_tree_divide_ (ltype,
+ convert (ltype, integer_one_node),
+ l,
+ NULL_TREE, NULL, NULL,
+ ffebld_nonter_hook (expr));
+ r = ffecom_1 (NEGATE_EXPR, rtype, r);
+ assert (TREE_CODE (r) == INTEGER_CST);
+ if (tree_int_cst_sgn (r) < 0)
+ { /* The "most negative" number. */
+ r = ffecom_1 (NEGATE_EXPR, rtype,
+ ffecom_2 (RSHIFT_EXPR, rtype,
+ r,
+ integer_one_node));
+ l = save_expr (l);
+ l = ffecom_2 (MULT_EXPR, ltype,
+ l,
+ l);
+ }
+ }
-// I/O stuff //
+ for (;;)
+ {
+ if (TREE_INT_CST_LOW (r) & 1)
+ {
+ if (result == NULL_TREE)
+ result = l;
+ else
+ result = ffecom_2 (MULT_EXPR, ltype,
+ result,
+ l);
+ }
+ r = ffecom_2 (RSHIFT_EXPR, rtype,
+ r,
+ integer_one_node);
+ if (integer_zerop (r))
+ break;
+ assert (TREE_CODE (r) == INTEGER_CST);
+ l = save_expr (l);
+ l = ffecom_2 (MULT_EXPR, ltype,
+ l,
+ l);
+ }
+ return result;
+ }
+ /* Though rhs isn't a constant, in-line code cannot be expanded
+ while transforming dummies
+ because the back end cannot be easily convinced to generate
+ stores (MODIFY_EXPR), handle temporaries, and so on before
+ all the appropriate rtx's have been generated for things like
+ dummy args referenced in rhs -- which doesn't happen until
+ store_parm_decls() is called (expand_function_start, I believe,
+ does the actual rtx-stuffing of PARM_DECLs).
+ So, in this case, let the caller generate the call to the
+ run-time-library function to evaluate the power for us. */
+ if (ffecom_transform_only_dummies_)
+ return NULL_TREE;
+ /* Right-hand operand not a constant, expand in-line code to figure
+ out how to do the multiplies, &c.
+ The returned expression is expressed this way in GNU C, where l and
+ r are the "inputs":
-typedef long int // int or long int // flag;
-typedef long int // int or long int // ftnlen;
-typedef long int // int or long int // ftnint;
+ ({ typeof (r) rtmp = r;
+ typeof (l) ltmp = l;
+ typeof (l) result;
+ if (rtmp == 0)
+ result = 1;
+ else
+ {
+ if ((basetypeof (l) == basetypeof (int))
+ && (rtmp < 0))
+ {
+ result = ((typeof (l)) 1) / ltmp;
+ if ((ltmp < 0) && (((-rtmp) & 1) == 0))
+ result = -result;
+ }
+ else
+ {
+ result = 1;
+ if ((basetypeof (l) != basetypeof (int))
+ && (rtmp < 0))
+ {
+ ltmp = ((typeof (l)) 1) / ltmp;
+ rtmp = -rtmp;
+ if (rtmp < 0)
+ {
+ rtmp = -(rtmp >> 1);
+ ltmp *= ltmp;
+ }
+ }
+ for (;;)
+ {
+ if (rtmp & 1)
+ result *= ltmp;
+ if ((rtmp >>= 1) == 0)
+ break;
+ ltmp *= ltmp;
+ }
+ }
+ }
+ result;
+ })
-//external read, write//
-typedef struct
-{ flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
-} cilist;
+ Note that some of the above is compile-time collapsable, such as
+ the first part of the if statements that checks the base type of
+ l against int. The if statements are phrased that way to suggest
+ an easy way to generate the if/else constructs here, knowing that
+ the back end should (and probably does) eliminate the resulting
+ dead code (either the int case or the non-int case), something
+ it couldn't do without the redundant phrasing, requiring explicit
+ dead-code elimination here, which would be kind of difficult to
+ read. */
-//internal read, write//
-typedef struct
-{ flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
-} icilist;
+ {
+ tree rtmp;
+ tree ltmp;
+ tree divide;
+ tree basetypeof_l_is_int;
+ tree se;
+ tree t;
-//open//
-typedef struct
-{ flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
-} olist;
+ basetypeof_l_is_int
+ = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
-//close//
-typedef struct
-{ flag cerr;
- ftnint cunit;
- char *csta;
-} cllist;
+ se = expand_start_stmt_expr ();
-//rewind, backspace, endfile//
-typedef struct
-{ flag aerr;
- ftnint aunit;
-} alist;
+ ffecom_start_compstmt ();
+
+#ifndef HAHA
+ rtmp = ffecom_make_tempvar ("power_r", rtype,
+ FFETARGET_charactersizeNONE, -1);
+ ltmp = ffecom_make_tempvar ("power_l", ltype,
+ FFETARGET_charactersizeNONE, -1);
+ result = ffecom_make_tempvar ("power_res", ltype,
+ FFETARGET_charactersizeNONE, -1);
+ if (TREE_CODE (ltype) == COMPLEX_TYPE
+ || TREE_CODE (ltype) == RECORD_TYPE)
+ divide = ffecom_make_tempvar ("power_div", ltype,
+ FFETARGET_charactersizeNONE, -1);
+ else
+ divide = NULL_TREE;
+#else /* HAHA */
+ {
+ tree hook;
+
+ hook = ffebld_nonter_hook (expr);
+ assert (hook);
+ assert (TREE_CODE (hook) == TREE_VEC);
+ assert (TREE_VEC_LENGTH (hook) == 4);
+ rtmp = TREE_VEC_ELT (hook, 0);
+ ltmp = TREE_VEC_ELT (hook, 1);
+ result = TREE_VEC_ELT (hook, 2);
+ divide = TREE_VEC_ELT (hook, 3);
+ if (TREE_CODE (ltype) == COMPLEX_TYPE
+ || TREE_CODE (ltype) == RECORD_TYPE)
+ assert (divide);
+ else
+ assert (! divide);
+ }
+#endif /* HAHA */
-// inquire //
-typedef struct
-{ flag inerr;
- ftnint inunit;
- char *infile;
- ftnlen infilen;
- ftnint *inex; //parameters in standard's order//
- ftnint *inopen;
- ftnint *innum;
- ftnint *innamed;
- char *inname;
- ftnlen innamlen;
- char *inacc;
- ftnlen inacclen;
- char *inseq;
- ftnlen inseqlen;
- char *indir;
- ftnlen indirlen;
- char *infmt;
- ftnlen infmtlen;
- char *inform;
- ftnint informlen;
- char *inunf;
- ftnlen inunflen;
- ftnint *inrecl;
- ftnint *innrec;
- char *inblank;
- ftnlen inblanklen;
-} inlist;
-
-
-
-union Multitype { // for multiple entry points //
- integer1 g;
- shortint h;
- integer i;
- // longint j; //
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ rtmp,
+ r));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ l));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (EQ_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype, integer_zero_node))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ convert (ltype, integer_one_node)));
+ expand_start_else ();
+ if (! integer_zerop (basetypeof_l_is_int))
+ {
+ expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype,
+ integer_zero_node)),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ ffecom_tree_divide_
+ (ltype,
+ convert (ltype, integer_one_node),
+ ltmp,
+ NULL_TREE, NULL, NULL,
+ divide)));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
+ ffecom_2 (LT_EXPR, integer_type_node,
+ ltmp,
+ convert (ltype,
+ integer_zero_node)),
+ ffecom_2 (EQ_EXPR, integer_type_node,
+ ffecom_2 (BIT_AND_EXPR,
+ rtype,
+ ffecom_1 (NEGATE_EXPR,
+ rtype,
+ rtmp),
+ convert (rtype,
+ integer_one_node)),
+ convert (rtype,
+ integer_zero_node)))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ ffecom_1 (NEGATE_EXPR,
+ ltype,
+ result)));
+ expand_end_cond ();
+ expand_start_else ();
+ }
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ convert (ltype, integer_one_node)));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
+ ffecom_truth_value_invert
+ (basetypeof_l_is_int),
+ ffecom_2 (LT_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype,
+ integer_zero_node)))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ ffecom_tree_divide_
+ (ltype,
+ convert (ltype, integer_one_node),
+ ltmp,
+ NULL_TREE, NULL, NULL,
+ divide)));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ rtmp,
+ ffecom_1 (NEGATE_EXPR, rtype,
+ rtmp)));
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (LT_EXPR, integer_type_node,
+ rtmp,
+ convert (rtype, integer_zero_node))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ rtmp,
+ ffecom_1 (NEGATE_EXPR, rtype,
+ ffecom_2 (RSHIFT_EXPR,
+ rtype,
+ rtmp,
+ integer_one_node))));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ ffecom_2 (MULT_EXPR, ltype,
+ ltmp,
+ ltmp)));
+ expand_end_cond ();
+ expand_end_cond ();
+ expand_start_loop (1);
+ expand_start_cond (ffecom_truth_value
+ (ffecom_2 (BIT_AND_EXPR, rtype,
+ rtmp,
+ convert (rtype, integer_one_node))),
+ 0);
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ result,
+ ffecom_2 (MULT_EXPR, ltype,
+ result,
+ ltmp)));
+ expand_end_cond ();
+ expand_exit_loop_if_false (NULL,
+ ffecom_truth_value
+ (ffecom_modify (rtype,
+ rtmp,
+ ffecom_2 (RSHIFT_EXPR,
+ rtype,
+ rtmp,
+ integer_one_node))));
+ expand_expr_stmt (ffecom_modify (void_type_node,
+ ltmp,
+ ffecom_2 (MULT_EXPR, ltype,
+ ltmp,
+ ltmp)));
+ expand_end_loop ();
+ expand_end_cond ();
+ if (!integer_zerop (basetypeof_l_is_int))
+ expand_end_cond ();
+ expand_expr_stmt (result);
-typedef union Multitype Multitype;
+ t = ffecom_end_compstmt ();
-typedef long Long; // No longer used; formerly in Namelist //
+ result = expand_end_stmt_expr (se);
-struct Vardesc { // for Namelist //
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
-typedef struct Vardesc Vardesc;
+ /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
-struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
-typedef struct Namelist Namelist;
+ if (TREE_CODE (t) == BLOCK)
+ {
+ /* Make a BIND_EXPR for the BLOCK already made. */
+ result = build (BIND_EXPR, TREE_TYPE (result),
+ NULL_TREE, result, t);
+ /* Remove the block from the tree at this point.
+ It gets put back at the proper place
+ when the BIND_EXPR is expanded. */
+ delete_block (t);
+ }
+ else
+ result = t;
+ }
+ return result;
+}
+#endif
+/* ffecom_expr_transform_ -- Transform symbols in expr
+ ffebld expr; // FFE expression.
+ ffecom_expr_transform_ (expr);
+ Recursive descent on expr while transforming any untransformed SYMTERs. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_expr_transform_ (ffebld expr)
+{
+ tree t;
+ ffesymbol s;
+tail_recurse: /* :::::::::::::::::::: */
+ if (expr == NULL)
+ return;
-// procedure parameter types for -A and -C++ //
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opSYMTER:
+ s = ffebld_symter (expr);
+ t = ffesymbol_hook (s).decl_tree;
+ if ((t == NULL_TREE)
+ && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
+ || ((ffesymbol_where (s) != FFEINFO_whereNONE)
+ && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
+ {
+ s = ffecom_sym_transform_ (s);
+ t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
+ DIMENSION expr? */
+ }
+ break; /* Ok if (t == NULL) here. */
+ case FFEBLD_opITEM:
+ ffecom_expr_transform_ (ffebld_head (expr));
+ expr = ffebld_trail (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
+ default:
+ break;
+ }
+ switch (ffebld_arity (expr))
+ {
+ case 2:
+ ffecom_expr_transform_ (ffebld_left (expr));
+ expr = ffebld_right (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
-typedef int // Unknown procedure type // (*U_fp)();
-typedef shortint (*J_fp)();
-typedef integer (*I_fp)();
-typedef real (*R_fp)();
-typedef doublereal (*D_fp)(), (*E_fp)();
-typedef // Complex // void (*C_fp)();
-typedef // Double Complex // void (*Z_fp)();
-typedef logical (*L_fp)();
-typedef shortlogical (*K_fp)();
-typedef // Character // void (*H_fp)();
-typedef // Subroutine // int (*S_fp)();
+ case 1:
+ expr = ffebld_left (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
-// E_fp is for real functions when -R is not specified //
-typedef void C_f; // complex function //
-typedef void H_f; // character function //
-typedef void Z_f; // double complex function //
-typedef doublereal E_f; // real function with -R not specified //
+ default:
+ break;
+ }
-// undef any lower-case symbols that your C compiler predefines, e.g.: //
+ return;
+}
+#endif
+/* Make a type based on info in live f2c.h file. */
-// (No such symbols should be defined in a strict ANSI C compiler.
- We can avoid trouble with f2c-translated code by using
- gcc -ansi [-traditional].) //
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
+{
+ switch (tcode)
+ {
+ case FFECOM_f2ccodeCHAR:
+ *type = make_signed_type (CHAR_TYPE_SIZE);
+ break;
+
+ case FFECOM_f2ccodeSHORT:
+ *type = make_signed_type (SHORT_TYPE_SIZE);
+ break;
+
+ case FFECOM_f2ccodeINT:
+ *type = make_signed_type (INT_TYPE_SIZE);
+ break;
+
+ case FFECOM_f2ccodeLONG:
+ *type = make_signed_type (LONG_TYPE_SIZE);
+ break;
+
+ case FFECOM_f2ccodeLONGLONG:
+ *type = make_signed_type (LONG_LONG_TYPE_SIZE);
+ break;
+
+ case FFECOM_f2ccodeCHARPTR:
+ *type = build_pointer_type (DEFAULT_SIGNED_CHAR
+ ? signed_char_type_node
+ : unsigned_char_type_node);
+ break;
+
+ case FFECOM_f2ccodeFLOAT:
+ *type = make_node (REAL_TYPE);
+ TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
+ layout_type (*type);
+ break;
+
+ case FFECOM_f2ccodeDOUBLE:
+ *type = make_node (REAL_TYPE);
+ TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
+ layout_type (*type);
+ break;
+ case FFECOM_f2ccodeLONGDOUBLE:
+ *type = make_node (REAL_TYPE);
+ TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
+ layout_type (*type);
+ break;
+ case FFECOM_f2ccodeTWOREALS:
+ *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
+ break;
+ case FFECOM_f2ccodeTWODOUBLEREALS:
+ *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
+ break;
+ default:
+ assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
+ *type = error_mark_node;
+ return;
+ }
+ pushdecl (build_decl (TYPE_DECL,
+ ffecom_get_invented_identifier ("__g77_f2c_%s", name),
+ *type));
+}
+#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+/* Set the f2c list-directed-I/O code for whatever (integral) type has the
+ given size. */
+static void
+ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
+ int code)
+{
+ int j;
+ tree t;
+ for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
+ if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
+ && compare_tree_int (TYPE_SIZE (t), size) == 0)
+ {
+ assert (code != -1);
+ ffecom_f2c_typecode_[bt][j] = code;
+ code = -1;
+ }
+}
+#endif
+/* Finish up globals after doing all program units in file
+ Need to handle only uninitialized COMMON areas. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffeglobal
+ffecom_finish_global_ (ffeglobal global)
+{
+ tree cbtype;
+ tree cbt;
+ tree size;
+ if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
+ return global;
+ if (ffeglobal_common_init (global))
+ return global;
+ cbt = ffeglobal_hook (global);
+ if ((cbt == NULL_TREE)
+ || !ffeglobal_common_have_size (global))
+ return global; /* No need to make common, never ref'd. */
+ DECL_EXTERNAL (cbt) = 0;
+ /* Give the array a size now. */
+ size = build_int_2 ((ffeglobal_common_size (global)
+ + ffeglobal_common_pad (global)) - 1,
+ 0);
+ cbtype = TREE_TYPE (cbt);
+ TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
+ integer_zero_node,
+ size);
+ if (!TREE_TYPE (size))
+ TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
+ layout_type (cbtype);
+ cbt = start_decl (cbt, FALSE);
+ assert (cbt == ffeglobal_hook (global));
+ finish_decl (cbt, NULL_TREE, FALSE);
+ return global;
+}
+#endif
+/* Finish up any untransformed symbols. */
-// Main program // MAIN__()
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffesymbol
+ffecom_finish_symbol_transform_ (ffesymbol s)
{
- // System generated locals //
- integer i__1;
- real r__1, r__2;
- doublereal d__1, d__2;
- complex q__1;
- doublecomplex z__1, z__2, z__3;
- logical L__1;
- char ch__1[1];
+ if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
+ return s;
- // Builtin functions //
- void c_div();
- integer pow_ii();
- double pow_ri(), pow_di();
- void pow_ci();
- double pow_dd();
- void pow_zz();
- double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
- asin(), atan(), atan2(), c_abs();
- void c_cos(), c_exp(), c_log(), r_cnjg();
- double cos(), cosh();
- void c_sin(), c_sqrt();
- double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
- d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
- integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
- logical l_ge(), l_gt(), l_le(), l_lt();
- integer i_nint();
- double r_sign();
+ /* It's easy to know to transform an untransformed symbol, to make sure
+ we put out debugging info for it. But COMMON variables, unlike
+ EQUIVALENCE ones, aren't given declarations in addition to the
+ tree expressions that specify offsets, because COMMON variables
+ can be referenced in the outer scope where only dummy arguments
+ (PARM_DECLs) should really be seen. To be safe, just don't do any
+ VAR_DECLs for COMMON variables when we transform them for real
+ use, and therefore we do all the VAR_DECL creating here. */
- // Local variables //
- extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
- fool_(), fooz_(), getem_();
- static char a1[10], a2[10];
- static complex c1, c2;
- static doublereal d1, d2;
- static integer i1, i2;
- static real r1, r2;
+ if (ffesymbol_hook (s).decl_tree == NULL_TREE)
+ {
+ if (ffesymbol_kind (s) != FFEINFO_kindNONE
+ || (ffesymbol_where (s) != FFEINFO_whereNONE
+ && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
+ && ffesymbol_where (s) != FFEINFO_whereDUMMY))
+ /* Not transformed, and not CHARACTER*(*), and not a dummy
+ argument, which can happen only if the entry point names
+ it "rides in on" are all invalidated for other reasons. */
+ s = ffecom_sym_transform_ (s);
+ }
-
- getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
-// / //
- i__1 = i1 / i2;
- fooi_(&i__1);
- r__1 = r1 / i1;
- foor_(&r__1);
- d__1 = d1 / i1;
- food_(&d__1);
- d__1 = (doublereal) i1;
- q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
- fooc_(&q__1);
- r__1 = r1 / r2;
- foor_(&r__1);
- d__1 = r1 / d1;
- food_(&d__1);
- d__1 = d1 / d2;
- food_(&d__1);
- d__1 = d1 / r1;
- food_(&d__1);
- c_div(&q__1, &c1, &c2);
- fooc_(&q__1);
- q__1.r = c1.r / r1, q__1.i = c1.i / r1;
- fooc_(&q__1);
- z__1.r = c1.r / d1, z__1.i = c1.i / d1;
- fooz_(&z__1);
-// ** //
- i__1 = pow_ii(&i1, &i2);
- fooi_(&i__1);
- r__1 = pow_ri(&r1, &i1);
- foor_(&r__1);
- d__1 = pow_di(&d1, &i1);
- food_(&d__1);
- pow_ci(&q__1, &c1, &i1);
- fooc_(&q__1);
- d__1 = (doublereal) r1;
- d__2 = (doublereal) r2;
- r__1 = pow_dd(&d__1, &d__2);
- foor_(&r__1);
- d__2 = (doublereal) r1;
- d__1 = pow_dd(&d__2, &d1);
- food_(&d__1);
- d__1 = pow_dd(&d1, &d2);
- food_(&d__1);
- d__2 = (doublereal) r1;
- d__1 = pow_dd(&d1, &d__2);
- food_(&d__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = c2.r, z__3.i = c2.i;
- pow_zz(&z__1, &z__2, &z__3);
- q__1.r = z__1.r, q__1.i = z__1.i;
- fooc_(&q__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = r1, z__3.i = 0.;
- pow_zz(&z__1, &z__2, &z__3);
- q__1.r = z__1.r, q__1.i = z__1.i;
- fooc_(&q__1);
- z__2.r = c1.r, z__2.i = c1.i;
- z__3.r = d1, z__3.i = 0.;
- pow_zz(&z__1, &z__2, &z__3);
- fooz_(&z__1);
-// FFEINTRIN_impABS //
- r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
- foor_(&r__1);
-// FFEINTRIN_impACOS //
- r__1 = acos(r1);
- foor_(&r__1);
-// FFEINTRIN_impAIMAG //
- r__1 = r_imag(&c1);
- foor_(&r__1);
-// FFEINTRIN_impAINT //
- r__1 = r_int(&r1);
- foor_(&r__1);
-// FFEINTRIN_impALOG //
- r__1 = log(r1);
- foor_(&r__1);
-// FFEINTRIN_impALOG10 //
- r__1 = r_lg10(&r1);
- foor_(&r__1);
-// FFEINTRIN_impAMAX0 //
- r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMAX1 //
- r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMIN0 //
- r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMIN1 //
- r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
- foor_(&r__1);
-// FFEINTRIN_impAMOD //
- r__1 = r_mod(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impANINT //
- r__1 = r_nint(&r1);
- foor_(&r__1);
-// FFEINTRIN_impASIN //
- r__1 = asin(r1);
- foor_(&r__1);
-// FFEINTRIN_impATAN //
- r__1 = atan(r1);
- foor_(&r__1);
-// FFEINTRIN_impATAN2 //
- r__1 = atan2(r1, r2);
- foor_(&r__1);
-// FFEINTRIN_impCABS //
- r__1 = c_abs(&c1);
- foor_(&r__1);
-// FFEINTRIN_impCCOS //
- c_cos(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCEXP //
- c_exp(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCHAR //
- *(unsigned char *)&ch__1[0] = i1;
- fooa_(ch__1, 1L);
-// FFEINTRIN_impCLOG //
- c_log(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCONJG //
- r_cnjg(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCOS //
- r__1 = cos(r1);
- foor_(&r__1);
-// FFEINTRIN_impCOSH //
- r__1 = cosh(r1);
- foor_(&r__1);
-// FFEINTRIN_impCSIN //
- c_sin(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impCSQRT //
- c_sqrt(&q__1, &c1);
- fooc_(&q__1);
-// FFEINTRIN_impDABS //
- d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
- food_(&d__1);
-// FFEINTRIN_impDACOS //
- d__1 = acos(d1);
- food_(&d__1);
-// FFEINTRIN_impDASIN //
- d__1 = asin(d1);
- food_(&d__1);
-// FFEINTRIN_impDATAN //
- d__1 = atan(d1);
- food_(&d__1);
-// FFEINTRIN_impDATAN2 //
- d__1 = atan2(d1, d2);
- food_(&d__1);
-// FFEINTRIN_impDCOS //
- d__1 = cos(d1);
- food_(&d__1);
-// FFEINTRIN_impDCOSH //
- d__1 = cosh(d1);
- food_(&d__1);
-// FFEINTRIN_impDDIM //
- d__1 = d_dim(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDEXP //
- d__1 = exp(d1);
- food_(&d__1);
-// FFEINTRIN_impDIM //
- r__1 = r_dim(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impDINT //
- d__1 = d_int(&d1);
- food_(&d__1);
-// FFEINTRIN_impDLOG //
- d__1 = log(d1);
- food_(&d__1);
-// FFEINTRIN_impDLOG10 //
- d__1 = d_lg10(&d1);
- food_(&d__1);
-// FFEINTRIN_impDMAX1 //
- d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
- food_(&d__1);
-// FFEINTRIN_impDMIN1 //
- d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
- food_(&d__1);
-// FFEINTRIN_impDMOD //
- d__1 = d_mod(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDNINT //
- d__1 = d_nint(&d1);
- food_(&d__1);
-// FFEINTRIN_impDPROD //
- d__1 = (doublereal) r1 * r2;
- food_(&d__1);
-// FFEINTRIN_impDSIGN //
- d__1 = d_sign(&d1, &d2);
- food_(&d__1);
-// FFEINTRIN_impDSIN //
- d__1 = sin(d1);
- food_(&d__1);
-// FFEINTRIN_impDSINH //
- d__1 = sinh(d1);
- food_(&d__1);
-// FFEINTRIN_impDSQRT //
- d__1 = sqrt(d1);
- food_(&d__1);
-// FFEINTRIN_impDTAN //
- d__1 = tan(d1);
- food_(&d__1);
-// FFEINTRIN_impDTANH //
- d__1 = tanh(d1);
- food_(&d__1);
-// FFEINTRIN_impEXP //
- r__1 = exp(r1);
- foor_(&r__1);
-// FFEINTRIN_impIABS //
- i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impICHAR //
- i__1 = *(unsigned char *)a1;
- fooi_(&i__1);
-// FFEINTRIN_impIDIM //
- i__1 = i_dim(&i1, &i2);
- fooi_(&i__1);
-// FFEINTRIN_impIDNINT //
- i__1 = i_dnnt(&d1);
- fooi_(&i__1);
-// FFEINTRIN_impINDEX //
- i__1 = i_indx(a1, a2, 10L, 10L);
- fooi_(&i__1);
-// FFEINTRIN_impISIGN //
- i__1 = i_sign(&i1, &i2);
- fooi_(&i__1);
-// FFEINTRIN_impLEN //
- i__1 = i_len(a1, 10L);
- fooi_(&i__1);
-// FFEINTRIN_impLGE //
- L__1 = l_ge(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLGT //
- L__1 = l_gt(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLLE //
- L__1 = l_le(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impLLT //
- L__1 = l_lt(a1, a2, 10L, 10L);
- fool_(&L__1);
-// FFEINTRIN_impMAX0 //
- i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMAX1 //
- i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMIN0 //
- i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMIN1 //
- i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
- fooi_(&i__1);
-// FFEINTRIN_impMOD //
- i__1 = i1 % i2;
- fooi_(&i__1);
-// FFEINTRIN_impNINT //
- i__1 = i_nint(&r1);
- fooi_(&i__1);
-// FFEINTRIN_impSIGN //
- r__1 = r_sign(&r1, &r2);
- foor_(&r__1);
-// FFEINTRIN_impSIN //
- r__1 = sin(r1);
- foor_(&r__1);
-// FFEINTRIN_impSINH //
- r__1 = sinh(r1);
- foor_(&r__1);
-// FFEINTRIN_impSQRT //
- r__1 = sqrt(r1);
- foor_(&r__1);
-// FFEINTRIN_impTAN //
- r__1 = tan(r1);
- foor_(&r__1);
-// FFEINTRIN_impTANH //
- r__1 = tanh(r1);
- foor_(&r__1);
-// FFEINTRIN_imp_CMPLX_C //
- r__1 = c1.r;
- r__2 = c2.r;
- q__1.r = r__1, q__1.i = r__2;
- fooc_(&q__1);
-// FFEINTRIN_imp_CMPLX_D //
- z__1.r = d1, z__1.i = d2;
- fooz_(&z__1);
-// FFEINTRIN_imp_CMPLX_I //
- r__1 = (real) i1;
- r__2 = (real) i2;
- q__1.r = r__1, q__1.i = r__2;
- fooc_(&q__1);
-// FFEINTRIN_imp_CMPLX_R //
- q__1.r = r1, q__1.i = r2;
- fooc_(&q__1);
-// FFEINTRIN_imp_DBLE_C //
- d__1 = (doublereal) c1.r;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_D //
- d__1 = d1;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_I //
- d__1 = (doublereal) i1;
- food_(&d__1);
-// FFEINTRIN_imp_DBLE_R //
- d__1 = (doublereal) r1;
- food_(&d__1);
-// FFEINTRIN_imp_INT_C //
- i__1 = (integer) c1.r;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_D //
- i__1 = (integer) d1;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_I //
- i__1 = i1;
- fooi_(&i__1);
-// FFEINTRIN_imp_INT_R //
- i__1 = (integer) r1;
- fooi_(&i__1);
-// FFEINTRIN_imp_REAL_C //
- r__1 = c1.r;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_D //
- r__1 = (real) d1;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_I //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_imp_REAL_R //
- r__1 = r1;
- foor_(&r__1);
-
-// FFEINTRIN_imp_INT_D: //
-
-// FFEINTRIN_specIDINT //
- i__1 = (integer) d1;
- fooi_(&i__1);
-
-// FFEINTRIN_imp_INT_R: //
-
-// FFEINTRIN_specIFIX //
- i__1 = (integer) r1;
- fooi_(&i__1);
-// FFEINTRIN_specINT //
- i__1 = (integer) r1;
- fooi_(&i__1);
-
-// FFEINTRIN_imp_REAL_D: //
-
-// FFEINTRIN_specSNGL //
- r__1 = (real) d1;
- foor_(&r__1);
-
-// FFEINTRIN_imp_REAL_I: //
-
-// FFEINTRIN_specFLOAT //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_specREAL //
- r__1 = (real) i1;
- foor_(&r__1);
-
-} // MAIN__ //
-
--------- (end output file from f2c)
-
-*/
-}
-
-#endif
-/* For power (exponentiation) where right-hand operand is type INTEGER,
- generate in-line code to do it the fast way (which, if the operand
- is a constant, might just mean a series of multiplies). */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_expr_power_integer_ (ffebld left, ffebld right)
-{
- tree l = ffecom_expr (left);
- tree r = ffecom_expr (right);
- tree ltype = TREE_TYPE (l);
- tree rtype = TREE_TYPE (r);
- tree result = NULL_TREE;
-
- if (l == error_mark_node
- || r == error_mark_node)
- return error_mark_node;
-
- if (TREE_CODE (r) == INTEGER_CST)
- {
- int sgn = tree_int_cst_sgn (r);
-
- if (sgn == 0)
- return convert (ltype, integer_one_node);
-
- if ((TREE_CODE (ltype) == INTEGER_TYPE)
- && (sgn < 0))
- {
- /* Reciprocal of integer is either 0, -1, or 1, so after
- calculating that (which we leave to the back end to do
- or not do optimally), don't bother with any multiplying. */
-
- result = ffecom_tree_divide_ (ltype,
- convert (ltype, integer_one_node),
- l,
- NULL_TREE, NULL, NULL);
- r = ffecom_1 (NEGATE_EXPR,
- rtype,
- r);
- if ((TREE_INT_CST_LOW (r) & 1) == 0)
- result = ffecom_1 (ABS_EXPR, rtype,
- result);
- }
-
- /* Generate appropriate series of multiplies, preceded
- by divide if the exponent is negative. */
-
- l = save_expr (l);
-
- if (sgn < 0)
- {
- l = ffecom_tree_divide_ (ltype,
- convert (ltype, integer_one_node),
- l,
- NULL_TREE, NULL, NULL);
- r = ffecom_1 (NEGATE_EXPR, rtype, r);
- assert (TREE_CODE (r) == INTEGER_CST);
-
- if (tree_int_cst_sgn (r) < 0)
- { /* The "most negative" number. */
- r = ffecom_1 (NEGATE_EXPR, rtype,
- ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node));
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- }
-
- for (;;)
- {
- if (TREE_INT_CST_LOW (r) & 1)
- {
- if (result == NULL_TREE)
- result = l;
- else
- result = ffecom_2 (MULT_EXPR, ltype,
- result,
- l);
- }
-
- r = ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node);
- if (integer_zerop (r))
- break;
- assert (TREE_CODE (r) == INTEGER_CST);
-
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- return result;
- }
-
- /* Though rhs isn't a constant, in-line code cannot be expanded
- while transforming dummies
- because the back end cannot be easily convinced to generate
- stores (MODIFY_EXPR), handle temporaries, and so on before
- all the appropriate rtx's have been generated for things like
- dummy args referenced in rhs -- which doesn't happen until
- store_parm_decls() is called (expand_function_start, I believe,
- does the actual rtx-stuffing of PARM_DECLs).
-
- So, in this case, let the caller generate the call to the
- run-time-library function to evaluate the power for us. */
-
- if (ffecom_transform_only_dummies_)
- return NULL_TREE;
-
- /* Right-hand operand not a constant, expand in-line code to figure
- out how to do the multiplies, &c.
-
- The returned expression is expressed this way in GNU C, where l and
- r are the "inputs":
-
- ({ typeof (r) rtmp = r;
- typeof (l) ltmp = l;
- typeof (l) result;
-
- if (rtmp == 0)
- result = 1;
- else
- {
- if ((basetypeof (l) == basetypeof (int))
- && (rtmp < 0))
- {
- result = ((typeof (l)) 1) / ltmp;
- if ((ltmp < 0) && (((-rtmp) & 1) == 0))
- result = -result;
- }
- else
- {
- result = 1;
- if ((basetypeof (l) != basetypeof (int))
- && (rtmp < 0))
- {
- ltmp = ((typeof (l)) 1) / ltmp;
- rtmp = -rtmp;
- if (rtmp < 0)
- {
- rtmp = -(rtmp >> 1);
- ltmp *= ltmp;
- }
- }
- for (;;)
- {
- if (rtmp & 1)
- result *= ltmp;
- if ((rtmp >>= 1) == 0)
- break;
- ltmp *= ltmp;
- }
- }
- }
- result;
- })
-
- Note that some of the above is compile-time collapsable, such as
- the first part of the if statements that checks the base type of
- l against int. The if statements are phrased that way to suggest
- an easy way to generate the if/else constructs here, knowing that
- the back end should (and probably does) eliminate the resulting
- dead code (either the int case or the non-int case), something
- it couldn't do without the redundant phrasing, requiring explicit
- dead-code elimination here, which would be kind of difficult to
- read. */
-
- {
- tree rtmp;
- tree ltmp;
- tree basetypeof_l_is_int;
- tree se;
-
- basetypeof_l_is_int
- = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
-
- se = expand_start_stmt_expr ();
- ffecom_push_calltemps ();
-
- rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1,
- TRUE);
- ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
- TRUE);
- result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
- TRUE);
-
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- r));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- l));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (EQ_EXPR, integer_type_node,
- rtmp,
- convert (rtype, integer_zero_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- convert (ltype, integer_one_node)));
- expand_start_else ();
- if (!integer_zerop (basetypeof_l_is_int))
- {
- expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype,
- integer_zero_node)),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_tree_divide_
- (ltype,
- convert (ltype, integer_one_node),
- ltmp,
- NULL_TREE, NULL, NULL)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_2 (LT_EXPR, integer_type_node,
- ltmp,
- convert (ltype,
- integer_zero_node)),
- ffecom_2 (EQ_EXPR, integer_type_node,
- ffecom_2 (BIT_AND_EXPR,
- rtype,
- ffecom_1 (NEGATE_EXPR,
- rtype,
- rtmp),
- convert (rtype,
- integer_one_node)),
- convert (rtype,
- integer_zero_node)))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_1 (NEGATE_EXPR,
- ltype,
- result)));
- expand_end_cond ();
- expand_start_else ();
- }
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- convert (ltype, integer_one_node)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
- ffecom_truth_value_invert
- (basetypeof_l_is_int),
- ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype,
- integer_zero_node)))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_tree_divide_
- (ltype,
- convert (ltype, integer_one_node),
- ltmp,
- NULL_TREE, NULL, NULL)));
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- ffecom_1 (NEGATE_EXPR, rtype,
- rtmp)));
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (LT_EXPR, integer_type_node,
- rtmp,
- convert (rtype, integer_zero_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- rtmp,
- ffecom_1 (NEGATE_EXPR, rtype,
- ffecom_2 (RSHIFT_EXPR,
- rtype,
- rtmp,
- integer_one_node))));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_2 (MULT_EXPR, ltype,
- ltmp,
- ltmp)));
- expand_end_cond ();
- expand_end_cond ();
- expand_start_loop (1);
- expand_start_cond (ffecom_truth_value
- (ffecom_2 (BIT_AND_EXPR, rtype,
- rtmp,
- convert (rtype, integer_one_node))),
- 0);
- expand_expr_stmt (ffecom_modify (void_type_node,
- result,
- ffecom_2 (MULT_EXPR, ltype,
- result,
- ltmp)));
- expand_end_cond ();
- expand_exit_loop_if_false (NULL,
- ffecom_truth_value
- (ffecom_modify (rtype,
- rtmp,
- ffecom_2 (RSHIFT_EXPR,
- rtype,
- rtmp,
- integer_one_node))));
- expand_expr_stmt (ffecom_modify (void_type_node,
- ltmp,
- ffecom_2 (MULT_EXPR, ltype,
- ltmp,
- ltmp)));
- expand_end_loop ();
- expand_end_cond ();
- if (!integer_zerop (basetypeof_l_is_int))
- expand_end_cond ();
- expand_expr_stmt (result);
-
- ffecom_pop_calltemps ();
- result = expand_end_stmt_expr (se);
- TREE_SIDE_EFFECTS (result) = 1;
- }
-
- return result;
-}
-
-#endif
-/* ffecom_expr_transform_ -- Transform symbols in expr
-
- ffebld expr; // FFE expression.
- ffecom_expr_transform_ (expr);
-
- Recursive descent on expr while transforming any untransformed SYMTERs. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_expr_transform_ (ffebld expr)
-{
- tree t;
- ffesymbol s;
-
-tail_recurse: /* :::::::::::::::::::: */
-
- if (expr == NULL)
- return;
-
- switch (ffebld_op (expr))
- {
- case FFEBLD_opSYMTER:
- s = ffebld_symter (expr);
- t = ffesymbol_hook (s).decl_tree;
- if ((t == NULL_TREE)
- && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
- DIMENSION expr? */
- }
- break; /* Ok if (t == NULL) here. */
-
- case FFEBLD_opITEM:
- ffecom_expr_transform_ (ffebld_head (expr));
- expr = ffebld_trail (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- switch (ffebld_arity (expr))
- {
- case 2:
- ffecom_expr_transform_ (ffebld_left (expr));
- expr = ffebld_right (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- case 1:
- expr = ffebld_left (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
-
- default:
- break;
- }
-
- return;
-}
-
-#endif
-/* Make a type based on info in live f2c.h file. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_f2c_make_type_ (tree *type, int tcode, char *name)
-{
- switch (tcode)
- {
- case FFECOM_f2ccodeCHAR:
- *type = make_signed_type (CHAR_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeSHORT:
- *type = make_signed_type (SHORT_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeINT:
- *type = make_signed_type (INT_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeLONG:
- *type = make_signed_type (LONG_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeLONGLONG:
- *type = make_signed_type (LONG_LONG_TYPE_SIZE);
- break;
-
- case FFECOM_f2ccodeCHARPTR:
- *type = build_pointer_type (DEFAULT_SIGNED_CHAR
- ? signed_char_type_node
- : unsigned_char_type_node);
- break;
-
- case FFECOM_f2ccodeFLOAT:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
- layout_type (*type);
- break;
-
- case FFECOM_f2ccodeDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
-
- case FFECOM_f2ccodeLONGDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
-
- case FFECOM_f2ccodeTWOREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
- break;
-
- case FFECOM_f2ccodeTWODOUBLEREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
- break;
-
- default:
- assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
- *type = error_mark_node;
- return;
- }
-
- pushdecl (build_decl (TYPE_DECL,
- ffecom_get_invented_identifier ("__g77_f2c_%s",
- name, 0),
- *type));
-}
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-/* Set the f2c list-directed-I/O code for whatever (integral) type has the
- given size. */
-
-static void
-ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
- int code)
-{
- int j;
- tree t;
-
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
- && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
- {
- assert (code != -1);
- ffecom_f2c_typecode_[bt][j] = code;
- code = -1;
- }
-}
-
-#endif
-/* Finish up globals after doing all program units in file
-
- Need to handle only uninitialized COMMON areas. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffeglobal
-ffecom_finish_global_ (ffeglobal global)
-{
- tree cbtype;
- tree cbt;
- tree size;
-
- if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
- return global;
-
- if (ffeglobal_common_init (global))
- return global;
-
- cbt = ffeglobal_hook (global);
- if ((cbt == NULL_TREE)
- || !ffeglobal_common_have_size (global))
- return global; /* No need to make common, never ref'd. */
-
- suspend_momentary ();
-
- DECL_EXTERNAL (cbt) = 0;
-
- /* Give the array a size now. */
-
- size = build_int_2 (ffeglobal_common_size (global), 0);
-
- cbtype = TREE_TYPE (cbt);
- TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
- integer_one_node,
- size);
- if (!TREE_TYPE (size))
- TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
- layout_type (cbtype);
-
- cbt = start_decl (cbt, FALSE);
- assert (cbt == ffeglobal_hook (global));
-
- finish_decl (cbt, NULL_TREE, FALSE);
-
- return global;
-}
-
-#endif
-/* Finish up any untransformed symbols. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffesymbol
-ffecom_finish_symbol_transform_ (ffesymbol s)
-{
- if (s == NULL)
- return s;
-
- /* It's easy to know to transform an untransformed symbol, to make sure
- we put out debugging info for it. But COMMON variables, unlike
- EQUIVALENCE ones, aren't given declarations in addition to the
- tree expressions that specify offsets, because COMMON variables
- can be referenced in the outer scope where only dummy arguments
- (PARM_DECLs) should really be seen. To be safe, just don't do any
- VAR_DECLs for COMMON variables when we transform them for real
- use, and therefore we do all the VAR_DECL creating here. */
-
- if ((ffesymbol_hook (s).decl_tree == NULL_TREE)
- && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
- || ((ffesymbol_where (s) != FFEINFO_whereNONE)
- && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))
- && (ffesymbol_where (s) != FFEINFO_whereDUMMY))
- /* Not transformed, and not CHARACTER*(*), and not a dummy
- argument, which can happen only if the entry point names
- it "rides in on" are all invalidated for other reasons. */
- s = ffecom_sym_transform_ (s);
-
- if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
- && (ffesymbol_hook (s).decl_tree != error_mark_node))
- {
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
- int yes = suspend_momentary ();
-
- /* This isn't working, at least for dbxout. The .s file looks
- okay to me (burley), but in gdb 4.9 at least, the variables
- appear to reside somewhere outside of the common area, so
- it doesn't make sense to mislead anyone by generating the info
- on those variables until this is fixed. NOTE: Same problem
- with EQUIVALENCE, sadly...see similar #if later. */
- ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
- ffesymbol_storage (s));
-
- resume_momentary (yes);
-#endif
- }
+ if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
+ && (ffesymbol_hook (s).decl_tree != error_mark_node))
+ {
+ /* This isn't working, at least for dbxout. The .s file looks
+ okay to me (burley), but in gdb 4.9 at least, the variables
+ appear to reside somewhere outside of the common area, so
+ it doesn't make sense to mislead anyone by generating the info
+ on those variables until this is fixed. NOTE: Same problem
+ with EQUIVALENCE, sadly...see similar #if later. */
+ ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
+ ffesymbol_storage (s));
+ }
return s;
}
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_get_appended_identifier_ (char us, char *name)
+ffecom_get_appended_identifier_ (char us, const char *name)
{
int i;
char *newname;
ffecom_get_external_identifier_ (ffesymbol s)
{
char us;
- char *name = ffesymbol_text (s);
+ const char *name = ffesymbol_text (s);
/* If name is a built-in name, just return it as is. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_get_identifier_ (char *name)
+ffecom_get_identifier_ (const char *name)
{
/* If name does not contain an underscore, just return it as is. */
tree result;
bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
static bool recurse = FALSE;
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
ffecom_nested_entry_ = s;
assert (!recurse);
recurse = TRUE;
- yes = suspend_momentary ();
-
push_f_function_context ();
- ffecom_push_calltemps ();
-
if (charfunc)
type = void_type_node;
else
entirely internal to our code, and gcc has the ability to return COMPLEX
directly as a value. */
- yes = suspend_momentary ();
-
if (charfunc)
{ /* Prepend arg for where result goes. */
tree type;
type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
- resume_momentary (yes);
-
store_parm_decls (0);
- ffecom_start_compstmt_ ();
+ ffecom_start_compstmt ();
if (expr != NULL)
{
result_length = build_int_2 (sz, 0);
TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
+ ffecom_prepare_let_char_ (sz, expr);
+
+ ffecom_prepare_end ();
+
ffecom_let_char_ (result, result_length, sz, expr);
expand_null_return ();
}
else
- expand_return (ffecom_modify (NULL_TREE,
- DECL_RESULT (current_function_decl),
- ffecom_expr (expr)));
+ {
+ ffecom_prepare_expr (expr);
- clear_momentary ();
+ ffecom_prepare_end ();
+
+ expand_return (ffecom_modify (NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ ffecom_expr (expr)));
+ }
}
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
func = current_function_decl;
finish_function (1);
- ffecom_pop_calltemps ();
-
pop_f_function_context ();
- resume_momentary (yes);
-
recurse = FALSE;
lineno = old_lineno;
#endif
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static char *
+static const char *
ffecom_gfrt_args_ (ffecomGfrt ix)
{
return ffecom_gfrt_argstring_[ix];
/* Return initialize-to-zero expression for this VAR_DECL. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
+/* A somewhat evil way to prevent the garbage collector
+ from collecting 'tree' structures. */
+#define NUM_TRACKED_CHUNK 63
+static struct tree_ggc_tracker
+{
+ struct tree_ggc_tracker *next;
+ tree trees[NUM_TRACKED_CHUNK];
+} *tracker_head = NULL;
+
+static void
+mark_tracker_head (void *arg)
+{
+ struct tree_ggc_tracker *head;
+ int i;
+
+ for (head = * (struct tree_ggc_tracker **) arg;
+ head != NULL;
+ head = head->next)
+ {
+ ggc_mark (head);
+ for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+ ggc_mark_tree (head->trees[i]);
+ }
+}
+
+void
+ffecom_save_tree_forever (tree t)
+{
+ int i;
+ if (tracker_head != NULL)
+ for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+ if (tracker_head->trees[i] == NULL)
+ {
+ tracker_head->trees[i] = t;
+ return;
+ }
+
+ {
+ /* Need to allocate a new block. */
+ struct tree_ggc_tracker *old_head = tracker_head;
+
+ tracker_head = ggc_alloc (sizeof (*tracker_head));
+ tracker_head->next = old_head;
+ tracker_head->trees[0] = t;
+ for (i = 1; i < NUM_TRACKED_CHUNK; i++)
+ tracker_head->trees[i] = NULL;
+ }
+}
+
static tree
ffecom_init_zero_ (tree decl)
{
if (incremental)
{
- int momentary = suspend_momentary ();
- push_obstacks_nochange ();
- if (TREE_PERMANENT (decl))
- end_temporary_allocation ();
- make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
+ make_decl_rtl (decl, NULL);
assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
- pop_obstacks ();
- resume_momentary (momentary);
}
- push_momentary ();
-
if ((TREE_CODE (type) != ARRAY_TYPE)
&& (TREE_CODE (type) != RECORD_TYPE)
&& (TREE_CODE (type) != UNION_TYPE)
init = convert (type, integer_zero_node);
else if (!incremental)
{
- int momentary = suspend_momentary ();
-
init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
-
- resume_momentary (momentary);
}
else
{
- int momentary = suspend_momentary ();
-
assemble_zeros (int_size_in_bytes (type));
init = error_mark_node;
-
- resume_momentary (momentary);
}
- pop_momentary_nofree ();
-
return init;
}
case FFEBLD_opARRAYREF:
case FFEBLD_opFUNCREF:
case FFEBLD_opSUBSTR:
- ffecom_push_calltemps ();
ffecom_char_args_ (&expr_tree, &length_tree, arg);
- ffecom_pop_calltemps ();
if ((expr_tree == error_mark_node)
|| (length_tree == error_mark_node))
}
#endif
-/* ffecom_let_char_ -- Do assignment stuff for character type
-
- tree dest_tree; // destination (ADDR_EXPR)
- tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL))
- ffetargetCharacterSize dest_size; // length
- ffebld source; // source expression
- ffecom_let_char_(dest_tree,dest_length,dest_size,source);
+/* Handle CHARACTER assignments.
Generates code to do the assignment. Used by ordinary assignment
statement handler ffecom_let_stmt and by statement-function
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
= build_tree_list (NULL_TREE, source_length);
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
TREE_SIDE_EFFECTS (expr_tree) = 1;
expand_expr_stmt (expr_tree);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
= build_tree_list (NULL_TREE, source_length);
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
TREE_SIDE_EFFECTS (expr_tree) = 1;
expand_expr_stmt (expr_tree);
tree citem;
tree clength;
+#ifdef HOHO
length_array
= lengths
= ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
FFETARGET_charactersizeNONE,
count, TRUE);
+#else
+ {
+ tree hook;
+
+ hook = ffebld_nonter_hook (source);
+ assert (hook);
+ assert (TREE_CODE (hook) == TREE_VEC);
+ assert (TREE_VEC_LENGTH (hook) == 2);
+ length_array = lengths = TREE_VEC_ELT (hook, 0);
+ item_array = items = TREE_VEC_ELT (hook, 1);
+ }
+#endif
for (i = 0; i < count; ++i)
{
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
= build_tree_list (NULL_TREE, dest_length);
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree);
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
TREE_SIDE_EFFECTS (expr_tree) = 1;
expand_expr_stmt (expr_tree);
tree t;
tree ttype;
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
switch (ffecom_gfrt_type_[ix])
{
case FFECOM_rttypeVOID_:
ttype = void_type_node;
break;
+ case FFECOM_rttypeVOIDSTAR_:
+ ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
+ break;
+
case FFECOM_rttypeFTNINT_:
ttype = ffecom_f2c_ftnint_type_node;
break;
get_identifier (ffecom_gfrt_name_[ix]),
ttype);
DECL_EXTERNAL (t) = 1;
+ TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
TREE_PUBLIC (t) = 1;
TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
+ /* Sanity check: A function that's const cannot be volatile. */
+
+ assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
+
+ /* Sanity check: A function that's const cannot return complex. */
+
+ assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
+
t = start_decl (t, TRUE);
finish_decl (t, NULL_TREE, TRUE);
- resume_temporary_allocation ();
- pop_obstacks ();
-
ffecom_gfrt_[ix] = t;
}
referencing the member. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
static void
ffecom_member_phase2_ (ffestorag mst, ffestorag st)
{
TREE_STATIC (t) = TREE_STATIC (mt);
DECL_INITIAL (t) = NULL_TREE;
TREE_ASM_WRITTEN (t) = 1;
+ TREE_USED (t) = 1;
DECL_RTL (t)
= gen_rtx (MEM, TYPE_MODE (type),
}
#endif
-#endif
+/* Prepare source expression for assignment into a destination perhaps known
+ to be of a specific size. */
+
+static void
+ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
+{
+ ffecomConcatList_ catlist;
+ int count;
+ int i;
+ tree ltmp;
+ tree itmp;
+ tree tempvar = NULL_TREE;
+
+ while (ffebld_op (source) == FFEBLD_opCONVERT)
+ source = ffebld_left (source);
+
+ catlist = ffecom_concat_list_new_ (source, dest_size);
+ count = ffecom_concat_list_count_ (catlist);
+
+ if (count >= 2)
+ {
+ ltmp
+ = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
+ FFETARGET_charactersizeNONE, count);
+ itmp
+ = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
+ FFETARGET_charactersizeNONE, count);
+
+ tempvar = make_tree_vec (2);
+ TREE_VEC_ELT (tempvar, 0) = ltmp;
+ TREE_VEC_ELT (tempvar, 1) = itmp;
+ }
+
+ for (i = 0; i < count; ++i)
+ ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
+
+ ffecom_concat_list_kill_ (catlist);
+
+ if (tempvar)
+ {
+ ffebld_nonter_set_hook (source, tempvar);
+ current_binding_level->prep_state = 1;
+ }
+}
+
/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
Ignores STAR (alternate-return) dummies. All other get exec-transitioned
&& (ffecom_master_bt_ == FFEINFO_basictypeNONE);
bool main_program = FALSE;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
- int yes;
+ const char *old_input_filename = input_filename;
assert (fn != NULL);
assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
input_filename = ffesymbol_where_filename (fn);
lineno = ffesymbol_where_filelinenum (fn);
- /* c-parse.y indeed does call suspend_momentary and not only ignores the
- return value, but also never calls resume_momentary, when starting an
- outer function (see "fndef:", "setspecs:", and so on). So g77 does the
- same thing. It shouldn't be a problem since start_function calls
- temporary_allocation, but it might be necessary. If it causes a problem
- here, then maybe there's a bug lurking in gcc. NOTE: This identical
- comment appears twice in thist file. */
-
- suspend_momentary ();
-
switch (ffecom_primary_entry_kind_)
{
case FFEINFO_kindPROGRAM:
}
if (altentries)
- id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
- ffesymbol_text (fn),
- 0);
+ {
+ id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
+ ffesymbol_text (fn));
+ }
#if FFETARGET_isENFORCED_MAIN
else if (main_program)
id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
0, /* nested/inline */
!altentries); /* TREE_PUBLIC */
+ TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
+
if (!altentries
&& ((g = ffesymbol_global (fn)) != NULL)
&& ((ffeglobal_type (g) == gt)
ffeglobal_set_hook (g, current_function_decl);
}
- yes = suspend_momentary ();
-
/* Arg handling needs exec-transitioned ffesymbols to work with. But
exec-transitioning needs current_function_decl to be filled in. So we
do these things in two phases. */
ffecom_which_entrypoint_decl_
= build_decl (PARM_DECL,
ffecom_get_invented_identifier ("__g77_%s",
- "which_entrypoint",
- 0),
+ "which_entrypoint"),
integer_type_node);
push_parm_decl (ffecom_which_entrypoint_decl_);
}
else
type = ffecom_multi_type_node_;
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
/* Make length arg _and_ enhance type info for CHAR arg itself. */
ffecom_push_dummy_decls_ (arglist, FALSE);
}
- resume_momentary (yes);
+ if (TREE_CODE (current_function_decl) != ERROR_MARK)
+ store_parm_decls (main_program ? 1 : 0);
- store_parm_decls (main_program ? 1 : 0);
-
- ffecom_start_compstmt_ ();
+ ffecom_start_compstmt ();
+ /* Disallow temp vars at this level. */
+ current_binding_level->prep_state = 2;
lineno = old_lineno;
input_filename = old_input_filename;
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffeglobal g;
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
+
+ /* Must ensure special ASSIGN variables are declared at top of outermost
+ block, else they'll end up in the innermost block when their first
+ ASSIGN is seen, which leaves them out of scope when they're the
+ subject of a GOTO or I/O statement.
+
+ We make this variable even if -fugly-assign. Just let it go unused,
+ in case it turns out there are cases where we really want to use this
+ variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
+
+ if (! ffecom_transform_only_dummies_
+ && ffesymbol_assigned (s)
+ && ! ffesymbol_hook (s).assign_tree)
+ s = ffecom_sym_transform_assign_ (s);
if (ffesymbol_sfdummyparent (s) == NULL)
{
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type); /* Assume subr. */
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
switch (ffeinfo_where (ffesymbol_info (s)))
{
- case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */
+ case FFEINFO_whereCONSTANT:
+ /* ~~Debugging info needed? */
assert (!ffecom_transform_only_dummies_);
t = error_mark_node; /* Shouldn't ever see this in expr. */
break;
break;
}
- yes = suspend_momentary ();
type = ffecom_type_localvar_ (s, bt, kt);
- resume_momentary (yes);
if (type == error_mark_node)
{
{ /* Child of EQUIVALENCE parent. */
ffestorag est;
tree et;
- int yes;
ffetargetOffset offset;
est = ffestorag_parent (st);
if (! TREE_STATIC (et))
put_var_into_stack (et);
- yes = suspend_momentary ();
-
offset = ffestorag_modulo (est)
+ ffestorag_offset (ffesymbol_storage (s))
- ffestorag_offset (est);
build_int_2 (offset, 0));
t = convert (build_pointer_type (type),
t);
+ TREE_CONSTANT (t) = staticp (et);
addr = TRUE;
-
- resume_momentary (yes);
}
else
{
tree initexpr;
bool init = ffesymbol_is_init (s);
- yes = suspend_momentary ();
-
t = build_decl (VAR_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
type);
finish_decl (t, initexpr, FALSE);
- if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
+ if (st != NULL && DECL_SIZE (t) != error_mark_node)
{
- tree size_tree;
-
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (t),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
+ assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
+ ffestorag_size (st)));
}
-
- resume_momentary (yes);
}
}
break;
if ((ffecom_num_entrypoints_ != 0)
&& (ffecom_master_bt_ == FFEINFO_basictypeNONE))
{
- yes = suspend_momentary ();
-
assert (ffecom_multi_retval_ != NULL_TREE);
t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
ffecom_multi_retval_);
t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
t, ffecom_multi_fields_[bt][kt]);
- resume_momentary (yes);
break;
}
- yes = suspend_momentary ();
-
t = build_decl (VAR_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
ffecom_tree_type[bt][kt]);
ffecom_func_result_ = t;
- resume_momentary (yes);
break;
case FFEINFO_whereDUMMY:
ffecom_integer_zero_node);
#endif
- /* ~~~gcc/stor-layout.c/layout_type should do this,
+ /* ~~~gcc/stor-layout.c (layout_type) should do this,
probably. Fixes 950302-1.f. */
if (TREE_CODE (low) != INTEGER_CST)
low = variable_size (low);
- /* ~~~similarly, this fixes dumb0.f. The C front end
+ /* ~~~Similarly, this fixes dumb0.f. The C front end
does this, which is why dumb0.c would work. */
if (high && TREE_CODE (high) != INTEGER_CST)
tree ct;
ffestorag st = ffesymbol_storage (s);
tree type;
- int yes;
cs = ffesymbol_common (s); /* The COMMON area itself. */
if (st != NULL) /* Else not laid out. */
st = ffesymbol_storage (s);
}
- yes = suspend_momentary ();
-
type = ffecom_type_localvar_ (s, bt, kt);
cg = ffesymbol_global (cs); /* The global COMMON info. */
build_int_2 (offset, 0));
t = convert (build_pointer_type (type),
t);
+ TREE_CONSTANT (t) = 1;
addr = TRUE;
}
-
- resume_momentary (yes);
}
break;
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
if (ffesymbol_is_f2c (s)
&& (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
t = ffecom_tree_fun_type[bt][kt];
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type);
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
case FFEINFO_whereGLOBAL:
assert (!ffecom_transform_only_dummies_);
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_blockdata_type);
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
ffecom_sym_transform_assign_ (ffesymbol s)
{
tree t; /* Transformed thingy. */
- int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
if (ffesymbol_sfdummyparent (s) == NULL)
{
assert (!ffecom_transform_only_dummies_);
- yes = suspend_momentary ();
-
t = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
- ffesymbol_text (s),
- 0),
+ ffesymbol_text (s)),
TREE_TYPE (null_pointer_node));
switch (ffesymbol_where (s))
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- resume_momentary (yes);
-
ffesymbol_hook (s).assign_tree = t;
lineno = old_lineno;
tree cbt;
tree cbtype;
tree init;
+ tree high;
bool is_init = ffestorag_is_init (st);
assert (st != NULL);
if ((cbt != NULL_TREE)
&& (!is_init
|| !DECL_EXTERNAL (cbt)))
- return;
+ {
+ if (st->hook == NULL) ffestorag_set_hook (st, cbt);
+ return;
+ }
/* Process inits. */
{
if (ffestorag_init (st) != NULL)
{
- init = ffecom_expr (ffestorag_init (st));
+ ffebld sexp;
+
+ /* Set the padding for the expression, so ffecom_expr
+ knows to insert that many zeros. */
+ switch (ffebld_op (sexp = ffestorag_init (st)))
+ {
+ case FFEBLD_opCONTER:
+ ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
+ break;
+
+ case FFEBLD_opARRTER:
+ ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
+ break;
+
+ case FFEBLD_opACCTER:
+ ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
+ break;
+
+ default:
+ assert ("bad op for cmn init (pad)" == NULL);
+ break;
+ }
+
+ init = ffecom_expr (sexp);
if (init == error_mark_node)
{ /* Hopefully the back end complained! */
init = NULL_TREE;
else
init = NULL_TREE;
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
/* cbtype must be permanently allocated! */
+ /* Allocate the MAX of the areas so far, seen filewide. */
+ high = build_int_2 ((ffeglobal_common_size (g)
+ + ffeglobal_common_pad (g)) - 1, 0);
+ TREE_TYPE (high) = ffecom_integer_type_node;
+
if (init)
cbtype = build_array_type (char_type_node,
build_range_type (integer_type_node,
- integer_one_node,
- build_int_2
- (ffeglobal_common_size (g),
- 0)));
+ integer_zero_node,
+ high));
else
cbtype = build_array_type (char_type_node, NULL_TREE);
this seems easy enough. */
DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
+ DECL_USER_ALIGN (cbt) = 0;
if (is_init && (ffestorag_init (st) == NULL))
init = ffecom_init_zero_ (cbt);
if (init)
{
- tree size_tree;
-
- assert (DECL_SIZE (cbt) != NULL_TREE);
- assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (cbt),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree) == ffeglobal_common_size (g));
+ assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
+ assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
+ (ffeglobal_common_size (g)
+ + ffeglobal_common_pad (g))));
}
ffeglobal_set_hook (g, cbt);
ffestorag_set_hook (st, cbt);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (cbt);
}
#endif
tree init;
tree high;
bool is_init = ffestorag_is_init (eqst);
- int yes;
assert (eqst != NULL);
{
if (ffestorag_init (eqst) != NULL)
{
- init = ffecom_expr (ffestorag_init (eqst));
+ ffebld sexp;
+
+ /* Set the padding for the expression, so ffecom_expr
+ knows to insert that many zeros. */
+ switch (ffebld_op (sexp = ffestorag_init (eqst)))
+ {
+ case FFEBLD_opCONTER:
+ ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
+ break;
+
+ case FFEBLD_opARRTER:
+ ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
+ break;
+
+ case FFEBLD_opACCTER:
+ ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
+ break;
+
+ default:
+ assert ("bad op for eqv init (pad)" == NULL);
+ break;
+ }
+
+ init = ffecom_expr (sexp);
if (init == error_mark_node)
init = NULL_TREE; /* Hopefully the back end complained! */
}
&ffecom_member_phase1_,
eqst);
- yes = suspend_momentary ();
-
- high = build_int_2 (ffestorag_size (eqst), 0);
+ high = build_int_2 ((ffestorag_size (eqst)
+ + ffestorag_modulo (eqst)) - 1, 0);
TREE_TYPE (high) = ffecom_integer_type_node;
eqtype = build_array_type (char_type_node,
build_range_type (ffecom_integer_type_node,
- ffecom_integer_one_node,
+ ffecom_integer_zero_node,
high));
eqt = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_equiv_%s",
ffesymbol_text
- (ffestorag_symbol
- (eqst)),
- 0),
+ (ffestorag_symbol (eqst))),
eqtype);
DECL_EXTERNAL (eqt) = 0;
if (is_init
else
TREE_STATIC (eqt) = 0;
TREE_PUBLIC (eqt) = 0;
+ TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
DECL_CONTEXT (eqt) = current_function_decl;
if (init)
DECL_INITIAL (eqt) = error_mark_node;
eqt = start_decl (eqt, FALSE);
- /* Make sure this shows up as a debug symbol, which is not normally
- the case for invented identifiers. */
-
- DECL_IGNORED_P (eqt) = 0;
-
/* Make sure that any type can live in EQUIVALENCE and be referenced
without getting a bus error. We could pick the most restrictive
alignment of all entities actually placed in the EQUIVALENCE, but
this seems easy enough. */
DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
+ DECL_USER_ALIGN (eqt) = 0;
if ((!is_init && ffe_is_init_local_zero ())
|| (is_init && (ffestorag_init (eqst) == NULL)))
ffestorag_set_init (eqst, ffebld_new_any ());
{
- tree size_tree;
-
- size_tree = size_binop (CEIL_DIV_EXPR,
- DECL_SIZE (eqt),
- size_int (BITS_PER_UNIT));
- assert (TREE_INT_CST_HIGH (size_tree) == 0);
- assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (eqst));
+ assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
+ (ffestorag_size (eqst)
+ + ffestorag_modulo (eqst))));
}
ffestorag_set_hook (eqst, eqt);
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
ffestorag_drive (ffestorag_list_equivs (eqst),
&ffecom_member_phase2_,
eqst);
-#endif
-
- resume_momentary (yes);
}
#endif
tree nvarsinit;
tree field;
tree high;
- int yes;
int i;
static int mynumber = 0;
- yes = suspend_momentary ();
-
nmlt = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_namelist_%d",
- NULL, mynumber++),
+ mynumber++),
nmltype);
TREE_STATIC (nmlt) = 1;
DECL_INITIAL (nmlt) = error_mark_node;
nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
- resume_momentary (yes);
-
return nmlt;
}
if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
{
/* An offset into COMMON. */
- *offset = size_binop (PLUS_EXPR,
- *offset,
- TREE_OPERAND (t, 1));
+ *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
+ *offset, TREE_OPERAND (t, 1)));
/* Convert offset (presumably in bytes) into canonical units
(presumably bits). */
*offset = size_binop (MULT_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
- *offset);
+ convert (bitsizetype, *offset),
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
break;
}
/* Not a COMMON reference, so an unrecognized pattern. */
case PARM_DECL:
*decl = t;
- *offset = bitsize_int (0L, 0L);
+ *offset = bitsize_zero_node;
break;
case ADDR_EXPR:
{
/* A reference to COMMON. */
*decl = TREE_OPERAND (t, 0);
- *offset = bitsize_int (0L, 0L);
+ *offset = bitsize_zero_node;
break;
}
/* Fall through. */
case VAR_DECL:
case PARM_DECL:
*decl = t;
- *offset = bitsize_int (0L, 0L);
+ *offset = bitsize_zero_node;
*size = TYPE_SIZE (TREE_TYPE (t));
return;
|| (*decl == error_mark_node))
return;
+ /* Calculate ((element - base) * NBBY) + init_offset. */
+ *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
+ element,
+ TYPE_MIN_VALUE (TYPE_DOMAIN
+ (TREE_TYPE (array)))));
+
*offset = size_binop (MULT_EXPR,
- TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
- size_binop (MINUS_EXPR,
- element,
- TYPE_MIN_VALUE
- (TYPE_DOMAIN
- (TREE_TYPE (array)))));
+ convert (bitsizetype, *offset),
+ TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
- *offset = size_binop (PLUS_EXPR,
- init_offset,
- *offset);
+ *offset = size_binop (PLUS_EXPR, init_offset, *offset);
*size = TYPE_SIZE (TREE_TYPE (t));
return;
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_tree_divide_ (tree tree_type, tree left, tree right,
- tree dest_tree, ffebld dest, bool *dest_used)
+ tree dest_tree, ffebld dest, bool *dest_used,
+ tree hook)
{
if ((left == error_mark_node)
|| (right == error_mark_node))
right);
case COMPLEX_TYPE:
+ if (! optimize_size)
+ return ffecom_2 (RDIV_EXPR, tree_type,
+ left,
+ right);
{
ffecomGfrt ix;
tree_type,
left,
dest_tree, dest, dest_used,
- NULL_TREE, TRUE);
+ NULL_TREE, TRUE, hook);
}
break;
tree_type,
left,
dest_tree, dest, dest_used,
- NULL_TREE, TRUE);
+ NULL_TREE, TRUE, hook);
}
break;
}
#endif
-/* ffecom_type_localvar_ -- Build type info for non-dummy variable
-
- tree type;
- ffesymbol s; // the variable's symbol
- ffeinfoBasictype bt; // it's basictype
- ffeinfoKindtype kt; // it's kindtype
-
- type = ffecom_type_localvar_(s,bt,kt);
-
- Handles static arrays, CHARACTER type, etc. */
+/* Build type info for non-dummy variable. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
vardesctype = ffecom_type_vardesc_ ();
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
- type = make_node (RECORD_TYPE);
-
- vardesctype = build_pointer_type (build_pointer_type (vardesctype));
-
- namefield = ffecom_decl_field (type, NULL_TREE, "name",
- string_type_node);
- varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
- nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
- integer_type_node);
-
- TYPE_FIELDS (type) = namefield;
- layout_type (type);
-
- resume_temporary_allocation ();
- pop_obstacks ();
- }
-
- return type;
-}
-
-#endif
-
-/* Make a copy of a type, assuming caller has switched to the permanent
- obstacks and that the type is for an aggregate (array) initializer. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
-static tree
-ffecom_type_permanent_copy_ (tree t)
-{
- tree domain;
- tree max;
-
- assert (TREE_TYPE (t) != NULL_TREE);
+ type = make_node (RECORD_TYPE);
- domain = TYPE_DOMAIN (t);
+ vardesctype = build_pointer_type (build_pointer_type (vardesctype));
- assert (TREE_CODE (t) == ARRAY_TYPE);
- assert (TREE_PERMANENT (TREE_TYPE (t)));
- assert (TREE_PERMANENT (TREE_TYPE (domain)));
- assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
+ namefield = ffecom_decl_field (type, NULL_TREE, "name",
+ string_type_node);
+ varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
+ nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
+ integer_type_node);
- max = TYPE_MAX_VALUE (domain);
- if (!TREE_PERMANENT (max))
- {
- assert (TREE_CODE (max) == INTEGER_CST);
+ TYPE_FIELDS (type) = namefield;
+ layout_type (type);
- max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
- TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
+ ggc_add_tree_root (&type, 1);
}
- return build_array_type (TREE_TYPE (t),
- build_range_type (TREE_TYPE (domain),
- TYPE_MIN_VALUE (domain),
- max));
+ return type;
}
+
#endif
/* Build Vardesc type. */
if (type == NULL_TREE)
{
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
type = make_node (RECORD_TYPE);
namefield = ffecom_decl_field (type, NULL_TREE, "name",
TYPE_FIELDS (type) = namefield;
layout_type (type);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ggc_add_tree_root (&type, 1);
}
return type;
tree typeinit;
tree field;
tree varinits;
- int yes;
static int mynumber = 0;
- yes = suspend_momentary ();
-
var = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_vardesc_%d",
- NULL, mynumber++),
+ mynumber++),
vardesctype);
TREE_STATIC (var) = 1;
DECL_INITIAL (var) = error_mark_node;
var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
- resume_momentary (yes);
-
ffesymbol_hook (s).vardesc_tree = var;
}
tree item = NULL_TREE;
tree var;
int i;
- int yes;
static int mynumber = 0;
for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
}
}
- yes = suspend_momentary ();
-
item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
build_range_type (integer_type_node,
integer_one_node,
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
- var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
- mynumber++);
+ var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
var = build_decl (VAR_DECL, var, item);
TREE_STATIC (var) = 1;
DECL_INITIAL (var) = error_mark_node;
var = start_decl (var, FALSE);
finish_decl (var, list, FALSE);
- resume_momentary (yes);
-
return var;
}
tree backlist;
tree item = NULL_TREE;
tree var;
- int yes;
tree numdim;
tree numelem;
tree baseoff = NULL_TREE;
numdim = build_tree_list (NULL_TREE, numdim);
TREE_CHAIN (numdim) = numelem;
- yes = suspend_momentary ();
-
item = build_array_type (ffecom_f2c_ftnlen_type_node,
build_range_type (integer_type_node,
integer_zero_node,
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
- var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
- mynumber++);
+ var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
var = build_decl (VAR_DECL, var, item);
TREE_STATIC (var) = 1;
DECL_INITIAL (var) = error_mark_node;
var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
- resume_momentary (yes);
-
return var;
}
}
mfn_num = ffecom_num_fns_;
ffecom_do_entry_ (ffecom_primary_entry_, 0);
}
- else
- ++ent_num;
+ else
+ ++ent_num;
+
+ --ffecom_num_entrypoints_;
+
+ ffecom_do_entry_ (entry, ent_num);
+}
+
+#endif
+
+/* Essentially does a "fold (build (code, type, node1, node2))" while
+ checking for certain housekeeping things. Always sets
+ TREE_SIDE_EFFECTS. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_2s (enum tree_code code, tree type, tree node1,
+ tree node2)
+{
+ tree item;
+
+ if ((node1 == error_mark_node)
+ || (node2 == error_mark_node)
+ || (type == error_mark_node))
+ return error_mark_node;
+
+ item = build (code, type, node1, node2);
+ TREE_SIDE_EFFECTS (item) = 1;
+ return fold (item);
+}
+
+#endif
+/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
+ checking for certain housekeeping things. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_3 (enum tree_code code, tree type, tree node1,
+ tree node2, tree node3)
+{
+ tree item;
+
+ if ((node1 == error_mark_node)
+ || (node2 == error_mark_node)
+ || (node3 == error_mark_node)
+ || (type == error_mark_node))
+ return error_mark_node;
+
+ item = build (code, type, node1, node2, node3);
+ if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
+ || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
+ TREE_SIDE_EFFECTS (item) = 1;
+ return fold (item);
+}
+
+#endif
+/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
+ checking for certain housekeeping things. Always sets
+ TREE_SIDE_EFFECTS. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_3s (enum tree_code code, tree type, tree node1,
+ tree node2, tree node3)
+{
+ tree item;
+
+ if ((node1 == error_mark_node)
+ || (node2 == error_mark_node)
+ || (node3 == error_mark_node)
+ || (type == error_mark_node))
+ return error_mark_node;
+
+ item = build (code, type, node1, node2, node3);
+ TREE_SIDE_EFFECTS (item) = 1;
+ return fold (item);
+}
+
+#endif
+
+/* ffecom_arg_expr -- Transform argument expr into gcc tree
+
+ See use by ffecom_list_expr.
+
+ If expression is NULL, returns an integer zero tree. If it is not
+ a CHARACTER expression, returns whatever ffecom_expr
+ returns and sets the length return value to NULL_TREE. Otherwise
+ generates code to evaluate the character expression, returns the proper
+ pointer to the result, but does NOT set the length return value to a tree
+ that specifies the length of the result. (In other words, the length
+ variable is always set to NULL_TREE, because a length is never passed.)
+
+ 21-Dec-91 JCB 1.1
+ Don't set returned length, since nobody needs it (yet; someday if
+ we allow CHARACTER*(*) dummies to statement functions, we'll need
+ it). */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_arg_expr (ffebld expr, tree *length)
+{
+ tree ign;
+
+ *length = NULL_TREE;
+
+ if (expr == NULL)
+ return integer_zero_node;
+
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_expr (expr);
+
+ return ffecom_arg_ptr_to_expr (expr, &ign);
+}
+
+#endif
+/* Transform expression into constant argument-pointer-to-expression tree.
+
+ If the expression can be transformed into a argument-pointer-to-expression
+ tree that is constant, that is done, and the tree returned. Else
+ NULL_TREE is returned.
+
+ That way, a caller can attempt to provide compile-time initialization
+ of a variable and, if that fails, *then* choose to start a new block
+ and resort to using temporaries, as appropriate. */
+
+tree
+ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
+{
+ if (! expr)
+ return integer_zero_node;
+
+ if (ffebld_op (expr) == FFEBLD_opANY)
+ {
+ if (length)
+ *length = error_mark_node;
+ return error_mark_node;
+ }
+
+ if (ffebld_arity (expr) == 0
+ && (ffebld_op (expr) != FFEBLD_opSYMTER
+ || ffebld_where (expr) == FFEINFO_whereCOMMON
+ || ffebld_where (expr) == FFEINFO_whereGLOBAL
+ || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
+ {
+ tree t;
+
+ t = ffecom_arg_ptr_to_expr (expr, length);
+ assert (TREE_CONSTANT (t));
+ assert (! length || TREE_CONSTANT (*length));
+ return t;
+ }
+
+ if (length
+ && ffebld_size (expr) != FFETARGET_charactersizeNONE)
+ *length = build_int_2 (ffebld_size (expr), 0);
+ else if (length)
+ *length = NULL_TREE;
+ return NULL_TREE;
+}
+
+/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
+
+ See use by ffecom_list_ptr_to_expr.
+
+ If expression is NULL, returns an integer zero tree. If it is not
+ a CHARACTER expression, returns whatever ffecom_ptr_to_expr
+ returns and sets the length return value to NULL_TREE. Otherwise
+ generates code to evaluate the character expression, returns the proper
+ pointer to the result, AND sets the length return value to a tree that
+ specifies the length of the result.
+
+ If the length argument is NULL, this is a slightly special
+ case of building a FORMAT expression, that is, an expression that
+ will be used at run time without regard to length. For the current
+ implementation, which uses the libf2c library, this means it is nice
+ to append a null byte to the end of the expression, where feasible,
+ to make sure any diagnostic about the FORMAT string terminates at
+ some useful point.
+
+ For now, treat %REF(char-expr) as the same as char-expr with a NULL
+ length argument. This might even be seen as a feature, if a null
+ byte can always be appended. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
+{
+ tree item;
+ tree ign_length;
+ ffecomConcatList_ catlist;
+
+ if (length != NULL)
+ *length = NULL_TREE;
+
+ if (expr == NULL)
+ return integer_zero_node;
+
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opPERCENT_VAL:
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_expr (ffebld_left (expr));
+ {
+ tree temp_exp;
+ tree temp_length;
+
+ temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
+ if (temp_exp == error_mark_node)
+ return error_mark_node;
+
+ return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
+ temp_exp);
+ }
+
+ case FFEBLD_opPERCENT_REF:
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_ptr_to_expr (ffebld_left (expr));
+ if (length != NULL)
+ {
+ ign_length = NULL_TREE;
+ length = &ign_length;
+ }
+ expr = ffebld_left (expr);
+ break;
+
+ case FFEBLD_opPERCENT_DESCR:
+ switch (ffeinfo_basictype (ffebld_info (expr)))
+ {
+#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
+ case FFEINFO_basictypeHOLLERITH:
+#endif
+ case FFEINFO_basictypeCHARACTER:
+ break; /* Passed by descriptor anyway. */
+
+ default:
+ item = ffecom_ptr_to_expr (expr);
+ if (item != error_mark_node)
+ *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
+ break;
+ }
+ break;
+
+ default:
+ break;
+ }
+
+#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
+ if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
+ && (length != NULL))
+ { /* Pass Hollerith by descriptor. */
+ ffetargetHollerith h;
+
+ assert (ffebld_op (expr) == FFEBLD_opCONTER);
+ h = ffebld_cu_val_hollerith (ffebld_constant_union
+ (ffebld_conter (expr)));
+ *length
+ = build_int_2 (h.length, 0);
+ TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
+ }
+#endif
+
+ if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
+ return ffecom_ptr_to_expr (expr);
+
+ assert (ffeinfo_kindtype (ffebld_info (expr))
+ == FFEINFO_kindtypeCHARACTER1);
+
+ while (ffebld_op (expr) == FFEBLD_opPAREN)
+ expr = ffebld_left (expr);
+
+ catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
+ switch (ffecom_concat_list_count_ (catlist))
+ {
+ case 0: /* Shouldn't happen, but in case it does... */
+ if (length != NULL)
+ {
+ *length = ffecom_f2c_ftnlen_zero_node;
+ TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
+ }
+ ffecom_concat_list_kill_ (catlist);
+ return null_pointer_node;
+
+ case 1: /* The (fairly) easy case. */
+ if (length == NULL)
+ ffecom_char_args_with_null_ (&item, &ign_length,
+ ffecom_concat_list_expr_ (catlist, 0));
+ else
+ ffecom_char_args_ (&item, length,
+ ffecom_concat_list_expr_ (catlist, 0));
+ ffecom_concat_list_kill_ (catlist);
+ assert (item != NULL_TREE);
+ return item;
+
+ default: /* Must actually concatenate things. */
+ break;
+ }
- --ffecom_num_entrypoints_;
+ {
+ int count = ffecom_concat_list_count_ (catlist);
+ int i;
+ tree lengths;
+ tree items;
+ tree length_array;
+ tree item_array;
+ tree citem;
+ tree clength;
+ tree temporary;
+ tree num;
+ tree known_length;
+ ffetargetCharacterSize sz;
- ffecom_do_entry_ (entry, ent_num);
-}
+ sz = ffecom_concat_list_maxlen_ (catlist);
+ /* ~~Kludge! */
+ assert (sz != FFETARGET_charactersizeNONE);
+#ifdef HOHO
+ length_array
+ = lengths
+ = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
+ FFETARGET_charactersizeNONE, count, TRUE);
+ item_array
+ = items
+ = ffecom_push_tempvar (ffecom_f2c_address_type_node,
+ FFETARGET_charactersizeNONE, count, TRUE);
+ temporary = ffecom_push_tempvar (char_type_node,
+ sz, -1, TRUE);
+#else
+ {
+ tree hook;
+
+ hook = ffebld_nonter_hook (expr);
+ assert (hook);
+ assert (TREE_CODE (hook) == TREE_VEC);
+ assert (TREE_VEC_LENGTH (hook) == 3);
+ length_array = lengths = TREE_VEC_ELT (hook, 0);
+ item_array = items = TREE_VEC_ELT (hook, 1);
+ temporary = TREE_VEC_ELT (hook, 2);
+ }
#endif
-/* Essentially does a "fold (build (code, type, node1, node2))" while
- checking for certain housekeeping things. Always sets
- TREE_SIDE_EFFECTS. */
+ known_length = ffecom_f2c_ftnlen_zero_node;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_2s (enum tree_code code, tree type, tree node1,
- tree node2)
-{
- tree item;
+ for (i = 0; i < count; ++i)
+ {
+ if ((i == count)
+ && (length == NULL))
+ ffecom_char_args_with_null_ (&citem, &clength,
+ ffecom_concat_list_expr_ (catlist, i));
+ else
+ ffecom_char_args_ (&citem, &clength,
+ ffecom_concat_list_expr_ (catlist, i));
+ if ((citem == error_mark_node)
+ || (clength == error_mark_node))
+ {
+ ffecom_concat_list_kill_ (catlist);
+ *length = error_mark_node;
+ return error_mark_node;
+ }
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
+ items
+ = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
+ ffecom_modify (void_type_node,
+ ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
+ item_array,
+ build_int_2 (i, 0)),
+ citem),
+ items);
+ clength = ffecom_save_tree (clength);
+ if (length != NULL)
+ known_length
+ = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
+ known_length,
+ clength);
+ lengths
+ = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
+ ffecom_modify (void_type_node,
+ ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
+ length_array,
+ build_int_2 (i, 0)),
+ clength),
+ lengths);
+ }
- item = build (code, type, node1, node2);
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
-}
+ temporary = ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (temporary)),
+ temporary);
-#endif
-/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
- checking for certain housekeeping things. */
+ item = build_tree_list (NULL_TREE, temporary);
+ TREE_CHAIN (item)
+ = build_tree_list (NULL_TREE,
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (items)),
+ items));
+ TREE_CHAIN (TREE_CHAIN (item))
+ = build_tree_list (NULL_TREE,
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (lengths)),
+ lengths));
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
+ = build_tree_list
+ (NULL_TREE,
+ ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
+ convert (ffecom_f2c_ftnlen_type_node,
+ build_int_2 (count, 0))));
+ num = build_int_2 (sz, 0);
+ TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
+ = build_tree_list (NULL_TREE, num);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_3 (enum tree_code code, tree type, tree node1,
- tree node2, tree node3)
-{
- tree item;
+ item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
+ TREE_SIDE_EFFECTS (item) = 1;
+ item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
+ item,
+ temporary);
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (node3 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
+ if (length != NULL)
+ *length = known_length;
+ }
- item = build (code, type, node1, node2, node3);
- if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
- || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
+ ffecom_concat_list_kill_ (catlist);
+ assert (item != NULL_TREE);
+ return item;
}
#endif
-/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
- checking for certain housekeeping things. Always sets
- TREE_SIDE_EFFECTS. */
+/* Generate call to run-time function.
+
+ The first arg is the GNU Fortran Run-Time function index, the second
+ arg is the list of arguments to pass to it. Returned is the expression
+ (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
+ result (which may be void). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_3s (enum tree_code code, tree type, tree node1,
- tree node2, tree node3)
+ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
{
- tree item;
-
- if ((node1 == error_mark_node)
- || (node2 == error_mark_node)
- || (node3 == error_mark_node)
- || (type == error_mark_node))
- return error_mark_node;
-
- item = build (code, type, node1, node2, node3);
- TREE_SIDE_EFFECTS (item) = 1;
- return fold (item);
+ return ffecom_call_ (ffecom_gfrt_tree_ (ix),
+ ffecom_gfrt_kindtype (ix),
+ ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
+ NULL_TREE, args, NULL_TREE, NULL,
+ NULL, NULL_TREE, TRUE, hook);
}
-
#endif
-/* ffecom_arg_expr -- Transform argument expr into gcc tree
-
- See use by ffecom_list_expr.
-
- If expression is NULL, returns an integer zero tree. If it is not
- a CHARACTER expression, returns whatever ffecom_expr
- returns and sets the length return value to NULL_TREE. Otherwise
- generates code to evaluate the character expression, returns the proper
- pointer to the result, but does NOT set the length return value to a tree
- that specifies the length of the result. (In other words, the length
- variable is always set to NULL_TREE, because a length is never passed.)
- 21-Dec-91 JCB 1.1
- Don't set returned length, since nobody needs it (yet; someday if
- we allow CHARACTER*(*) dummies to statement functions, we'll need
- it). */
+/* Transform constant-union to tree. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_arg_expr (ffebld expr, tree *length)
+ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
+ ffeinfoKindtype kt, tree tree_type)
{
- tree ign;
+ tree item;
- *length = NULL_TREE;
+ switch (bt)
+ {
+ case FFEINFO_basictypeINTEGER:
+ {
+ int val;
- if (expr == NULL)
- return integer_zero_node;
+ switch (kt)
+ {
+#if FFETARGET_okINTEGER1
+ case FFEINFO_kindtypeINTEGER1:
+ val = ffebld_cu_val_integer1 (*cu);
+ break;
+#endif
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_expr (expr);
+#if FFETARGET_okINTEGER2
+ case FFEINFO_kindtypeINTEGER2:
+ val = ffebld_cu_val_integer2 (*cu);
+ break;
+#endif
- return ffecom_arg_ptr_to_expr (expr, &ign);
-}
+#if FFETARGET_okINTEGER3
+ case FFEINFO_kindtypeINTEGER3:
+ val = ffebld_cu_val_integer3 (*cu);
+ break;
+#endif
+#if FFETARGET_okINTEGER4
+ case FFEINFO_kindtypeINTEGER4:
+ val = ffebld_cu_val_integer4 (*cu);
+ break;
#endif
-/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
- See use by ffecom_list_ptr_to_expr.
+ default:
+ assert ("bad INTEGER constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ TREE_TYPE (item) = tree_type;
+ }
+ break;
- If expression is NULL, returns an integer zero tree. If it is not
- a CHARACTER expression, returns whatever ffecom_ptr_to_expr
- returns and sets the length return value to NULL_TREE. Otherwise
- generates code to evaluate the character expression, returns the proper
- pointer to the result, AND sets the length return value to a tree that
- specifies the length of the result. */
+ case FFEINFO_basictypeLOGICAL:
+ {
+ int val;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
-{
- tree item;
- tree ign_length;
- ffecomConcatList_ catlist;
+ switch (kt)
+ {
+#if FFETARGET_okLOGICAL1
+ case FFEINFO_kindtypeLOGICAL1:
+ val = ffebld_cu_val_logical1 (*cu);
+ break;
+#endif
+
+#if FFETARGET_okLOGICAL2
+ case FFEINFO_kindtypeLOGICAL2:
+ val = ffebld_cu_val_logical2 (*cu);
+ break;
+#endif
- *length = NULL_TREE;
+#if FFETARGET_okLOGICAL3
+ case FFEINFO_kindtypeLOGICAL3:
+ val = ffebld_cu_val_logical3 (*cu);
+ break;
+#endif
- if (expr == NULL)
- return integer_zero_node;
+#if FFETARGET_okLOGICAL4
+ case FFEINFO_kindtypeLOGICAL4:
+ val = ffebld_cu_val_logical4 (*cu);
+ break;
+#endif
- switch (ffebld_op (expr))
- {
- case FFEBLD_opPERCENT_VAL:
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_expr (ffebld_left (expr));
+ default:
+ assert ("bad LOGICAL constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ TREE_TYPE (item) = tree_type;
+ }
+ break;
+
+ case FFEINFO_basictypeREAL:
{
- tree temp_exp;
- tree temp_length;
+ REAL_VALUE_TYPE val;
- temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
- return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
- temp_exp);
- }
+ switch (kt)
+ {
+#if FFETARGET_okREAL1
+ case FFEINFO_kindtypeREAL1:
+ val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
+ break;
+#endif
- case FFEBLD_opPERCENT_REF:
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_ptr_to_expr (ffebld_left (expr));
- ign_length = NULL_TREE;
- length = &ign_length;
- expr = ffebld_left (expr);
- break;
+#if FFETARGET_okREAL2
+ case FFEINFO_kindtypeREAL2:
+ val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
+ break;
+#endif
- case FFEBLD_opPERCENT_DESCR:
- switch (ffeinfo_basictype (ffebld_info (expr)))
- {
-#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
- case FFEINFO_basictypeHOLLERITH:
+#if FFETARGET_okREAL3
+ case FFEINFO_kindtypeREAL3:
+ val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
+ break;
#endif
- case FFEINFO_basictypeCHARACTER:
- break; /* Passed by descriptor anyway. */
- default:
- item = ffecom_ptr_to_expr (expr);
- if (item != error_mark_node)
- *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
- break;
- }
- break;
+#if FFETARGET_okREAL4
+ case FFEINFO_kindtypeREAL4:
+ val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
+ break;
+#endif
- default:
+ default:
+ assert ("bad REAL constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_real (tree_type, val);
+ }
break;
- }
-#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
- if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
- { /* Pass Hollerith by descriptor. */
- ffetargetHollerith h;
+ case FFEINFO_basictypeCOMPLEX:
+ {
+ REAL_VALUE_TYPE real;
+ REAL_VALUE_TYPE imag;
+ tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
- assert (ffebld_op (expr) == FFEBLD_opCONTER);
- h = ffebld_cu_val_hollerith (ffebld_constant_union
- (ffebld_conter (expr)));
- *length
- = build_int_2 (h.length, 0);
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- }
+ switch (kt)
+ {
+#if FFETARGET_okCOMPLEX1
+ case FFEINFO_kindtypeREAL1:
+ real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
+ imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
+ break;
#endif
- if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
- return ffecom_ptr_to_expr (expr);
-
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeCHARACTER1);
+#if FFETARGET_okCOMPLEX2
+ case FFEINFO_kindtypeREAL2:
+ real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
+ imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
+ break;
+#endif
- catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
- switch (ffecom_concat_list_count_ (catlist))
- {
- case 0: /* Shouldn't happen, but in case it does... */
- *length = ffecom_f2c_ftnlen_zero_node;
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- ffecom_concat_list_kill_ (catlist);
- return null_pointer_node;
+#if FFETARGET_okCOMPLEX3
+ case FFEINFO_kindtypeREAL3:
+ real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
+ imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
+ break;
+#endif
- case 1: /* The (fairly) easy case. */
- ffecom_char_args_ (&item, length,
- ffecom_concat_list_expr_ (catlist, 0));
- ffecom_concat_list_kill_ (catlist);
- assert (item != NULL_TREE);
- return item;
+#if FFETARGET_okCOMPLEX4
+ case FFEINFO_kindtypeREAL4:
+ real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
+ imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
+ break;
+#endif
- default: /* Must actually concatenate things. */
+ default:
+ assert ("bad REAL constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = ffecom_build_complex_constant_ (tree_type,
+ build_real (el_type, real),
+ build_real (el_type, imag));
+ }
break;
- }
- {
- int count = ffecom_concat_list_count_ (catlist);
- int i;
- tree lengths;
- tree items;
- tree length_array;
- tree item_array;
- tree citem;
- tree clength;
- tree temporary;
- tree num;
- tree known_length;
- ffetargetCharacterSize sz;
+ case FFEINFO_basictypeCHARACTER:
+ { /* Happens only in DATA and similar contexts. */
+ ffetargetCharacter1 val;
- length_array
- = lengths
- = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
- item_array
- = items
- = ffecom_push_tempvar (ffecom_f2c_address_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
+ switch (kt)
+ {
+#if FFETARGET_okCHARACTER1
+ case FFEINFO_kindtypeLOGICAL1:
+ val = ffebld_cu_val_character1 (*cu);
+ break;
+#endif
- known_length = ffecom_f2c_ftnlen_zero_node;
+ default:
+ assert ("bad CHARACTER constant kind type" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindtypeANY:
+ return error_mark_node;
+ }
+ item = build_string (ffetarget_length_character1 (val),
+ ffetarget_text_character1 (val));
+ TREE_TYPE (item)
+ = build_type_variant (build_array_type (char_type_node,
+ build_range_type
+ (integer_type_node,
+ integer_one_node,
+ build_int_2
+ (ffetarget_length_character1
+ (val), 0))),
+ 1, 0);
+ }
+ break;
- for (i = 0; i < count; ++i)
+ case FFEINFO_basictypeHOLLERITH:
{
- ffecom_char_args_ (&citem, &clength,
- ffecom_concat_list_expr_ (catlist, i));
- if ((citem == error_mark_node)
- || (clength == error_mark_node))
+ ffetargetHollerith h;
+
+ h = ffebld_cu_val_hollerith (*cu);
+
+ /* If not at least as wide as default INTEGER, widen it. */
+ if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
+ item = build_string (h.length, h.text);
+ else
{
- ffecom_concat_list_kill_ (catlist);
- *length = error_mark_node;
- return error_mark_node;
- }
+ char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
- items
- = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
- ffecom_modify (void_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
- item_array,
- build_int_2 (i, 0)),
- citem),
- items);
- clength = ffecom_save_tree (clength);
- known_length
- = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- known_length,
- clength);
- lengths
- = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
- ffecom_modify (void_type_node,
- ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
- length_array,
- build_int_2 (i, 0)),
- clength),
- lengths);
+ memcpy (str, h.text, h.length);
+ memset (&str[h.length], ' ',
+ FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
+ - h.length);
+ item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
+ str);
+ }
+ TREE_TYPE (item)
+ = build_type_variant (build_array_type (char_type_node,
+ build_range_type
+ (integer_type_node,
+ integer_one_node,
+ build_int_2
+ (h.length, 0))),
+ 1, 0);
}
+ break;
- sz = ffecom_concat_list_maxlen_ (catlist);
- assert (sz != FFETARGET_charactersizeNONE);
+ case FFEINFO_basictypeTYPELESS:
+ {
+ ffetargetInteger1 ival;
+ ffetargetTypeless tless;
+ ffebad error;
- temporary = ffecom_push_tempvar (char_type_node,
- sz, -1, TRUE);
- temporary = ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (temporary)),
- temporary);
+ tless = ffebld_cu_val_typeless (*cu);
+ error = ffetarget_convert_integer1_typeless (&ival, tless);
+ assert (error == FFEBAD);
- item = build_tree_list (NULL_TREE, temporary);
- TREE_CHAIN (item)
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (items)),
- items));
- TREE_CHAIN (TREE_CHAIN (item))
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (lengths)),
- lengths));
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
- = build_tree_list
- (NULL_TREE,
- ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
- convert (ffecom_f2c_ftnlen_type_node,
- build_int_2 (count, 0))));
- num = build_int_2 (sz, 0);
- TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
- = build_tree_list (NULL_TREE, num);
+ item = build_int_2 ((int) ival, 0);
+ }
+ break;
- item = ffecom_call_gfrt (FFECOM_gfrtCAT, item);
- TREE_SIDE_EFFECTS (item) = 1;
- item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
- item,
- temporary);
+ default:
+ assert ("not yet on constant type" == NULL);
+ /* Fall through. */
+ case FFEINFO_basictypeANY:
+ return error_mark_node;
+ }
- *length = known_length;
- }
+ TREE_CONSTANT (item) = 1;
- ffecom_concat_list_kill_ (catlist);
- assert (item != NULL_TREE);
return item;
}
#endif
-/* ffecom_call_gfrt -- Generate call to run-time function
- tree expr;
- expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
+/* Transform expression into constant tree.
- The first arg is the GNU Fortran Run-Time function index, the second
- arg is the list of arguments to pass to it. Returned is the expression
- (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
- result (which may be void). */
+ If the expression can be transformed into a tree that is constant,
+ that is done, and the tree returned. Else NULL_TREE is returned.
+
+ That way, a caller can attempt to provide compile-time initialization
+ of a variable and, if that fails, *then* choose to start a new block
+ and resort to using temporaries, as appropriate. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_call_gfrt (ffecomGfrt ix, tree args)
+ffecom_const_expr (ffebld expr)
{
- return ffecom_call_ (ffecom_gfrt_tree_ (ix),
- ffecom_gfrt_kindtype (ix),
- ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
- NULL_TREE, args, NULL_TREE, NULL,
- NULL, NULL_TREE, TRUE);
-}
+ if (! expr)
+ return integer_zero_node;
+
+ if (ffebld_op (expr) == FFEBLD_opANY)
+ return error_mark_node;
+
+ if (ffebld_arity (expr) == 0
+ && (ffebld_op (expr) != FFEBLD_opSYMTER
+#if NEWCOMMON
+ /* ~~Enable once common/equivalence is handled properly? */
+ || ffebld_where (expr) == FFEINFO_whereCOMMON
#endif
+ || ffebld_where (expr) == FFEINFO_whereGLOBAL
+ || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
+ {
+ tree t;
-/* ffecom_constantunion -- Transform constant-union to tree
+ t = ffecom_expr (expr);
+ assert (TREE_CONSTANT (t));
+ return t;
+ }
+
+ return NULL_TREE;
+}
- ffebldConstantUnion cu; // the constant to transform
- ffeinfoBasictype bt; // its basic type
- ffeinfoKindtype kt; // its kind type
- tree tree_type; // ffecom_tree_type[bt][kt]
- ffecom_constantunion(&cu,bt,kt,tree_type); */
+/* Handy way to make a field in a struct/union. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
- ffeinfoKindtype kt, tree tree_type)
+ffecom_decl_field (tree context, tree prevfield,
+ const char *name, tree type)
{
- tree item;
+ tree field;
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- {
- int val;
+ field = build_decl (FIELD_DECL, get_identifier (name), type);
+ DECL_CONTEXT (field) = context;
+ DECL_ALIGN (field) = 0;
+ DECL_USER_ALIGN (field) = 0;
+ if (prevfield != NULL_TREE)
+ TREE_CHAIN (prevfield) = field;
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- val = ffebld_cu_val_integer1 (*cu);
- break;
-#endif
+ return field;
+}
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- val = ffebld_cu_val_integer2 (*cu);
- break;
#endif
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- val = ffebld_cu_val_integer3 (*cu);
- break;
+void
+ffecom_close_include (FILE *f)
+{
+#if FFECOM_GCC_INCLUDE
+ ffecom_close_include_ (f);
#endif
+}
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- val = ffebld_cu_val_integer4 (*cu);
- break;
+int
+ffecom_decode_include_option (char *spec)
+{
+#if FFECOM_GCC_INCLUDE
+ return ffecom_decode_include_option_ (spec);
+#else
+ return 1;
#endif
+}
- default:
- assert ("bad INTEGER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- TREE_TYPE (item) = tree_type;
- }
- break;
+/* End a compound statement (block). */
- case FFEINFO_basictypeLOGICAL:
- {
- int val;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_end_compstmt (void)
+{
+ return bison_rule_compstmt_ ();
+}
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- val = ffebld_cu_val_logical1 (*cu);
- break;
+/* ffecom_end_transition -- Perform end transition on all symbols
+
+ ffecom_end_transition();
+
+ Calls ffecom_sym_end_transition for each global and local symbol. */
+
+void
+ffecom_end_transition ()
+{
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffebld item;
#endif
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- val = ffebld_cu_val_logical2 (*cu);
- break;
+ if (ffe_is_ffedebug ())
+ fprintf (dmpout, "; end_stmt_transition\n");
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffecom_list_blockdata_ = NULL;
+ ffecom_list_common_ = NULL;
#endif
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- val = ffebld_cu_val_logical3 (*cu);
- break;
+ ffesymbol_drive (ffecom_sym_end_transition);
+ if (ffe_is_ffedebug ())
+ {
+ ffestorag_report ();
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffesymbol_report_all ();
+#endif
+ }
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffecom_start_progunit_ ();
+
+ for (item = ffecom_list_blockdata_;
+ item != NULL;
+ item = ffebld_trail (item))
+ {
+ ffebld callee;
+ ffesymbol s;
+ tree dt;
+ tree t;
+ tree var;
+ static int number = 0;
+
+ callee = ffebld_head (item);
+ s = ffebld_symter (callee);
+ t = ffesymbol_hook (s).decl_tree;
+ if (t == NULL_TREE)
+ {
+ s = ffecom_sym_transform_ (s);
+ t = ffesymbol_hook (s).decl_tree;
+ }
+
+ dt = build_pointer_type (TREE_TYPE (t));
+
+ var = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier ("__g77_forceload_%d",
+ number++),
+ dt);
+ DECL_EXTERNAL (var) = 0;
+ TREE_STATIC (var) = 1;
+ TREE_PUBLIC (var) = 0;
+ DECL_INITIAL (var) = error_mark_node;
+ TREE_USED (var) = 1;
+
+ var = start_decl (var, FALSE);
+
+ t = ffecom_1 (ADDR_EXPR, dt, t);
+
+ finish_decl (var, t, FALSE);
+ }
+
+ /* This handles any COMMON areas that weren't referenced but have, for
+ example, important initial data. */
+
+ for (item = ffecom_list_common_;
+ item != NULL;
+ item = ffebld_trail (item))
+ ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
+
+ ffecom_list_common_ = NULL;
#endif
+}
+
+/* ffecom_exec_transition -- Perform exec transition on all symbols
+
+ ffecom_exec_transition();
+
+ Calls ffecom_sym_exec_transition for each global and local symbol.
+ Make sure error updating not inhibited. */
+
+void
+ffecom_exec_transition ()
+{
+ bool inhibited;
+
+ if (ffe_is_ffedebug ())
+ fprintf (dmpout, "; exec_stmt_transition\n");
+
+ inhibited = ffebad_inhibit ();
+ ffebad_set_inhibit (FALSE);
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- val = ffebld_cu_val_logical4 (*cu);
- break;
+ ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
+ ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
+ if (ffe_is_ffedebug ())
+ {
+ ffestorag_report ();
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffesymbol_report_all ();
#endif
+ }
- default:
- assert ("bad LOGICAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_int_2 (val, (val < 0) ? -1 : 0);
- TREE_TYPE (item) = tree_type;
- }
- break;
+ if (inhibited)
+ ffebad_set_inhibit (TRUE);
+}
- case FFEINFO_basictypeREAL:
- {
- REAL_VALUE_TYPE val;
+/* Handle assignment statement.
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
- break;
-#endif
+ Convert dest and source using ffecom_expr, then join them
+ with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
- break;
-#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_expand_let_stmt (ffebld dest, ffebld source)
+{
+ tree dest_tree;
+ tree dest_length;
+ tree source_tree;
+ tree expr_tree;
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
- break;
-#endif
+ if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
+ {
+ bool dest_used;
+ tree assign_temp;
+
+ /* This attempts to replicate the test below, but must not be
+ true when the test below is false. (Always err on the side
+ of creating unused temporaries, to avoid ICEs.) */
+ if (ffebld_op (dest) != FFEBLD_opSYMTER
+ || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
+ && (TREE_CODE (dest_tree) != VAR_DECL
+ || TREE_ADDRESSABLE (dest_tree))))
+ {
+ ffecom_prepare_expr_ (source, dest);
+ dest_used = TRUE;
+ }
+ else
+ {
+ ffecom_prepare_expr_ (source, NULL);
+ dest_used = FALSE;
+ }
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
- break;
-#endif
+ ffecom_prepare_expr_w (NULL_TREE, dest);
- default:
- assert ("bad REAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_real (tree_type, val);
- }
- break;
+ /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
+ create a temporary through which the assignment is to take place,
+ since MODIFY_EXPR doesn't handle partial overlap properly. */
+ if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
+ && ffecom_possible_partial_overlap_ (dest, source))
+ {
+ assign_temp = ffecom_make_tempvar ("complex_let",
+ ffecom_tree_type
+ [ffebld_basictype (dest)]
+ [ffebld_kindtype (dest)],
+ FFETARGET_charactersizeNONE,
+ -1);
+ }
+ else
+ assign_temp = NULL_TREE;
- case FFEINFO_basictypeCOMPLEX:
- {
- REAL_VALUE_TYPE real;
- REAL_VALUE_TYPE imag;
- tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
+ ffecom_prepare_end ();
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
- imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
- break;
-#endif
+ dest_tree = ffecom_expr_w (NULL_TREE, dest);
+ if (dest_tree == error_mark_node)
+ return;
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
- imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
- break;
-#endif
+ if ((TREE_CODE (dest_tree) != VAR_DECL)
+ || TREE_ADDRESSABLE (dest_tree))
+ source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
+ FALSE, FALSE);
+ else
+ {
+ assert (! dest_used);
+ dest_used = FALSE;
+ source_tree = ffecom_expr (source);
+ }
+ if (source_tree == error_mark_node)
+ return;
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
- imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
- break;
+ if (dest_used)
+ expr_tree = source_tree;
+ else if (assign_temp)
+ {
+#ifdef MOVE_EXPR
+ /* The back end understands a conceptual move (evaluate source;
+ store into dest), so use that, in case it can determine
+ that it is going to use, say, two registers as temporaries
+ anyway. So don't use the temp (and someday avoid generating
+ it, once this code starts triggering regularly). */
+ expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
+ dest_tree,
+ source_tree);
+#else
+ expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
+ assign_temp,
+ source_tree);
+ expand_expr_stmt (expr_tree);
+ expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
+ dest_tree,
+ assign_temp);
#endif
+ }
+ else
+ expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
+ dest_tree,
+ source_tree);
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
- imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
- break;
-#endif
+ expand_expr_stmt (expr_tree);
+ return;
+ }
- default:
- assert ("bad REAL constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = ffecom_build_complex_constant_ (tree_type,
- build_real (el_type, real),
- build_real (el_type, imag));
- }
- break;
+ ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
+ ffecom_prepare_expr_w (NULL_TREE, dest);
- case FFEINFO_basictypeCHARACTER:
- { /* Happens only in DATA and similar contexts. */
- ffetargetCharacter1 val;
+ ffecom_prepare_end ();
+
+ ffecom_char_args_ (&dest_tree, &dest_length, dest);
+ ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
+ source);
+}
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeLOGICAL1:
- val = ffebld_cu_val_character1 (*cu);
- break;
#endif
+/* ffecom_expr -- Transform expr into gcc tree
- default:
- assert ("bad CHARACTER constant kind type" == NULL);
- /* Fall through. */
- case FFEINFO_kindtypeANY:
- return error_mark_node;
- }
- item = build_string (ffetarget_length_character1 (val),
- ffetarget_text_character1 (val));
- TREE_TYPE (item)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2
- (ffetarget_length_character1
- (val), 0))),
- 1, 0);
- }
- break;
+ tree t;
+ ffebld expr; // FFE expression.
+ tree = ffecom_expr(expr);
- case FFEINFO_basictypeHOLLERITH:
- {
- ffetargetHollerith h;
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
- h = ffebld_cu_val_hollerith (*cu);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr (ffebld expr)
+{
+ return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
+}
- /* If not at least as wide as default INTEGER, widen it. */
- if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
- item = build_string (h.length, h.text);
- else
- {
- char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
+#endif
+/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
- memcpy (str, h.text, h.length);
- memset (&str[h.length], ' ',
- FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
- - h.length);
- item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
- str);
- }
- TREE_TYPE (item)
- = build_type_variant (build_array_type (char_type_node,
- build_range_type
- (integer_type_node,
- integer_one_node,
- build_int_2
- (h.length, 0))),
- 1, 0);
- }
- break;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_assign (ffebld expr)
+{
+ return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
+}
- case FFEINFO_basictypeTYPELESS:
- {
- ffetargetInteger1 ival;
- ffetargetTypeless tless;
- ffebad error;
+#endif
+/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
- tless = ffebld_cu_val_typeless (*cu);
- error = ffetarget_convert_integer1_typeless (&ival, tless);
- assert (error == FFEBAD);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_assign_w (ffebld expr)
+{
+ return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
+}
- item = build_int_2 ((int) ival, 0);
- }
- break;
+#endif
+/* Transform expr for use as into read/write tree and stabilize the
+ reference. Not for use on CHARACTER expressions.
- default:
- assert ("not yet on constant type" == NULL);
- /* Fall through. */
- case FFEINFO_basictypeANY:
- return error_mark_node;
- }
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
- TREE_CONSTANT (item) = 1;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_rw (tree type, ffebld expr)
+{
+ assert (expr != NULL);
+ /* Different target types not yet supported. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
- return item;
+ return stabilize_reference (ffecom_expr (expr));
}
#endif
+/* Transform expr for use as into write tree and stabilize the
+ reference. Not for use on CHARACTER expressions.
-/* Handy way to make a field in a struct/union. */
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_decl_field (tree context, tree prevfield,
- char *name, tree type)
+ffecom_expr_w (tree type, ffebld expr)
{
- tree field;
-
- field = build_decl (FIELD_DECL, get_identifier (name), type);
- DECL_CONTEXT (field) = context;
- DECL_FRAME_SIZE (field) = 0;
- if (prevfield != NULL_TREE)
- TREE_CHAIN (prevfield) = field;
+ assert (expr != NULL);
+ /* Different target types not yet supported. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
- return field;
+ return stabilize_reference (ffecom_expr (expr));
}
#endif
+/* Do global stuff. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
-ffecom_close_include (FILE *f)
+ffecom_finish_compile ()
{
-#if FFECOM_GCC_INCLUDE
- ffecom_close_include_ (f);
-#endif
-}
+ assert (ffecom_outer_function_decl_ == NULL_TREE);
+ assert (current_function_decl == NULL_TREE);
-int
-ffecom_decode_include_option (char *spec)
-{
-#if FFECOM_GCC_INCLUDE
- return ffecom_decode_include_option_ (spec);
-#else
- return 1;
-#endif
+ ffeglobal_drive (ffecom_finish_global_);
}
-/* ffecom_end_transition -- Perform end transition on all symbols
+#endif
+/* Public entry point for front end to access finish_decl. */
- ffecom_end_transition();
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_finish_decl (tree decl, tree init, bool is_top_level)
+{
+ assert (!is_top_level);
+ finish_decl (decl, init, FALSE);
+}
- Calls ffecom_sym_end_transition for each global and local symbol. */
+#endif
+/* Finish a program unit. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
-ffecom_end_transition ()
+ffecom_finish_progunit ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffebld item;
-#endif
+ ffecom_end_compstmt ();
- if (ffe_is_ffedebug ())
- fprintf (dmpout, "; end_stmt_transition\n");
+ ffecom_previous_function_decl_ = current_function_decl;
+ ffecom_which_entrypoint_decl_ = NULL_TREE;
+
+ finish_function (0);
+}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffecom_list_blockdata_ = NULL;
- ffecom_list_common_ = NULL;
#endif
- ffesymbol_drive (ffecom_sym_end_transition);
- if (ffe_is_ffedebug ())
- {
- ffestorag_report ();
- ffesymbol_report_all ();
- }
+/* Wrapper for get_identifier. pattern is sprintf-like. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
- ffecom_start_progunit_ ();
+tree
+ffecom_get_invented_identifier (const char *pattern, ...)
+{
+ tree decl;
+ char *nam;
+ va_list ap;
- for (item = ffecom_list_blockdata_;
- item != NULL;
- item = ffebld_trail (item))
- {
- ffebld callee;
- ffesymbol s;
- tree dt;
- tree t;
- tree var;
- int yes;
- static int number = 0;
+ va_start (ap, pattern);
+ if (vasprintf (&nam, pattern, ap) == 0)
+ abort ();
+ va_end (ap);
+ decl = get_identifier (nam);
+ free (nam);
+ IDENTIFIER_INVENTED (decl) = 1;
+ return decl;
+}
- callee = ffebld_head (item);
- s = ffebld_symter (callee);
- t = ffesymbol_hook (s).decl_tree;
- if (t == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- t = ffesymbol_hook (s).decl_tree;
- }
+ffeinfoBasictype
+ffecom_gfrt_basictype (ffecomGfrt gfrt)
+{
+ assert (gfrt < FFECOM_gfrt);
- yes = suspend_momentary ();
+ switch (ffecom_gfrt_type_[gfrt])
+ {
+ case FFECOM_rttypeVOID_:
+ case FFECOM_rttypeVOIDSTAR_:
+ return FFEINFO_basictypeNONE;
- dt = build_pointer_type (TREE_TYPE (t));
+ case FFECOM_rttypeFTNINT_:
+ return FFEINFO_basictypeINTEGER;
- var = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_forceload_%d",
- NULL, number++),
- dt);
- DECL_EXTERNAL (var) = 0;
- TREE_STATIC (var) = 1;
- TREE_PUBLIC (var) = 0;
- DECL_INITIAL (var) = error_mark_node;
- TREE_USED (var) = 1;
+ case FFECOM_rttypeINTEGER_:
+ return FFEINFO_basictypeINTEGER;
- var = start_decl (var, FALSE);
+ case FFECOM_rttypeLONGINT_:
+ return FFEINFO_basictypeINTEGER;
- t = ffecom_1 (ADDR_EXPR, dt, t);
+ case FFECOM_rttypeLOGICAL_:
+ return FFEINFO_basictypeLOGICAL;
- finish_decl (var, t, FALSE);
+ case FFECOM_rttypeREAL_F2C_:
+ case FFECOM_rttypeREAL_GNU_:
+ return FFEINFO_basictypeREAL;
- resume_momentary (yes);
- }
+ case FFECOM_rttypeCOMPLEX_F2C_:
+ case FFECOM_rttypeCOMPLEX_GNU_:
+ return FFEINFO_basictypeCOMPLEX;
- /* This handles any COMMON areas that weren't referenced but have, for
- example, important initial data. */
+ case FFECOM_rttypeDOUBLE_:
+ case FFECOM_rttypeDOUBLEREAL_:
+ return FFEINFO_basictypeREAL;
- for (item = ffecom_list_common_;
- item != NULL;
- item = ffebld_trail (item))
- ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
+ case FFECOM_rttypeDBLCMPLX_F2C_:
+ case FFECOM_rttypeDBLCMPLX_GNU_:
+ return FFEINFO_basictypeCOMPLEX;
- ffecom_list_common_ = NULL;
-#endif
+ case FFECOM_rttypeCHARACTER_:
+ return FFEINFO_basictypeCHARACTER;
+
+ default:
+ return FFEINFO_basictypeANY;
+ }
}
-/* ffecom_exec_transition -- Perform exec transition on all symbols
+ffeinfoKindtype
+ffecom_gfrt_kindtype (ffecomGfrt gfrt)
+{
+ assert (gfrt < FFECOM_gfrt);
- ffecom_exec_transition();
+ switch (ffecom_gfrt_type_[gfrt])
+ {
+ case FFECOM_rttypeVOID_:
+ case FFECOM_rttypeVOIDSTAR_:
+ return FFEINFO_kindtypeNONE;
- Calls ffecom_sym_exec_transition for each global and local symbol.
- Make sure error updating not inhibited. */
+ case FFECOM_rttypeFTNINT_:
+ return FFEINFO_kindtypeINTEGER1;
-void
-ffecom_exec_transition ()
-{
- bool inhibited;
+ case FFECOM_rttypeINTEGER_:
+ return FFEINFO_kindtypeINTEGER1;
- if (ffe_is_ffedebug ())
- fprintf (dmpout, "; exec_stmt_transition\n");
+ case FFECOM_rttypeLONGINT_:
+ return FFEINFO_kindtypeINTEGER4;
- inhibited = ffebad_inhibit ();
- ffebad_set_inhibit (FALSE);
+ case FFECOM_rttypeLOGICAL_:
+ return FFEINFO_kindtypeLOGICAL1;
- ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
- ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
- if (ffe_is_ffedebug ())
- {
- ffestorag_report ();
- ffesymbol_report_all ();
- }
+ case FFECOM_rttypeREAL_F2C_:
+ case FFECOM_rttypeREAL_GNU_:
+ return FFEINFO_kindtypeREAL1;
- if (inhibited)
- ffebad_set_inhibit (TRUE);
-}
+ case FFECOM_rttypeCOMPLEX_F2C_:
+ case FFECOM_rttypeCOMPLEX_GNU_:
+ return FFEINFO_kindtypeREAL1;
+
+ case FFECOM_rttypeDOUBLE_:
+ case FFECOM_rttypeDOUBLEREAL_:
+ return FFEINFO_kindtypeREAL2;
-/* ffecom_expand_let_stmt -- Compile let (assignment) statement
+ case FFECOM_rttypeDBLCMPLX_F2C_:
+ case FFECOM_rttypeDBLCMPLX_GNU_:
+ return FFEINFO_kindtypeREAL2;
- ffebld dest;
- ffebld source;
- ffecom_expand_let_stmt(dest,source);
+ case FFECOM_rttypeCHARACTER_:
+ return FFEINFO_kindtypeCHARACTER1;
- Convert dest and source using ffecom_expr, then join them
- with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
+ default:
+ return FFEINFO_kindtypeANY;
+ }
+}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
-ffecom_expand_let_stmt (ffebld dest, ffebld source)
+ffecom_init_0 ()
{
- tree dest_tree;
- tree dest_length;
- tree source_tree;
- tree expr_tree;
+ tree endlink;
+ int i;
+ int j;
+ tree t;
+ tree field;
+ ffetype type;
+ ffetype base_type;
+ tree double_ftype_double;
+ tree float_ftype_float;
+ tree ldouble_ftype_ldouble;
+ tree ffecom_tree_ptr_to_fun_type_void;
- if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
- {
- bool dest_used;
+ /* This block of code comes from the now-obsolete cktyps.c. It checks
+ whether the compiler environment is buggy in known ways, some of which
+ would, if not explicitly checked here, result in subtle bugs in g77. */
- dest_tree = ffecom_expr_rw (dest);
- if (dest_tree == error_mark_node)
- return;
+ if (ffe_is_do_internal_checks ())
+ {
+ static char names[][12]
+ =
+ {"bar", "bletch", "foo", "foobar"};
+ char *name;
+ unsigned long ul;
+ double fl;
- if ((TREE_CODE (dest_tree) != VAR_DECL)
- || TREE_ADDRESSABLE (dest_tree))
- source_tree = ffecom_expr_ (source, NULL_TREE, dest_tree, dest,
- &dest_used, FALSE);
- else
+ name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
+ (int (*)(const void *, const void *)) strcmp);
+ if (name != (char *) &names[2])
{
- source_tree = ffecom_expr (source);
- dest_used = FALSE;
+ assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
+ == NULL);
+ abort ();
}
- if (source_tree == error_mark_node)
- return;
- if (dest_used)
- expr_tree = source_tree;
- else
- expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
- dest_tree,
- source_tree);
+ ul = strtoul ("123456789", NULL, 10);
+ if (ul != 123456789L)
+ {
+ assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
+ in proj.h" == NULL);
+ abort ();
+ }
- expand_expr_stmt (expr_tree);
- return;
+ fl = atof ("56.789");
+ if ((fl < 56.788) || (fl > 56.79))
+ {
+ assert ("atof not type double, fix your #include <stdio.h>"
+ == NULL);
+ abort ();
+ }
}
- ffecom_push_calltemps ();
- ffecom_char_args_ (&dest_tree, &dest_length, dest);
- ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
- source);
- ffecom_pop_calltemps ();
-}
-
+#if FFECOM_GCC_INCLUDE
+ ffecom_initialize_char_syntax_ ();
#endif
-/* ffecom_expr -- Transform expr into gcc tree
- tree t;
- ffebld expr; // FFE expression.
- tree = ffecom_expr(expr);
+ ffecom_outer_function_decl_ = NULL_TREE;
+ current_function_decl = NULL_TREE;
+ named_labels = NULL_TREE;
+ current_binding_level = NULL_BINDING_LEVEL;
+ free_binding_level = NULL_BINDING_LEVEL;
+ /* Make the binding_level structure for global names. */
+ pushlevel (0);
+ global_binding_level = current_binding_level;
+ current_binding_level->prep_state = 2;
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
+ build_common_tree_nodes (1);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL_TREE, NULL, NULL,
- FALSE);
-}
+ /* Define `int' and `char' first so that dbx will output them first. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
+ integer_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
+ char_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
+ long_integer_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
+ unsigned_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
+ long_unsigned_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
+ long_long_integer_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
+ long_long_unsigned_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
+ short_integer_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
+ short_unsigned_type_node));
-#endif
-/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
+ /* Set the sizetype before we make other types. This *should* be the
+ first type we create. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr_assign (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL_TREE, NULL, NULL,
- TRUE);
-}
+ set_sizetype
+ (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
+ ffecom_typesize_pointer_
+ = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
-#endif
-/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
+ build_common_tree_nodes_2 (0);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr_assign_w (ffebld expr)
-{
- return ffecom_expr_ (expr, NULL_TREE, NULL_TREE, NULL, NULL,
- TRUE);
-}
+ /* Define both `signed char' and `unsigned char'. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
+ signed_char_type_node));
-#endif
-/* Transform expr for use as into read/write tree and stabilize the
- reference. Not for use on CHARACTER expressions.
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
+ unsigned_char_type_node));
- Recursive descent on expr while making corresponding tree nodes and
- attaching type info and such. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
+ float_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
+ double_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
+ long_double_type_node));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_expr_rw (ffebld expr)
-{
- assert (expr != NULL);
+ /* For now, override what build_common_tree_nodes has done. */
+ complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
+ complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
+ complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
+ complex_long_double_type_node
+ = ffecom_make_complex_type_ (long_double_type_node);
- return stabilize_reference (ffecom_expr (expr));
-}
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
+ complex_integer_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
+ complex_float_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
+ complex_double_type_node));
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
+ complex_long_double_type_node));
-#endif
-/* Do global stuff. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
+ void_type_node));
+ /* We are not going to have real types in C with less than byte alignment,
+ so we might as well not have any types that claim to have it. */
+ TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
+ TYPE_USER_ALIGN (void_type_node) = 0;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_finish_compile ()
-{
- assert (ffecom_outer_function_decl_ == NULL_TREE);
- assert (current_function_decl == NULL_TREE);
+ string_type_node = build_pointer_type (char_type_node);
- ffeglobal_drive (ffecom_finish_global_);
-}
+ ffecom_tree_fun_type_void
+ = build_function_type (void_type_node, NULL_TREE);
-#endif
-/* Public entry point for front end to access finish_decl. */
+ ffecom_tree_ptr_to_fun_type_void
+ = build_pointer_type (ffecom_tree_fun_type_void);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_finish_decl (tree decl, tree init, bool is_top_level)
-{
- assert (!is_top_level);
- finish_decl (decl, init, FALSE);
-}
+ endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
-#endif
-/* Finish a program unit. */
+ float_ftype_float
+ = build_function_type (float_type_node,
+ tree_cons (NULL_TREE, float_type_node, endlink));
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_finish_progunit ()
-{
- ffecom_end_compstmt_ ();
+ double_ftype_double
+ = build_function_type (double_type_node,
+ tree_cons (NULL_TREE, double_type_node, endlink));
- ffecom_previous_function_decl_ = current_function_decl;
- ffecom_which_entrypoint_decl_ = NULL_TREE;
+ ldouble_ftype_ldouble
+ = build_function_type (long_double_type_node,
+ tree_cons (NULL_TREE, long_double_type_node,
+ endlink));
- finish_function (0);
-}
+ for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
+ for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
+ {
+ ffecom_tree_type[i][j] = NULL_TREE;
+ ffecom_tree_fun_type[i][j] = NULL_TREE;
+ ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
+ ffecom_f2c_typecode_[i][j] = -1;
+ }
-#endif
-/* Wrapper for get_identifier. pattern is like "...%s...", text is
- inserted into final name in place of "%s", or if text is NULL,
- pattern is like "...%d..." and text form of number is inserted
- in place of "%d". */
+ /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
+ to size FLOAT_TYPE_SIZE because they have to be the same size as
+ REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
+ Compiler options and other such stuff that change the ways these
+ types are set should not affect this particular setup. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_get_invented_identifier (char *pattern, char *text, int number)
-{
- tree decl;
- char *nam;
- mallocSize lenlen;
- char space[66];
+ ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
+ = t = make_signed_type (FLOAT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
+ t));
+ type = ffetype_new ();
+ base_type = type;
+ ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 1, type);
+ ffecom_typesize_integer1_ = ffetype_size (type);
+ assert (ffetype_size (type) == sizeof (ffetargetInteger1));
- if (text == NULL)
- lenlen = strlen (pattern) + 20;
- else
- lenlen = strlen (pattern) + strlen (text) - 1;
- if (lenlen > ARRAY_SIZE (space))
- nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
- else
- nam = &space[0];
- if (text == NULL)
- sprintf (&nam[0], pattern, number);
- else
- sprintf (&nam[0], pattern, text);
- decl = get_identifier (nam);
- if (lenlen > ARRAY_SIZE (space))
- malloc_kill_ks (malloc_pool_image (), nam, lenlen);
+ ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
+ = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
+ t));
- IDENTIFIER_INVENTED (decl) = 1;
+ ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
+ = t = make_signed_type (CHAR_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 3, type);
+ assert (ffetype_size (type) == sizeof (ffetargetInteger2));
- return decl;
-}
+ ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
+ = t = make_unsigned_type (CHAR_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
+ t));
-ffeinfoBasictype
-ffecom_gfrt_basictype (ffecomGfrt gfrt)
-{
- assert (gfrt < FFECOM_gfrt);
+ ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
+ = t = make_signed_type (CHAR_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 6, type);
+ assert (ffetype_size (type) == sizeof (ffetargetInteger3));
+
+ ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
+ = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
+ t));
- switch (ffecom_gfrt_type_[gfrt])
- {
- case FFECOM_rttypeVOID_:
- return FFEINFO_basictypeNONE;
+ ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
+ = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 2, type);
+ assert (ffetype_size (type) == sizeof (ffetargetInteger4));
- case FFECOM_rttypeFTNINT_:
- return FFEINFO_basictypeINTEGER;
+ ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
+ = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
+ t));
- case FFECOM_rttypeINTEGER_:
- return FFEINFO_basictypeINTEGER;
+#if 0
+ if (ffe_is_do_internal_checks ()
+ && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
+ && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
+ && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
+ && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
+ {
+ fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
+ LONG_TYPE_SIZE);
+ }
+#endif
- case FFECOM_rttypeLONGINT_:
- return FFEINFO_basictypeINTEGER;
+ ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
+ = t = make_signed_type (FLOAT_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
+ t));
+ type = ffetype_new ();
+ base_type = type;
+ ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 1, type);
+ assert (ffetype_size (type) == sizeof (ffetargetLogical1));
- case FFECOM_rttypeLOGICAL_:
- return FFEINFO_basictypeLOGICAL;
+ ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
+ = t = make_signed_type (CHAR_TYPE_SIZE);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 3, type);
+ assert (ffetype_size (type) == sizeof (ffetargetLogical2));
- case FFECOM_rttypeREAL_F2C_:
- case FFECOM_rttypeREAL_GNU_:
- return FFEINFO_basictypeREAL;
+ ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
+ = t = make_signed_type (CHAR_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 6, type);
+ assert (ffetype_size (type) == sizeof (ffetargetLogical3));
- case FFECOM_rttypeCOMPLEX_F2C_:
- case FFECOM_rttypeCOMPLEX_GNU_:
- return FFEINFO_basictypeCOMPLEX;
+ ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
+ = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 2, type);
+ assert (ffetype_size (type) == sizeof (ffetargetLogical4));
- case FFECOM_rttypeDOUBLE_:
- case FFECOM_rttypeDOUBLEREAL_:
- return FFEINFO_basictypeREAL;
+ ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
+ = t = make_node (REAL_TYPE);
+ TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
+ t));
+ layout_type (t);
+ type = ffetype_new ();
+ base_type = type;
+ ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 1, type);
+ ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
+ = FFETARGET_f2cTYREAL;
+ assert (ffetype_size (type) == sizeof (ffetargetReal1));
- case FFECOM_rttypeDBLCMPLX_F2C_:
- case FFECOM_rttypeDBLCMPLX_GNU_:
- return FFEINFO_basictypeCOMPLEX;
+ ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
+ = t = make_node (REAL_TYPE);
+ TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
+ t));
+ layout_type (t);
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 2, type);
+ ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
+ = FFETARGET_f2cTYDREAL;
+ assert (ffetype_size (type) == sizeof (ffetargetReal2));
- case FFECOM_rttypeCHARACTER_:
- return FFEINFO_basictypeCHARACTER;
+ ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
+ = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
+ t));
+ type = ffetype_new ();
+ base_type = type;
+ ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 1, type);
+ ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
+ = FFETARGET_f2cTYCOMPLEX;
+ assert (ffetype_size (type) == sizeof (ffetargetComplex1));
- default:
- return FFEINFO_basictypeANY;
- }
-}
+ ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
+ = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
+ pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
+ t));
+ type = ffetype_new ();
+ ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_star (base_type,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
+ type);
+ ffetype_set_kind (base_type, 2,
+ type);
+ ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
+ = FFETARGET_f2cTYDCOMPLEX;
+ assert (ffetype_size (type) == sizeof (ffetargetComplex2));
-ffeinfoKindtype
-ffecom_gfrt_kindtype (ffecomGfrt gfrt)
-{
- assert (gfrt < FFECOM_gfrt);
+ /* Make function and ptr-to-function types for non-CHARACTER types. */
- switch (ffecom_gfrt_type_[gfrt])
- {
- case FFECOM_rttypeVOID_:
- return FFEINFO_kindtypeNONE;
+ for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
+ for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
+ {
+ if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
+ {
+ if (i == FFEINFO_basictypeINTEGER)
+ {
+ /* Figure out the smallest INTEGER type that can hold
+ a pointer on this machine. */
+ if (GET_MODE_SIZE (TYPE_MODE (t))
+ >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
+ {
+ if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
+ || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
+ > GET_MODE_SIZE (TYPE_MODE (t))))
+ ffecom_pointer_kind_ = j;
+ }
+ }
+ else if (i == FFEINFO_basictypeCOMPLEX)
+ t = void_type_node;
+ /* For f2c compatibility, REAL functions are really
+ implemented as DOUBLE PRECISION. */
+ else if ((i == FFEINFO_basictypeREAL)
+ && (j == FFEINFO_kindtypeREAL1))
+ t = ffecom_tree_type
+ [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
- case FFECOM_rttypeFTNINT_:
- return FFEINFO_kindtypeINTEGER1;
+ t = ffecom_tree_fun_type[i][j] = build_function_type (t,
+ NULL_TREE);
+ ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
+ }
+ }
- case FFECOM_rttypeINTEGER_:
- return FFEINFO_kindtypeINTEGER1;
+ /* Set up pointer types. */
- case FFECOM_rttypeLONGINT_:
- return FFEINFO_kindtypeINTEGER4;
+ if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
+ fatal_error ("no INTEGER type can hold a pointer on this configuration");
+ else if (0 && ffe_is_do_internal_checks ())
+ fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
+ ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
+ FFEINFO_kindtypeINTEGERDEFAULT),
+ 7,
+ ffeinfo_type (FFEINFO_basictypeINTEGER,
+ ffecom_pointer_kind_));
- case FFECOM_rttypeLOGICAL_:
- return FFEINFO_kindtypeLOGICAL1;
+ if (ffe_is_ugly_assign ())
+ ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
+ else
+ ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
+ if (0 && ffe_is_do_internal_checks ())
+ fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
- case FFECOM_rttypeREAL_F2C_:
- case FFECOM_rttypeREAL_GNU_:
- return FFEINFO_kindtypeREAL1;
+ ffecom_integer_type_node
+ = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
+ ffecom_integer_zero_node = convert (ffecom_integer_type_node,
+ integer_zero_node);
+ ffecom_integer_one_node = convert (ffecom_integer_type_node,
+ integer_one_node);
- case FFECOM_rttypeCOMPLEX_F2C_:
- case FFECOM_rttypeCOMPLEX_GNU_:
- return FFEINFO_kindtypeREAL1;
+ /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
+ Turns out that by TYLONG, runtime/libI77/lio.h really means
+ "whatever size an ftnint is". For consistency and sanity,
+ com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
+ all are INTEGER, which we also make out of whatever back-end
+ integer type is FLOAT_TYPE_SIZE bits wide. This change, from
+ LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
+ accommodate machines like the Alpha. Note that this suggests
+ f2c and libf2c are missing a distinction perhaps needed on
+ some machines between "int" and "long int". -- burley 0.5.5 950215 */
- case FFECOM_rttypeDOUBLE_:
- case FFECOM_rttypeDOUBLEREAL_:
- return FFEINFO_kindtypeREAL2;
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
+ FFETARGET_f2cTYLONG);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
+ FFETARGET_f2cTYSHORT);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
+ FFETARGET_f2cTYINT1);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
+ FFETARGET_f2cTYQUAD);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
+ FFETARGET_f2cTYLOGICAL);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
+ FFETARGET_f2cTYLOGICAL2);
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
+ FFETARGET_f2cTYLOGICAL1);
+ /* ~~~Not really such a type in libf2c, e.g. I/O support? */
+ ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
+ FFETARGET_f2cTYQUAD);
- case FFECOM_rttypeDBLCMPLX_F2C_:
- case FFECOM_rttypeDBLCMPLX_GNU_:
- return FFEINFO_kindtypeREAL2;
+ /* CHARACTER stuff is all special-cased, so it is not handled in the above
+ loop. CHARACTER items are built as arrays of unsigned char. */
- case FFECOM_rttypeCHARACTER_:
- return FFEINFO_kindtypeCHARACTER1;
+ ffecom_tree_type[FFEINFO_basictypeCHARACTER]
+ [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
+ type = ffetype_new ();
+ base_type = type;
+ ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
+ FFEINFO_kindtypeCHARACTER1,
+ type);
+ ffetype_set_ams (type,
+ TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
+ TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
+ ffetype_set_kind (base_type, 1, type);
+ assert (ffetype_size (type)
+ == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
- default:
- return FFEINFO_kindtypeANY;
- }
-}
+ ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
+ [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
+ ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
+ [FFEINFO_kindtypeCHARACTER1]
+ = ffecom_tree_ptr_to_fun_type_void;
+ ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
+ = FFETARGET_f2cTYCHAR;
-void
-ffecom_init_0 ()
-{
- tree endlink;
- int i;
- int j;
- tree t;
- tree field;
- ffetype type;
- ffetype base_type;
+ ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
+ = 0;
- /* This block of code comes from the now-obsolete cktyps.c. It checks
- whether the compiler environment is buggy in known ways, some of which
- would, if not explicitly checked here, result in subtle bugs in g77. */
+ /* Make multi-return-value type and fields. */
- if (ffe_is_do_internal_checks ())
- {
- static char names[][12]
- =
- {"bar", "bletch", "foo", "foobar"};
- char *name;
- unsigned long ul;
- double fl;
+ ffecom_multi_type_node_ = make_node (UNION_TYPE);
- name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
- (int (*)()) strcmp);
- if (name != (char *) &names[2])
- {
- assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
- == NULL);
- abort ();
- }
+ field = NULL_TREE;
- ul = strtoul ("123456789", NULL, 10);
- if (ul != 123456789L)
- {
- assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
- in proj.h" == NULL);
- abort ();
- }
+ for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
+ for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
+ {
+ char name[30];
- fl = atof ("56.789");
- if ((fl < 56.788) || (fl > 56.79))
- {
- assert ("atof not type double, fix your #include <stdio.h>"
- == NULL);
- abort ();
- }
- }
+ if (ffecom_tree_type[i][j] == NULL_TREE)
+ continue; /* Not supported. */
+ sprintf (&name[0], "bt_%s_kt_%s",
+ ffeinfo_basictype_string ((ffeinfoBasictype) i),
+ ffeinfo_kindtype_string ((ffeinfoKindtype) j));
+ ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
+ get_identifier (name),
+ ffecom_tree_type[i][j]);
+ DECL_CONTEXT (ffecom_multi_fields_[i][j])
+ = ffecom_multi_type_node_;
+ DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
+ DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
+ TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
+ field = ffecom_multi_fields_[i][j];
+ }
-#if FFECOM_GCC_INCLUDE
- ffecom_initialize_char_syntax_ ();
-#endif
+ TYPE_FIELDS (ffecom_multi_type_node_) = field;
+ layout_type (ffecom_multi_type_node_);
- ffecom_outer_function_decl_ = NULL_TREE;
- current_function_decl = NULL_TREE;
- named_labels = NULL_TREE;
- current_binding_level = NULL_BINDING_LEVEL;
- free_binding_level = NULL_BINDING_LEVEL;
- pushlevel (0); /* make the binding_level structure for
- global names */
- global_binding_level = current_binding_level;
+ /* Subroutines usually return integer because they might have alternate
+ returns. */
- /* Define `int' and `char' first so that dbx will output them first. */
+ ffecom_tree_subr_type
+ = build_function_type (integer_type_node, NULL_TREE);
+ ffecom_tree_ptr_to_subr_type
+ = build_pointer_type (ffecom_tree_subr_type);
+ ffecom_tree_blockdata_type
+ = build_function_type (void_type_node, NULL_TREE);
- integer_type_node = make_signed_type (INT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
- integer_type_node));
+ builtin_function ("__builtin_sqrtf", float_ftype_float,
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
+ builtin_function ("__builtin_fsqrt", double_ftype_double,
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
+ builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
+ builtin_function ("__builtin_sinf", float_ftype_float,
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
+ builtin_function ("__builtin_sin", double_ftype_double,
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
+ builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
+ builtin_function ("__builtin_cosf", float_ftype_float,
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
+ builtin_function ("__builtin_cos", double_ftype_double,
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
+ builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
- char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
- char_type_node));
+#if BUILT_FOR_270
+ pedantic_lvalues = FALSE;
+#endif
- long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
- long_integer_type_node));
+ ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
+ FFECOM_f2cINTEGER,
+ "integer");
+ ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
+ FFECOM_f2cADDRESS,
+ "address");
+ ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
+ FFECOM_f2cREAL,
+ "real");
+ ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
+ FFECOM_f2cDOUBLEREAL,
+ "doublereal");
+ ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
+ FFECOM_f2cCOMPLEX,
+ "complex");
+ ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
+ FFECOM_f2cDOUBLECOMPLEX,
+ "doublecomplex");
+ ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
+ FFECOM_f2cLONGINT,
+ "longint");
+ ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
+ FFECOM_f2cLOGICAL,
+ "logical");
+ ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
+ FFECOM_f2cFLAG,
+ "flag");
+ ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
+ FFECOM_f2cFTNLEN,
+ "ftnlen");
+ ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
+ FFECOM_f2cFTNINT,
+ "ftnint");
- unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
- unsigned_type_node));
+ ffecom_f2c_ftnlen_zero_node
+ = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
- long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
- long_unsigned_type_node));
+ ffecom_f2c_ftnlen_one_node
+ = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
- long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
- long_long_integer_type_node));
+ ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
+ TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
- long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
- long_long_unsigned_type_node));
+ ffecom_f2c_ptr_to_ftnlen_type_node
+ = build_pointer_type (ffecom_f2c_ftnlen_type_node);
- set_sizetype
- (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
+ ffecom_f2c_ptr_to_ftnint_type_node
+ = build_pointer_type (ffecom_f2c_ftnint_type_node);
- error_mark_node = make_node (ERROR_MARK);
- TREE_TYPE (error_mark_node) = error_mark_node;
+ ffecom_f2c_ptr_to_integer_type_node
+ = build_pointer_type (ffecom_f2c_integer_type_node);
- short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
- short_integer_type_node));
+ ffecom_f2c_ptr_to_real_type_node
+ = build_pointer_type (ffecom_f2c_real_type_node);
- short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
- short_unsigned_type_node));
+ ffecom_float_zero_ = build_real (float_type_node, dconst0);
+ ffecom_double_zero_ = build_real (double_type_node, dconst0);
+ {
+ REAL_VALUE_TYPE point_5;
- /* Define both `signed char' and `unsigned char'. */
- signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
- signed_char_type_node));
+#ifdef REAL_ARITHMETIC
+ REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
+#else
+ point_5 = .5;
+#endif
+ ffecom_float_half_ = build_real (float_type_node, point_5);
+ ffecom_double_half_ = build_real (double_type_node, point_5);
+ }
- unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
- unsigned_char_type_node));
+ /* Do "extern int xargc;". */
- float_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
- layout_type (float_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
- float_type_node));
+ ffecom_tree_xargc_ = build_decl (VAR_DECL,
+ get_identifier ("f__xargc"),
+ integer_type_node);
+ DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
+ TREE_STATIC (ffecom_tree_xargc_) = 1;
+ TREE_PUBLIC (ffecom_tree_xargc_) = 1;
+ ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
+ finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
- double_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
- layout_type (double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
- double_type_node));
+#if 0 /* This is being fixed, and seems to be working now. */
+ if ((FLOAT_TYPE_SIZE != 32)
+ || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
+ {
+ warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
+ (int) FLOAT_TYPE_SIZE);
+ warning ("and pointers are %d bits wide, but g77 doesn't yet work",
+ (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
+ warning ("properly unless they all are 32 bits wide.");
+ warning ("Please keep this in mind before you report bugs. g77 should");
+ warning ("support non-32-bit machines better as of version 0.6.");
+ }
+#endif
- long_double_type_node = make_node (REAL_TYPE);
- TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (long_double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
- long_double_type_node));
+#if 0 /* Code in ste.c that would crash has been commented out. */
+ if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
+ < TYPE_PRECISION (string_type_node))
+ /* I/O will probably crash. */
+ warning ("configuration: char * holds %d bits, but ftnlen only %d",
+ TYPE_PRECISION (string_type_node),
+ TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
+#endif
- complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
- complex_integer_type_node));
+#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
+ if (TYPE_PRECISION (ffecom_integer_type_node)
+ < TYPE_PRECISION (string_type_node))
+ /* ASSIGN 10 TO I will crash. */
+ warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
+ ASSIGN statement might fail",
+ TYPE_PRECISION (string_type_node),
+ TYPE_PRECISION (ffecom_integer_type_node));
+#endif
+}
- complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
- complex_float_type_node));
+#endif
+/* ffecom_init_2 -- Initialize
- complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
- complex_double_type_node));
+ ffecom_init_2(); */
- complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
- complex_long_double_type_node));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_init_2 ()
+{
+ assert (ffecom_outer_function_decl_ == NULL_TREE);
+ assert (current_function_decl == NULL_TREE);
+ assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
- integer_zero_node = build_int_2 (0, 0);
- TREE_TYPE (integer_zero_node) = integer_type_node;
- integer_one_node = build_int_2 (1, 0);
- TREE_TYPE (integer_one_node) = integer_type_node;
+ ffecom_master_arglist_ = NULL;
+ ++ffecom_num_fns_;
+ ffecom_primary_entry_ = NULL;
+ ffecom_is_altreturning_ = FALSE;
+ ffecom_func_result_ = NULL_TREE;
+ ffecom_multi_retval_ = NULL_TREE;
+}
- size_zero_node = build_int_2 (0, 0);
- TREE_TYPE (size_zero_node) = sizetype;
- size_one_node = build_int_2 (1, 0);
- TREE_TYPE (size_one_node) = sizetype;
+#endif
+/* ffecom_list_expr -- Transform list of exprs into gcc tree
- void_type_node = make_node (VOID_TYPE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
- void_type_node));
- layout_type (void_type_node); /* Uses integer_zero_node */
- /* We are not going to have real types in C with less than byte alignment,
- so we might as well not have any types that claim to have it. */
- TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
+ tree t;
+ ffebld expr; // FFE opITEM list.
+ tree = ffecom_list_expr(expr);
- null_pointer_node = build_int_2 (0, 0);
- TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
- layout_type (TREE_TYPE (null_pointer_node));
+ List of actual args is transformed into corresponding gcc backend list. */
- string_type_node = build_pointer_type (char_type_node);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_list_expr (ffebld expr)
+{
+ tree list;
+ tree *plist = &list;
+ tree trail = NULL_TREE; /* Append char length args here. */
+ tree *ptrail = &trail;
+ tree length;
- ffecom_tree_fun_type_void
- = build_function_type (void_type_node, NULL_TREE);
+ while (expr != NULL)
+ {
+ tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
- ffecom_tree_ptr_to_fun_type_void
- = build_pointer_type (ffecom_tree_fun_type_void);
+ if (texpr == error_mark_node)
+ return error_mark_node;
- endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
+ *plist = build_tree_list (NULL_TREE, texpr);
+ plist = &TREE_CHAIN (*plist);
+ expr = ffebld_trail (expr);
+ if (length != NULL_TREE)
+ {
+ *ptrail = build_tree_list (NULL_TREE, length);
+ ptrail = &TREE_CHAIN (*ptrail);
+ }
+ }
- float_ftype_float
- = build_function_type (float_type_node,
- tree_cons (NULL_TREE, float_type_node, endlink));
+ *plist = trail;
- double_ftype_double
- = build_function_type (double_type_node,
- tree_cons (NULL_TREE, double_type_node, endlink));
+ return list;
+}
- ldouble_ftype_ldouble
- = build_function_type (long_double_type_node,
- tree_cons (NULL_TREE, long_double_type_node,
- endlink));
+#endif
+/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- ffecom_tree_type[i][j] = NULL_TREE;
- ffecom_tree_fun_type[i][j] = NULL_TREE;
- ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
- ffecom_f2c_typecode_[i][j] = -1;
- }
+ tree t;
+ ffebld expr; // FFE opITEM list.
+ tree = ffecom_list_ptr_to_expr(expr);
- /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
- to size FLOAT_TYPE_SIZE because they have to be the same size as
- REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
- Compiler options and other such stuff that change the ways these
- types are set should not affect this particular setup. */
+ List of actual args is transformed into corresponding gcc backend list for
+ use in calling an external procedure (vs. a statement function). */
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
- = t = make_signed_type (FLOAT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger1));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_list_ptr_to_expr (ffebld expr)
+{
+ tree list;
+ tree *plist = &list;
+ tree trail = NULL_TREE; /* Append char length args here. */
+ tree *ptrail = &trail;
+ tree length;
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
- = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
- t));
+ while (expr != NULL)
+ {
+ tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
- = t = make_signed_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 3, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger2));
+ if (texpr == error_mark_node)
+ return error_mark_node;
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
- = t = make_unsigned_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
- t));
+ *plist = build_tree_list (NULL_TREE, texpr);
+ plist = &TREE_CHAIN (*plist);
+ expr = ffebld_trail (expr);
+ if (length != NULL_TREE)
+ {
+ *ptrail = build_tree_list (NULL_TREE, length);
+ ptrail = &TREE_CHAIN (*ptrail);
+ }
+ }
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
- = t = make_signed_type (CHAR_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 6, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger3));
+ *plist = trail;
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
- = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
- t));
+ return list;
+}
- ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
- = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- assert (ffetype_size (type) == sizeof (ffetargetInteger4));
+#endif
+/* Obtain gcc's LABEL_DECL tree for label. */
- ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
- = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
- t));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_lookup_label (ffelab label)
+{
+ tree glabel;
-#if 0
- if (ffe_is_do_internal_checks ()
- && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
- && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
- && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
- && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
+ if (ffelab_hook (label) == NULL_TREE)
{
- fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
- LONG_TYPE_SIZE);
- }
-#endif
+ char labelname[16];
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
- = t = make_signed_type (FLOAT_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical1));
+ switch (ffelab_type (label))
+ {
+ case FFELAB_typeLOOPEND:
+ case FFELAB_typeNOTLOOP:
+ case FFELAB_typeENDIF:
+ sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
+ glabel = build_decl (LABEL_DECL, get_identifier (labelname),
+ void_type_node);
+ DECL_CONTEXT (glabel) = current_function_decl;
+ DECL_MODE (glabel) = VOIDmode;
+ break;
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
- = t = make_signed_type (CHAR_TYPE_SIZE);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 3, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical2));
+ case FFELAB_typeFORMAT:
+ glabel = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier
+ ("__g77_format_%d", (int) ffelab_value (label)),
+ build_type_variant (build_array_type
+ (char_type_node,
+ NULL_TREE),
+ 1, 0));
+ TREE_CONSTANT (glabel) = 1;
+ TREE_STATIC (glabel) = 1;
+ DECL_CONTEXT (glabel) = current_function_decl;
+ DECL_INITIAL (glabel) = NULL;
+ make_decl_rtl (glabel, NULL);
+ expand_decl (glabel);
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
- = t = make_signed_type (CHAR_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 6, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical3));
+ ffecom_save_tree_forever (glabel);
- ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
- = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- assert (ffetype_size (type) == sizeof (ffetargetLogical4));
+ break;
- ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
- = t = make_node (REAL_TYPE);
- TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
- pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
- t));
- layout_type (t);
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
- = FFETARGET_f2cTYREAL;
- assert (ffetype_size (type) == sizeof (ffetargetReal1));
+ case FFELAB_typeANY:
+ glabel = error_mark_node;
+ break;
- ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
- = t = make_node (REAL_TYPE);
- TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
- t));
- layout_type (t);
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
- = FFETARGET_f2cTYDREAL;
- assert (ffetype_size (type) == sizeof (ffetargetReal2));
+ default:
+ assert ("bad label type" == NULL);
+ glabel = NULL;
+ break;
+ }
+ ffelab_set_hook (label, glabel);
+ }
+ else
+ {
+ glabel = ffelab_hook (label);
+ }
- ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
- = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
- t));
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 1, type);
- ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
- = FFETARGET_f2cTYCOMPLEX;
- assert (ffetype_size (type) == sizeof (ffetargetComplex1));
+ return glabel;
+}
- ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
- = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
- pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
- t));
- type = ffetype_new ();
- ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_star (base_type,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
- type);
- ffetype_set_kind (base_type, 2,
- type);
- ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
- = FFETARGET_f2cTYDCOMPLEX;
- assert (ffetype_size (type) == sizeof (ffetargetComplex2));
+#endif
+/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
+ a single source specification (as in the fourth argument of MVBITS).
+ If the type is NULL_TREE, the type of lhs is used to make the type of
+ the MODIFY_EXPR. */
- /* Make function and ptr-to-function types for non-CHARACTER types. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_modify (tree newtype, tree lhs,
+ tree rhs)
+{
+ if (lhs == error_mark_node || rhs == error_mark_node)
+ return error_mark_node;
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
- {
- if (i == FFEINFO_basictypeINTEGER)
- {
- /* Figure out the smallest INTEGER type that can hold
- a pointer on this machine. */
- if (GET_MODE_SIZE (TYPE_MODE (t))
- >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
- {
- if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
- || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
- > GET_MODE_SIZE (TYPE_MODE (t))))
- ffecom_pointer_kind_ = j;
- }
- }
- else if (i == FFEINFO_basictypeCOMPLEX)
- t = void_type_node;
- /* For f2c compatibility, REAL functions are really
- implemented as DOUBLE PRECISION. */
- else if ((i == FFEINFO_basictypeREAL)
- && (j == FFEINFO_kindtypeREAL1))
- t = ffecom_tree_type
- [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
+ if (newtype == NULL_TREE)
+ newtype = TREE_TYPE (lhs);
- t = ffecom_tree_fun_type[i][j] = build_function_type (t,
- NULL_TREE);
- ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
- }
- }
+ if (TREE_SIDE_EFFECTS (lhs))
+ lhs = stabilize_reference (lhs);
- /* Set up pointer types. */
+ return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
+}
- if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
- fatal ("no INTEGER type can hold a pointer on this configuration");
- else if (0 && ffe_is_do_internal_checks ())
- fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
- type = ffetype_new ();
- ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGERDEFAULT),
- 7, type);
+#endif
- if (ffe_is_ugly_assign ())
- ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
- else
- ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
- if (0 && ffe_is_do_internal_checks ())
- fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
+/* Register source file name. */
- ffecom_integer_type_node
- = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
- ffecom_integer_zero_node = convert (ffecom_integer_type_node,
- integer_zero_node);
- ffecom_integer_one_node = convert (ffecom_integer_type_node,
- integer_one_node);
+void
+ffecom_file (const char *name)
+{
+#if FFECOM_GCC_INCLUDE
+ ffecom_file_ (name);
+#endif
+}
- /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
- Turns out that by TYLONG, runtime/libI77/lio.h really means
- "whatever size an ftnint is". For consistency and sanity,
- com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
- all are INTEGER, which we also make out of whatever back-end
- integer type is FLOAT_TYPE_SIZE bits wide. This change, from
- LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
- accommodate machines like the Alpha. Note that this suggests
- f2c and libf2c are missing a distinction perhaps needed on
- some machines between "int" and "long int". -- burley 0.5.5 950215 */
+/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
- FFETARGET_f2cTYLONG);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
- FFETARGET_f2cTYSHORT);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
- FFETARGET_f2cTYINT1);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
- FFETARGET_f2cTYQUAD);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
- FFETARGET_f2cTYLOGICAL);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
- FFETARGET_f2cTYLOGICAL2);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
- FFETARGET_f2cTYLOGICAL1);
- ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
- FFETARGET_f2cTYQUAD /* ~~~ */);
+ ffestorag st;
+ ffecom_notify_init_storage(st);
- /* CHARACTER stuff is all special-cased, so it is not handled in the above
- loop. CHARACTER items are built as arrays of unsigned char. */
+ Gets called when all possible units in an aggregate storage area (a LOCAL
+ with equivalences or a COMMON) have been initialized. The initialization
+ info either is in ffestorag_init or, if that is NULL,
+ ffestorag_accretion:
- ffecom_tree_type[FFEINFO_basictypeCHARACTER]
- [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
- type = ffetype_new ();
- base_type = type;
- ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER1,
- type);
- ffetype_set_ams (type,
- TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
- TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
- ffetype_set_kind (base_type, 1, type);
- assert (ffetype_size (type)
- == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
+ ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
+ even for an array if the array is one element in length!
- ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
- [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
- ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
- [FFEINFO_kindtypeCHARACTER1]
- = ffecom_tree_ptr_to_fun_type_void;
- ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
- = FFETARGET_f2cTYCHAR;
+ ffestorag_accretion will contain an opACCTER. It is much like an
+ opARRTER except it has an ffebit object in it instead of just a size.
+ The back end can use the info in the ffebit object, if it wants, to
+ reduce the amount of actual initialization, but in any case it should
+ kill the ffebit object when done. Also, set accretion to NULL but
+ init to a non-NULL value.
- ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
- = 0;
+ After performing initialization, DO NOT set init to NULL, because that'll
+ tell the front end it is ok for more initialization to happen. Instead,
+ set init to an opANY expression or some such thing that you can use to
+ tell that you've already initialized the object.
- /* Make multi-return-value type and fields. */
+ 27-Oct-91 JCB 1.1
+ Support two-pass FFE. */
- ffecom_multi_type_node_ = make_node (UNION_TYPE);
+void
+ffecom_notify_init_storage (ffestorag st)
+{
+ ffebld init; /* The initialization expression. */
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffetargetOffset size; /* The size of the entity. */
+ ffetargetAlign pad; /* Its initial padding. */
+#endif
- field = NULL_TREE;
+ if (ffestorag_init (st) == NULL)
+ {
+ init = ffestorag_accretion (st);
+ assert (init != NULL);
+ ffestorag_set_accretion (st, NULL);
+ ffestorag_set_accretes (st, 0);
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- char name[30];
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
+ size = ffebld_accter_size (init);
+ pad = ffebld_accter_pad (init);
+ ffebit_kill (ffebld_accter_bits (init));
+ ffebld_set_op (init, FFEBLD_opARRTER);
+ ffebld_set_arrter (init, ffebld_accter (init));
+ ffebld_arrter_set_size (init, size);
+ ffebld_arrter_set_pad (init, size);
+#endif
- if (ffecom_tree_type[i][j] == NULL_TREE)
- continue; /* Not supported. */
- sprintf (&name[0], "bt_%s_kt_%s",
- ffeinfo_basictype_string ((ffeinfoBasictype) i),
- ffeinfo_kindtype_string ((ffeinfoKindtype) j));
- ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
- get_identifier (name),
- ffecom_tree_type[i][j]);
- DECL_CONTEXT (ffecom_multi_fields_[i][j])
- = ffecom_multi_type_node_;
- DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
- TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
- field = ffecom_multi_fields_[i][j];
- }
+#if FFECOM_TWOPASS
+ ffestorag_set_init (st, init);
+#endif
+ }
+#if FFECOM_ONEPASS
+ else
+ init = ffestorag_init (st);
+#endif
- TYPE_FIELDS (ffecom_multi_type_node_) = field;
- layout_type (ffecom_multi_type_node_);
+#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
+ ffestorag_set_init (st, ffebld_new_any ());
- /* Subroutines usually return integer because they might have alternate
- returns. */
+ if (ffebld_op (init) == FFEBLD_opANY)
+ return; /* Oh, we already did this! */
- ffecom_tree_subr_type
- = build_function_type (integer_type_node, NULL_TREE);
- ffecom_tree_ptr_to_subr_type
- = build_pointer_type (ffecom_tree_subr_type);
- ffecom_tree_blockdata_type
- = build_function_type (void_type_node, NULL_TREE);
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ {
+ ffesymbol s;
- builtin_function ("__builtin_sqrtf", float_ftype_float,
- BUILT_IN_FSQRT, "sqrtf");
- builtin_function ("__builtin_fsqrt", double_ftype_double,
- BUILT_IN_FSQRT, "sqrt");
- builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
- BUILT_IN_FSQRT, "sqrtl");
- builtin_function ("__builtin_sinf", float_ftype_float,
- BUILT_IN_SIN, "sinf");
- builtin_function ("__builtin_sin", double_ftype_double,
- BUILT_IN_SIN, "sin");
- builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
- BUILT_IN_SIN, "sinl");
- builtin_function ("__builtin_cosf", float_ftype_float,
- BUILT_IN_COS, "cosf");
- builtin_function ("__builtin_cos", double_ftype_double,
- BUILT_IN_COS, "cos");
- builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
- BUILT_IN_COS, "cosl");
+ if (ffestorag_symbol (st) != NULL)
+ s = ffestorag_symbol (st);
+ else
+ s = ffestorag_typesymbol (st);
-#if BUILT_FOR_270
- pedantic_lvalues = FALSE;
+ fprintf (dmpout, "= initialize_storage \"%s\" ",
+ (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
+ ffebld_dump (init);
+ fputc ('\n', dmpout);
+ }
#endif
- ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
- FFECOM_f2cINTEGER,
- "integer");
- ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
- FFECOM_f2cADDRESS,
- "address");
- ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
- FFECOM_f2cREAL,
- "real");
- ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
- FFECOM_f2cDOUBLEREAL,
- "doublereal");
- ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
- FFECOM_f2cCOMPLEX,
- "complex");
- ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
- FFECOM_f2cDOUBLECOMPLEX,
- "doublecomplex");
- ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
- FFECOM_f2cLONGINT,
- "longint");
- ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
- FFECOM_f2cLOGICAL,
- "logical");
- ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
- FFECOM_f2cFLAG,
- "flag");
- ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
- FFECOM_f2cFTNLEN,
- "ftnlen");
- ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
- FFECOM_f2cFTNINT,
- "ftnint");
-
- ffecom_f2c_ftnlen_zero_node
- = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
+#endif /* if FFECOM_ONEPASS */
+}
- ffecom_f2c_ftnlen_one_node
- = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
+/* ffecom_notify_init_symbol -- A symbol is now fully init'ed
- ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
- TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
+ ffesymbol s;
+ ffecom_notify_init_symbol(s);
- ffecom_f2c_ptr_to_ftnlen_type_node
- = build_pointer_type (ffecom_f2c_ftnlen_type_node);
+ Gets called when all possible units in a symbol (not placed in COMMON
+ or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
+ have been initialized. The initialization info either is in
+ ffesymbol_init or, if that is NULL, ffesymbol_accretion:
- ffecom_f2c_ptr_to_ftnint_type_node
- = build_pointer_type (ffecom_f2c_ftnint_type_node);
+ ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
+ even for an array if the array is one element in length!
- ffecom_f2c_ptr_to_integer_type_node
- = build_pointer_type (ffecom_f2c_integer_type_node);
+ ffesymbol_accretion will contain an opACCTER. It is much like an
+ opARRTER except it has an ffebit object in it instead of just a size.
+ The back end can use the info in the ffebit object, if it wants, to
+ reduce the amount of actual initialization, but in any case it should
+ kill the ffebit object when done. Also, set accretion to NULL but
+ init to a non-NULL value.
- ffecom_f2c_ptr_to_real_type_node
- = build_pointer_type (ffecom_f2c_real_type_node);
+ After performing initialization, DO NOT set init to NULL, because that'll
+ tell the front end it is ok for more initialization to happen. Instead,
+ set init to an opANY expression or some such thing that you can use to
+ tell that you've already initialized the object.
- ffecom_float_zero_ = build_real (float_type_node, dconst0);
- ffecom_double_zero_ = build_real (double_type_node, dconst0);
- {
- REAL_VALUE_TYPE point_5;
+ 27-Oct-91 JCB 1.1
+ Support two-pass FFE. */
-#ifdef REAL_ARITHMETIC
- REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
-#else
- point_5 = .5;
+void
+ffecom_notify_init_symbol (ffesymbol s)
+{
+ ffebld init; /* The initialization expression. */
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ ffetargetOffset size; /* The size of the entity. */
+ ffetargetAlign pad; /* Its initial padding. */
#endif
- ffecom_float_half_ = build_real (float_type_node, point_5);
- ffecom_double_half_ = build_real (double_type_node, point_5);
- }
-
- /* Do "extern int xargc;". */
- ffecom_tree_xargc_ = build_decl (VAR_DECL,
- get_identifier ("xargc"),
- integer_type_node);
- DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
- TREE_STATIC (ffecom_tree_xargc_) = 1;
- TREE_PUBLIC (ffecom_tree_xargc_) = 1;
- ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
- finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
+ if (ffesymbol_storage (s) == NULL)
+ return; /* Do nothing until COMMON/EQUIVALENCE
+ possibilities checked. */
-#if 0 /* This is being fixed, and seems to be working now. */
- if ((FLOAT_TYPE_SIZE != 32)
- || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
+ if ((ffesymbol_init (s) == NULL)
+ && ((init = ffesymbol_accretion (s)) != NULL))
{
- warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
- (int) FLOAT_TYPE_SIZE);
- warning ("and pointers are %d bits wide, but g77 doesn't yet work",
- (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
- warning ("properly unless they all are 32 bits wide.");
- warning ("Please keep this in mind before you report bugs. g77 should");
- warning ("support non-32-bit machines better as of version 0.6.");
- }
-#endif
+ ffesymbol_set_accretion (s, NULL);
+ ffesymbol_set_accretes (s, 0);
-#if 0 /* Code in ste.c that would crash has been commented out. */
- if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
- < TYPE_PRECISION (string_type_node))
- /* I/O will probably crash. */
- warning ("configuration: char * holds %d bits, but ftnlen only %d",
- TYPE_PRECISION (string_type_node),
- TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
+#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
+ /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
+ size = ffebld_accter_size (init);
+ pad = ffebld_accter_pad (init);
+ ffebit_kill (ffebld_accter_bits (init));
+ ffebld_set_op (init, FFEBLD_opARRTER);
+ ffebld_set_arrter (init, ffebld_accter (init));
+ ffebld_arrter_set_size (init, size);
+ ffebld_arrter_set_pad (init, size);
#endif
-#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
- if (TYPE_PRECISION (ffecom_integer_type_node)
- < TYPE_PRECISION (string_type_node))
- /* ASSIGN 10 TO I will crash. */
- warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
- ASSIGN statement might fail",
- TYPE_PRECISION (string_type_node),
- TYPE_PRECISION (ffecom_integer_type_node));
+#if FFECOM_TWOPASS
+ ffesymbol_set_init (s, init);
#endif
-}
-
+ }
+#if FFECOM_ONEPASS
+ else
+ init = ffesymbol_init (s);
#endif
-/* ffecom_init_2 -- Initialize
- ffecom_init_2(); */
+#if FFECOM_ONEPASS
+ ffesymbol_set_init (s, ffebld_new_any ());
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_init_2 ()
-{
- assert (ffecom_outer_function_decl_ == NULL_TREE);
- assert (current_function_decl == NULL_TREE);
- assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
+ if (ffebld_op (init) == FFEBLD_opANY)
+ return; /* Oh, we already did this! */
- ffecom_master_arglist_ = NULL;
- ++ffecom_num_fns_;
- ffecom_latest_temp_ = NULL;
- ffecom_primary_entry_ = NULL;
- ffecom_is_altreturning_ = FALSE;
- ffecom_func_result_ = NULL_TREE;
- ffecom_multi_retval_ = NULL_TREE;
+#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
+ ffebld_dump (init);
+ fputc ('\n', dmpout);
+#endif
+
+#endif /* if FFECOM_ONEPASS */
}
-#endif
-/* ffecom_list_expr -- Transform list of exprs into gcc tree
+/* ffecom_notify_primary_entry -- Learn which is the primary entry point
- tree t;
- ffebld expr; // FFE opITEM list.
- tree = ffecom_list_expr(expr);
+ ffesymbol s;
+ ffecom_notify_primary_entry(s);
- List of actual args is transformed into corresponding gcc backend list. */
+ Gets called when implicit or explicit PROGRAM statement seen or when
+ FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
+ global symbol that serves as the entry point. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_list_expr (ffebld expr)
+void
+ffecom_notify_primary_entry (ffesymbol s)
{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
+ ffecom_primary_entry_ = s;
+ ffecom_primary_entry_kind_ = ffesymbol_kind (s);
- while (expr != NULL)
+ if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
+ || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
+ ffecom_primary_entry_is_proc_ = TRUE;
+ else
+ ffecom_primary_entry_is_proc_ = FALSE;
+
+ if (!ffe_is_silent ())
{
- *plist
- = build_tree_list (NULL_TREE, ffecom_arg_expr (ffebld_head (expr),
- &length));
- plist = &TREE_CHAIN (*plist);
- expr = ffebld_trail (expr);
- if (length != NULL_TREE)
- {
- *ptrail = build_tree_list (NULL_TREE, length);
- ptrail = &TREE_CHAIN (*ptrail);
- }
+ if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
+ fprintf (stderr, "%s:\n", ffesymbol_text (s));
+ else
+ fprintf (stderr, " %s:\n", ffesymbol_text (s));
}
- *plist = trail;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
+ {
+ ffebld list;
+ ffebld arg;
- return list;
+ for (list = ffesymbol_dummyargs (s);
+ list != NULL;
+ list = ffebld_trail (list))
+ {
+ arg = ffebld_head (list);
+ if (ffebld_op (arg) == FFEBLD_opSTAR)
+ {
+ ffecom_is_altreturning_ = TRUE;
+ break;
+ }
+ }
+ }
+#endif
}
+FILE *
+ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
+{
+#if FFECOM_GCC_INCLUDE
+ return ffecom_open_include_ (name, l, c);
+#else
+ return fopen (name, "r");
#endif
-/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
+}
+
+/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
tree t;
- ffebld expr; // FFE opITEM list.
- tree = ffecom_list_ptr_to_expr(expr);
+ ffebld expr; // FFE expression.
+ tree = ffecom_ptr_to_expr(expr);
- List of actual args is transformed into corresponding gcc backend list for
- use in calling an external procedure (vs. a statement function). */
+ Like ffecom_expr, but sticks address-of in front of most things. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_list_ptr_to_expr (ffebld expr)
+ffecom_ptr_to_expr (ffebld expr)
{
- tree list;
- tree *plist = &list;
- tree trail = NULL_TREE; /* Append char length args here. */
- tree *ptrail = &trail;
- tree length;
+ tree item;
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffesymbol s;
- while (expr != NULL)
+ assert (expr != NULL);
+
+ switch (ffebld_op (expr))
{
- *plist
- = build_tree_list (NULL_TREE,
- ffecom_arg_ptr_to_expr (ffebld_head (expr),
- &length));
- plist = &TREE_CHAIN (*plist);
- expr = ffebld_trail (expr);
- if (length != NULL_TREE)
+ case FFEBLD_opSYMTER:
+ s = ffebld_symter (expr);
+ if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
{
- *ptrail = build_tree_list (NULL_TREE, length);
- ptrail = &TREE_CHAIN (*ptrail);
- }
- }
-
- *plist = trail;
-
- return list;
-}
-
-#endif
-/* Obtain gcc's LABEL_DECL tree for label. */
+ ffecomGfrt ix;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_lookup_label (ffelab label)
-{
- tree glabel;
+ ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
+ assert (ix != FFECOM_gfrt);
+ if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
+ {
+ ffecom_make_gfrt_ (ix);
+ item = ffecom_gfrt_[ix];
+ }
+ }
+ else
+ {
+ item = ffesymbol_hook (s).decl_tree;
+ if (item == NULL_TREE)
+ {
+ s = ffecom_sym_transform_ (s);
+ item = ffesymbol_hook (s).decl_tree;
+ }
+ }
+ assert (item != NULL);
+ if (item == error_mark_node)
+ return item;
+ if (!ffesymbol_hook (s).addr)
+ item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
+ item);
+ return item;
- if (ffelab_hook (label) == NULL_TREE)
- {
- char labelname[16];
+ case FFEBLD_opARRAYREF:
+ return ffecom_arrayref_ (NULL_TREE, expr, 1);
- switch (ffelab_type (label))
- {
- case FFELAB_typeLOOPEND:
- case FFELAB_typeNOTLOOP:
- case FFELAB_typeENDIF:
- sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
- glabel = build_decl (LABEL_DECL, get_identifier (labelname),
- void_type_node);
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_MODE (glabel) = VOIDmode;
- break;
+ case FFEBLD_opCONTER:
- case FFELAB_typeFORMAT:
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
- glabel = build_decl (VAR_DECL,
- ffecom_get_invented_identifier
- ("__g77_format_%d", NULL,
- (int) ffelab_value (label)),
- build_type_variant (build_array_type
- (char_type_node,
- NULL_TREE),
- 1, 0));
- TREE_CONSTANT (glabel) = 1;
- TREE_STATIC (glabel) = 1;
- DECL_CONTEXT (glabel) = 0;
- DECL_INITIAL (glabel) = NULL;
- make_decl_rtl (glabel, NULL, 0);
- expand_decl (glabel);
+ item = ffecom_constantunion (&ffebld_constant_union
+ (ffebld_conter (expr)), bt, kt,
+ ffecom_tree_type[bt][kt]);
+ if (item == error_mark_node)
+ return error_mark_node;
+ item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
+ item);
+ return item;
- resume_temporary_allocation ();
- pop_obstacks ();
+ case FFEBLD_opANY:
+ return error_mark_node;
- break;
+ default:
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
- case FFELAB_typeANY:
- glabel = error_mark_node;
- break;
+ item = ffecom_expr (expr);
+ if (item == error_mark_node)
+ return error_mark_node;
- default:
- assert ("bad label type" == NULL);
- glabel = NULL;
- break;
+ /* The back end currently optimizes a bit too zealously for us, in that
+ we fail JCB001 if the following block of code is omitted. It checks
+ to see if the transformed expression is a symbol or array reference,
+ and encloses it in a SAVE_EXPR if that is the case. */
+
+ STRIP_NOPS (item);
+ if ((TREE_CODE (item) == VAR_DECL)
+ || (TREE_CODE (item) == PARM_DECL)
+ || (TREE_CODE (item) == RESULT_DECL)
+ || (TREE_CODE (item) == INDIRECT_REF)
+ || (TREE_CODE (item) == ARRAY_REF)
+ || (TREE_CODE (item) == COMPONENT_REF)
+#ifdef OFFSET_REF
+ || (TREE_CODE (item) == OFFSET_REF)
+#endif
+ || (TREE_CODE (item) == BUFFER_REF)
+ || (TREE_CODE (item) == REALPART_EXPR)
+ || (TREE_CODE (item) == IMAGPART_EXPR))
+ {
+ item = ffecom_save_tree (item);
}
- ffelab_set_hook (label, glabel);
- }
- else
- {
- glabel = ffelab_hook (label);
+
+ item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
+ item);
+ return item;
}
- return glabel;
+ assert ("fall-through error" == NULL);
+ return error_mark_node;
}
#endif
-/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
- a single source specification (as in the fourth argument of MVBITS).
- If the type is NULL_TREE, the type of lhs is used to make the type of
- the MODIFY_EXPR. */
+/* Obtain a temp var with given data type.
+
+ size is FFETARGET_charactersizeNONE for a non-CHARACTER type
+ or >= 0 for a CHARACTER type.
+
+ elements is -1 for a scalar or > 0 for an array of type. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_modify (tree newtype, tree lhs,
- tree rhs)
+ffecom_make_tempvar (const char *commentary, tree type,
+ ffetargetCharacterSize size, int elements)
{
- if (lhs == error_mark_node || rhs == error_mark_node)
+ tree t;
+ static int mynumber;
+
+ assert (current_binding_level->prep_state < 2);
+
+ if (type == error_mark_node)
return error_mark_node;
- if (newtype == NULL_TREE)
- newtype = TREE_TYPE (lhs);
+ if (size != FFETARGET_charactersizeNONE)
+ type = build_array_type (type,
+ build_range_type (ffecom_f2c_ftnlen_type_node,
+ ffecom_f2c_ftnlen_one_node,
+ build_int_2 (size, 0)));
+ if (elements != -1)
+ type = build_array_type (type,
+ build_range_type (integer_type_node,
+ integer_zero_node,
+ build_int_2 (elements - 1,
+ 0)));
+ t = build_decl (VAR_DECL,
+ ffecom_get_invented_identifier ("__g77_%s_%d",
+ commentary,
+ mynumber++),
+ type);
- if (TREE_SIDE_EFFECTS (lhs))
- lhs = stabilize_reference (lhs);
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
+ return t;
}
-
#endif
-/* Register source file name. */
+/* Prepare argument pointer to expression.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_arg_ptr_to_expr. */
void
-ffecom_file (char *name)
+ffecom_prepare_arg_ptr_to_expr (ffebld expr)
{
-#if FFECOM_GCC_INCLUDE
- ffecom_file_ (name);
-#endif
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
}
-/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
+/* End of preparations. */
- ffestorag st;
- ffecom_notify_init_storage(st);
+bool
+ffecom_prepare_end (void)
+{
+ int prep_state = current_binding_level->prep_state;
- Gets called when all possible units in an aggregate storage area (a LOCAL
- with equivalences or a COMMON) have been initialized. The initialization
- info either is in ffestorag_init or, if that is NULL,
- ffestorag_accretion:
+ assert (prep_state < 2);
+ current_binding_level->prep_state = 2;
- ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
- even for an array if the array is one element in length!
+ return (prep_state == 1) ? TRUE : FALSE;
+}
- ffestorag_accretion will contain an opACCTER. It is much like an
- opARRTER except it has an ffebit object in it instead of just a size.
- The back end can use the info in the ffebit object, if it wants, to
- reduce the amount of actual initialization, but in any case it should
- kill the ffebit object when done. Also, set accretion to NULL but
- init to a non-NULL value.
+/* Prepare expression.
- After performing initialization, DO NOT set init to NULL, because that'll
- tell the front end it is ok for more initialization to happen. Instead,
- set init to an opANY expression or some such thing that you can use to
- tell that you've already initialized the object.
+ This is called before any code is generated for the current block.
+ It scans the expression, declares any temporaries that might be needed
+ during evaluation of the expression, and stores those temporaries in
+ the appropriate "hook" fields of the expression. `dest', if not NULL,
+ specifies the destination that ffecom_expr_ will see, in case that
+ helps avoid generating unused temporaries.
- 27-Oct-91 JCB 1.1
- Support two-pass FFE. */
+ ~~Improve to avoid allocating unused temporaries by taking `dest'
+ into account vis-a-vis aliasing requirements of complex/character
+ functions. */
void
-ffecom_notify_init_storage (ffestorag st)
+ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
{
- ffebld init; /* The initialization expression. */
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- ffetargetOffset size; /* The size of the entity. */
-#endif
-
- if (ffestorag_init (st) == NULL)
- {
- init = ffestorag_accretion (st);
- assert (init != NULL);
- ffestorag_set_accretion (st, NULL);
- ffestorag_set_accretes (st, 0);
-
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
- size = ffebld_accter_size (init);
- ffebit_kill (ffebld_accter_bits (init));
- ffebld_set_op (init, FFEBLD_opARRTER);
- ffebld_set_arrter (init, ffebld_accter (init));
- ffebld_arrter_set_size (init, size);
-#endif
-
-#if FFECOM_TWOPASS
- ffestorag_set_init (st, init);
-#endif
- }
-#if FFECOM_ONEPASS
- else
- init = ffestorag_init (st);
-#endif
-
-#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
- ffestorag_set_init (st, ffebld_new_any ());
-
- if (ffebld_op (init) == FFEBLD_opANY)
- return; /* Oh, we already did this! */
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffetargetCharacterSize sz;
+ tree tempvar = NULL_TREE;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- {
- ffesymbol s;
+ assert (current_binding_level->prep_state < 2);
- if (ffestorag_symbol (st) != NULL)
- s = ffestorag_symbol (st);
- else
- s = ffestorag_typesymbol (st);
+ if (! expr)
+ return;
- fprintf (dmpout, "= initialize_storage \"%s\" ",
- (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
- ffebld_dump (init);
- fputc ('\n', dmpout);
- }
-#endif
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+ sz = ffeinfo_size (ffebld_info (expr));
-#endif /* if FFECOM_ONEPASS */
-}
+ /* Generate whatever temporaries are needed to represent the result
+ of the expression. */
-/* ffecom_notify_init_symbol -- A symbol is now fully init'ed
+ if (bt == FFEINFO_basictypeCHARACTER)
+ {
+ while (ffebld_op (expr) == FFEBLD_opPAREN)
+ expr = ffebld_left (expr);
+ }
- ffesymbol s;
- ffecom_notify_init_symbol(s);
+ switch (ffebld_op (expr))
+ {
+ default:
+ /* Don't make temps for SYMTER, CONTER, etc. */
+ if (ffebld_arity (expr) == 0)
+ break;
- Gets called when all possible units in a symbol (not placed in COMMON
- or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
- have been initialized. The initialization info either is in
- ffesymbol_init or, if that is NULL, ffesymbol_accretion:
+ switch (bt)
+ {
+ case FFEINFO_basictypeCOMPLEX:
+ if (ffebld_op (expr) == FFEBLD_opFUNCREF)
+ {
+ ffesymbol s;
- ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
- even for an array if the array is one element in length!
+ if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
+ break;
- ffesymbol_accretion will contain an opACCTER. It is much like an
- opARRTER except it has an ffebit object in it instead of just a size.
- The back end can use the info in the ffebit object, if it wants, to
- reduce the amount of actual initialization, but in any case it should
- kill the ffebit object when done. Also, set accretion to NULL but
- init to a non-NULL value.
+ s = ffebld_symter (ffebld_left (expr));
+ if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
+ || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
+ && ! ffesymbol_is_f2c (s))
+ || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
+ && ! ffe_is_f2c_library ()))
+ break;
+ }
+ else if (ffebld_op (expr) == FFEBLD_opPOWER)
+ {
+ /* Requires special treatment. There's no POW_CC function
+ in libg2c, so POW_ZZ is used, which means we always
+ need a double-complex temp, not a single-complex. */
+ kt = FFEINFO_kindtypeREAL2;
+ }
+ else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
+ /* The other ops don't need temps for complex operands. */
+ break;
- After performing initialization, DO NOT set init to NULL, because that'll
- tell the front end it is ok for more initialization to happen. Instead,
- set init to an opANY expression or some such thing that you can use to
- tell that you've already initialized the object.
+ /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
+ REAL(C). See 19990325-0.f, routine `check', for cases. */
+ tempvar = ffecom_make_tempvar ("complex",
+ ffecom_tree_type
+ [FFEINFO_basictypeCOMPLEX][kt],
+ FFETARGET_charactersizeNONE,
+ -1);
+ break;
- 27-Oct-91 JCB 1.1
- Support two-pass FFE. */
+ case FFEINFO_basictypeCHARACTER:
+ if (ffebld_op (expr) != FFEBLD_opFUNCREF)
+ break;
-void
-ffecom_notify_init_symbol (ffesymbol s)
-{
- ffebld init; /* The initialization expression. */
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- ffetargetOffset size; /* The size of the entity. */
-#endif
+ if (sz == FFETARGET_charactersizeNONE)
+ /* ~~Kludge alert! This should someday be fixed. */
+ sz = 24;
- if (ffesymbol_storage (s) == NULL)
- return; /* Do nothing until COMMON/EQUIVALENCE
- possibilities checked. */
+ tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
+ break;
- if ((ffesymbol_init (s) == NULL)
- && ((init = ffesymbol_accretion (s)) != NULL))
- {
- ffesymbol_set_accretion (s, NULL);
- ffesymbol_set_accretes (s, 0);
+ default:
+ break;
+ }
+ break;
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
- size = ffebld_accter_size (init);
- ffebit_kill (ffebld_accter_bits (init));
- ffebld_set_op (init, FFEBLD_opARRTER);
- ffebld_set_arrter (init, ffebld_accter (init));
- ffebld_arrter_set_size (init, size);
-#endif
+#ifdef HAHA
+ case FFEBLD_opPOWER:
+ {
+ tree rtype, ltype;
+ tree rtmp, ltmp, result;
-#if FFECOM_TWOPASS
- ffesymbol_set_init (s, init);
-#endif
- }
-#if FFECOM_ONEPASS
- else
- init = ffesymbol_init (s);
-#endif
+ ltype = ffecom_type_expr (ffebld_left (expr));
+ rtype = ffecom_type_expr (ffebld_right (expr));
-#if FFECOM_ONEPASS
- ffesymbol_set_init (s, ffebld_new_any ());
+ rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
+ ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
+ result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
- if (ffebld_op (init) == FFEBLD_opANY)
- return; /* Oh, we already did this! */
+ tempvar = make_tree_vec (3);
+ TREE_VEC_ELT (tempvar, 0) = rtmp;
+ TREE_VEC_ELT (tempvar, 1) = ltmp;
+ TREE_VEC_ELT (tempvar, 2) = result;
+ }
+ break;
+#endif /* HAHA */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
- ffebld_dump (init);
- fputc ('\n', dmpout);
-#endif
+ case FFEBLD_opCONCATENATE:
+ {
+ /* This gets special handling, because only one set of temps
+ is needed for a tree of these -- the tree is treated as
+ a flattened list of concatenations when generating code. */
-#endif /* if FFECOM_ONEPASS */
-}
+ ffecomConcatList_ catlist;
+ tree ltmp, itmp, result;
+ int count;
+ int i;
-/* ffecom_notify_primary_entry -- Learn which is the primary entry point
+ catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
+ count = ffecom_concat_list_count_ (catlist);
- ffesymbol s;
- ffecom_notify_primary_entry(s);
+ if (count >= 2)
+ {
+ ltmp
+ = ffecom_make_tempvar ("concat_len",
+ ffecom_f2c_ftnlen_type_node,
+ FFETARGET_charactersizeNONE, count);
+ itmp
+ = ffecom_make_tempvar ("concat_item",
+ ffecom_f2c_address_type_node,
+ FFETARGET_charactersizeNONE, count);
+ result
+ = ffecom_make_tempvar ("concat_res",
+ char_type_node,
+ ffecom_concat_list_maxlen_ (catlist),
+ -1);
+
+ tempvar = make_tree_vec (3);
+ TREE_VEC_ELT (tempvar, 0) = ltmp;
+ TREE_VEC_ELT (tempvar, 1) = itmp;
+ TREE_VEC_ELT (tempvar, 2) = result;
+ }
- Gets called when implicit or explicit PROGRAM statement seen or when
- FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
- global symbol that serves as the entry point. */
+ for (i = 0; i < count; ++i)
+ ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
+ i));
-void
-ffecom_notify_primary_entry (ffesymbol s)
-{
- ffecom_primary_entry_ = s;
- ffecom_primary_entry_kind_ = ffesymbol_kind (s);
+ ffecom_concat_list_kill_ (catlist);
- if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
- || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
- ffecom_primary_entry_is_proc_ = TRUE;
- else
- ffecom_primary_entry_is_proc_ = FALSE;
+ if (tempvar)
+ {
+ ffebld_nonter_set_hook (expr, tempvar);
+ current_binding_level->prep_state = 1;
+ }
+ }
+ return;
- if (!ffe_is_silent ())
+ case FFEBLD_opCONVERT:
+ if (bt == FFEINFO_basictypeCHARACTER
+ && ((ffebld_size_known (ffebld_left (expr))
+ == FFETARGET_charactersizeNONE)
+ || (ffebld_size_known (ffebld_left (expr)) >= sz)))
+ tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
+ break;
+ }
+
+ if (tempvar)
{
- if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
- fprintf (stderr, "%s:\n", ffesymbol_text (s));
- else
- fprintf (stderr, " %s:\n", ffesymbol_text (s));
+ ffebld_nonter_set_hook (expr, tempvar);
+ current_binding_level->prep_state = 1;
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
+ /* Prepare subexpressions for this expr. */
+
+ switch (ffebld_op (expr))
{
- ffebld list;
- ffebld arg;
+ case FFEBLD_opPERCENT_LOC:
+ ffecom_prepare_ptr_to_expr (ffebld_left (expr));
+ break;
- for (list = ffesymbol_dummyargs (s);
- list != NULL;
- list = ffebld_trail (list))
+ case FFEBLD_opPERCENT_VAL:
+ case FFEBLD_opPERCENT_REF:
+ ffecom_prepare_expr (ffebld_left (expr));
+ break;
+
+ case FFEBLD_opPERCENT_DESCR:
+ ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
+ break;
+
+ case FFEBLD_opITEM:
+ {
+ ffebld item;
+
+ for (item = expr;
+ item != NULL;
+ item = ffebld_trail (item))
+ if (ffebld_head (item) != NULL)
+ ffecom_prepare_expr (ffebld_head (item));
+ }
+ break;
+
+ default:
+ /* Need to handle character conversion specially. */
+ switch (ffebld_arity (expr))
{
- arg = ffebld_head (list);
- if (ffebld_op (arg) == FFEBLD_opSTAR)
- {
- ffecom_is_altreturning_ = TRUE;
- break;
- }
+ case 2:
+ ffecom_prepare_expr (ffebld_left (expr));
+ ffecom_prepare_expr (ffebld_right (expr));
+ break;
+
+ case 1:
+ ffecom_prepare_expr (ffebld_left (expr));
+ break;
+
+ default:
+ break;
}
}
-#endif
+
+ return;
}
-FILE *
-ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
+/* Prepare expression for reading and writing.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_expr_rw. */
+
+void
+ffecom_prepare_expr_rw (tree type, ffebld expr)
{
-#if FFECOM_GCC_INCLUDE
- return ffecom_open_include_ (name, l, c);
-#else
- return fopen (name, "r");
-#endif
+ /* This is all we support for now. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
+
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
}
-/* Clean up after making automatically popped call-arg temps.
+/* Prepare expression for writing.
- Call this in pairs with push_calltemps around calls to
- ffecom_arg_ptr_to_expr if the latter might use temporaries.
- Any temporaries made within the outermost sequence of
- push_calltemps and pop_calltemps, that are marked as "auto-pop"
- meaning they won't be explicitly popped (freed), are popped
- at this point so they can be reused later.
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_expr_w. */
- NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
- should come in == 1, and all of the in-use auto-pop temps
- should have DECL_CONTEXT (temp->t) == current_function_decl.
- Moreover, these temps should _never_ be re-used in future
- calls to ffecom_push_tempvar -- since current_function_decl will
- never be the same again.
+void
+ffecom_prepare_expr_w (tree type, ffebld expr)
+{
+ /* This is all we support for now. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
- SO, it could be a minor win in terms of compile time to just
- strip these temps off the list. That is, if the above assumptions
- are correct, just remove from the list of temps any temp
- that is both in-use and has DECL_CONTEXT (temp->t)
- == current_function_decl, when called from ffecom_gen_sfuncdef_. */
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
+}
+
+/* Prepare expression for returning.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_return_expr. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
-ffecom_pop_calltemps ()
+ffecom_prepare_return_expr (ffebld expr)
{
- ffecomTemp_ temp;
+ assert (current_binding_level->prep_state < 2);
- assert (ffecom_pending_calls_ > 0);
-
- if (--ffecom_pending_calls_ == 0)
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
- if (temp->auto_pop)
- temp->in_use = FALSE;
+ if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
+ && ffecom_is_altreturning_
+ && expr != NULL)
+ ffecom_prepare_expr (expr);
}
-#endif
-/* Mark latest temp with given tree as no longer in use. */
+/* Prepare pointer to expression.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_ptr_to_expr. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
-ffecom_pop_tempvar (tree t)
+ffecom_prepare_ptr_to_expr (ffebld expr)
+{
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
+}
+
+/* Transform expression into constant pointer-to-expression tree.
+
+ If the expression can be transformed into a pointer-to-expression tree
+ that is constant, that is done, and the tree returned. Else NULL_TREE
+ is returned.
+
+ That way, a caller can attempt to provide compile-time initialization
+ of a variable and, if that fails, *then* choose to start a new block
+ and resort to using temporaries, as appropriate. */
+
+tree
+ffecom_ptr_to_const_expr (ffebld expr)
{
- ffecomTemp_ temp;
+ if (! expr)
+ return integer_zero_node;
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
- if (temp->in_use && (temp->t == t))
- {
- assert (!temp->auto_pop);
- temp->in_use = FALSE;
- return;
- }
- else
- assert (temp->t != t);
+ if (ffebld_op (expr) == FFEBLD_opANY)
+ return error_mark_node;
+
+ if (ffebld_arity (expr) == 0
+ && (ffebld_op (expr) != FFEBLD_opSYMTER
+ || ffebld_where (expr) == FFEINFO_whereCOMMON
+ || ffebld_where (expr) == FFEINFO_whereGLOBAL
+ || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
+ {
+ tree t;
+
+ t = ffecom_ptr_to_expr (expr);
+ assert (TREE_CONSTANT (t));
+ return t;
+ }
- assert ("couldn't ffecom_pop_tempvar!" != NULL);
+ return NULL_TREE;
}
-#endif
-/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
+/* ffecom_return_expr -- Returns return-value expr given alt return expr
- tree t;
- ffebld expr; // FFE expression.
- tree = ffecom_ptr_to_expr(expr);
+ tree rtn; // NULL_TREE means use expand_null_return()
+ ffebld expr; // NULL if no alt return expr to RETURN stmt
+ rtn = ffecom_return_expr(expr);
- Like ffecom_expr, but sticks address-of in front of most things. */
+ Based on the program unit type and other info (like return function
+ type, return master function type when alternate ENTRY points,
+ whether subroutine has any alternate RETURN points, etc), returns the
+ appropriate expression to be returned to the caller, or NULL_TREE
+ meaning no return value or the caller expects it to be returned somewhere
+ else (which is handled by other parts of this module). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_ptr_to_expr (ffebld expr)
+ffecom_return_expr (ffebld expr)
{
- tree item;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffesymbol s;
-
- assert (expr != NULL);
+ tree rtn;
- switch (ffebld_op (expr))
+ switch (ffecom_primary_entry_kind_)
{
- case FFEBLD_opSYMTER:
- s = ffebld_symter (expr);
- if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
- {
- ffecomGfrt ix;
+ case FFEINFO_kindPROGRAM:
+ case FFEINFO_kindBLOCKDATA:
+ rtn = NULL_TREE;
+ break;
- ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
- assert (ix != FFECOM_gfrt);
- if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
- {
- ffecom_make_gfrt_ (ix);
- item = ffecom_gfrt_[ix];
- }
- }
+ case FFEINFO_kindSUBROUTINE:
+ if (!ffecom_is_altreturning_)
+ rtn = NULL_TREE; /* No alt returns, never an expr. */
+ else if (expr == NULL)
+ rtn = integer_zero_node;
else
+ rtn = ffecom_expr (expr);
+ break;
+
+ case FFEINFO_kindFUNCTION:
+ if ((ffecom_multi_retval_ != NULL_TREE)
+ || (ffesymbol_basictype (ffecom_primary_entry_)
+ == FFEINFO_basictypeCHARACTER)
+ || ((ffesymbol_basictype (ffecom_primary_entry_)
+ == FFEINFO_basictypeCOMPLEX)
+ && (ffecom_num_entrypoints_ == 0)
+ && ffesymbol_is_f2c (ffecom_primary_entry_)))
+ { /* Value is returned by direct assignment
+ into (implicit) dummy. */
+ rtn = NULL_TREE;
+ break;
+ }
+ rtn = ffecom_func_result_;
+#if 0
+ /* Spurious error if RETURN happens before first reference! So elide
+ this code. In particular, for debugging registry, rtn should always
+ be non-null after all, but TREE_USED won't be set until we encounter
+ a reference in the code. Perfectly okay (but weird) code that,
+ e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
+ this diagnostic for no reason. Have people use -O -Wuninitialized
+ and leave it to the back end to find obviously weird cases. */
+
+ /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
+ situation; if the return value has never been referenced, it won't
+ have a tree under 2pass mode. */
+ if ((rtn == NULL_TREE)
+ || !TREE_USED (rtn))
{
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
+ ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
+ ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
+ ffesymbol_where_column (ffecom_primary_entry_));
+ ffebad_string (ffesymbol_text (ffesymbol_funcresult
+ (ffecom_primary_entry_)));
+ ffebad_finish ();
}
- assert (item != NULL);
- if (item == error_mark_node)
- return item;
- if (!ffesymbol_hook (s).addr)
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
+#endif
+ break;
- case FFEBLD_opARRAYREF:
- {
- ffebld dims[FFECOM_dimensionsMAX];
- tree array;
- int i;
+ default:
+ assert ("bad unit kind" == NULL);
+ case FFEINFO_kindANY:
+ rtn = error_mark_node;
+ break;
+ }
+
+ return rtn;
+}
+
+#endif
+/* Do save_expr only if tree is not error_mark_node. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_save_tree (tree t)
+{
+ return save_expr (t);
+}
+#endif
- item = ffecom_ptr_to_expr (ffebld_left (expr));
+/* Start a compound statement (block). */
- if (item == error_mark_node)
- return item;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_start_compstmt (void)
+{
+ bison_rule_pushlevel_ ();
+}
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
- if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
- && !mark_addressable (item))
- return error_mark_node; /* Make sure non-const ref is to
- non-reg. */
+/* Public entry point for front end to access start_decl. */
- /* Build up ARRAY_REFs in reverse order (since we're column major
- here in Fortran land). */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_start_decl (tree decl, bool is_initialized)
+{
+ DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
+ return start_decl (decl, FALSE);
+}
- for (i = 0, expr = ffebld_right (expr);
- expr != NULL;
- expr = ffebld_trail (expr))
- dims[i++] = ffebld_head (expr);
+#endif
+/* ffecom_sym_commit -- Symbol's state being committed to reality
- for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
- i >= 0;
- --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
- {
- item
- = ffecom_2 (PLUS_EXPR,
- build_pointer_type (TREE_TYPE (array)),
- item,
- size_binop (MULT_EXPR,
- size_in_bytes (TREE_TYPE (array)),
- convert (sizetype,
- fold (build (MINUS_EXPR,
- TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
- ffecom_expr (dims[i]),
- TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
- }
- }
- return item;
+ ffesymbol s;
+ ffecom_sym_commit(s);
- case FFEBLD_opCONTER:
+ Does whatever the backend needs when a symbol is committed after having
+ been backtrackable for a period of time. */
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_sym_commit (ffesymbol s UNUSED)
+{
+ assert (!ffesymbol_retractable ());
+}
- item = ffecom_constantunion (&ffebld_constant_union
- (ffebld_conter (expr)), bt, kt,
- ffecom_tree_type[bt][kt]);
- if (item == error_mark_node)
- return error_mark_node;
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
+#endif
+/* ffecom_sym_end_transition -- Perform end transition on all symbols
- case FFEBLD_opANY:
- return error_mark_node;
+ ffecom_sym_end_transition();
- default:
- assert (ffecom_pending_calls_ > 0);
+ Does backend-specific stuff and also calls ffest_sym_end_transition
+ to do the necessary FFE stuff.
- bt = ffeinfo_basictype (ffebld_info (expr));
- kt = ffeinfo_kindtype (ffebld_info (expr));
+ Backtracking is never enabled when this fn is called, so don't worry
+ about it. */
- item = ffecom_expr (expr);
- if (item == error_mark_node)
- return error_mark_node;
+ffesymbol
+ffecom_sym_end_transition (ffesymbol s)
+{
+ ffestorag st;
- /* The back end currently optimizes a bit too zealously for us, in that
- we fail JCB001 if the following block of code is omitted. It checks
- to see if the transformed expression is a symbol or array reference,
- and encloses it in a SAVE_EXPR if that is the case. */
+ assert (!ffesymbol_retractable ());
- STRIP_NOPS (item);
- if ((TREE_CODE (item) == VAR_DECL)
- || (TREE_CODE (item) == PARM_DECL)
- || (TREE_CODE (item) == RESULT_DECL)
- || (TREE_CODE (item) == INDIRECT_REF)
- || (TREE_CODE (item) == ARRAY_REF)
- || (TREE_CODE (item) == COMPONENT_REF)
-#ifdef OFFSET_REF
- || (TREE_CODE (item) == OFFSET_REF)
+ s = ffest_sym_end_transition (s);
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
+ && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
+ {
+ ffecom_list_blockdata_
+ = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
+ FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE),
+ ffecom_list_blockdata_);
+ }
#endif
- || (TREE_CODE (item) == BUFFER_REF)
- || (TREE_CODE (item) == REALPART_EXPR)
- || (TREE_CODE (item) == IMAGPART_EXPR))
- {
- item = ffecom_save_tree (item);
- }
- item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
- item);
- return item;
+ /* This is where we finally notice that a symbol has partial initialization
+ and finalize it. */
+
+ if (ffesymbol_accretion (s) != NULL)
+ {
+ assert (ffesymbol_init (s) == NULL);
+ ffecom_notify_init_symbol (s);
+ }
+ else if (((st = ffesymbol_storage (s)) != NULL)
+ && ((st = ffestorag_parent (st)) != NULL)
+ && (ffestorag_accretion (st) != NULL))
+ {
+ assert (ffestorag_init (st) == NULL);
+ ffecom_notify_init_storage (st);
}
- assert ("fall-through error" == NULL);
- return error_mark_node;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
+ && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
+ && (ffesymbol_storage (s) != NULL))
+ {
+ ffecom_list_common_
+ = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
+ FFEINTRIN_specNONE,
+ FFEINTRIN_impNONE),
+ ffecom_list_common_);
+ }
+#endif
+
+ return s;
}
-#endif
-/* Prepare to make call-arg temps.
+/* ffecom_sym_exec_transition -- Perform exec transition on all symbols
- Call this in pairs with pop_calltemps around calls to
- ffecom_arg_ptr_to_expr if the latter might use temporaries. */
+ ffecom_sym_exec_transition();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_push_calltemps ()
+ Does backend-specific stuff and also calls ffest_sym_exec_transition
+ to do the necessary FFE stuff.
+
+ See the long-winded description in ffecom_sym_learned for info
+ on handling the situation where backtracking is inhibited. */
+
+ffesymbol
+ffecom_sym_exec_transition (ffesymbol s)
{
- ffecom_pending_calls_++;
+ s = ffest_sym_exec_transition (s);
+
+ return s;
}
-#endif
-/* Obtain a temp var with given data type.
+/* ffecom_sym_learned -- Initial or more info gained on symbol after exec
- Returns a VAR_DECL tree of a currently (that is, at the current
- statement being compiled) not in use and having the given data type,
- making a new one if necessary. size is FFETARGET_charactersizeNONE
- for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is
- -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if
- ffecom_pop_tempvar won't be called, meaning temp will be freed
- when #pending calls goes to zero. */
+ ffesymbol s;
+ s = ffecom_sym_learned(s);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements,
- bool auto_pop)
+ Called when a new symbol is seen after the exec transition or when more
+ info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
+ it arrives here is that all its latest info is updated already, so its
+ state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
+ field filled in if its gone through here or exec_transition first, and
+ so on.
+
+ The backend probably wants to check ffesymbol_retractable() to see if
+ backtracking is in effect. If so, the FFE's changes to the symbol may
+ be retracted (undone) or committed (ratified), at which time the
+ appropriate ffecom_sym_retract or _commit function will be called
+ for that function.
+
+ If the backend has its own backtracking mechanism, great, use it so that
+ committal is a simple operation. Though it doesn't make much difference,
+ I suppose: the reason for tentative symbol evolution in the FFE is to
+ enable error detection in weird incorrect statements early and to disable
+ incorrect error detection on a correct statement. The backend is not
+ likely to introduce any information that'll get involved in these
+ considerations, so it is probably just fine that the implementation
+ model for this fn and for _exec_transition is to not do anything
+ (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
+ and instead wait until ffecom_sym_commit is called (which it never
+ will be as long as we're using ambiguity-detecting statement analysis in
+ the FFE, which we are initially to shake out the code, but don't depend
+ on this), otherwise go ahead and do whatever is needed.
+
+ In essence, then, when this fn and _exec_transition get called while
+ backtracking is enabled, a general mechanism would be to flag which (or
+ both) of these were called (and in what order? neat question as to what
+ might happen that I'm too lame to think through right now) and then when
+ _commit is called reproduce the original calling sequence, if any, for
+ the two fns (at which point backtracking will, of course, be disabled). */
+
+ffesymbol
+ffecom_sym_learned (ffesymbol s)
{
- ffecomTemp_ temp;
- int yes;
- tree t;
- static int mynumber;
+ ffestorag_exec_layout (s);
- assert (!auto_pop || (ffecom_pending_calls_ > 0));
+ return s;
+}
- if (type == error_mark_node)
- return error_mark_node;
+/* ffecom_sym_retract -- Symbol's state being retracted from reality
+
+ ffesymbol s;
+ ffecom_sym_retract(s);
+
+ Does whatever the backend needs when a symbol is retracted after having
+ been backtrackable for a period of time. */
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_sym_retract (ffesymbol s UNUSED)
+{
+ assert (!ffesymbol_retractable ());
+
+#if 0 /* GCC doesn't commit any backtrackable sins,
+ so nothing needed here. */
+ switch (ffesymbol_hook (s).state)
{
- if (temp->in_use
- || (temp->type != type)
- || (temp->size != size)
- || (temp->elements != elements)
- || (DECL_CONTEXT (temp->t) != current_function_decl))
- continue;
+ case 0: /* nothing happened yet. */
+ break;
- temp->in_use = TRUE;
- temp->auto_pop = auto_pop;
- return temp->t;
- }
+ case 1: /* exec transition happened. */
+ break;
- /* Create a new temp. */
+ case 2: /* learned happened. */
+ break;
- yes = suspend_momentary ();
+ case 3: /* learned then exec. */
+ break;
- if (size != FFETARGET_charactersizeNONE)
- type = build_array_type (type,
- build_range_type (ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- build_int_2 (size, 0)));
- if (elements != -1)
- type = build_array_type (type,
- build_range_type (integer_type_node,
- integer_zero_node,
- build_int_2 (elements - 1,
- 0)));
- t = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_expr_%d", NULL,
- mynumber++),
- type);
- { /* ~~~~ kludge alert here!!! else temp gets reused outside
- a compound-statement sequence.... */
- extern tree sequence_rtl_expr;
- tree back_end_bug = sequence_rtl_expr;
+ case 4: /* exec then learned. */
+ break;
- sequence_rtl_expr = NULL_TREE;
+ default:
+ assert ("bad hook state" == NULL);
+ break;
+ }
+#endif
+}
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+#endif
+/* Create temporary gcc label. */
- sequence_rtl_expr = back_end_bug;
- }
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_temp_label ()
+{
+ tree glabel;
+ static int mynumber = 0;
- resume_momentary (yes);
+ glabel = build_decl (LABEL_DECL,
+ ffecom_get_invented_identifier ("__g77_label_%d",
+ mynumber++),
+ void_type_node);
+ DECL_CONTEXT (glabel) = current_function_decl;
+ DECL_MODE (glabel) = VOIDmode;
- temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
- sizeof (*temp));
+ return glabel;
+}
- temp->next = ffecom_latest_temp_;
- temp->type = type;
- temp->t = t;
- temp->size = size;
- temp->elements = elements;
- temp->in_use = TRUE;
- temp->auto_pop = auto_pop;
+#endif
+/* Return an expression that is usable as an arg in a conditional context
+ (IF, DO WHILE, .NOT., and so on).
- ffecom_latest_temp_ = temp;
+ Use the one provided for the back end as of >2.6.0. */
- return t;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_truth_value (tree expr)
+{
+ return truthvalue_conversion (expr);
}
#endif
-/* ffecom_return_expr -- Returns return-value expr given alt return expr
-
- tree rtn; // NULL_TREE means use expand_null_return()
- ffebld expr; // NULL if no alt return expr to RETURN stmt
- rtn = ffecom_return_expr(expr);
+/* Return the inversion of a truth value (the inversion of what
+ ffecom_truth_value builds).
- Based on the program unit type and other info (like return function
- type, return master function type when alternate ENTRY points,
- whether subroutine has any alternate RETURN points, etc), returns the
- appropriate expression to be returned to the caller, or NULL_TREE
- meaning no return value or the caller expects it to be returned somewhere
- else (which is handled by other parts of this module). */
+ Apparently invert_truthvalue, which is properly in the back end, is
+ enough for now, so just use it. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_return_expr (ffebld expr)
+ffecom_truth_value_invert (tree expr)
{
- tree rtn;
+ return invert_truthvalue (ffecom_truth_value (expr));
+}
- switch (ffecom_primary_entry_kind_)
- {
- case FFEINFO_kindPROGRAM:
- case FFEINFO_kindBLOCKDATA:
- rtn = NULL_TREE;
- break;
+#endif
- case FFEINFO_kindSUBROUTINE:
- if (!ffecom_is_altreturning_)
- rtn = NULL_TREE; /* No alt returns, never an expr. */
- else if (expr == NULL)
- rtn = integer_zero_node;
- else
- rtn = ffecom_expr (expr);
- break;
+/* Return the tree that is the type of the expression, as would be
+ returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
+ transforming the expression, generating temporaries, etc. */
- case FFEINFO_kindFUNCTION:
- if ((ffecom_multi_retval_ != NULL_TREE)
- || (ffesymbol_basictype (ffecom_primary_entry_)
- == FFEINFO_basictypeCHARACTER)
- || ((ffesymbol_basictype (ffecom_primary_entry_)
- == FFEINFO_basictypeCOMPLEX)
- && (ffecom_num_entrypoints_ == 0)
- && ffesymbol_is_f2c (ffecom_primary_entry_)))
- { /* Value is returned by direct assignment
- into (implicit) dummy. */
- rtn = NULL_TREE;
- break;
- }
- rtn = ffecom_func_result_;
-#if 0
- /* Spurious error if RETURN happens before first reference! So elide
- this code. In particular, for debugging registry, rtn should always
- be non-null after all, but TREE_USED won't be set until we encounter
- a reference in the code. Perfectly okay (but weird) code that,
- e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
- this diagnostic for no reason. Have people use -O -Wuninitialized
- and leave it to the back end to find obviously weird cases. */
+tree
+ffecom_type_expr (ffebld expr)
+{
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ tree tree_type;
- /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
- situation; if the return value has never been referenced, it won't
- have a tree under 2pass mode. */
- if ((rtn == NULL_TREE)
- || !TREE_USED (rtn))
- {
- ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
- ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
- ffesymbol_where_column (ffecom_primary_entry_));
- ffebad_string (ffesymbol_text (ffesymbol_funcresult
- (ffecom_primary_entry_)));
- ffebad_finish ();
- }
-#endif
- break;
+ assert (expr != NULL);
+
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+ tree_type = ffecom_tree_type[bt][kt];
+
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opCONTER:
+ case FFEBLD_opSYMTER:
+ case FFEBLD_opARRAYREF:
+ case FFEBLD_opUPLUS:
+ case FFEBLD_opPAREN:
+ case FFEBLD_opUMINUS:
+ case FFEBLD_opADD:
+ case FFEBLD_opSUBTRACT:
+ case FFEBLD_opMULTIPLY:
+ case FFEBLD_opDIVIDE:
+ case FFEBLD_opPOWER:
+ case FFEBLD_opNOT:
+ case FFEBLD_opFUNCREF:
+ case FFEBLD_opSUBRREF:
+ case FFEBLD_opAND:
+ case FFEBLD_opOR:
+ case FFEBLD_opXOR:
+ case FFEBLD_opNEQV:
+ case FFEBLD_opEQV:
+ case FFEBLD_opCONVERT:
+ case FFEBLD_opLT:
+ case FFEBLD_opLE:
+ case FFEBLD_opEQ:
+ case FFEBLD_opNE:
+ case FFEBLD_opGT:
+ case FFEBLD_opGE:
+ case FFEBLD_opPERCENT_LOC:
+ return tree_type;
+ case FFEBLD_opACCTER:
+ case FFEBLD_opARRTER:
+ case FFEBLD_opITEM:
+ case FFEBLD_opSTAR:
+ case FFEBLD_opBOUNDS:
+ case FFEBLD_opREPEAT:
+ case FFEBLD_opLABTER:
+ case FFEBLD_opLABTOK:
+ case FFEBLD_opIMPDO:
+ case FFEBLD_opCONCATENATE:
+ case FFEBLD_opSUBSTR:
default:
- assert ("bad unit kind" == NULL);
- case FFEINFO_kindANY:
- rtn = error_mark_node;
- break;
+ assert ("bad op for ffecom_type_expr" == NULL);
+ /* Fall through. */
+ case FFEBLD_opANY:
+ return error_mark_node;
}
-
- return rtn;
}
-#endif
-/* Do save_expr only if tree is not error_mark_node. */
+/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
+
+ If the PARM_DECL already exists, return it, else create it. It's an
+ integer_type_node argument for the master function that implements a
+ subroutine or function with more than one entrypoint and is bound at
+ run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
+ first ENTRY statement, and so on). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_save_tree (tree t)
+ffecom_which_entrypoint_decl ()
{
- return save_expr (t);
+ assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
+
+ return ffecom_which_entrypoint_decl_;
}
+
#endif
+\f
+/* The following sections consists of private and public functions
+ that have the same names and perform roughly the same functions
+ as counterparts in the C front end. Changes in the C front end
+ might affect how things should be done here. Only functions
+ needed by the back end should be public here; the rest should
+ be private (static in the C sense). Functions needed by other
+ g77 front-end modules should be accessed by them via public
+ ffecom_* names, which should themselves call private versions
+ in this section so the private versions are easy to recognize
+ when upgrading to a new gcc and finding interesting changes
+ in the front end.
-/* Public entry point for front end to access start_decl. */
+ Functions named after rule "foo:" in c-parse.y are named
+ "bison_rule_foo_" so they are easy to find. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_start_decl (tree decl, bool is_initialized)
+
+static void
+bison_rule_pushlevel_ ()
{
- DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
- return start_decl (decl, FALSE);
+ emit_line_note (input_filename, lineno);
+ pushlevel (0);
+ clear_last_expr ();
+ expand_start_bindings (0);
}
-#endif
-/* ffecom_sym_commit -- Symbol's state being committed to reality
+static tree
+bison_rule_compstmt_ ()
+{
+ tree t;
+ int keep = kept_level_p ();
- ffesymbol s;
- ffecom_sym_commit(s);
+ /* Make the temps go away. */
+ if (! keep)
+ current_binding_level->names = NULL_TREE;
- Does whatever the backend needs when a symbol is committed after having
- been backtrackable for a period of time. */
+ emit_line_note (input_filename, lineno);
+ expand_end_bindings (getdecls (), keep, 0);
+ t = poplevel (keep, 1, 0);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_sym_commit (ffesymbol s UNUSED)
-{
- assert (!ffesymbol_retractable ());
+ return t;
}
-#endif
-/* ffecom_sym_end_transition -- Perform end transition on all symbols
+/* Return a definition for a builtin function named NAME and whose data type
+ is TYPE. TYPE should be a function type with argument types.
+ FUNCTION_CODE tells later passes how to compile calls to this function.
+ See tree.h for its possible values.
- ffecom_sym_end_transition();
+ If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
+ the name to be called if we can't opencode the function. */
- Does backend-specific stuff and also calls ffest_sym_end_transition
- to do the necessary FFE stuff.
+tree
+builtin_function (const char *name, tree type, int function_code,
+ enum built_in_class class,
+ const char *library_name)
+{
+ tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ DECL_EXTERNAL (decl) = 1;
+ TREE_PUBLIC (decl) = 1;
+ if (library_name)
+ DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
+ make_decl_rtl (decl, NULL_PTR);
+ pushdecl (decl);
+ DECL_BUILT_IN_CLASS (decl) = class;
+ DECL_FUNCTION_CODE (decl) = function_code;
- Backtracking is never enabled when this fn is called, so don't worry
- about it. */
+ return decl;
+}
-ffesymbol
-ffecom_sym_end_transition (ffesymbol s)
+/* Handle when a new declaration NEWDECL
+ has the same name as an old one OLDDECL
+ in the same binding contour.
+ Prints an error message if appropriate.
+
+ If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
+ Otherwise, return 0. */
+
+static int
+duplicate_decls (tree newdecl, tree olddecl)
{
- ffestorag st;
+ int types_match = 1;
+ int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
+ && DECL_INITIAL (newdecl) != 0);
+ tree oldtype = TREE_TYPE (olddecl);
+ tree newtype = TREE_TYPE (newdecl);
+
+ if (olddecl == newdecl)
+ return 1;
+
+ if (TREE_CODE (newtype) == ERROR_MARK
+ || TREE_CODE (oldtype) == ERROR_MARK)
+ types_match = 0;
+
+ /* New decl is completely inconsistent with the old one =>
+ tell caller to replace the old one.
+ This is always an error except in the case of shadowing a builtin. */
+ if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
+ return 0;
- assert (!ffesymbol_retractable ());
+ /* For real parm decl following a forward decl,
+ return 1 so old decl will be reused. */
+ if (types_match && TREE_CODE (newdecl) == PARM_DECL
+ && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
+ return 1;
- s = ffest_sym_end_transition (s);
+ /* The new declaration is the same kind of object as the old one.
+ The declarations may partially match. Print warnings if they don't
+ match enough. Ultimately, copy most of the information from the new
+ decl to the old one, and keep using the old one. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
- && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
+ if (TREE_CODE (olddecl) == FUNCTION_DECL
+ && DECL_BUILT_IN (olddecl))
{
- ffecom_list_blockdata_
- = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE),
- ffecom_list_blockdata_);
- }
-#endif
+ /* A function declaration for a built-in function. */
+ if (!TREE_PUBLIC (newdecl))
+ return 0;
+ else if (!types_match)
+ {
+ /* Accept the return type of the new declaration if same modes. */
+ tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
+ tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
- /* This is where we finally notice that a symbol has partial initialization
- and finalize it. */
+ if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
+ {
+ /* Function types may be shared, so we can't just modify
+ the return type of olddecl's function type. */
+ tree newtype
+ = build_function_type (newreturntype,
+ TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
- if (ffesymbol_accretion (s) != NULL)
- {
- assert (ffesymbol_init (s) == NULL);
- ffecom_notify_init_symbol (s);
- }
- else if (((st = ffesymbol_storage (s)) != NULL)
- && ((st = ffestorag_parent (st)) != NULL)
- && (ffestorag_accretion (st) != NULL))
- {
- assert (ffestorag_init (st) == NULL);
- ffecom_notify_init_storage (st);
+ types_match = 1;
+ if (types_match)
+ TREE_TYPE (olddecl) = newtype;
+ }
+ }
+ if (!types_match)
+ return 0;
}
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
- && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
- && (ffesymbol_storage (s) != NULL))
+ else if (TREE_CODE (olddecl) == FUNCTION_DECL
+ && DECL_SOURCE_LINE (olddecl) == 0)
{
- ffecom_list_common_
- = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
- FFEINTRIN_specNONE,
- FFEINTRIN_impNONE),
- ffecom_list_common_);
+ /* A function declaration for a predeclared function
+ that isn't actually built in. */
+ if (!TREE_PUBLIC (newdecl))
+ return 0;
+ else if (!types_match)
+ {
+ /* If the types don't match, preserve volatility indication.
+ Later on, we will discard everything else about the
+ default declaration. */
+ TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
+ }
}
-#endif
-
- return s;
-}
-
-/* ffecom_sym_exec_transition -- Perform exec transition on all symbols
-
- ffecom_sym_exec_transition();
-
- Does backend-specific stuff and also calls ffest_sym_exec_transition
- to do the necessary FFE stuff.
-
- See the long-winded description in ffecom_sym_learned for info
- on handling the situation where backtracking is inhibited. */
-ffesymbol
-ffecom_sym_exec_transition (ffesymbol s)
-{
- s = ffest_sym_exec_transition (s);
-
- return s;
-}
-
-/* ffecom_sym_learned -- Initial or more info gained on symbol after exec
+ /* Copy all the DECL_... slots specified in the new decl
+ except for any that we copy here from the old type.
- ffesymbol s;
- s = ffecom_sym_learned(s);
+ Past this point, we don't change OLDTYPE and NEWTYPE
+ even if we change the types of NEWDECL and OLDDECL. */
- Called when a new symbol is seen after the exec transition or when more
- info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
- it arrives here is that all its latest info is updated already, so its
- state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
- field filled in if its gone through here or exec_transition first, and
- so on.
+ if (types_match)
+ {
+ /* Merge the data types specified in the two decls. */
+ if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
+ TREE_TYPE (newdecl)
+ = TREE_TYPE (olddecl)
+ = TREE_TYPE (newdecl);
- The backend probably wants to check ffesymbol_retractable() to see if
- backtracking is in effect. If so, the FFE's changes to the symbol may
- be retracted (undone) or committed (ratified), at which time the
- appropriate ffecom_sym_retract or _commit function will be called
- for that function.
+ /* Lay the type out, unless already done. */
+ if (oldtype != TREE_TYPE (newdecl))
+ {
+ if (TREE_TYPE (newdecl) != error_mark_node)
+ layout_type (TREE_TYPE (newdecl));
+ if (TREE_CODE (newdecl) != FUNCTION_DECL
+ && TREE_CODE (newdecl) != TYPE_DECL
+ && TREE_CODE (newdecl) != CONST_DECL)
+ layout_decl (newdecl, 0);
+ }
+ else
+ {
+ /* Since the type is OLDDECL's, make OLDDECL's size go with. */
+ DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
+ DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
+ if (TREE_CODE (olddecl) != FUNCTION_DECL)
+ if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
+ {
+ DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
+ DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
+ }
+ }
- If the backend has its own backtracking mechanism, great, use it so that
- committal is a simple operation. Though it doesn't make much difference,
- I suppose: the reason for tentative symbol evolution in the FFE is to
- enable error detection in weird incorrect statements early and to disable
- incorrect error detection on a correct statement. The backend is not
- likely to introduce any information that'll get involved in these
- considerations, so it is probably just fine that the implementation
- model for this fn and for _exec_transition is to not do anything
- (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
- and instead wait until ffecom_sym_commit is called (which it never
- will be as long as we're using ambiguity-detecting statement analysis in
- the FFE, which we are initially to shake out the code, but don't depend
- on this), otherwise go ahead and do whatever is needed.
+ /* Keep the old rtl since we can safely use it. */
+ DECL_RTL (newdecl) = DECL_RTL (olddecl);
- In essence, then, when this fn and _exec_transition get called while
- backtracking is enabled, a general mechanism would be to flag which (or
- both) of these were called (and in what order? neat question as to what
- might happen that I'm too lame to think through right now) and then when
- _commit is called reproduce the original calling sequence, if any, for
- the two fns (at which point backtracking will, of course, be disabled). */
+ /* Merge the type qualifiers. */
+ if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
+ && !TREE_THIS_VOLATILE (newdecl))
+ TREE_THIS_VOLATILE (olddecl) = 0;
+ if (TREE_READONLY (newdecl))
+ TREE_READONLY (olddecl) = 1;
+ if (TREE_THIS_VOLATILE (newdecl))
+ {
+ TREE_THIS_VOLATILE (olddecl) = 1;
+ if (TREE_CODE (newdecl) == VAR_DECL)
+ make_var_volatile (newdecl);
+ }
-ffesymbol
-ffecom_sym_learned (ffesymbol s)
-{
- ffestorag_exec_layout (s);
+ /* Keep source location of definition rather than declaration.
+ Likewise, keep decl at outer scope. */
+ if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
+ || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
+ {
+ DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
+ DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
- return s;
-}
+ if (DECL_CONTEXT (olddecl) == 0
+ && TREE_CODE (newdecl) != FUNCTION_DECL)
+ DECL_CONTEXT (newdecl) = 0;
+ }
-/* ffecom_sym_retract -- Symbol's state being retracted from reality
+ /* Merge the unused-warning information. */
+ if (DECL_IN_SYSTEM_HEADER (olddecl))
+ DECL_IN_SYSTEM_HEADER (newdecl) = 1;
+ else if (DECL_IN_SYSTEM_HEADER (newdecl))
+ DECL_IN_SYSTEM_HEADER (olddecl) = 1;
- ffesymbol s;
- ffecom_sym_retract(s);
+ /* Merge the initialization information. */
+ if (DECL_INITIAL (newdecl) == 0)
+ DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
- Does whatever the backend needs when a symbol is retracted after having
- been backtrackable for a period of time. */
+ /* Merge the section attribute.
+ We want to issue an error if the sections conflict but that must be
+ done later in decl_attributes since we are called before attributes
+ are assigned. */
+ if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
+ DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_sym_retract (ffesymbol s UNUSED)
-{
- assert (!ffesymbol_retractable ());
+#if BUILT_FOR_270
+ if (TREE_CODE (newdecl) == FUNCTION_DECL)
+ {
+ DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
+ DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
+ }
+#endif
+ }
+ /* If cannot merge, then use the new type and qualifiers,
+ and don't preserve the old rtl. */
+ else
+ {
+ TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
+ TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
+ TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
+ TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
+ }
-#if 0 /* GCC doesn't commit any backtrackable sins,
- so nothing needed here. */
- switch (ffesymbol_hook (s).state)
+ /* Merge the storage class information. */
+ /* For functions, static overrides non-static. */
+ if (TREE_CODE (newdecl) == FUNCTION_DECL)
+ {
+ TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
+ /* This is since we don't automatically
+ copy the attributes of NEWDECL into OLDDECL. */
+ TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
+ /* If this clears `static', clear it in the identifier too. */
+ if (! TREE_PUBLIC (olddecl))
+ TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
+ }
+ if (DECL_EXTERNAL (newdecl))
+ {
+ TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
+ DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
+ /* An extern decl does not override previous storage class. */
+ TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
+ }
+ else
{
- case 0: /* nothing happened yet. */
- break;
-
- case 1: /* exec transition happened. */
- break;
+ TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
+ TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
+ }
- case 2: /* learned happened. */
- break;
+ /* If either decl says `inline', this fn is inline,
+ unless its definition was passed already. */
+ if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
+ DECL_INLINE (olddecl) = 1;
+ DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
- case 3: /* learned then exec. */
- break;
+ /* Get rid of any built-in function if new arg types don't match it
+ or if we have a function definition. */
+ if (TREE_CODE (newdecl) == FUNCTION_DECL
+ && DECL_BUILT_IN (olddecl)
+ && (!types_match || new_is_definition))
+ {
+ TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
+ DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
+ }
- case 4: /* exec then learned. */
- break;
+ /* If redeclaring a builtin function, and not a definition,
+ it stays built in.
+ Also preserve various other info from the definition. */
+ if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
+ {
+ if (DECL_BUILT_IN (olddecl))
+ {
+ DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
+ DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
+ }
+ else
+ DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
- default:
- assert ("bad hook state" == NULL);
- break;
+ DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
+ DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
+ DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
+ DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
}
-#endif
-}
-
-#endif
-/* Create temporary gcc label. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_temp_label ()
-{
- tree glabel;
- static int mynumber = 0;
+ /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
+ But preserve olddecl's DECL_UID. */
+ {
+ register unsigned olddecl_uid = DECL_UID (olddecl);
- glabel = build_decl (LABEL_DECL,
- ffecom_get_invented_identifier ("__g77_label_%d",
- NULL,
- mynumber++),
- void_type_node);
- DECL_CONTEXT (glabel) = current_function_decl;
- DECL_MODE (glabel) = VOIDmode;
+ memcpy ((char *) olddecl + sizeof (struct tree_common),
+ (char *) newdecl + sizeof (struct tree_common),
+ sizeof (struct tree_decl) - sizeof (struct tree_common));
+ DECL_UID (olddecl) = olddecl_uid;
+ }
- return glabel;
+ return 1;
}
-#endif
-/* Return an expression that is usable as an arg in a conditional context
- (IF, DO WHILE, .NOT., and so on).
-
- Use the one provided for the back end as of >2.6.0. */
+/* Finish processing of a declaration;
+ install its initial value.
+ If the length of an array type is not known before,
+ it must be determined now, from the initial value, or it is an error. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_truth_value (tree expr)
+static void
+finish_decl (tree decl, tree init, bool is_top_level)
{
- return truthvalue_conversion (expr);
-}
+ register tree type = TREE_TYPE (decl);
+ int was_incomplete = (DECL_SIZE (decl) == 0);
+ bool at_top_level = (current_binding_level == global_binding_level);
+ bool top_level = is_top_level || at_top_level;
-#endif
-/* Return the inversion of a truth value (the inversion of what
- ffecom_truth_value builds).
+ /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
+ level anyway. */
+ assert (!is_top_level || !at_top_level);
- Apparently invert_truthvalue, which is properly in the back end, is
- enough for now, so just use it. */
+ if (TREE_CODE (decl) == PARM_DECL)
+ assert (init == NULL_TREE);
+ /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
+ overlaps DECL_ARG_TYPE. */
+ else if (init == NULL_TREE)
+ assert (DECL_INITIAL (decl) == NULL_TREE);
+ else
+ assert (DECL_INITIAL (decl) == error_mark_node);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_truth_value_invert (tree expr)
-{
- return invert_truthvalue (ffecom_truth_value (expr));
-}
+ if (init != NULL_TREE)
+ {
+ if (TREE_CODE (decl) != TYPE_DECL)
+ DECL_INITIAL (decl) = init;
+ else
+ {
+ /* typedef foo = bar; store the type of bar as the type of foo. */
+ TREE_TYPE (decl) = TREE_TYPE (init);
+ DECL_INITIAL (decl) = init = 0;
+ }
+ }
-#endif
-/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
+ /* Deduce size of array from initialization, if not already known */
- If the PARM_DECL already exists, return it, else create it. It's an
- integer_type_node argument for the master function that implements a
- subroutine or function with more than one entrypoint and is bound at
- run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
- first ENTRY statement, and so on). */
+ if (TREE_CODE (type) == ARRAY_TYPE
+ && TYPE_DOMAIN (type) == 0
+ && TREE_CODE (decl) != TYPE_DECL)
+ {
+ assert (top_level);
+ assert (was_incomplete);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_which_entrypoint_decl ()
-{
- assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
+ layout_decl (decl, 0);
+ }
- return ffecom_which_entrypoint_decl_;
-}
+ if (TREE_CODE (decl) == VAR_DECL)
+ {
+ if (DECL_SIZE (decl) == NULL_TREE
+ && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
+ layout_decl (decl, 0);
-#endif
-\f
-/* The following sections consists of private and public functions
- that have the same names and perform roughly the same functions
- as counterparts in the C front end. Changes in the C front end
- might affect how things should be done here. Only functions
- needed by the back end should be public here; the rest should
- be private (static in the C sense). Functions needed by other
- g77 front-end modules should be accessed by them via public
- ffecom_* names, which should themselves call private versions
- in this section so the private versions are easy to recognize
- when upgrading to a new gcc and finding interesting changes
- in the front end.
+ if (DECL_SIZE (decl) == NULL_TREE
+ && (TREE_STATIC (decl)
+ ?
+ /* A static variable with an incomplete type is an error if it is
+ initialized. Also if it is not file scope. Otherwise, let it
+ through, but if it is not `extern' then it may cause an error
+ message later. */
+ (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
+ :
+ /* An automatic variable with an incomplete type is an error. */
+ !DECL_EXTERNAL (decl)))
+ {
+ assert ("storage size not known" == NULL);
+ abort ();
+ }
- Functions named after rule "foo:" in c-parse.y are named
- "bison_rule_foo_" so they are easy to find. */
+ if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
+ && (DECL_SIZE (decl) != 0)
+ && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
+ {
+ assert ("storage size not constant" == NULL);
+ abort ();
+ }
+ }
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ /* Output the assembler code and/or RTL code for variables and functions,
+ unless the type is an undefined structure or union. If not, it will get
+ done when the type is completed. */
-static void
-bison_rule_compstmt_ ()
-{
- emit_line_note (input_filename, lineno);
- expand_end_bindings (getdecls (), 1, 1);
- poplevel (1, 1, 0);
- pop_momentary ();
-}
+ if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
+ {
+ rest_of_decl_compilation (decl, NULL,
+ DECL_CONTEXT (decl) == 0,
+ 0);
-static void
-bison_rule_pushlevel_ ()
-{
- emit_line_note (input_filename, lineno);
- pushlevel (0);
- clear_last_expr ();
- push_momentary ();
- expand_start_bindings (0);
+ if (DECL_CONTEXT (decl) != 0)
+ {
+ /* Recompute the RTL of a local array now if it used to be an
+ incomplete type. */
+ if (was_incomplete
+ && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
+ {
+ /* If we used it already as memory, it must stay in memory. */
+ TREE_ADDRESSABLE (decl) = TREE_USED (decl);
+ /* If it's still incomplete now, no init will save it. */
+ if (DECL_SIZE (decl) == 0)
+ DECL_INITIAL (decl) = 0;
+ expand_decl (decl);
+ }
+ /* Compute and store the initial value. */
+ if (TREE_CODE (decl) != FUNCTION_DECL)
+ expand_decl_init (decl);
+ }
+ }
+ else if (TREE_CODE (decl) == TYPE_DECL)
+ {
+ rest_of_decl_compilation (decl, NULL_PTR,
+ DECL_CONTEXT (decl) == 0,
+ 0);
+ }
+
+ /* At the end of a declaration, throw away any variable type sizes of types
+ defined inside that declaration. There is no use computing them in the
+ following function definition. */
+ if (current_binding_level == global_binding_level)
+ get_pending_sizes ();
}
-/* Return a definition for a builtin function named NAME and whose data type
- is TYPE. TYPE should be a function type with argument types.
- FUNCTION_CODE tells later passes how to compile calls to this function.
- See tree.h for its possible values.
+/* Finish up a function declaration and compile that function
+ all the way to assembler language output. The free the storage
+ for the function definition.
- If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
- the name to be called if we can't opencode the function. */
+ This is called after parsing the body of the function definition.
-static tree
-builtin_function (char *name, tree type,
- enum built_in_function function_code, char *library_name)
+ NESTED is nonzero if the function being finished is nested in another. */
+
+static void
+finish_function (int nested)
{
- tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
- DECL_EXTERNAL (decl) = 1;
- TREE_PUBLIC (decl) = 1;
- if (library_name)
- DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
- make_decl_rtl (decl, NULL_PTR, 1);
- pushdecl (decl);
- if (function_code != NOT_BUILT_IN)
+ register tree fndecl = current_function_decl;
+
+ assert (fndecl != NULL_TREE);
+ if (TREE_CODE (fndecl) != ERROR_MARK)
{
- DECL_BUILT_IN (decl) = 1;
- DECL_FUNCTION_CODE (decl) = function_code;
+ if (nested)
+ assert (DECL_CONTEXT (fndecl) != NULL_TREE);
+ else
+ assert (DECL_CONTEXT (fndecl) == NULL_TREE);
}
- return decl;
-}
+/* TREE_READONLY (fndecl) = 1;
+ This caused &foo to be of type ptr-to-const-function
+ which then got a warning when stored in a ptr-to-function variable. */
-/* Handle when a new declaration NEWDECL
- has the same name as an old one OLDDECL
- in the same binding contour.
- Prints an error message if appropriate.
+ poplevel (1, 0, 1);
- If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
- Otherwise, return 0. */
+ if (TREE_CODE (fndecl) != ERROR_MARK)
+ {
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
-static int
-duplicate_decls (tree newdecl, tree olddecl)
-{
- int types_match = 1;
- int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
- && DECL_INITIAL (newdecl) != 0);
- tree oldtype = TREE_TYPE (olddecl);
- tree newtype = TREE_TYPE (newdecl);
+ /* Must mark the RESULT_DECL as being in this function. */
- if (olddecl == newdecl)
- return 1;
+ DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
- if (TREE_CODE (newtype) == ERROR_MARK
- || TREE_CODE (oldtype) == ERROR_MARK)
- types_match = 0;
+ /* Obey `register' declarations if `setjmp' is called in this fn. */
+ /* Generate rtl for function exit. */
+ expand_function_end (input_filename, lineno, 0);
- /* New decl is completely inconsistent with the old one =>
- tell caller to replace the old one.
- This is always an error except in the case of shadowing a builtin. */
- if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
- return 0;
+ /* If this is a nested function, protect the local variables in the stack
+ above us from being collected while we're compiling this function. */
+ if (nested)
+ ggc_push_context ();
- /* For real parm decl following a forward decl,
- return 1 so old decl will be reused. */
- if (types_match && TREE_CODE (newdecl) == PARM_DECL
- && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
- return 1;
+ /* Run the optimizers and output the assembler code for this function. */
+ rest_of_compilation (fndecl);
- /* The new declaration is the same kind of object as the old one.
- The declarations may partially match. Print warnings if they don't
- match enough. Ultimately, copy most of the information from the new
- decl to the old one, and keep using the old one. */
+ /* Undo the GC context switch. */
+ if (nested)
+ ggc_pop_context ();
+ }
- if (TREE_CODE (olddecl) == FUNCTION_DECL
- && DECL_BUILT_IN (olddecl))
+ if (TREE_CODE (fndecl) != ERROR_MARK
+ && !nested
+ && DECL_SAVED_INSNS (fndecl) == 0)
{
- /* A function declaration for a built-in function. */
- if (!TREE_PUBLIC (newdecl))
- return 0;
- else if (!types_match)
- {
- /* Accept the return type of the new declaration if same modes. */
- tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
- tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
+ /* Stop pointing to the local nodes about to be freed. */
+ /* But DECL_INITIAL must remain nonzero so we know this was an actual
+ function definition. */
+ /* For a nested function, this is done in pop_f_function_context. */
+ /* If rest_of_compilation set this to 0, leave it 0. */
+ if (DECL_INITIAL (fndecl) != 0)
+ DECL_INITIAL (fndecl) = error_mark_node;
+ DECL_ARGUMENTS (fndecl) = 0;
+ }
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the
- permanent one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
+ if (!nested)
+ {
+ /* Let the error reporting routines know that we're outside a function.
+ For a nested function, this value is used in pop_c_function_context
+ and then reset via pop_function_context. */
+ ffecom_outer_function_decl_ = current_function_decl = NULL;
+ }
+}
- if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
- {
- /* Function types may be shared, so we can't just modify
- the return type of olddecl's function type. */
- tree newtype
- = build_function_type (newreturntype,
- TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
+/* Plug-in replacement for identifying the name of a decl and, for a
+ function, what we call it in diagnostics. For now, "program unit"
+ should suffice, since it's a bit of a hassle to figure out which
+ of several kinds of things it is. Note that it could conceivably
+ be a statement function, which probably isn't really a program unit
+ per se, but if that comes up, it should be easy to check (being a
+ nested function and all). */
- types_match = 1;
- if (types_match)
- TREE_TYPE (olddecl) = newtype;
- }
+static const char *
+lang_printable_name (tree decl, int v)
+{
+ /* Just to keep GCC quiet about the unused variable.
+ In theory, differing values of V should produce different
+ output. */
+ switch (v)
+ {
+ default:
+ if (TREE_CODE (decl) == ERROR_MARK)
+ return "erroneous code";
+ return IDENTIFIER_POINTER (DECL_NAME (decl));
+ }
+}
- pop_obstacks ();
- }
- if (!types_match)
- return 0;
+/* g77's function to print out name of current function that caused
+ an error. */
+
+#if BUILT_FOR_270
+static void
+lang_print_error_function (const char *file)
+{
+ static ffeglobal last_g = NULL;
+ static ffesymbol last_s = NULL;
+ ffeglobal g;
+ ffesymbol s;
+ const char *kind;
+
+ if ((ffecom_primary_entry_ == NULL)
+ || (ffesymbol_global (ffecom_primary_entry_) == NULL))
+ {
+ g = NULL;
+ s = NULL;
+ kind = NULL;
}
- else if (TREE_CODE (olddecl) == FUNCTION_DECL
- && DECL_SOURCE_LINE (olddecl) == 0)
+ else
{
- /* A function declaration for a predeclared function
- that isn't actually built in. */
- if (!TREE_PUBLIC (newdecl))
- return 0;
- else if (!types_match)
+ g = ffesymbol_global (ffecom_primary_entry_);
+ if (ffecom_nested_entry_ == NULL)
{
- /* If the types don't match, preserve volatility indication.
- Later on, we will discard everything else about the
- default declaration. */
- TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
- }
- }
+ s = ffecom_primary_entry_;
+ switch (ffesymbol_kind (s))
+ {
+ case FFEINFO_kindFUNCTION:
+ kind = "function";
+ break;
- /* Copy all the DECL_... slots specified in the new decl
- except for any that we copy here from the old type.
+ case FFEINFO_kindSUBROUTINE:
+ kind = "subroutine";
+ break;
- Past this point, we don't change OLDTYPE and NEWTYPE
- even if we change the types of NEWDECL and OLDDECL. */
+ case FFEINFO_kindPROGRAM:
+ kind = "program";
+ break;
- if (types_match)
- {
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the permanent
- one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
+ case FFEINFO_kindBLOCKDATA:
+ kind = "block-data";
+ break;
+
+ default:
+ kind = ffeinfo_kind_message (ffesymbol_kind (s));
+ break;
+ }
+ }
else
{
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ s = ffecom_nested_entry_;
+ kind = "statement function";
}
+ }
- /* Merge the data types specified in the two decls. */
- if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
- TREE_TYPE (newdecl)
- = TREE_TYPE (olddecl)
- = TREE_TYPE (newdecl);
+ if ((last_g != g) || (last_s != s))
+ {
+ if (file)
+ fprintf (stderr, "%s: ", file);
- /* Lay the type out, unless already done. */
- if (oldtype != TREE_TYPE (newdecl))
- {
- if (TREE_TYPE (newdecl) != error_mark_node)
- layout_type (TREE_TYPE (newdecl));
- if (TREE_CODE (newdecl) != FUNCTION_DECL
- && TREE_CODE (newdecl) != TYPE_DECL
- && TREE_CODE (newdecl) != CONST_DECL)
- layout_decl (newdecl, 0);
- }
+ if (s == NULL)
+ fprintf (stderr, "Outside of any program unit:\n");
else
{
- /* Since the type is OLDDECL's, make OLDDECL's size go with. */
- DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
- if (TREE_CODE (olddecl) != FUNCTION_DECL)
- if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
- DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
+ const char *name = ffesymbol_text (s);
+
+ fprintf (stderr, "In %s `%s':\n", kind, name);
}
- /* Keep the old rtl since we can safely use it. */
- DECL_RTL (newdecl) = DECL_RTL (olddecl);
+ last_g = g;
+ last_s = s;
+ }
+}
+#endif
+
+/* Similar to `lookup_name' but look only at current binding level. */
+
+static tree
+lookup_name_current_level (tree name)
+{
+ register tree t;
+
+ if (current_binding_level == global_binding_level)
+ return IDENTIFIER_GLOBAL_VALUE (name);
+
+ if (IDENTIFIER_LOCAL_VALUE (name) == 0)
+ return 0;
+
+ for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
+ if (DECL_NAME (t) == name)
+ break;
+
+ return t;
+}
+
+/* Create a new `struct binding_level'. */
+
+static struct binding_level *
+make_binding_level ()
+{
+ /* NOSTRICT */
+ return (struct binding_level *) xmalloc (sizeof (struct binding_level));
+}
+
+/* Save and restore the variables in this file and elsewhere
+ that keep track of the progress of compilation of the current function.
+ Used for nested functions. */
+
+struct f_function
+{
+ struct f_function *next;
+ tree named_labels;
+ tree shadowed_labels;
+ struct binding_level *binding_level;
+};
+
+struct f_function *f_function_chain;
+
+/* Restore the variables used during compilation of a C function. */
+
+static void
+pop_f_function_context ()
+{
+ struct f_function *p = f_function_chain;
+ tree link;
+
+ /* Bring back all the labels that were shadowed. */
+ for (link = shadowed_labels; link; link = TREE_CHAIN (link))
+ if (DECL_NAME (TREE_VALUE (link)) != 0)
+ IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
+ = TREE_VALUE (link);
+
+ if (current_function_decl != error_mark_node
+ && DECL_SAVED_INSNS (current_function_decl) == 0)
+ {
+ /* Stop pointing to the local nodes about to be freed. */
+ /* But DECL_INITIAL must remain nonzero so we know this was an actual
+ function definition. */
+ DECL_INITIAL (current_function_decl) = error_mark_node;
+ DECL_ARGUMENTS (current_function_decl) = 0;
+ }
+
+ pop_function_context ();
- /* Merge the type qualifiers. */
- if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
- && !TREE_THIS_VOLATILE (newdecl))
- TREE_THIS_VOLATILE (olddecl) = 0;
- if (TREE_READONLY (newdecl))
- TREE_READONLY (olddecl) = 1;
- if (TREE_THIS_VOLATILE (newdecl))
- {
- TREE_THIS_VOLATILE (olddecl) = 1;
- if (TREE_CODE (newdecl) == VAR_DECL)
- make_var_volatile (newdecl);
- }
+ f_function_chain = p->next;
- /* Keep source location of definition rather than declaration.
- Likewise, keep decl at outer scope. */
- if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
- || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
- {
- DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
- DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
+ named_labels = p->named_labels;
+ shadowed_labels = p->shadowed_labels;
+ current_binding_level = p->binding_level;
- if (DECL_CONTEXT (olddecl) == 0
- && TREE_CODE (newdecl) != FUNCTION_DECL)
- DECL_CONTEXT (newdecl) = 0;
- }
+ free (p);
+}
- /* Merge the unused-warning information. */
- if (DECL_IN_SYSTEM_HEADER (olddecl))
- DECL_IN_SYSTEM_HEADER (newdecl) = 1;
- else if (DECL_IN_SYSTEM_HEADER (newdecl))
- DECL_IN_SYSTEM_HEADER (olddecl) = 1;
+/* Save and reinitialize the variables
+ used during compilation of a C function. */
- /* Merge the initialization information. */
- if (DECL_INITIAL (newdecl) == 0)
- DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
+static void
+push_f_function_context ()
+{
+ struct f_function *p
+ = (struct f_function *) xmalloc (sizeof (struct f_function));
- /* Merge the section attribute.
- We want to issue an error if the sections conflict but that must be
- done later in decl_attributes since we are called before attributes
- are assigned. */
- if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
- DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
+ push_function_context ();
-#if BUILT_FOR_270
- if (TREE_CODE (newdecl) == FUNCTION_DECL)
- {
- DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
- DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
- }
-#endif
+ p->next = f_function_chain;
+ f_function_chain = p;
- pop_obstacks ();
- }
- /* If cannot merge, then use the new type and qualifiers,
- and don't preserve the old rtl. */
- else
- {
- TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
- TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
- TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
- }
+ p->named_labels = named_labels;
+ p->shadowed_labels = shadowed_labels;
+ p->binding_level = current_binding_level;
+}
- /* Merge the storage class information. */
- /* For functions, static overrides non-static. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL)
- {
- TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
- /* This is since we don't automatically
- copy the attributes of NEWDECL into OLDDECL. */
- TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
- /* If this clears `static', clear it in the identifier too. */
- if (! TREE_PUBLIC (olddecl))
- TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
- }
- if (DECL_EXTERNAL (newdecl))
- {
- TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
- DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
- /* An extern decl does not override previous storage class. */
- TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
- }
- else
- {
- TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
- TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
- }
+static void
+push_parm_decl (tree parm)
+{
+ int old_immediate_size_expand = immediate_size_expand;
- /* If either decl says `inline', this fn is inline,
- unless its definition was passed already. */
- if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
- DECL_INLINE (olddecl) = 1;
- DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
+ /* Don't try computing parm sizes now -- wait till fn is called. */
- /* Get rid of any built-in function if new arg types don't match it
- or if we have a function definition. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL
- && DECL_BUILT_IN (olddecl)
- && (!types_match || new_is_definition))
- {
- TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- DECL_BUILT_IN (olddecl) = 0;
- }
+ immediate_size_expand = 0;
- /* If redeclaring a builtin function, and not a definition,
- it stays built in.
- Also preserve various other info from the definition. */
- if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
- {
- if (DECL_BUILT_IN (olddecl))
- {
- DECL_BUILT_IN (newdecl) = 1;
- DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
- }
- else
- DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
+ /* Fill in arg stuff. */
- DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
- DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
- DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
- DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
- }
+ DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
+ DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
+ TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
- /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
- But preserve olddecl's DECL_UID. */
- {
- register unsigned olddecl_uid = DECL_UID (olddecl);
+ parm = pushdecl (parm);
- memcpy ((char *) olddecl + sizeof (struct tree_common),
- (char *) newdecl + sizeof (struct tree_common),
- sizeof (struct tree_decl) - sizeof (struct tree_common));
- DECL_UID (olddecl) = olddecl_uid;
- }
+ immediate_size_expand = old_immediate_size_expand;
- return 1;
+ finish_decl (parm, NULL_TREE, FALSE);
}
-/* Finish processing of a declaration;
- install its initial value.
- If the length of an array type is not known before,
- it must be determined now, from the initial value, or it is an error. */
+/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
-static void
-finish_decl (tree decl, tree init, bool is_top_level)
+static tree
+pushdecl_top_level (x)
+ tree x;
{
- register tree type = TREE_TYPE (decl);
- int was_incomplete = (DECL_SIZE (decl) == 0);
- int temporary = allocation_temporary_p ();
- bool at_top_level = (current_binding_level == global_binding_level);
- bool top_level = is_top_level || at_top_level;
-
- /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
- level anyway. */
- assert (!is_top_level || !at_top_level);
+ register tree t;
+ register struct binding_level *b = current_binding_level;
+ register tree f = current_function_decl;
- if (TREE_CODE (decl) == PARM_DECL)
- assert (init == NULL_TREE);
- /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
- overlaps DECL_ARG_TYPE. */
- else if (init == NULL_TREE)
- assert (DECL_INITIAL (decl) == NULL_TREE);
- else
- assert (DECL_INITIAL (decl) == error_mark_node);
+ current_binding_level = global_binding_level;
+ current_function_decl = NULL_TREE;
+ t = pushdecl (x);
+ current_binding_level = b;
+ current_function_decl = f;
+ return t;
+}
- if (init != NULL_TREE)
- {
- if (TREE_CODE (decl) != TYPE_DECL)
- DECL_INITIAL (decl) = init;
- else
- {
- /* typedef foo = bar; store the type of bar as the type of foo. */
- TREE_TYPE (decl) = TREE_TYPE (init);
- DECL_INITIAL (decl) = init = 0;
- }
- }
+/* Store the list of declarations of the current level.
+ This is done for the parameter declarations of a function being defined,
+ after they are modified in the light of any missing parameters. */
- /* Pop back to the obstack that is current for this binding level. This is
- because MAXINDEX, rtl, etc. to be made below must go in the permanent
- obstack. But don't discard the temporary data yet. */
- pop_obstacks ();
+static tree
+storedecls (decls)
+ tree decls;
+{
+ return current_binding_level->names = decls;
+}
- /* Deduce size of array from initialization, if not already known */
+/* Store the parameter declarations into the current function declaration.
+ This is called after parsing the parameter declarations, before
+ digesting the body of the function.
- if (TREE_CODE (type) == ARRAY_TYPE
- && TYPE_DOMAIN (type) == 0
- && TREE_CODE (decl) != TYPE_DECL)
- {
- assert (top_level);
- assert (was_incomplete);
+ For an old-style definition, modify the function's type
+ to specify at least the number of arguments. */
- layout_decl (decl, 0);
- }
+static void
+store_parm_decls (int is_main_program UNUSED)
+{
+ register tree fndecl = current_function_decl;
- if (TREE_CODE (decl) == VAR_DECL)
- {
- if (DECL_SIZE (decl) == NULL_TREE
- && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
- layout_decl (decl, 0);
+ if (fndecl == error_mark_node)
+ return;
- if (DECL_SIZE (decl) == NULL_TREE
- && (TREE_STATIC (decl)
- ?
- /* A static variable with an incomplete type is an error if it is
- initialized. Also if it is not file scope. Otherwise, let it
- through, but if it is not `extern' then it may cause an error
- message later. */
- (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
- :
- /* An automatic variable with an incomplete type is an error. */
- !DECL_EXTERNAL (decl)))
- {
- assert ("storage size not known" == NULL);
- abort ();
- }
+ /* This is a chain of PARM_DECLs from old-style parm declarations. */
+ DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
- if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
- && (DECL_SIZE (decl) != 0)
- && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
- {
- assert ("storage size not constant" == NULL);
- abort ();
- }
- }
+ /* Initialize the RTL code for the function. */
- /* Output the assembler code and/or RTL code for variables and functions,
- unless the type is an undefined structure or union. If not, it will get
- done when the type is completed. */
+ init_function_start (fndecl, input_filename, lineno);
- if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
- {
- rest_of_decl_compilation (decl, NULL,
- DECL_CONTEXT (decl) == 0,
- 0);
+ /* Set up parameters and prepare for return, for the function. */
- if (DECL_CONTEXT (decl) != 0)
- {
- /* Recompute the RTL of a local array now if it used to be an
- incomplete type. */
- if (was_incomplete
- && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
- {
- /* If we used it already as memory, it must stay in memory. */
- TREE_ADDRESSABLE (decl) = TREE_USED (decl);
- /* If it's still incomplete now, no init will save it. */
- if (DECL_SIZE (decl) == 0)
- DECL_INITIAL (decl) = 0;
- expand_decl (decl);
- }
- /* Compute and store the initial value. */
- if (TREE_CODE (decl) != FUNCTION_DECL)
- expand_decl_init (decl);
- }
- }
- else if (TREE_CODE (decl) == TYPE_DECL)
- {
- rest_of_decl_compilation (decl, NULL_PTR,
- DECL_CONTEXT (decl) == 0,
- 0);
- }
+ expand_function_start (fndecl, 0);
+}
- /* This test used to include TREE_PERMANENT, however, we have the same
- problem with initializers at the function level. Such initializers get
- saved until the end of the function on the momentary_obstack. */
- if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
- && temporary
- /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
- DECL_ARG_TYPE. */
- && TREE_CODE (decl) != PARM_DECL)
- {
- /* We need to remember that this array HAD an initialization, but
- discard the actual temporary nodes, since we can't have a permanent
- node keep pointing to them. */
- /* We make an exception for inline functions, since it's normal for a
- local extern redeclaration of an inline function to have a copy of
- the top-level decl's DECL_INLINE. */
- if ((DECL_INITIAL (decl) != 0)
- && (DECL_INITIAL (decl) != error_mark_node))
- {
- /* If this is a const variable, then preserve the
- initializer instead of discarding it so that we can optimize
- references to it. */
- /* This test used to include TREE_STATIC, but this won't be set
- for function level initializers. */
- if (TREE_READONLY (decl))
- {
- preserve_initializer ();
- /* Hack? Set the permanent bit for something that is
- permanent, but not on the permenent obstack, so as to
- convince output_constant_def to make its rtl on the
- permanent obstack. */
- TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
-
- /* The initializer and DECL must have the same (or equivalent
- types), but if the initializer is a STRING_CST, its type
- might not be on the right obstack, so copy the type
- of DECL. */
- TREE_TYPE (DECL_INITIAL (decl)) = type;
- }
- else
- DECL_INITIAL (decl) = error_mark_node;
- }
- }
+static tree
+start_decl (tree decl, bool is_top_level)
+{
+ register tree tem;
+ bool at_top_level = (current_binding_level == global_binding_level);
+ bool top_level = is_top_level || at_top_level;
- /* If requested, warn about definitions of large data objects. */
+ /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
+ level anyway. */
+ assert (!is_top_level || !at_top_level);
- if (warn_larger_than
- && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
- && !DECL_EXTERNAL (decl))
+ if (DECL_INITIAL (decl) != NULL_TREE)
{
- register tree decl_size = DECL_SIZE (decl);
+ assert (DECL_INITIAL (decl) == error_mark_node);
+ assert (!DECL_EXTERNAL (decl));
+ }
+ else if (top_level)
+ assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
- if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
- {
- unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
+ /* For Fortran, we by default put things in .common when possible. */
+ DECL_COMMON (decl) = 1;
- if (units > larger_than_size)
- warning_with_decl (decl, "size of `%s' is %u bytes", units);
- }
- }
+ /* Add this decl to the current binding level. TEM may equal DECL or it may
+ be a previous decl of the same name. */
+ if (is_top_level)
+ tem = pushdecl_top_level (decl);
+ else
+ tem = pushdecl (decl);
- /* If we have gone back from temporary to permanent allocation, actually
- free the temporary space that we no longer need. */
- if (temporary && !allocation_temporary_p ())
- permanent_allocation (0);
+ /* For a local variable, define the RTL now. */
+ if (!top_level
+ /* But not if this is a duplicate decl and we preserved the rtl from the
+ previous one (which may or may not happen). */
+ && DECL_RTL (tem) == 0)
+ {
+ if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
+ expand_decl (tem);
+ else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
+ && DECL_INITIAL (tem) != 0)
+ expand_decl (tem);
+ }
- /* At the end of a declaration, throw away any variable type sizes of types
- defined inside that declaration. There is no use computing them in the
- following function definition. */
- if (current_binding_level == global_binding_level)
- get_pending_sizes ();
+ return tem;
}
-/* Finish up a function declaration and compile that function
- all the way to assembler language output. The free the storage
- for the function definition.
+/* Create the FUNCTION_DECL for a function definition.
+ DECLSPECS and DECLARATOR are the parts of the declaration;
+ they describe the function's name and the type it returns,
+ but twisted together in a fashion that parallels the syntax of C.
- This is called after parsing the body of the function definition.
+ This function creates a binding context for the function body
+ as well as setting up the FUNCTION_DECL in current_function_decl.
- NESTED is nonzero if the function being finished is nested in another. */
+ Returns 1 on success. If the DECLARATOR is not suitable for a function
+ (it defines a datum instead), we return 0, which tells
+ yyparse to report a parse error.
+
+ NESTED is nonzero for a function nested within another function. */
static void
-finish_function (int nested)
+start_function (tree name, tree type, int nested, int public)
{
- register tree fndecl = current_function_decl;
+ tree decl1;
+ tree restype;
+ int old_immediate_size_expand = immediate_size_expand;
- assert (fndecl != NULL_TREE);
- if (nested)
- assert (DECL_CONTEXT (fndecl) != NULL_TREE);
- else
- assert (DECL_CONTEXT (fndecl) == NULL_TREE);
+ named_labels = 0;
+ shadowed_labels = 0;
-/* TREE_READONLY (fndecl) = 1;
- This caused &foo to be of type ptr-to-const-function
- which then got a warning when stored in a ptr-to-function variable. */
+ /* Don't expand any sizes in the return type of the function. */
+ immediate_size_expand = 0;
- poplevel (1, 0, 1);
- BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+ if (nested)
+ {
+ assert (!public);
+ assert (current_function_decl != NULL_TREE);
+ assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
+ }
+ else
+ {
+ assert (current_function_decl == NULL_TREE);
+ }
- /* Must mark the RESULT_DECL as being in this function. */
+ if (TREE_CODE (type) == ERROR_MARK)
+ decl1 = current_function_decl = error_mark_node;
+ else
+ {
+ decl1 = build_decl (FUNCTION_DECL,
+ name,
+ type);
+ TREE_PUBLIC (decl1) = public ? 1 : 0;
+ if (nested)
+ DECL_INLINE (decl1) = 1;
+ TREE_STATIC (decl1) = 1;
+ DECL_EXTERNAL (decl1) = 0;
- DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
+ announce_function (decl1);
- /* Obey `register' declarations if `setjmp' is called in this fn. */
- /* Generate rtl for function exit. */
- expand_function_end (input_filename, lineno, 0);
+ /* Make the init_value nonzero so pushdecl knows this is not tentative.
+ error_mark_node is replaced below (in poplevel) with the BLOCK. */
+ DECL_INITIAL (decl1) = error_mark_node;
- /* So we can tell if jump_optimize sets it to 1. */
- can_reach_end = 0;
+ /* Record the decl so that the function name is defined. If we already have
+ a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
- /* Run the optimizers and output the assembler code for this function. */
- rest_of_compilation (fndecl);
+ current_function_decl = pushdecl (decl1);
+ }
- /* Free all the tree nodes making up this function. */
- /* Switch back to allocating nodes permanently until we start another
- function. */
if (!nested)
- permanent_allocation (1);
+ ffecom_outer_function_decl_ = current_function_decl;
- if (DECL_SAVED_INSNS (fndecl) == 0 && !nested)
+ pushlevel (0);
+ current_binding_level->prep_state = 2;
+
+ if (TREE_CODE (current_function_decl) != ERROR_MARK)
{
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this was an actual
- function definition. */
- /* For a nested function, this is done in pop_f_function_context. */
- /* If rest_of_compilation set this to 0, leave it 0. */
- if (DECL_INITIAL (fndecl) != 0)
- DECL_INITIAL (fndecl) = error_mark_node;
- DECL_ARGUMENTS (fndecl) = 0;
+ make_decl_rtl (current_function_decl, NULL);
+
+ restype = TREE_TYPE (TREE_TYPE (current_function_decl));
+ DECL_RESULT (current_function_decl)
+ = build_decl (RESULT_DECL, NULL_TREE, restype);
}
- if (!nested)
+ if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
+ TREE_ADDRESSABLE (current_function_decl) = 1;
+
+ immediate_size_expand = old_immediate_size_expand;
+}
+\f
+/* Here are the public functions the GNU back end needs. */
+
+tree
+convert (type, expr)
+ tree type, expr;
+{
+ register tree e = expr;
+ register enum tree_code code = TREE_CODE (type);
+
+ if (type == TREE_TYPE (e)
+ || TREE_CODE (e) == ERROR_MARK)
+ return e;
+ if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
+ return fold (build1 (NOP_EXPR, type, e));
+ if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
+ || code == ERROR_MARK)
+ return error_mark_node;
+ if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
{
- /* Let the error reporting routines know that we're outside a function.
- For a nested function, this value is used in pop_c_function_context
- and then reset via pop_function_context. */
- ffecom_outer_function_decl_ = current_function_decl = NULL;
+ assert ("void value not ignored as it ought to be" == NULL);
+ return error_mark_node;
}
+ if (code == VOID_TYPE)
+ return build1 (CONVERT_EXPR, type, e);
+ if ((code != RECORD_TYPE)
+ && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
+ e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
+ e);
+ if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
+ return fold (convert_to_integer (type, e));
+ if (code == POINTER_TYPE)
+ return fold (convert_to_pointer (type, e));
+ if (code == REAL_TYPE)
+ return fold (convert_to_real (type, e));
+ if (code == COMPLEX_TYPE)
+ return fold (convert_to_complex (type, e));
+ if (code == RECORD_TYPE)
+ return fold (ffecom_convert_to_complex_ (type, e));
+
+ assert ("conversion to non-scalar type requested" == NULL);
+ return error_mark_node;
}
-/* Plug-in replacement for identifying the name of a decl and, for a
- function, what we call it in diagnostics. For now, "program unit"
- should suffice, since it's a bit of a hassle to figure out which
- of several kinds of things it is. Note that it could conceivably
- be a statement function, which probably isn't really a program unit
- per se, but if that comes up, it should be easy to check (being a
- nested function and all). */
+/* integrate_decl_tree calls this function, but since we don't use the
+ DECL_LANG_SPECIFIC field, this is a no-op. */
-static char *
-lang_printable_name (tree decl, int v)
+void
+copy_lang_decl (node)
+ tree node UNUSED;
{
- /* Just to keep GCC quiet about the unused variable.
- In theory, differing values of V should produce different
- output. */
- switch (v)
- {
- default:
- return IDENTIFIER_POINTER (DECL_NAME (decl));
- }
}
-/* g77's function to print out name of current function that caused
- an error. */
+/* Return the list of declarations of the current level.
+ Note that this list is in reverse order unless/until
+ you nreverse it; and when you do nreverse it, you must
+ store the result back using `storedecls' or you will lose. */
+
+tree
+getdecls ()
+{
+ return current_binding_level->names;
+}
+
+/* Nonzero if we are currently in the global binding level. */
+
+int
+global_bindings_p ()
+{
+ return current_binding_level == global_binding_level;
+}
+
+/* Print an error message for invalid use of an incomplete type.
+ VALUE is the expression that was used (or 0 if that isn't known)
+ and TYPE is the type that was invalid. */
+
+void
+incomplete_type_error (value, type)
+ tree value UNUSED;
+ tree type;
+{
+ if (TREE_CODE (type) == ERROR_MARK)
+ return;
+
+ assert ("incomplete type?!?" == NULL);
+}
-#if BUILT_FOR_270
-void
-lang_print_error_function (file)
- char *file;
+/* Mark ARG for GC. */
+static void
+mark_binding_level (void *arg)
{
- static ffesymbol last_s = NULL;
- ffesymbol s;
- char *kind;
+ struct binding_level *level = *(struct binding_level **) arg;
- if (ffecom_primary_entry_ == NULL)
+ while (level)
{
- s = NULL;
- kind = NULL;
+ ggc_mark_tree (level->names);
+ ggc_mark_tree (level->blocks);
+ ggc_mark_tree (level->this_block);
+ level = level->level_chain;
}
- else if (ffecom_nested_entry_ == NULL)
- {
- s = ffecom_primary_entry_;
- switch (ffesymbol_kind (s))
- {
- case FFEINFO_kindFUNCTION:
- kind = "function";
- break;
+}
- case FFEINFO_kindSUBROUTINE:
- kind = "subroutine";
- break;
+void
+init_decl_processing ()
+{
+ static tree *const tree_roots[] = {
+ ¤t_function_decl,
+ &string_type_node,
+ &ffecom_tree_fun_type_void,
+ &ffecom_integer_zero_node,
+ &ffecom_integer_one_node,
+ &ffecom_tree_subr_type,
+ &ffecom_tree_ptr_to_subr_type,
+ &ffecom_tree_blockdata_type,
+ &ffecom_tree_xargc_,
+ &ffecom_f2c_integer_type_node,
+ &ffecom_f2c_ptr_to_integer_type_node,
+ &ffecom_f2c_address_type_node,
+ &ffecom_f2c_real_type_node,
+ &ffecom_f2c_ptr_to_real_type_node,
+ &ffecom_f2c_doublereal_type_node,
+ &ffecom_f2c_complex_type_node,
+ &ffecom_f2c_doublecomplex_type_node,
+ &ffecom_f2c_longint_type_node,
+ &ffecom_f2c_logical_type_node,
+ &ffecom_f2c_flag_type_node,
+ &ffecom_f2c_ftnlen_type_node,
+ &ffecom_f2c_ftnlen_zero_node,
+ &ffecom_f2c_ftnlen_one_node,
+ &ffecom_f2c_ftnlen_two_node,
+ &ffecom_f2c_ptr_to_ftnlen_type_node,
+ &ffecom_f2c_ftnint_type_node,
+ &ffecom_f2c_ptr_to_ftnint_type_node,
+ &ffecom_outer_function_decl_,
+ &ffecom_previous_function_decl_,
+ &ffecom_which_entrypoint_decl_,
+ &ffecom_float_zero_,
+ &ffecom_float_half_,
+ &ffecom_double_zero_,
+ &ffecom_double_half_,
+ &ffecom_func_result_,
+ &ffecom_func_length_,
+ &ffecom_multi_type_node_,
+ &ffecom_multi_retval_,
+ &named_labels,
+ &shadowed_labels
+ };
+ size_t i;
- case FFEINFO_kindPROGRAM:
- kind = "program";
- break;
+ malloc_init ();
- case FFEINFO_kindBLOCKDATA:
- kind = "block-data";
- break;
+ /* Record our roots. */
+ for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
+ ggc_add_tree_root (tree_roots[i], 1);
+ ggc_add_tree_root (&ffecom_tree_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
+ ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+ ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+ ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
- default:
- kind = ffeinfo_kind_message (ffesymbol_kind (s));
- break;
- }
- }
- else
+ ffe_init_0 ();
+}
+
+const char *
+init_parse (filename)
+ const char *filename;
+{
+ /* Open input file. */
+ if (filename == 0 || !strcmp (filename, "-"))
{
- s = ffecom_nested_entry_;
- kind = "statement function";
+ finput = stdin;
+ filename = "stdin";
}
+ else
+ finput = fopen (filename, "r");
+ if (finput == 0)
+ fatal_io_error ("can't open %s", filename);
- if (last_s != s)
- {
- if (file)
- fprintf (stderr, "%s: ", file);
+#ifdef IO_BUFFER_SIZE
+ setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
+#endif
- if (s == NULL)
- fprintf (stderr, "Outside of any program unit:\n");
- else
- {
- char *name = ffesymbol_text (s);
+ /* Make identifier nodes long enough for the language-specific slots. */
+ set_identifier_size (sizeof (struct lang_identifier));
+ decl_printable_name = lang_printable_name;
+#if BUILT_FOR_270
+ print_error_function = lang_print_error_function;
+#endif
- fprintf (stderr, "In %s `%s':\n", kind, name);
- }
+ return filename;
+}
- last_s = s;
- }
+void
+finish_parse ()
+{
+ fclose (finput);
}
-#endif
-/* Similar to `lookup_name' but look only at current binding level. */
+/* Delete the node BLOCK from the current binding level.
+ This is used for the block inside a stmt expr ({...})
+ so that the block can be reinserted where appropriate. */
-static tree
-lookup_name_current_level (tree name)
+static void
+delete_block (block)
+ tree block;
{
- register tree t;
+ tree t;
+ if (current_binding_level->blocks == block)
+ current_binding_level->blocks = TREE_CHAIN (block);
+ for (t = current_binding_level->blocks; t;)
+ {
+ if (TREE_CHAIN (t) == block)
+ TREE_CHAIN (t) = TREE_CHAIN (block);
+ else
+ t = TREE_CHAIN (t);
+ }
+ TREE_CHAIN (block) = NULL;
+ /* Clear TREE_USED which is always set by poplevel.
+ The flag is set again if insert_block is called. */
+ TREE_USED (block) = 0;
+}
- if (current_binding_level == global_binding_level)
- return IDENTIFIER_GLOBAL_VALUE (name);
+void
+insert_block (block)
+ tree block;
+{
+ TREE_USED (block) = 1;
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
+}
- if (IDENTIFIER_LOCAL_VALUE (name) == 0)
- return 0;
+/* Each front end provides its own. */
+static void ffe_init PARAMS ((void));
+static void ffe_finish PARAMS ((void));
+static void ffe_init_options PARAMS ((void));
- for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
- if (DECL_NAME (t) == name)
- break;
+struct lang_hooks lang_hooks = {ffe_init,
+ ffe_finish,
+ ffe_init_options,
+ ffe_decode_option,
+ NULL /* post_options */};
- return t;
+/* used by print-tree.c */
+
+void
+lang_print_xnode (file, node, indent)
+ FILE *file UNUSED;
+ tree node UNUSED;
+ int indent UNUSED;
+{
}
-/* Create a new `struct binding_level'. */
+static void
+ffe_finish ()
+{
+ ffe_terminate_0 ();
-static struct binding_level *
-make_binding_level ()
+ if (ffe_is_ffedebug ())
+ malloc_pool_display (malloc_pool_image ());
+}
+
+const char *
+lang_identify ()
{
- /* NOSTRICT */
- return (struct binding_level *) xmalloc (sizeof (struct binding_level));
+ return "f77";
}
-/* Save and restore the variables in this file and elsewhere
- that keep track of the progress of compilation of the current function.
- Used for nested functions. */
+/* Return the typed-based alias set for T, which may be an expression
+ or a type. Return -1 if we don't do anything special. */
-struct f_function
+HOST_WIDE_INT
+lang_get_alias_set (t)
+ tree t ATTRIBUTE_UNUSED;
{
- struct f_function *next;
- tree named_labels;
- tree shadowed_labels;
- struct binding_level *binding_level;
-};
-
-struct f_function *f_function_chain;
+ /* We do not wish to use alias-set based aliasing at all. Used in the
+ extreme (every object with its own set, with equivalences recorded)
+ it might be helpful, but there are problems when it comes to inlining.
+ We get on ok with flag_argument_noalias, and alias-set aliasing does
+ currently limit how stack slots can be reused, which is a lose. */
+ return 0;
+}
-/* Restore the variables used during compilation of a C function. */
+static void
+ffe_init_options ()
+{
+ /* Set default options for Fortran. */
+ flag_move_all_movables = 1;
+ flag_reduce_all_givs = 1;
+ flag_argument_noalias = 2;
+ flag_errno_math = 0;
+ flag_complex_divide_method = 1;
+}
static void
-pop_f_function_context ()
+ffe_init ()
{
- struct f_function *p = f_function_chain;
- tree link;
+ /* If the file is output from cpp, it should contain a first line
+ `# 1 "real-filename"', and the current design of gcc (toplev.c
+ in particular and the way it sets up information relied on by
+ INCLUDE) requires that we read this now, and store the
+ "real-filename" info in master_input_filename. Ask the lexer
+ to try doing this. */
+ ffelex_hash_kludge (finput);
+}
- /* Bring back all the labels that were shadowed. */
- for (link = shadowed_labels; link; link = TREE_CHAIN (link))
- if (DECL_NAME (TREE_VALUE (link)) != 0)
- IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
- = TREE_VALUE (link);
+int
+mark_addressable (exp)
+ tree exp;
+{
+ register tree x = exp;
+ while (1)
+ switch (TREE_CODE (x))
+ {
+ case ADDR_EXPR:
+ case COMPONENT_REF:
+ case ARRAY_REF:
+ x = TREE_OPERAND (x, 0);
+ break;
- if (DECL_SAVED_INSNS (current_function_decl) == 0)
- {
- /* Stop pointing to the local nodes about to be freed. */
- /* But DECL_INITIAL must remain nonzero so we know this was an actual
- function definition. */
- DECL_INITIAL (current_function_decl) = error_mark_node;
- DECL_ARGUMENTS (current_function_decl) = 0;
- }
+ case CONSTRUCTOR:
+ TREE_ADDRESSABLE (x) = 1;
+ return 1;
- pop_function_context ();
+ case VAR_DECL:
+ case CONST_DECL:
+ case PARM_DECL:
+ case RESULT_DECL:
+ if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
+ && DECL_NONLOCAL (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ assert ("address of global register var requested" == NULL);
+ return 0;
+ }
+ assert ("address of register variable requested" == NULL);
+ }
+ else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
+ {
+ if (TREE_PUBLIC (x))
+ {
+ assert ("address of global register var requested" == NULL);
+ return 0;
+ }
+ assert ("address of register var requested" == NULL);
+ }
+ put_var_into_stack (x);
- f_function_chain = p->next;
+ /* drops in */
+ case FUNCTION_DECL:
+ TREE_ADDRESSABLE (x) = 1;
+#if 0 /* poplevel deals with this now. */
+ if (DECL_CONTEXT (x) == 0)
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
+#endif
- named_labels = p->named_labels;
- shadowed_labels = p->shadowed_labels;
- current_binding_level = p->binding_level;
+ default:
+ return 1;
+ }
+}
- free (p);
+/* If DECL has a cleanup, build and return that cleanup here.
+ This is a callback called by expand_expr. */
+
+tree
+maybe_build_cleanup (decl)
+ tree decl UNUSED;
+{
+ /* There are no cleanups in Fortran. */
+ return NULL_TREE;
}
-/* Save and reinitialize the variables
- used during compilation of a C function. */
+/* Exit a binding level.
+ Pop the level off, and restore the state of the identifier-decl mappings
+ that were in effect when this level was entered.
-static void
-push_f_function_context ()
+ If KEEP is nonzero, this level had explicit declarations, so
+ and create a "block" (a BLOCK node) for the level
+ to record its declarations and subblocks for symbol table output.
+
+ If FUNCTIONBODY is nonzero, this level is the body of a function,
+ so create a block as if KEEP were set and also clear out all
+ label names.
+
+ If REVERSE is nonzero, reverse the order of decls before putting
+ them into the BLOCK. */
+
+tree
+poplevel (keep, reverse, functionbody)
+ int keep;
+ int reverse;
+ int functionbody;
{
- struct f_function *p
- = (struct f_function *) xmalloc (sizeof (struct f_function));
+ register tree link;
+ /* The chain of decls was accumulated in reverse order.
+ Put it into forward order, just for cleanliness. */
+ tree decls;
+ tree subblocks = current_binding_level->blocks;
+ tree block = 0;
+ tree decl;
+ int block_previously_created;
- push_function_context ();
+ /* Get the decls in the order they were written.
+ Usually current_binding_level->names is in reverse order.
+ But parameter decls were previously put in forward order. */
+
+ if (reverse)
+ current_binding_level->names
+ = decls = nreverse (current_binding_level->names);
+ else
+ decls = current_binding_level->names;
+
+ /* Output any nested inline functions within this block
+ if they weren't already output. */
+
+ for (decl = decls; decl; decl = TREE_CHAIN (decl))
+ if (TREE_CODE (decl) == FUNCTION_DECL
+ && ! TREE_ASM_WRITTEN (decl)
+ && DECL_INITIAL (decl) != 0
+ && TREE_ADDRESSABLE (decl))
+ {
+ /* If this decl was copied from a file-scope decl
+ on account of a block-scope extern decl,
+ propagate TREE_ADDRESSABLE to the file-scope decl.
+
+ DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
+ true, since then the decl goes through save_for_inline_copying. */
+ if (DECL_ABSTRACT_ORIGIN (decl) != 0
+ && DECL_ABSTRACT_ORIGIN (decl) != decl)
+ TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
+ else if (DECL_SAVED_INSNS (decl) != 0)
+ {
+ push_function_context ();
+ output_inline_function (decl);
+ pop_function_context ();
+ }
+ }
- p->next = f_function_chain;
- f_function_chain = p;
+ /* If there were any declarations or structure tags in that level,
+ or if this level is a function body,
+ create a BLOCK to record them for the life of this function. */
- p->named_labels = named_labels;
- p->shadowed_labels = shadowed_labels;
- p->binding_level = current_binding_level;
-}
+ block = 0;
+ block_previously_created = (current_binding_level->this_block != 0);
+ if (block_previously_created)
+ block = current_binding_level->this_block;
+ else if (keep || functionbody)
+ block = make_node (BLOCK);
+ if (block != 0)
+ {
+ BLOCK_VARS (block) = decls;
+ BLOCK_SUBBLOCKS (block) = subblocks;
+ }
-static void
-push_parm_decl (tree parm)
-{
- int old_immediate_size_expand = immediate_size_expand;
+ /* In each subblock, record that this is its superior. */
- /* Don't try computing parm sizes now -- wait till fn is called. */
+ for (link = subblocks; link; link = TREE_CHAIN (link))
+ BLOCK_SUPERCONTEXT (link) = block;
- immediate_size_expand = 0;
+ /* Clear out the meanings of the local variables of this level. */
- push_obstacks_nochange ();
+ for (link = decls; link; link = TREE_CHAIN (link))
+ {
+ if (DECL_NAME (link) != 0)
+ {
+ /* If the ident. was used or addressed via a local extern decl,
+ don't forget that fact. */
+ if (DECL_EXTERNAL (link))
+ {
+ if (TREE_USED (link))
+ TREE_USED (DECL_NAME (link)) = 1;
+ if (TREE_ADDRESSABLE (link))
+ TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
+ }
+ IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
+ }
+ }
- /* Fill in arg stuff. */
+ /* If the level being exited is the top level of a function,
+ check over all the labels, and clear out the current
+ (function local) meanings of their names. */
- DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
- DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
- TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
+ if (functionbody)
+ {
+ /* If this is the top level block of a function,
+ the vars are the function's parameters.
+ Don't leave them in the BLOCK because they are
+ found in the FUNCTION_DECL instead. */
- parm = pushdecl (parm);
+ BLOCK_VARS (block) = 0;
+ }
- immediate_size_expand = old_immediate_size_expand;
+ /* Pop the current level, and free the structure for reuse. */
- finish_decl (parm, NULL_TREE, FALSE);
-}
+ {
+ register struct binding_level *level = current_binding_level;
+ current_binding_level = current_binding_level->level_chain;
-/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
+ level->level_chain = free_binding_level;
+ free_binding_level = level;
+ }
-static tree
-pushdecl_top_level (x)
- tree x;
-{
- register tree t;
- register struct binding_level *b = current_binding_level;
- register tree f = current_function_decl;
+ /* Dispose of the block that we just made inside some higher level. */
+ if (functionbody
+ && current_function_decl != error_mark_node)
+ DECL_INITIAL (current_function_decl) = block;
+ else if (block)
+ {
+ if (!block_previously_created)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, block);
+ }
+ /* If we did not make a block for the level just exited,
+ any blocks made for inner levels
+ (since they cannot be recorded as subblocks in that level)
+ must be carried forward so they will later become subblocks
+ of something else. */
+ else if (subblocks)
+ current_binding_level->blocks
+ = chainon (current_binding_level->blocks, subblocks);
- current_binding_level = global_binding_level;
- current_function_decl = NULL_TREE;
- t = pushdecl (x);
- current_binding_level = b;
- current_function_decl = f;
- return t;
+ if (block)
+ TREE_USED (block) = 1;
+ return block;
}
-/* Store the list of declarations of the current level.
- This is done for the parameter declarations of a function being defined,
- after they are modified in the light of any missing parameters. */
-
-static tree
-storedecls (decls)
- tree decls;
+void
+print_lang_decl (file, node, indent)
+ FILE *file UNUSED;
+ tree node UNUSED;
+ int indent UNUSED;
{
- return current_binding_level->names = decls;
}
-/* Store the parameter declarations into the current function declaration.
- This is called after parsing the parameter declarations, before
- digesting the body of the function.
-
- For an old-style definition, modify the function's type
- to specify at least the number of arguments. */
-
-static void
-store_parm_decls (int is_main_program UNUSED)
+void
+print_lang_identifier (file, node, indent)
+ FILE *file;
+ tree node;
+ int indent;
{
- register tree fndecl = current_function_decl;
-
- /* This is a chain of PARM_DECLs from old-style parm declarations. */
- DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
-
- /* Initialize the RTL code for the function. */
-
- init_function_start (fndecl, input_filename, lineno);
-
- /* Set up parameters and prepare for return, for the function. */
-
- expand_function_start (fndecl, 0);
+ print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
+ print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
}
-static tree
-start_decl (tree decl, bool is_top_level)
+void
+print_lang_statistics ()
{
- register tree tem;
- bool at_top_level = (current_binding_level == global_binding_level);
- bool top_level = is_top_level || at_top_level;
+}
- /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
- level anyway. */
- assert (!is_top_level || !at_top_level);
+void
+print_lang_type (file, node, indent)
+ FILE *file UNUSED;
+ tree node UNUSED;
+ int indent UNUSED;
+{
+}
- /* The corresponding pop_obstacks is in finish_decl. */
- push_obstacks_nochange ();
+/* Record a decl-node X as belonging to the current lexical scope.
+ Check for errors (such as an incompatible declaration for the same
+ name already seen in the same scope).
- if (DECL_INITIAL (decl) != NULL_TREE)
- {
- assert (DECL_INITIAL (decl) == error_mark_node);
- assert (!DECL_EXTERNAL (decl));
- }
- else if (top_level)
- assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
+ Returns either X or an old decl for the same name.
+ If an old decl is returned, it may have been smashed
+ to agree with what X says. */
- /* For Fortran, we by default put things in .common when possible. */
- DECL_COMMON (decl) = 1;
+tree
+pushdecl (x)
+ tree x;
+{
+ register tree t;
+ register tree name = DECL_NAME (x);
+ register struct binding_level *b = current_binding_level;
- /* Add this decl to the current binding level. TEM may equal DECL or it may
- be a previous decl of the same name. */
- if (is_top_level)
- tem = pushdecl_top_level (decl);
+ if ((TREE_CODE (x) == FUNCTION_DECL)
+ && (DECL_INITIAL (x) == 0)
+ && DECL_EXTERNAL (x))
+ DECL_CONTEXT (x) = NULL_TREE;
else
- tem = pushdecl (decl);
-
- /* For a local variable, define the RTL now. */
- if (!top_level
- /* But not if this is a duplicate decl and we preserved the rtl from the
- previous one (which may or may not happen). */
- && DECL_RTL (tem) == 0)
- {
- if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
- expand_decl (tem);
- else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
- && DECL_INITIAL (tem) != 0)
- expand_decl (tem);
- }
+ DECL_CONTEXT (x) = current_function_decl;
- if (DECL_INITIAL (tem) != NULL_TREE)
+ if (name)
{
- /* When parsing and digesting the initializer, use temporary storage.
- Do this even if we will ignore the value. */
- if (at_top_level)
- temporary_allocation ();
- }
-
- return tem;
-}
-
-/* Create the FUNCTION_DECL for a function definition.
- DECLSPECS and DECLARATOR are the parts of the declaration;
- they describe the function's name and the type it returns,
- but twisted together in a fashion that parallels the syntax of C.
+ if (IDENTIFIER_INVENTED (name))
+ {
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (x) = 1;
+#endif
+ DECL_IN_SYSTEM_HEADER (x) = 1;
+ }
- This function creates a binding context for the function body
- as well as setting up the FUNCTION_DECL in current_function_decl.
+ t = lookup_name_current_level (name);
- Returns 1 on success. If the DECLARATOR is not suitable for a function
- (it defines a datum instead), we return 0, which tells
- yyparse to report a parse error.
+ assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
- NESTED is nonzero for a function nested within another function. */
+ /* Don't push non-parms onto list for parms until we understand
+ why we're doing this and whether it works. */
-static void
-start_function (tree name, tree type, int nested, int public)
-{
- tree decl1;
- tree restype;
- int old_immediate_size_expand = immediate_size_expand;
+ assert ((b == global_binding_level)
+ || !ffecom_transform_only_dummies_
+ || TREE_CODE (x) == PARM_DECL);
- named_labels = 0;
- shadowed_labels = 0;
+ if ((t != NULL_TREE) && duplicate_decls (x, t))
+ return t;
- /* Don't expand any sizes in the return type of the function. */
- immediate_size_expand = 0;
+ /* If we are processing a typedef statement, generate a whole new
+ ..._TYPE node (which will be just an variant of the existing
+ ..._TYPE node with identical properties) and then install the
+ TYPE_DECL node generated to represent the typedef name as the
+ TYPE_NAME of this brand new (duplicate) ..._TYPE node.
- if (nested)
- {
- assert (!public);
- assert (current_function_decl != NULL_TREE);
- assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
- }
- else
- {
- assert (current_function_decl == NULL_TREE);
- }
+ The whole point here is to end up with a situation where each and every
+ ..._TYPE node the compiler creates will be uniquely associated with
+ AT MOST one node representing a typedef name. This way, even though
+ the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
+ (i.e. "typedef name") nodes very early on, later parts of the
+ compiler can always do the reverse translation and get back the
+ corresponding typedef name. For example, given:
- decl1 = build_decl (FUNCTION_DECL,
- name,
- type);
- TREE_PUBLIC (decl1) = public ? 1 : 0;
- if (nested)
- DECL_INLINE (decl1) = 1;
- TREE_STATIC (decl1) = 1;
- DECL_EXTERNAL (decl1) = 0;
+ typedef struct S MY_TYPE; MY_TYPE object;
- announce_function (decl1);
+ Later parts of the compiler might only know that `object' was of type
+ `struct S' if it were not for code just below. With this code
+ however, later parts of the compiler see something like:
- /* Make the init_value nonzero so pushdecl knows this is not tentative.
- error_mark_node is replaced below (in poplevel) with the BLOCK. */
- DECL_INITIAL (decl1) = error_mark_node;
+ struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
- /* Record the decl so that the function name is defined. If we already have
- a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
+ And they can then deduce (from the node for type struct S') that the
+ original object declaration was:
- current_function_decl = pushdecl (decl1);
- if (!nested)
- ffecom_outer_function_decl_ = current_function_decl;
+ MY_TYPE object;
- pushlevel (0);
+ Being able to do this is important for proper support of protoize, and
+ also for generating precise symbolic debugging information which
+ takes full account of the programmer's (typedef) vocabulary.
- make_function_rtl (current_function_decl);
+ Obviously, we don't want to generate a duplicate ..._TYPE node if the
+ TYPE_DECL node that we are now processing really represents a
+ standard built-in type.
- restype = TREE_TYPE (TREE_TYPE (current_function_decl));
- DECL_RESULT (current_function_decl)
- = build_decl (RESULT_DECL, NULL_TREE, restype);
+ Since all standard types are effectively declared at line zero in the
+ source file, we can easily check to see if we are working on a
+ standard type by checking the current value of lineno. */
- if (!nested)
- /* Allocate further tree nodes temporarily during compilation of this
- function only. */
- temporary_allocation ();
+ if (TREE_CODE (x) == TYPE_DECL)
+ {
+ if (DECL_SOURCE_LINE (x) == 0)
+ {
+ if (TYPE_NAME (TREE_TYPE (x)) == 0)
+ TYPE_NAME (TREE_TYPE (x)) = x;
+ }
+ else if (TREE_TYPE (x) != error_mark_node)
+ {
+ tree tt = TREE_TYPE (x);
- if (!nested)
- TREE_ADDRESSABLE (current_function_decl) = 1;
+ tt = build_type_copy (tt);
+ TYPE_NAME (tt) = x;
+ TREE_TYPE (x) = tt;
+ }
+ }
- immediate_size_expand = old_immediate_size_expand;
-}
-\f
-/* Here are the public functions the GNU back end needs. */
+ /* This name is new in its binding level. Install the new declaration
+ and return it. */
+ if (b == global_binding_level)
+ IDENTIFIER_GLOBAL_VALUE (name) = x;
+ else
+ IDENTIFIER_LOCAL_VALUE (name) = x;
+ }
-/* This is used by the `assert' macro. It is provided in libgcc.a,
- which `cc' doesn't know how to link. Note that the C++ front-end
- no longer actually uses the `assert' macro (instead, it calls
- my_friendly_assert). But all of the back-end files still need this. */
-void
-__eprintf (string, expression, line, filename)
-#ifdef __STDC__
- const char *string;
- const char *expression;
- unsigned line;
- const char *filename;
-#else
- char *string;
- char *expression;
- unsigned line;
- char *filename;
-#endif
-{
- fprintf (stderr, string, expression, line, filename);
- fflush (stderr);
- abort ();
+ /* Put decls on list in reverse order. We will reverse them later if
+ necessary. */
+ TREE_CHAIN (x) = b->names;
+ b->names = x;
+
+ return x;
}
-tree
-convert (type, expr)
- tree type, expr;
+/* Nonzero if the current level needs to have a BLOCK made. */
+
+static int
+kept_level_p ()
{
- register tree e = expr;
- register enum tree_code code = TREE_CODE (type);
+ tree decl;
- if (type == TREE_TYPE (e)
- || TREE_CODE (e) == ERROR_MARK)
- return e;
- if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
- return fold (build1 (NOP_EXPR, type, e));
- if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
- || code == ERROR_MARK)
- return error_mark_node;
- if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
+ for (decl = current_binding_level->names;
+ decl;
+ decl = TREE_CHAIN (decl))
{
- assert ("void value not ignored as it ought to be" == NULL);
- return error_mark_node;
+ if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
+ || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
+ /* Currently, there aren't supposed to be non-artificial names
+ at other than the top block for a function -- they're
+ believed to always be temps. But it's wise to check anyway. */
+ return 1;
}
- if (code == VOID_TYPE)
- return build1 (CONVERT_EXPR, type, e);
- if ((code != RECORD_TYPE)
- && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
- e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
- e);
- if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
- return fold (convert_to_integer (type, e));
- if (code == POINTER_TYPE)
- return fold (convert_to_pointer (type, e));
- if (code == REAL_TYPE)
- return fold (convert_to_real (type, e));
- if (code == COMPLEX_TYPE)
- return fold (convert_to_complex (type, e));
- if (code == RECORD_TYPE)
- return fold (ffecom_convert_to_complex_ (type, e));
-
- assert ("conversion to non-scalar type requested" == NULL);
- return error_mark_node;
+ return 0;
}
-/* integrate_decl_tree calls this function, but since we don't use the
- DECL_LANG_SPECIFIC field, this is a no-op. */
+/* Enter a new binding level.
+ If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
+ not for that of tags. */
void
-copy_lang_decl (node)
- tree node UNUSED;
+pushlevel (tag_transparent)
+ int tag_transparent;
{
-}
-
-/* Return the list of declarations of the current level.
- Note that this list is in reverse order unless/until
- you nreverse it; and when you do nreverse it, you must
- store the result back using `storedecls' or you will lose. */
+ register struct binding_level *newlevel = NULL_BINDING_LEVEL;
-tree
-getdecls ()
-{
- return current_binding_level->names;
-}
+ assert (! tag_transparent);
-/* Nonzero if we are currently in the global binding level. */
+ if (current_binding_level == global_binding_level)
+ {
+ named_labels = 0;
+ }
-int
-global_bindings_p ()
-{
- return current_binding_level == global_binding_level;
-}
+ /* Reuse or create a struct for this binding level. */
-/* Insert BLOCK at the end of the list of subblocks of the
- current binding level. This is used when a BIND_EXPR is expanded,
- to handle the BLOCK node inside the BIND_EXPR. */
+ if (free_binding_level)
+ {
+ newlevel = free_binding_level;
+ free_binding_level = free_binding_level->level_chain;
+ }
+ else
+ {
+ newlevel = make_binding_level ();
+ }
-void
-incomplete_type_error (value, type)
- tree value UNUSED;
- tree type;
-{
- if (TREE_CODE (type) == ERROR_MARK)
- return;
+ /* Add this level to the front of the chain (stack) of levels that
+ are active. */
- assert ("incomplete type?!?" == NULL);
+ *newlevel = clear_binding_level;
+ newlevel->level_chain = current_binding_level;
+ current_binding_level = newlevel;
}
+/* Set the BLOCK node for the innermost scope
+ (the one we are currently in). */
+
void
-init_decl_processing ()
+set_block (block)
+ register tree block;
{
- malloc_init ();
- ffe_init_0 ();
+ current_binding_level->this_block = block;
+ current_binding_level->names = chainon (current_binding_level->names,
+ BLOCK_VARS (block));
+ current_binding_level->blocks = chainon (current_binding_level->blocks,
+ BLOCK_SUBBLOCKS (block));
}
-void
-init_lex ()
-{
-#if BUILT_FOR_270
- extern void (*print_error_function) (char *);
-#endif
+/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
- /* Make identifier nodes long enough for the language-specific slots. */
- set_identifier_size (sizeof (struct lang_identifier));
- decl_printable_name = lang_printable_name;
-#if BUILT_FOR_270
- print_error_function = lang_print_error_function;
-#endif
-}
+/* Can't 'yydebug' a front end not generated by yacc/bison! */
void
-insert_block (block)
- tree block;
+set_yydebug (value)
+ int value;
{
- TREE_USED (block) = 1;
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
+ if (value)
+ fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
}
-int
-lang_decode_option (p)
- char *p;
+tree
+signed_or_unsigned_type (unsignedp, type)
+ int unsignedp;
+ tree type;
{
- return ffe_decode_option (p);
+ tree type2;
+
+ if (! INTEGRAL_TYPE_P (type))
+ return type;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+ if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
+ return (unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node);
+
+ type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
+ if (type2 == NULL_TREE)
+ return type;
+
+ return type2;
}
-void
-lang_finish ()
+tree
+signed_type (type)
+ tree type;
{
- ffe_terminate_0 ();
+ tree type1 = TYPE_MAIN_VARIANT (type);
+ ffeinfoKindtype kt;
+ tree type2;
- if (ffe_is_ffedebug ())
- malloc_pool_display (malloc_pool_image ());
+ if (type1 == unsigned_char_type_node || type1 == char_type_node)
+ return signed_char_type_node;
+ if (type1 == unsigned_type_node)
+ return integer_type_node;
+ if (type1 == short_unsigned_type_node)
+ return short_integer_type_node;
+ if (type1 == long_unsigned_type_node)
+ return long_integer_type_node;
+ if (type1 == long_long_unsigned_type_node)
+ return long_long_integer_type_node;
+#if 0 /* gcc/c-* files only */
+ if (type1 == unsigned_intDI_type_node)
+ return intDI_type_node;
+ if (type1 == unsigned_intSI_type_node)
+ return intSI_type_node;
+ if (type1 == unsigned_intHI_type_node)
+ return intHI_type_node;
+ if (type1 == unsigned_intQI_type_node)
+ return intQI_type_node;
+#endif
+
+ type2 = type_for_size (TYPE_PRECISION (type1), 0);
+ if (type2 != NULL_TREE)
+ return type2;
+
+ for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ {
+ type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
+
+ if (type1 == type2)
+ return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ }
+
+ return type;
}
-char *
-lang_identify ()
-{
- return "f77";
-}
+/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
+ or validate its data type for an `if' or `while' statement or ?..: exp.
-void
-lang_init ()
-{
- extern FILE *finput; /* Don't pollute com.h with this. */
+ This preparation consists of taking the ordinary
+ representation of an expression expr and producing a valid tree
+ boolean expression describing whether expr is nonzero. We could
+ simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
+ but we optimize comparisons, &&, ||, and !.
- /* If the file is output from cpp, it should contain a first line
- `# 1 "real-filename"', and the current design of gcc (toplev.c
- in particular and the way it sets up information relied on by
- INCLUDE) requires that we read this now, and store the
- "real-filename" info in master_input_filename. Ask the lexer
- to try doing this. */
- ffelex_hash_kludge (finput);
-}
+ The resulting type should always be `integer_type_node'. */
-int
-mark_addressable (exp)
- tree exp;
+tree
+truthvalue_conversion (expr)
+ tree expr;
{
- register tree x = exp;
- while (1)
- switch (TREE_CODE (x))
- {
- case ADDR_EXPR:
- case COMPONENT_REF:
- case ARRAY_REF:
- x = TREE_OPERAND (x, 0);
- break;
+ if (TREE_CODE (expr) == ERROR_MARK)
+ return expr;
- case CONSTRUCTOR:
- TREE_ADDRESSABLE (x) = 1;
- return 1;
+#if 0 /* This appears to be wrong for C++. */
+ /* These really should return error_mark_node after 2.4 is stable.
+ But not all callers handle ERROR_MARK properly. */
+ switch (TREE_CODE (TREE_TYPE (expr)))
+ {
+ case RECORD_TYPE:
+ error ("struct type value used where scalar is required");
+ return integer_zero_node;
- case VAR_DECL:
- case CONST_DECL:
- case PARM_DECL:
- case RESULT_DECL:
- if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
- && DECL_NONLOCAL (x))
- {
- if (TREE_PUBLIC (x))
- {
- assert ("address of global register var requested" == NULL);
- return 0;
- }
- assert ("address of register variable requested" == NULL);
- }
- else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
- {
- if (TREE_PUBLIC (x))
- {
- assert ("address of global register var requested" == NULL);
- return 0;
- }
- assert ("address of register var requested" == NULL);
- }
- put_var_into_stack (x);
+ case UNION_TYPE:
+ error ("union type value used where scalar is required");
+ return integer_zero_node;
- /* drops in */
- case FUNCTION_DECL:
- TREE_ADDRESSABLE (x) = 1;
-#if 0 /* poplevel deals with this now. */
- if (DECL_CONTEXT (x) == 0)
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
-#endif
+ case ARRAY_TYPE:
+ error ("array type value used where scalar is required");
+ return integer_zero_node;
- default:
- return 1;
- }
-}
+ default:
+ break;
+ }
+#endif /* 0 */
-/* If DECL has a cleanup, build and return that cleanup here.
- This is a callback called by expand_expr. */
+ switch (TREE_CODE (expr))
+ {
+ /* It is simpler and generates better code to have only TRUTH_*_EXPR
+ or comparison expressions as truth values at this level. */
+#if 0
+ case COMPONENT_REF:
+ /* A one-bit unsigned bit-field is already acceptable. */
+ if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
+ && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
+ return expr;
+ break;
+#endif
-tree
-maybe_build_cleanup (decl)
- tree decl UNUSED;
-{
- /* There are no cleanups in Fortran. */
- return NULL_TREE;
-}
+ case EQ_EXPR:
+ /* It is simpler and generates better code to have only TRUTH_*_EXPR
+ or comparison expressions as truth values at this level. */
+#if 0
+ if (integer_zerop (TREE_OPERAND (expr, 1)))
+ return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
+#endif
+ case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
+ case TRUTH_ANDIF_EXPR:
+ case TRUTH_ORIF_EXPR:
+ case TRUTH_AND_EXPR:
+ case TRUTH_OR_EXPR:
+ case TRUTH_XOR_EXPR:
+ TREE_TYPE (expr) = integer_type_node;
+ return expr;
-/* Exit a binding level.
- Pop the level off, and restore the state of the identifier-decl mappings
- that were in effect when this level was entered.
+ case ERROR_MARK:
+ return expr;
- If KEEP is nonzero, this level had explicit declarations, so
- and create a "block" (a BLOCK node) for the level
- to record its declarations and subblocks for symbol table output.
+ case INTEGER_CST:
+ return integer_zerop (expr) ? integer_zero_node : integer_one_node;
- If FUNCTIONBODY is nonzero, this level is the body of a function,
- so create a block as if KEEP were set and also clear out all
- label names.
+ case REAL_CST:
+ return real_zerop (expr) ? integer_zero_node : integer_one_node;
- If REVERSE is nonzero, reverse the order of decls before putting
- them into the BLOCK. */
+ case ADDR_EXPR:
+ if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
+ return build (COMPOUND_EXPR, integer_type_node,
+ TREE_OPERAND (expr, 0), integer_one_node);
+ else
+ return integer_one_node;
-tree
-poplevel (keep, reverse, functionbody)
- int keep;
- int reverse;
- int functionbody;
-{
- register tree link;
- /* The chain of decls was accumulated in reverse order. Put it into forward
- order, just for cleanliness. */
- tree decls;
- tree subblocks = current_binding_level->blocks;
- tree block = 0;
- tree decl;
- int block_previously_created;
+ case COMPLEX_EXPR:
+ return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
+ ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
+ integer_type_node,
+ truthvalue_conversion (TREE_OPERAND (expr, 0)),
+ truthvalue_conversion (TREE_OPERAND (expr, 1)));
- /* Get the decls in the order they were written. Usually
- current_binding_level->names is in reverse order. But parameter decls
- were previously put in forward order. */
+ case NEGATE_EXPR:
+ case ABS_EXPR:
+ case FLOAT_EXPR:
+ case FFS_EXPR:
+ /* These don't change whether an object is non-zero or zero. */
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
- if (reverse)
- current_binding_level->names
- = decls = nreverse (current_binding_level->names);
- else
- decls = current_binding_level->names;
+ case LROTATE_EXPR:
+ case RROTATE_EXPR:
+ /* These don't change whether an object is zero or non-zero, but
+ we can't ignore them if their second arg has side-effects. */
+ if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
+ return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
+ truthvalue_conversion (TREE_OPERAND (expr, 0)));
+ else
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
- /* Output any nested inline functions within this block if they weren't
- already output. */
+ case COND_EXPR:
+ /* Distribute the conversion into the arms of a COND_EXPR. */
+ return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
+ truthvalue_conversion (TREE_OPERAND (expr, 1)),
+ truthvalue_conversion (TREE_OPERAND (expr, 2))));
- for (decl = decls; decl; decl = TREE_CHAIN (decl))
- if (TREE_CODE (decl) == FUNCTION_DECL
- && !TREE_ASM_WRITTEN (decl)
- && DECL_INITIAL (decl) != 0
- && TREE_ADDRESSABLE (decl))
- {
- /* If this decl was copied from a file-scope decl on account of a
- block-scope extern decl, propagate TREE_ADDRESSABLE to the
- file-scope decl. */
- if (DECL_ABSTRACT_ORIGIN (decl) != 0)
- TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
- else
- {
- push_function_context ();
- output_inline_function (decl);
- pop_function_context ();
- }
- }
+ case CONVERT_EXPR:
+ /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
+ since that affects how `default_conversion' will behave. */
+ if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
+ || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
+ break;
+ /* fall through... */
+ case NOP_EXPR:
+ /* If this is widening the argument, we can ignore it. */
+ if (TYPE_PRECISION (TREE_TYPE (expr))
+ >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
+ return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ break;
- /* If there were any declarations or structure tags in that level, or if
- this level is a function body, create a BLOCK to record them for the
- life of this function. */
+ case MINUS_EXPR:
+ /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
+ this case. */
+ if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
+ && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
+ break;
+ /* fall through... */
+ case BIT_XOR_EXPR:
+ /* This and MINUS_EXPR can be changed into a comparison of the
+ two objects. */
+ if (TREE_TYPE (TREE_OPERAND (expr, 0))
+ == TREE_TYPE (TREE_OPERAND (expr, 1)))
+ return ffecom_2 (NE_EXPR, integer_type_node,
+ TREE_OPERAND (expr, 0),
+ TREE_OPERAND (expr, 1));
+ return ffecom_2 (NE_EXPR, integer_type_node,
+ TREE_OPERAND (expr, 0),
+ fold (build1 (NOP_EXPR,
+ TREE_TYPE (TREE_OPERAND (expr, 0)),
+ TREE_OPERAND (expr, 1))));
- block = 0;
- block_previously_created = (current_binding_level->this_block != 0);
- if (block_previously_created)
- block = current_binding_level->this_block;
- else if (keep || functionbody)
- block = make_node (BLOCK);
- if (block != 0)
- {
- BLOCK_VARS (block) = decls;
- BLOCK_SUBBLOCKS (block) = subblocks;
- remember_end_note (block);
- }
+ case BIT_AND_EXPR:
+ if (integer_onep (TREE_OPERAND (expr, 1)))
+ return expr;
+ break;
- /* In each subblock, record that this is its superior. */
+ case MODIFY_EXPR:
+#if 0 /* No such thing in Fortran. */
+ if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
+ warning ("suggest parentheses around assignment used as truth value");
+#endif
+ break;
- for (link = subblocks; link; link = TREE_CHAIN (link))
- BLOCK_SUPERCONTEXT (link) = block;
+ default:
+ break;
+ }
- /* Clear out the meanings of the local variables of this level. */
+ if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
+ return (ffecom_2
+ ((TREE_SIDE_EFFECTS (expr)
+ ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
+ integer_type_node,
+ truthvalue_conversion (ffecom_1 (REALPART_EXPR,
+ TREE_TYPE (TREE_TYPE (expr)),
+ expr)),
+ truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (expr)),
+ expr))));
- for (link = decls; link; link = TREE_CHAIN (link))
- {
- if (DECL_NAME (link) != 0)
- {
- /* If the ident. was used or addressed via a local extern decl,
- don't forget that fact. */
- if (DECL_EXTERNAL (link))
- {
- if (TREE_USED (link))
- TREE_USED (DECL_NAME (link)) = 1;
- if (TREE_ADDRESSABLE (link))
- TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
- }
- IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
- }
- }
+ return ffecom_2 (NE_EXPR, integer_type_node,
+ expr,
+ convert (TREE_TYPE (expr), integer_zero_node));
+}
- /* If the level being exited is the top level of a function, check over all
- the labels, and clear out the current (function local) meanings of their
- names. */
+tree
+type_for_mode (mode, unsignedp)
+ enum machine_mode mode;
+ int unsignedp;
+{
+ int i;
+ int j;
+ tree t;
- if (functionbody)
- {
- /* If this is the top level block of a function, the vars are the
- function's parameters. Don't leave them in the BLOCK because they
- are found in the FUNCTION_DECL instead. */
+ if (mode == TYPE_MODE (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
- BLOCK_VARS (block) = 0;
- }
+ if (mode == TYPE_MODE (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
- /* Pop the current level, and free the structure for reuse. */
+ if (mode == TYPE_MODE (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
- {
- register struct binding_level *level = current_binding_level;
- current_binding_level = current_binding_level->level_chain;
+ if (mode == TYPE_MODE (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- level->level_chain = free_binding_level;
- free_binding_level = level;
- }
+ if (mode == TYPE_MODE (long_long_integer_type_node))
+ return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
- /* Dispose of the block that we just made inside some higher level. */
- if (functionbody)
- DECL_INITIAL (current_function_decl) = block;
- else if (block)
- {
- if (!block_previously_created)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, block);
- }
- /* If we did not make a block for the level just exited, any blocks made
- for inner levels (since they cannot be recorded as subblocks in that
- level) must be carried forward so they will later become subblocks of
- something else. */
- else if (subblocks)
- current_binding_level->blocks
- = chainon (current_binding_level->blocks, subblocks);
+#if HOST_BITS_PER_WIDE_INT >= 64
+ if (mode == TYPE_MODE (intTI_type_node))
+ return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
+#endif
- /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
- binding contour so that they point to the appropriate construct, i.e.
- either to the current FUNCTION_DECL node, or else to the BLOCK node we
- just constructed.
+ if (mode == TYPE_MODE (float_type_node))
+ return float_type_node;
- Note that for tagged types whose scope is just the formal parameter list
- for some function type specification, we can't properly set their
- TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
- FUNCTION_TYPE node readily available to us. For those cases, the
- TYPE_CONTEXTs of the relevant tagged type nodes get set in
- `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
- will represent the "scope" for these "parameter list local" tagged
- types. */
+ if (mode == TYPE_MODE (double_type_node))
+ return double_type_node;
- if (block)
- TREE_USED (block) = 1;
- return block;
-}
+ if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
+ return build_pointer_type (char_type_node);
-void
-print_lang_decl (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
-{
-}
+ if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
+ return build_pointer_type (integer_type_node);
-void
-print_lang_identifier (file, node, indent)
- FILE *file;
- tree node;
- int indent;
-{
- print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
- print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
-}
+ for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
+ for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
+ {
+ if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
+ && (mode == TYPE_MODE (t)))
+ {
+ if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
+ return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
+ else
+ return t;
+ }
+ }
-void
-print_lang_statistics ()
-{
+ return 0;
}
-void
-print_lang_type (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
+tree
+type_for_size (bits, unsignedp)
+ unsigned bits;
+ int unsignedp;
{
-}
+ ffeinfoKindtype kt;
+ tree type_node;
-/* Record a decl-node X as belonging to the current lexical scope.
- Check for errors (such as an incompatible declaration for the same
- name already seen in the same scope).
+ if (bits == TYPE_PRECISION (integer_type_node))
+ return unsignedp ? unsigned_type_node : integer_type_node;
- Returns either X or an old decl for the same name.
- If an old decl is returned, it may have been smashed
- to agree with what X says. */
+ if (bits == TYPE_PRECISION (signed_char_type_node))
+ return unsignedp ? unsigned_char_type_node : signed_char_type_node;
-tree
-pushdecl (x)
- tree x;
-{
- register tree t;
- register tree name = DECL_NAME (x);
- register struct binding_level *b = current_binding_level;
+ if (bits == TYPE_PRECISION (short_integer_type_node))
+ return unsignedp ? short_unsigned_type_node : short_integer_type_node;
- if ((TREE_CODE (x) == FUNCTION_DECL)
- && (DECL_INITIAL (x) == 0)
- && DECL_EXTERNAL (x))
- DECL_CONTEXT (x) = NULL_TREE;
- else
- DECL_CONTEXT (x) = current_function_decl;
+ if (bits == TYPE_PRECISION (long_integer_type_node))
+ return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- if (name)
+ if (bits == TYPE_PRECISION (long_long_integer_type_node))
+ return (unsignedp ? long_long_unsigned_type_node
+ : long_long_integer_type_node);
+
+ for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
{
- if (IDENTIFIER_INVENTED (name))
- {
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (x) = 1;
-#endif
- DECL_IN_SYSTEM_HEADER (x) = 1;
- DECL_IGNORED_P (x) = 1;
- TREE_USED (x) = 1;
- if (TREE_CODE (x) == TYPE_DECL)
- TYPE_DECL_SUPPRESS_DEBUG (x) = 1;
- }
+ type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
- t = lookup_name_current_level (name);
+ if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
+ return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
+ : type_node;
+ }
- assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
+ return 0;
+}
- /* Don't push non-parms onto list for parms until we understand
- why we're doing this and whether it works. */
+tree
+unsigned_type (type)
+ tree type;
+{
+ tree type1 = TYPE_MAIN_VARIANT (type);
+ ffeinfoKindtype kt;
+ tree type2;
- assert ((b == global_binding_level)
- || !ffecom_transform_only_dummies_
- || TREE_CODE (x) == PARM_DECL);
+ if (type1 == signed_char_type_node || type1 == char_type_node)
+ return unsigned_char_type_node;
+ if (type1 == integer_type_node)
+ return unsigned_type_node;
+ if (type1 == short_integer_type_node)
+ return short_unsigned_type_node;
+ if (type1 == long_integer_type_node)
+ return long_unsigned_type_node;
+ if (type1 == long_long_integer_type_node)
+ return long_long_unsigned_type_node;
+#if 0 /* gcc/c-* files only */
+ if (type1 == intDI_type_node)
+ return unsigned_intDI_type_node;
+ if (type1 == intSI_type_node)
+ return unsigned_intSI_type_node;
+ if (type1 == intHI_type_node)
+ return unsigned_intHI_type_node;
+ if (type1 == intQI_type_node)
+ return unsigned_intQI_type_node;
+#endif
- if ((t != NULL_TREE) && duplicate_decls (x, t))
- return t;
+ type2 = type_for_size (TYPE_PRECISION (type1), 1);
+ if (type2 != NULL_TREE)
+ return type2;
- /* If we are processing a typedef statement, generate a whole new
- ..._TYPE node (which will be just an variant of the existing
- ..._TYPE node with identical properties) and then install the
- TYPE_DECL node generated to represent the typedef name as the
- TYPE_NAME of this brand new (duplicate) ..._TYPE node.
+ for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ {
+ type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
- The whole point here is to end up with a situation where each and every
- ..._TYPE node the compiler creates will be uniquely associated with
- AT MOST one node representing a typedef name. This way, even though
- the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
- (i.e. "typedef name") nodes very early on, later parts of the
- compiler can always do the reverse translation and get back the
- corresponding typedef name. For example, given:
+ if (type1 == type2)
+ return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
+ }
- typedef struct S MY_TYPE; MY_TYPE object;
+ return type;
+}
- Later parts of the compiler might only know that `object' was of type
- `struct S' if if were not for code just below. With this code
- however, later parts of the compiler see something like:
+void
+lang_mark_tree (t)
+ union tree_node *t ATTRIBUTE_UNUSED;
+{
+ if (TREE_CODE (t) == IDENTIFIER_NODE)
+ {
+ struct lang_identifier *i = (struct lang_identifier *) t;
+ ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
+ ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
+ ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
+ }
+ else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
+ ggc_mark (TYPE_LANG_SPECIFIC (t));
+}
- struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
+\f
+#if FFECOM_GCC_INCLUDE
- And they can then deduce (from the node for type struct S') that the
- original object declaration was:
+/* From gcc/cccp.c, the code to handle -I. */
- MY_TYPE object;
+/* Skip leading "./" from a directory name.
+ This may yield the empty string, which represents the current directory. */
- Being able to do this is important for proper support of protoize, and
- also for generating precise symbolic debugging information which
- takes full account of the programmer's (typedef) vocabulary.
+static const char *
+skip_redundant_dir_prefix (const char *dir)
+{
+ while (dir[0] == '.' && dir[1] == '/')
+ for (dir += 2; *dir == '/'; dir++)
+ continue;
+ if (dir[0] == '.' && !dir[1])
+ dir++;
+ return dir;
+}
- Obviously, we don't want to generate a duplicate ..._TYPE node if the
- TYPE_DECL node that we are now processing really represents a
- standard built-in type.
+/* The file_name_map structure holds a mapping of file names for a
+ particular directory. This mapping is read from the file named
+ FILE_NAME_MAP_FILE in that directory. Such a file can be used to
+ map filenames on a file system with severe filename restrictions,
+ such as DOS. The format of the file name map file is just a series
+ of lines with two tokens on each line. The first token is the name
+ to map, and the second token is the actual name to use. */
- Since all standard types are effectively declared at line zero in the
- source file, we can easily check to see if we are working on a
- standard type by checking the current value of lineno. */
+struct file_name_map
+{
+ struct file_name_map *map_next;
+ char *map_from;
+ char *map_to;
+};
- if (TREE_CODE (x) == TYPE_DECL)
- {
- if (DECL_SOURCE_LINE (x) == 0)
- {
- if (TYPE_NAME (TREE_TYPE (x)) == 0)
- TYPE_NAME (TREE_TYPE (x)) = x;
- }
- else if (TREE_TYPE (x) != error_mark_node)
- {
- tree tt = TREE_TYPE (x);
+#define FILE_NAME_MAP_FILE "header.gcc"
- tt = build_type_copy (tt);
- TYPE_NAME (tt) = x;
- TREE_TYPE (x) = tt;
- }
- }
+/* Current maximum length of directory names in the search path
+ for include files. (Altered as we get more of them.) */
- /* This name is new in its binding level. Install the new declaration
- and return it. */
- if (b == global_binding_level)
- IDENTIFIER_GLOBAL_VALUE (name) = x;
- else
- IDENTIFIER_LOCAL_VALUE (name) = x;
- }
+static int max_include_len = 0;
- /* Put decls on list in reverse order. We will reverse them later if
- necessary. */
- TREE_CHAIN (x) = b->names;
- b->names = x;
+struct file_name_list
+ {
+ struct file_name_list *next;
+ char *fname;
+ /* Mapping of file names for this directory. */
+ struct file_name_map *name_map;
+ /* Non-zero if name_map is valid. */
+ int got_name_map;
+ };
- return x;
-}
+static struct file_name_list *include = NULL; /* First dir to search */
+static struct file_name_list *last_include = NULL; /* Last in chain */
-/* Enter a new binding level.
- If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
- not for that of tags. */
+/* I/O buffer structure.
+ The `fname' field is nonzero for source files and #include files
+ and for the dummy text used for -D and -U.
+ It is zero for rescanning results of macro expansion
+ and for expanding macro arguments. */
+#define INPUT_STACK_MAX 400
+static struct file_buf {
+ const char *fname;
+ /* Filename specified with #line command. */
+ const char *nominal_fname;
+ /* Record where in the search path this file was found.
+ For #include_next. */
+ struct file_name_list *dir;
+ ffewhereLine line;
+ ffewhereColumn column;
+} instack[INPUT_STACK_MAX];
-void
-pushlevel (tag_transparent)
- int tag_transparent;
-{
- register struct binding_level *newlevel = NULL_BINDING_LEVEL;
+static int last_error_tick = 0; /* Incremented each time we print it. */
+static int input_file_stack_tick = 0; /* Incremented when status changes. */
- assert (!tag_transparent);
+/* Current nesting level of input sources.
+ `instack[indepth]' is the level currently being read. */
+static int indepth = -1;
- /* Reuse or create a struct for this binding level. */
+typedef struct file_buf FILE_BUF;
- if (free_binding_level)
- {
- newlevel = free_binding_level;
- free_binding_level = free_binding_level->level_chain;
- }
- else
- {
- newlevel = make_binding_level ();
- }
+typedef unsigned char U_CHAR;
- /* Add this level to the front of the chain (stack) of levels that are
- active. */
+/* table to tell if char can be part of a C identifier. */
+U_CHAR is_idchar[256];
+/* table to tell if char can be first char of a c identifier. */
+U_CHAR is_idstart[256];
+/* table to tell if c is horizontal space. */
+U_CHAR is_hor_space[256];
+/* table to tell if c is horizontal or vertical space. */
+static U_CHAR is_space[256];
- *newlevel = clear_binding_level;
- newlevel->level_chain = current_binding_level;
- current_binding_level = newlevel;
-}
+#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
+#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
-/* Set the BLOCK node for the innermost scope
- (the one we are currently in). */
+/* Nonzero means -I- has been seen,
+ so don't look for #include "foo" the source-file directory. */
+static int ignore_srcdir;
-void
-set_block (block)
- register tree block;
-{
- current_binding_level->this_block = block;
-}
+#ifndef INCLUDE_LEN_FUDGE
+#define INCLUDE_LEN_FUDGE 0
+#endif
-/* ~~tree.h SHOULD declare this, because toplev.c references it. */
+static void append_include_chain (struct file_name_list *first,
+ struct file_name_list *last);
+static FILE *open_include_file (char *filename,
+ struct file_name_list *searchptr);
+static void print_containing_files (ffebadSeverity sev);
+static const char *skip_redundant_dir_prefix (const char *);
+static char *read_filename_string (int ch, FILE *f);
+static struct file_name_map *read_name_map (const char *dirname);
-/* Can't 'yydebug' a front end not generated by yacc/bison! */
+/* Append a chain of `struct file_name_list's
+ to the end of the main include chain.
+ FIRST is the beginning of the chain to append, and LAST is the end. */
-void
-set_yydebug (value)
- int value;
+static void
+append_include_chain (first, last)
+ struct file_name_list *first, *last;
{
- if (value)
- fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
-}
+ struct file_name_list *dir;
-tree
-signed_or_unsigned_type (unsignedp, type)
- int unsignedp;
- tree type;
-{
- tree type2;
+ if (!first || !last)
+ return;
- if (! INTEGRAL_TYPE_P (type))
- return type;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
- if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
- return (unsignedp ? long_long_unsigned_type_node
- : long_long_integer_type_node);
+ if (include == 0)
+ include = first;
+ else
+ last_include->next = first;
- type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
- if (type2 == NULL_TREE)
- return type;
+ for (dir = first; ; dir = dir->next) {
+ int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
+ if (len > max_include_len)
+ max_include_len = len;
+ if (dir == last)
+ break;
+ }
- return type2;
+ last->next = NULL;
+ last_include = last;
}
-tree
-signed_type (type)
- tree type;
+/* Try to open include file FILENAME. SEARCHPTR is the directory
+ being tried from the include file search path. This function maps
+ filenames on file systems based on information read by
+ read_name_map. */
+
+static FILE *
+open_include_file (filename, searchptr)
+ char *filename;
+ struct file_name_list *searchptr;
{
- tree type1 = TYPE_MAIN_VARIANT (type);
- ffeinfoKindtype kt;
- tree type2;
+ register struct file_name_map *map;
+ register char *from;
+ char *p, *dir;
- if (type1 == unsigned_char_type_node || type1 == char_type_node)
- return signed_char_type_node;
- if (type1 == unsigned_type_node)
- return integer_type_node;
- if (type1 == short_unsigned_type_node)
- return short_integer_type_node;
- if (type1 == long_unsigned_type_node)
- return long_integer_type_node;
- if (type1 == long_long_unsigned_type_node)
- return long_long_integer_type_node;
-#if 0 /* gcc/c-* files only */
- if (type1 == unsigned_intDI_type_node)
- return intDI_type_node;
- if (type1 == unsigned_intSI_type_node)
- return intSI_type_node;
- if (type1 == unsigned_intHI_type_node)
- return intHI_type_node;
- if (type1 == unsigned_intQI_type_node)
- return intQI_type_node;
-#endif
+ if (searchptr && ! searchptr->got_name_map)
+ {
+ searchptr->name_map = read_name_map (searchptr->fname
+ ? searchptr->fname : ".");
+ searchptr->got_name_map = 1;
+ }
- type2 = type_for_size (TYPE_PRECISION (type1), 0);
- if (type2 != NULL_TREE)
- return type2;
+ /* First check the mapping for the directory we are using. */
+ if (searchptr && searchptr->name_map)
+ {
+ from = filename;
+ if (searchptr->fname)
+ from += strlen (searchptr->fname) + 1;
+ for (map = searchptr->name_map; map; map = map->map_next)
+ {
+ if (! strcmp (map->map_from, from))
+ {
+ /* Found a match. */
+ return fopen (map->map_to, "r");
+ }
+ }
+ }
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ /* Try to find a mapping file for the particular directory we are
+ looking in. Thus #include <sys/types.h> will look up sys/types.h
+ in /usr/include/header.gcc and look up types.h in
+ /usr/include/sys/header.gcc. */
+ p = strrchr (filename, '/');
+#ifdef DIR_SEPARATOR
+ if (! p) p = strrchr (filename, DIR_SEPARATOR);
+ else {
+ char *tmp = strrchr (filename, DIR_SEPARATOR);
+ if (tmp != NULL && tmp > p) p = tmp;
+ }
+#endif
+ if (! p)
+ p = filename;
+ if (searchptr
+ && searchptr->fname
+ && strlen (searchptr->fname) == (size_t) (p - filename)
+ && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
{
- type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
+ /* FILENAME is in SEARCHPTR, which we've already checked. */
+ return fopen (filename, "r");
+ }
- if (type1 == type2)
- return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ if (p == filename)
+ {
+ from = filename;
+ map = read_name_map (".");
+ }
+ else
+ {
+ dir = (char *) xmalloc (p - filename + 1);
+ memcpy (dir, filename, p - filename);
+ dir[p - filename] = '\0';
+ from = p + 1;
+ map = read_name_map (dir);
+ free (dir);
}
+ for (; map; map = map->map_next)
+ if (! strcmp (map->map_from, from))
+ return fopen (map->map_to, "r");
- return type;
+ return fopen (filename, "r");
}
-/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
- or validate its data type for an `if' or `while' statement or ?..: exp.
+/* Print the file names and line numbers of the #include
+ commands which led to the current file. */
- This preparation consists of taking the ordinary
- representation of an expression expr and producing a valid tree
- boolean expression describing whether expr is nonzero. We could
- simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
- but we optimize comparisons, &&, ||, and !.
+static void
+print_containing_files (ffebadSeverity sev)
+{
+ FILE_BUF *ip = NULL;
+ int i;
+ int first = 1;
+ const char *str1;
+ const char *str2;
- The resulting type should always be `integer_type_node'. */
+ /* If stack of files hasn't changed since we last printed
+ this info, don't repeat it. */
+ if (last_error_tick == input_file_stack_tick)
+ return;
-tree
-truthvalue_conversion (expr)
- tree expr;
-{
- if (TREE_CODE (expr) == ERROR_MARK)
- return expr;
+ for (i = indepth; i >= 0; i--)
+ if (instack[i].fname != NULL) {
+ ip = &instack[i];
+ break;
+ }
-#if 0 /* This appears to be wrong for C++. */
- /* These really should return error_mark_node after 2.4 is stable.
- But not all callers handle ERROR_MARK properly. */
- switch (TREE_CODE (TREE_TYPE (expr)))
- {
- case RECORD_TYPE:
- error ("struct type value used where scalar is required");
- return integer_zero_node;
+ /* Give up if we don't find a source file. */
+ if (ip == NULL)
+ return;
- case UNION_TYPE:
- error ("union type value used where scalar is required");
- return integer_zero_node;
+ /* Find the other, outer source files. */
+ for (i--; i >= 0; i--)
+ if (instack[i].fname != NULL)
+ {
+ ip = &instack[i];
+ if (first)
+ {
+ first = 0;
+ str1 = "In file included";
+ }
+ else
+ {
+ str1 = "... ...";
+ }
- case ARRAY_TYPE:
- error ("array type value used where scalar is required");
- return integer_zero_node;
+ if (i == 1)
+ str2 = ":";
+ else
+ str2 = "";
- default:
- break;
- }
-#endif /* 0 */
+ ffebad_start_msg ("%A from %B at %0%C", sev);
+ ffebad_here (0, ip->line, ip->column);
+ ffebad_string (str1);
+ ffebad_string (ip->nominal_fname);
+ ffebad_string (str2);
+ ffebad_finish ();
+ }
- switch (TREE_CODE (expr))
- {
- /* It is simpler and generates better code to have only TRUTH_*_EXPR
- or comparison expressions as truth values at this level. */
-#if 0
- case COMPONENT_REF:
- /* A one-bit unsigned bit-field is already acceptable. */
- if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
- && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
- return expr;
- break;
-#endif
+ /* Record we have printed the status as of this time. */
+ last_error_tick = input_file_stack_tick;
+}
- case EQ_EXPR:
- /* It is simpler and generates better code to have only TRUTH_*_EXPR
- or comparison expressions as truth values at this level. */
-#if 0
- if (integer_zerop (TREE_OPERAND (expr, 1)))
- return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
-#endif
- case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
- case TRUTH_ANDIF_EXPR:
- case TRUTH_ORIF_EXPR:
- case TRUTH_AND_EXPR:
- case TRUTH_OR_EXPR:
- case TRUTH_XOR_EXPR:
- TREE_TYPE (expr) = integer_type_node;
- return expr;
+/* Read a space delimited string of unlimited length from a stdio
+ file. */
- case ERROR_MARK:
- return expr;
+static char *
+read_filename_string (ch, f)
+ int ch;
+ FILE *f;
+{
+ char *alloc, *set;
+ int len;
- case INTEGER_CST:
- return integer_zerop (expr) ? integer_zero_node : integer_one_node;
+ len = 20;
+ set = alloc = xmalloc (len + 1);
+ if (! is_space[ch])
+ {
+ *set++ = ch;
+ while ((ch = getc (f)) != EOF && ! is_space[ch])
+ {
+ if (set - alloc == len)
+ {
+ len *= 2;
+ alloc = xrealloc (alloc, len + 1);
+ set = alloc + len / 2;
+ }
+ *set++ = ch;
+ }
+ }
+ *set = '\0';
+ ungetc (ch, f);
+ return alloc;
+}
- case REAL_CST:
- return real_zerop (expr) ? integer_zero_node : integer_one_node;
+/* Read the file name map file for DIRNAME. */
- case ADDR_EXPR:
- if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
- return build (COMPOUND_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0), integer_one_node);
- else
- return integer_one_node;
+static struct file_name_map *
+read_name_map (dirname)
+ const char *dirname;
+{
+ /* This structure holds a linked list of file name maps, one per
+ directory. */
+ struct file_name_map_list
+ {
+ struct file_name_map_list *map_list_next;
+ char *map_list_name;
+ struct file_name_map *map_list_map;
+ };
+ static struct file_name_map_list *map_list;
+ register struct file_name_map_list *map_list_ptr;
+ char *name;
+ FILE *f;
+ size_t dirlen;
+ int separator_needed;
- case COMPLEX_EXPR:
- return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
- ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
- integer_type_node,
- truthvalue_conversion (TREE_OPERAND (expr, 0)),
- truthvalue_conversion (TREE_OPERAND (expr, 1)));
+ dirname = skip_redundant_dir_prefix (dirname);
- case NEGATE_EXPR:
- case ABS_EXPR:
- case FLOAT_EXPR:
- case FFS_EXPR:
- /* These don't change whether an object is non-zero or zero. */
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ for (map_list_ptr = map_list; map_list_ptr;
+ map_list_ptr = map_list_ptr->map_list_next)
+ if (! strcmp (map_list_ptr->map_list_name, dirname))
+ return map_list_ptr->map_list_map;
- case LROTATE_EXPR:
- case RROTATE_EXPR:
- /* These don't change whether an object is zero or non-zero, but
- we can't ignore them if their second arg has side-effects. */
- if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
- return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
- truthvalue_conversion (TREE_OPERAND (expr, 0)));
- else
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ map_list_ptr = ((struct file_name_map_list *)
+ xmalloc (sizeof (struct file_name_map_list)));
+ map_list_ptr->map_list_name = xstrdup (dirname);
+ map_list_ptr->map_list_map = NULL;
+
+ dirlen = strlen (dirname);
+ separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
+ name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
+ strcpy (name, dirname);
+ name[dirlen] = '/';
+ strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
+ f = fopen (name, "r");
+ free (name);
+ if (!f)
+ map_list_ptr->map_list_map = NULL;
+ else
+ {
+ int ch;
- case COND_EXPR:
- /* Distribute the conversion into the arms of a COND_EXPR. */
- return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
- truthvalue_conversion (TREE_OPERAND (expr, 1)),
- truthvalue_conversion (TREE_OPERAND (expr, 2))));
+ while ((ch = getc (f)) != EOF)
+ {
+ char *from, *to;
+ struct file_name_map *ptr;
- case CONVERT_EXPR:
- /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
- since that affects how `default_conversion' will behave. */
- if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
- || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
- break;
- /* fall through... */
- case NOP_EXPR:
- /* If this is widening the argument, we can ignore it. */
- if (TYPE_PRECISION (TREE_TYPE (expr))
- >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
- break;
+ if (is_space[ch])
+ continue;
+ from = read_filename_string (ch, f);
+ while ((ch = getc (f)) != EOF && is_hor_space[ch])
+ ;
+ to = read_filename_string (ch, f);
- case MINUS_EXPR:
- /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
- this case. */
- if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
- && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
- break;
- /* fall through... */
- case BIT_XOR_EXPR:
- /* This and MINUS_EXPR can be changed into a comparison of the
- two objects. */
- if (TREE_TYPE (TREE_OPERAND (expr, 0))
- == TREE_TYPE (TREE_OPERAND (expr, 1)))
- return ffecom_2 (NE_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0),
- TREE_OPERAND (expr, 1));
- return ffecom_2 (NE_EXPR, integer_type_node,
- TREE_OPERAND (expr, 0),
- fold (build1 (NOP_EXPR,
- TREE_TYPE (TREE_OPERAND (expr, 0)),
- TREE_OPERAND (expr, 1))));
+ ptr = ((struct file_name_map *)
+ xmalloc (sizeof (struct file_name_map)));
+ ptr->map_from = from;
- case BIT_AND_EXPR:
- if (integer_onep (TREE_OPERAND (expr, 1)))
- return expr;
- break;
+ /* Make the real filename absolute. */
+ if (*to == '/')
+ ptr->map_to = to;
+ else
+ {
+ ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
+ strcpy (ptr->map_to, dirname);
+ ptr->map_to[dirlen] = '/';
+ strcpy (ptr->map_to + dirlen + separator_needed, to);
+ free (to);
+ }
- case MODIFY_EXPR:
-#if 0 /* No such thing in Fortran. */
- if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
- warning ("suggest parentheses around assignment used as truth value");
-#endif
- break;
+ ptr->map_next = map_list_ptr->map_list_map;
+ map_list_ptr->map_list_map = ptr;
- default:
- break;
+ while ((ch = getc (f)) != '\n')
+ if (ch == EOF)
+ break;
+ }
+ fclose (f);
}
- if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
- return (ffecom_2
- ((TREE_SIDE_EFFECTS (expr)
- ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
- integer_type_node,
- truthvalue_conversion (ffecom_1 (REALPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr)),
- truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr))));
+ map_list_ptr->map_list_next = map_list;
+ map_list = map_list_ptr;
- return ffecom_2 (NE_EXPR, integer_type_node,
- expr,
- convert (TREE_TYPE (expr), integer_zero_node));
+ return map_list_ptr->map_list_map;
}
-tree
-type_for_mode (mode, unsignedp)
- enum machine_mode mode;
- int unsignedp;
+static void
+ffecom_file_ (const char *name)
{
- int i;
- int j;
- tree t;
+ FILE_BUF *fp;
- if (mode == TYPE_MODE (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
+ /* Do partial setup of input buffer for the sake of generating
+ early #line directives (when -g is in effect). */
- if (mode == TYPE_MODE (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ fp = &instack[++indepth];
+ memset ((char *) fp, 0, sizeof (FILE_BUF));
+ if (name == NULL)
+ name = "";
+ fp->nominal_fname = fp->fname = name;
+}
- if (mode == TYPE_MODE (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+/* Initialize syntactic classifications of characters. */
- if (mode == TYPE_MODE (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+static void
+ffecom_initialize_char_syntax_ ()
+{
+ register int i;
- if (mode == TYPE_MODE (long_long_integer_type_node))
- return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
+ /*
+ * Set up is_idchar and is_idstart tables. These should be
+ * faster than saying (is_alpha (c) || c == '_'), etc.
+ * Set up these things before calling any routines tthat
+ * refer to them.
+ */
+ for (i = 'a'; i <= 'z'; i++) {
+ is_idchar[i - 'a' + 'A'] = 1;
+ is_idchar[i] = 1;
+ is_idstart[i - 'a' + 'A'] = 1;
+ is_idstart[i] = 1;
+ }
+ for (i = '0'; i <= '9'; i++)
+ is_idchar[i] = 1;
+ is_idchar['_'] = 1;
+ is_idstart['_'] = 1;
- if (mode == TYPE_MODE (float_type_node))
- return float_type_node;
+ /* horizontal space table */
+ is_hor_space[' '] = 1;
+ is_hor_space['\t'] = 1;
+ is_hor_space['\v'] = 1;
+ is_hor_space['\f'] = 1;
+ is_hor_space['\r'] = 1;
- if (mode == TYPE_MODE (double_type_node))
- return double_type_node;
+ is_space[' '] = 1;
+ is_space['\t'] = 1;
+ is_space['\v'] = 1;
+ is_space['\f'] = 1;
+ is_space['\n'] = 1;
+ is_space['\r'] = 1;
+}
- if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
- return build_pointer_type (char_type_node);
+static void
+ffecom_close_include_ (FILE *f)
+{
+ fclose (f);
- if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
- return build_pointer_type (integer_type_node);
+ indepth--;
+ input_file_stack_tick++;
- for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
- for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
- {
- if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
- && (mode == TYPE_MODE (t)))
- if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
- return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
- else
- return t;
- }
+ ffewhere_line_kill (instack[indepth].line);
+ ffewhere_column_kill (instack[indepth].column);
+}
- return 0;
+static int
+ffecom_decode_include_option_ (char *spec)
+{
+ struct file_name_list *dirtmp;
+
+ if (! ignore_srcdir && !strcmp (spec, "-"))
+ ignore_srcdir = 1;
+ else
+ {
+ dirtmp = (struct file_name_list *)
+ xmalloc (sizeof (struct file_name_list));
+ dirtmp->next = 0; /* New one goes on the end */
+ dirtmp->fname = spec;
+ dirtmp->got_name_map = 0;
+ if (spec[0] == 0)
+ error ("Directory name must immediately follow -I");
+ else
+ append_include_chain (dirtmp, dirtmp);
+ }
+ return 1;
}
-tree
-type_for_size (bits, unsignedp)
- unsigned bits;
- int unsignedp;
+/* Open INCLUDEd file. */
+
+static FILE *
+ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
{
- ffeinfoKindtype kt;
- tree type_node;
+ char *fbeg = name;
+ size_t flen = strlen (fbeg);
+ struct file_name_list *search_start = include; /* Chain of dirs to search */
+ struct file_name_list dsp[1]; /* First in chain, if #include "..." */
+ struct file_name_list *searchptr = 0;
+ char *fname; /* Dynamically allocated fname buffer */
+ FILE *f;
+ FILE_BUF *fp;
- if (bits == TYPE_PRECISION (integer_type_node))
- return unsignedp ? unsigned_type_node : integer_type_node;
+ if (flen == 0)
+ return NULL;
- if (bits == TYPE_PRECISION (signed_char_type_node))
- return unsignedp ? unsigned_char_type_node : signed_char_type_node;
+ dsp[0].fname = NULL;
- if (bits == TYPE_PRECISION (short_integer_type_node))
- return unsignedp ? short_unsigned_type_node : short_integer_type_node;
+ /* If -I- was specified, don't search current dir, only spec'd ones. */
+ if (!ignore_srcdir)
+ {
+ for (fp = &instack[indepth]; fp >= instack; fp--)
+ {
+ int n;
+ char *ep;
+ const char *nam;
+
+ if ((nam = fp->nominal_fname) != NULL)
+ {
+ /* Found a named file. Figure out dir of the file,
+ and put it in front of the search list. */
+ dsp[0].next = search_start;
+ search_start = dsp;
+#ifndef VMS
+ ep = strrchr (nam, '/');
+#ifdef DIR_SEPARATOR
+ if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
+ else {
+ char *tmp = strrchr (nam, DIR_SEPARATOR);
+ if (tmp != NULL && tmp > ep) ep = tmp;
+ }
+#endif
+#else /* VMS */
+ ep = strrchr (nam, ']');
+ if (ep == NULL) ep = strrchr (nam, '>');
+ if (ep == NULL) ep = strrchr (nam, ':');
+ if (ep != NULL) ep++;
+#endif /* VMS */
+ if (ep != NULL)
+ {
+ n = ep - nam;
+ dsp[0].fname = (char *) xmalloc (n + 1);
+ strncpy (dsp[0].fname, nam, n);
+ dsp[0].fname[n] = '\0';
+ if (n + INCLUDE_LEN_FUDGE > max_include_len)
+ max_include_len = n + INCLUDE_LEN_FUDGE;
+ }
+ else
+ dsp[0].fname = NULL; /* Current directory */
+ dsp[0].got_name_map = 0;
+ break;
+ }
+ }
+ }
- if (bits == TYPE_PRECISION (long_integer_type_node))
- return unsignedp ? long_unsigned_type_node : long_integer_type_node;
+ /* Allocate this permanently, because it gets stored in the definitions
+ of macros. */
+ fname = xmalloc (max_include_len + flen + 4);
+ /* + 2 above for slash and terminating null. */
+ /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
+ for g77 yet). */
- if (bits == TYPE_PRECISION (long_long_integer_type_node))
- return (unsignedp ? long_long_unsigned_type_node
- : long_long_integer_type_node);
+ /* If specified file name is absolute, just open it. */
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ if (*fbeg == '/'
+#ifdef DIR_SEPARATOR
+ || *fbeg == DIR_SEPARATOR
+#endif
+ )
{
- type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
-
- if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
- return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
- : type_node;
+ strncpy (fname, (char *) fbeg, flen);
+ fname[flen] = 0;
+ f = open_include_file (fname, NULL_PTR);
}
+ else
+ {
+ f = NULL;
- return 0;
-}
+ /* Search directory path, trying to open the file.
+ Copy each filename tried into FNAME. */
-tree
-unsigned_type (type)
- tree type;
-{
- tree type1 = TYPE_MAIN_VARIANT (type);
- ffeinfoKindtype kt;
- tree type2;
+ for (searchptr = search_start; searchptr; searchptr = searchptr->next)
+ {
+ if (searchptr->fname)
+ {
+ /* The empty string in a search path is ignored.
+ This makes it possible to turn off entirely
+ a standard piece of the list. */
+ if (searchptr->fname[0] == 0)
+ continue;
+ strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
+ if (fname[0] && fname[strlen (fname) - 1] != '/')
+ strcat (fname, "/");
+ fname[strlen (fname) + flen] = 0;
+ }
+ else
+ fname[0] = 0;
- if (type1 == signed_char_type_node || type1 == char_type_node)
- return unsigned_char_type_node;
- if (type1 == integer_type_node)
- return unsigned_type_node;
- if (type1 == short_integer_type_node)
- return short_unsigned_type_node;
- if (type1 == long_integer_type_node)
- return long_unsigned_type_node;
- if (type1 == long_long_integer_type_node)
- return long_long_unsigned_type_node;
-#if 0 /* gcc/c-* files only */
- if (type1 == intDI_type_node)
- return unsigned_intDI_type_node;
- if (type1 == intSI_type_node)
- return unsigned_intSI_type_node;
- if (type1 == intHI_type_node)
- return unsigned_intHI_type_node;
- if (type1 == intQI_type_node)
- return unsigned_intQI_type_node;
+ strncat (fname, fbeg, flen);
+#ifdef VMS
+ /* Change this 1/2 Unix 1/2 VMS file specification into a
+ full VMS file specification */
+ if (searchptr->fname && (searchptr->fname[0] != 0))
+ {
+ /* Fix up the filename */
+ hack_vms_include_specification (fname);
+ }
+ else
+ {
+ /* This is a normal VMS filespec, so use it unchanged. */
+ strncpy (fname, (char *) fbeg, flen);
+ fname[flen] = 0;
+#if 0 /* Not for g77. */
+ /* if it's '#include filename', add the missing .h */
+ if (strchr (fname, '.') == NULL)
+ strcat (fname, ".h");
#endif
+ }
+#endif /* VMS */
+ f = open_include_file (fname, searchptr);
+#ifdef EACCES
+ if (f == NULL && errno == EACCES)
+ {
+ print_containing_files (FFEBAD_severityWARNING);
+ ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
+ FFEBAD_severityWARNING);
+ ffebad_string (fname);
+ ffebad_here (0, l, c);
+ ffebad_finish ();
+ }
+#endif
+ if (f != NULL)
+ break;
+ }
+ }
- type2 = type_for_size (TYPE_PRECISION (type1), 1);
- if (type2 != NULL_TREE)
- return type2;
-
- for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
+ if (f == NULL)
{
- type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
+ /* A file that was not found. */
- if (type1 == type2)
- return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
+ strncpy (fname, (char *) fbeg, flen);
+ fname[flen] = 0;
+ print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
+ ffebad_start (FFEBAD_OPEN_INCLUDE);
+ ffebad_here (0, l, c);
+ ffebad_string (fname);
+ ffebad_finish ();
}
- return type;
-}
-
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-\f
-#if FFECOM_GCC_INCLUDE
-
-/* From gcc/cccp.c, the code to handle -I. */
-
-/* Skip leading "./" from a directory name.
- This may yield the empty string, which represents the current directory. */
-
-static char *
-skip_redundant_dir_prefix (char *dir)
-{
- while (dir[0] == '.' && dir[1] == '/')
- for (dir += 2; *dir == '/'; dir++)
- continue;
- if (dir[0] == '.' && !dir[1])
- dir++;
- return dir;
-}
-
-/* The file_name_map structure holds a mapping of file names for a
- particular directory. This mapping is read from the file named
- FILE_NAME_MAP_FILE in that directory. Such a file can be used to
- map filenames on a file system with severe filename restrictions,
- such as DOS. The format of the file name map file is just a series
- of lines with two tokens on each line. The first token is the name
- to map, and the second token is the actual name to use. */
-
-struct file_name_map
-{
- struct file_name_map *map_next;
- char *map_from;
- char *map_to;
-};
-
-#define FILE_NAME_MAP_FILE "header.gcc"
+ if (dsp[0].fname != NULL)
+ free (dsp[0].fname);
-/* Current maximum length of directory names in the search path
- for include files. (Altered as we get more of them.) */
+ if (f == NULL)
+ return NULL;
-static int max_include_len = 0;
+ if (indepth >= (INPUT_STACK_MAX - 1))
+ {
+ print_containing_files (FFEBAD_severityFATAL);
+ ffebad_start_msg ("At %0, INCLUDE nesting too deep",
+ FFEBAD_severityFATAL);
+ ffebad_string (fname);
+ ffebad_here (0, l, c);
+ ffebad_finish ();
+ return NULL;
+ }
-struct file_name_list
- {
- struct file_name_list *next;
- char *fname;
- /* Mapping of file names for this directory. */
- struct file_name_map *name_map;
- /* Non-zero if name_map is valid. */
- int got_name_map;
- };
+ instack[indepth].line = ffewhere_line_use (l);
+ instack[indepth].column = ffewhere_column_use (c);
-static struct file_name_list *include = NULL; /* First dir to search */
-static struct file_name_list *last_include = NULL; /* Last in chain */
+ fp = &instack[indepth + 1];
+ memset ((char *) fp, 0, sizeof (FILE_BUF));
+ fp->nominal_fname = fp->fname = fname;
+ fp->dir = searchptr;
-/* I/O buffer structure.
- The `fname' field is nonzero for source files and #include files
- and for the dummy text used for -D and -U.
- It is zero for rescanning results of macro expansion
- and for expanding macro arguments. */
-#define INPUT_STACK_MAX 400
-static struct file_buf {
- char *fname;
- /* Filename specified with #line command. */
- char *nominal_fname;
- /* Record where in the search path this file was found.
- For #include_next. */
- struct file_name_list *dir;
- ffewhereLine line;
- ffewhereColumn column;
-} instack[INPUT_STACK_MAX];
+ indepth++;
+ input_file_stack_tick++;
-static int last_error_tick = 0; /* Incremented each time we print it. */
-static int input_file_stack_tick = 0; /* Incremented when status changes. */
+ return f;
+}
+#endif /* FFECOM_GCC_INCLUDE */
-/* Current nesting level of input sources.
- `instack[indepth]' is the level currently being read. */
-static int indepth = -1;
+/**INDENT* (Do not reformat this comment even with -fca option.)
+ Data-gathering files: Given the source file listed below, compiled with
+ f2c I obtained the output file listed after that, and from the output
+ file I derived the above code.
-typedef struct file_buf FILE_BUF;
+-------- (begin input file to f2c)
+ implicit none
+ character*10 A1,A2
+ complex C1,C2
+ integer I1,I2
+ real R1,R2
+ double precision D1,D2
+C
+ call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
+c /
+ call fooI(I1/I2)
+ call fooR(R1/I1)
+ call fooD(D1/I1)
+ call fooC(C1/I1)
+ call fooR(R1/R2)
+ call fooD(R1/D1)
+ call fooD(D1/D2)
+ call fooD(D1/R1)
+ call fooC(C1/C2)
+ call fooC(C1/R1)
+ call fooZ(C1/D1)
+c **
+ call fooI(I1**I2)
+ call fooR(R1**I1)
+ call fooD(D1**I1)
+ call fooC(C1**I1)
+ call fooR(R1**R2)
+ call fooD(R1**D1)
+ call fooD(D1**D2)
+ call fooD(D1**R1)
+ call fooC(C1**C2)
+ call fooC(C1**R1)
+ call fooZ(C1**D1)
+c FFEINTRIN_impABS
+ call fooR(ABS(R1))
+c FFEINTRIN_impACOS
+ call fooR(ACOS(R1))
+c FFEINTRIN_impAIMAG
+ call fooR(AIMAG(C1))
+c FFEINTRIN_impAINT
+ call fooR(AINT(R1))
+c FFEINTRIN_impALOG
+ call fooR(ALOG(R1))
+c FFEINTRIN_impALOG10
+ call fooR(ALOG10(R1))
+c FFEINTRIN_impAMAX0
+ call fooR(AMAX0(I1,I2))
+c FFEINTRIN_impAMAX1
+ call fooR(AMAX1(R1,R2))
+c FFEINTRIN_impAMIN0
+ call fooR(AMIN0(I1,I2))
+c FFEINTRIN_impAMIN1
+ call fooR(AMIN1(R1,R2))
+c FFEINTRIN_impAMOD
+ call fooR(AMOD(R1,R2))
+c FFEINTRIN_impANINT
+ call fooR(ANINT(R1))
+c FFEINTRIN_impASIN
+ call fooR(ASIN(R1))
+c FFEINTRIN_impATAN
+ call fooR(ATAN(R1))
+c FFEINTRIN_impATAN2
+ call fooR(ATAN2(R1,R2))
+c FFEINTRIN_impCABS
+ call fooR(CABS(C1))
+c FFEINTRIN_impCCOS
+ call fooC(CCOS(C1))
+c FFEINTRIN_impCEXP
+ call fooC(CEXP(C1))
+c FFEINTRIN_impCHAR
+ call fooA(CHAR(I1))
+c FFEINTRIN_impCLOG
+ call fooC(CLOG(C1))
+c FFEINTRIN_impCONJG
+ call fooC(CONJG(C1))
+c FFEINTRIN_impCOS
+ call fooR(COS(R1))
+c FFEINTRIN_impCOSH
+ call fooR(COSH(R1))
+c FFEINTRIN_impCSIN
+ call fooC(CSIN(C1))
+c FFEINTRIN_impCSQRT
+ call fooC(CSQRT(C1))
+c FFEINTRIN_impDABS
+ call fooD(DABS(D1))
+c FFEINTRIN_impDACOS
+ call fooD(DACOS(D1))
+c FFEINTRIN_impDASIN
+ call fooD(DASIN(D1))
+c FFEINTRIN_impDATAN
+ call fooD(DATAN(D1))
+c FFEINTRIN_impDATAN2
+ call fooD(DATAN2(D1,D2))
+c FFEINTRIN_impDCOS
+ call fooD(DCOS(D1))
+c FFEINTRIN_impDCOSH
+ call fooD(DCOSH(D1))
+c FFEINTRIN_impDDIM
+ call fooD(DDIM(D1,D2))
+c FFEINTRIN_impDEXP
+ call fooD(DEXP(D1))
+c FFEINTRIN_impDIM
+ call fooR(DIM(R1,R2))
+c FFEINTRIN_impDINT
+ call fooD(DINT(D1))
+c FFEINTRIN_impDLOG
+ call fooD(DLOG(D1))
+c FFEINTRIN_impDLOG10
+ call fooD(DLOG10(D1))
+c FFEINTRIN_impDMAX1
+ call fooD(DMAX1(D1,D2))
+c FFEINTRIN_impDMIN1
+ call fooD(DMIN1(D1,D2))
+c FFEINTRIN_impDMOD
+ call fooD(DMOD(D1,D2))
+c FFEINTRIN_impDNINT
+ call fooD(DNINT(D1))
+c FFEINTRIN_impDPROD
+ call fooD(DPROD(R1,R2))
+c FFEINTRIN_impDSIGN
+ call fooD(DSIGN(D1,D2))
+c FFEINTRIN_impDSIN
+ call fooD(DSIN(D1))
+c FFEINTRIN_impDSINH
+ call fooD(DSINH(D1))
+c FFEINTRIN_impDSQRT
+ call fooD(DSQRT(D1))
+c FFEINTRIN_impDTAN
+ call fooD(DTAN(D1))
+c FFEINTRIN_impDTANH
+ call fooD(DTANH(D1))
+c FFEINTRIN_impEXP
+ call fooR(EXP(R1))
+c FFEINTRIN_impIABS
+ call fooI(IABS(I1))
+c FFEINTRIN_impICHAR
+ call fooI(ICHAR(A1))
+c FFEINTRIN_impIDIM
+ call fooI(IDIM(I1,I2))
+c FFEINTRIN_impIDNINT
+ call fooI(IDNINT(D1))
+c FFEINTRIN_impINDEX
+ call fooI(INDEX(A1,A2))
+c FFEINTRIN_impISIGN
+ call fooI(ISIGN(I1,I2))
+c FFEINTRIN_impLEN
+ call fooI(LEN(A1))
+c FFEINTRIN_impLGE
+ call fooL(LGE(A1,A2))
+c FFEINTRIN_impLGT
+ call fooL(LGT(A1,A2))
+c FFEINTRIN_impLLE
+ call fooL(LLE(A1,A2))
+c FFEINTRIN_impLLT
+ call fooL(LLT(A1,A2))
+c FFEINTRIN_impMAX0
+ call fooI(MAX0(I1,I2))
+c FFEINTRIN_impMAX1
+ call fooI(MAX1(R1,R2))
+c FFEINTRIN_impMIN0
+ call fooI(MIN0(I1,I2))
+c FFEINTRIN_impMIN1
+ call fooI(MIN1(R1,R2))
+c FFEINTRIN_impMOD
+ call fooI(MOD(I1,I2))
+c FFEINTRIN_impNINT
+ call fooI(NINT(R1))
+c FFEINTRIN_impSIGN
+ call fooR(SIGN(R1,R2))
+c FFEINTRIN_impSIN
+ call fooR(SIN(R1))
+c FFEINTRIN_impSINH
+ call fooR(SINH(R1))
+c FFEINTRIN_impSQRT
+ call fooR(SQRT(R1))
+c FFEINTRIN_impTAN
+ call fooR(TAN(R1))
+c FFEINTRIN_impTANH
+ call fooR(TANH(R1))
+c FFEINTRIN_imp_CMPLX_C
+ call fooC(cmplx(C1,C2))
+c FFEINTRIN_imp_CMPLX_D
+ call fooZ(cmplx(D1,D2))
+c FFEINTRIN_imp_CMPLX_I
+ call fooC(cmplx(I1,I2))
+c FFEINTRIN_imp_CMPLX_R
+ call fooC(cmplx(R1,R2))
+c FFEINTRIN_imp_DBLE_C
+ call fooD(dble(C1))
+c FFEINTRIN_imp_DBLE_D
+ call fooD(dble(D1))
+c FFEINTRIN_imp_DBLE_I
+ call fooD(dble(I1))
+c FFEINTRIN_imp_DBLE_R
+ call fooD(dble(R1))
+c FFEINTRIN_imp_INT_C
+ call fooI(int(C1))
+c FFEINTRIN_imp_INT_D
+ call fooI(int(D1))
+c FFEINTRIN_imp_INT_I
+ call fooI(int(I1))
+c FFEINTRIN_imp_INT_R
+ call fooI(int(R1))
+c FFEINTRIN_imp_REAL_C
+ call fooR(real(C1))
+c FFEINTRIN_imp_REAL_D
+ call fooR(real(D1))
+c FFEINTRIN_imp_REAL_I
+ call fooR(real(I1))
+c FFEINTRIN_imp_REAL_R
+ call fooR(real(R1))
+c
+c FFEINTRIN_imp_INT_D:
+c
+c FFEINTRIN_specIDINT
+ call fooI(IDINT(D1))
+c
+c FFEINTRIN_imp_INT_R:
+c
+c FFEINTRIN_specIFIX
+ call fooI(IFIX(R1))
+c FFEINTRIN_specINT
+ call fooI(INT(R1))
+c
+c FFEINTRIN_imp_REAL_D:
+c
+c FFEINTRIN_specSNGL
+ call fooR(SNGL(D1))
+c
+c FFEINTRIN_imp_REAL_I:
+c
+c FFEINTRIN_specFLOAT
+ call fooR(FLOAT(I1))
+c FFEINTRIN_specREAL
+ call fooR(REAL(I1))
+c
+ end
+-------- (end input file to f2c)
-typedef unsigned char U_CHAR;
+-------- (begin output from providing above input file as input to:
+-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
+-------- -e "s:^#.*$::g"')
-/* table to tell if char can be part of a C identifier. */
-U_CHAR is_idchar[256];
-/* table to tell if char can be first char of a c identifier. */
-U_CHAR is_idstart[256];
-/* table to tell if c is horizontal space. */
-U_CHAR is_hor_space[256];
-/* table to tell if c is horizontal or vertical space. */
-static U_CHAR is_space[256];
+// -- translated by f2c (version 19950223).
+ You must link the resulting object file with the libraries:
+ -lf2c -lm (in that order)
+//
-#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
-#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
-/* Nonzero means -I- has been seen,
- so don't look for #include "foo" the source-file directory. */
-static int ignore_srcdir;
+// f2c.h -- Standard Fortran to C header file //
-#ifndef INCLUDE_LEN_FUDGE
-#define INCLUDE_LEN_FUDGE 0
-#endif
+/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
-static void append_include_chain (struct file_name_list *first,
- struct file_name_list *last);
-static FILE *open_include_file (char *filename,
- struct file_name_list *searchptr);
-static void print_containing_files (ffebadSeverity sev);
-static char *skip_redundant_dir_prefix (char *);
-static char *read_filename_string (int ch, FILE *f);
-static struct file_name_map *read_name_map (char *dirname);
-static char *savestring (char *input);
+ - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
-/* Append a chain of `struct file_name_list's
- to the end of the main include chain.
- FIRST is the beginning of the chain to append, and LAST is the end. */
-static void
-append_include_chain (first, last)
- struct file_name_list *first, *last;
-{
- struct file_name_list *dir;
- if (!first || !last)
- return;
- if (include == 0)
- include = first;
- else
- last_include->next = first;
+// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
+// we assume short, float are OK //
+typedef long int // long int // integer;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int // long int // logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+// typedef long long longint; // // system-dependent //
- for (dir = first; ; dir = dir->next) {
- int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
- if (len > max_include_len)
- max_include_len = len;
- if (dir == last)
- break;
- }
- last->next = NULL;
- last_include = last;
-}
-/* Try to open include file FILENAME. SEARCHPTR is the directory
- being tried from the include file search path. This function maps
- filenames on file systems based on information read by
- read_name_map. */
-static FILE *
-open_include_file (filename, searchptr)
- char *filename;
- struct file_name_list *searchptr;
-{
- register struct file_name_map *map;
- register char *from;
- char *p, *dir;
+// Extern is for use with -E //
- if (searchptr && ! searchptr->got_name_map)
- {
- searchptr->name_map = read_name_map (searchptr->fname
- ? searchptr->fname : ".");
- searchptr->got_name_map = 1;
- }
- /* First check the mapping for the directory we are using. */
- if (searchptr && searchptr->name_map)
- {
- from = filename;
- if (searchptr->fname)
- from += strlen (searchptr->fname) + 1;
- for (map = searchptr->name_map; map; map = map->map_next)
- {
- if (! strcmp (map->map_from, from))
- {
- /* Found a match. */
- return fopen (map->map_to, "r");
- }
- }
- }
- /* Try to find a mapping file for the particular directory we are
- looking in. Thus #include <sys/types.h> will look up sys/types.h
- in /usr/include/header.gcc and look up types.h in
- /usr/include/sys/header.gcc. */
- p = rindex (filename, '/');
-#ifdef DIR_SEPARATOR
- if (! p) p = rindex (filename, DIR_SEPARATOR);
- else {
- char *tmp = rindex (filename, DIR_SEPARATOR);
- if (tmp != NULL && tmp > p) p = tmp;
- }
-#endif
- if (! p)
- p = filename;
- if (searchptr
- && searchptr->fname
- && strlen (searchptr->fname) == (size_t) (p - filename)
- && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
- {
- /* FILENAME is in SEARCHPTR, which we've already checked. */
- return fopen (filename, "r");
- }
- if (p == filename)
- {
- from = filename;
- map = read_name_map (".");
- }
- else
- {
- dir = (char *) xmalloc (p - filename + 1);
- memcpy (dir, filename, p - filename);
- dir[p - filename] = '\0';
- from = p + 1;
- map = read_name_map (dir);
- free (dir);
- }
- for (; map; map = map->map_next)
- if (! strcmp (map->map_from, from))
- return fopen (map->map_to, "r");
+// I/O stuff //
- return fopen (filename, "r");
-}
-/* Print the file names and line numbers of the #include
- commands which led to the current file. */
-static void
-print_containing_files (ffebadSeverity sev)
-{
- FILE_BUF *ip = NULL;
- int i;
- int first = 1;
- char *str1;
- char *str2;
- /* If stack of files hasn't changed since we last printed
- this info, don't repeat it. */
- if (last_error_tick == input_file_stack_tick)
- return;
- for (i = indepth; i >= 0; i--)
- if (instack[i].fname != NULL) {
- ip = &instack[i];
- break;
- }
- /* Give up if we don't find a source file. */
- if (ip == NULL)
- return;
- /* Find the other, outer source files. */
- for (i--; i >= 0; i--)
- if (instack[i].fname != NULL)
- {
- ip = &instack[i];
- if (first)
- {
- first = 0;
- str1 = "In file included";
- }
- else
- {
- str1 = "... ...";
- }
- if (i == 1)
- str2 = ":";
- else
- str2 = "";
+typedef long int // int or long int // flag;
+typedef long int // int or long int // ftnlen;
+typedef long int // int or long int // ftnint;
- ffebad_start_msg ("%A from %B at %0%C", sev);
- ffebad_here (0, ip->line, ip->column);
- ffebad_string (str1);
- ffebad_string (ip->nominal_fname);
- ffebad_string (str2);
- ffebad_finish ();
- }
- /* Record we have printed the status as of this time. */
- last_error_tick = input_file_stack_tick;
-}
+//external read, write//
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
-/* Read a space delimited string of unlimited length from a stdio
- file. */
+//internal read, write//
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
-static char *
-read_filename_string (ch, f)
- int ch;
- FILE *f;
-{
- char *alloc, *set;
- int len;
+//open//
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
- len = 20;
- set = alloc = xmalloc (len + 1);
- if (! is_space[ch])
- {
- *set++ = ch;
- while ((ch = getc (f)) != EOF && ! is_space[ch])
- {
- if (set - alloc == len)
- {
- len *= 2;
- alloc = xrealloc (alloc, len + 1);
- set = alloc + len / 2;
- }
- *set++ = ch;
- }
- }
- *set = '\0';
- ungetc (ch, f);
- return alloc;
-}
+//close//
+typedef struct
+{ flag cerr;
+ ftnint cunit;
+ char *csta;
+} cllist;
+
+//rewind, backspace, endfile//
+typedef struct
+{ flag aerr;
+ ftnint aunit;
+} alist;
+
+// inquire //
+typedef struct
+{ flag inerr;
+ ftnint inunit;
+ char *infile;
+ ftnlen infilen;
+ ftnint *inex; //parameters in standard's order//
+ ftnint *inopen;
+ ftnint *innum;
+ ftnint *innamed;
+ char *inname;
+ ftnlen innamlen;
+ char *inacc;
+ ftnlen inacclen;
+ char *inseq;
+ ftnlen inseqlen;
+ char *indir;
+ ftnlen indirlen;
+ char *infmt;
+ ftnlen infmtlen;
+ char *inform;
+ ftnint informlen;
+ char *inunf;
+ ftnlen inunflen;
+ ftnint *inrecl;
+ ftnint *innrec;
+ char *inblank;
+ ftnlen inblanklen;
+} inlist;
-/* Read the file name map file for DIRNAME. */
-static struct file_name_map *
-read_name_map (dirname)
- char *dirname;
-{
- /* This structure holds a linked list of file name maps, one per
- directory. */
- struct file_name_map_list
- {
- struct file_name_map_list *map_list_next;
- char *map_list_name;
- struct file_name_map *map_list_map;
- };
- static struct file_name_map_list *map_list;
- register struct file_name_map_list *map_list_ptr;
- char *name;
- FILE *f;
- size_t dirlen;
- int separator_needed;
- dirname = skip_redundant_dir_prefix (dirname);
+union Multitype { // for multiple entry points //
+ integer1 g;
+ shortint h;
+ integer i;
+ // longint j; //
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
- for (map_list_ptr = map_list; map_list_ptr;
- map_list_ptr = map_list_ptr->map_list_next)
- if (! strcmp (map_list_ptr->map_list_name, dirname))
- return map_list_ptr->map_list_map;
+typedef union Multitype Multitype;
- map_list_ptr = ((struct file_name_map_list *)
- xmalloc (sizeof (struct file_name_map_list)));
- map_list_ptr->map_list_name = savestring (dirname);
- map_list_ptr->map_list_map = NULL;
+typedef long Long; // No longer used; formerly in Namelist //
- dirlen = strlen (dirname);
- separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
- name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
- strcpy (name, dirname);
- name[dirlen] = '/';
- strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
- f = fopen (name, "r");
- free (name);
- if (!f)
- map_list_ptr->map_list_map = NULL;
- else
- {
- int ch;
+struct Vardesc { // for Namelist //
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
- while ((ch = getc (f)) != EOF)
- {
- char *from, *to;
- struct file_name_map *ptr;
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
- if (is_space[ch])
- continue;
- from = read_filename_string (ch, f);
- while ((ch = getc (f)) != EOF && is_hor_space[ch])
- ;
- to = read_filename_string (ch, f);
- ptr = ((struct file_name_map *)
- xmalloc (sizeof (struct file_name_map)));
- ptr->map_from = from;
- /* Make the real filename absolute. */
- if (*to == '/')
- ptr->map_to = to;
- else
- {
- ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
- strcpy (ptr->map_to, dirname);
- ptr->map_to[dirlen] = '/';
- strcpy (ptr->map_to + dirlen + separator_needed, to);
- free (to);
- }
- ptr->map_next = map_list_ptr->map_list_map;
- map_list_ptr->map_list_map = ptr;
- while ((ch = getc (f)) != '\n')
- if (ch == EOF)
- break;
- }
- fclose (f);
- }
- map_list_ptr->map_list_next = map_list;
- map_list = map_list_ptr;
- return map_list_ptr->map_list_map;
-}
-static char *
-savestring (input)
- char *input;
-{
- unsigned size = strlen (input);
- char *output = xmalloc (size + 1);
- strcpy (output, input);
- return output;
-}
+// procedure parameter types for -A and -C++ //
-static void
-ffecom_file_ (char *name)
-{
- FILE_BUF *fp;
- /* Do partial setup of input buffer for the sake of generating
- early #line directives (when -g is in effect). */
- fp = &instack[++indepth];
- memset ((char *) fp, 0, sizeof (FILE_BUF));
- if (name == NULL)
- name = "";
- fp->nominal_fname = fp->fname = name;
-}
-/* Initialize syntactic classifications of characters. */
+typedef int // Unknown procedure type // (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef // Complex // void (*C_fp)();
+typedef // Double Complex // void (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef // Character // void (*H_fp)();
+typedef // Subroutine // int (*S_fp)();
-static void
-ffecom_initialize_char_syntax_ ()
-{
- register int i;
+// E_fp is for real functions when -R is not specified //
+typedef void C_f; // complex function //
+typedef void H_f; // character function //
+typedef void Z_f; // double complex function //
+typedef doublereal E_f; // real function with -R not specified //
- /*
- * Set up is_idchar and is_idstart tables. These should be
- * faster than saying (is_alpha (c) || c == '_'), etc.
- * Set up these things before calling any routines tthat
- * refer to them.
- */
- for (i = 'a'; i <= 'z'; i++) {
- is_idchar[i - 'a' + 'A'] = 1;
- is_idchar[i] = 1;
- is_idstart[i - 'a' + 'A'] = 1;
- is_idstart[i] = 1;
- }
- for (i = '0'; i <= '9'; i++)
- is_idchar[i] = 1;
- is_idchar['_'] = 1;
- is_idstart['_'] = 1;
+// undef any lower-case symbols that your C compiler predefines, e.g.: //
+
+
+// (No such symbols should be defined in a strict ANSI C compiler.
+ We can avoid trouble with f2c-translated code by using
+ gcc -ansi [-traditional].) //
- /* horizontal space table */
- is_hor_space[' '] = 1;
- is_hor_space['\t'] = 1;
- is_hor_space['\v'] = 1;
- is_hor_space['\f'] = 1;
- is_hor_space['\r'] = 1;
- is_space[' '] = 1;
- is_space['\t'] = 1;
- is_space['\v'] = 1;
- is_space['\f'] = 1;
- is_space['\n'] = 1;
- is_space['\r'] = 1;
-}
-static void
-ffecom_close_include_ (FILE *f)
-{
- fclose (f);
- indepth--;
- input_file_stack_tick++;
- ffewhere_line_kill (instack[indepth].line);
- ffewhere_column_kill (instack[indepth].column);
-}
-static int
-ffecom_decode_include_option_ (char *spec)
-{
- struct file_name_list *dirtmp;
- if (! ignore_srcdir && !strcmp (spec, "-"))
- ignore_srcdir = 1;
- else
- {
- dirtmp = (struct file_name_list *)
- xmalloc (sizeof (struct file_name_list));
- dirtmp->next = 0; /* New one goes on the end */
- if (spec[0] != 0)
- dirtmp->fname = spec;
- else
- fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
- dirtmp->got_name_map = 0;
- append_include_chain (dirtmp, dirtmp);
- }
- return 1;
-}
-/* Open INCLUDEd file. */
-static FILE *
-ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
-{
- char *fbeg = name;
- size_t flen = strlen (fbeg);
- struct file_name_list *search_start = include; /* Chain of dirs to search */
- struct file_name_list dsp[1]; /* First in chain, if #include "..." */
- struct file_name_list *searchptr = 0;
- char *fname; /* Dynamically allocated fname buffer */
- FILE *f;
- FILE_BUF *fp;
- if (flen == 0)
- return NULL;
- dsp[0].fname = NULL;
- /* If -I- was specified, don't search current dir, only spec'd ones. */
- if (!ignore_srcdir)
- {
- for (fp = &instack[indepth]; fp >= instack; fp--)
- {
- int n;
- char *ep;
- char *nam;
- if ((nam = fp->nominal_fname) != NULL)
- {
- /* Found a named file. Figure out dir of the file,
- and put it in front of the search list. */
- dsp[0].next = search_start;
- search_start = dsp;
-#ifndef VMS
- ep = rindex (nam, '/');
-#ifdef DIR_SEPARATOR
- if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
- else {
- char *tmp = rindex (nam, DIR_SEPARATOR);
- if (tmp != NULL && tmp > ep) ep = tmp;
- }
-#endif
-#else /* VMS */
- ep = rindex (nam, ']');
- if (ep == NULL) ep = rindex (nam, '>');
- if (ep == NULL) ep = rindex (nam, ':');
- if (ep != NULL) ep++;
-#endif /* VMS */
- if (ep != NULL)
- {
- n = ep - nam;
- dsp[0].fname = (char *) xmalloc (n + 1);
- strncpy (dsp[0].fname, nam, n);
- dsp[0].fname[n] = '\0';
- if (n + INCLUDE_LEN_FUDGE > max_include_len)
- max_include_len = n + INCLUDE_LEN_FUDGE;
- }
- else
- dsp[0].fname = NULL; /* Current directory */
- dsp[0].got_name_map = 0;
- break;
- }
- }
- }
- /* Allocate this permanently, because it gets stored in the definitions
- of macros. */
- fname = xmalloc (max_include_len + flen + 4);
- /* + 2 above for slash and terminating null. */
- /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
- for g77 yet). */
- /* If specified file name is absolute, just open it. */
- if (*fbeg == '/'
-#ifdef DIR_SEPARATOR
- || *fbeg == DIR_SEPARATOR
-#endif
- )
- {
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
- f = open_include_file (fname, NULL_PTR);
- }
- else
- {
- f = NULL;
- /* Search directory path, trying to open the file.
- Copy each filename tried into FNAME. */
- for (searchptr = search_start; searchptr; searchptr = searchptr->next)
- {
- if (searchptr->fname)
- {
- /* The empty string in a search path is ignored.
- This makes it possible to turn off entirely
- a standard piece of the list. */
- if (searchptr->fname[0] == 0)
- continue;
- strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
- if (fname[0] && fname[strlen (fname) - 1] != '/')
- strcat (fname, "/");
- fname[strlen (fname) + flen] = 0;
- }
- else
- fname[0] = 0;
- strncat (fname, fbeg, flen);
-#ifdef VMS
- /* Change this 1/2 Unix 1/2 VMS file specification into a
- full VMS file specification */
- if (searchptr->fname && (searchptr->fname[0] != 0))
- {
- /* Fix up the filename */
- hack_vms_include_specification (fname);
- }
- else
- {
- /* This is a normal VMS filespec, so use it unchanged. */
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
-#if 0 /* Not for g77. */
- /* if it's '#include filename', add the missing .h */
- if (index (fname, '.') == NULL)
- strcat (fname, ".h");
-#endif
- }
-#endif /* VMS */
- f = open_include_file (fname, searchptr);
-#ifdef EACCES
- if (f == NULL && errno == EACCES)
- {
- print_containing_files (FFEBAD_severityWARNING);
- ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
- FFEBAD_severityWARNING);
- ffebad_string (fname);
- ffebad_here (0, l, c);
- ffebad_finish ();
- }
-#endif
- if (f != NULL)
- break;
- }
- }
- if (f == NULL)
- {
- /* A file that was not found. */
- strncpy (fname, (char *) fbeg, flen);
- fname[flen] = 0;
- print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
- ffebad_start (FFEBAD_OPEN_INCLUDE);
- ffebad_here (0, l, c);
- ffebad_string (fname);
- ffebad_finish ();
- }
- if (dsp[0].fname != NULL)
- free (dsp[0].fname);
- if (f == NULL)
- return NULL;
+// Main program // MAIN__()
+{
+ // System generated locals //
+ integer i__1;
+ real r__1, r__2;
+ doublereal d__1, d__2;
+ complex q__1;
+ doublecomplex z__1, z__2, z__3;
+ logical L__1;
+ char ch__1[1];
+
+ // Builtin functions //
+ void c_div();
+ integer pow_ii();
+ double pow_ri(), pow_di();
+ void pow_ci();
+ double pow_dd();
+ void pow_zz();
+ double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
+ asin(), atan(), atan2(), c_abs();
+ void c_cos(), c_exp(), c_log(), r_cnjg();
+ double cos(), cosh();
+ void c_sin(), c_sqrt();
+ double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
+ d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
+ integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
+ logical l_ge(), l_gt(), l_le(), l_lt();
+ integer i_nint();
+ double r_sign();
+
+ // Local variables //
+ extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
+ fool_(), fooz_(), getem_();
+ static char a1[10], a2[10];
+ static complex c1, c2;
+ static doublereal d1, d2;
+ static integer i1, i2;
+ static real r1, r2;
+
+
+ getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
+// / //
+ i__1 = i1 / i2;
+ fooi_(&i__1);
+ r__1 = r1 / i1;
+ foor_(&r__1);
+ d__1 = d1 / i1;
+ food_(&d__1);
+ d__1 = (doublereal) i1;
+ q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
+ fooc_(&q__1);
+ r__1 = r1 / r2;
+ foor_(&r__1);
+ d__1 = r1 / d1;
+ food_(&d__1);
+ d__1 = d1 / d2;
+ food_(&d__1);
+ d__1 = d1 / r1;
+ food_(&d__1);
+ c_div(&q__1, &c1, &c2);
+ fooc_(&q__1);
+ q__1.r = c1.r / r1, q__1.i = c1.i / r1;
+ fooc_(&q__1);
+ z__1.r = c1.r / d1, z__1.i = c1.i / d1;
+ fooz_(&z__1);
+// ** //
+ i__1 = pow_ii(&i1, &i2);
+ fooi_(&i__1);
+ r__1 = pow_ri(&r1, &i1);
+ foor_(&r__1);
+ d__1 = pow_di(&d1, &i1);
+ food_(&d__1);
+ pow_ci(&q__1, &c1, &i1);
+ fooc_(&q__1);
+ d__1 = (doublereal) r1;
+ d__2 = (doublereal) r2;
+ r__1 = pow_dd(&d__1, &d__2);
+ foor_(&r__1);
+ d__2 = (doublereal) r1;
+ d__1 = pow_dd(&d__2, &d1);
+ food_(&d__1);
+ d__1 = pow_dd(&d1, &d2);
+ food_(&d__1);
+ d__2 = (doublereal) r1;
+ d__1 = pow_dd(&d1, &d__2);
+ food_(&d__1);
+ z__2.r = c1.r, z__2.i = c1.i;
+ z__3.r = c2.r, z__3.i = c2.i;
+ pow_zz(&z__1, &z__2, &z__3);
+ q__1.r = z__1.r, q__1.i = z__1.i;
+ fooc_(&q__1);
+ z__2.r = c1.r, z__2.i = c1.i;
+ z__3.r = r1, z__3.i = 0.;
+ pow_zz(&z__1, &z__2, &z__3);
+ q__1.r = z__1.r, q__1.i = z__1.i;
+ fooc_(&q__1);
+ z__2.r = c1.r, z__2.i = c1.i;
+ z__3.r = d1, z__3.i = 0.;
+ pow_zz(&z__1, &z__2, &z__3);
+ fooz_(&z__1);
+// FFEINTRIN_impABS //
+ r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impACOS //
+ r__1 = acos(r1);
+ foor_(&r__1);
+// FFEINTRIN_impAIMAG //
+ r__1 = r_imag(&c1);
+ foor_(&r__1);
+// FFEINTRIN_impAINT //
+ r__1 = r_int(&r1);
+ foor_(&r__1);
+// FFEINTRIN_impALOG //
+ r__1 = log(r1);
+ foor_(&r__1);
+// FFEINTRIN_impALOG10 //
+ r__1 = r_lg10(&r1);
+ foor_(&r__1);
+// FFEINTRIN_impAMAX0 //
+ r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMAX1 //
+ r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMIN0 //
+ r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMIN1 //
+ r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ foor_(&r__1);
+// FFEINTRIN_impAMOD //
+ r__1 = r_mod(&r1, &r2);
+ foor_(&r__1);
+// FFEINTRIN_impANINT //
+ r__1 = r_nint(&r1);
+ foor_(&r__1);
+// FFEINTRIN_impASIN //
+ r__1 = asin(r1);
+ foor_(&r__1);
+// FFEINTRIN_impATAN //
+ r__1 = atan(r1);
+ foor_(&r__1);
+// FFEINTRIN_impATAN2 //
+ r__1 = atan2(r1, r2);
+ foor_(&r__1);
+// FFEINTRIN_impCABS //
+ r__1 = c_abs(&c1);
+ foor_(&r__1);
+// FFEINTRIN_impCCOS //
+ c_cos(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCEXP //
+ c_exp(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCHAR //
+ *(unsigned char *)&ch__1[0] = i1;
+ fooa_(ch__1, 1L);
+// FFEINTRIN_impCLOG //
+ c_log(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCONJG //
+ r_cnjg(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCOS //
+ r__1 = cos(r1);
+ foor_(&r__1);
+// FFEINTRIN_impCOSH //
+ r__1 = cosh(r1);
+ foor_(&r__1);
+// FFEINTRIN_impCSIN //
+ c_sin(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impCSQRT //
+ c_sqrt(&q__1, &c1);
+ fooc_(&q__1);
+// FFEINTRIN_impDABS //
+ d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
+ food_(&d__1);
+// FFEINTRIN_impDACOS //
+ d__1 = acos(d1);
+ food_(&d__1);
+// FFEINTRIN_impDASIN //
+ d__1 = asin(d1);
+ food_(&d__1);
+// FFEINTRIN_impDATAN //
+ d__1 = atan(d1);
+ food_(&d__1);
+// FFEINTRIN_impDATAN2 //
+ d__1 = atan2(d1, d2);
+ food_(&d__1);
+// FFEINTRIN_impDCOS //
+ d__1 = cos(d1);
+ food_(&d__1);
+// FFEINTRIN_impDCOSH //
+ d__1 = cosh(d1);
+ food_(&d__1);
+// FFEINTRIN_impDDIM //
+ d__1 = d_dim(&d1, &d2);
+ food_(&d__1);
+// FFEINTRIN_impDEXP //
+ d__1 = exp(d1);
+ food_(&d__1);
+// FFEINTRIN_impDIM //
+ r__1 = r_dim(&r1, &r2);
+ foor_(&r__1);
+// FFEINTRIN_impDINT //
+ d__1 = d_int(&d1);
+ food_(&d__1);
+// FFEINTRIN_impDLOG //
+ d__1 = log(d1);
+ food_(&d__1);
+// FFEINTRIN_impDLOG10 //
+ d__1 = d_lg10(&d1);
+ food_(&d__1);
+// FFEINTRIN_impDMAX1 //
+ d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
+ food_(&d__1);
+// FFEINTRIN_impDMIN1 //
+ d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
+ food_(&d__1);
+// FFEINTRIN_impDMOD //
+ d__1 = d_mod(&d1, &d2);
+ food_(&d__1);
+// FFEINTRIN_impDNINT //
+ d__1 = d_nint(&d1);
+ food_(&d__1);
+// FFEINTRIN_impDPROD //
+ d__1 = (doublereal) r1 * r2;
+ food_(&d__1);
+// FFEINTRIN_impDSIGN //
+ d__1 = d_sign(&d1, &d2);
+ food_(&d__1);
+// FFEINTRIN_impDSIN //
+ d__1 = sin(d1);
+ food_(&d__1);
+// FFEINTRIN_impDSINH //
+ d__1 = sinh(d1);
+ food_(&d__1);
+// FFEINTRIN_impDSQRT //
+ d__1 = sqrt(d1);
+ food_(&d__1);
+// FFEINTRIN_impDTAN //
+ d__1 = tan(d1);
+ food_(&d__1);
+// FFEINTRIN_impDTANH //
+ d__1 = tanh(d1);
+ food_(&d__1);
+// FFEINTRIN_impEXP //
+ r__1 = exp(r1);
+ foor_(&r__1);
+// FFEINTRIN_impIABS //
+ i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impICHAR //
+ i__1 = *(unsigned char *)a1;
+ fooi_(&i__1);
+// FFEINTRIN_impIDIM //
+ i__1 = i_dim(&i1, &i2);
+ fooi_(&i__1);
+// FFEINTRIN_impIDNINT //
+ i__1 = i_dnnt(&d1);
+ fooi_(&i__1);
+// FFEINTRIN_impINDEX //
+ i__1 = i_indx(a1, a2, 10L, 10L);
+ fooi_(&i__1);
+// FFEINTRIN_impISIGN //
+ i__1 = i_sign(&i1, &i2);
+ fooi_(&i__1);
+// FFEINTRIN_impLEN //
+ i__1 = i_len(a1, 10L);
+ fooi_(&i__1);
+// FFEINTRIN_impLGE //
+ L__1 = l_ge(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impLGT //
+ L__1 = l_gt(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impLLE //
+ L__1 = l_le(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impLLT //
+ L__1 = l_lt(a1, a2, 10L, 10L);
+ fool_(&L__1);
+// FFEINTRIN_impMAX0 //
+ i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMAX1 //
+ i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMIN0 //
+ i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMIN1 //
+ i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
+ fooi_(&i__1);
+// FFEINTRIN_impMOD //
+ i__1 = i1 % i2;
+ fooi_(&i__1);
+// FFEINTRIN_impNINT //
+ i__1 = i_nint(&r1);
+ fooi_(&i__1);
+// FFEINTRIN_impSIGN //
+ r__1 = r_sign(&r1, &r2);
+ foor_(&r__1);
+// FFEINTRIN_impSIN //
+ r__1 = sin(r1);
+ foor_(&r__1);
+// FFEINTRIN_impSINH //
+ r__1 = sinh(r1);
+ foor_(&r__1);
+// FFEINTRIN_impSQRT //
+ r__1 = sqrt(r1);
+ foor_(&r__1);
+// FFEINTRIN_impTAN //
+ r__1 = tan(r1);
+ foor_(&r__1);
+// FFEINTRIN_impTANH //
+ r__1 = tanh(r1);
+ foor_(&r__1);
+// FFEINTRIN_imp_CMPLX_C //
+ r__1 = c1.r;
+ r__2 = c2.r;
+ q__1.r = r__1, q__1.i = r__2;
+ fooc_(&q__1);
+// FFEINTRIN_imp_CMPLX_D //
+ z__1.r = d1, z__1.i = d2;
+ fooz_(&z__1);
+// FFEINTRIN_imp_CMPLX_I //
+ r__1 = (real) i1;
+ r__2 = (real) i2;
+ q__1.r = r__1, q__1.i = r__2;
+ fooc_(&q__1);
+// FFEINTRIN_imp_CMPLX_R //
+ q__1.r = r1, q__1.i = r2;
+ fooc_(&q__1);
+// FFEINTRIN_imp_DBLE_C //
+ d__1 = (doublereal) c1.r;
+ food_(&d__1);
+// FFEINTRIN_imp_DBLE_D //
+ d__1 = d1;
+ food_(&d__1);
+// FFEINTRIN_imp_DBLE_I //
+ d__1 = (doublereal) i1;
+ food_(&d__1);
+// FFEINTRIN_imp_DBLE_R //
+ d__1 = (doublereal) r1;
+ food_(&d__1);
+// FFEINTRIN_imp_INT_C //
+ i__1 = (integer) c1.r;
+ fooi_(&i__1);
+// FFEINTRIN_imp_INT_D //
+ i__1 = (integer) d1;
+ fooi_(&i__1);
+// FFEINTRIN_imp_INT_I //
+ i__1 = i1;
+ fooi_(&i__1);
+// FFEINTRIN_imp_INT_R //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+// FFEINTRIN_imp_REAL_C //
+ r__1 = c1.r;
+ foor_(&r__1);
+// FFEINTRIN_imp_REAL_D //
+ r__1 = (real) d1;
+ foor_(&r__1);
+// FFEINTRIN_imp_REAL_I //
+ r__1 = (real) i1;
+ foor_(&r__1);
+// FFEINTRIN_imp_REAL_R //
+ r__1 = r1;
+ foor_(&r__1);
+
+// FFEINTRIN_imp_INT_D: //
+
+// FFEINTRIN_specIDINT //
+ i__1 = (integer) d1;
+ fooi_(&i__1);
+
+// FFEINTRIN_imp_INT_R: //
+
+// FFEINTRIN_specIFIX //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+// FFEINTRIN_specINT //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+
+// FFEINTRIN_imp_REAL_D: //
+
+// FFEINTRIN_specSNGL //
+ r__1 = (real) d1;
+ foor_(&r__1);
- if (indepth >= (INPUT_STACK_MAX - 1))
- {
- print_containing_files (FFEBAD_severityFATAL);
- ffebad_start_msg ("At %0, INCLUDE nesting too deep",
- FFEBAD_severityFATAL);
- ffebad_string (fname);
- ffebad_here (0, l, c);
- ffebad_finish ();
- return NULL;
- }
+// FFEINTRIN_imp_REAL_I: //
- instack[indepth].line = ffewhere_line_use (l);
- instack[indepth].column = ffewhere_column_use (c);
+// FFEINTRIN_specFLOAT //
+ r__1 = (real) i1;
+ foor_(&r__1);
+// FFEINTRIN_specREAL //
+ r__1 = (real) i1;
+ foor_(&r__1);
- fp = &instack[indepth + 1];
- memset ((char *) fp, 0, sizeof (FILE_BUF));
- fp->nominal_fname = fp->fname = fname;
- fp->dir = searchptr;
+} // MAIN__ //
- indepth++;
- input_file_stack_tick++;
+-------- (end output file from f2c)
- return f;
-}
-#endif /* FFECOM_GCC_INCLUDE */
+*/
OSDN Git Service
