diff options
Diffstat (limited to 'contrib/gcc/f/com.c')
| -rw-r--r-- | contrib/gcc/f/com.c | 680 |
1 files changed, 307 insertions, 373 deletions
diff --git a/contrib/gcc/f/com.c b/contrib/gcc/f/com.c index 13de981..fca0f94 100644 --- a/contrib/gcc/f/com.c +++ b/contrib/gcc/f/com.c @@ -82,6 +82,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "proj.h" #include "flags.h" +#include "real.h" #include "rtl.h" #include "toplev.h" #include "tree.h" @@ -92,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 @@ -154,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. */ @@ -165,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_ = @@ -187,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; @@ -261,6 +264,13 @@ struct _ffecom_concat_list_ /* 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); @@ -364,9 +374,10 @@ 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 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); @@ -388,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_; @@ -406,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; @@ -418,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. */ @@ -521,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. @@ -538,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; @@ -546,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. */ @@ -596,6 +603,25 @@ 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"), + 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. @@ -605,11 +631,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. @@ -780,6 +806,7 @@ ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims, 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), @@ -795,7 +822,7 @@ ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims, `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 @@ -854,7 +881,7 @@ ffecom_arrayref_ (tree item, ffebld expr, int want_ptr) return item; if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING - && ! mark_addressable (item)) + && ! ffe_mark_addressable (item)) return error_mark_node; } @@ -1787,15 +1814,8 @@ ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex, 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 { @@ -2143,13 +2163,8 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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); @@ -2201,13 +2216,8 @@ ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null) 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); @@ -4021,12 +4031,8 @@ ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree, 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))); @@ -5599,7 +5605,6 @@ ffecom_expr_power_integer_ (ffebld expr) ffecom_start_compstmt (); -#ifndef HAHA rtmp = ffecom_make_tempvar ("power_r", rtype, FFETARGET_charactersizeNONE, -1); ltmp = ffecom_make_tempvar ("power_l", ltype, @@ -5612,25 +5617,6 @@ ffecom_expr_power_integer_ (ffebld expr) 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, @@ -6267,27 +6253,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) @@ -6725,15 +6696,6 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, 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; @@ -6744,7 +6706,6 @@ ffecom_let_char_ (tree dest_tree, tree dest_length, length_array = lengths = TREE_VEC_ELT (hook, 0); item_array = items = TREE_VEC_ELT (hook, 1); } -#endif for (i = 0; i < count; ++i) { @@ -7484,7 +7445,7 @@ ffecom_sym_transform_ (ffesymbol s) 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)) @@ -8130,8 +8091,8 @@ ffecom_sym_transform_ (ffesymbol s) DECL_EXTERNAL (t) = 1; TREE_PUBLIC (t) = 1; - t = start_decl (t, FALSE); - finish_decl (t, NULL_TREE, FALSE); + t = start_decl (t, ffe_is_globals ()); + finish_decl (t, NULL_TREE, ffe_is_globals ()); if ((g != NULL) && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR) @@ -9205,15 +9166,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_ (); @@ -9230,22 +9189,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", @@ -9260,10 +9218,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 @@ -9525,7 +9483,7 @@ ffecom_1 (enum tree_code code, tree type, tree node) if (code == ADDR_EXPR) { - if (!mark_addressable (node)) + if (!ffe_mark_addressable (node)) assert ("can't mark_addressable this node!" == NULL); } @@ -10251,18 +10209,6 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) /* ~~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; @@ -10274,7 +10220,6 @@ ffecom_arg_ptr_to_expr (ffebld expr, tree *length) item_array = items = TREE_VEC_ELT (hook, 1); temporary = TREE_VEC_ELT (hook, 2); } -#endif known_length = ffecom_f2c_ftnlen_zero_node; @@ -10648,6 +10593,78 @@ ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt, 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: + val = ffebld_cu_val_integer4 (*cu); + item = build_int_2 (val, (val < 0) ? -1 : 0); + 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, @@ -11180,7 +11197,7 @@ ffecom_init_0 () 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); @@ -11724,23 +11741,23 @@ ffecom_init_0 () = build_function_type (void_type_node, NULL_TREE); builtin_function ("__builtin_sqrtf", float_ftype_float, - BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf"); + BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE); builtin_function ("__builtin_sqrt", double_ftype_double, - BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt"); + BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE); builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble, - BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl"); + BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE); builtin_function ("__builtin_sinf", float_ftype_float, - BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf"); + BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE); builtin_function ("__builtin_sin", double_ftype_double, - BUILT_IN_SIN, BUILT_IN_NORMAL, "sin"); + BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE); builtin_function ("__builtin_sinl", ldouble_ftype_ldouble, - BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl"); + BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE); builtin_function ("__builtin_cosf", float_ftype_float, - BUILT_IN_COSF, 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_COSL, BUILT_IN_NORMAL, "cosl"); + BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE); pedantic_lvalues = FALSE; @@ -11804,11 +11821,7 @@ ffecom_init_0 () { 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); } @@ -12466,27 +12479,6 @@ ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED) } 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 @@ -13009,7 +13001,7 @@ ffecom_temp_label () 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 @@ -13154,12 +13146,14 @@ bison_rule_compstmt_ () 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; @@ -13639,7 +13633,7 @@ finish_function (int nested) 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 @@ -13657,8 +13651,8 @@ lang_printable_name (tree decl, int v) 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; @@ -13727,13 +13721,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 @@ -13745,7 +13739,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; @@ -13833,7 +13827,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; @@ -13937,7 +13931,7 @@ start_decl (tree decl, bool is_top_level) 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. */ @@ -14054,15 +14048,6 @@ convert (type, expr) 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 @@ -14082,101 +14067,11 @@ global_bindings_p () return current_binding_level == global_binding_level; } -/* Print an error message for invalid use of an incomplete type. - VALUE is the expression that was used (or 0 if that isn't known) - and TYPE is the type that was invalid. */ - -void -incomplete_type_error (value, type) - tree value UNUSED; - tree type; -{ - if (TREE_CODE (type) == ERROR_MARK) - return; - - assert ("incomplete type?!?" == NULL); -} - -/* 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[] = { - ¤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 (); } @@ -14219,6 +14114,11 @@ static void ffe_finish PARAMS ((void)); static void ffe_init_options PARAMS ((void)); 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" #undef LANG_HOOKS_INIT @@ -14229,8 +14129,29 @@ static void ffe_print_identifier PARAMS ((FILE *, tree, int)); #define LANG_HOOKS_INIT_OPTIONS ffe_init_options #undef LANG_HOOKS_DECODE_OPTION #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_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 @@ -14242,6 +14163,37 @@ static void ffe_print_identifier PARAMS ((FILE *, tree, int)); const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER; +/* 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. */ + +#define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE, + +const char tree_code_type[] = { +#include "tree.def" +}; +#undef DEFTREECODE + +/* Table indexed by tree code giving number of expression + operands beyond the fixed part of the node structure. + Not used for types or decls. */ + +#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 const char * ffe_init (filename) const char *filename; @@ -14262,8 +14214,6 @@ ffe_init (filename) #endif ffecom_init_decl_processing (); - decl_printable_name = lang_printable_name; - print_error_function = lang_print_error_function; /* If the file is output from cpp, it should contain a first line `# 1 "real-filename"', and the current design of gcc (toplev.c @@ -14304,8 +14254,8 @@ ffe_init_options () flag_complex_divide_method = 1; } -int -mark_addressable (exp) +static bool +ffe_mark_addressable (exp) tree exp; { register tree x = exp; @@ -14320,7 +14270,7 @@ mark_addressable (exp) case CONSTRUCTOR: TREE_ADDRESSABLE (x) = 1; - return 1; + return true; case VAR_DECL: case CONST_DECL: @@ -14332,7 +14282,7 @@ mark_addressable (exp) if (TREE_PUBLIC (x)) { assert ("address of global register var requested" == NULL); - return 0; + return false; } assert ("address of register variable requested" == NULL); } @@ -14341,11 +14291,11 @@ mark_addressable (exp) 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: @@ -14356,21 +14306,10 @@ mark_addressable (exp) #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. @@ -14494,7 +14433,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; @@ -14549,7 +14488,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) @@ -14681,7 +14620,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); @@ -14724,8 +14663,8 @@ set_block (block) BLOCK_SUBBLOCKS (block)); } -tree -signed_or_unsigned_type (unsignedp, type) +static tree +ffe_signed_or_unsigned_type (unsignedp, type) int unsignedp; tree type; { @@ -14745,15 +14684,15 @@ signed_or_unsigned_type (unsignedp, type) 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) +static tree +ffe_signed_type (type) tree type; { tree type1 = TYPE_MAIN_VARIANT (type); @@ -14781,7 +14720,7 @@ signed_type (type) 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; @@ -14807,8 +14746,8 @@ signed_type (type) The resulting type should always be `integer_type_node'. */ -tree -truthvalue_conversion (expr) +static tree +ffe_truthvalue_conversion (expr) tree expr; { if (TREE_CODE (expr) == ERROR_MARK) @@ -14885,31 +14824,38 @@ truthvalue_conversion (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, @@ -14922,7 +14868,7 @@ truthvalue_conversion (expr) /* If this is widening the argument, we can ignore it. */ if (TYPE_PRECISION (TREE_TYPE (expr)) >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0)))) - return truthvalue_conversion (TREE_OPERAND (expr, 0)); + return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)); break; case MINUS_EXPR: @@ -14967,20 +14913,20 @@ truthvalue_conversion (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) +static tree +ffe_type_for_mode (mode, unsignedp) enum machine_mode mode; int unsignedp; { @@ -15039,8 +14985,8 @@ type_for_mode (mode, unsignedp) return 0; } -tree -type_for_size (bits, unsignedp) +static tree +ffe_type_for_size (bits, unsignedp) unsigned bits; int unsignedp; { @@ -15075,8 +15021,8 @@ type_for_size (bits, unsignedp) return 0; } -tree -unsigned_type (type) +static tree +ffe_unsigned_type (type) tree type; { tree type1 = TYPE_MAIN_VARIANT (type); @@ -15104,7 +15050,7 @@ unsigned_type (type) 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; @@ -15118,21 +15064,6 @@ unsigned_type (type) 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)); -} /* From gcc/cccp.c, the code to handle -I. */ @@ -15178,7 +15109,7 @@ struct file_name_list 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; }; @@ -15465,10 +15396,10 @@ read_name_map (dirname) 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) @@ -15498,10 +15429,10 @@ read_name_map (dirname) 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); } @@ -16205,7 +16136,7 @@ typedef doublereal E_f; // real function with -R not specified // // (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.) // @@ -16636,3 +16567,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" |
