aboutsummaryrefslogtreecommitdiff
path: root/gcc/f/com.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/f/com.c')
-rw-r--r--gcc/f/com.c265
1 files changed, 89 insertions, 176 deletions
diff --git a/gcc/f/com.c b/gcc/f/com.c
index d669515..310a3107 100644
--- a/gcc/f/com.c
+++ b/gcc/f/com.c
@@ -93,6 +93,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "intl.h"
#include "langhooks.h"
#include "langhooks-def.h"
+#include "debug.h"
/* VMS-specific definitions */
#ifdef VMS
@@ -155,7 +156,7 @@ tree string_type_node;
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. */
@@ -166,13 +167,14 @@ tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
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_
=
@@ -188,10 +190,10 @@ ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
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;
@@ -375,7 +377,7 @@ static void finish_function (int nested);
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);
@@ -397,15 +399,15 @@ static ffesymbol ffecom_primary_entry_ = NULL;
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_;
@@ -415,9 +417,9 @@ static ffetargetCharacterSize ffecom_master_size_;
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;
@@ -427,13 +429,7 @@ static int ffecom_typesize_integer1_;
/* 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. */
@@ -530,7 +526,7 @@ static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
/* 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.
@@ -547,7 +543,7 @@ struct binding_level
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;
@@ -555,36 +551,38 @@ struct binding_level
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 const 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. */
@@ -605,6 +603,24 @@ struct lang_identifier
#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")))
+{
+ 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.
@@ -614,11 +630,11 @@ struct lang_identifier
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;
/* Return the subscript expression, modified to do range-checking.
@@ -6276,27 +6292,12 @@ ffecom_gfrt_tree_ (ffecomGfrt ix)
/* 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)
@@ -9214,15 +9215,13 @@ ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
/* 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_ ();
@@ -9239,22 +9238,21 @@ ffecom_type_namelist_ ()
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",
@@ -9269,10 +9267,10 @@ ffecom_type_vardesc_ ()
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
@@ -13732,13 +13730,13 @@ lookup_name_current_level (tree name)
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
@@ -13750,7 +13748,7 @@ struct f_function
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;
@@ -13838,7 +13836,7 @@ pushdecl_top_level (x)
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;
@@ -14078,86 +14076,11 @@ global_bindings_p ()
return current_binding_level == global_binding_level;
}
-/* 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;
- }
-}
-
static void
ffecom_init_decl_processing ()
{
- static tree *const tree_roots[] = {
- &current_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 (&current_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 ();
}
@@ -14199,7 +14122,11 @@ static const char *ffe_init PARAMS ((const char *));
static void ffe_finish PARAMS ((void));
static void ffe_init_options PARAMS ((void));
static void ffe_print_identifier PARAMS ((FILE *, tree, int));
-static void ffe_mark_tree (tree);
+
+struct language_function GTY(())
+{
+ int unused;
+};
#undef LANG_HOOKS_NAME
#define LANG_HOOKS_NAME "GNU F77"
@@ -14213,8 +14140,6 @@ static void ffe_mark_tree (tree);
#define LANG_HOOKS_DECODE_OPTION ffe_decode_option
#undef LANG_HOOKS_PARSE_FILE
#define LANG_HOOKS_PARSE_FILE ffe_parse_file
-#undef LANG_HOOKS_MARK_TREE
-#define LANG_HOOKS_MARK_TREE ffe_mark_tree
#undef LANG_HOOKS_MARK_ADDRESSABLE
#define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
#undef LANG_HOOKS_PRINT_IDENTIFIER
@@ -14517,7 +14442,7 @@ poplevel (keep, reverse, functionbody)
/* 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;
@@ -14572,7 +14497,7 @@ pushdecl (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)
@@ -14704,7 +14629,7 @@ void
pushlevel (tag_transparent)
int tag_transparent;
{
- register struct binding_level *newlevel = NULL_BINDING_LEVEL;
+ register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
assert (! tag_transparent);
@@ -15138,21 +15063,6 @@ ffe_unsigned_type (type)
return type;
}
-
-static void
-ffe_mark_tree (t)
- tree t;
-{
- 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));
-}
/* From gcc/cccp.c, the code to handle -I. */
@@ -16656,3 +16566,6 @@ typedef doublereal E_f; // real function with -R not specified //
-------- (end output file from f2c)
*/
+
+#include "gt-f-com.h"
+#include "gtype-f.h"
generated by cgit v1.1 at 2024-09-27 12:08:17 +0000