/* com.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+ Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
Free Software Foundation, Inc.
Contributed by James Craig Burley.
#include "proj.h"
#include "flags.h"
+#include "real.h"
#include "rtl.h"
#include "toplev.h"
#include "tree.h"
#include "convert.h"
#include "ggc.h"
#include "diagnostic.h"
+#include "intl.h"
#include "langhooks.h"
#include "langhooks-def.h"
+#include "debug.h"
/* VMS-specific definitions */
#ifdef VMS
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 GTY(()) tree ffecom_tree_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. */
just use build_function_type and build_pointer_type on the
appropriate _tree_type array element. */
-static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
-static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
-static tree ffecom_tree_subr_type;
-static tree ffecom_tree_ptr_to_subr_type;
-static tree ffecom_tree_blockdata_type;
+static GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
+static GTY(()) tree
+ ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
+static GTY(()) tree ffecom_tree_subr_type;
+static GTY(()) tree ffecom_tree_ptr_to_subr_type;
+static GTY(()) tree ffecom_tree_blockdata_type;
-static tree ffecom_tree_xargc_;
+static GTY(()) tree ffecom_tree_xargc_;
ffecomSymbol ffecom_symbol_null_
=
int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
tree ffecom_f2c_integer_type_node;
-tree ffecom_f2c_ptr_to_integer_type_node;
+static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
tree ffecom_f2c_address_type_node;
tree ffecom_f2c_real_type_node;
-tree ffecom_f2c_ptr_to_real_type_node;
+static GTY(()) tree ffecom_f2c_ptr_to_real_type_node;
tree ffecom_f2c_doublereal_type_node;
tree ffecom_f2c_complex_type_node;
tree ffecom_f2c_doublecomplex_type_node;
/* Static functions (internal). */
+static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
+static tree ffe_type_for_size PARAMS ((unsigned int, int));
+static tree ffe_unsigned_type PARAMS ((tree));
+static tree ffe_signed_type PARAMS ((tree));
+static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
+static bool ffe_mark_addressable PARAMS ((tree));
+static tree ffe_truthvalue_conversion PARAMS ((tree));
+static void ffecom_init_decl_processing PARAMS ((void));
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,
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 const char *lang_printable_name (tree decl, int v);
+static const char *ffe_printable_name (tree decl, int v);
+static void ffe_print_error_function (diagnostic_context *, const char *);
static tree lookup_name_current_level (tree name);
-static struct binding_level *make_binding_level (void);
+static struct f_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 void start_function (tree name, tree type, int nested, int public);
static void ffecom_file_ (const char *name);
static void ffecom_close_include_ (FILE *f);
-static int ffecom_decode_include_option_ (char *spec);
static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
ffewhereColumn c);
static ffesymbol ffecom_nested_entry_ = NULL;
static ffeinfoKind ffecom_primary_entry_kind_;
static bool ffecom_primary_entry_is_proc_;
-static tree ffecom_outer_function_decl_;
-static tree ffecom_previous_function_decl_;
-static tree ffecom_which_entrypoint_decl_;
-static tree ffecom_float_zero_ = NULL_TREE;
-static tree ffecom_float_half_ = NULL_TREE;
-static tree ffecom_double_zero_ = NULL_TREE;
-static tree ffecom_double_half_ = NULL_TREE;
-static tree ffecom_func_result_;/* For functions. */
-static tree ffecom_func_length_;/* For CHARACTER fns. */
+static GTY(()) tree ffecom_outer_function_decl_;
+static GTY(()) tree ffecom_previous_function_decl_;
+static GTY(()) tree ffecom_which_entrypoint_decl_;
+static GTY(()) tree ffecom_float_zero_;
+static GTY(()) tree ffecom_float_half_;
+static GTY(()) tree ffecom_double_zero_;
+static GTY(()) tree ffecom_double_half_;
+static GTY(()) tree ffecom_func_result_;/* For functions. */
+static GTY(()) tree ffecom_func_length_;/* For CHARACTER fns. */
static ffebld ffecom_list_blockdata_;
static ffebld ffecom_list_common_;
static ffebld ffecom_master_arglist_;
static int ffecom_num_fns_ = 0;
static int ffecom_num_entrypoints_ = 0;
static bool ffecom_is_altreturning_ = FALSE;
-static tree ffecom_multi_type_node_;
-static tree ffecom_multi_retval_;
-static tree
+static GTY(()) tree ffecom_multi_type_node_;
+static GTY(()) tree ffecom_multi_retval_;
+static GTY(()) tree
ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
static bool ffecom_doing_entry_ = FALSE;
/* Holds pointer-to-function expressions. */
-static tree ffecom_gfrt_[FFECOM_gfrt]
-=
-{
-#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
-#include "com-rt.def"
-#undef DEFGFRT
-};
+static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
/* Holds the external names of the functions. */
/* Whether the function returns. */
-static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
+static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
/* Whether the function returns type complex. */
-static bool ffecom_gfrt_complex_[FFECOM_gfrt]
+static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
/* Whether the function is const
(i.e., has no side effects and only depends on its arguments). */
-static bool ffecom_gfrt_const_[FFECOM_gfrt]
+static const bool ffecom_gfrt_const_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
/* Type code for the function return value. */
-static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
+static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
=
{
#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
/* Note that the information in the `names' component of the global contour
is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
-struct binding_level
+struct f_binding_level GTY(())
{
/* A chain of _DECL nodes for all variables, constants, functions,
and typedef types. These are in the reverse of the order supplied.
tree this_block;
/* The binding level which this one is contained in (inherits from). */
- struct binding_level *level_chain;
+ struct f_binding_level *level_chain;
/* 0: no ffecom_prepare_* functions called at this level yet;
1: ffecom_prepare* functions called, except not ffecom_prepare_end;
int prep_state;
};
-#define NULL_BINDING_LEVEL (struct binding_level *) NULL
+#define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
/* The binding level currently in effect. */
-static struct binding_level *current_binding_level;
+static GTY(()) struct f_binding_level *current_binding_level;
/* A chain of binding_level structures awaiting reuse. */
-static struct binding_level *free_binding_level;
+static GTY((deletable (""))) struct f_binding_level *free_binding_level;
/* The outermost binding level, for names of file scope.
This is created when the compiler is started and exists
through the entire run. */
-static struct binding_level *global_binding_level;
+static struct f_binding_level *global_binding_level;
/* Binding level structures are initialized by copying this one. */
-static struct binding_level clear_binding_level
+static const struct f_binding_level clear_binding_level
=
{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
/* Language-dependent contents of an identifier. */
-struct lang_identifier
- {
- struct tree_identifier ignore;
- tree global_value, local_value, label_value;
- bool invented;
- };
+struct lang_identifier GTY(())
+{
+ struct tree_identifier common;
+ tree global_value;
+ tree local_value;
+ tree label_value;
+ bool invented;
+};
/* Macros for access to language-specific slots in an identifier. */
/* Each of these slots contains a DECL node or null. */
#define IDENTIFIER_INVENTED(NODE) \
(((struct lang_identifier *)(NODE))->invented)
+/* The resulting tree type. */
+union lang_tree_node
+ GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
+ chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
+{
+ union tree_node GTY ((tag ("0"),
+ desc ("tree_node_structure (&%h)")))
+ generic;
+ struct lang_identifier GTY ((tag ("1"))) identifier;
+};
+
+/* Fortran doesn't use either of these. */
+struct lang_decl GTY(())
+{
+};
+struct lang_type GTY(())
+{
+};
+
/* In identifiers, C uses the following fields in a special way:
TREE_PUBLIC to record that there was a previous local extern decl.
TREE_USED to record that such a decl was used.
that have names. Here so we can clear out their names' definitions
at the end of the function. */
-static tree named_labels;
+static GTY(()) tree named_labels;
/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
-static tree shadowed_labels;
+static GTY(()) tree shadowed_labels;
\f
/* Return the subscript expression, modified to do range-checking.
arg3);
arg4 = convert (ffecom_f2c_ftnint_type_node,
- build_int_2 (lineno, 0));
+ build_int_2 (input_line, 0));
arg1 = build_tree_list (NULL_TREE, arg1);
arg2 = build_tree_list (NULL_TREE, arg2);
die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
args, NULL_TREE);
TREE_SIDE_EFFECTS (die) = 1;
+ die = convert (void_type_node, die);
element = ffecom_3 (COND_EXPR,
TREE_TYPE (element),
`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
+ `want_ptr' is nonzero if a pointer to the element, instead of
the element itself, is to be returned. */
static tree
return item;
if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
- && ! mark_addressable (item))
+ && ! ffe_mark_addressable (item))
return error_mark_node;
}
/* Like gcc's convert(), but crashes if widening might happen. */
static tree
-ffecom_convert_narrow_ (type, expr)
- tree type, expr;
+ffecom_convert_narrow_ (tree type, tree expr)
{
register tree e = expr;
register enum tree_code code = TREE_CODE (type);
/* Like gcc's convert(), but crashes if narrowing might happen. */
static tree
-ffecom_convert_widen_ (type, expr)
- tree type, expr;
+ffecom_convert_widen_ (tree type, tree expr)
{
register tree e = expr;
register enum tree_code code = TREE_CODE (type);
{
bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
- bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
+ bothparts = build_constructor (type, bothparts);
}
else
{
tree item;
bool ptr = FALSE;
tree wanted = NULL_TREE;
- static char zed[] = "0";
+ static const char zed[] = "0";
if (c == NULL)
c = &zed[0];
callee_commons,
scalar_args))
{
-#ifdef HOHO
- tempvar = ffecom_make_tempvar (ffecom_tree_type
- [FFEINFO_basictypeCOMPLEX][kt],
- FFETARGET_charactersizeNONE,
- -1);
-#else
tempvar = hook;
assert (tempvar);
-#endif
}
else
{
if (!ffesymbol_hook (s).addr)
item = ffecom_1_fn (item);
}
-
-#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);
tree args;
tree newlen;
-#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);
if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
return type;
+ /* An array is too large if size is negative or the type_size overflows
+ or its "upper half" is larger than 3 (which would make the signed
+ byte size and offset computations overflow). */
+
if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
- || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
+ || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
+ || TREE_OVERFLOW (TYPE_SIZE (type)))))
{
ffebad_start (FFEBAD_ARRAY_LARGE);
ffebad_string (ffesymbol_text (s));
CHARACTER. */
bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
bool multi; /* Master fn has multiple return types. */
- bool altreturning = FALSE; /* This entry point has alternate returns. */
- int old_lineno = lineno;
- const char *old_input_filename = input_filename;
+ bool altreturning = FALSE; /* This entry point has alternate
+ returns. */
+ location_t old_loc = input_location;
input_filename = ffesymbol_where_filename (fn);
- lineno = ffesymbol_where_filelinenum (fn);
+ input_line = ffesymbol_where_filelinenum (fn);
ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
finish_function (0);
- lineno = old_lineno;
- input_filename = old_input_filename;
+ input_location = old_loc;
ffecom_doing_entry_ = FALSE;
}
build_range_type (ffecom_integer_type_node,
ffecom_integer_zero_node,
item));
- list = build (CONSTRUCTOR, item, NULL_TREE, list);
+ list = build_constructor (item, list);
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
return list;
build_range_type (ffecom_integer_type_node,
ffecom_integer_zero_node,
item));
- list = build (CONSTRUCTOR, item, NULL_TREE, list);
+ list = build_constructor (item, list);
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
return list;
if (ffesymbol_hook (s).assign_tree == NULL_TREE)
{
+ /* xgettext:no-c-format */
ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
FFEBAD_severityWARNING);
ffebad_string (ffesymbol_text (s));
item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
return convert (tree_type, item);
+ case FFEBLD_opPERCENT_VAL:
+ item = ffecom_arg_expr (ffebld_left (expr), &list);
+ return convert (tree_type, item);
+
case FFEBLD_opITEM:
case FFEBLD_opSTAR:
case FFEBLD_opBOUNDS:
case FFEINTRIN_impCHAR:
case FFEINTRIN_impACHAR:
-#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)));
basetypeof_l_is_int
= build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
- se = expand_start_stmt_expr ();
+ se = expand_start_stmt_expr (/*has_scope=*/1);
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);
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 */
expand_expr_stmt (ffecom_modify (void_type_node,
rtmp,
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);
tree result;
bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
static bool recurse = FALSE;
- int old_lineno = lineno;
- const char *old_input_filename = input_filename;
+ location_t old_loc = input_location;
ffecom_nested_entry_ = s;
see how it works at this point. */
input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
+ input_line = ffesymbol_where_filelinenum (s);
/* Pretransform the expression so any newly discovered things belong to the
outer program unit, not to the statement function. */
recurse = FALSE;
- lineno = old_lineno;
- input_filename = old_input_filename;
+ input_location = old_loc;
ffecom_nested_entry_ = NULL;
/* 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 GTY(())
{
struct tree_ggc_tracker *next;
tree trees[NUM_TRACKED_CHUNK];
-} *tracker_head = NULL;
-
-static void
-mark_tracker_head (void *arg)
-{
- struct tree_ggc_tracker *head;
- int i;
-
- for (head = * (struct tree_ggc_tracker **) arg;
- head != NULL;
- head = head->next)
- {
- ggc_mark (head);
- for (i = 0; i < NUM_TRACKED_CHUNK; i++)
- ggc_mark_tree (head->trees[i]);
- }
-}
+};
+static GTY(()) struct tree_ggc_tracker *tracker_head;
void
ffecom_save_tree_forever (tree t)
init = convert (type, integer_zero_node);
else if (!incremental)
{
- init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
+ init = build_constructor (type, NULL_TREE);
TREE_CONSTANT (init) = 1;
TREE_STATIC (init) = 1;
}
tree citem;
tree clength;
-#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
{
tree hook;
length_array = lengths = TREE_VEC_ELT (hook, 0);
item_array = items = TREE_VEC_ELT (hook, 1);
}
-#endif
for (i = 0; i < count; ++i)
{
&& (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;
+ location_t old_loc = input_location;
assert (fn != NULL);
assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
input_filename = ffesymbol_where_filename (fn);
- lineno = ffesymbol_where_filelinenum (fn);
+ input_line = ffesymbol_where_filelinenum (fn);
switch (ffecom_primary_entry_kind_)
{
/* Disallow temp vars at this level. */
current_binding_level->prep_state = 2;
- lineno = old_lineno;
- input_filename = old_input_filename;
+ input_location = old_loc;
/* This handles any symbols still untransformed, in case -g specified.
This used to be done in ffecom_finish_progunit, but it turns out to
ffeinfoBasictype bt;
ffeinfoKindtype kt;
ffeglobal g;
- int old_lineno = lineno;
- const char *old_input_filename = input_filename;
+ location_t old_loc = input_location;
/* Must ensure special ASSIGN variables are declared at top of outermost
block, else they'll end up in the innermost block when their first
if (ffesymbol_sfdummyparent (s) == NULL)
{
input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
+ input_line = ffesymbol_where_filelinenum (s);
}
else
{
ffesymbol sf = ffesymbol_sfdummyparent (s);
input_filename = ffesymbol_where_filename (sf);
- lineno = ffesymbol_where_filelinenum (sf);
+ input_line = ffesymbol_where_filelinenum (sf);
}
bt = ffeinfo_basictype (ffebld_info (s));
ffestorag st = ffesymbol_storage (s);
tree type;
- if ((st != NULL)
- && (ffestorag_size (st) == 0))
+ type = ffecom_type_localvar_ (s, bt, kt);
+
+ if (type == error_mark_node)
{
t = error_mark_node;
break;
}
- type = ffecom_type_localvar_ (s, bt, kt);
-
- if (type == error_mark_node)
+ if ((st != NULL)
+ && (ffestorag_size (st) == 0))
{
t = error_mark_node;
break;
assert (et != NULL_TREE);
if (! TREE_STATIC (et))
- put_var_into_stack (et);
+ put_var_into_stack (et, /*rescan=*/true);
offset = ffestorag_modulo (est)
+ ffestorag_offset (ffesymbol_storage (s))
DECL_EXTERNAL (t) = 1;
TREE_PUBLIC (t) = 1;
- t = start_decl (t, FALSE);
- finish_decl (t, NULL_TREE, FALSE);
+ t = start_decl (t, TRUE);
+ finish_decl (t, NULL_TREE, TRUE);
if ((g != NULL)
&& ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
ffesymbol_hook (s).length_tree = tlen;
ffesymbol_hook (s).addr = addr;
- lineno = old_lineno;
- input_filename = old_input_filename;
+ input_location = old_loc;
return s;
}
ffecom_sym_transform_assign_ (ffesymbol s)
{
tree t; /* Transformed thingy. */
- int old_lineno = lineno;
- const char *old_input_filename = input_filename;
+ location_t old_loc = input_location;
if (ffesymbol_sfdummyparent (s) == NULL)
{
input_filename = ffesymbol_where_filename (s);
- lineno = ffesymbol_where_filelinenum (s);
+ input_line = ffesymbol_where_filelinenum (s);
}
else
{
ffesymbol sf = ffesymbol_sfdummyparent (s);
input_filename = ffesymbol_where_filename (sf);
- lineno = ffesymbol_where_filelinenum (sf);
+ input_line = ffesymbol_where_filelinenum (sf);
}
assert (!ffecom_transform_only_dummies_);
ffesymbol_hook (s).assign_tree = t;
- lineno = old_lineno;
- input_filename = old_input_filename;
+ input_location = old_loc;
return s;
}
TREE_CHAIN (TREE_CHAIN (nmlinits))
= build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
- nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
+ nmlinits = build_constructor (nmltype, nmlinits);
TREE_CONSTANT (nmlinits) = 1;
TREE_STATIC (nmlinits) = 1;
/* Build Namelist type. */
+static GTY(()) tree ffecom_type_namelist_var;
static tree
ffecom_type_namelist_ ()
{
- static tree type = NULL_TREE;
-
- if (type == NULL_TREE)
+ if (ffecom_type_namelist_var == NULL_TREE)
{
- static tree namefield, varsfield, nvarsfield;
- tree vardesctype;
+ tree namefield, varsfield, nvarsfield, vardesctype, type;
vardesctype = ffecom_type_vardesc_ ();
TYPE_FIELDS (type) = namefield;
layout_type (type);
- ggc_add_tree_root (&type, 1);
+ ffecom_type_namelist_var = type;
}
- return type;
+ return ffecom_type_namelist_var;
}
/* Build Vardesc type. */
+static GTY(()) tree ffecom_type_vardesc_var;
static tree
ffecom_type_vardesc_ ()
{
- static tree type = NULL_TREE;
- static tree namefield, addrfield, dimsfield, typefield;
-
- if (type == NULL_TREE)
+ if (ffecom_type_vardesc_var == NULL_TREE)
{
+ tree namefield, addrfield, dimsfield, typefield, type;
type = make_node (RECORD_TYPE);
namefield = ffecom_decl_field (type, NULL_TREE, "name",
TYPE_FIELDS (type) = namefield;
layout_type (type);
- ggc_add_tree_root (&type, 1);
+ ffecom_type_vardesc_var = type;
}
- return type;
+ return ffecom_type_vardesc_var;
}
static tree
TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
= build_tree_list ((field = TREE_CHAIN (field)), typeinit);
- varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
+ varinits = build_constructor (vardesctype, varinits);
TREE_CONSTANT (varinits) = 1;
TREE_STATIC (varinits) = 1;
build_range_type (integer_type_node,
integer_one_node,
build_int_2 (i, 0)));
- list = build (CONSTRUCTOR, item, NULL_TREE, list);
+ list = build_constructor (item, list);
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
build_int_2
((int) ffesymbol_rank (s)
+ 2, 0)));
- list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
+ list = build_constructor (item, numdim);
TREE_CONSTANT (list) = 1;
TREE_STATIC (list) = 1;
if (code == ADDR_EXPR)
{
- if (!mark_addressable (node))
+ if (!ffe_mark_addressable (node))
assert ("can't mark_addressable this node!" == NULL);
}
if (TREE_SIDE_EFFECTS (node))
TREE_SIDE_EFFECTS (item) = 1;
- if ((code == ADDR_EXPR) && staticp (node))
+ if (code == ADDR_EXPR && staticp (node))
TREE_CONSTANT (item) = 1;
+ else if (code == INDIRECT_REF)
+ TREE_READONLY (item) = TYPE_READONLY (type);
return fold (item);
}
case COMPLEX_EXPR:
item = build_tree_list (TYPE_FIELDS (type), node1);
TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
- item = build (CONSTRUCTOR, type, NULL_TREE, item);
+ item = build_constructor (type, item);
break;
case PLUS_EXPR:
case FFEBLD_opPERCENT_DESCR:
switch (ffeinfo_basictype (ffebld_info (expr)))
{
-#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
- case FFEINFO_basictypeHOLLERITH:
-#endif
case FFEINFO_basictypeCHARACTER:
break; /* Passed by descriptor anyway. */
break;
}
-#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
- if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
- && (length != NULL))
- { /* Pass Hollerith by descriptor. */
- ffetargetHollerith h;
-
- assert (ffebld_op (expr) == FFEBLD_opCONTER);
- h = ffebld_cu_val_hollerith (ffebld_constant_union
- (ffebld_conter (expr)));
- *length
- = build_int_2 (h.length, 0);
- TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
- }
-#endif
-
if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
return ffecom_ptr_to_expr (expr);
/* ~~Kludge! */
assert (sz != FFETARGET_charactersizeNONE);
-#ifdef HOHO
- length_array
- = lengths
- = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
- item_array
- = items
- = ffecom_push_tempvar (ffecom_f2c_address_type_node,
- FFETARGET_charactersizeNONE, count, TRUE);
- temporary = ffecom_push_tempvar (char_type_node,
- sz, -1, TRUE);
-#else
{
tree hook;
item_array = items = TREE_VEC_ELT (hook, 1);
temporary = TREE_VEC_ELT (hook, 2);
}
-#endif
known_length = ffecom_f2c_ftnlen_zero_node;
{
case FFEINFO_basictypeINTEGER:
{
- int val;
+ HOST_WIDE_INT hi, lo;
switch (kt)
{
#if FFETARGET_okINTEGER1
case FFEINFO_kindtypeINTEGER1:
- val = ffebld_cu_val_integer1 (*cu);
+ lo = ffebld_cu_val_integer1 (*cu);
+ hi = (lo < 0) ? -1 : 0;
break;
#endif
#if FFETARGET_okINTEGER2
case FFEINFO_kindtypeINTEGER2:
- val = ffebld_cu_val_integer2 (*cu);
+ lo = ffebld_cu_val_integer2 (*cu);
+ hi = (lo < 0) ? -1 : 0;
break;
#endif
#if FFETARGET_okINTEGER3
case FFEINFO_kindtypeINTEGER3:
- val = ffebld_cu_val_integer3 (*cu);
+ lo = ffebld_cu_val_integer3 (*cu);
+ hi = (lo < 0) ? -1 : 0;
break;
#endif
#if FFETARGET_okINTEGER4
case FFEINFO_kindtypeINTEGER4:
- val = ffebld_cu_val_integer4 (*cu);
+#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
+ {
+ long long int big = ffebld_cu_val_integer4 (*cu);
+ hi = (HOST_WIDE_INT) (big >> HOST_BITS_PER_WIDE_INT);
+ lo = (HOST_WIDE_INT) big;
+ }
+#else
+ lo = ffebld_cu_val_integer4 (*cu);
+ hi = (lo < 0) ? -1 : 0;
+#endif
break;
#endif
case FFEINFO_kindtypeANY:
return error_mark_node;
}
- item = build_int_2 (val, (val < 0) ? -1 : 0);
+ item = build_int_2 (lo, hi);
TREE_TYPE (item) = tree_type;
}
break;
break;
#endif
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
- break;
-#endif
-
default:
assert ("bad REAL constant kind type" == NULL);
/* Fall through. */
break;
#endif
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
- imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
- break;
-#endif
-
default:
assert ("bad REAL constant kind type" == NULL);
/* Fall through. */
return item;
}
+/* Transform constant-union to tree, with the type known. */
+
+tree
+ffecom_constantunion_with_type (ffebldConstantUnion *cu,
+ tree tree_type, ffebldConst ct)
+{
+ tree item;
+
+ int val;
+
+ switch (ct)
+ {
+#if FFETARGET_okINTEGER1
+ case FFEBLD_constINTEGER1:
+ val = ffebld_cu_val_integer1 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+#if FFETARGET_okINTEGER2
+ case FFEBLD_constINTEGER2:
+ val = ffebld_cu_val_integer2 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+#if FFETARGET_okINTEGER3
+ case FFEBLD_constINTEGER3:
+ val = ffebld_cu_val_integer3 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+#if FFETARGET_okINTEGER4
+ case FFEBLD_constINTEGER4:
+#if HOST_BITS_PER_LONGLONG > HOST_BITS_PER_WIDE_INT
+ {
+ long long int big = ffebld_cu_val_integer4 (*cu);
+ item = build_int_2 ((HOST_WIDE_INT) big,
+ (HOST_WIDE_INT)
+ (big >> HOST_BITS_PER_WIDE_INT));
+ }
+#else
+ val = ffebld_cu_val_integer4 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+#endif
+ break;
+#endif
+#if FFETARGET_okLOGICAL1
+ case FFEBLD_constLOGICAL1:
+ val = ffebld_cu_val_logical1 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+#if FFETARGET_okLOGICAL2
+ case FFEBLD_constLOGICAL2:
+ val = ffebld_cu_val_logical2 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+#if FFETARGET_okLOGICAL3
+ case FFEBLD_constLOGICAL3:
+ val = ffebld_cu_val_logical3 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+#if FFETARGET_okLOGICAL4
+ case FFEBLD_constLOGICAL4:
+ val = ffebld_cu_val_logical4 (*cu);
+ item = build_int_2 (val, (val < 0) ? -1 : 0);
+ break;
+#endif
+ default:
+ assert ("constant type not supported"==NULL);
+ return error_mark_node;
+ break;
+ }
+
+ TREE_TYPE (item) = tree_type;
+
+ TREE_CONSTANT (item) = 1;
+
+ return item;
+}
/* Transform expression into constant tree.
If the expression can be transformed into a tree that is constant,
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))
{
ffecom_close_include_ (f);
}
-int
-ffecom_decode_include_option (char *spec)
-{
- return ffecom_decode_include_option_ (spec);
-}
-
/* End a compound statement (block). */
tree
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);
expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
dest_tree,
assign_temp);
-#endif
}
else
expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
tree field;
ffetype type;
ffetype base_type;
- tree double_ftype_double;
- tree float_ftype_float;
- tree ldouble_ftype_ldouble;
+ tree double_ftype_double, double_ftype_double_double;
+ tree float_ftype_float, float_ftype_float_float;
+ tree ldouble_ftype_ldouble, ldouble_ftype_ldouble_ldouble;
tree ffecom_tree_ptr_to_fun_type_void;
/* This block of code comes from the now-obsolete cktyps.c. It checks
name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
(int (*)(const void *, const void *)) strcmp);
- if (name != &names[0][2])
+ if (name != &names[2][0])
{
assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
== NULL);
endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
- float_ftype_float
- = build_function_type (float_type_node,
- tree_cons (NULL_TREE, float_type_node, endlink));
+ t = tree_cons (NULL_TREE, float_type_node, endlink);
+ float_ftype_float = build_function_type (float_type_node, t);
+ t = tree_cons (NULL_TREE, float_type_node, t);
+ float_ftype_float_float = build_function_type (float_type_node, t);
- double_ftype_double
- = build_function_type (double_type_node,
- tree_cons (NULL_TREE, double_type_node, endlink));
+ t = tree_cons (NULL_TREE, double_type_node, endlink);
+ double_ftype_double = build_function_type (double_type_node, t);
+ t = tree_cons (NULL_TREE, double_type_node, t);
+ double_ftype_double_double = build_function_type (double_type_node, t);
- ldouble_ftype_ldouble
- = build_function_type (long_double_type_node,
- tree_cons (NULL_TREE, long_double_type_node,
- endlink));
+ t = tree_cons (NULL_TREE, long_double_type_node, endlink);
+ ldouble_ftype_ldouble = build_function_type (long_double_type_node, t);
+ t = tree_cons (NULL_TREE, long_double_type_node, t);
+ ldouble_ftype_ldouble_ldouble = build_function_type (long_double_type_node,
+ t);
for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
ffecom_tree_blockdata_type
= build_function_type (void_type_node, NULL_TREE);
- builtin_function ("__builtin_sqrtf", float_ftype_float,
- BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
- builtin_function ("__builtin_fsqrt", double_ftype_double,
- BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
- builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
- BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
- builtin_function ("__builtin_sinf", float_ftype_float,
- BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
- builtin_function ("__builtin_sin", double_ftype_double,
- BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
- builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
- BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
+ builtin_function ("__builtin_atanf", float_ftype_float,
+ BUILT_IN_ATANF, BUILT_IN_NORMAL, "atanf", NULL_TREE);
+ builtin_function ("__builtin_atan", double_ftype_double,
+ BUILT_IN_ATAN, BUILT_IN_NORMAL, "atan", NULL_TREE);
+ builtin_function ("__builtin_atanl", ldouble_ftype_ldouble,
+ BUILT_IN_ATANL, BUILT_IN_NORMAL, "atanl", NULL_TREE);
+
+ builtin_function ("__builtin_atan2f", float_ftype_float_float,
+ BUILT_IN_ATAN2F, BUILT_IN_NORMAL, "atan2f", NULL_TREE);
+ builtin_function ("__builtin_atan2", double_ftype_double_double,
+ BUILT_IN_ATAN2, BUILT_IN_NORMAL, "atan2", NULL_TREE);
+ builtin_function ("__builtin_atan2l", ldouble_ftype_ldouble_ldouble,
+ BUILT_IN_ATAN2L, BUILT_IN_NORMAL, "atan2l", NULL_TREE);
+
builtin_function ("__builtin_cosf", float_ftype_float,
- BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
+ BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE);
builtin_function ("__builtin_cos", double_ftype_double,
- BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
+ BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE);
builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
- BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
+ BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE);
+
+ builtin_function ("__builtin_expf", float_ftype_float,
+ BUILT_IN_EXPF, BUILT_IN_NORMAL, "expf", NULL_TREE);
+ builtin_function ("__builtin_exp", double_ftype_double,
+ BUILT_IN_EXP, BUILT_IN_NORMAL, "exp", NULL_TREE);
+ builtin_function ("__builtin_expl", ldouble_ftype_ldouble,
+ BUILT_IN_EXPL, BUILT_IN_NORMAL, "expl", NULL_TREE);
+
+ builtin_function ("__builtin_floorf", float_ftype_float,
+ BUILT_IN_FLOORF, BUILT_IN_NORMAL, "floorf", NULL_TREE);
+ builtin_function ("__builtin_floor", double_ftype_double,
+ BUILT_IN_FLOOR, BUILT_IN_NORMAL, "floor", NULL_TREE);
+ builtin_function ("__builtin_floorl", ldouble_ftype_ldouble,
+ BUILT_IN_FLOORL, BUILT_IN_NORMAL, "floorl", NULL_TREE);
+
+ builtin_function ("__builtin_fmodf", float_ftype_float_float,
+ BUILT_IN_FMODF, BUILT_IN_NORMAL, "fmodf", NULL_TREE);
+ builtin_function ("__builtin_fmod", double_ftype_double_double,
+ BUILT_IN_FMOD, BUILT_IN_NORMAL, "fmod", NULL_TREE);
+ builtin_function ("__builtin_fmodl", ldouble_ftype_ldouble_ldouble,
+ BUILT_IN_FMODL, BUILT_IN_NORMAL, "fmodl", NULL_TREE);
+
+ builtin_function ("__builtin_logf", float_ftype_float,
+ BUILT_IN_LOGF, BUILT_IN_NORMAL, "logf", NULL_TREE);
+ builtin_function ("__builtin_log", double_ftype_double,
+ BUILT_IN_LOG, BUILT_IN_NORMAL, "log", NULL_TREE);
+ builtin_function ("__builtin_logl", ldouble_ftype_ldouble,
+ BUILT_IN_LOGL, BUILT_IN_NORMAL, "logl", NULL_TREE);
+
+ builtin_function ("__builtin_powf", float_ftype_float_float,
+ BUILT_IN_POWF, BUILT_IN_NORMAL, "powf", NULL_TREE);
+ builtin_function ("__builtin_pow", double_ftype_double_double,
+ BUILT_IN_POW, BUILT_IN_NORMAL, "pow", NULL_TREE);
+ builtin_function ("__builtin_powl", ldouble_ftype_ldouble_ldouble,
+ BUILT_IN_POWL, BUILT_IN_NORMAL, "powl", NULL_TREE);
+
+ builtin_function ("__builtin_sinf", float_ftype_float,
+ BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE);
+ builtin_function ("__builtin_sin", double_ftype_double,
+ BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE);
+ builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
+ BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE);
+
+ builtin_function ("__builtin_sqrtf", float_ftype_float,
+ BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE);
+ builtin_function ("__builtin_sqrt", double_ftype_double,
+ BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE);
+ builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
+ BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE);
+
+ builtin_function ("__builtin_tanf", float_ftype_float,
+ BUILT_IN_TANF, BUILT_IN_NORMAL, "tanf", NULL_TREE);
+ builtin_function ("__builtin_tan", double_ftype_double,
+ BUILT_IN_TAN, BUILT_IN_NORMAL, "tan", NULL_TREE);
+ builtin_function ("__builtin_tanl", ldouble_ftype_ldouble,
+ BUILT_IN_TANL, BUILT_IN_NORMAL, "tanl", NULL_TREE);
pedantic_lvalues = FALSE;
{
REAL_VALUE_TYPE point_5;
-#ifdef REAL_ARITHMETIC
REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
-#else
- point_5 = .5;
-#endif
ffecom_float_half_ = build_real (float_type_node, point_5);
ffecom_double_half_ = build_real (double_type_node, point_5);
}
(int) FLOAT_TYPE_SIZE);
warning ("and pointers are %d bits wide, but g77 doesn't yet work",
(int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
- warning ("properly unless they all are 32 bits wide.");
- warning ("Please keep this in mind before you report bugs. g77 should");
- warning ("support non-32-bit machines better as of version 0.6.");
+ warning ("properly unless they all are 32 bits wide");
+ warning ("Please keep this in mind before you report bugs.");
}
#endif
}
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
tree
ffecom_truth_value (tree expr)
{
- return truthvalue_conversion (expr);
+ return ffe_truthvalue_conversion (expr);
}
/* Return the inversion of a truth value (the inversion of what
static void
bison_rule_pushlevel_ ()
{
- emit_line_note (input_filename, lineno);
+ emit_line_note (input_filename, input_line);
pushlevel (0);
clear_last_expr ();
expand_start_bindings (0);
if (! keep)
current_binding_level->names = NULL_TREE;
- emit_line_note (input_filename, lineno);
+ emit_line_note (input_filename, input_line);
expand_end_bindings (getdecls (), keep, 0);
t = poplevel (keep, 1, 0);
See tree.h for its possible values.
If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
- the name to be called if we can't opencode the function. */
+ the name to be called if we can't opencode the function. If
+ ATTRS is nonzero, use that for the function's attribute list. */
tree
builtin_function (const char *name, tree type, int function_code,
enum built_in_class class,
- const char *library_name)
+ const char *library_name,
+ tree attrs ATTRIBUTE_UNUSED)
{
tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
DECL_EXTERNAL (decl) = 1;
COPY_DECL_RTL (olddecl, newdecl);
/* Merge the type qualifiers. */
- if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
- && !TREE_THIS_VOLATILE (newdecl))
- TREE_THIS_VOLATILE (olddecl) = 0;
if (TREE_READONLY (newdecl))
TREE_READONLY (olddecl) = 1;
if (TREE_THIS_VOLATILE (newdecl))
if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
+ /* Copy the assembler name. */
+ COPY_DECL_ASSEMBLER_NAME (olddecl, newdecl);
+
if (TREE_CODE (newdecl) == FUNCTION_DECL)
{
DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
+ TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
+ TREE_READONLY (newdecl) |= TREE_READONLY (olddecl);
+ DECL_IS_MALLOC (newdecl) |= DECL_IS_MALLOC (olddecl);
+ DECL_IS_PURE (newdecl) |= DECL_IS_PURE (olddecl);
}
}
/* If cannot merge, then use the new type and qualifiers,
/* Obey `register' declarations if `setjmp' is called in this fn. */
/* Generate rtl for function exit. */
- expand_function_end (input_filename, lineno, 0);
+ expand_function_end (input_filename, input_line, 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. */
nested function and all). */
static const char *
-lang_printable_name (tree decl, int v)
+ffe_printable_name (tree decl, int v)
{
/* Just to keep GCC quiet about the unused variable.
In theory, differing values of V should produce different
an error. */
static void
-lang_print_error_function (diagnostic_context *context __attribute__((unused)),
- const char *file)
+ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
+ const char *file)
{
static ffeglobal last_g = NULL;
static ffesymbol last_s = NULL;
if (ffecom_nested_entry_ == NULL)
{
s = ffecom_primary_entry_;
- switch (ffesymbol_kind (s))
- {
- case FFEINFO_kindFUNCTION:
- kind = "function";
- break;
-
- case FFEINFO_kindSUBROUTINE:
- kind = "subroutine";
- break;
-
- case FFEINFO_kindPROGRAM:
- kind = "program";
- break;
-
- case FFEINFO_kindBLOCKDATA:
- kind = "block-data";
- break;
-
- default:
- kind = ffeinfo_kind_message (ffesymbol_kind (s));
- break;
- }
+ kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
}
else
{
s = ffecom_nested_entry_;
- kind = "statement function";
+ kind = _("In statement function");
}
}
fprintf (stderr, "%s: ", file);
if (s == NULL)
- fprintf (stderr, "Outside of any program unit:\n");
+ fprintf (stderr, _("Outside of any program unit:\n"));
else
{
const char *name = ffesymbol_text (s);
- fprintf (stderr, "In %s `%s':\n", kind, name);
+ fprintf (stderr, "%s `%s':\n", kind, name);
}
last_g = g;
return t;
}
-/* Create a new `struct binding_level'. */
+/* Create a new `struct f_binding_level'. */
-static struct binding_level *
+static struct f_binding_level *
make_binding_level ()
{
/* NOSTRICT */
- return (struct binding_level *) xmalloc (sizeof (struct binding_level));
+ return ggc_alloc (sizeof (struct f_binding_level));
}
/* Save and restore the variables in this file and elsewhere
struct f_function *next;
tree named_labels;
tree shadowed_labels;
- struct binding_level *binding_level;
+ struct f_binding_level *binding_level;
};
struct f_function *f_function_chain;
/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
static tree
-pushdecl_top_level (x)
- tree x;
+pushdecl_top_level (tree x)
{
register tree t;
- register struct binding_level *b = current_binding_level;
+ register struct f_binding_level *b = current_binding_level;
register tree f = current_function_decl;
current_binding_level = global_binding_level;
after they are modified in the light of any missing parameters. */
static tree
-storedecls (decls)
- tree decls;
+storedecls (tree decls)
{
return current_binding_level->names = decls;
}
DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
/* Initialize the RTL code for the function. */
-
- init_function_start (fndecl, input_filename, lineno);
+ init_function_start (fndecl);
/* Set up parameters and prepare for return, for the function. */
-
expand_function_start (fndecl, 0);
}
Returns 1 on success. If the DECLARATOR is not suitable for a function
(it defines a datum instead), we return 0, which tells
- yyparse to report a parse error.
+ ffe_parse_file to report a parse error.
NESTED is nonzero for a function nested within another function. */
/* Here are the public functions the GNU back end needs. */
tree
-convert (type, expr)
- tree type, expr;
+convert (tree type, tree expr)
{
register tree e = expr;
register enum tree_code code = TREE_CODE (type);
return error_mark_node;
}
-/* integrate_decl_tree calls this function, but since we don't use the
- DECL_LANG_SPECIFIC field, this is a no-op. */
-
-void
-copy_lang_decl (node)
- tree node UNUSED;
-{
-}
-
/* Return the list of declarations of the current level.
Note that this list is in reverse order unless/until
you nreverse it; and when you do nreverse it, you must
return current_binding_level == global_binding_level;
}
-/* Print an error message for invalid use of an incomplete type.
- VALUE is the expression that was used (or 0 if that isn't known)
- and TYPE is the type that was invalid. */
-
-void
-incomplete_type_error (value, type)
- tree value UNUSED;
- tree type;
-{
- if (TREE_CODE (type) == ERROR_MARK)
- return;
-
- assert ("incomplete type?!?" == NULL);
-}
-
-/* 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 ()
+ffecom_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 < ARRAY_SIZE (tree_roots); i++)
- ggc_add_tree_root (tree_roots[i], 1);
- ggc_add_tree_root (&ffecom_tree_type[0][0],
- FFEINFO_basictype*FFEINFO_kindtype);
- ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
- FFEINFO_basictype*FFEINFO_kindtype);
- ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
- FFEINFO_basictype*FFEINFO_kindtype);
- ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
- ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
- mark_binding_level);
- ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
- mark_binding_level);
- ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
-
ffe_init_0 ();
}
-const char *
-init_parse (filename)
- const char *filename;
-{
- /* Open input file. */
- if (filename == 0 || !strcmp (filename, "-"))
- {
- finput = stdin;
- filename = "stdin";
- }
- else
- finput = fopen (filename, "r");
- if (finput == 0)
- fatal_io_error ("can't open %s", filename);
-
-#ifdef IO_BUFFER_SIZE
- setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
-#endif
-
- decl_printable_name = lang_printable_name;
- print_error_function = lang_print_error_function;
-
- return filename;
-}
-
-void
-finish_parse ()
-{
- 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;
+delete_block (tree block)
{
tree t;
if (current_binding_level->blocks == block)
}
void
-insert_block (block)
- tree block;
+insert_block (tree block)
{
TREE_USED (block) = 1;
current_binding_level->blocks
}
/* Each front end provides its own. */
-static void ffe_init PARAMS ((void));
+static bool ffe_init PARAMS ((void));
static void ffe_finish PARAMS ((void));
-static void ffe_init_options PARAMS ((void));
+static bool ffe_post_options PARAMS ((const char **));
+static void ffe_print_identifier PARAMS ((FILE *, tree, int));
+
+struct language_function GTY(())
+{
+ int unused;
+};
#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "GNU F77"
#define LANG_HOOKS_FINISH ffe_finish
#undef LANG_HOOKS_INIT_OPTIONS
#define LANG_HOOKS_INIT_OPTIONS ffe_init_options
-#undef LANG_HOOKS_DECODE_OPTION
-#define LANG_HOOKS_DECODE_OPTION ffe_decode_option
+#undef LANG_HOOKS_HANDLE_OPTION
+#define LANG_HOOKS_HANDLE_OPTION ffe_handle_option
+#undef LANG_HOOKS_POST_OPTIONS
+#define LANG_HOOKS_POST_OPTIONS ffe_post_options
+#undef LANG_HOOKS_PARSE_FILE
+#define LANG_HOOKS_PARSE_FILE ffe_parse_file
+#undef LANG_HOOKS_MARK_ADDRESSABLE
+#define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
+#undef LANG_HOOKS_PRINT_IDENTIFIER
+#define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
+#undef LANG_HOOKS_DECL_PRINTABLE_NAME
+#define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
+#undef LANG_HOOKS_PRINT_ERROR_FUNCTION
+#define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
+#undef LANG_HOOKS_TRUTHVALUE_CONVERSION
+#define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
+
+#undef LANG_HOOKS_TYPE_FOR_MODE
+#define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
+#undef LANG_HOOKS_TYPE_FOR_SIZE
+#define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
+#undef LANG_HOOKS_SIGNED_TYPE
+#define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
+#undef LANG_HOOKS_UNSIGNED_TYPE
+#define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
+#undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
+#define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
/* 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
const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
-/* used by print-tree.c */
+/* Table indexed by tree code giving a string containing a character
+ classifying the tree code. Possibilities are
+ t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
-void
-lang_print_xnode (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
-{
-}
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
-static void
-ffe_finish ()
-{
- ffe_terminate_0 ();
+const char tree_code_type[] = {
+#include "tree.def"
+};
+#undef DEFTREECODE
- if (ffe_is_ffedebug ())
- malloc_pool_display (malloc_pool_image ());
-}
+/* Table indexed by tree code giving number of expression
+ operands beyond the fixed part of the node structure.
+ Not used for types or decls. */
-static void
-ffe_init_options ()
+#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
+
+const unsigned char tree_code_length[] = {
+#include "tree.def"
+};
+#undef DEFTREECODE
+
+/* Names of tree components.
+ Used for printing out the tree and error messages. */
+#define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
+
+const char *const tree_code_name[] = {
+#include "tree.def"
+};
+#undef DEFTREECODE
+
+static bool
+ffe_post_options (pfilename)
+ const char **pfilename;
{
- /* Set default options for Fortran. */
- flag_move_all_movables = 1;
- flag_reduce_all_givs = 1;
- flag_argument_noalias = 2;
- flag_merge_constants = 2;
- flag_errno_math = 0;
- flag_complex_divide_method = 1;
+ const char *filename = *pfilename;
+
+ /* Open input file. */
+ if (filename == 0 || !strcmp (filename, "-"))
+ {
+ finput = stdin;
+ filename = "stdin";
+ }
+ else
+ finput = fopen (filename, "r");
+
+ if (finput == 0)
+ fatal_error ("can't open %s: %m", filename);
+
+ return false;
}
-static void
+
+static bool
ffe_init ()
{
+#ifdef IO_BUFFER_SIZE
+ setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
+#endif
+
+ ffecom_init_decl_processing ();
+
/* If the file is output from cpp, it should contain a first line
`# 1 "real-filename"', and the current design of gcc (toplev.c
in particular and the way it sets up information relied on by
"real-filename" info in master_input_filename. Ask the lexer
to try doing this. */
ffelex_hash_kludge (finput);
+
+ /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
+ set the new file name. Maybe in ffe_post_options. */
+ return true;
}
-int
-mark_addressable (exp)
- tree exp;
+static void
+ffe_finish ()
+{
+ ffe_terminate_0 ();
+
+ if (ffe_is_ffedebug ())
+ malloc_pool_display (malloc_pool_image ());
+
+ fclose (finput);
+}
+
+static bool
+ffe_mark_addressable (tree exp)
{
register tree x = exp;
while (1)
case CONSTRUCTOR:
TREE_ADDRESSABLE (x) = 1;
- return 1;
+ return true;
case VAR_DECL:
case CONST_DECL:
if (TREE_PUBLIC (x))
{
assert ("address of global register var requested" == NULL);
- return 0;
+ return false;
}
assert ("address of register variable requested" == NULL);
}
if (TREE_PUBLIC (x))
{
assert ("address of global register var requested" == NULL);
- return 0;
+ return false;
}
assert ("address of register var requested" == NULL);
}
- put_var_into_stack (x);
+ put_var_into_stack (x, /*rescan=*/true);
/* drops in */
case FUNCTION_DECL:
#endif
default:
- return 1;
+ return true;
}
}
-/* If DECL has a cleanup, build and return that cleanup here.
- This is a callback called by expand_expr. */
-
-tree
-maybe_build_cleanup (decl)
- tree decl UNUSED;
-{
- /* There are no cleanups in Fortran. */
- return NULL_TREE;
-}
-
/* Exit a binding level.
Pop the level off, and restore the state of the identifier-decl mappings
that were in effect when this level was entered.
them into the BLOCK. */
tree
-poplevel (keep, reverse, functionbody)
- int keep;
- int reverse;
- int functionbody;
+poplevel (int keep, int reverse, int functionbody)
{
register tree link;
/* The chain of decls was accumulated in reverse order.
/* Pop the current level, and free the structure for reuse. */
{
- register struct binding_level *level = current_binding_level;
+ register struct f_binding_level *level = current_binding_level;
current_binding_level = current_binding_level->level_chain;
level->level_chain = free_binding_level;
return block;
}
-void
-print_lang_decl (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
-{
-}
-
-void
-print_lang_identifier (file, node, indent)
- FILE *file;
- tree node;
- int indent;
+static void
+ffe_print_identifier (FILE *file, tree node, int indent)
{
print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
}
-void
-print_lang_statistics ()
-{
-}
-
-void
-print_lang_type (file, node, indent)
- FILE *file UNUSED;
- tree node UNUSED;
- int indent UNUSED;
-{
-}
-
/* Record a decl-node X as belonging to the current lexical scope.
Check for errors (such as an incompatible declaration for the same
name already seen in the same scope).
to agree with what X says. */
tree
-pushdecl (x)
- tree x;
+pushdecl (tree x)
{
register tree t;
register tree name = DECL_NAME (x);
- register struct binding_level *b = current_binding_level;
+ register struct f_binding_level *b = current_binding_level;
if ((TREE_CODE (x) == FUNCTION_DECL)
&& (DECL_INITIAL (x) == 0)
not for that of tags. */
void
-pushlevel (tag_transparent)
- int tag_transparent;
+pushlevel (int tag_transparent)
{
- register struct binding_level *newlevel = NULL_BINDING_LEVEL;
+ register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
assert (! tag_transparent);
(the one we are currently in). */
void
-set_block (block)
- register tree block;
+set_block (tree block)
{
current_binding_level->this_block = block;
current_binding_level->names = chainon (current_binding_level->names,
BLOCK_SUBBLOCKS (block));
}
-/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
-
-/* Can't 'yydebug' a front end not generated by yacc/bison! */
-
-void
-set_yydebug (value)
- int value;
-{
- if (value)
- fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
-}
-
-tree
-signed_or_unsigned_type (unsignedp, type)
- int unsignedp;
- tree type;
+static tree
+ffe_signed_or_unsigned_type (int unsignedp, tree type)
{
tree type2;
return (unsignedp ? long_long_unsigned_type_node
: long_long_integer_type_node);
- type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
+ type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
if (type2 == NULL_TREE)
return type;
return type2;
}
-tree
-signed_type (type)
- tree type;
+static tree
+ffe_signed_type (tree type)
{
tree type1 = TYPE_MAIN_VARIANT (type);
ffeinfoKindtype kt;
return intQI_type_node;
#endif
- type2 = type_for_size (TYPE_PRECISION (type1), 0);
+ type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
if (type2 != NULL_TREE)
return type2;
The resulting type should always be `integer_type_node'. */
-tree
-truthvalue_conversion (expr)
- tree expr;
+static tree
+ffe_truthvalue_conversion (tree expr)
{
if (TREE_CODE (expr) == ERROR_MARK)
return expr;
return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
integer_type_node,
- truthvalue_conversion (TREE_OPERAND (expr, 0)),
- truthvalue_conversion (TREE_OPERAND (expr, 1)));
+ ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
+ ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
case NEGATE_EXPR:
case ABS_EXPR:
case FLOAT_EXPR:
case FFS_EXPR:
- /* These don't change whether an object is non-zero or zero. */
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ /* These don't change whether an object is nonzero or zero. */
+ return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
case LROTATE_EXPR:
case RROTATE_EXPR:
- /* These don't change whether an object is zero or non-zero, but
+ /* These don't change whether an object is zero or nonzero, but
we can't ignore them if their second arg has side-effects. */
if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
- truthvalue_conversion (TREE_OPERAND (expr, 0)));
+ ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
else
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
case COND_EXPR:
- /* Distribute the conversion into the arms of a COND_EXPR. */
- return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
- truthvalue_conversion (TREE_OPERAND (expr, 1)),
- truthvalue_conversion (TREE_OPERAND (expr, 2))));
+ {
+ /* Distribute the conversion into the arms of a COND_EXPR. */
+ tree arg1 = TREE_OPERAND (expr, 1);
+ tree arg2 = TREE_OPERAND (expr, 2);
+ if (! VOID_TYPE_P (TREE_TYPE (arg1)))
+ arg1 = ffe_truthvalue_conversion (arg1);
+ if (! VOID_TYPE_P (TREE_TYPE (arg2)))
+ arg2 = ffe_truthvalue_conversion (arg2);
+ return fold (build (COND_EXPR, integer_type_node,
+ TREE_OPERAND (expr, 0), arg1, arg2));
+ }
case CONVERT_EXPR:
/* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
/* If this is widening the argument, we can ignore it. */
if (TYPE_PRECISION (TREE_TYPE (expr))
>= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
- return truthvalue_conversion (TREE_OPERAND (expr, 0));
+ return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
break;
case MINUS_EXPR:
((TREE_SIDE_EFFECTS (expr)
? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
integer_type_node,
- truthvalue_conversion (ffecom_1 (REALPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr)),
- truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
- TREE_TYPE (TREE_TYPE (expr)),
- expr))));
+ ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
+ TREE_TYPE (TREE_TYPE (expr)),
+ expr)),
+ ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (expr)),
+ expr))));
return ffecom_2 (NE_EXPR, integer_type_node,
expr,
convert (TREE_TYPE (expr), integer_zero_node));
}
-tree
-type_for_mode (mode, unsignedp)
- enum machine_mode mode;
- int unsignedp;
+static tree
+ffe_type_for_mode (enum machine_mode mode, int unsignedp)
{
int i;
int j;
if (mode == TYPE_MODE (double_type_node))
return double_type_node;
- if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
+ if (mode == TYPE_MODE (long_double_type_node))
+ return long_double_type_node;
+
+ if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
return build_pointer_type (char_type_node);
if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
return 0;
}
-tree
-type_for_size (bits, unsignedp)
- unsigned bits;
- int unsignedp;
+static tree
+ffe_type_for_size (unsigned bits, int unsignedp)
{
ffeinfoKindtype kt;
tree type_node;
return 0;
}
-tree
-unsigned_type (type)
- tree type;
+static tree
+ffe_unsigned_type (tree type)
{
tree type1 = TYPE_MAIN_VARIANT (type);
ffeinfoKindtype kt;
return unsigned_intQI_type_node;
#endif
- type2 = type_for_size (TYPE_PRECISION (type1), 1);
+ type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
if (type2 != NULL_TREE)
return type2;
return type;
}
-
-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));
-}
\f
/* From gcc/cccp.c, the code to handle -I. */
struct file_name_list
{
struct file_name_list *next;
- char *fname;
+ const char *fname;
/* Mapping of file names for this directory. */
struct file_name_map *name_map;
- /* Non-zero if name_map is valid. */
+ /* Nonzero if name_map is valid. */
int got_name_map;
};
FIRST is the beginning of the chain to append, and LAST is the end. */
static void
-append_include_chain (first, last)
- struct file_name_list *first, *last;
+append_include_chain (struct file_name_list *first, struct file_name_list *last)
{
struct file_name_list *dir;
read_name_map. */
static FILE *
-open_include_file (filename, searchptr)
- char *filename;
- struct file_name_list *searchptr;
+open_include_file (char *filename, struct file_name_list *searchptr)
{
register struct file_name_map *map;
register char *from;
else
str2 = "";
+ /* xgettext:no-c-format */
ffebad_start_msg ("%A from %B at %0%C", sev);
ffebad_here (0, ip->line, ip->column);
ffebad_string (str1);
file. */
static char *
-read_filename_string (ch, f)
- int ch;
- FILE *f;
+read_filename_string (int ch, FILE *f)
{
char *alloc, *set;
int len;
/* Read the file name map file for DIRNAME. */
static struct file_name_map *
-read_name_map (dirname)
- const char *dirname;
+read_name_map (const char *dirname)
{
/* This structure holds a linked list of file name maps, one per
directory. */
dirlen = strlen (dirname);
separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
- name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
- strcpy (name, dirname);
- name[dirlen] = '/';
- strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
+ if (separator_needed)
+ name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
+ else
+ name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
f = fopen (name, "r");
free (name);
if (!f)
ptr->map_to = to;
else
{
- ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
- strcpy (ptr->map_to, dirname);
- ptr->map_to[dirlen] = '/';
- strcpy (ptr->map_to + dirlen + separator_needed, to);
+ if (separator_needed)
+ ptr->map_to = concat (dirname, "/", to, NULL);
+ else
+ ptr->map_to = concat (dirname, to, NULL);
free (to);
}
ffewhere_column_kill (instack[indepth].column);
}
-static int
-ffecom_decode_include_option_ (char *spec)
+void
+ffecom_decode_include_option (const char *dir)
{
- struct file_name_list *dirtmp;
-
- if (! ignore_srcdir && !strcmp (spec, "-"))
+ if (! ignore_srcdir && !strcmp (dir, "-"))
ignore_srcdir = 1;
else
{
- dirtmp = (struct file_name_list *)
+ struct file_name_list *dirtmp = (struct file_name_list *)
xmalloc (sizeof (struct file_name_list));
dirtmp->next = 0; /* New one goes on the end */
- dirtmp->fname = spec;
+ dirtmp->fname = dir;
dirtmp->got_name_map = 0;
- if (spec[0] == 0)
- error ("Directory name must immediately follow -I");
- else
- append_include_chain (dirtmp, dirtmp);
+ append_include_chain (dirtmp, dirtmp);
}
- return 1;
}
/* Open INCLUDEd file. */
if (ep != NULL)
{
n = ep - nam;
- dsp[0].fname = (char *) xmalloc (n + 1);
- strncpy (dsp[0].fname, nam, n);
- dsp[0].fname[n] = '\0';
+ fname = xmalloc (n + 1);
+ strncpy (fname, nam, n);
+ fname[n] = '\0';
+ dsp[0].fname = fname;
if (n + INCLUDE_LEN_FUDGE > max_include_len)
max_include_len = n + INCLUDE_LEN_FUDGE;
}
if (f == NULL && errno == EACCES)
{
print_containing_files (FFEBAD_severityWARNING);
+ /* xgettext:no-c-format */
ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
FFEBAD_severityWARNING);
ffebad_string (fname);
}
if (dsp[0].fname != NULL)
- free (dsp[0].fname);
+ free ((char *) dsp[0].fname);
if (f == NULL)
return NULL;
if (indepth >= (INPUT_STACK_MAX - 1))
{
print_containing_files (FFEBAD_severityFATAL);
+ /* xgettext:no-c-format */
ffebad_start_msg ("At %0, INCLUDE nesting too deep",
FFEBAD_severityFATAL);
ffebad_string (fname);
// (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].) //
+ gcc -ansi.) //
-------- (end output file from f2c)
*/
+
+#include "gt-f-com.h"
+#include "gtype-f.h"
OSDN Git Service
