/* com.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995-1998 Free Software Foundation, Inc.
- Contributed by James Craig Burley (burley@gnu.org).
+ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
+ Free Software Foundation, Inc.
+ Contributed by James Craig Burley.
This file is part of GNU Fortran.
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);
#include "proj.h"
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#include "flags.j"
-#include "rtl.j"
-#include "toplev.j"
-#include "tree.j"
-#include "output.j" /* Must follow tree.j so TREE_CODE is defined! */
-#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. */
/* 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. */
-
-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;
+/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
+ reference it. */
-/* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
- it. */
-
-char *language_string = "GNU F77";
+const char * const language_string = "GNU F77";
/* Stream for reading from the input file. */
FILE *finput;
"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;
#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);
+ bool scalar_args, 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 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 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. */
/* 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,
/* 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,
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
#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)
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
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)
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 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;
}
#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;
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, 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 ();
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_x_ -- Return ptr/length args for char subexpression
-
- tree ptr_arg;
- tree length_arg;
- ffebld expr;
- bool with_null;
- ffecom_char_args_x_(&ptr_arg,&length_arg,expr,with_null);
+/* 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-
newlen = ffetarget_length_character1 (val);
if (with_null)
{
+ /* Begin FFETARGET-NULL-KLUDGE. */
if (newlen != 0)
- ++newlen; /* begin FFETARGET-NULL-KLUDGE. */
+ ++newlen;
}
*length = build_int_2 (newlen, 0);
TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
high = build_int_2 (newlen, 0);
TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
- item = build_string (newlen, /* end FFETARGET-NULL-KLUDGE. */
+ 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);
{
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;
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 altreturning = FALSE; /* This entry point has alternate returns. */
int yes;
int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ const char *old_input_filename = input_filename;
input_filename = ffesymbol_where_filename (fn);
lineno = ffesymbol_where_filelinenum (fn);
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. */
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. */
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);
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;
clear_momentary ();
}
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
finish_function (0);
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], NULL, NULL, NULL, FALSE, TRUE));
-#endif
-
- return t;
- }
+ return ffecom_arrayref_ (NULL_TREE, expr, 0);
case FFEBLD_opUPLUS:
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 */
+ 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);
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:
{
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;
}
&& ffecom_gfrt_complex_[code]),
tree_type, left, right,
dest_tree, dest, dest_used,
- NULL_TREE, FALSE);
+ NULL_TREE, FALSE,
+ 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)));
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 ();
+ 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));
expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
convert (TREE_TYPE (arg3_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,
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);
-
- arg2_tree = ffecom_ptr_to_expr (arg2);
+ result_tree = ffecom_expr_w (NULL_TREE, 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:
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.
+ /* 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. */
+}
--------- (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)
+#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). */
--------- (begin output from providing above input file as input to:
--------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
--------- -e "s:^#.*$::g"')
+#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;
-// -- translated by f2c (version 19950223).
- You must link the resulting object file with the libraries:
- -lf2c -lm (in that order)
-//
+ 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);
-// f2c.h -- Standard Fortran to C header file //
+ if (sgn == 0)
+ return convert (ltype, integer_one_node);
-/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
+ 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. */
- - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
+ 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);
+ }
+ /* 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);
-// 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_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;
+ }
-// Extern is for use with -E //
+ /* 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.
-// I/O stuff //
+ 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 divide;
+ tree basetypeof_l_is_int;
+ tree se;
+ tree t;
+ basetypeof_l_is_int
+ = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
+ se = expand_start_stmt_expr ();
+ 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 */
-typedef long int // int or long int // flag;
-typedef long int // int or long int // ftnlen;
-typedef long int // int or long int // ftnint;
+ 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);
+ t = ffecom_end_compstmt ();
-//external read, write//
-typedef struct
-{ flag cierr;
- ftnint ciunit;
- flag ciend;
- char *cifmt;
- ftnint cirec;
-} cilist;
+ result = expand_end_stmt_expr (se);
-//internal read, write//
-typedef struct
-{ flag icierr;
- char *iciunit;
- flag iciend;
- char *icifmt;
- ftnint icirlen;
- ftnint icirnum;
-} icilist;
+ /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
-//open//
-typedef struct
-{ flag oerr;
- ftnint ounit;
- char *ofnm;
- ftnlen ofnmlen;
- char *osta;
- char *oacc;
- char *ofm;
- ftnint orl;
- char *oblnk;
-} olist;
+ 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;
+ }
-//close//
-typedef struct
-{ flag cerr;
- ftnint cunit;
- char *csta;
-} cllist;
+ return result;
+}
-//rewind, backspace, endfile//
-typedef struct
-{ flag aerr;
- ftnint aunit;
-} alist;
+#endif
+/* ffecom_expr_transform_ -- Transform symbols in expr
-// 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;
+ 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;
-union Multitype { // for multiple entry points //
- integer1 g;
- shortint h;
- integer i;
- // longint j; //
- real r;
- doublereal d;
- complex c;
- doublecomplex z;
- };
+tail_recurse: /* :::::::::::::::::::: */
-typedef union Multitype Multitype;
+ if (expr == NULL)
+ return;
-typedef long Long; // No longer used; formerly in Namelist //
+ 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. */
-struct Vardesc { // for Namelist //
- char *name;
- char *addr;
- ftnlen *dims;
- int type;
- };
-typedef struct Vardesc Vardesc;
+ case FFEBLD_opITEM:
+ ffecom_expr_transform_ (ffebld_head (expr));
+ expr = ffebld_trail (expr);
+ goto tail_recurse; /* :::::::::::::::::::: */
-struct Namelist {
- char *name;
- Vardesc **vars;
- int nvars;
- };
-typedef struct Namelist Namelist;
+ 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, 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;
-// procedure parameter types for -A and -C++ //
+ 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;
-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 FFECOM_f2ccodeFLOAT:
+ *type = make_node (REAL_TYPE);
+ TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
+ layout_type (*type);
+ break;
-// 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 //
+ case FFECOM_f2ccodeDOUBLE:
+ *type = make_node (REAL_TYPE);
+ TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
+ layout_type (*type);
+ break;
-// undef any lower-case symbols that your C compiler predefines, e.g.: //
+ 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;
-// (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].) //
+ 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. */
+
+ suspend_momentary ();
+
+ 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. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static ffesymbol
+ffecom_finish_symbol_transform_ (ffesymbol s)
+{
+ if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
+ 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)
+ {
+ 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);
+ }
+ if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
+ && (ffesymbol_hook (s).decl_tree != error_mark_node))
+ {
+ 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);
+ }
-// Main program // MAIN__()
+ return s;
+}
+
+#endif
+/* Append underscore(s) to name before calling get_identifier. "us"
+ is nonzero if the name already contains an underscore and thus
+ needs two underscores appended. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_get_appended_identifier_ (char us, const char *name)
{
- // 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];
+ int i;
+ char *newname;
+ tree id;
- // 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();
+ newname = xmalloc ((i = strlen (name)) + 1
+ + ffe_is_underscoring ()
+ + us);
+ memcpy (newname, name, i);
+ newname[i] = '_';
+ newname[i + us] = '_';
+ newname[i + 1 + us] = '\0';
+ id = get_identifier (newname);
- // 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;
+ free (newname);
+ return id;
+}
- 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);
+#endif
+/* Decide whether to append underscore to name before calling
+ get_identifier. */
-// FFEINTRIN_imp_REAL_I: //
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_get_external_identifier_ (ffesymbol s)
+{
+ char us;
+ const char *name = ffesymbol_text (s);
-// FFEINTRIN_specFLOAT //
- r__1 = (real) i1;
- foor_(&r__1);
-// FFEINTRIN_specREAL //
- r__1 = (real) i1;
- foor_(&r__1);
+ /* If name is a built-in name, just return it as is. */
-} // MAIN__ //
+ if (!ffe_is_underscoring ()
+ || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
+#if FFETARGET_isENFORCED_MAIN_NAME
+ || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
+#else
+ || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
+#endif
+ || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
+ return get_identifier (name);
--------- (end output file from f2c)
+ us = ffe_is_second_underscore ()
+ ? (strchr (name, '_') != NULL)
+ : 0;
-*/
+ return ffecom_get_appended_identifier_ (us, name);
}
#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). */
+/* Decide whether to append underscore to internal name before calling
+ get_identifier.
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ This is for non-external, top-function-context names only. Transform
+ identifier so it doesn't conflict with the transformed result
+ of using a _different_ external name. E.g. if "CALL FOO" is
+ transformed into "FOO_();", then the variable in "FOO_ = 3"
+ must be transformed into something that does not conflict, since
+ these two things should be independent.
+
+ The transformation is as follows. If the name does not contain
+ an underscore, there is no possible conflict, so just return.
+ If the name does contain an underscore, then transform it just
+ like we transform an external identifier. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_expr_power_integer_ (ffebld left, ffebld right)
+ffecom_get_identifier_ (const char *name)
{
- 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 name does not contain an underscore, just return it as is. */
- if (l == error_mark_node
- || r == error_mark_node)
- return error_mark_node;
+ if (!ffe_is_underscoring ()
+ || (strchr (name, '_') == NULL))
+ return get_identifier (name);
- if (TREE_CODE (r) == INTEGER_CST)
- {
- int sgn = tree_int_cst_sgn (r);
+ return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
+ name);
+}
- if (sgn == 0)
- return convert (ltype, integer_one_node);
+#endif
+/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
- 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. */
+ tree t;
+ ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
+ t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
+ ffesymbol_kindtype(s));
- 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);
- }
+ Call after setting up containing function and getting trees for all
+ other symbols. */
- /* Generate appropriate series of multiplies, preceded
- by divide if the exponent is negative. */
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
+{
+ ffebld expr = ffesymbol_sfexpr (s);
+ tree type;
+ tree func;
+ tree result;
+ bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
+ static bool recurse = FALSE;
+ int yes;
+ int old_lineno = lineno;
+ const char *old_input_filename = input_filename;
- l = save_expr (l);
+ ffecom_nested_entry_ = s;
- 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);
+ /* For now, we don't have a handy pointer to where the sfunc is actually
+ defined, though that should be easy to add to an ffesymbol. (The
+ token/where info available might well point to the place where the type
+ of the sfunc is declared, especially if that precedes the place where
+ the sfunc itself is defined, which is typically the case.) We should
+ put out a null pointer rather than point somewhere wrong, but I want to
+ see how it works at this point. */
- 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);
- }
- }
+ input_filename = ffesymbol_where_filename (s);
+ lineno = ffesymbol_where_filelinenum (s);
- for (;;)
- {
- if (TREE_INT_CST_LOW (r) & 1)
- {
- if (result == NULL_TREE)
- result = l;
- else
- result = ffecom_2 (MULT_EXPR, ltype,
- result,
- l);
- }
+ /* Pretransform the expression so any newly discovered things belong to the
+ outer program unit, not to the statement function. */
- r = ffecom_2 (RSHIFT_EXPR, rtype,
- r,
- integer_one_node);
- if (integer_zerop (r))
- break;
- assert (TREE_CODE (r) == INTEGER_CST);
+ ffecom_expr_transform_ (expr);
- l = save_expr (l);
- l = ffecom_2 (MULT_EXPR, ltype,
- l,
- l);
- }
- return result;
+ /* Make sure no recursive invocation of this fn (a specific case of failing
+ to pretransform an sfunc's expression, i.e. where its expression
+ references another untransformed sfunc) happens. */
+
+ assert (!recurse);
+ recurse = TRUE;
+
+ yes = suspend_momentary ();
+
+ push_f_function_context ();
+
+ if (charfunc)
+ type = void_type_node;
+ else
+ {
+ type = ffecom_tree_type[bt][kt];
+ if (type == NULL_TREE)
+ type = integer_type_node; /* _sym_exec_transition reports
+ error. */
}
- /* 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).
+ start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
+ build_function_type (type, NULL_TREE),
+ 1, /* nested/inline */
+ 0); /* TREE_PUBLIC */
- So, in this case, let the caller generate the call to the
- run-time-library function to evaluate the power for us. */
+ /* We don't worry about COMPLEX return values here, because this is
+ entirely internal to our code, and gcc has the ability to return COMPLEX
+ directly as a value. */
- if (ffecom_transform_only_dummies_)
- return NULL_TREE;
+ yes = suspend_momentary ();
- /* Right-hand operand not a constant, expand in-line code to figure
- out how to do the multiplies, &c.
+ if (charfunc)
+ { /* Prepend arg for where result goes. */
+ tree type;
- The returned expression is expressed this way in GNU C, where l and
- r are the "inputs":
+ type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
- ({ typeof (r) rtmp = r;
- typeof (l) ltmp = l;
- typeof (l) result;
+ result = ffecom_get_invented_identifier ("__g77_%s", "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;
- })
+ ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
- 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. */
+ type = build_pointer_type (type);
+ result = build_decl (PARM_DECL, result, type);
- {
- tree rtmp;
- tree ltmp;
- tree basetypeof_l_is_int;
- tree se;
+ push_parm_decl (result);
+ }
+ else
+ result = NULL_TREE; /* Not ref'd if !charfunc. */
- basetypeof_l_is_int
- = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
+ ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
- se = expand_start_stmt_expr ();
- ffecom_push_calltemps ();
+ resume_momentary (yes);
- 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);
+ store_parm_decls (0);
- 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_start_compstmt ();
- ffecom_pop_calltemps ();
- result = expand_end_stmt_expr (se);
- TREE_SIDE_EFFECTS (result) = 1;
- }
+ if (expr != NULL)
+ {
+ if (charfunc)
+ {
+ ffetargetCharacterSize sz = ffesymbol_size (s);
+ tree result_length;
- return result;
-}
+ result_length = build_int_2 (sz, 0);
+ TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
-#endif
-/* ffecom_expr_transform_ -- Transform symbols in expr
+ ffecom_prepare_let_char_ (sz, expr);
- ffebld expr; // FFE expression.
- ffecom_expr_transform_ (expr);
+ ffecom_prepare_end ();
- Recursive descent on expr while transforming any untransformed SYMTERs. */
+ ffecom_let_char_ (result, result_length, sz, expr);
+ expand_null_return ();
+ }
+ else
+ {
+ ffecom_prepare_expr (expr);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_expr_transform_ (ffebld expr)
-{
- tree t;
- ffesymbol s;
+ ffecom_prepare_end ();
-tail_recurse: /* :::::::::::::::::::: */
+ expand_return (ffecom_modify (NULL_TREE,
+ DECL_RESULT (current_function_decl),
+ ffecom_expr (expr)));
+ }
- if (expr == NULL)
- return;
+ clear_momentary ();
+ }
- 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. */
+ ffecom_end_compstmt ();
- case FFEBLD_opITEM:
- ffecom_expr_transform_ (ffebld_head (expr));
- expr = ffebld_trail (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
+ func = current_function_decl;
+ finish_function (1);
- default:
- break;
- }
+ pop_f_function_context ();
- switch (ffebld_arity (expr))
- {
- case 2:
- ffecom_expr_transform_ (ffebld_left (expr));
- expr = ffebld_right (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
+ resume_momentary (yes);
- case 1:
- expr = ffebld_left (expr);
- goto tail_recurse; /* :::::::::::::::::::: */
+ recurse = FALSE;
- default:
- break;
- }
+ lineno = old_lineno;
+ input_filename = old_input_filename;
- return;
+ ffecom_nested_entry_ = NULL;
+
+ return func;
}
#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)
+static const char *
+ffecom_gfrt_args_ (ffecomGfrt ix)
{
- switch (tcode)
- {
- case FFECOM_f2ccodeCHAR:
- *type = make_signed_type (CHAR_TYPE_SIZE);
- break;
+ return ffecom_gfrt_argstring_[ix];
+}
- case FFECOM_f2ccodeSHORT:
- *type = make_signed_type (SHORT_TYPE_SIZE);
- break;
+#endif
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static tree
+ffecom_gfrt_tree_ (ffecomGfrt ix)
+{
+ if (ffecom_gfrt_[ix] == NULL_TREE)
+ ffecom_make_gfrt_ (ix);
- case FFECOM_f2ccodeINT:
- *type = make_signed_type (INT_TYPE_SIZE);
- break;
+ return ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
+ ffecom_gfrt_[ix]);
+}
- case FFECOM_f2ccodeLONG:
- *type = make_signed_type (LONG_TYPE_SIZE);
- break;
+#endif
+/* Return initialize-to-zero expression for this VAR_DECL. */
- case FFECOM_f2ccodeLONGLONG:
- *type = make_signed_type (LONG_LONG_TYPE_SIZE);
- break;
+#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;
- case FFECOM_f2ccodeCHARPTR:
- *type = build_pointer_type (DEFAULT_SIGNED_CHAR
- ? signed_char_type_node
- : unsigned_char_type_node);
- break;
+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]);
+ }
+}
- case FFECOM_f2ccodeFLOAT:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
- layout_type (*type);
- break;
+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;
+ }
- case FFECOM_f2ccodeDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
+ {
+ /* 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;
+ }
+}
- case FFECOM_f2ccodeLONGDOUBLE:
- *type = make_node (REAL_TYPE);
- TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
- layout_type (*type);
- break;
+static tree
+ffecom_init_zero_ (tree decl)
+{
+ tree init;
+ int incremental = TREE_STATIC (decl);
+ tree type = TREE_TYPE (decl);
- case FFECOM_f2ccodeTWOREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
- break;
+ if (incremental)
+ {
+ make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
+ assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
+ }
- case FFECOM_f2ccodeTWODOUBLEREALS:
- *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
- break;
+ push_momentary ();
- default:
- assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
- *type = error_mark_node;
- return;
+ if ((TREE_CODE (type) != ARRAY_TYPE)
+ && (TREE_CODE (type) != RECORD_TYPE)
+ && (TREE_CODE (type) != UNION_TYPE)
+ && !incremental)
+ 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 ();
- pushdecl (build_decl (TYPE_DECL,
- ffecom_get_invented_identifier ("__g77_f2c_%s",
- name, 0),
- *type));
-}
+ assemble_zeros (int_size_in_bytes (type));
+ init = error_mark_node;
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-/* Set the f2c list-directed-I/O code for whatever (integral) type has the
- given size. */
+ resume_momentary (momentary);
+ }
-static void
-ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
- int code)
-{
- int j;
- tree t;
+ pop_momentary_nofree ();
- 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;
- }
+ return init;
}
#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)
+static tree
+ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
+ tree *maybe_tree)
{
- 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)
- + ffeglobal_common_pad (global)) - 1,
- 0);
+ tree expr_tree;
+ tree length_tree;
- 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);
+ switch (ffebld_op (arg))
+ {
+ case FFEBLD_opCONTER: /* For F90, check 0-length. */
+ if (ffetarget_length_character1
+ (ffebld_constant_character1
+ (ffebld_conter (arg))) == 0)
+ {
+ *maybe_tree = integer_zero_node;
+ return convert (tree_type, integer_zero_node);
+ }
- cbt = start_decl (cbt, FALSE);
- assert (cbt == ffeglobal_hook (global));
+ *maybe_tree = integer_one_node;
+ expr_tree = build_int_2 (*ffetarget_text_character1
+ (ffebld_constant_character1
+ (ffebld_conter (arg))),
+ 0);
+ TREE_TYPE (expr_tree) = tree_type;
+ return expr_tree;
- finish_decl (cbt, NULL_TREE, FALSE);
+ case FFEBLD_opSYMTER:
+ case FFEBLD_opARRAYREF:
+ case FFEBLD_opFUNCREF:
+ case FFEBLD_opSUBSTR:
+ ffecom_char_args_ (&expr_tree, &length_tree, arg);
- return global;
-}
+ if ((expr_tree == error_mark_node)
+ || (length_tree == error_mark_node))
+ {
+ *maybe_tree = error_mark_node;
+ return error_mark_node;
+ }
-#endif
-/* Finish up any untransformed symbols. */
+ if (integer_zerop (length_tree))
+ {
+ *maybe_tree = integer_zero_node;
+ return convert (tree_type, integer_zero_node);
+ }
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffesymbol
-ffecom_finish_symbol_transform_ (ffesymbol s)
-{
- if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
- return s;
+ expr_tree
+ = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
+ expr_tree);
+ expr_tree
+ = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
+ expr_tree,
+ integer_one_node);
+ expr_tree = convert (tree_type, expr_tree);
- /* 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 (TREE_CODE (length_tree) == INTEGER_CST)
+ *maybe_tree = integer_one_node;
+ else /* Must check length at run time. */
+ *maybe_tree
+ = ffecom_truth_value
+ (ffecom_2 (GT_EXPR, integer_type_node,
+ length_tree,
+ ffecom_f2c_ftnlen_zero_node));
+ return expr_tree;
- if (ffesymbol_hook (s).decl_tree == NULL_TREE)
- {
- if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
- && (ffesymbol_kind (s) == FFEINFO_kindFUNCTION
- || ffesymbol_kind (s) == FFEINFO_kindSUBROUTINE))
+ case FFEBLD_opPAREN:
+ case FFEBLD_opCONVERT:
+ if (ffeinfo_size (ffebld_info (arg)) == 0)
{
- /* An unreferenced statement function. If this refers to
- an undeclared array, it'll look like a reference to
- an external function that might not exist. Even if it
- does refer to an non-existent function, it seems silly
- to force a linker error when the function won't actually
- be called. But before the 1998-05-15 change to egcs/gcc
- toplev.c by Mark Mitchell, to fix other problems, this
- didn't actually happen, since gcc would defer nested
- functions to be compiled later only if needed. With that
- change, it makes sense to simply avoid telling the back
- end about the statement (nested) function at all. But
- if -Wunused is specified, might as well warn about it. */
-
- if (warn_unused)
- {
- ffebad_start (FFEBAD_SFUNC_UNUSED);
- ffebad_string (ffesymbol_text (s));
- ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
- ffebad_finish ();
- }
+ *maybe_tree = integer_zero_node;
+ return convert (tree_type, integer_zero_node);
}
- else 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);
- }
+ return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
+ maybe_tree);
- if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
- && (ffesymbol_hook (s).decl_tree != error_mark_node))
- {
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
- int yes = suspend_momentary ();
+ case FFEBLD_opCONCATENATE:
+ {
+ tree maybe_left;
+ tree maybe_right;
+ tree expr_left;
+ tree expr_right;
- /* 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));
+ expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
+ &maybe_left);
+ expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
+ &maybe_right);
+ *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
+ maybe_left,
+ maybe_right);
+ expr_tree = ffecom_3 (COND_EXPR, tree_type,
+ maybe_left,
+ expr_left,
+ expr_right);
+ return expr_tree;
+ }
- resume_momentary (yes);
-#endif
+ default:
+ assert ("bad op in ICHAR" == NULL);
+ return error_mark_node;
}
-
- return s;
}
#endif
-/* Append underscore(s) to name before calling get_identifier. "us"
- is nonzero if the name already contains an underscore and thus
- needs two underscores appended. */
+/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
+
+ tree length_arg;
+ ffebld expr;
+ length_arg = ffecom_intrinsic_len_ (expr);
+
+ Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
+ subexpressions by constructing the appropriate tree for the
+ length-of-character-text argument in a calling sequence. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
-ffecom_get_appended_identifier_ (char us, char *name)
+ffecom_intrinsic_len_ (ffebld expr)
{
- int i;
- char *newname;
- tree id;
+ ffetargetCharacter1 val;
+ tree length;
- newname = xmalloc ((i = strlen (name)) + 1
- + ffe_is_underscoring ()
- + us);
- memcpy (newname, name, i);
- newname[i] = '_';
- newname[i + us] = '_';
- newname[i + 1 + us] = '\0';
- id = get_identifier (newname);
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opCONTER:
+ val = ffebld_constant_character1 (ffebld_conter (expr));
+ length = build_int_2 (ffetarget_length_character1 (val), 0);
+ TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
+ break;
- free (newname);
+ case FFEBLD_opSYMTER:
+ {
+ ffesymbol s = ffebld_symter (expr);
+ tree item;
- return id;
-}
+ item = ffesymbol_hook (s).decl_tree;
+ if (item == NULL_TREE)
+ {
+ s = ffecom_sym_transform_ (s);
+ item = ffesymbol_hook (s).decl_tree;
+ }
+ if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
+ {
+ if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
+ length = ffesymbol_hook (s).length_tree;
+ else
+ {
+ length = build_int_2 (ffesymbol_size (s), 0);
+ TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
+ }
+ }
+ else if (item == error_mark_node)
+ length = error_mark_node;
+ else /* FFEINFO_kindFUNCTION: */
+ length = NULL_TREE;
+ }
+ break;
-#endif
-/* Decide whether to append underscore to name before calling
- get_identifier. */
+ case FFEBLD_opARRAYREF:
+ length = ffecom_intrinsic_len_ (ffebld_left (expr));
+ break;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_get_external_identifier_ (ffesymbol s)
-{
- char us;
- char *name = ffesymbol_text (s);
+ case FFEBLD_opSUBSTR:
+ {
+ ffebld start;
+ ffebld end;
+ ffebld thing = ffebld_right (expr);
+ tree start_tree;
+ tree end_tree;
- /* If name is a built-in name, just return it as is. */
+ assert (ffebld_op (thing) == FFEBLD_opITEM);
+ start = ffebld_head (thing);
+ thing = ffebld_trail (thing);
+ assert (ffebld_trail (thing) == NULL);
+ end = ffebld_head (thing);
- if (!ffe_is_underscoring ()
- || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
-#if FFETARGET_isENFORCED_MAIN_NAME
- || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
-#else
- || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
-#endif
- || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
- return get_identifier (name);
+ length = ffecom_intrinsic_len_ (ffebld_left (expr));
- us = ffe_is_second_underscore ()
- ? (strchr (name, '_') != NULL)
- : 0;
+ if (length == error_mark_node)
+ break;
- return ffecom_get_appended_identifier_ (us, name);
-}
+ if (start == NULL)
+ {
+ if (end == NULL)
+ ;
+ else
+ {
+ length = convert (ffecom_f2c_ftnlen_type_node,
+ ffecom_expr (end));
+ }
+ }
+ else
+ {
+ start_tree = convert (ffecom_f2c_ftnlen_type_node,
+ ffecom_expr (start));
-#endif
-/* Decide whether to append underscore to internal name before calling
- get_identifier.
+ if (start_tree == error_mark_node)
+ {
+ length = error_mark_node;
+ break;
+ }
- This is for non-external, top-function-context names only. Transform
- identifier so it doesn't conflict with the transformed result
- of using a _different_ external name. E.g. if "CALL FOO" is
- transformed into "FOO_();", then the variable in "FOO_ = 3"
- must be transformed into something that does not conflict, since
- these two things should be independent.
+ if (end == NULL)
+ {
+ length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
+ ffecom_f2c_ftnlen_one_node,
+ ffecom_2 (MINUS_EXPR,
+ ffecom_f2c_ftnlen_type_node,
+ length,
+ start_tree));
+ }
+ else
+ {
+ end_tree = convert (ffecom_f2c_ftnlen_type_node,
+ ffecom_expr (end));
- The transformation is as follows. If the name does not contain
- an underscore, there is no possible conflict, so just return.
- If the name does contain an underscore, then transform it just
- like we transform an external identifier. */
+ if (end_tree == error_mark_node)
+ {
+ length = error_mark_node;
+ break;
+ }
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_get_identifier_ (char *name)
-{
- /* If name does not contain an underscore, just return it as is. */
+ length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
+ ffecom_f2c_ftnlen_one_node,
+ ffecom_2 (MINUS_EXPR,
+ ffecom_f2c_ftnlen_type_node,
+ end_tree, start_tree));
+ }
+ }
+ }
+ break;
- if (!ffe_is_underscoring ()
- || (strchr (name, '_') == NULL))
- return get_identifier (name);
+ case FFEBLD_opCONCATENATE:
+ length
+ = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
+ ffecom_intrinsic_len_ (ffebld_left (expr)),
+ ffecom_intrinsic_len_ (ffebld_right (expr)));
+ break;
- return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
- name);
+ case FFEBLD_opFUNCREF:
+ case FFEBLD_opCONVERT:
+ length = build_int_2 (ffebld_size (expr), 0);
+ TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
+ break;
+
+ default:
+ assert ("bad op for single char arg expr" == NULL);
+ length = ffecom_f2c_ftnlen_zero_node;
+ break;
+ }
+
+ assert (length != NULL_TREE);
+
+ return length;
}
#endif
-/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
-
- tree t;
- ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
- t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
- ffesymbol_kindtype(s));
+/* Handle CHARACTER assignments.
- Call after setting up containing function and getting trees for all
- other symbols. */
+ Generates code to do the assignment. Used by ordinary assignment
+ statement handler ffecom_let_stmt and by statement-function
+ handler to generate code for a statement function. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
+static void
+ffecom_let_char_ (tree dest_tree, tree dest_length,
+ ffetargetCharacterSize dest_size, ffebld source)
{
- ffebld expr = ffesymbol_sfexpr (s);
- tree type;
- tree func;
- tree result;
- bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
- static bool recurse = FALSE;
- int yes;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ ffecomConcatList_ catlist;
+ tree source_length;
+ tree source_tree;
+ tree expr_tree;
- ffecom_nested_entry_ = s;
+ if ((dest_tree == error_mark_node)
+ || (dest_length == error_mark_node))
+ return;
- /* For now, we don't have a handy pointer to where the sfunc is actually
- defined, though that should be easy to add to an ffesymbol. (The
- token/where info available might well point to the place where the type
- of the sfunc is declared, especially if that precedes the place where
- the sfunc itself is defined, which is typically the case.) We should
- put out a null pointer rather than point somewhere wrong, but I want to
- see how it works at this point. */
+ assert (dest_tree != NULL_TREE);
+ assert (dest_length != NULL_TREE);
- input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
+ /* Source might be an opCONVERT, which just means it is a different size
+ than the destination. Since the underlying implementation here handles
+ that (directly or via the s_copy or s_cat run-time-library functions),
+ we don't need the "convenience" of an opCONVERT that tells us to
+ truncate or blank-pad, particularly since the resulting implementation
+ would probably be slower than otherwise. */
- /* Pretransform the expression so any newly discovered things belong to the
- outer program unit, not to the statement function. */
+ while (ffebld_op (source) == FFEBLD_opCONVERT)
+ source = ffebld_left (source);
- ffecom_expr_transform_ (expr);
+ catlist = ffecom_concat_list_new_ (source, dest_size);
+ switch (ffecom_concat_list_count_ (catlist))
+ {
+ case 0: /* Shouldn't happen, but in case it does... */
+ ffecom_concat_list_kill_ (catlist);
+ source_tree = null_pointer_node;
+ source_length = ffecom_f2c_ftnlen_zero_node;
+ expr_tree = build_tree_list (NULL_TREE, dest_tree);
+ TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
+ TREE_CHAIN (TREE_CHAIN (expr_tree))
+ = build_tree_list (NULL_TREE, dest_length);
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
+ = build_tree_list (NULL_TREE, source_length);
- /* Make sure no recursive invocation of this fn (a specific case of failing
- to pretransform an sfunc's expression, i.e. where its expression
- references another untransformed sfunc) happens. */
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
- assert (!recurse);
- recurse = TRUE;
+ expand_expr_stmt (expr_tree);
- yes = suspend_momentary ();
+ return;
- push_f_function_context ();
+ case 1: /* The (fairly) easy case. */
+ ffecom_char_args_ (&source_tree, &source_length,
+ ffecom_concat_list_expr_ (catlist, 0));
+ ffecom_concat_list_kill_ (catlist);
+ assert (source_tree != NULL_TREE);
+ assert (source_length != NULL_TREE);
- ffecom_push_calltemps ();
-
- if (charfunc)
- type = void_type_node;
- else
- {
- type = ffecom_tree_type[bt][kt];
- if (type == NULL_TREE)
- type = integer_type_node; /* _sym_exec_transition reports
- error. */
- }
+ if ((source_tree == error_mark_node)
+ || (source_length == error_mark_node))
+ return;
- start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
- build_function_type (type, NULL_TREE),
- 1, /* nested/inline */
- 0); /* TREE_PUBLIC */
+ if (dest_size == 1)
+ {
+ dest_tree
+ = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (dest_tree))),
+ dest_tree);
+ dest_tree
+ = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (dest_tree))),
+ dest_tree,
+ integer_one_node);
+ source_tree
+ = ffecom_1 (INDIRECT_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (source_tree))),
+ source_tree);
+ source_tree
+ = ffecom_2 (ARRAY_REF,
+ TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
+ (source_tree))),
+ source_tree,
+ integer_one_node);
- /* We don't worry about COMPLEX return values here, because this is
- entirely internal to our code, and gcc has the ability to return COMPLEX
- directly as a value. */
+ expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
- yes = suspend_momentary ();
+ expand_expr_stmt (expr_tree);
- if (charfunc)
- { /* Prepend arg for where result goes. */
- tree type;
+ return;
+ }
- type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
+ expr_tree = build_tree_list (NULL_TREE, dest_tree);
+ TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
+ TREE_CHAIN (TREE_CHAIN (expr_tree))
+ = build_tree_list (NULL_TREE, dest_length);
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
+ = build_tree_list (NULL_TREE, source_length);
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
- ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
+ expand_expr_stmt (expr_tree);
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
+ return;
- push_parm_decl (result);
+ default: /* Must actually concatenate things. */
+ break;
}
- else
- result = NULL_TREE; /* Not ref'd if !charfunc. */
-
- ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
- resume_momentary (yes);
-
- store_parm_decls (0);
+ /* Heavy-duty concatenation. */
- ffecom_start_compstmt_ ();
+ {
+ int count = ffecom_concat_list_count_ (catlist);
+ int i;
+ tree lengths;
+ tree items;
+ tree length_array;
+ tree item_array;
+ tree citem;
+ tree clength;
- if (expr != NULL)
+#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);
+#else
{
- if (charfunc)
- {
- ffetargetCharacterSize sz = ffesymbol_size (s);
- tree result_length;
-
- result_length = build_int_2 (sz, 0);
- TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
-
- 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)));
-
- clear_momentary ();
+ 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
- ffecom_end_compstmt_ ();
-
- func = current_function_decl;
- finish_function (1);
-
- ffecom_pop_calltemps ();
-
- pop_f_function_context ();
-
- resume_momentary (yes);
-
- recurse = FALSE;
+ for (i = 0; i < count; ++i)
+ {
+ 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);
+ return;
+ }
- lineno = old_lineno;
- input_filename = old_input_filename;
+ 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);
+ 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);
+ }
- ffecom_nested_entry_ = NULL;
+ expr_tree = build_tree_list (NULL_TREE, dest_tree);
+ TREE_CHAIN (expr_tree)
+ = build_tree_list (NULL_TREE,
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (items)),
+ items));
+ TREE_CHAIN (TREE_CHAIN (expr_tree))
+ = build_tree_list (NULL_TREE,
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (lengths)),
+ lengths));
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
+ = 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))));
+ TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
+ = build_tree_list (NULL_TREE, dest_length);
- return func;
-}
+ expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
+ TREE_SIDE_EFFECTS (expr_tree) = 1;
-#endif
+ expand_expr_stmt (expr_tree);
+ }
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static char *
-ffecom_gfrt_args_ (ffecomGfrt ix)
-{
- return ffecom_gfrt_argstring_[ix];
+ ffecom_concat_list_kill_ (catlist);
}
#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_gfrt_tree_ (ffecomGfrt ix)
-{
- if (ffecom_gfrt_[ix] == NULL_TREE)
- ffecom_make_gfrt_ (ix);
+/* ffecom_make_gfrt_ -- Make initial info for run-time routine
- return ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
- ffecom_gfrt_[ix]);
-}
+ ffecomGfrt ix;
+ ffecom_make_gfrt_(ix);
-#endif
-/* Return initialize-to-zero expression for this VAR_DECL. */
+ Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
+ for the indicated run-time routine (ix). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_init_zero_ (tree decl)
+static void
+ffecom_make_gfrt_ (ffecomGfrt ix)
{
- tree init;
- int incremental = TREE_STATIC (decl);
- tree type = TREE_TYPE (decl);
+ tree t;
+ tree ttype;
- if (incremental)
+ switch (ffecom_gfrt_type_[ix])
{
- int momentary = suspend_momentary ();
- push_obstacks_nochange ();
- if (TREE_PERMANENT (decl))
- end_temporary_allocation ();
- make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
- assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
- pop_obstacks ();
- resume_momentary (momentary);
- }
-
- push_momentary ();
+ case FFECOM_rttypeVOID_:
+ ttype = void_type_node;
+ break;
- if ((TREE_CODE (type) != ARRAY_TYPE)
- && (TREE_CODE (type) != RECORD_TYPE)
- && (TREE_CODE (type) != UNION_TYPE)
- && !incremental)
- init = convert (type, integer_zero_node);
- else if (!incremental)
- {
- int momentary = suspend_momentary ();
+ case FFECOM_rttypeVOIDSTAR_:
+ ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
+ break;
- init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
- TREE_CONSTANT (init) = 1;
- TREE_STATIC (init) = 1;
+ case FFECOM_rttypeFTNINT_:
+ ttype = ffecom_f2c_ftnint_type_node;
+ break;
- resume_momentary (momentary);
- }
- else
- {
- int momentary = suspend_momentary ();
+ case FFECOM_rttypeINTEGER_:
+ ttype = ffecom_f2c_integer_type_node;
+ break;
- assemble_zeros (int_size_in_bytes (type));
- init = error_mark_node;
+ case FFECOM_rttypeLONGINT_:
+ ttype = ffecom_f2c_longint_type_node;
+ break;
- resume_momentary (momentary);
- }
+ case FFECOM_rttypeLOGICAL_:
+ ttype = ffecom_f2c_logical_type_node;
+ break;
- pop_momentary_nofree ();
+ case FFECOM_rttypeREAL_F2C_:
+ ttype = double_type_node;
+ break;
- return init;
-}
+ case FFECOM_rttypeREAL_GNU_:
+ ttype = float_type_node;
+ break;
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
- tree *maybe_tree)
-{
- tree expr_tree;
- tree length_tree;
+ case FFECOM_rttypeCOMPLEX_F2C_:
+ ttype = void_type_node;
+ break;
- switch (ffebld_op (arg))
- {
- case FFEBLD_opCONTER: /* For F90, check 0-length. */
- if (ffetarget_length_character1
- (ffebld_constant_character1
- (ffebld_conter (arg))) == 0)
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
+ case FFECOM_rttypeCOMPLEX_GNU_:
+ ttype = ffecom_f2c_complex_type_node;
+ break;
- *maybe_tree = integer_one_node;
- expr_tree = build_int_2 (*ffetarget_text_character1
- (ffebld_constant_character1
- (ffebld_conter (arg))),
- 0);
- TREE_TYPE (expr_tree) = tree_type;
- return expr_tree;
+ case FFECOM_rttypeDOUBLE_:
+ ttype = double_type_node;
+ break;
- case FFEBLD_opSYMTER:
- case FFEBLD_opARRAYREF:
- case FFEBLD_opFUNCREF:
- case FFEBLD_opSUBSTR:
- ffecom_push_calltemps ();
- ffecom_char_args_ (&expr_tree, &length_tree, arg);
- ffecom_pop_calltemps ();
+ case FFECOM_rttypeDOUBLEREAL_:
+ ttype = ffecom_f2c_doublereal_type_node;
+ break;
- if ((expr_tree == error_mark_node)
- || (length_tree == error_mark_node))
- {
- *maybe_tree = error_mark_node;
- return error_mark_node;
- }
+ case FFECOM_rttypeDBLCMPLX_F2C_:
+ ttype = void_type_node;
+ break;
- if (integer_zerop (length_tree))
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
+ case FFECOM_rttypeDBLCMPLX_GNU_:
+ ttype = ffecom_f2c_doublecomplex_type_node;
+ break;
- expr_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
- expr_tree);
- expr_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
- expr_tree,
- integer_one_node);
- expr_tree = convert (tree_type, expr_tree);
+ case FFECOM_rttypeCHARACTER_:
+ ttype = void_type_node;
+ break;
- if (TREE_CODE (length_tree) == INTEGER_CST)
- *maybe_tree = integer_one_node;
- else /* Must check length at run time. */
- *maybe_tree
- = ffecom_truth_value
- (ffecom_2 (GT_EXPR, integer_type_node,
- length_tree,
- ffecom_f2c_ftnlen_zero_node));
- return expr_tree;
+ default:
+ ttype = NULL;
+ assert ("bad rttype" == NULL);
+ break;
+ }
- case FFEBLD_opPAREN:
- case FFEBLD_opCONVERT:
- if (ffeinfo_size (ffebld_info (arg)) == 0)
- {
- *maybe_tree = integer_zero_node;
- return convert (tree_type, integer_zero_node);
- }
- return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
- maybe_tree);
+ ttype = build_function_type (ttype, NULL_TREE);
+ t = build_decl (FUNCTION_DECL,
+ get_identifier (ffecom_gfrt_name_[ix]),
+ ttype);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
+ TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
- case FFEBLD_opCONCATENATE:
- {
- tree maybe_left;
- tree maybe_right;
- tree expr_left;
- tree expr_right;
+ t = start_decl (t, TRUE);
- expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
- &maybe_left);
- expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
- &maybe_right);
- *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
- maybe_left,
- maybe_right);
- expr_tree = ffecom_3 (COND_EXPR, tree_type,
- maybe_left,
- expr_left,
- expr_right);
- return expr_tree;
- }
+ finish_decl (t, NULL_TREE, TRUE);
- default:
- assert ("bad op in ICHAR" == NULL);
- return error_mark_node;
- }
+ ffecom_gfrt_[ix] = t;
}
#endif
-/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
+/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
- tree length_arg;
- ffebld expr;
- length_arg = ffecom_intrinsic_len_ (expr);
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
+{
+ ffesymbol s = ffestorag_symbol (st);
- Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
- subexpressions by constructing the appropriate tree for the
- length-of-character-text argument in a calling sequence. */
+ if (ffesymbol_namelisted (s))
+ ffecom_member_namelisted_ = TRUE;
+}
+
+#endif
+/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
+ the member so debugger will see it. Otherwise nobody should be
+ referencing the member. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static tree
-ffecom_intrinsic_len_ (ffebld expr)
+static void
+ffecom_member_phase2_ (ffestorag mst, ffestorag st)
{
- ffetargetCharacter1 val;
- tree length;
+ ffesymbol s;
+ tree t;
+ tree mt;
+ tree type;
- switch (ffebld_op (expr))
- {
- case FFEBLD_opCONTER:
- val = ffebld_constant_character1 (ffebld_conter (expr));
- length = build_int_2 (ffetarget_length_character1 (val), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- break;
+ if ((mst == NULL)
+ || ((mt = ffestorag_hook (mst)) == NULL)
+ || (mt == error_mark_node))
+ return;
- case FFEBLD_opSYMTER:
- {
- ffesymbol s = ffebld_symter (expr);
- tree item;
+ if ((st == NULL)
+ || ((s = ffestorag_symbol (st)) == NULL))
+ return;
- item = ffesymbol_hook (s).decl_tree;
- if (item == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- item = ffesymbol_hook (s).decl_tree;
- }
- if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
- {
- if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
- length = ffesymbol_hook (s).length_tree;
- else
- {
- length = build_int_2 (ffesymbol_size (s), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- }
- }
- else if (item == error_mark_node)
- length = error_mark_node;
- else /* FFEINFO_kindFUNCTION: */
- length = NULL_TREE;
- }
- break;
+ type = ffecom_type_localvar_ (s,
+ ffesymbol_basictype (s),
+ ffesymbol_kindtype (s));
+ if (type == error_mark_node)
+ return;
- case FFEBLD_opARRAYREF:
- length = ffecom_intrinsic_len_ (ffebld_left (expr));
- break;
+ t = build_decl (VAR_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ type);
- case FFEBLD_opSUBSTR:
- {
- ffebld start;
- ffebld end;
- ffebld thing = ffebld_right (expr);
- tree start_tree;
- tree end_tree;
+ TREE_STATIC (t) = TREE_STATIC (mt);
+ DECL_INITIAL (t) = NULL_TREE;
+ TREE_ASM_WRITTEN (t) = 1;
- assert (ffebld_op (thing) == FFEBLD_opITEM);
- start = ffebld_head (thing);
- thing = ffebld_trail (thing);
- assert (ffebld_trail (thing) == NULL);
- end = ffebld_head (thing);
+ DECL_RTL (t)
+ = gen_rtx (MEM, TYPE_MODE (type),
+ plus_constant (XEXP (DECL_RTL (mt), 0),
+ ffestorag_modulo (mst)
+ + ffestorag_offset (st)
+ - ffestorag_offset (mst)));
- length = ffecom_intrinsic_len_ (ffebld_left (expr));
+ t = start_decl (t, FALSE);
- if (length == error_mark_node)
- break;
+ finish_decl (t, NULL_TREE, FALSE);
+}
- if (start == NULL)
- {
- if (end == NULL)
- ;
- else
- {
- length = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (end));
- }
- }
- else
- {
- start_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (start));
+#endif
+/* Prepare source expression for assignment into a destination perhaps known
+ to be of a specific size. */
- if (start_tree == error_mark_node)
- {
- length = error_mark_node;
- break;
- }
+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;
- if (end == NULL)
- {
- length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- ffecom_2 (MINUS_EXPR,
- ffecom_f2c_ftnlen_type_node,
- length,
- start_tree));
- }
- else
- {
- end_tree = convert (ffecom_f2c_ftnlen_type_node,
- ffecom_expr (end));
+ while (ffebld_op (source) == FFEBLD_opCONVERT)
+ source = ffebld_left (source);
- if (end_tree == error_mark_node)
- {
- length = error_mark_node;
- break;
- }
+ catlist = ffecom_concat_list_new_ (source, dest_size);
+ count = ffecom_concat_list_count_ (catlist);
- length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_f2c_ftnlen_one_node,
- ffecom_2 (MINUS_EXPR,
- ffecom_f2c_ftnlen_type_node,
- end_tree, start_tree));
- }
- }
- }
- break;
+ 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;
+ }
- case FFEBLD_opCONCATENATE:
- length
- = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
- ffecom_intrinsic_len_ (ffebld_left (expr)),
- ffecom_intrinsic_len_ (ffebld_right (expr)));
- break;
+ for (i = 0; i < count; ++i)
+ ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
- case FFEBLD_opFUNCREF:
- case FFEBLD_opCONVERT:
- length = build_int_2 (ffebld_size (expr), 0);
- TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
- break;
+ ffecom_concat_list_kill_ (catlist);
- default:
- assert ("bad op for single char arg expr" == NULL);
- length = ffecom_f2c_ftnlen_zero_node;
- break;
+ if (tempvar)
+ {
+ ffebld_nonter_set_hook (source, tempvar);
+ current_binding_level->prep_state = 1;
}
-
- assert (length != NULL_TREE);
-
- return length;
}
-#endif
-/* ffecom_let_char_ -- Do assignment stuff for character type
+/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
- 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);
+ Ignores STAR (alternate-return) dummies. All other get exec-transitioned
+ (which generates their trees) and then their trees get push_parm_decl'd.
- Generates code to do the assignment. Used by ordinary assignment
- statement handler ffecom_let_stmt and by statement-function
- handler to generate code for a statement function. */
+ The second arg is TRUE if the dummies are for a statement function, in
+ which case lengths are not pushed for character arguments (since they are
+ always known by both the caller and the callee, though the code allows
+ for someday permitting CHAR*(*) stmtfunc dummies). */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
-ffecom_let_char_ (tree dest_tree, tree dest_length,
- ffetargetCharacterSize dest_size, ffebld source)
+ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
{
- ffecomConcatList_ catlist;
- tree source_length;
- tree source_tree;
- tree expr_tree;
-
- if ((dest_tree == error_mark_node)
- || (dest_length == error_mark_node))
- return;
-
- assert (dest_tree != NULL_TREE);
- assert (dest_length != NULL_TREE);
+ ffebld dummy;
+ ffebld dumlist;
+ ffesymbol s;
+ tree parm;
- /* Source might be an opCONVERT, which just means it is a different size
- than the destination. Since the underlying implementation here handles
- that (directly or via the s_copy or s_cat run-time-library functions),
- we don't need the "convenience" of an opCONVERT that tells us to
- truncate or blank-pad, particularly since the resulting implementation
- would probably be slower than otherwise. */
+ ffecom_transform_only_dummies_ = TRUE;
- while (ffebld_op (source) == FFEBLD_opCONVERT)
- source = ffebld_left (source);
+ /* First push the parms corresponding to actual dummy "contents". */
- catlist = ffecom_concat_list_new_ (source, dest_size);
- switch (ffecom_concat_list_count_ (catlist))
+ for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
{
- case 0: /* Shouldn't happen, but in case it does... */
- ffecom_concat_list_kill_ (catlist);
- source_tree = null_pointer_node;
- source_length = ffecom_f2c_ftnlen_zero_node;
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE, dest_length);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = build_tree_list (NULL_TREE, source_length);
-
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
-
- expand_expr_stmt (expr_tree);
-
- return;
-
- case 1: /* The (fairly) easy case. */
- ffecom_char_args_ (&source_tree, &source_length,
- ffecom_concat_list_expr_ (catlist, 0));
- ffecom_concat_list_kill_ (catlist);
- assert (source_tree != NULL_TREE);
- assert (source_length != NULL_TREE);
-
- if ((source_tree == error_mark_node)
- || (source_length == error_mark_node))
- return;
+ dummy = ffebld_head (dumlist);
+ switch (ffebld_op (dummy))
+ {
+ case FFEBLD_opSTAR:
+ case FFEBLD_opANY:
+ continue; /* Forget alternate returns. */
- if (dest_size == 1)
+ default:
+ break;
+ }
+ assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
+ s = ffebld_symter (dummy);
+ parm = ffesymbol_hook (s).decl_tree;
+ if (parm == NULL_TREE)
{
- dest_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (dest_tree))),
- dest_tree);
- dest_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (dest_tree))),
- dest_tree,
- integer_one_node);
- source_tree
- = ffecom_1 (INDIRECT_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (source_tree))),
- source_tree);
- source_tree
- = ffecom_2 (ARRAY_REF,
- TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
- (source_tree))),
- source_tree,
- integer_one_node);
+ s = ffecom_sym_transform_ (s);
+ parm = ffesymbol_hook (s).decl_tree;
+ assert (parm != NULL_TREE);
+ }
+ if (parm != error_mark_node)
+ push_parm_decl (parm);
+ }
- expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
+ /* Then, for CHARACTER dummies, push the parms giving their lengths. */
- expand_expr_stmt (expr_tree);
+ for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
+ {
+ dummy = ffebld_head (dumlist);
+ switch (ffebld_op (dummy))
+ {
+ case FFEBLD_opSTAR:
+ case FFEBLD_opANY:
+ continue; /* Forget alternate returns, they mean
+ NOTHING! */
- return;
+ default:
+ break;
}
+ s = ffebld_symter (dummy);
+ if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
+ continue; /* Only looking for CHARACTER arguments. */
+ if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
+ continue; /* Stmtfunc arg with known size needs no
+ length param. */
+ if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
+ continue; /* Only looking for variables and arrays. */
+ parm = ffesymbol_hook (s).length_tree;
+ assert (parm != NULL_TREE);
+ if (parm != error_mark_node)
+ push_parm_decl (parm);
+ }
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE, dest_length);
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = build_tree_list (NULL_TREE, source_length);
+ ffecom_transform_only_dummies_ = FALSE;
+}
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
+#endif
+/* ffecom_start_progunit_ -- Beginning of program unit
- expand_expr_stmt (expr_tree);
+ Does GNU back end stuff necessary to teach it about the start of its
+ equivalent of a Fortran program unit. */
- return;
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+static void
+ffecom_start_progunit_ ()
+{
+ ffesymbol fn = ffecom_primary_entry_;
+ ffebld arglist;
+ tree id; /* Identifier (name) of function. */
+ tree type; /* Type of function. */
+ tree result; /* Result of function. */
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffeglobal g;
+ ffeglobalType gt;
+ ffeglobalType egt = FFEGLOBAL_type;
+ bool charfunc;
+ bool cmplxfunc;
+ bool altentries = (ffecom_num_entrypoints_ != 0);
+ bool multi
+ = altentries
+ && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
+ && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
+ bool main_program = FALSE;
+ int old_lineno = lineno;
+ const char *old_input_filename = input_filename;
+ int yes;
- default: /* Must actually concatenate things. */
- break;
- }
+ assert (fn != NULL);
+ assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
- /* Heavy-duty concatenation. */
+ input_filename = ffesymbol_where_filename (fn);
+ lineno = ffesymbol_where_filelinenum (fn);
- {
- int count = ffecom_concat_list_count_ (catlist);
- int i;
- tree lengths;
- tree items;
- tree length_array;
- tree item_array;
- tree citem;
- tree clength;
+ /* 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. */
- 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);
+ suspend_momentary ();
- for (i = 0; i < count; ++i)
- {
- 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);
- return;
- }
+ switch (ffecom_primary_entry_kind_)
+ {
+ case FFEINFO_kindPROGRAM:
+ main_program = TRUE;
+ gt = FFEGLOBAL_typeMAIN;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ type = ffecom_tree_fun_type_void;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
- 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);
- 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);
- }
+ case FFEINFO_kindBLOCKDATA:
+ gt = FFEGLOBAL_typeBDATA;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ type = ffecom_tree_fun_type_void;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
- expr_tree = build_tree_list (NULL_TREE, dest_tree);
- TREE_CHAIN (expr_tree)
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (items)),
- items));
- TREE_CHAIN (TREE_CHAIN (expr_tree))
- = build_tree_list (NULL_TREE,
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (lengths)),
- lengths));
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
- = 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))));
- TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
- = build_tree_list (NULL_TREE, dest_length);
+ case FFEINFO_kindFUNCTION:
+ gt = FFEGLOBAL_typeFUNC;
+ egt = FFEGLOBAL_typeEXT;
+ bt = ffesymbol_basictype (fn);
+ kt = ffesymbol_kindtype (fn);
+ if (bt == FFEINFO_basictypeNONE)
+ {
+ ffeimplic_establish_symbol (fn);
+ if (ffesymbol_funcresult (fn) != NULL)
+ ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
+ bt = ffesymbol_basictype (fn);
+ kt = ffesymbol_kindtype (fn);
+ }
- expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree);
- TREE_SIDE_EFFECTS (expr_tree) = 1;
+ if (multi)
+ charfunc = cmplxfunc = FALSE;
+ else if (bt == FFEINFO_basictypeCHARACTER)
+ charfunc = TRUE, cmplxfunc = FALSE;
+ else if ((bt == FFEINFO_basictypeCOMPLEX)
+ && ffesymbol_is_f2c (fn)
+ && !altentries)
+ charfunc = FALSE, cmplxfunc = TRUE;
+ else
+ charfunc = cmplxfunc = FALSE;
- expand_expr_stmt (expr_tree);
- }
+ if (multi || charfunc)
+ type = ffecom_tree_fun_type_void;
+ else if (ffesymbol_is_f2c (fn) && !altentries)
+ type = ffecom_tree_fun_type[bt][kt];
+ else
+ type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
- ffecom_concat_list_kill_ (catlist);
-}
+ if ((type == NULL_TREE)
+ || (TREE_TYPE (type) == NULL_TREE))
+ type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
+ break;
-#endif
-/* ffecom_make_gfrt_ -- Make initial info for run-time routine
+ case FFEINFO_kindSUBROUTINE:
+ gt = FFEGLOBAL_typeSUBR;
+ egt = FFEGLOBAL_typeEXT;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ if (ffecom_is_altreturning_)
+ type = ffecom_tree_subr_type;
+ else
+ type = ffecom_tree_fun_type_void;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
- ffecomGfrt ix;
- ffecom_make_gfrt_(ix);
+ default:
+ assert ("say what??" == NULL);
+ /* Fall through. */
+ case FFEINFO_kindANY:
+ gt = FFEGLOBAL_typeANY;
+ bt = FFEINFO_basictypeNONE;
+ kt = FFEINFO_kindtypeNONE;
+ type = error_mark_node;
+ charfunc = FALSE;
+ cmplxfunc = FALSE;
+ break;
+ }
- Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
- for the indicated run-time routine (ix). */
+ if (altentries)
+ {
+ 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);
+#endif
+ else
+ id = ffecom_get_external_identifier_ (fn);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_make_gfrt_ (ffecomGfrt ix)
-{
- tree t;
- tree ttype;
+ start_function (id,
+ type,
+ 0, /* nested/inline */
+ !altentries); /* TREE_PUBLIC */
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
- switch (ffecom_gfrt_type_[ix])
+ if (!altentries
+ && ((g = ffesymbol_global (fn)) != NULL)
+ && ((ffeglobal_type (g) == gt)
+ || (ffeglobal_type (g) == egt)))
{
- case FFECOM_rttypeVOID_:
- ttype = void_type_node;
- break;
+ ffeglobal_set_hook (g, current_function_decl);
+ }
- case FFECOM_rttypeVOIDSTAR_:
- ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
- break;
+ yes = suspend_momentary ();
- case FFECOM_rttypeFTNINT_:
- ttype = ffecom_f2c_ftnint_type_node;
- break;
+ /* 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. */
- case FFECOM_rttypeINTEGER_:
- ttype = ffecom_f2c_integer_type_node;
- break;
+ if (altentries)
+ { /* 1st arg identifies which entrypoint. */
+ ffecom_which_entrypoint_decl_
+ = build_decl (PARM_DECL,
+ ffecom_get_invented_identifier ("__g77_%s",
+ "which_entrypoint"),
+ integer_type_node);
+ push_parm_decl (ffecom_which_entrypoint_decl_);
+ }
- case FFECOM_rttypeLONGINT_:
- ttype = ffecom_f2c_longint_type_node;
- break;
+ if (charfunc
+ || cmplxfunc
+ || multi)
+ { /* Arg for result (return value). */
+ tree type;
+ tree length;
- case FFECOM_rttypeLOGICAL_:
- ttype = ffecom_f2c_logical_type_node;
- break;
+ if (charfunc)
+ type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
+ else if (cmplxfunc)
+ type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
+ else
+ type = ffecom_multi_type_node_;
- case FFECOM_rttypeREAL_F2C_:
- ttype = double_type_node;
- break;
+ result = ffecom_get_invented_identifier ("__g77_%s", "result");
- case FFECOM_rttypeREAL_GNU_:
- ttype = float_type_node;
- break;
+ /* Make length arg _and_ enhance type info for CHAR arg itself. */
- case FFECOM_rttypeCOMPLEX_F2C_:
- ttype = void_type_node;
- break;
+ if (charfunc)
+ length = ffecom_char_enhance_arg_ (&type, fn);
+ else
+ length = NULL_TREE; /* Not ref'd if !charfunc. */
- case FFECOM_rttypeCOMPLEX_GNU_:
- ttype = ffecom_f2c_complex_type_node;
- break;
+ type = build_pointer_type (type);
+ result = build_decl (PARM_DECL, result, type);
- case FFECOM_rttypeDOUBLE_:
- ttype = double_type_node;
- break;
+ push_parm_decl (result);
+ if (multi)
+ ffecom_multi_retval_ = result;
+ else
+ ffecom_func_result_ = result;
- case FFECOM_rttypeDOUBLEREAL_:
- ttype = ffecom_f2c_doublereal_type_node;
- break;
-
- case FFECOM_rttypeDBLCMPLX_F2C_:
- ttype = void_type_node;
- break;
-
- case FFECOM_rttypeDBLCMPLX_GNU_:
- ttype = ffecom_f2c_doublecomplex_type_node;
- break;
-
- case FFECOM_rttypeCHARACTER_:
- ttype = void_type_node;
- break;
+ if (charfunc)
+ {
+ push_parm_decl (length);
+ ffecom_func_length_ = length;
+ }
+ }
- default:
- ttype = NULL;
- assert ("bad rttype" == NULL);
- break;
+ if (ffecom_primary_entry_is_proc_)
+ {
+ if (altentries)
+ arglist = ffecom_master_arglist_;
+ else
+ arglist = ffesymbol_dummyargs (fn);
+ ffecom_push_dummy_decls_ (arglist, FALSE);
}
- ttype = build_function_type (ttype, NULL_TREE);
- t = build_decl (FUNCTION_DECL,
- get_identifier (ffecom_gfrt_name_[ix]),
- ttype);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
- TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
+ resume_momentary (yes);
- t = start_decl (t, TRUE);
+ if (TREE_CODE (current_function_decl) != ERROR_MARK)
+ store_parm_decls (main_program ? 1 : 0);
- finish_decl (t, NULL_TREE, TRUE);
+ ffecom_start_compstmt ();
+ /* Disallow temp vars at this level. */
+ current_binding_level->prep_state = 2;
- resume_temporary_allocation ();
- pop_obstacks ();
+ lineno = old_lineno;
+ input_filename = old_input_filename;
- ffecom_gfrt_[ix] = t;
+ /* This handles any symbols still untransformed, in case -g specified.
+ This used to be done in ffecom_finish_progunit, but it turns out to
+ be necessary to do it here so that statement functions are
+ expanded before code. But don't bother for BLOCK DATA. */
+
+ if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
+ ffesymbol_drive (ffecom_finish_symbol_transform_);
}
#endif
-/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
-{
- ffesymbol s = ffestorag_symbol (st);
+/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
- if (ffesymbol_namelisted (s))
- ffecom_member_namelisted_ = TRUE;
-}
+ ffesymbol s;
+ ffecom_sym_transform_(s);
-#endif
-/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
- the member so debugger will see it. Otherwise nobody should be
- referencing the member. */
+ The ffesymbol_hook info for s is updated with appropriate backend info
+ on the symbol. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
-static void
-ffecom_member_phase2_ (ffestorag mst, ffestorag st)
+static ffesymbol
+ffecom_sym_transform_ (ffesymbol s)
{
- ffesymbol s;
- tree t;
- tree mt;
- tree type;
+ tree t; /* Transformed thingy. */
+ tree tlen; /* Length if CHAR*(*). */
+ bool addr; /* Is t the address of the thingy? */
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffeglobal g;
+ int yes;
+ int old_lineno = lineno;
+ const char *old_input_filename = input_filename;
- if ((mst == NULL)
- || ((mt = ffestorag_hook (mst)) == NULL)
- || (mt == error_mark_node))
- return;
+ /* 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.
- if ((st == NULL)
- || ((s = ffestorag_symbol (st)) == NULL))
- return;
+ 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). */
- type = ffecom_type_localvar_ (s,
- ffesymbol_basictype (s),
- ffesymbol_kindtype (s));
- if (type == error_mark_node)
- return;
+ if (! ffecom_transform_only_dummies_
+ && ffesymbol_assigned (s)
+ && ! ffesymbol_hook (s).assign_tree)
+ s = ffecom_sym_transform_assign_ (s);
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- type);
+ if (ffesymbol_sfdummyparent (s) == NULL)
+ {
+ input_filename = ffesymbol_where_filename (s);
+ lineno = ffesymbol_where_filelinenum (s);
+ }
+ else
+ {
+ ffesymbol sf = ffesymbol_sfdummyparent (s);
- TREE_STATIC (t) = TREE_STATIC (mt);
- DECL_INITIAL (t) = NULL_TREE;
- TREE_ASM_WRITTEN (t) = 1;
+ input_filename = ffesymbol_where_filename (sf);
+ lineno = ffesymbol_where_filelinenum (sf);
+ }
- DECL_RTL (t)
- = gen_rtx (MEM, TYPE_MODE (type),
- plus_constant (XEXP (DECL_RTL (mt), 0),
- ffestorag_modulo (mst)
- + ffestorag_offset (st)
- - ffestorag_offset (mst)));
+ bt = ffeinfo_basictype (ffebld_info (s));
+ kt = ffeinfo_kindtype (ffebld_info (s));
- t = start_decl (t, FALSE);
+ t = NULL_TREE;
+ tlen = NULL_TREE;
+ addr = FALSE;
- finish_decl (t, NULL_TREE, FALSE);
-}
+ switch (ffesymbol_kind (s))
+ {
+ case FFEINFO_kindNONE:
+ switch (ffesymbol_where (s))
+ {
+ case FFEINFO_whereDUMMY: /* Subroutine or function. */
+ assert (ffecom_transform_only_dummies_);
+ /* Before 0.4, this could be ENTITY/DUMMY, but see
+ ffestu_sym_end_transition -- no longer true (in particular, if
+ it could be an ENTITY, it _will_ be made one, so that
+ possibility won't come through here). So we never make length
+ arg for CHARACTER type. */
+
+ t = build_decl (PARM_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ ffecom_tree_ptr_to_subr_type);
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (t) = 1;
#endif
-#endif
-/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
+ addr = TRUE;
+ break;
- Ignores STAR (alternate-return) dummies. All other get exec-transitioned
- (which generates their trees) and then their trees get push_parm_decl'd.
+ case FFEINFO_whereGLOBAL: /* Subroutine or function. */
+ assert (!ffecom_transform_only_dummies_);
- The second arg is TRUE if the dummies are for a statement function, in
- which case lengths are not pushed for character arguments (since they are
- always known by both the caller and the callee, though the code allows
- for someday permitting CHAR*(*) stmtfunc dummies). */
+ if (((g = ffesymbol_global (s)) != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
+ && (ffeglobal_hook (g) != NULL_TREE)
+ && ffe_is_globals ())
+ {
+ t = ffeglobal_hook (g);
+ break;
+ }
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
-{
- ffebld dummy;
- ffebld dumlist;
- ffesymbol s;
- tree parm;
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ ffecom_tree_subr_type); /* Assume subr. */
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- ffecom_transform_only_dummies_ = TRUE;
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- /* First push the parms corresponding to actual dummy "contents". */
+ if ((g != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
+ ffeglobal_set_hook (g, t);
- for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
- {
- dummy = ffebld_head (dumlist);
- switch (ffebld_op (dummy))
- {
- case FFEBLD_opSTAR:
- case FFEBLD_opANY:
- continue; /* Forget alternate returns. */
+ ffecom_save_tree_forever (t);
+
+ break;
default:
+ assert ("NONE where unexpected" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
break;
}
- assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
- s = ffebld_symter (dummy);
- parm = ffesymbol_hook (s).decl_tree;
- if (parm == NULL_TREE)
- {
- s = ffecom_sym_transform_ (s);
- parm = ffesymbol_hook (s).decl_tree;
- assert (parm != NULL_TREE);
- }
- if (parm != error_mark_node)
- push_parm_decl (parm);
- }
-
- /* Then, for CHARACTER dummies, push the parms giving their lengths. */
+ break;
- for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
- {
- dummy = ffebld_head (dumlist);
- switch (ffebld_op (dummy))
+ case FFEINFO_kindENTITY:
+ switch (ffeinfo_where (ffesymbol_info (s)))
{
- case FFEBLD_opSTAR:
- case FFEBLD_opANY:
- continue; /* Forget alternate returns, they mean
- NOTHING! */
- default:
+ case FFEINFO_whereCONSTANT:
+ /* ~~Debugging info needed? */
+ assert (!ffecom_transform_only_dummies_);
+ t = error_mark_node; /* Shouldn't ever see this in expr. */
break;
- }
- s = ffebld_symter (dummy);
- if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
- continue; /* Only looking for CHARACTER arguments. */
- if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
- continue; /* Stmtfunc arg with known size needs no
- length param. */
- if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
- continue; /* Only looking for variables and arrays. */
- parm = ffesymbol_hook (s).length_tree;
- assert (parm != NULL_TREE);
- if (parm != error_mark_node)
- push_parm_decl (parm);
- }
- ffecom_transform_only_dummies_ = FALSE;
-}
+ case FFEINFO_whereLOCAL:
+ assert (!ffecom_transform_only_dummies_);
-#endif
-/* ffecom_start_progunit_ -- Beginning of program unit
-
- Does GNU back end stuff necessary to teach it about the start of its
- equivalent of a Fortran program unit. */
+ {
+ ffestorag st = ffesymbol_storage (s);
+ tree type;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static void
-ffecom_start_progunit_ ()
-{
- ffesymbol fn = ffecom_primary_entry_;
- ffebld arglist;
- tree id; /* Identifier (name) of function. */
- tree type; /* Type of function. */
- tree result; /* Result of function. */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- ffeglobalType gt;
- ffeglobalType egt = FFEGLOBAL_type;
- bool charfunc;
- bool cmplxfunc;
- bool altentries = (ffecom_num_entrypoints_ != 0);
- bool multi
- = altentries
- && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
- && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
- bool main_program = FALSE;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
- int yes;
+ if ((st != NULL)
+ && (ffestorag_size (st) == 0))
+ {
+ t = error_mark_node;
+ break;
+ }
- assert (fn != NULL);
- assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
+ yes = suspend_momentary ();
+ type = ffecom_type_localvar_ (s, bt, kt);
+ resume_momentary (yes);
- input_filename = ffesymbol_where_filename (fn);
- lineno = ffesymbol_where_filelinenum (fn);
+ if (type == error_mark_node)
+ {
+ t = error_mark_node;
+ break;
+ }
- /* 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. */
+ if ((st != NULL)
+ && (ffestorag_parent (st) != NULL))
+ { /* Child of EQUIVALENCE parent. */
+ ffestorag est;
+ tree et;
+ int yes;
+ ffetargetOffset offset;
- suspend_momentary ();
+ est = ffestorag_parent (st);
+ ffecom_transform_equiv_ (est);
- switch (ffecom_primary_entry_kind_)
- {
- case FFEINFO_kindPROGRAM:
- main_program = TRUE;
- gt = FFEGLOBAL_typeMAIN;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
+ et = ffestorag_hook (est);
+ assert (et != NULL_TREE);
- case FFEINFO_kindBLOCKDATA:
- gt = FFEGLOBAL_typeBDATA;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
+ if (! TREE_STATIC (et))
+ put_var_into_stack (et);
- case FFEINFO_kindFUNCTION:
- gt = FFEGLOBAL_typeFUNC;
- egt = FFEGLOBAL_typeEXT;
- bt = ffesymbol_basictype (fn);
- kt = ffesymbol_kindtype (fn);
- if (bt == FFEINFO_basictypeNONE)
- {
- ffeimplic_establish_symbol (fn);
- if (ffesymbol_funcresult (fn) != NULL)
- ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
- bt = ffesymbol_basictype (fn);
- kt = ffesymbol_kindtype (fn);
- }
+ yes = suspend_momentary ();
- if (multi)
- charfunc = cmplxfunc = FALSE;
- else if (bt == FFEINFO_basictypeCHARACTER)
- charfunc = TRUE, cmplxfunc = FALSE;
- else if ((bt == FFEINFO_basictypeCOMPLEX)
- && ffesymbol_is_f2c (fn)
- && !altentries)
- charfunc = FALSE, cmplxfunc = TRUE;
- else
- charfunc = cmplxfunc = FALSE;
+ offset = ffestorag_modulo (est)
+ + ffestorag_offset (ffesymbol_storage (s))
+ - ffestorag_offset (est);
- if (multi || charfunc)
- type = ffecom_tree_fun_type_void;
- else if (ffesymbol_is_f2c (fn) && !altentries)
- type = ffecom_tree_fun_type[bt][kt];
- else
- type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
+ ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
- if ((type == NULL_TREE)
- || (TREE_TYPE (type) == NULL_TREE))
- type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
- break;
+ /* (t_type *) (((char *) &et) + offset) */
- case FFEINFO_kindSUBROUTINE:
- gt = FFEGLOBAL_typeSUBR;
- egt = FFEGLOBAL_typeEXT;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- if (ffecom_is_altreturning_)
- type = ffecom_tree_subr_type;
- else
- type = ffecom_tree_fun_type_void;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
+ t = convert (string_type_node, /* (char *) */
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (et)),
+ et));
+ t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
+ t,
+ build_int_2 (offset, 0));
+ t = convert (build_pointer_type (type),
+ t);
+ TREE_CONSTANT (t) = staticp (et);
- default:
- assert ("say what??" == NULL);
- /* Fall through. */
- case FFEINFO_kindANY:
- gt = FFEGLOBAL_typeANY;
- bt = FFEINFO_basictypeNONE;
- kt = FFEINFO_kindtypeNONE;
- type = error_mark_node;
- charfunc = FALSE;
- cmplxfunc = FALSE;
- break;
- }
+ addr = TRUE;
- if (altentries)
- {
- id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
- ffesymbol_text (fn),
- 0);
- }
-#if FFETARGET_isENFORCED_MAIN
- else if (main_program)
- id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
-#endif
- else
- id = ffecom_get_external_identifier_ (fn);
+ resume_momentary (yes);
+ }
+ else
+ {
+ tree initexpr;
+ bool init = ffesymbol_is_init (s);
- start_function (id,
- type,
- 0, /* nested/inline */
- !altentries); /* TREE_PUBLIC */
+ yes = suspend_momentary ();
- TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
+ t = build_decl (VAR_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ type);
- if (!altentries
- && ((g = ffesymbol_global (fn)) != NULL)
- && ((ffeglobal_type (g) == gt)
- || (ffeglobal_type (g) == egt)))
- {
- ffeglobal_set_hook (g, current_function_decl);
- }
+ if (init
+ || ffesymbol_namelisted (s)
+#ifdef FFECOM_sizeMAXSTACKITEM
+ || ((st != NULL)
+ && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
+#endif
+ || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
+ && (ffecom_primary_entry_kind_
+ != FFEINFO_kindBLOCKDATA)
+ && (ffesymbol_is_save (s) || ffe_is_saveall ())))
+ TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
+ else
+ TREE_STATIC (t) = 0; /* No need to make static. */
- yes = suspend_momentary ();
+ if (init || ffe_is_init_local_zero ())
+ DECL_INITIAL (t) = error_mark_node;
- /* 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. */
+ /* Keep -Wunused from complaining about var if it
+ is used as sfunc arg or DATA implied-DO. */
+ if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
+ DECL_IN_SYSTEM_HEADER (t) = 1;
- if (altentries)
- { /* 1st arg identifies which entrypoint. */
- ffecom_which_entrypoint_decl_
- = build_decl (PARM_DECL,
- ffecom_get_invented_identifier ("__g77_%s",
- "which_entrypoint",
- 0),
- integer_type_node);
- push_parm_decl (ffecom_which_entrypoint_decl_);
- }
+ t = start_decl (t, FALSE);
- if (charfunc
- || cmplxfunc
- || multi)
- { /* Arg for result (return value). */
- tree type;
- tree length;
+ if (init)
+ {
+ if (ffesymbol_init (s) != NULL)
+ initexpr = ffecom_expr (ffesymbol_init (s));
+ else
+ initexpr = ffecom_init_zero_ (t);
+ }
+ else if (ffe_is_init_local_zero ())
+ initexpr = ffecom_init_zero_ (t);
+ else
+ initexpr = NULL_TREE; /* Not ref'd if !init. */
- if (charfunc)
- type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
- else if (cmplxfunc)
- type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
- else
- type = ffecom_multi_type_node_;
+ finish_decl (t, initexpr, FALSE);
- result = ffecom_get_invented_identifier ("__g77_%s",
- "result", 0);
+ if (st != NULL && DECL_SIZE (t) != error_mark_node)
+ {
+ assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
+ assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
+ ffestorag_size (st)));
+ }
- /* Make length arg _and_ enhance type info for CHAR arg itself. */
+ resume_momentary (yes);
+ }
+ }
+ break;
- if (charfunc)
- length = ffecom_char_enhance_arg_ (&type, fn);
- else
- length = NULL_TREE; /* Not ref'd if !charfunc. */
-
- type = build_pointer_type (type);
- result = build_decl (PARM_DECL, result, type);
-
- push_parm_decl (result);
- if (multi)
- ffecom_multi_retval_ = result;
- else
- ffecom_func_result_ = result;
+ case FFEINFO_whereRESULT:
+ assert (!ffecom_transform_only_dummies_);
- if (charfunc)
- {
- push_parm_decl (length);
- ffecom_func_length_ = length;
- }
- }
+ if (bt == FFEINFO_basictypeCHARACTER)
+ { /* Result is already in list of dummies, use
+ it (& length). */
+ t = ffecom_func_result_;
+ tlen = ffecom_func_length_;
+ addr = TRUE;
+ break;
+ }
+ if ((ffecom_num_entrypoints_ == 0)
+ && (bt == FFEINFO_basictypeCOMPLEX)
+ && (ffesymbol_is_f2c (ffecom_primary_entry_)))
+ { /* Result is already in list of dummies, use
+ it. */
+ t = ffecom_func_result_;
+ addr = TRUE;
+ break;
+ }
+ if (ffecom_func_result_ != NULL_TREE)
+ {
+ t = ffecom_func_result_;
+ break;
+ }
+ if ((ffecom_num_entrypoints_ != 0)
+ && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
+ {
+ yes = suspend_momentary ();
- if (ffecom_primary_entry_is_proc_)
- {
- if (altentries)
- arglist = ffecom_master_arglist_;
- else
- arglist = ffesymbol_dummyargs (fn);
- ffecom_push_dummy_decls_ (arglist, FALSE);
- }
+ 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);
+ resume_momentary (yes);
+ break;
+ }
- if (TREE_CODE (current_function_decl) != ERROR_MARK)
- store_parm_decls (main_program ? 1 : 0);
+ yes = suspend_momentary ();
- ffecom_start_compstmt_ ();
+ t = build_decl (VAR_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ ffecom_tree_type[bt][kt]);
+ TREE_STATIC (t) = 0; /* Put result on stack. */
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- lineno = old_lineno;
- input_filename = old_input_filename;
+ ffecom_func_result_ = t;
- /* This handles any symbols still untransformed, in case -g specified.
- This used to be done in ffecom_finish_progunit, but it turns out to
- be necessary to do it here so that statement functions are
- expanded before code. But don't bother for BLOCK DATA. */
+ resume_momentary (yes);
+ break;
- if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
- ffesymbol_drive (ffecom_finish_symbol_transform_);
-}
+ case FFEINFO_whereDUMMY:
+ {
+ tree type;
+ ffebld dl;
+ ffebld dim;
+ tree low;
+ tree high;
+ tree old_sizes;
+ bool adjustable = FALSE; /* Conditionally adjustable? */
-#endif
-/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
+ type = ffecom_tree_type[bt][kt];
+ if (ffesymbol_sfdummyparent (s) != NULL)
+ {
+ if (current_function_decl == ffecom_outer_function_decl_)
+ { /* Exec transition before sfunc
+ context; get it later. */
+ break;
+ }
+ t = ffecom_get_identifier_ (ffesymbol_text
+ (ffesymbol_sfdummyparent (s)));
+ }
+ else
+ t = ffecom_get_identifier_ (ffesymbol_text (s));
- ffesymbol s;
- ffecom_sym_transform_(s);
+ assert (ffecom_transform_only_dummies_);
- The ffesymbol_hook info for s is updated with appropriate backend info
- on the symbol. */
+ old_sizes = get_pending_sizes ();
+ put_pending_sizes (old_sizes);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static ffesymbol
-ffecom_sym_transform_ (ffesymbol s)
-{
- tree t; /* Transformed thingy. */
- tree tlen; /* Length if CHAR*(*). */
- bool addr; /* Is t the address of the thingy? */
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffeglobal g;
- int yes;
- int old_lineno = lineno;
- char *old_input_filename = input_filename;
+ if (bt == FFEINFO_basictypeCHARACTER)
+ tlen = ffecom_char_enhance_arg_ (&type, s);
+ type = ffecom_check_size_overflow_ (s, type, TRUE);
- if (ffesymbol_sfdummyparent (s) == NULL)
- {
- input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
- }
- else
- {
- ffesymbol sf = ffesymbol_sfdummyparent (s);
+ for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
+ {
+ if (type == error_mark_node)
+ break;
- input_filename = ffesymbol_where_filename (sf);
- lineno = ffesymbol_where_filelinenum (sf);
- }
+ dim = ffebld_head (dl);
+ assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
+ if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
+ low = ffecom_integer_one_node;
+ else
+ low = ffecom_expr (ffebld_left (dim));
+ assert (ffebld_right (dim) != NULL);
+ if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
+ || ffecom_doing_entry_)
+ {
+ /* Used to just do high=low. But for ffecom_tree_
+ canonize_ref_, it probably is important to correctly
+ assess the size. E.g. given COMPLEX C(*),CFUNC and
+ C(2)=CFUNC(C), overlap can happen, while it can't
+ for, say, C(1)=CFUNC(C(2)). */
+ /* Even more recently used to set to INT_MAX, but that
+ broke when some overflow checking went into the back
+ end. Now we just leave the upper bound unspecified. */
+ high = NULL;
+ }
+ else
+ high = ffecom_expr (ffebld_right (dim));
- bt = ffeinfo_basictype (ffebld_info (s));
- kt = ffeinfo_kindtype (ffebld_info (s));
+ /* Determine whether array is conditionally adjustable,
+ to decide whether back-end magic is needed.
- t = NULL_TREE;
- tlen = NULL_TREE;
- addr = FALSE;
+ Normally the front end uses the back-end function
+ variable_size to wrap SAVE_EXPR's around expressions
+ affecting the size/shape of an array so that the
+ size/shape info doesn't change during execution
+ of the compiled code even though variables and
+ functions referenced in those expressions might.
- switch (ffesymbol_kind (s))
- {
- case FFEINFO_kindNONE:
- switch (ffesymbol_where (s))
- {
- case FFEINFO_whereDUMMY: /* Subroutine or function. */
- assert (ffecom_transform_only_dummies_);
+ variable_size also makes sure those saved expressions
+ get evaluated immediately upon entry to the
+ compiled procedure -- the front end normally doesn't
+ have to worry about that.
- /* Before 0.4, this could be ENTITY/DUMMY, but see
- ffestu_sym_end_transition -- no longer true (in particular, if
- it could be an ENTITY, it _will_ be made one, so that
- possibility won't come through here). So we never make length
- arg for CHARACTER type. */
+ However, there is a problem with this that affects
+ g77's implementation of entry points, and that is
+ that it is _not_ true that each invocation of the
+ compiled procedure is permitted to evaluate
+ array size/shape info -- because it is possible
+ that, for some invocations, that info is invalid (in
+ which case it is "promised" -- i.e. a violation of
+ the Fortran standard -- that the compiled code
+ won't reference the array or its size/shape
+ during that particular invocation).
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_ptr_to_subr_type);
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
-#endif
- addr = TRUE;
- break;
+ To phrase this in C terms, consider this gcc function:
- case FFEINFO_whereGLOBAL: /* Subroutine or function. */
- assert (!ffecom_transform_only_dummies_);
+ void foo (int *n, float (*a)[*n])
+ {
+ // a is "pointer to array ...", fyi.
+ }
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
- {
- t = ffeglobal_hook (g);
- break;
- }
+ Suppose that, for some invocations, it is permitted
+ for a caller of foo to do this:
- push_obstacks_nochange ();
- end_temporary_allocation ();
+ foo (NULL, NULL);
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_subr_type); /* Assume subr. */
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
+ Now the _written_ code for foo can take such a call
+ into account by either testing explicitly for whether
+ (a == NULL) || (n == NULL) -- presumably it is
+ not permitted to reference *a in various fashions
+ if (n == NULL) I suppose -- or it can avoid it by
+ looking at other info (other arguments, static/global
+ data, etc.).
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ However, this won't work in gcc 2.5.8 because it'll
+ automatically emit the code to save the "*n"
+ expression, which'll yield a NULL dereference for
+ the "foo (NULL, NULL)" call, something the code
+ for foo cannot prevent.
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
+ g77 definitely needs to avoid executing such
+ code anytime the pointer to the adjustable array
+ is NULL, because even if its bounds expressions
+ don't have any references to possible "absent"
+ variables like "*n" -- say all variable references
+ are to COMMON variables, i.e. global (though in C,
+ local static could actually make sense) -- the
+ expressions could yield other run-time problems
+ for allowably "dead" values in those variables.
- resume_temporary_allocation ();
- pop_obstacks ();
+ For example, let's consider a more complicated
+ version of foo:
- break;
+ extern int i;
+ extern int j;
- default:
- assert ("NONE where unexpected" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- break;
- }
- break;
+ void foo (float (*a)[i/j])
+ {
+ ...
+ }
- case FFEINFO_kindENTITY:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
+ The above is (essentially) quite valid for Fortran
+ but, again, for a call like "foo (NULL);", it is
+ permitted for i and j to be undefined when the
+ call is made. If j happened to be zero, for
+ example, emitting the code to evaluate "i/j"
+ could result in a run-time error.
- case FFEINFO_whereCONSTANT: /* ~~debugging info needed? */
- assert (!ffecom_transform_only_dummies_);
- t = error_mark_node; /* Shouldn't ever see this in expr. */
- break;
+ Offhand, though I don't have my F77 or F90
+ standards handy, it might even be valid for a
+ bounds expression to contain a function reference,
+ in which case I doubt it is permitted for an
+ implementation to invoke that function in the
+ Fortran case involved here (invocation of an
+ alternate ENTRY point that doesn't have the adjustable
+ array as one of its arguments).
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
+ So, the code that the compiler would normally emit
+ to preevaluate the size/shape info for an
+ adjustable array _must not_ be executed at run time
+ in certain cases. Specifically, for Fortran,
+ the case is when the pointer to the adjustable
+ array == NULL. (For gnu-ish C, it might be nice
+ for the source code itself to specify an expression
+ that, if TRUE, inhibits execution of the code. Or
+ reverse the sense for elegance.)
- {
- ffestorag st = ffesymbol_storage (s);
- tree type;
+ (Note that g77 could use a different test than NULL,
+ actually, since it happens to always pass an
+ integer to the called function that specifies which
+ entry point is being invoked. Hmm, this might
+ solve the next problem.)
- if ((st != NULL)
- && (ffestorag_size (st) == 0))
- {
- t = error_mark_node;
- break;
- }
+ One way a user could, I suppose, write "foo" so
+ it works is to insert COND_EXPR's for the
+ size/shape info so the dangerous stuff isn't
+ actually done, as in:
- yes = suspend_momentary ();
- type = ffecom_type_localvar_ (s, bt, kt);
- resume_momentary (yes);
+ void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
+ {
+ ...
+ }
- if (type == error_mark_node)
- {
- t = error_mark_node;
- break;
- }
+ The next problem is that the front end needs to
+ be able to tell the back end about the array's
+ decl _before_ it tells it about the conditional
+ expression to inhibit evaluation of size/shape info,
+ as shown above.
- if ((st != NULL)
- && (ffestorag_parent (st) != NULL))
- { /* Child of EQUIVALENCE parent. */
- ffestorag est;
- tree et;
- int yes;
- ffetargetOffset offset;
+ To solve this, the front end needs to be able
+ to give the back end the expression to inhibit
+ generation of the preevaluation code _after_
+ it makes the decl for the adjustable array.
- est = ffestorag_parent (st);
- ffecom_transform_equiv_ (est);
+ Until then, the above example using the COND_EXPR
+ doesn't pass muster with gcc because the "(a == NULL)"
+ part has a reference to "a", which is still
+ undefined at that point.
- et = ffestorag_hook (est);
- assert (et != NULL_TREE);
+ g77 will therefore use a different mechanism in the
+ meantime. */
- if (! TREE_STATIC (et))
- put_var_into_stack (et);
+ if (!adjustable
+ && ((TREE_CODE (low) != INTEGER_CST)
+ || (high && TREE_CODE (high) != INTEGER_CST)))
+ adjustable = TRUE;
- yes = suspend_momentary ();
+#if 0 /* Old approach -- see below. */
+ if (TREE_CODE (low) != INTEGER_CST)
+ low = ffecom_3 (COND_EXPR, integer_type_node,
+ ffecom_adjarray_passed_ (s),
+ low,
+ ffecom_integer_zero_node);
- offset = ffestorag_modulo (est)
- + ffestorag_offset (ffesymbol_storage (s))
- - ffestorag_offset (est);
+ if (high && TREE_CODE (high) != INTEGER_CST)
+ high = ffecom_3 (COND_EXPR, integer_type_node,
+ ffecom_adjarray_passed_ (s),
+ high,
+ ffecom_integer_zero_node);
+#endif
- ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
+ /* ~~~gcc/stor-layout.c (layout_type) should do this,
+ probably. Fixes 950302-1.f. */
- /* (t_type *) (((char *) &et) + offset) */
+ if (TREE_CODE (low) != INTEGER_CST)
+ low = variable_size (low);
- t = convert (string_type_node, /* (char *) */
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (et)),
- et));
- t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
- t,
- build_int_2 (offset, 0));
- t = convert (build_pointer_type (type),
- t);
+ /* ~~~Similarly, this fixes dumb0.f. The C front end
+ does this, which is why dumb0.c would work. */
- addr = TRUE;
+ if (high && TREE_CODE (high) != INTEGER_CST)
+ high = variable_size (high);
- resume_momentary (yes);
+ type
+ = build_array_type
+ (type,
+ build_range_type (ffecom_integer_type_node,
+ low, high));
+ type = ffecom_check_size_overflow_ (s, type, TRUE);
}
- else
- {
- tree initexpr;
- bool init = ffesymbol_is_init (s);
- yes = suspend_momentary ();
+ if (type == error_mark_node)
+ {
+ t = error_mark_node;
+ break;
+ }
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- type);
+ if ((ffesymbol_sfdummyparent (s) == NULL)
+ || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
+ {
+ type = build_pointer_type (type);
+ addr = TRUE;
+ }
- if (init
- || ffesymbol_namelisted (s)
-#ifdef FFECOM_sizeMAXSTACKITEM
- || ((st != NULL)
- && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
+ t = build_decl (PARM_DECL, t, type);
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (t) = 1;
#endif
- || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
- && (ffecom_primary_entry_kind_
- != FFEINFO_kindBLOCKDATA)
- && (ffesymbol_is_save (s) || ffe_is_saveall ())))
- TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
- else
- TREE_STATIC (t) = 0; /* No need to make static. */
-
- if (init || ffe_is_init_local_zero ())
- DECL_INITIAL (t) = error_mark_node;
-
- /* Keep -Wunused from complaining about var if it
- is used as sfunc arg or DATA implied-DO. */
- if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
- DECL_IN_SYSTEM_HEADER (t) = 1;
- t = start_decl (t, FALSE);
+ /* If this arg is present in every entry point's list of
+ dummy args, then we're done. */
- if (init)
- {
- if (ffesymbol_init (s) != NULL)
- initexpr = ffecom_expr (ffesymbol_init (s));
- else
- initexpr = ffecom_init_zero_ (t);
- }
- else if (ffe_is_init_local_zero ())
- initexpr = ffecom_init_zero_ (t);
- else
- initexpr = NULL_TREE; /* Not ref'd if !init. */
+ if (ffesymbol_numentries (s)
+ == (ffecom_num_entrypoints_ + 1))
+ break;
- finish_decl (t, initexpr, FALSE);
+#if 1
- if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
- {
- tree size_tree;
+ /* If variable_size in stor-layout has been called during
+ the above, then get_pending_sizes should have the
+ yet-to-be-evaluated saved expressions pending.
+ Make the whole lot of them get emitted, conditionally
+ on whether the array decl ("t" above) is not NULL. */
- 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));
- }
+ {
+ tree sizes = get_pending_sizes ();
+ tree tem;
- resume_momentary (yes);
- }
- }
- break;
+ for (tem = sizes;
+ tem != old_sizes;
+ tem = TREE_CHAIN (tem))
+ {
+ tree temv = TREE_VALUE (tem);
- case FFEINFO_whereRESULT:
- assert (!ffecom_transform_only_dummies_);
+ if (sizes == tem)
+ sizes = temv;
+ else
+ sizes
+ = ffecom_2 (COMPOUND_EXPR,
+ TREE_TYPE (sizes),
+ temv,
+ sizes);
+ }
- if (bt == FFEINFO_basictypeCHARACTER)
- { /* Result is already in list of dummies, use
- it (& length). */
- t = ffecom_func_result_;
- tlen = ffecom_func_length_;
- addr = TRUE;
- break;
- }
- if ((ffecom_num_entrypoints_ == 0)
- && (bt == FFEINFO_basictypeCOMPLEX)
- && (ffesymbol_is_f2c (ffecom_primary_entry_)))
- { /* Result is already in list of dummies, use
- it. */
- t = ffecom_func_result_;
- addr = TRUE;
- break;
- }
- if (ffecom_func_result_ != NULL_TREE)
- {
- t = ffecom_func_result_;
- break;
- }
- if ((ffecom_num_entrypoints_ != 0)
- && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
- {
- yes = suspend_momentary ();
+ if (sizes != tem)
+ {
+ sizes
+ = ffecom_3 (COND_EXPR,
+ TREE_TYPE (sizes),
+ ffecom_2 (NE_EXPR,
+ integer_type_node,
+ t,
+ null_pointer_node),
+ sizes,
+ convert (TREE_TYPE (sizes),
+ integer_zero_node));
+ sizes = ffecom_save_tree (sizes);
- 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]);
+ sizes
+ = tree_cons (NULL_TREE, sizes, tem);
+ }
- resume_momentary (yes);
- break;
+ if (sizes)
+ put_pending_sizes (sizes);
}
- yes = suspend_momentary ();
-
- t = build_decl (VAR_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_type[bt][kt]);
- TREE_STATIC (t) = 0; /* Put result on stack. */
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- ffecom_func_result_ = t;
-
- resume_momentary (yes);
+#else
+#if 0
+ if (adjustable
+ && (ffesymbol_numentries (s)
+ != ffecom_num_entrypoints_ + 1))
+ DECL_SOMETHING (t)
+ = ffecom_2 (NE_EXPR, integer_type_node,
+ t,
+ null_pointer_node);
+#else
+#if 0
+ if (adjustable
+ && (ffesymbol_numentries (s)
+ != ffecom_num_entrypoints_ + 1))
+ {
+ ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
+ ffebad_here (0, ffesymbol_where_line (s),
+ ffesymbol_where_column (s));
+ ffebad_string (ffesymbol_text (s));
+ ffebad_finish ();
+ }
+#endif
+#endif
+#endif
+ }
break;
- case FFEINFO_whereDUMMY:
+ case FFEINFO_whereCOMMON:
{
+ ffesymbol cs;
+ ffeglobal cg;
+ tree ct;
+ ffestorag st = ffesymbol_storage (s);
tree type;
- ffebld dl;
- ffebld dim;
- tree low;
- tree high;
- tree old_sizes;
- bool adjustable = FALSE; /* Conditionally adjustable? */
+ int yes;
- type = ffecom_tree_type[bt][kt];
- if (ffesymbol_sfdummyparent (s) != NULL)
+ cs = ffesymbol_common (s); /* The COMMON area itself. */
+ if (st != NULL) /* Else not laid out. */
{
- if (current_function_decl == ffecom_outer_function_decl_)
- { /* Exec transition before sfunc
- context; get it later. */
- break;
- }
- t = ffecom_get_identifier_ (ffesymbol_text
- (ffesymbol_sfdummyparent (s)));
+ ffecom_transform_common_ (cs);
+ st = ffesymbol_storage (s);
}
- else
- t = ffecom_get_identifier_ (ffesymbol_text (s));
- assert (ffecom_transform_only_dummies_);
+ yes = suspend_momentary ();
- old_sizes = get_pending_sizes ();
- put_pending_sizes (old_sizes);
+ type = ffecom_type_localvar_ (s, bt, kt);
- if (bt == FFEINFO_basictypeCHARACTER)
- tlen = ffecom_char_enhance_arg_ (&type, s);
- type = ffecom_check_size_overflow_ (s, type, TRUE);
+ cg = ffesymbol_global (cs); /* The global COMMON info. */
+ if ((cg == NULL)
+ || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
+ ct = NULL_TREE;
+ else
+ ct = ffeglobal_hook (cg); /* The common area's tree. */
- for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
+ if ((ct == NULL_TREE)
+ || (st == NULL)
+ || (type == error_mark_node))
+ t = error_mark_node;
+ else
{
- if (type == error_mark_node)
- break;
+ ffetargetOffset offset;
+ ffestorag cst;
- dim = ffebld_head (dl);
- assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
- if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
- low = ffecom_integer_one_node;
- else
- low = ffecom_expr (ffebld_left (dim));
- assert (ffebld_right (dim) != NULL);
- if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
- || ffecom_doing_entry_)
- {
- /* Used to just do high=low. But for ffecom_tree_
- canonize_ref_, it probably is important to correctly
- assess the size. E.g. given COMPLEX C(*),CFUNC and
- C(2)=CFUNC(C), overlap can happen, while it can't
- for, say, C(1)=CFUNC(C(2)). */
- /* Even more recently used to set to INT_MAX, but that
- broke when some overflow checking went into the back
- end. Now we just leave the upper bound unspecified. */
- high = NULL;
- }
- else
- high = ffecom_expr (ffebld_right (dim));
+ cst = ffestorag_parent (st);
+ assert (cst == ffesymbol_storage (cs));
- /* Determine whether array is conditionally adjustable,
- to decide whether back-end magic is needed.
+ offset = ffestorag_modulo (cst)
+ + ffestorag_offset (st)
+ - ffestorag_offset (cst);
- Normally the front end uses the back-end function
- variable_size to wrap SAVE_EXPR's around expressions
- affecting the size/shape of an array so that the
- size/shape info doesn't change during execution
- of the compiled code even though variables and
- functions referenced in those expressions might.
+ ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
- variable_size also makes sure those saved expressions
- get evaluated immediately upon entry to the
- compiled procedure -- the front end normally doesn't
- have to worry about that.
+ /* (t_type *) (((char *) &ct) + offset) */
- However, there is a problem with this that affects
- g77's implementation of entry points, and that is
- that it is _not_ true that each invocation of the
- compiled procedure is permitted to evaluate
- array size/shape info -- because it is possible
- that, for some invocations, that info is invalid (in
- which case it is "promised" -- i.e. a violation of
- the Fortran standard -- that the compiled code
- won't reference the array or its size/shape
- during that particular invocation).
+ t = convert (string_type_node, /* (char *) */
+ ffecom_1 (ADDR_EXPR,
+ build_pointer_type (TREE_TYPE (ct)),
+ ct));
+ t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
+ t,
+ build_int_2 (offset, 0));
+ t = convert (build_pointer_type (type),
+ t);
+ TREE_CONSTANT (t) = 1;
- To phrase this in C terms, consider this gcc function:
+ addr = TRUE;
+ }
- void foo (int *n, float (*a)[*n])
- {
- // a is "pointer to array ...", fyi.
- }
+ resume_momentary (yes);
+ }
+ break;
- Suppose that, for some invocations, it is permitted
- for a caller of foo to do this:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("ENTITY where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- foo (NULL, NULL);
+ case FFEINFO_kindFUNCTION:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
+ break;
- Now the _written_ code for foo can take such a call
- into account by either testing explicitly for whether
- (a == NULL) || (n == NULL) -- presumably it is
- not permitted to reference *a in various fashions
- if (n == NULL) I suppose -- or it can avoid it by
- looking at other info (other arguments, static/global
- data, etc.).
+ case FFEINFO_whereGLOBAL:
+ assert (!ffecom_transform_only_dummies_);
- However, this won't work in gcc 2.5.8 because it'll
- automatically emit the code to save the "*n"
- expression, which'll yield a NULL dereference for
- the "foo (NULL, NULL)" call, something the code
- for foo cannot prevent.
+ if (((g = ffesymbol_global (s)) != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
+ && (ffeglobal_hook (g) != NULL_TREE)
+ && ffe_is_globals ())
+ {
+ t = ffeglobal_hook (g);
+ break;
+ }
- g77 definitely needs to avoid executing such
- code anytime the pointer to the adjustable array
- is NULL, because even if its bounds expressions
- don't have any references to possible "absent"
- variables like "*n" -- say all variable references
- are to COMMON variables, i.e. global (though in C,
- local static could actually make sense) -- the
- expressions could yield other run-time problems
- for allowably "dead" values in those variables.
-
- For example, let's consider a more complicated
- version of foo:
-
- extern int i;
- extern int j;
-
- void foo (float (*a)[i/j])
- {
- ...
- }
+ if (ffesymbol_is_f2c (s)
+ && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
+ t = ffecom_tree_fun_type[bt][kt];
+ else
+ t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
- The above is (essentially) quite valid for Fortran
- but, again, for a call like "foo (NULL);", it is
- permitted for i and j to be undefined when the
- call is made. If j happened to be zero, for
- example, emitting the code to evaluate "i/j"
- could result in a run-time error.
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ t);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- Offhand, though I don't have my F77 or F90
- standards handy, it might even be valid for a
- bounds expression to contain a function reference,
- in which case I doubt it is permitted for an
- implementation to invoke that function in the
- Fortran case involved here (invocation of an
- alternate ENTRY point that doesn't have the adjustable
- array as one of its arguments).
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- So, the code that the compiler would normally emit
- to preevaluate the size/shape info for an
- adjustable array _must not_ be executed at run time
- in certain cases. Specifically, for Fortran,
- the case is when the pointer to the adjustable
- array == NULL. (For gnu-ish C, it might be nice
- for the source code itself to specify an expression
- that, if TRUE, inhibits execution of the code. Or
- reverse the sense for elegance.)
+ if ((g != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
+ ffeglobal_set_hook (g, t);
- (Note that g77 could use a different test than NULL,
- actually, since it happens to always pass an
- integer to the called function that specifies which
- entry point is being invoked. Hmm, this might
- solve the next problem.)
+ ffecom_save_tree_forever (t);
- One way a user could, I suppose, write "foo" so
- it works is to insert COND_EXPR's for the
- size/shape info so the dangerous stuff isn't
- actually done, as in:
+ break;
- void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
- {
- ...
- }
+ case FFEINFO_whereDUMMY:
+ assert (ffecom_transform_only_dummies_);
- The next problem is that the front end needs to
- be able to tell the back end about the array's
- decl _before_ it tells it about the conditional
- expression to inhibit evaluation of size/shape info,
- as shown above.
+ if (ffesymbol_is_f2c (s)
+ && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
+ t = ffecom_tree_ptr_to_fun_type[bt][kt];
+ else
+ t = build_pointer_type
+ (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
- To solve this, the front end needs to be able
- to give the back end the expression to inhibit
- generation of the preevaluation code _after_
- it makes the decl for the adjustable array.
+ t = build_decl (PARM_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ t);
+#if BUILT_FOR_270
+ DECL_ARTIFICIAL (t) = 1;
+#endif
+ addr = TRUE;
+ break;
- Until then, the above example using the COND_EXPR
- doesn't pass muster with gcc because the "(a == NULL)"
- part has a reference to "a", which is still
- undefined at that point.
+ case FFEINFO_whereCONSTANT: /* Statement function. */
+ assert (!ffecom_transform_only_dummies_);
+ t = ffecom_gen_sfuncdef_ (s, bt, kt);
+ break;
- g77 will therefore use a different mechanism in the
- meantime. */
+ case FFEINFO_whereINTRINSIC:
+ assert (!ffecom_transform_only_dummies_);
+ break; /* Let actual references generate their
+ decls. */
- if (!adjustable
- && ((TREE_CODE (low) != INTEGER_CST)
- || (high && TREE_CODE (high) != INTEGER_CST)))
- adjustable = TRUE;
+ default:
+ assert ("FUNCTION where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
-#if 0 /* Old approach -- see below. */
- if (TREE_CODE (low) != INTEGER_CST)
- low = ffecom_3 (COND_EXPR, integer_type_node,
- ffecom_adjarray_passed_ (s),
- low,
- ffecom_integer_zero_node);
+ case FFEINFO_kindSUBROUTINE:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
+ break;
- if (high && TREE_CODE (high) != INTEGER_CST)
- high = ffecom_3 (COND_EXPR, integer_type_node,
- ffecom_adjarray_passed_ (s),
- high,
- ffecom_integer_zero_node);
-#endif
+ case FFEINFO_whereGLOBAL:
+ assert (!ffecom_transform_only_dummies_);
- /* ~~~gcc/stor-layout.c/layout_type should do this,
- probably. Fixes 950302-1.f. */
+ if (((g = ffesymbol_global (s)) != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
+ && (ffeglobal_hook (g) != NULL_TREE)
+ && ffe_is_globals ())
+ {
+ t = ffeglobal_hook (g);
+ break;
+ }
- if (TREE_CODE (low) != INTEGER_CST)
- low = variable_size (low);
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ ffecom_tree_subr_type);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- /* ~~~similarly, this fixes dumb0.f. The C front end
- does this, which is why dumb0.c would work. */
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- if (high && TREE_CODE (high) != INTEGER_CST)
- high = variable_size (high);
+ if ((g != NULL)
+ && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
+ || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
+ ffeglobal_set_hook (g, t);
- type
- = build_array_type
- (type,
- build_range_type (ffecom_integer_type_node,
- low, high));
- type = ffecom_check_size_overflow_ (s, type, TRUE);
- }
+ ffecom_save_tree_forever (t);
- if (type == error_mark_node)
- {
- t = error_mark_node;
- break;
- }
+ break;
- if ((ffesymbol_sfdummyparent (s) == NULL)
- || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
- {
- type = build_pointer_type (type);
- addr = TRUE;
- }
+ case FFEINFO_whereDUMMY:
+ assert (ffecom_transform_only_dummies_);
- t = build_decl (PARM_DECL, t, type);
+ t = build_decl (PARM_DECL,
+ ffecom_get_identifier_ (ffesymbol_text (s)),
+ ffecom_tree_ptr_to_subr_type);
#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
+ DECL_ARTIFICIAL (t) = 1;
#endif
+ addr = TRUE;
+ break;
- /* If this arg is present in every entry point's list of
- dummy args, then we're done. */
-
- if (ffesymbol_numentries (s)
- == (ffecom_num_entrypoints_ + 1))
- break;
+ case FFEINFO_whereINTRINSIC:
+ assert (!ffecom_transform_only_dummies_);
+ break; /* Let actual references generate their
+ decls. */
-#if 1
+ default:
+ assert ("SUBROUTINE where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- /* If variable_size in stor-layout has been called during
- the above, then get_pending_sizes should have the
- yet-to-be-evaluated saved expressions pending.
- Make the whole lot of them get emitted, conditionally
- on whether the array decl ("t" above) is not NULL. */
+ case FFEINFO_kindPROGRAM:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
+ break;
- {
- tree sizes = get_pending_sizes ();
- tree tem;
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("PROGRAM where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
+ break;
+ }
+ break;
- for (tem = sizes;
- tem != old_sizes;
- tem = TREE_CHAIN (tem))
- {
- tree temv = TREE_VALUE (tem);
-
- if (sizes == tem)
- sizes = temv;
- else
- sizes
- = ffecom_2 (COMPOUND_EXPR,
- TREE_TYPE (sizes),
- temv,
- sizes);
- }
-
- if (sizes != tem)
- {
- sizes
- = ffecom_3 (COND_EXPR,
- TREE_TYPE (sizes),
- ffecom_2 (NE_EXPR,
- integer_type_node,
- t,
- null_pointer_node),
- sizes,
- convert (TREE_TYPE (sizes),
- integer_zero_node));
- sizes = ffecom_save_tree (sizes);
-
- sizes
- = tree_cons (NULL_TREE, sizes, tem);
- }
-
- if (sizes)
- put_pending_sizes (sizes);
- }
-
-#else
-#if 0
- if (adjustable
- && (ffesymbol_numentries (s)
- != ffecom_num_entrypoints_ + 1))
- DECL_SOMETHING (t)
- = ffecom_2 (NE_EXPR, integer_type_node,
- t,
- null_pointer_node);
-#else
-#if 0
- if (adjustable
- && (ffesymbol_numentries (s)
- != ffecom_num_entrypoints_ + 1))
- {
- ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
- ffebad_here (0, ffesymbol_where_line (s),
- ffesymbol_where_column (s));
- ffebad_string (ffesymbol_text (s));
- ffebad_finish ();
- }
-#endif
-#endif
-#endif
- }
+ case FFEINFO_kindBLOCKDATA:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL: /* Me. */
+ assert (!ffecom_transform_only_dummies_);
+ t = current_function_decl;
break;
- case FFEINFO_whereCOMMON:
- {
- ffesymbol cs;
- ffeglobal cg;
- 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. */
- {
- ffecom_transform_common_ (cs);
- st = ffesymbol_storage (s);
- }
-
- yes = suspend_momentary ();
-
- type = ffecom_type_localvar_ (s, bt, kt);
-
- cg = ffesymbol_global (cs); /* The global COMMON info. */
- if ((cg == NULL)
- || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
- ct = NULL_TREE;
- else
- ct = ffeglobal_hook (cg); /* The common area's tree. */
-
- if ((ct == NULL_TREE)
- || (st == NULL)
- || (type == error_mark_node))
- t = error_mark_node;
- else
- {
- ffetargetOffset offset;
- ffestorag cst;
-
- cst = ffestorag_parent (st);
- assert (cst == ffesymbol_storage (cs));
-
- offset = ffestorag_modulo (cst)
- + ffestorag_offset (st)
- - ffestorag_offset (cst);
-
- ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
+ case FFEINFO_whereGLOBAL:
+ assert (!ffecom_transform_only_dummies_);
- /* (t_type *) (((char *) &ct) + offset) */
+ t = build_decl (FUNCTION_DECL,
+ ffecom_get_external_identifier_ (s),
+ ffecom_tree_blockdata_type);
+ DECL_EXTERNAL (t) = 1;
+ TREE_PUBLIC (t) = 1;
- t = convert (string_type_node, /* (char *) */
- ffecom_1 (ADDR_EXPR,
- build_pointer_type (TREE_TYPE (ct)),
- ct));
- t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
- t,
- build_int_2 (offset, 0));
- t = convert (build_pointer_type (type),
- t);
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- addr = TRUE;
- }
+ ffecom_save_tree_forever (t);
- resume_momentary (yes);
- }
break;
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereRESULT:
case FFEINFO_whereFLEETING:
case FFEINFO_whereFLEETING_CADDR:
case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
case FFEINFO_whereCONSTANT_SUBOBJECT:
default:
- assert ("ENTITY where unheard of" == NULL);
+ assert ("BLOCKDATA where unheard of" == NULL);
/* Fall through. */
case FFEINFO_whereANY:
t = error_mark_node;
}
break;
- case FFEINFO_kindFUNCTION:
+ case FFEINFO_kindCOMMON:
switch (ffeinfo_where (ffesymbol_info (s)))
{
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereLOCAL:
assert (!ffecom_transform_only_dummies_);
-
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
- {
- t = ffeglobal_hook (g);
- break;
- }
-
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
- if (ffesymbol_is_f2c (s)
- && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
- t = ffecom_tree_fun_type[bt][kt];
- else
- t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
-
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- t);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
-
- resume_temporary_allocation ();
- pop_obstacks ();
-
+ ffecom_transform_common_ (s);
break;
+ case FFEINFO_whereNONE:
+ case FFEINFO_whereCOMMON:
case FFEINFO_whereDUMMY:
- assert (ffecom_transform_only_dummies_);
-
- if (ffesymbol_is_f2c (s)
- && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
- t = ffecom_tree_ptr_to_fun_type[bt][kt];
- else
- t = build_pointer_type
- (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
-
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- t);
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
-#endif
- addr = TRUE;
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
+ case FFEINFO_whereINTRINSIC:
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
+ default:
+ assert ("COMMON where unheard of" == NULL);
+ /* Fall through. */
+ case FFEINFO_whereANY:
+ t = error_mark_node;
break;
+ }
+ break;
- case FFEINFO_whereCONSTANT: /* Statement function. */
+ case FFEINFO_kindCONSTRUCT:
+ switch (ffeinfo_where (ffesymbol_info (s)))
+ {
+ case FFEINFO_whereLOCAL:
assert (!ffecom_transform_only_dummies_);
- t = ffecom_gen_sfuncdef_ (s, bt, kt);
break;
+ case FFEINFO_whereNONE:
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
+ case FFEINFO_whereGLOBAL:
+ case FFEINFO_whereRESULT:
+ case FFEINFO_whereFLEETING:
+ case FFEINFO_whereFLEETING_CADDR:
+ case FFEINFO_whereFLEETING_IADDR:
+ case FFEINFO_whereIMMEDIATE:
case FFEINFO_whereINTRINSIC:
- assert (!ffecom_transform_only_dummies_);
- break; /* Let actual references generate their
- decls. */
-
+ case FFEINFO_whereCONSTANT:
+ case FFEINFO_whereCONSTANT_SUBOBJECT:
default:
- assert ("FUNCTION where unheard of" == NULL);
+ assert ("CONSTRUCT where unheard of" == NULL);
/* Fall through. */
case FFEINFO_whereANY:
t = error_mark_node;
}
break;
- case FFEINFO_kindSUBROUTINE:
+ case FFEINFO_kindNAMELIST:
switch (ffeinfo_where (ffesymbol_info (s)))
{
- case FFEINFO_whereLOCAL: /* Me. */
+ case FFEINFO_whereLOCAL:
assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
+ t = ffecom_transform_namelist_ (s);
break;
- case FFEINFO_whereGLOBAL:
- assert (!ffecom_transform_only_dummies_);
-
- if (((g = ffesymbol_global (s)) != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
- && (ffeglobal_hook (g) != NULL_TREE)
- && ffe_is_globals ())
- {
- t = ffeglobal_hook (g);
- break;
- }
-
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
- t = build_decl (FUNCTION_DECL,
- ffecom_get_external_identifier_ (s),
- ffecom_tree_subr_type);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- if ((g != NULL)
- && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
- || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
- ffeglobal_set_hook (g, t);
-
- resume_temporary_allocation ();
- pop_obstacks ();
-
- break;
-
- case FFEINFO_whereDUMMY:
- assert (ffecom_transform_only_dummies_);
-
- t = build_decl (PARM_DECL,
- ffecom_get_identifier_ (ffesymbol_text (s)),
- ffecom_tree_ptr_to_subr_type);
-#if BUILT_FOR_270
- DECL_ARTIFICIAL (t) = 1;
-#endif
- addr = TRUE;
- break;
-
- case FFEINFO_whereINTRINSIC:
- assert (!ffecom_transform_only_dummies_);
- break; /* Let actual references generate their
- decls. */
-
- default:
- assert ("SUBROUTINE where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindPROGRAM:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- break;
-
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("PROGRAM where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindBLOCKDATA:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL: /* Me. */
- assert (!ffecom_transform_only_dummies_);
- t = current_function_decl;
- 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);
- DECL_EXTERNAL (t) = 1;
- TREE_PUBLIC (t) = 1;
-
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
-
- resume_temporary_allocation ();
- pop_obstacks ();
-
- break;
-
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("BLOCKDATA where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindCOMMON:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- ffecom_transform_common_ (s);
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("COMMON where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindCONSTRUCT:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
- case FFEINFO_whereGLOBAL:
- case FFEINFO_whereRESULT:
- case FFEINFO_whereFLEETING:
- case FFEINFO_whereFLEETING_CADDR:
- case FFEINFO_whereFLEETING_IADDR:
- case FFEINFO_whereIMMEDIATE:
- case FFEINFO_whereINTRINSIC:
- case FFEINFO_whereCONSTANT:
- case FFEINFO_whereCONSTANT_SUBOBJECT:
- default:
- assert ("CONSTRUCT where unheard of" == NULL);
- /* Fall through. */
- case FFEINFO_whereANY:
- t = error_mark_node;
- break;
- }
- break;
-
- case FFEINFO_kindNAMELIST:
- switch (ffeinfo_where (ffesymbol_info (s)))
- {
- case FFEINFO_whereLOCAL:
- assert (!ffecom_transform_only_dummies_);
- t = ffecom_transform_namelist_ (s);
- break;
-
- case FFEINFO_whereNONE:
- case FFEINFO_whereCOMMON:
- case FFEINFO_whereDUMMY:
+ case FFEINFO_whereNONE:
+ case FFEINFO_whereCOMMON:
+ case FFEINFO_whereDUMMY:
case FFEINFO_whereGLOBAL:
case FFEINFO_whereRESULT:
case FFEINFO_whereFLEETING:
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)
{
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))
if ((cbt != NULL_TREE)
&& (!is_init
|| !DECL_EXTERNAL (cbt)))
- return;
+ {
+ if (st->hook == NULL) ffestorag_set_hook (st, cbt);
+ return;
+ }
/* Process inits. */
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. */
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) + ffeglobal_common_pad (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
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
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) + ffestorag_modulo (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);
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;
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));
TYPE_FIELDS (type) = namefield;
layout_type (type);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ggc_add_tree_root (&type, 1);
}
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);
-
- domain = TYPE_DOMAIN (t);
-
- 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)));
-
- max = TYPE_MAX_VALUE (domain);
- if (!TREE_PERMANENT (max))
- {
- assert (TREE_CODE (max) == INTEGER_CST);
-
- max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
- TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
- }
-
- return build_array_type (TREE_TYPE (t),
- build_range_type (TREE_TYPE (domain),
- TYPE_MIN_VALUE (domain),
- max));
-}
-#endif
-
/* Build Vardesc type. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
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;
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;
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;
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;
}
#endif
+
/* ffecom_arg_expr -- Transform argument expr into gcc tree
See use by ffecom_list_expr.
}
#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.
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);
}
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))
{
tree known_length;
ffetargetCharacterSize sz;
+ sz = ffecom_concat_list_maxlen_ (catlist);
+ /* ~~Kludge! */
+ assert (sz != FFETARGET_charactersizeNONE);
+
+#ifdef HOHO
length_array
= lengths
= ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
= 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
known_length = ffecom_f2c_ftnlen_zero_node;
lengths);
}
- sz = ffecom_concat_list_maxlen_ (catlist);
- assert (sz != FFETARGET_charactersizeNONE);
-
- temporary = ffecom_push_tempvar (char_type_node,
- sz, -1, TRUE);
temporary = ffecom_1 (ADDR_EXPR,
build_pointer_type (TREE_TYPE (temporary)),
temporary);
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
= build_tree_list (NULL_TREE, num);
- item = ffecom_call_gfrt (FFECOM_gfrtCAT, item);
+ item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
TREE_SIDE_EFFECTS (item) = 1;
item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
item,
}
#endif
-/* ffecom_call_gfrt -- Generate call to run-time function
-
- tree expr;
- expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
+/* 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
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_call_gfrt (ffecomGfrt ix, tree args)
+ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
{
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);
+ NULL, NULL_TREE, TRUE, hook);
}
#endif
-/* ffecom_constantunion -- Transform constant-union to 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); */
+/* Transform constant-union to tree. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
#endif
+/* Transform expression into constant tree.
+
+ 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. */
+
+tree
+ffecom_const_expr (ffebld expr)
+{
+ 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;
+
+ t = ffecom_expr (expr);
+ assert (TREE_CONSTANT (t));
+ return t;
+ }
+
+ return NULL_TREE;
+}
+
/* Handy way to make a field in a struct/union. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_decl_field (tree context, tree prevfield,
- char *name, tree type)
+ const char *name, tree type)
{
tree field;
field = build_decl (FIELD_DECL, get_identifier (name), type);
DECL_CONTEXT (field) = context;
- DECL_FRAME_SIZE (field) = 0;
+ DECL_ALIGN (field) = 0;
+ DECL_USER_ALIGN (field) = 0;
if (prevfield != NULL_TREE)
TREE_CHAIN (prevfield) = field;
#endif
}
+/* End a compound statement (block). */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_end_compstmt (void)
+{
+ return bison_rule_compstmt_ ();
+}
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
+
/* ffecom_end_transition -- Perform end transition on all symbols
ffecom_end_transition();
var = build_decl (VAR_DECL,
ffecom_get_invented_identifier ("__g77_forceload_%d",
- NULL, number++),
+ number++),
dt);
DECL_EXTERNAL (var) = 0;
TREE_STATIC (var) = 1;
ffebad_set_inhibit (TRUE);
}
-/* ffecom_expand_let_stmt -- Compile let (assignment) statement
-
- ffebld dest;
- ffebld source;
- ffecom_expand_let_stmt(dest,source);
+/* Handle assignment statement.
Convert dest and source using ffecom_expr, then join them
with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
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;
+ }
+
+ ffecom_prepare_expr_w (NULL_TREE, dest);
+
+ /* 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;
- dest_tree = ffecom_expr_rw (dest);
+ ffecom_prepare_end ();
+
+ dest_tree = ffecom_expr_w (NULL_TREE, dest);
if (dest_tree == error_mark_node)
return;
FALSE, FALSE);
else
{
- source_tree = ffecom_expr (source);
+ assert (! dest_used);
dest_used = FALSE;
+ source_tree = ffecom_expr (source);
}
if (source_tree == error_mark_node)
return;
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,
return;
}
- ffecom_push_calltemps ();
+ ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
+ ffecom_prepare_expr_w (NULL_TREE, dest);
+
+ ffecom_prepare_end ();
+
ffecom_char_args_ (&dest_tree, &dest_length, dest);
ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
source);
- ffecom_pop_calltemps ();
}
#endif
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_expr_rw (ffebld expr)
+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 stabilize_reference (ffecom_expr (expr));
+}
+
+#endif
+/* Transform expr for use as into write tree and stabilize the
+ reference. Not for use on CHARACTER expressions.
+
+ Recursive descent on expr while making corresponding tree nodes and
+ attaching type info and such. */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+tree
+ffecom_expr_w (tree type, ffebld expr)
{
assert (expr != NULL);
+ /* Different target types not yet supported. */
+ assert (type == NULL_TREE || type == ffecom_type_expr (expr));
return stabilize_reference (ffecom_expr (expr));
}
void
ffecom_finish_progunit ()
{
- ffecom_end_compstmt_ ();
+ ffecom_end_compstmt ();
ffecom_previous_function_decl_ = current_function_decl;
ffecom_which_entrypoint_decl_ = NULL_TREE;
}
#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". */
+
+/* Wrapper for get_identifier. pattern is sprintf-like. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_get_invented_identifier (char *pattern, char *text, int number)
+ffecom_get_invented_identifier (const char *pattern, ...)
{
tree decl;
char *nam;
- mallocSize lenlen;
- char space[66];
+ va_list ap;
- 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);
+ va_start (ap, pattern);
+ if (vasprintf (&nam, pattern, ap) == 0)
+ abort ();
+ va_end (ap);
decl = get_identifier (nam);
- if (lenlen > ARRAY_SIZE (space))
- malloc_kill_ks (malloc_pool_image (), nam, lenlen);
-
+ free (nam);
IDENTIFIER_INVENTED (decl) = 1;
-
return decl;
}
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;
/* 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
double fl;
name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
- (int (*)()) strcmp);
+ (int (*)(const void *, const void *)) strcmp);
if (name != (char *) &names[2])
{
assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
}
}
- /* Set the sizetype before we do anything else. This _should_ be the
- first type we create. */
-
- t = make_unsigned_type (POINTER_SIZE);
- assert (t == sizetype);
-
#if FFECOM_GCC_INCLUDE
ffecom_initialize_char_syntax_ ();
#endif
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 */
+ /* Make the binding_level structure for global names. */
+ pushlevel (0);
global_binding_level = current_binding_level;
+ current_binding_level->prep_state = 2;
- /* Define `int' and `char' first so that dbx will output them first. */
+ build_common_tree_nodes (1);
- integer_type_node = make_signed_type (INT_TYPE_SIZE);
+ /* Define `int' and `char' first so that dbx will output them first. */
pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
integer_type_node));
-
- char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
char_type_node));
-
- long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
long_integer_type_node));
-
- unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
unsigned_type_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));
-
- 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));
-
- 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));
-
- error_mark_node = make_node (ERROR_MARK);
- TREE_TYPE (error_mark_node) = error_mark_node;
-
- short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
short_integer_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));
+ /* Set the sizetype before we make other types. This *should* be the
+ first type we create. */
+
+ set_sizetype
+ (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
+ ffecom_typesize_pointer_
+ = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
+
+ build_common_tree_nodes_2 (0);
+
/* 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));
- unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
unsigned_char_type_node));
- 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));
-
- 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));
-
- 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));
+ /* 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);
+
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
complex_integer_type_node));
-
- complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
complex_float_type_node));
-
- complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
complex_double_type_node));
-
- 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));
- 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;
-
- 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;
-
- 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;
-
- 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));
+ TYPE_USER_ALIGN (void_type_node) = 0;
string_type_node = build_pointer_type (char_type_node);
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));
ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
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 /* ~~~ */);
+ FFETARGET_f2cTYQUAD);
/* CHARACTER stuff is all special-cased, so it is not handled in the above
loop. CHARACTER items are built as arrays of unsigned char. */
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;
+ 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];
}
= build_function_type (void_type_node, NULL_TREE);
builtin_function ("__builtin_sqrtf", float_ftype_float,
- BUILT_IN_FSQRT, "sqrtf");
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
builtin_function ("__builtin_fsqrt", double_ftype_double,
- BUILT_IN_FSQRT, "sqrt");
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
- BUILT_IN_FSQRT, "sqrtl");
+ BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
builtin_function ("__builtin_sinf", float_ftype_float,
- BUILT_IN_SIN, "sinf");
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
builtin_function ("__builtin_sin", double_ftype_double,
- BUILT_IN_SIN, "sin");
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
- BUILT_IN_SIN, "sinl");
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
builtin_function ("__builtin_cosf", float_ftype_float,
- BUILT_IN_COS, "cosf");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
builtin_function ("__builtin_cos", double_ftype_double,
- BUILT_IN_COS, "cos");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
- BUILT_IN_COS, "cosl");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
#if BUILT_FOR_270
pedantic_lvalues = FALSE;
ffecom_master_arglist_ = NULL;
++ffecom_num_fns_;
- ffecom_latest_temp_ = NULL;
ffecom_primary_entry_ = NULL;
ffecom_is_altreturning_ = FALSE;
ffecom_func_result_ = NULL_TREE;
while (expr != NULL)
{
- *plist
- = build_tree_list (NULL_TREE, ffecom_arg_expr (ffebld_head (expr),
- &length));
+ tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
+
+ if (texpr == error_mark_node)
+ return error_mark_node;
+
+ *plist = build_tree_list (NULL_TREE, texpr);
plist = &TREE_CHAIN (*plist);
expr = ffebld_trail (expr);
if (length != NULL_TREE)
while (expr != NULL)
{
- *plist
- = build_tree_list (NULL_TREE,
- ffecom_arg_ptr_to_expr (ffebld_head (expr),
- &length));
+ tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
+
+ if (texpr == error_mark_node)
+ return error_mark_node;
+
+ *plist = build_tree_list (NULL_TREE, texpr);
plist = &TREE_CHAIN (*plist);
expr = ffebld_trail (expr);
if (length != NULL_TREE)
break;
case FFELAB_typeFORMAT:
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
glabel = build_decl (VAR_DECL,
ffecom_get_invented_identifier
- ("__g77_format_%d", NULL,
- (int) ffelab_value (label)),
+ ("__g77_format_%d", (int) ffelab_value (label)),
build_type_variant (build_array_type
(char_type_node,
NULL_TREE),
make_decl_rtl (glabel, NULL, 0);
expand_decl (glabel);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (glabel);
break;
/* Register source file name. */
void
-ffecom_file (char *name)
+ffecom_file (const char *name)
{
#if FFECOM_GCC_INCLUDE
ffecom_file_ (name);
#endif
}
-/* Clean up after making automatically popped call-arg temps.
-
- 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.
-
- 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.
-
- 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_. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_pop_calltemps ()
-{
- ffecomTemp_ temp;
-
- 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;
-}
-
-#endif
-/* Mark latest temp with given tree as no longer in use. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_pop_tempvar (tree t)
-{
- ffecomTemp_ temp;
-
- 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);
-
- assert ("couldn't ffecom_pop_tempvar!" != NULL);
-}
-
-#endif
/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
tree t;
return item;
case FFEBLD_opARRAYREF:
- {
- ffebld dims[FFECOM_dimensionsMAX];
- tree array;
- int i;
-
- item = ffecom_ptr_to_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; /* 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);
-
- for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
- i >= 0;
- --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
- {
- /* The initial subtraction should happen in the original type so
- that (possible) negative values are handled appropriately. */
- 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;
+ return ffecom_arrayref_ (NULL_TREE, expr, 1);
case FFEBLD_opCONTER:
return error_mark_node;
default:
- assert (ffecom_pending_calls_ > 0);
-
bt = ffeinfo_basictype (ffebld_info (expr));
kt = ffeinfo_kindtype (ffebld_info (expr));
}
#endif
-/* Prepare to make call-arg temps.
-
- Call this in pairs with pop_calltemps around calls to
- ffecom_arg_ptr_to_expr if the latter might use temporaries. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-void
-ffecom_push_calltemps ()
-{
- ffecom_pending_calls_++;
-}
-
-#endif
/* Obtain a temp var with given data type.
- 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. */
+ 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_push_tempvar (tree type, ffetargetCharacterSize size, int elements,
- bool auto_pop)
+ffecom_make_tempvar (const char *commentary, tree type,
+ ffetargetCharacterSize size, int elements)
{
- ffecomTemp_ temp;
int yes;
tree t;
static int mynumber;
- assert (!auto_pop || (ffecom_pending_calls_ > 0));
+ assert (current_binding_level->prep_state < 2);
if (type == error_mark_node)
return error_mark_node;
- for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
- {
- if (temp->in_use
- || (temp->type != type)
- || (temp->size != size)
- || (temp->elements != elements)
- || (DECL_CONTEXT (temp->t) != current_function_decl))
- continue;
-
- temp->in_use = TRUE;
- temp->auto_pop = auto_pop;
- return temp->t;
- }
-
- /* Create a new temp. */
-
yes = suspend_momentary ();
if (size != FFETARGET_charactersizeNONE)
build_int_2 (elements - 1,
0)));
t = build_decl (VAR_DECL,
- ffecom_get_invented_identifier ("__g77_expr_%d", NULL,
+ ffecom_get_invented_identifier ("__g77_%s_%d",
+ commentary,
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;
- sequence_rtl_expr = NULL_TREE;
+ t = start_decl (t, FALSE);
+ finish_decl (t, NULL_TREE, FALSE);
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ resume_momentary (yes);
- sequence_rtl_expr = back_end_bug;
- }
+ return t;
+}
+#endif
- resume_momentary (yes);
+/* Prepare argument pointer to expression.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_arg_ptr_to_expr. */
+
+void
+ffecom_prepare_arg_ptr_to_expr (ffebld expr)
+{
+ /* ~~For now, it seems to be the same thing. */
+ ffecom_prepare_expr (expr);
+ return;
+}
- temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
- sizeof (*temp));
+/* End of preparations. */
- 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;
+bool
+ffecom_prepare_end (void)
+{
+ int prep_state = current_binding_level->prep_state;
- ffecom_latest_temp_ = temp;
+ assert (prep_state < 2);
+ current_binding_level->prep_state = 2;
- return t;
+ return (prep_state == 1) ? TRUE : FALSE;
}
-#endif
-/* ffecom_return_expr -- Returns return-value expr given alt return expr
+/* Prepare expression.
- 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);
+ 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.
- 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). */
+ ~~Improve to avoid allocating unused temporaries by taking `dest'
+ into account vis-a-vis aliasing requirements of complex/character
+ functions. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-tree
-ffecom_return_expr (ffebld expr)
+void
+ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
{
- tree rtn;
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ ffetargetCharacterSize sz;
+ tree tempvar = NULL_TREE;
- switch (ffecom_primary_entry_kind_)
- {
- case FFEINFO_kindPROGRAM:
- case FFEINFO_kindBLOCKDATA:
- rtn = NULL_TREE;
- break;
+ assert (current_binding_level->prep_state < 2);
- 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;
+ if (! expr)
+ return;
- 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. */
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+ sz = ffeinfo_size (ffebld_info (expr));
- /* 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_));
+ /* Generate whatever temporaries are needed to represent the result
+ of the expression. */
+
+ if (bt == FFEINFO_basictypeCHARACTER)
+ {
+ while (ffebld_op (expr) == FFEBLD_opPAREN)
+ expr = ffebld_left (expr);
+ }
+
+ switch (ffebld_op (expr))
+ {
+ default:
+ /* Don't make temps for SYMTER, CONTER, etc. */
+ if (ffebld_arity (expr) == 0)
+ break;
+
+ switch (bt)
+ {
+ case FFEINFO_basictypeCOMPLEX:
+ if (ffebld_op (expr) == FFEBLD_opFUNCREF)
+ {
+ ffesymbol s;
+
+ if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
+ break;
+
+ 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;
+
+ /* ~~~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;
+
+ case FFEINFO_basictypeCHARACTER:
+ if (ffebld_op (expr) != FFEBLD_opFUNCREF)
+ break;
+
+ if (sz == FFETARGET_charactersizeNONE)
+ /* ~~Kludge alert! This should someday be fixed. */
+ sz = 24;
+
+ tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
+ break;
+
+ default:
+ break;
+ }
+ break;
+
+#ifdef HAHA
+ case FFEBLD_opPOWER:
+ {
+ tree rtype, ltype;
+ tree rtmp, ltmp, result;
+
+ ltype = ffecom_type_expr (ffebld_left (expr));
+ rtype = ffecom_type_expr (ffebld_right (expr));
+
+ rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
+ ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
+ result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
+
+ 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 */
+
+ 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. */
+
+ ffecomConcatList_ catlist;
+ tree ltmp, itmp, result;
+ int count;
+ int i;
+
+ catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
+ count = ffecom_concat_list_count_ (catlist);
+
+ 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;
+ }
+
+ 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 (expr, tempvar);
+ current_binding_level->prep_state = 1;
+ }
+ }
+ return;
+
+ 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)
+ {
+ ffebld_nonter_set_hook (expr, tempvar);
+ current_binding_level->prep_state = 1;
+ }
+
+ /* Prepare subexpressions for this expr. */
+
+ switch (ffebld_op (expr))
+ {
+ case FFEBLD_opPERCENT_LOC:
+ ffecom_prepare_ptr_to_expr (ffebld_left (expr));
+ break;
+
+ 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))
+ {
+ 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;
+ }
+ }
+
+ return;
+}
+
+/* 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)
+{
+ /* 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;
+}
+
+/* Prepare expression for writing.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_expr_w. */
+
+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));
+
+ /* ~~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. */
+
+void
+ffecom_prepare_return_expr (ffebld expr)
+{
+ assert (current_binding_level->prep_state < 2);
+
+ if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
+ && ffecom_is_altreturning_
+ && expr != NULL)
+ ffecom_prepare_expr (expr);
+}
+
+/* Prepare pointer to expression.
+
+ Like ffecom_prepare_expr, except for expressions to be evaluated
+ via ffecom_ptr_to_expr. */
+
+void
+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)
+{
+ 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
+ || 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;
+ }
+
+ return NULL_TREE;
+}
+
+/* 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);
+
+ 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_return_expr (ffebld expr)
+{
+ tree rtn;
+
+ switch (ffecom_primary_entry_kind_)
+ {
+ case FFEINFO_kindPROGRAM:
+ case FFEINFO_kindBLOCKDATA:
+ rtn = NULL_TREE;
+ break;
+
+ 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))
+ {
+ 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
+/* Start a compound statement (block). */
+
+#if FFECOM_targetCURRENT == FFECOM_targetGCC
+void
+ffecom_start_compstmt (void)
+{
+ bison_rule_pushlevel_ ();
+}
+#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
+
/* Public entry point for front end to access start_decl. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
glabel = build_decl (LABEL_DECL,
ffecom_get_invented_identifier ("__g77_label_%d",
- NULL,
mynumber++),
void_type_node);
DECL_CONTEXT (glabel) = current_function_decl;
}
#endif
-/* 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). */
+/* 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. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
-ffecom_which_entrypoint_decl ()
+ffecom_type_expr (ffebld expr)
{
- assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
+ ffeinfoBasictype bt;
+ ffeinfoKindtype kt;
+ tree tree_type;
- return ffecom_which_entrypoint_decl_;
-}
+ assert (expr != NULL);
-#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.
+ bt = ffeinfo_basictype (ffebld_info (expr));
+ kt = ffeinfo_kindtype (ffebld_info (expr));
+ tree_type = ffecom_tree_type[bt][kt];
- Functions named after rule "foo:" in c-parse.y are named
- "bison_rule_foo_" so they are easy to find. */
+ 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;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
+ 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 op for ffecom_type_expr" == NULL);
+ /* Fall through. */
+ case FFEBLD_opANY:
+ return error_mark_node;
+ }
+}
-static void
-bison_rule_compstmt_ ()
+/* 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_which_entrypoint_decl ()
{
- emit_line_note (input_filename, lineno);
- expand_end_bindings (getdecls (), 1, 1);
- poplevel (1, 1, 0);
- pop_momentary ();
+ 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.
+
+ 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
+
static void
bison_rule_pushlevel_ ()
{
expand_start_bindings (0);
}
+static tree
+bison_rule_compstmt_ ()
+{
+ tree t;
+ int keep = kept_level_p ();
+
+ /* Make the temps go away. */
+ if (! keep)
+ current_binding_level->names = NULL_TREE;
+
+ emit_line_note (input_filename, lineno);
+ expand_end_bindings (getdecls (), keep, 0);
+ t = poplevel (keep, 1, 0);
+ pop_momentary ();
+
+ return t;
+}
+
/* 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.
If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
the name to be called if we can't opencode the function. */
-static tree
-builtin_function (char *name, tree type,
- enum built_in_function function_code, char *library_name)
+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;
DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
make_decl_rtl (decl, NULL_PTR, 1);
pushdecl (decl);
- if (function_code != NOT_BUILT_IN)
- {
- DECL_BUILT_IN (decl) = 1;
- DECL_FUNCTION_CODE (decl) = function_code;
- }
+ DECL_BUILT_IN_CLASS (decl) = class;
+ DECL_FUNCTION_CODE (decl) = function_code;
return decl;
}
tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
- /* 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 (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
{
/* Function types may be shared, so we can't just modify
if (types_match)
TREE_TYPE (olddecl) = newtype;
}
-
- pop_obstacks ();
}
if (!types_match)
return 0;
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));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
-
/* Merge the data types specified in the two decls. */
if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
TREE_TYPE (newdecl)
{
/* 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_ALIGN (newdecl) = DECL_ALIGN (olddecl);
+ DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
+ }
}
/* Keep the old rtl since we can safely use it. */
DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
}
#endif
-
- pop_obstacks ();
}
/* If cannot merge, then use the new type and qualifiers,
and don't preserve the old rtl. */
&& (!types_match || new_is_definition))
{
TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
- DECL_BUILT_IN (olddecl) = 0;
+ DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
}
/* If redeclaring a builtin function, and not a definition,
{
if (DECL_BUILT_IN (olddecl))
{
- DECL_BUILT_IN (newdecl) = 1;
+ DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
}
else
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
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
}
}
- /* If requested, warn about definitions of large data objects. */
-
- if (warn_larger_than
- && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
- && !DECL_EXTERNAL (decl))
- {
- register tree decl_size = DECL_SIZE (decl);
-
- if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
- {
- unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
-
- if (units > larger_than_size)
- warning_with_decl (decl, "size of `%s' is %u bytes", units);
- }
- }
-
/* 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 ())
/* So we can tell if jump_optimize sets it to 1. */
can_reach_end = 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 (ggc_p && nested)
+ ggc_push_context ();
+
/* Run the optimizers and output the assembler code for this function. */
rest_of_compilation (fndecl);
+
+ /* Undo the GC context switch. */
+ if (ggc_p && nested)
+ ggc_pop_context ();
}
/* Free all the tree nodes making up this function. */
if (!nested)
permanent_allocation (1);
- if (DECL_SAVED_INSNS (fndecl) == 0 && !nested && (TREE_CODE (fndecl) != ERROR_MARK))
+ if (TREE_CODE (fndecl) != ERROR_MARK
+ && !nested
+ && DECL_SAVED_INSNS (fndecl) == 0)
{
/* Stop pointing to the local nodes about to be freed. */
/* But DECL_INITIAL must remain nonzero so we know this was an actual
per se, but if that comes up, it should be easy to check (being a
nested function and all). */
-static char *
+static const char *
lang_printable_name (tree decl, int v)
{
/* Just to keep GCC quiet about the unused variable.
an error. */
#if BUILT_FOR_270
-void
-lang_print_error_function (file)
- char *file;
+static void
+lang_print_error_function (const char *file)
{
static ffeglobal last_g = NULL;
static ffesymbol last_s = NULL;
ffeglobal g;
ffesymbol s;
- char *kind;
+ const char *kind;
if ((ffecom_primary_entry_ == NULL)
|| (ffesymbol_global (ffecom_primary_entry_) == NULL))
fprintf (stderr, "Outside of any program unit:\n");
else
{
- char *name = ffesymbol_text (s);
+ const char *name = ffesymbol_text (s);
fprintf (stderr, "In %s `%s':\n", kind, name);
}
IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
= TREE_VALUE (link);
- if (DECL_SAVED_INSNS (current_function_decl) == 0)
+ 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
{
register tree fndecl = current_function_decl;
+ if (fndecl == error_mark_node)
+ return;
+
/* This is a chain of PARM_DECLs from old-style parm declarations. */
DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
ffecom_outer_function_decl_ = current_function_decl;
pushlevel (0);
+ current_binding_level->prep_state = 2;
if (TREE_CODE (current_function_decl) != ERROR_MARK)
{
\f
/* Here are the public functions the GNU back end needs. */
-/* 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 ();
-}
-
tree
convert (type, expr)
tree type, expr;
return current_binding_level == global_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. */
+/* 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)
assert ("incomplete type?!?" == NULL);
}
+/* Mark ARG for GC. */
+static void
+mark_binding_level (void *arg)
+{
+ struct binding_level *level = *(struct binding_level **) arg;
+
+ while (level)
+ {
+ ggc_mark_tree (level->names);
+ ggc_mark_tree (level->blocks);
+ ggc_mark_tree (level->this_block);
+ level = level->level_chain;
+ }
+}
+
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;
+
malloc_init ();
+
+ /* Record our roots. */
+ for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); 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);
+
ffe_init_0 ();
}
-char *
+const char *
init_parse (filename)
- char *filename;
+ const char *filename;
{
-#if BUILT_FOR_270
- extern void (*print_error_function) (char *);
-#endif
-
/* Open input file. */
if (filename == 0 || !strcmp (filename, "-"))
{
fclose (finput);
}
+/* 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 void
+delete_block (block)
+ tree block;
+{
+ 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;
+}
+
void
insert_block (block)
tree block;
malloc_pool_display (malloc_pool_image ());
}
-char *
+const char *
lang_identify ()
{
return "f77";
}
+/* 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. */
+
+HOST_WIDE_INT
+lang_get_alias_set (t)
+ tree t ATTRIBUTE_UNUSED;
+{
+ /* 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;
+}
+
void
lang_init_options ()
{
flag_move_all_movables = 1;
flag_reduce_all_givs = 1;
flag_argument_noalias = 2;
+ flag_errno_math = 0;
+ flag_complex_divide_method = 1;
}
void
int functionbody;
{
register tree link;
- /* The chain of decls was accumulated in reverse order. Put it into forward
- order, just for cleanliness. */
+ /* 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;
- /* 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. */
+ /* 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
else
decls = current_binding_level->names;
- /* Output any nested inline functions within this block if they weren't
- already output. */
+ /* 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)
+ && ! 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)
+ /* 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
+ else if (DECL_SAVED_INSNS (decl) != 0)
{
push_function_context ();
output_inline_function (decl);
}
}
- /* 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. */
+ /* 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. */
block = 0;
block_previously_created = (current_binding_level->this_block != 0);
{
BLOCK_VARS (block) = decls;
BLOCK_SUBBLOCKS (block) = subblocks;
- remember_end_note (block);
}
/* In each subblock, record that this is its superior. */
}
}
- /* 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. */
+ /* 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. */
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 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. */
BLOCK_VARS (block) = 0;
}
}
/* Dispose of the block that we just made inside some higher level. */
- if (functionbody)
+ if (functionbody
+ && current_function_decl != error_mark_node)
DECL_INITIAL (current_function_decl) = block;
else if (block)
{
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. */
+ /* 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);
- /* 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.
-
- 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 (block)
TREE_USED (block) = 1;
return block;
return x;
}
+/* Nonzero if the current level needs to have a BLOCK made. */
+
+static int
+kept_level_p ()
+{
+ tree decl;
+
+ for (decl = current_binding_level->names;
+ decl;
+ decl = TREE_CHAIN (decl))
+ {
+ 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;
+ }
+ return 0;
+}
+
/* Enter a new binding level.
If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
not for that of tags. */
{
register struct binding_level *newlevel = NULL_BINDING_LEVEL;
- assert (!tag_transparent);
+ assert (! tag_transparent);
+
+ if (current_binding_level == global_binding_level)
+ {
+ named_labels = 0;
+ }
/* Reuse or create a struct for this binding level. */
newlevel = make_binding_level ();
}
- /* Add this level to the front of the chain (stack) of levels that are
- active. */
+ /* Add this level to the front of the chain (stack) of levels that
+ are active. */
*newlevel = clear_binding_level;
newlevel->level_chain = current_binding_level;
current_binding_level->this_block = block;
}
-/* ~~tree.h SHOULD declare this, because toplev.c references it. */
+/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
/* Can't 'yydebug' a front end not generated by yacc/bison! */
if (mode == TYPE_MODE (long_long_integer_type_node))
return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
+#if HOST_BITS_PER_WIDE_INT >= 64
+ if (mode == TYPE_MODE (intTI_type_node))
+ return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
+#endif
+
if (mode == TYPE_MODE (float_type_node))
return float_type_node;
return type;
}
+/* Callback routines for garbage collection. */
+
+int ggc_p = 1;
+
+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));
+}
+
+void
+lang_mark_false_label_stack (l)
+ struct label_node *l;
+{
+ /* Fortran doesn't use false_label_stack. It better be NULL. */
+ if (l != NULL)
+ abort();
+}
+
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
#if FFECOM_GCC_INCLUDE
/* 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)
+static const char *
+skip_redundant_dir_prefix (const char *dir)
{
while (dir[0] == '.' && dir[1] == '/')
for (dir += 2; *dir == '/'; dir++)
and for expanding macro arguments. */
#define INPUT_STACK_MAX 400
static struct file_buf {
- char *fname;
+ const char *fname;
/* Filename specified with #line command. */
- char *nominal_fname;
+ const char *nominal_fname;
/* Record where in the search path this file was found.
For #include_next. */
struct file_name_list *dir;
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 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 (char *dirname);
-static char *savestring (char *input);
+static struct file_name_map *read_name_map (const char *dirname);
/* Append a chain of `struct file_name_list's
to the end of the main include chain.
FILE_BUF *ip = NULL;
int i;
int first = 1;
- char *str1;
- char *str2;
+ const char *str1;
+ const char *str2;
/* If stack of files hasn't changed since we last printed
this info, don't repeat it. */
static struct file_name_map *
read_name_map (dirname)
- char *dirname;
+ const char *dirname;
{
/* This structure holds a linked list of file name maps, one per
directory. */
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_name = xstrdup (dirname);
map_list_ptr->map_list_map = NULL;
dirlen = strlen (dirname);
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;
-}
-
static void
-ffecom_file_ (char *name)
+ffecom_file_ (const char *name)
{
FILE_BUF *fp;
{
int n;
char *ep;
- char *nam;
+ const char *nam;
if ((nam = fp->nominal_fname) != 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;
+ 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;
+
+ 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;
+ }
+
+ instack[indepth].line = ffewhere_line_use (l);
+ instack[indepth].column = ffewhere_column_use (c);
+
+ fp = &instack[indepth + 1];
+ memset ((char *) fp, 0, sizeof (FILE_BUF));
+ fp->nominal_fname = fp->fname = fname;
+ fp->dir = searchptr;
+
+ indepth++;
+ input_file_stack_tick++;
+
+ return f;
+}
+#endif /* FFECOM_GCC_INCLUDE */
+
+/**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) //
+
+
+
+
+// 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 //
+
+
+
+
+// Extern is for use with -E //
+
+
+
+
+// I/O stuff //
+
+
+
+
+
+
+
+
+typedef long int // int or long int // flag;
+typedef long int // int or long int // ftnlen;
+typedef long int // int or long int // ftnint;
+
+
+//external read, write//
+typedef struct
+{ flag cierr;
+ ftnint ciunit;
+ flag ciend;
+ char *cifmt;
+ ftnint cirec;
+} cilist;
+
+//internal read, write//
+typedef struct
+{ flag icierr;
+ char *iciunit;
+ flag iciend;
+ char *icifmt;
+ ftnint icirlen;
+ ftnint icirnum;
+} icilist;
+
+//open//
+typedef struct
+{ flag oerr;
+ ftnint ounit;
+ char *ofnm;
+ ftnlen ofnmlen;
+ char *osta;
+ char *oacc;
+ char *ofm;
+ ftnint orl;
+ char *oblnk;
+} olist;
+
+//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;
+
+
+
+union Multitype { // for multiple entry points //
+ integer1 g;
+ shortint h;
+ integer i;
+ // longint j; //
+ real r;
+ doublereal d;
+ complex c;
+ doublecomplex z;
+ };
+
+typedef union Multitype Multitype;
+
+typedef long Long; // No longer used; formerly in Namelist //
+
+struct Vardesc { // for Namelist //
+ char *name;
+ char *addr;
+ ftnlen *dims;
+ int type;
+ };
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+ char *name;
+ Vardesc **vars;
+ int nvars;
+ };
+typedef struct Namelist Namelist;
+
+
+
+
+
+
+
+
+// procedure parameter types for -A and -C++ //
+
+
+
+
+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)();
+
+// 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 //
+
+// 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].) //
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+// 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: //
- 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;
- }
- }
+// FFEINTRIN_specIDINT //
+ i__1 = (integer) d1;
+ fooi_(&i__1);
- if (f == NULL)
- {
- /* A file that was not found. */
+// FFEINTRIN_imp_INT_R: //
- 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 ();
- }
+// FFEINTRIN_specIFIX //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
+// FFEINTRIN_specINT //
+ i__1 = (integer) r1;
+ fooi_(&i__1);
- if (dsp[0].fname != NULL)
- free (dsp[0].fname);
+// FFEINTRIN_imp_REAL_D: //
- if (f == NULL)
- return NULL;
+// 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
