diff options
| author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2016-04-27 10:13:12 +0000 |
|---|---|---|
| committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2016-04-27 10:13:12 +0000 |
| commit | e0e4357b88efe5dc53e50d341a09de4d02331200 (patch) | |
| tree | cafff2748190357bac05d69d344e79b0e38d1e27 /gcc/ada/gcc-interface/decl.c | |
| parent | 7b48bf2011b4020c4a5a2d5d4149b03983f72cc2 (diff) | |
| download | gcc-tarball-e0e4357b88efe5dc53e50d341a09de4d02331200.tar.gz | |
gcc-6.1.0gcc-6.1.0
Diffstat (limited to 'gcc/ada/gcc-interface/decl.c')
| -rw-r--r-- | gcc/ada/gcc-interface/decl.c | 1904 |
1 files changed, 1090 insertions, 814 deletions
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index a77ca6634e..87026e742b 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2015, Free Software Foundation, Inc. * + * Copyright (C) 1992-2016, Free Software Foundation, Inc. * * * * GNAT is free software; you can redistribute it and/or modify it under * * terms of the GNU General Public License as published by the Free Soft- * @@ -26,26 +26,14 @@ #include "config.h" #include "system.h" #include "coretypes.h" -#include "tm.h" -#include "hash-set.h" -#include "machmode.h" -#include "vec.h" -#include "double-int.h" -#include "input.h" -#include "alias.h" -#include "symtab.h" -#include "wide-int.h" -#include "inchash.h" +#include "target.h" #include "tree.h" -#include "fold-const.h" #include "stringpool.h" +#include "diagnostic-core.h" +#include "alias.h" +#include "fold-const.h" #include "stor-layout.h" -#include "flags.h" -#include "toplev.h" -#include "ggc.h" -#include "target.h" #include "tree-inline.h" -#include "diagnostic-core.h" #include "ada.h" #include "types.h" @@ -55,8 +43,8 @@ #include "nlists.h" #include "repinfo.h" #include "snames.h" -#include "stringt.h" #include "uintp.h" +#include "urealp.h" #include "fe.h" #include "sinfo.h" #include "einfo.h" @@ -139,7 +127,7 @@ typedef struct variant_desc_d { /* A hash table used to cache the result of annotate_value. */ -struct value_annotation_hasher : ggc_cache_hasher<tree_int_map *> +struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map> { static inline hashval_t hash (tree_int_map *m) @@ -153,31 +141,26 @@ struct value_annotation_hasher : ggc_cache_hasher<tree_int_map *> return a->base.from == b->base.from; } - static void - handle_cache_entry (tree_int_map *&m) + static int + keep_cache_entry (tree_int_map *&m) { - extern void gt_ggc_mx (tree_int_map *&); - if (m == HTAB_EMPTY_ENTRY || m == HTAB_DELETED_ENTRY) - return; - else if (ggc_marked_p (m->base.from)) - gt_ggc_mx (m); - else - m = static_cast<tree_int_map *> (HTAB_DELETED_ENTRY); + return ggc_marked_p (m->base.from); } }; static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache; -static bool allocatable_size_p (tree, bool); static void prepend_one_attribute (struct attrib **, - enum attr_type, tree, tree, Node_Id); + enum attrib_type, tree, tree, Node_Id); static void prepend_one_attribute_pragma (struct attrib **, Node_Id); static void prepend_attributes (struct attrib **, Entity_Id); -static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool); +static tree elaborate_expression (Node_Id, Entity_Id, const char *, bool, bool, + bool); static bool type_has_variable_size (tree); -static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool); -static tree elaborate_expression_2 (tree, Entity_Id, tree, bool, bool, +static tree elaborate_expression_1 (tree, Entity_Id, const char *, bool, bool); +static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool, unsigned int); +static tree elaborate_reference (tree, Entity_Id, bool, tree *); static tree gnat_to_gnu_component_type (Entity_Id, bool, bool); static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool, bool *); @@ -187,8 +170,10 @@ static tree change_qualified_type (tree, int); static bool same_discriminant_p (Entity_Id, Entity_Id); static bool array_type_has_nonaliased_component (tree, Entity_Id); static bool compile_time_known_address_p (Node_Id); -static bool cannot_be_superflat_p (Node_Id); +static bool cannot_be_superflat (Node_Id); static bool constructor_address_p (tree); +static bool allocatable_size_p (tree, bool); +static bool initial_value_needs_conversion (tree, tree); static int compare_field_bitpos (const PTR, const PTR); static bool components_to_record (tree, Node_Id, tree, int, bool, bool, bool, bool, bool, bool, bool, bool, tree, tree *); @@ -210,7 +195,8 @@ static tree get_rep_part (tree); static tree create_variant_part_from (tree, vec<variant_desc> , tree, tree, vec<subst_pair> ); static void copy_and_substitute_in_size (tree, tree, vec<subst_pair> ); -static void add_parallel_type_for_packed_array (tree, Entity_Id); +static void associate_original_type_to_packed_array (tree, Entity_Id); +static const char *get_entity_char (Entity_Id); /* The relevant constituents of a subprogram binding to a GCC builtin. Used to pass around calls performing profile compatibility checks. */ @@ -245,6 +231,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) const Entity_Kind kind = Ekind (gnat_entity); /* True if this is a type. */ const bool is_type = IN (kind, Type_Kind); + /* True if this is an artificial entity. */ + const bool artificial_p = !Comes_From_Source (gnat_entity); /* True if debug info is requested for this entity. */ const bool debug_info_p = Needs_Debug_Info (gnat_entity); /* True if this entity is to be considered as imported. */ @@ -448,87 +436,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) switch (kind) { - case E_Constant: - /* If this is a use of a deferred constant without address clause, - get its full definition. */ - if (!definition - && No (Address_Clause (gnat_entity)) - && Present (Full_View (gnat_entity))) - { - gnu_decl - = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0); - saved = true; - break; - } - - /* If we have an external constant that we are not defining, get the - expression that is was defined to represent. We may throw it away - later if it is not a constant. But do not retrieve the expression - if it is an allocator because the designated type might be dummy - at this point. */ - if (!definition - && !No_Initialization (Declaration_Node (gnat_entity)) - && Present (Expression (Declaration_Node (gnat_entity))) - && Nkind (Expression (Declaration_Node (gnat_entity))) - != N_Allocator) - { - bool went_into_elab_proc = false; - int save_force_global = force_global; - - /* The expression may contain N_Expression_With_Actions nodes and - thus object declarations from other units. In this case, even - though the expression will eventually be discarded since not a - constant, the declarations would be stuck either in the global - varpool or in the current scope. Therefore we force the local - context and create a fake scope that we'll zap at the end. */ - if (!current_function_decl) - { - current_function_decl = get_elaboration_procedure (); - went_into_elab_proc = true; - } - force_global = 0; - gnat_pushlevel (); - - gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity))); - - gnat_zaplevel (); - force_global = save_force_global; - if (went_into_elab_proc) - current_function_decl = NULL_TREE; - } - - /* Ignore deferred constant definitions without address clause since - they are processed fully in the front-end. If No_Initialization - is set, this is not a deferred constant but a constant whose value - is built manually. And constants that are renamings are handled - like variables. */ - if (definition - && !gnu_expr - && No (Address_Clause (gnat_entity)) - && !No_Initialization (Declaration_Node (gnat_entity)) - && No (Renamed_Object (gnat_entity))) - { - gnu_decl = error_mark_node; - saved = true; - break; - } - - /* Ignore constant definitions already marked with the error node. See - the N_Object_Declaration case of gnat_to_gnu for the rationale. */ - if (definition - && gnu_expr - && present_gnu_tree (gnat_entity) - && get_gnu_tree (gnat_entity) == error_mark_node) - { - maybe_present = true; - break; - } - - goto object; - - case E_Exception: - goto object; - case E_Component: case E_Discriminant: { @@ -596,12 +503,66 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gcc_unreachable (); } + case E_Constant: + /* Ignore constant definitions already marked with the error node. See + the N_Object_Declaration case of gnat_to_gnu for the rationale. */ + if (definition + && present_gnu_tree (gnat_entity) + && get_gnu_tree (gnat_entity) == error_mark_node) + { + maybe_present = true; + break; + } + + /* Ignore deferred constant definitions without address clause since + they are processed fully in the front-end. If No_Initialization + is set, this is not a deferred constant but a constant whose value + is built manually. And constants that are renamings are handled + like variables. */ + if (definition + && !gnu_expr + && No (Address_Clause (gnat_entity)) + && !No_Initialization (Declaration_Node (gnat_entity)) + && No (Renamed_Object (gnat_entity))) + { + gnu_decl = error_mark_node; + saved = true; + break; + } + + /* If this is a use of a deferred constant without address clause, + get its full definition. */ + if (!definition + && No (Address_Clause (gnat_entity)) + && Present (Full_View (gnat_entity))) + { + gnu_decl + = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0); + saved = true; + break; + } + + /* If we have a constant that we are not defining, get the expression it + was defined to represent. This is necessary to avoid generating dumb + elaboration code in simple cases, but we may throw it away later if it + is not a constant. But do not retrieve it if it is an allocator since + the designated type might still be dummy at this point. */ + if (!definition + && !No_Initialization (Declaration_Node (gnat_entity)) + && Present (Expression (Declaration_Node (gnat_entity))) + && Nkind (Expression (Declaration_Node (gnat_entity))) + != N_Allocator) + /* The expression may contain N_Expression_With_Actions nodes and + thus object declarations from other units. Discard them. */ + gnu_expr + = gnat_to_gnu_external (Expression (Declaration_Node (gnat_entity))); + + /* ... fall through ... */ + + case E_Exception: case E_Loop_Parameter: case E_Out_Parameter: case E_Variable: - - /* Simple variables, loop variables, Out parameters and exceptions. */ - object: { /* Always create a variable for volatile objects and variables seen constant but with a Linker_Section pragma. */ @@ -617,20 +578,29 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || Present (Renamed_Object (gnat_entity)) || imported_p)); bool inner_const_flag = const_flag; - bool static_p = Is_Statically_Allocated (gnat_entity); + bool static_flag = Is_Statically_Allocated (gnat_entity); + /* We implement RM 13.3(19) for exported and imported (non-constant) + objects by making them volatile. */ + bool volatile_flag + = (Treat_As_Volatile (gnat_entity) + || (!const_flag && (Is_Exported (gnat_entity) || imported_p))); bool mutable_p = false; bool used_by_ref = false; tree gnu_ext_name = NULL_TREE; tree renamed_obj = NULL_TREE; tree gnu_object_size; + /* We need to translate the renamed object even though we are only + referencing the renaming. But it may contain a call for which + we'll generate a temporary to hold the return value and which + is part of the definition of the renaming, so discard it. */ if (Present (Renamed_Object (gnat_entity)) && !definition) { if (kind == E_Exception) gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), NULL_TREE, 0); else - gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity)); + gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity)); } /* Get the type after elaborating the renamed object. */ @@ -787,8 +757,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) calculating it each time. */ if (global_bindings_p () && !TREE_CONSTANT (gnu_size)) gnu_size = elaborate_expression_1 (gnu_size, gnat_entity, - get_identifier ("SIZE"), - definition, false); + "SIZE", definition, false); } /* If the size is zero byte, make it one byte since some linkers have @@ -816,7 +785,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) constant, set the alignment to the smallest one which is not smaller than the size, with an appropriate cap. */ if (!gnu_size && align == 0 - && (Is_Atomic (gnat_entity) + && (Is_Atomic_Or_VFA (gnat_entity) || (!Optimize_Alignment_Space (gnat_entity) && kind != E_Exception && kind != E_Out_Parameter @@ -837,7 +806,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) to support BIGGEST_ALIGNMENT if we don't really have to. So we cap to the smallest alignment that corresponds to a known efficient memory access pattern of the target. */ - if (Is_Atomic (gnat_entity)) + if (Is_Atomic_Or_VFA (gnat_entity)) { size_cap = UINT_MAX; align_cap = BIGGEST_ALIGNMENT; @@ -884,17 +853,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) check_ok_for_atomic_type (gnu_inner, gnat_entity, true); } - /* Now check if the type of the object allows atomic access. Note - that we must test the type, even if this object has size and - alignment to allow such access, because we will be going inside - the padded record to assign to the object. We could fix this by - always copying via an intermediate value, but it's not clear it's - worth the effort. */ - if (Is_Atomic (gnat_entity)) - check_ok_for_atomic_type (gnu_type, gnat_entity, false); - - /* If this is an aliased object with an unconstrained nominal subtype, - make a type that includes the template. */ + /* If this is an aliased object with an unconstrained array nominal + subtype, make a type that includes the template. We will either + allocate or create a variable of that type, see below. */ if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) && Is_Array_Type (Underlying_Type (Etype (gnat_entity))) && !type_annotate_only) @@ -958,16 +919,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) debug_info_p, gnat_entity); } + /* Now check if the type of the object allows atomic access. */ + if (Is_Atomic_Or_VFA (gnat_entity)) + check_ok_for_atomic_type (gnu_type, gnat_entity, false); + /* If this is a renaming, avoid as much as possible to create a new - object. However, in several cases, creating it is required. - This processing needs to be applied to the raw expression so - as to make it more likely to rename the underlying object. */ + object. However, in some cases, creating it is required because + renaming can be applied to objects that are not names in Ada. + This processing needs to be applied to the raw expression so as + to make it more likely to rename the underlying object. */ if (Present (Renamed_Object (gnat_entity))) { - bool create_normal_object = false; - - /* If the renamed object had padding, strip off the reference - to the inner object and reset our type. */ + /* If the renamed object had padding, strip off the reference to + the inner object and reset our type. */ if ((TREE_CODE (gnu_expr) == COMPONENT_REF && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) /* Strip useless conversions around the object. */ @@ -979,164 +943,142 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Or else, if the renamed object has an unconstrained type with default discriminant, use the padded type. */ - else if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_expr)) - && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_expr))) - == gnu_type - && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + else if (type_is_padding_self_referential (TREE_TYPE (gnu_expr))) gnu_type = TREE_TYPE (gnu_expr); - /* Case 1: If this is a constant renaming stemming from a function - call, treat it as a normal object whose initial value is what is - being renamed. RM 3.3 says that the result of evaluating a - function call is a constant object. Treat constant literals - the same way. As a consequence, it can be the inner object of - a constant renaming. In this case, the renaming must be fully - instantiated, i.e. it cannot be a mere reference to (part of) an - existing object. */ - if (const_flag) - { - tree inner_object = gnu_expr; - while (handled_component_p (inner_object)) - inner_object = TREE_OPERAND (inner_object, 0); - if (TREE_CODE (inner_object) == CALL_EXPR - || CONSTANT_CLASS_P (inner_object)) - create_normal_object = true; - } + /* Case 1: if this is a constant renaming stemming from a function + call, treat it as a normal object whose initial value is what + is being renamed. RM 3.3 says that the result of evaluating a + function call is a constant object. Therefore, it can be the + inner object of a constant renaming and the renaming must be + fully instantiated, i.e. it cannot be a reference to (part of) + an existing object. And treat other rvalues (addresses, null + expressions, constructors and literals) the same way. */ + tree inner = gnu_expr; + while (handled_component_p (inner) || CONVERT_EXPR_P (inner)) + inner = TREE_OPERAND (inner, 0); + /* Expand_Dispatching_Call can prepend a comparison of the tags + before the call to "=". */ + if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR + || TREE_CODE (inner) == COMPOUND_EXPR) + inner = TREE_OPERAND (inner, 1); + if ((TREE_CODE (inner) == CALL_EXPR + && !call_is_atomic_load (inner)) + || TREE_CODE (inner) == ADDR_EXPR + || TREE_CODE (inner) == NULL_EXPR + || TREE_CODE (inner) == CONSTRUCTOR + || CONSTANT_CLASS_P (inner) + /* We need to detect the case where a temporary is created to + hold the return value, since we cannot safely rename it at + top level as it lives only in the elaboration routine. */ + || (TREE_CODE (inner) == VAR_DECL + && DECL_RETURN_VALUE_P (inner)) + /* We also need to detect the case where the front-end creates + a dangling 'reference to a function call at top level and + substitutes it in the renaming, for example: + + q__b : boolean renames r__f.e (1); + + can be rewritten into: + + q__R1s : constant q__A2s := r__f'reference; + [...] + q__b : boolean renames q__R1s.all.e (1); + + We cannot safely rename the rewritten expression since the + underlying object lives only in the elaboration routine. */ + || (TREE_CODE (inner) == INDIRECT_REF + && (inner + = remove_conversions (TREE_OPERAND (inner, 0), true)) + && TREE_CODE (inner) == VAR_DECL + && DECL_RETURN_VALUE_P (inner))) + ; - /* Otherwise, see if we can proceed with a stabilized version of - the renamed entity or if we need to make a new object. */ - if (!create_normal_object) + /* Case 2: if the renaming entity need not be materialized, use + the elaborated renamed expression for the renaming. But this + means that the caller is responsible for evaluating the address + of the renaming in the correct place for the definition case to + instantiate the SAVE_EXPRs. */ + else if (!Materialize_Entity (gnat_entity)) { - tree maybe_stable_expr = NULL_TREE; - bool stable = false; - - /* Case 2: If the renaming entity need not be materialized and - the renamed expression is something we can stabilize, use - that for the renaming. At the global level, we can only do - this if we know no SAVE_EXPRs need be made, because the - expression we return might be used in arbitrary conditional - branches so we must force the evaluation of the SAVE_EXPRs - immediately and this requires a proper function context. - Note that an external constant is at the global level. */ - if (!Materialize_Entity (gnat_entity) - && (!((!definition && kind == E_Constant) - || global_bindings_p ()) - || (staticp (gnu_expr) - && !TREE_SIDE_EFFECTS (gnu_expr)))) - { - maybe_stable_expr - = gnat_stabilize_reference (gnu_expr, true, &stable); + tree init = NULL_TREE; - if (stable) - { - /* ??? No DECL_EXPR is created so we need to mark - the expression manually lest it is shared. */ - if ((!definition && kind == E_Constant) - || global_bindings_p ()) - MARK_VISITED (maybe_stable_expr); - gnu_decl = maybe_stable_expr; - save_gnu_tree (gnat_entity, gnu_decl, true); - saved = true; - annotate_object (gnat_entity, gnu_type, NULL_TREE, - false); - /* This assertion will fail if the renamed object - isn't aligned enough as to make it possible to - honor the alignment set on the renaming. */ - if (align) - { - unsigned int renamed_align - = DECL_P (gnu_decl) - ? DECL_ALIGN (gnu_decl) - : TYPE_ALIGN (TREE_TYPE (gnu_decl)); - gcc_assert (renamed_align >= align); - } - break; - } - - /* The stabilization failed. Keep maybe_stable_expr - untouched here to let the pointer case below know - about that failure. */ + gnu_decl + = elaborate_reference (gnu_expr, gnat_entity, definition, + &init); + + /* We cannot evaluate the first arm of a COMPOUND_EXPR in the + correct place for this case. */ + gcc_assert (!init); + + /* No DECL_EXPR will be created so the expression needs to be + marked manually because it will likely be shared. */ + if (global_bindings_p ()) + MARK_VISITED (gnu_decl); + + /* This assertion will fail if the renamed object isn't aligned + enough as to make it possible to honor the alignment set on + the renaming. */ + if (align) + { + unsigned int ralign = DECL_P (gnu_decl) + ? DECL_ALIGN (gnu_decl) + : TYPE_ALIGN (TREE_TYPE (gnu_decl)); + gcc_assert (ralign >= align); } - /* Case 3: Make this into a constant pointer to the object we - are to rename and attach the object to the pointer if it is - something we can stabilize. - - From the proper scope, attached objects will be referenced - directly instead of indirectly via the pointer to avoid - subtle aliasing problems with non-addressable entities. - They have to be stable because we must not evaluate the - variables in the expression every time the renaming is used. - The pointer is called a "renaming" pointer in this case. + save_gnu_tree (gnat_entity, gnu_decl, true); + saved = true; + annotate_object (gnat_entity, gnu_type, NULL_TREE, false); + break; + } - In the rare cases where we cannot stabilize the renamed - object, we just make a "bare" pointer and the renamed - object will always be accessed indirectly through it. + /* Case 3: otherwise, make a constant pointer to the object we + are renaming and attach the object to the pointer after it is + elaborated. The object will be referenced directly instead + of indirectly via the pointer to avoid aliasing problems with + non-addressable entities. The pointer is called a "renaming" + pointer in this case. Note that we also need to preserve the + volatility of the renamed object through the indirection. */ + else + { + tree init = NULL_TREE; - Note that we need to preserve the volatility of the renamed - object through the indirection. */ if (TREE_THIS_VOLATILE (gnu_expr) && !TYPE_VOLATILE (gnu_type)) gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); gnu_type = build_reference_type (gnu_type); - inner_const_flag = TREE_READONLY (gnu_expr); + used_by_ref = true; const_flag = true; + volatile_flag = false; + inner_const_flag = TREE_READONLY (gnu_expr); + gnu_size = NULL_TREE; - /* If the previous attempt at stabilizing failed, there is - no point in trying again and we reuse the result without - attaching it to the pointer. In this case it will only - be used as the initializing expression of the pointer and - thus needs no special treatment with regard to multiple - evaluations. - - Otherwise, try to stabilize and attach the expression to - the pointer if the stabilization succeeds. - - Note that this might introduce SAVE_EXPRs and we don't - check whether we are at the global level or not. This - is fine since we are building a pointer initializer and - neither the pointer nor the initializing expression can - be accessed before the pointer elaboration has taken - place in a correct program. - - These SAVE_EXPRs will be evaluated at the right place - by either the evaluation of the initializer for the - non-global case or the elaboration code for the global - case, and will be attached to the elaboration procedure - in the latter case. */ - if (!maybe_stable_expr) - { - maybe_stable_expr - = gnat_stabilize_reference (gnu_expr, true, &stable); + renamed_obj + = elaborate_reference (gnu_expr, gnat_entity, definition, + &init); - if (stable) - renamed_obj = maybe_stable_expr; - } + /* The expression needs to be marked manually because it will + likely be shared, even for a definition since the ADDR_EXPR + built below can cause the first few nodes to be folded. */ + if (global_bindings_p ()) + MARK_VISITED (renamed_obj); if (type_annotate_only - && TREE_CODE (maybe_stable_expr) == ERROR_MARK) + && TREE_CODE (renamed_obj) == ERROR_MARK) gnu_expr = NULL_TREE; else - gnu_expr - = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr); - - gnu_size = NULL_TREE; - used_by_ref = true; + { + gnu_expr + = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj); + if (init) + gnu_expr + = build_compound_expr (TREE_TYPE (gnu_expr), init, + gnu_expr); + } } } - /* Make a volatile version of this object's type if we are to make - the object volatile. We also interpret 13.3(19) conservatively - and disallow any optimizations for such a non-constant object. */ - if ((Treat_As_Volatile (gnat_entity) - || (!const_flag - && gnu_type != except_type_node - && (Is_Exported (gnat_entity) - || imported_p - || Present (Address_Clause (gnat_entity))))) - && !TYPE_VOLATILE (gnu_type)) - gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); - /* If we are defining an aliased object whose nominal subtype is unconstrained, the object is a record that contains both the template and the object. If there is an initializer, it will @@ -1166,28 +1108,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_expr = gnat_build_constructor (gnu_type, v); } - /* Convert the expression to the type of the object except in the - case where the object's type is unconstrained or the object's type - is a padded record whose field is of self-referential size. In - the former case, converting will generate unnecessary evaluations - of the CONSTRUCTOR to compute the size and in the latter case, we - want to only copy the actual data. Also don't convert to a record - type with a variant part from a record type without one, to keep - the object simpler. */ - if (gnu_expr - && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TYPE_IS_PADDING_P (gnu_type) - && CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE - && get_variant_part (gnu_type) != NULL_TREE - && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)) + /* Convert the expression to the type of the object if need be. */ + if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr)) gnu_expr = convert (gnu_type, gnu_expr); /* If this is a pointer that doesn't have an initializing expression, - initialize it to NULL, unless the object is imported. */ + initialize it to NULL, unless the object is declared imported as + per RM B.1(24). */ if (definition && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type)) && !gnu_expr @@ -1201,32 +1128,61 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) effects in this case. */ if (definition && Present (Address_Clause (gnat_entity))) { - Node_Id gnat_expr = Expression (Address_Clause (gnat_entity)); + const Node_Id gnat_clause = Address_Clause (gnat_entity); + Node_Id gnat_expr = Expression (gnat_clause); tree gnu_address = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr); save_gnu_tree (gnat_entity, NULL_TREE, false); - /* Ignore the size. It's either meaningless or was handled - above. */ - gnu_size = NULL_TREE; /* Convert the type of the object to a reference type that can - alias everything as per 13.3(19). */ + alias everything as per RM 13.3(19). */ + if (volatile_flag && !TYPE_VOLATILE (gnu_type)) + gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); gnu_type = build_reference_type_for_mode (gnu_type, ptr_mode, true); gnu_address = convert (gnu_type, gnu_address); used_by_ref = true; const_flag - = !Is_Public (gnat_entity) - || compile_time_known_address_p (gnat_expr); + = (!Is_Public (gnat_entity) + || compile_time_known_address_p (gnat_expr)); + volatile_flag = false; + gnu_size = NULL_TREE; - /* If this is a deferred constant, the initializer is attached to - the full view. */ - if (kind == E_Constant && Present (Full_View (gnat_entity))) - gnu_expr - = gnat_to_gnu - (Expression (Declaration_Node (Full_View (gnat_entity)))); + /* If this is an aliased object with an unconstrained array nominal + subtype, then it can overlay only another aliased object with an + unconstrained array nominal subtype and compatible template. */ + if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) + && Is_Array_Type (Underlying_Type (Etype (gnat_entity))) + && !type_annotate_only) + { + tree rec_type = TREE_TYPE (gnu_type); + tree off = byte_position (DECL_CHAIN (TYPE_FIELDS (rec_type))); + + /* This is the pattern built for a regular object. */ + if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR + && TREE_OPERAND (gnu_address, 1) == off) + gnu_address = TREE_OPERAND (gnu_address, 0); + /* This is the pattern built for an overaligned object. */ + else if (TREE_CODE (gnu_address) == POINTER_PLUS_EXPR + && TREE_CODE (TREE_OPERAND (gnu_address, 1)) + == PLUS_EXPR + && TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 1) + == off) + gnu_address + = build2 (POINTER_PLUS_EXPR, gnu_type, + TREE_OPERAND (gnu_address, 0), + TREE_OPERAND (TREE_OPERAND (gnu_address, 1), 0)); + else + { + post_error_ne ("aliased object& with unconstrained array " + "nominal subtype", gnat_clause, + gnat_entity); + post_error ("\\can overlay only aliased object with " + "compatible subtype", gnat_clause); + } + } /* If we don't have an initializing expression for the underlying variable, the initializing expression for the pointer is the @@ -1237,11 +1193,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else gnu_expr = build2 (COMPOUND_EXPR, gnu_type, - build_binary_op - (MODIFY_EXPR, NULL_TREE, - build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_address), - gnu_expr), + build_binary_op (INIT_EXPR, NULL_TREE, + build_unary_op (INDIRECT_REF, + NULL_TREE, + gnu_address), + gnu_expr), gnu_address); } @@ -1249,13 +1205,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) as an indirect object. Likewise for Stdcall objects that are imported. */ if ((!definition && Present (Address_Clause (gnat_entity))) - || (Is_Imported (gnat_entity) - && Has_Stdcall_Convention (gnat_entity))) + || (imported_p && Has_Stdcall_Convention (gnat_entity))) { /* Convert the type of the object to a reference type that can - alias everything as per 13.3(19). */ + alias everything as per RM 13.3(19). */ + if (volatile_flag && !TYPE_VOLATILE (gnu_type)) + gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); gnu_type = build_reference_type_for_mode (gnu_type, ptr_mode, true); + used_by_ref = true; + const_flag = false; + volatile_flag = false; gnu_size = NULL_TREE; /* No point in taking the address of an initializing expression @@ -1276,8 +1236,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) const_flag = true; } } - - used_by_ref = true; } /* If we are at top level and this object is of variable size, @@ -1293,7 +1251,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type), global_bindings_p () || !definition - || static_p) + || static_flag) || (gnu_size && !allocatable_size_p (convert (sizetype, size_binop @@ -1301,11 +1259,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) bitsize_unit_node)), global_bindings_p () || !definition - || static_p))) + || static_flag))) { + if (volatile_flag && !TYPE_VOLATILE (gnu_type)) + gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); gnu_type = build_reference_type (gnu_type); - gnu_size = NULL_TREE; used_by_ref = true; + const_flag = true; + volatile_flag = false; + gnu_size = NULL_TREE; /* In case this was a aliased object whose nominal subtype is unconstrained, the pointer above will be a thin pointer and @@ -1330,12 +1292,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type))); if (TREE_CODE (gnu_expr) == CONSTRUCTOR - && 1 == vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr))) - gnu_expr = 0; + && vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr)) == 1) + gnu_expr = NULL_TREE; else gnu_expr = build_component_ref - (gnu_expr, NULL_TREE, + (gnu_expr, DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))), false); } @@ -1348,20 +1310,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type, Empty, Empty, gnat_entity, mutable_p); - const_flag = true; } else - { - gnu_expr = NULL_TREE; - const_flag = false; - } + gnu_expr = NULL_TREE; } /* If this object would go into the stack and has an alignment larger than the largest stack alignment the back-end can honor, resort to a variable of "aligning type". */ - if (!global_bindings_p () && !static_p && definition - && !imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) + if (definition + && !global_bindings_p () + && !static_flag + && !imported_p + && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT) { /* Create the new variable. No need for extra room before the aligned field as this is in automatic storage. */ @@ -1371,16 +1332,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) BIGGEST_ALIGNMENT, 0, gnat_entity); tree gnu_new_var = create_var_decl (create_concat_name (gnat_entity, "ALIGN"), - NULL_TREE, gnu_new_type, NULL_TREE, false, - false, false, false, NULL, gnat_entity); + NULL_TREE, gnu_new_type, NULL_TREE, + false, false, false, false, false, + true, debug_info_p, NULL, gnat_entity); /* Initialize the aligned field if we have an initializer. */ if (gnu_expr) add_stmt_with_node - (build_binary_op (MODIFY_EXPR, NULL_TREE, + (build_binary_op (INIT_EXPR, NULL_TREE, build_component_ref - (gnu_new_var, NULL_TREE, - TYPE_FIELDS (gnu_new_type), false), + (gnu_new_var, TYPE_FIELDS (gnu_new_type), + false), gnu_expr), gnat_entity); @@ -1388,48 +1350,53 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = build_reference_type (gnu_type); gnu_expr = build_unary_op - (ADDR_EXPR, gnu_type, - build_component_ref (gnu_new_var, NULL_TREE, - TYPE_FIELDS (gnu_new_type), false)); + (ADDR_EXPR, NULL_TREE, + build_component_ref (gnu_new_var, TYPE_FIELDS (gnu_new_type), + false)); + TREE_CONSTANT (gnu_expr) = 1; - gnu_size = NULL_TREE; used_by_ref = true; const_flag = true; + volatile_flag = false; + gnu_size = NULL_TREE; } - /* If this is an aliased object with an unconstrained nominal subtype, - we make its type a thin reference, i.e. the reference counterpart - of a thin pointer, so that it points to the array part. This is - aimed at making it easier for the debugger to decode the object. - Note that we have to do that this late because of the couple of - allocation adjustments that might be made just above. */ + /* If this is an aliased object with an unconstrained array nominal + subtype, we make its type a thin reference, i.e. the reference + counterpart of a thin pointer, so it points to the array part. + This is aimed to make it easier for the debugger to decode the + object. Note that we have to do it this late because of the + couple of allocation adjustments that might be made above. */ if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity)) && Is_Array_Type (Underlying_Type (Etype (gnat_entity))) && !type_annotate_only) { - tree gnu_array - = gnat_to_gnu_type (Base_Type (Etype (gnat_entity))); - /* In case the object with the template has already been allocated just above, we have nothing to do here. */ if (!TYPE_IS_THIN_POINTER_P (gnu_type)) { + /* This variable is a GNAT encoding used by Workbench: let it + go through the debugging information but mark it as + artificial: users are not interested in it. */ tree gnu_unc_var = create_var_decl (concat_name (gnu_entity_name, "UNC"), NULL_TREE, gnu_type, gnu_expr, const_flag, Is_Public (gnat_entity), - imported_p || !definition, static_p, + imported_p || !definition, static_flag, + volatile_flag, true, debug_info_p, NULL, gnat_entity); - gnu_expr - = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var); + gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var); TREE_CONSTANT (gnu_expr) = 1; - gnu_size = NULL_TREE; used_by_ref = true; - inner_const_flag = TREE_READONLY (gnu_unc_var); const_flag = true; + volatile_flag = false; + inner_const_flag = TREE_READONLY (gnu_unc_var); + gnu_size = NULL_TREE; } + tree gnu_array + = gnat_to_gnu_type (Base_Type (Etype (gnat_entity))); gnu_type = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array)); } @@ -1437,37 +1404,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (const_flag) gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST); - /* Convert the expression to the type of the object except in the - case where the object's type is unconstrained or the object's type - is a padded record whose field is of self-referential size. In - the former case, converting will generate unnecessary evaluations - of the CONSTRUCTOR to compute the size and in the latter case, we - want to only copy the actual data. Also don't convert to a record - type with a variant part from a record type without one, to keep - the object simpler. */ - if (gnu_expr - && TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE - && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) - && !(TYPE_IS_PADDING_P (gnu_type) - && CONTAINS_PLACEHOLDER_P - (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))) - && !(TREE_CODE (gnu_type) == RECORD_TYPE - && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE - && get_variant_part (gnu_type) != NULL_TREE - && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)) + /* Convert the expression to the type of the object if need be. */ + if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr)) gnu_expr = convert (gnu_type, gnu_expr); /* If this name is external or a name was specified, use it, but don't use the Interface_Name with an address clause (see cd30005). */ - if ((Present (Interface_Name (gnat_entity)) - && No (Address_Clause (gnat_entity))) - || (Is_Public (gnat_entity) - && (!Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))) + if ((Is_Public (gnat_entity) && !Is_Imported (gnat_entity)) + || (Present (Interface_Name (gnat_entity)) + && No (Address_Clause (gnat_entity)))) gnu_ext_name = create_concat_name (gnat_entity, NULL); /* If this is an aggregate constant initialized to a constant, force it to be statically allocated. This saves an initialization copy. */ - if (!static_p + if (!static_flag && const_flag && gnu_expr && TREE_CONSTANT (gnu_expr) && AGGREGATE_TYPE_P (gnu_type) @@ -1475,7 +1425,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && !(TYPE_IS_PADDING_P (gnu_type) && !tree_fits_uhwi_p (TYPE_SIZE_UNIT (TREE_TYPE (TYPE_FIELDS (gnu_type)))))) - static_p = true; + static_flag = true; /* Deal with a pragma Linker_Section on a constant or variable. */ if ((kind == E_Constant || kind == E_Variable) @@ -1485,10 +1435,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Now create the variable or the constant and set various flags. */ gnu_decl - = create_var_decl_1 (gnu_entity_name, gnu_ext_name, gnu_type, - gnu_expr, const_flag, Is_Public (gnat_entity), - imported_p || !definition, static_p, - !renamed_obj, attr_list, gnat_entity); + = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, + gnu_expr, const_flag, Is_Public (gnat_entity), + imported_p || !definition, static_flag, + volatile_flag, artificial_p, debug_info_p, + attr_list, gnat_entity, !renamed_obj); DECL_BY_REF_P (gnu_decl) = used_by_ref; DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity); @@ -1516,18 +1467,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else if (kind == E_Loop_Parameter) DECL_LOOP_PARM_P (gnu_decl) = 1; - /* If this is a renaming pointer, attach the renamed object to it and - register it if we are at the global level. Note that an external - constant is at the global level. */ + /* If this is a renaming pointer, attach the renamed object to it. */ if (renamed_obj) - { - SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); - if ((!definition && kind == E_Constant) || global_bindings_p ()) - { - DECL_RENAMING_GLOBAL_P (gnu_decl) = 1; - record_global_renaming_pointer (gnu_decl); - } - } + SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); /* If this is a constant and we are defining it or it generates a real symbol at the object level and we are referencing it, we may want @@ -1546,19 +1488,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || Is_Aliased (Etype (gnat_entity)))) { tree gnu_corr_var - = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, - gnu_expr, true, Is_Public (gnat_entity), - !definition, static_p, attr_list, - gnat_entity); + = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, + gnu_expr, true, Is_Public (gnat_entity), + !definition, static_flag, volatile_flag, + artificial_p, debug_info_p, attr_list, + gnat_entity, false); SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var); - - /* As debugging information will be generated for the variable, - do not generate debugging information for the constant. */ - if (debug_info_p) - DECL_IGNORED_P (gnu_decl) = 1; - else - DECL_IGNORED_P (gnu_corr_var) = 1; } /* If this is a constant, even if we don't need a true variable, we @@ -1574,7 +1510,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) exception handler, and we aren't using the GCC exception mechanism, we must force this variable in memory in order to avoid an invalid optimization. */ - if (Exception_Mechanism != Back_End_Exceptions + if (Front_End_Exceptions () && Has_Nested_Block_With_Handler (Scope (gnat_entity))) TREE_ADDRESSABLE (gnu_decl) = 1; @@ -1593,9 +1529,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If we are defining an object with variable size or an object with fixed size that will be dynamically allocated, and we are using the - setjmp/longjmp exception mechanism, update the setjmp buffer. */ + front-end setjmp/longjmp exception mechanism, update the setjmp + buffer. */ if (definition - && Exception_Mechanism == Setjmp_Longjmp + && Exception_Mechanism == Front_End_SJLJ && get_block_jmpbuf_decl () && DECL_SIZE_UNIT (gnu_decl) && (TREE_CODE (DECL_SIZE_UNIT (gnu_decl)) != INTEGER_CST @@ -1628,16 +1565,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) case E_Enumeration_Type: /* A special case: for the types Character and Wide_Character in Standard, we do not list all the literals. So if the literals - are not specified, make this an unsigned integer type. */ + are not specified, make this an integer type. */ if (No (First_Literal (gnat_entity))) { - gnu_type = make_unsigned_type (esize); + if (esize == CHAR_TYPE_SIZE && flag_signed_char) + gnu_type = make_signed_type (CHAR_TYPE_SIZE); + else + gnu_type = make_unsigned_type (esize); TYPE_NAME (gnu_type) = gnu_entity_name; /* Set TYPE_STRING_FLAG for Character and Wide_Character types. This is needed by the DWARF-2 back-end to distinguish between unsigned integer types and character types. */ TYPE_STRING_FLAG (gnu_type) = 1; + + /* This flag is needed by the call just below. */ + TYPE_ARTIFICIAL (gnu_type) = artificial_p; + + finish_character_type (gnu_type); } else { @@ -1667,12 +1612,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type); + /* Do not generate debug info for individual enumerators. */ tree gnu_literal = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, gnu_type, gnu_value, true, false, false, - false, NULL, gnat_literal); - /* Do not generate debug info for individual enumerators. */ - DECL_IGNORED_P (gnu_literal) = 1; + false, false, artificial_p, false, + NULL, gnat_literal); save_gnu_tree (gnat_literal, gnu_literal, false); gnu_list = tree_cons (DECL_NAME (gnu_literal), gnu_value, gnu_list); @@ -1688,13 +1633,80 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) break; case E_Signed_Integer_Type: - case E_Ordinary_Fixed_Point_Type: - case E_Decimal_Fixed_Point_Type: /* For integer types, just make a signed type the appropriate number of bits. */ gnu_type = make_signed_type (esize); goto discrete_type; + case E_Ordinary_Fixed_Point_Type: + case E_Decimal_Fixed_Point_Type: + { + /* Small_Value is the scale factor. */ + const Ureal gnat_small_value = Small_Value (gnat_entity); + tree scale_factor = NULL_TREE; + + gnu_type = make_signed_type (esize); + + /* Try to decode the scale factor and to save it for the fixed-point + types debug hook. */ + + /* There are various ways to describe the scale factor, however there + are cases where back-end internals cannot hold it. In such cases, + we output invalid scale factor for such cases (i.e. the 0/0 + rational constant) but we expect GNAT to output GNAT encodings, + then. Thus, keep this in sync with + Exp_Dbug.Is_Handled_Scale_Factor. */ + + /* When encoded as 1/2**N or 1/10**N, describe the scale factor as a + binary or decimal scale: it is easier to read for humans. */ + if (UI_Eq (Numerator (gnat_small_value), Uint_1) + && (Rbase (gnat_small_value) == 2 + || Rbase (gnat_small_value) == 10)) + { + /* Given RM restrictions on 'Small values, we assume here that + the denominator fits in an int. */ + const tree base = build_int_cst (integer_type_node, + Rbase (gnat_small_value)); + const tree exponent + = build_int_cst (integer_type_node, + UI_To_Int (Denominator (gnat_small_value))); + scale_factor + = build2 (RDIV_EXPR, integer_type_node, + integer_one_node, + build2 (POWER_EXPR, integer_type_node, + base, exponent)); + } + + /* Default to arbitrary scale factors descriptions. */ + else + { + const Uint num = Norm_Num (gnat_small_value); + const Uint den = Norm_Den (gnat_small_value); + + if (UI_Is_In_Int_Range (num) && UI_Is_In_Int_Range (den)) + { + const tree gnu_num + = build_int_cst (integer_type_node, + UI_To_Int (Norm_Num (gnat_small_value))); + const tree gnu_den + = build_int_cst (integer_type_node, + UI_To_Int (Norm_Den (gnat_small_value))); + scale_factor = build2 (RDIV_EXPR, integer_type_node, + gnu_num, gnu_den); + } + else + /* If compiler internals cannot represent arbitrary scale + factors, output an invalid scale factor so that debugger + don't try to handle them but so that we still have a type + in the output. Note that GNAT */ + scale_factor = integer_zero_node; + } + + TYPE_FIXED_POINT_P (gnu_type) = 1; + SET_TYPE_SCALE_FACTOR (gnu_type, scale_factor); + } + goto discrete_type; + case E_Modular_Integer_Type: { /* For modular types, make the unsigned type of the proper number @@ -1717,7 +1729,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_MODULAR_P (gnu_type) = 1; SET_TYPE_MODULUS (gnu_type, gnu_modulus); gnu_high = fold_build2 (MINUS_EXPR, gnu_type, gnu_modulus, - convert (gnu_type, integer_one_node)); + build_int_cst (gnu_type, 1)); } /* If the upper bound is not maximal, make an extra subtype. */ @@ -1766,12 +1778,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))) esize = UI_To_Int (RM_Size (gnat_entity)); - /* This should be an unsigned type if the base type is unsigned or + /* First subtypes of Character are treated as Character; otherwise + this should be an unsigned type if the base type is unsigned or if the lower bound is constant and non-negative or if the type is biased. */ - if (Is_Unsigned_Type (Etype (gnat_entity)) - || Is_Unsigned_Type (gnat_entity) - || Has_Biased_Representation (gnat_entity)) + if (kind == E_Enumeration_Subtype + && No (First_Literal (Etype (gnat_entity))) + && Esize (gnat_entity) == RM_Size (gnat_entity) + && esize == CHAR_TYPE_SIZE + && flag_signed_char) + gnu_type = make_signed_type (CHAR_TYPE_SIZE); + else if (Is_Unsigned_Type (Etype (gnat_entity)) + || Is_Unsigned_Type (gnat_entity) + || Has_Biased_Representation (gnat_entity)) gnu_type = make_unsigned_type (esize); else gnu_type = make_signed_type (esize); @@ -1779,19 +1798,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) SET_TYPE_RM_MIN_VALUE (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, get_identifier ("L"), - definition, true, - Needs_Debug_Info (gnat_entity))); + gnat_entity, "L", definition, true, + debug_info_p)); SET_TYPE_RM_MAX_VALUE (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, get_identifier ("U"), - definition, true, - Needs_Debug_Info (gnat_entity))); + gnat_entity, "U", definition, true, + debug_info_p)); TYPE_BIASED_REPRESENTATION_P (gnu_type) = Has_Biased_Representation (gnat_entity); + /* Set TYPE_STRING_FLAG for Character and Wide_Character subtypes. */ + TYPE_STRING_FLAG (gnu_type) = TYPE_STRING_FLAG (TREE_TYPE (gnu_type)); + /* Inherit our alias set from what we're a subtype of. Subtypes are not different types and a pointer can designate any instance within a subtype hierarchy. */ @@ -1809,9 +1829,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_STUB_DECL (gnu_type) = create_type_stub_decl (gnu_entity_name, gnu_type); - /* For a packed array, make the original array type a parallel type. */ + /* For a packed array, make the original array type a parallel/debug + type. */ if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity)) - add_parallel_type_for_packed_array (gnu_type, gnat_entity); + associate_original_type_to_packed_array (gnu_type, gnat_entity); discrete_type: @@ -1844,6 +1865,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) UI_To_gnu (RM_Size (gnat_entity), bitsizetype)); TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1; + /* Strip the ___XP suffix for standard DWARF. */ + if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + gnu_entity_name = TYPE_NAME (gnu_type); + /* Create a stripped-down declaration, mainly for debugging. */ create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p, gnat_entity); @@ -1866,6 +1891,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_ALIGN (gnu_type) = align > 0 ? align : TYPE_ALIGN (gnu_field_type); + /* Propagate the reverse storage order flag to the record type so + that the required byte swapping is performed when retrieving the + enclosed modular value. */ + TYPE_REVERSE_STORAGE_ORDER (gnu_type) + = Reverse_Storage_Order (Original_Array_Type (gnat_entity)); + relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY); /* Don't declare the field as addressable since we won't be taking @@ -1882,8 +1913,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (debug_info_p) { - /* Make the original array type a parallel type. */ - add_parallel_type_for_packed_array (gnu_type, gnat_entity); + /* Make the original array type a parallel/debug type. */ + associate_original_type_to_packed_array (gnu_type, gnat_entity); + + /* Since GNU_TYPE is a padding type around the packed array + implementation type, the padded type is its debug type. */ + if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type); rest_of_record_type_compilation (gnu_type); } @@ -1911,6 +1947,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = make_node (RECORD_TYPE); TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD"); + if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type); TYPE_PACKED (gnu_type) = 1; TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type); TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type); @@ -1961,15 +1999,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) SET_TYPE_RM_MIN_VALUE (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, get_identifier ("L"), - definition, true, - Needs_Debug_Info (gnat_entity))); + gnat_entity, "L", definition, true, + debug_info_p)); SET_TYPE_RM_MAX_VALUE (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, get_identifier ("U"), - definition, true, - Needs_Debug_Info (gnat_entity))); + gnat_entity, "U", definition, true, + debug_info_p)); /* Inherit our alias set from what we're a subtype of, as for integer subtypes. */ @@ -2055,7 +2091,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) a pointer to the array type since we don't have the array type yet (it will reference the fat pointer via the bounds). */ tem - = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node, + = create_field_decl (get_identifier ("P_ARRAY"), ptr_type_node, gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0); DECL_CHAIN (tem) = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template, @@ -2100,8 +2136,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnat_index = Next_Index (gnat_index)) { char field_name[16]; + tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); tree gnu_index_base_type - = get_unpadded_type (Base_Type (Etype (gnat_index))); + = maybe_character_type (get_base_type (gnu_index_type)); tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max; tree gnu_min, gnu_max, gnu_high; @@ -2160,7 +2197,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Update the maximum size of the array in elements. */ if (gnu_max_size) { - tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); tree gnu_min = convert (sizetype, TYPE_MIN_VALUE (gnu_index_type)); tree gnu_max @@ -2215,21 +2251,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) for (index = ndim - 1; index >= 0; index--) { tem = build_nonshared_array_type (tem, gnu_index_types[index]); - if (Reverse_Storage_Order (gnat_entity) && !GNAT_Mode) - sorry ("non-default Scalar_Storage_Order"); + if (index == ndim - 1) + TYPE_REVERSE_STORAGE_ORDER (tem) + = Reverse_Storage_Order (gnat_entity); TYPE_MULTI_ARRAY_P (tem) = (index > 0); if (array_type_has_nonaliased_component (tem, gnat_entity)) TYPE_NONALIASED_COMPONENT (tem) = 1; - - /* If it is passed by reference, force BLKmode to ensure that - objects of this type will always be put in memory. */ - if (TYPE_MODE (tem) != BLKmode - && Is_By_Reference_Type (gnat_entity)) - SET_TYPE_MODE (tem, BLKmode); } - TYPE_VOLATILE (tem) = Treat_As_Volatile (gnat_entity); - /* If an alignment is specified, use it if valid. But ignore it for the original type of packed array types. If the alignment was requested with an explicit alignment clause, state so. */ @@ -2245,6 +2274,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p; + /* Tag top-level ARRAY_TYPE nodes for packed arrays and their + implementation types as such so that the debug information back-end + can output the appropriate description for them. */ + TYPE_PACKED (tem) + = (Is_Packed (gnat_entity) + || Is_Packed_Array_Impl_Type (gnat_entity)); + + if (Treat_As_Volatile (gnat_entity)) + tem = change_qualified_type (tem, TYPE_QUAL_VOLATILE); + /* Adjust the type of the pointer-to-array field of the fat pointer and record the aliasing relationships if necessary. */ TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem); @@ -2273,26 +2312,33 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } create_type_decl (create_concat_name (gnat_entity, "XUA"), tem, - !Comes_From_Source (gnat_entity), debug_info_p, - gnat_entity); + artificial_p, debug_info_p, gnat_entity); - /* Give the fat pointer type a name. If this is a packed array, tell - the debugger how to interpret the underlying bits. */ + /* If told to generate GNAT encodings for them (GDB rely on them at the + moment): give the fat pointer type a name. If this is a packed + array, tell the debugger how to interpret the underlying bits. */ if (Present (Packed_Array_Impl_Type (gnat_entity))) gnat_name = Packed_Array_Impl_Type (gnat_entity); else gnat_name = gnat_entity; - create_type_decl (create_concat_name (gnat_name, "XUP"), gnu_fat_type, - !Comes_From_Source (gnat_entity), debug_info_p, - gnat_entity); + if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + gnu_entity_name = create_concat_name (gnat_name, "XUP"); + create_type_decl (gnu_entity_name, gnu_fat_type, artificial_p, + debug_info_p, gnat_entity); /* Create the type to be designated by thin pointers: a record type for the array and its template. We used to shift the fields to have the template at a negative offset, but this was somewhat of a kludge; we now shift thin pointer values explicitly but only those which have a - TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE. */ - tem = build_unc_object_type (gnu_template_type, tem, - create_concat_name (gnat_name, "XUT"), + TYPE_UNCONSTRAINED_ARRAY attached to the designated RECORD_TYPE. + Note that GDB can handle standard DWARF information for them, so we + don't have to name them as a GNAT encoding, except if specifically + asked to. */ + if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) + gnu_entity_name = create_concat_name (gnat_name, "XUT"); + else + gnu_entity_name = get_entity_name (gnat_name); + tem = build_unc_object_type (gnu_template_type, tem, gnu_entity_name, debug_info_p); SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type); @@ -2314,7 +2360,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) First check to see if this is simply a renaming of the array type. If so, the result is the array type. */ - gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); + gnu_type = TYPE_MAIN_VARIANT (gnat_to_gnu_type (Etype (gnat_entity))); if (!Is_Constrained (gnat_entity)) ; else @@ -2341,7 +2387,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnat_base_index = Next_Index (gnat_base_index)) { tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); - tree gnu_index_base_type = get_base_type (gnu_index_type); + tree gnu_index_base_type + = maybe_character_type (get_base_type (gnu_index_type)); tree gnu_orig_min = convert (gnu_index_base_type, TYPE_MIN_VALUE (gnu_index_type)); @@ -2353,7 +2400,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) tree gnu_base_index_type = get_unpadded_type (Etype (gnat_base_index)); tree gnu_base_index_base_type - = get_base_type (gnu_base_index_type); + = maybe_character_type (get_base_type (gnu_base_index_type)); tree gnu_base_orig_min = convert (gnu_base_index_base_type, TYPE_MIN_VALUE (gnu_base_index_type)); @@ -2409,7 +2456,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) this. If we can prove that the array can never be superflat, we can just use the high bound of the index type. */ else if ((Nkind (gnat_index) == N_Range - && cannot_be_superflat_p (gnat_index)) + && cannot_be_superflat (gnat_index)) /* Bit-Packed Array Impl. Types are never superflat. */ || (Is_Packed_Array_Impl_Type (gnat_entity) && Is_Bit_Packed_Array @@ -2472,8 +2519,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { tree gnu_base_min = convert (sizetype, gnu_base_orig_min); tree gnu_base_max = convert (sizetype, gnu_base_orig_max); - tree gnu_base_index_base_type - = get_base_type (gnu_base_index_type); tree gnu_base_base_min = convert (sizetype, TYPE_MIN_VALUE (gnu_base_index_base_type)); @@ -2525,14 +2570,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* We need special types for debugging information to point to the index types if they have variable bounds, are not integer - types or are biased. */ - if (TREE_CODE (gnu_orig_min) != INTEGER_CST - || TREE_CODE (gnu_orig_max) != INTEGER_CST - || TREE_CODE (gnu_index_type) != INTEGER_TYPE - || (TREE_TYPE (gnu_index_type) - && TREE_CODE (TREE_TYPE (gnu_index_type)) - != INTEGER_TYPE) - || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)) + types, are biased or are wider than sizetype. These are GNAT + encodings, so we have to include them only when all encodings + are requested. */ + if ((TREE_CODE (gnu_orig_min) != INTEGER_CST + || TREE_CODE (gnu_orig_max) != INTEGER_CST + || TREE_CODE (gnu_index_type) != INTEGER_TYPE + || (TREE_TYPE (gnu_index_type) + && TREE_CODE (TREE_TYPE (gnu_index_type)) + != INTEGER_TYPE) + || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)) + && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) need_index_type_struct = true; } @@ -2586,17 +2634,24 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { gnu_type = build_nonshared_array_type (gnu_type, gnu_index_types[index]); + if (index == ndim - 1) + TYPE_REVERSE_STORAGE_ORDER (gnu_type) + = Reverse_Storage_Order (gnat_entity); TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0); if (array_type_has_nonaliased_component (gnu_type, gnat_entity)) TYPE_NONALIASED_COMPONENT (gnu_type) = 1; - - /* See the E_Array_Type case for the rationale. */ - if (TYPE_MODE (gnu_type) != BLKmode - && Is_By_Reference_Type (gnat_entity)) - SET_TYPE_MODE (gnu_type, BLKmode); } - TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); + /* Strip the ___XP suffix for standard DWARF. */ + if (Is_Packed_Array_Impl_Type (gnat_entity) + && gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + { + Entity_Id gnat_original_array_type + = Underlying_Type (Original_Array_Type (gnat_entity)); + + gnu_entity_name + = get_entity_name (gnat_original_array_type); + } /* Attach the TYPE_STUB_DECL in case we have a parallel type. */ TYPE_STUB_DECL (gnu_type) @@ -2607,28 +2662,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) inner dimensions. */ if (global_bindings_p () && ndim > 1) { - tree gnu_st_name = get_identifier ("ST"); tree gnu_arr_type; - for (gnu_arr_type = TREE_TYPE (gnu_type); + for (gnu_arr_type = TREE_TYPE (gnu_type), index = 1; TREE_CODE (gnu_arr_type) == ARRAY_TYPE; - gnu_arr_type = TREE_TYPE (gnu_arr_type), - gnu_st_name = concat_name (gnu_st_name, "ST")) + gnu_arr_type = TREE_TYPE (gnu_arr_type), index++) { tree eltype = TREE_TYPE (gnu_arr_type); + char stride_name[32]; + sprintf (stride_name, "ST%d", index); TYPE_SIZE (gnu_arr_type) = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type), - gnat_entity, gnu_st_name, + gnat_entity, stride_name, definition, false); /* ??? For now, store the size as a multiple of the alignment of the element type in bytes so that we can see the alignment from the tree. */ + sprintf (stride_name, "ST%d_A_UNIT", index); TYPE_SIZE_UNIT (gnu_arr_type) = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_arr_type), - gnat_entity, - concat_name (gnu_st_name, "A_U"), + gnat_entity, stride_name, definition, false, TYPE_ALIGN (eltype)); @@ -2672,17 +2727,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } /* If this is a packed array type, make the original array type a - parallel type. Otherwise, do it for the base array type if it - isn't artificial to make sure it is kept in the debug info. */ + parallel/debug type. Otherwise, if such GNAT encodings are + required, do it for the base array type if it isn't artificial to + make sure it is kept in the debug info. */ if (debug_info_p) { if (Is_Packed_Array_Impl_Type (gnat_entity)) - add_parallel_type_for_packed_array (gnu_type, gnat_entity); + associate_original_type_to_packed_array (gnu_type, + gnat_entity); else { tree gnu_base_decl = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0); - if (!DECL_ARTIFICIAL (gnu_base_decl)) + if (!DECL_ARTIFICIAL (gnu_base_decl) + && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) add_parallel_type (gnu_type, TREE_TYPE (TREE_TYPE (gnu_base_decl))); } @@ -2693,6 +2751,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = (Is_Packed_Array_Impl_Type (gnat_entity) && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity))); + /* Tag top-level ARRAY_TYPE nodes for packed arrays and their + implementation types as such so that the debug information back-end + can output the appropriate description for them. */ + TYPE_PACKED (gnu_type) + = (Is_Packed (gnat_entity) + || Is_Packed_Array_Impl_Type (gnat_entity)); + /* If the size is self-referential and the maximum size doesn't overflow, use it. */ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)) @@ -2724,8 +2789,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) debugging information for it. */ process_attributes (&gnu_type, &attr_list, false, gnat_entity); if (Treat_As_Volatile (gnat_entity)) - gnu_type - = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); + { + const int quals + = TYPE_QUAL_VOLATILE + | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0); + gnu_type = change_qualified_type (gnu_type, quals); + } /* Make it artificial only if the base type was artificial too. That's sort of "morally" true and will make it possible for the debugger to look it up by name in DWARF, which is needed @@ -2733,8 +2802,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_decl = create_type_decl (gnu_entity_name, gnu_type, !Comes_From_Source (Etype (gnat_entity)) - && !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); + && artificial_p, debug_info_p, + gnat_entity); /* Save it as our equivalent in case the call below elaborates this type again. */ @@ -2745,6 +2814,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) NULL_TREE, 0); this_made_decl = true; gnu_type = TREE_TYPE (gnu_decl); + save_gnu_tree (gnat_entity, NULL_TREE, false); gnu_inner = gnu_type; @@ -2780,10 +2850,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1; -#ifdef ENABLE_CHECKING /* Check for other cases of overloading. */ - gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner)); -#endif + gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner)); } for (gnat_index = First_Index (gnat_entity); @@ -2907,11 +2975,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ? 1 : Component_Alignment (gnat_entity) == Calign_Storage_Unit ? -1 - : (Known_Alignment (gnat_entity) - || (Strict_Alignment (gnat_entity) - && Known_RM_Size (gnat_entity))) - ? -2 - : 0; + : 0; + const bool has_align = Known_Alignment (gnat_entity); const bool has_discr = Has_Discriminants (gnat_entity); const bool has_rep = Has_Specified_Layout (gnat_entity); const bool is_extension @@ -2950,9 +3015,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) suppress expanding incomplete types. */ gnu_type = make_node (tree_code_for_record_type (gnat_entity)); TYPE_NAME (gnu_type) = gnu_entity_name; - TYPE_PACKED (gnu_type) = (packed != 0) || has_rep; - if (Reverse_Storage_Order (gnat_entity) && !GNAT_Mode) - sorry ("non-default Scalar_Storage_Order"); + TYPE_PACKED (gnu_type) = (packed != 0) || has_align || has_rep; + TYPE_REVERSE_STORAGE_ORDER (gnu_type) + = Reverse_Storage_Order (gnat_entity); process_attributes (&gnu_type, &attr_list, true, gnat_entity); if (!definition) @@ -2961,38 +3026,32 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) this_deferred = true; } - /* If both a size and rep clause was specified, put the size in - the record type now so that it can get the proper mode. */ + /* If both a size and rep clause were specified, put the size on + the record type now so that it can get the proper layout. */ if (has_rep && Known_RM_Size (gnat_entity)) TYPE_SIZE (gnu_type) = UI_To_gnu (RM_Size (gnat_entity), bitsizetype); - /* Always set the alignment here so that it can be used to - set the mode, if it is making the alignment stricter. If - it is invalid, it will be checked again below. If this is to - be Atomic, choose a default alignment of a word unless we know - the size and it's smaller. */ - if (Known_Alignment (gnat_entity)) + /* Always set the alignment on the record type here so that it can + get the proper layout. */ + if (has_align) TYPE_ALIGN (gnu_type) = validate_alignment (Alignment (gnat_entity), gnat_entity, 0); - else if (Is_Atomic (gnat_entity) && Known_Esize (gnat_entity)) - { - unsigned int size = UI_To_Int (Esize (gnat_entity)); - TYPE_ALIGN (gnu_type) - = size >= BITS_PER_WORD ? BITS_PER_WORD : ceil_pow2 (size); - } - /* If a type needs strict alignment, the minimum size will be the - type size instead of the RM size (see validate_size). Cap the - alignment, lest it causes this type size to become too large. */ - else if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity)) + else { - unsigned int raw_size = UI_To_Int (RM_Size (gnat_entity)); - unsigned int raw_align = raw_size & -raw_size; - if (raw_align < BIGGEST_ALIGNMENT) - TYPE_ALIGN (gnu_type) = raw_align; + TYPE_ALIGN (gnu_type) = 0; + + /* If a type needs strict alignment, the minimum size will be the + type size instead of the RM size (see validate_size). Cap the + alignment lest it causes this type size to become too large. */ + if (Strict_Alignment (gnat_entity) && Known_RM_Size (gnat_entity)) + { + unsigned int max_size = UI_To_Int (RM_Size (gnat_entity)); + unsigned int max_align = max_size & -max_size; + if (max_align < BIGGEST_ALIGNMENT) + TYPE_MAX_ALIGN (gnu_type) = max_align; + } } - else - TYPE_ALIGN (gnu_type) = 0; /* If we have a Parent_Subtype, make a field for the parent. If this record has rep clauses, force the position to zero. */ @@ -3075,6 +3134,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) else gnu_parent = gnat_to_gnu_type (gnat_parent); + /* The parent field needs strict alignment so, if it is to + be created with a component clause below, then we need + to apply the same adjustment as in gnat_to_gnu_field. */ + if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent)) + TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_parent); + /* Finally we fix up both kinds of twisted COMPONENT_REF we have initially built. The discriminants must reference the fields of the parent subtype and not those of its base type for the @@ -3138,6 +3203,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Present (Corresponding_Discriminant (gnat_field))) continue; + /* However, if we are just annotating types, the Parent_Subtype + doesn't exist so we need skip the discriminant altogether. */ + if (type_annotate_only + && Is_Tagged_Type (gnat_entity) + && Is_Derived_Type (gnat_entity) + && Present (Corresponding_Discriminant (gnat_field))) + continue; + gnu_field = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition, debug_info_p); @@ -3229,18 +3302,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) components_to_record (gnu_type, Component_List (record_definition), gnu_field_list, packed, definition, false, all_rep, is_unchecked_union, - !Comes_From_Source (gnat_entity), debug_info_p, + artificial_p, debug_info_p, false, OK_To_Reorder_Components (gnat_entity), all_rep ? NULL_TREE : bitsize_zero_node, NULL); - /* If it is passed by reference, force BLKmode to ensure that objects - of this type will always be put in memory. */ - if (TYPE_MODE (gnu_type) != BLKmode - && Is_By_Reference_Type (gnat_entity)) - SET_TYPE_MODE (gnu_type, BLKmode); - - TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); - /* Fill in locations of fields. */ annotate_rep (gnat_entity, gnu_type); @@ -3317,7 +3382,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) this_deferred = true; } - gnu_base_type = gnat_to_gnu_type (gnat_base_type); + gnu_base_type + = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type)); if (present_gnu_tree (gnat_entity)) { @@ -3362,7 +3428,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = make_node (RECORD_TYPE); TYPE_NAME (gnu_type) = gnu_entity_name; + if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + SET_TYPE_DEBUG_TYPE (gnu_type, gnu_base_type); TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type); + TYPE_REVERSE_STORAGE_ORDER (gnu_type) + = Reverse_Storage_Order (gnat_entity); process_attributes (&gnu_type, &attr_list, true, gnat_entity); /* Set the size, alignment and alias set of the new type to @@ -3417,6 +3487,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TYPE_NAME (new_variant) = concat_name (TYPE_NAME (gnu_type), IDENTIFIER_POINTER (suffix)); + TYPE_REVERSE_STORAGE_ORDER (new_variant) + = TYPE_REVERSE_STORAGE_ORDER (gnu_type); copy_and_substitute_in_size (new_variant, old_variant, gnu_subst_list); v->new_type = new_variant; @@ -3634,20 +3706,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) false); compute_record_mode (gnu_type); - /* See the E_Record_Type case for the rationale. */ - if (TYPE_MODE (gnu_type) != BLKmode - && Is_By_Reference_Type (gnat_entity)) - SET_TYPE_MODE (gnu_type, BLKmode); - - TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity); - /* Fill in locations of fields. */ annotate_rep (gnat_entity, gnu_type); - /* If debugging information is being written for the type, write - a record that shows what we are a subtype of and also make a - variable that indicates our size, if still variable. */ - if (debug_info_p) + /* If debugging information is being written for the type and if + we are asked to output such encodings, write a record that + shows what we are a subtype of and also make a variable that + indicates our size, if still variable. */ + if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) { tree gnu_subtype_marker = make_node (RECORD_TYPE); tree gnu_unpad_base_name @@ -3674,8 +3740,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = create_var_decl (create_concat_name (gnat_entity, "XVZ"), NULL_TREE, sizetype, gnu_size_unit, - false, false, false, false, NULL, - gnat_entity); + false, false, false, false, false, + true, debug_info_p, + NULL, gnat_entity); } gnu_variant_list.release (); @@ -3734,8 +3801,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = build_pointer_type (make_dummy_type (Directly_Designated_Type (gnat_entity))); gnu_decl = create_type_decl (gnu_entity_name, gnu_type, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); + artificial_p, debug_info_p, + gnat_entity); this_made_decl = true; gnu_type = TREE_TYPE (gnu_decl); save_gnu_tree (gnat_entity, gnu_decl, false); @@ -3786,8 +3853,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* The type actually used to represent the designated type, either gnat_desig_full or gnat_desig_equiv. */ Entity_Id gnat_desig_rep; - /* True if this is a pointer to an unconstrained array. */ - bool is_unconstrained_array; /* We want to know if we'll be seeing the freeze node for any incomplete type we may be pointing to. */ bool in_main_unit @@ -3821,62 +3886,26 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && Ekind (Etype (gnat_desig_full)) == E_Record_Type))) gnat_desig_full = Etype (gnat_desig_full); - /* Set the type that's actually the representation of the designated - type and also flag whether we have a unconstrained array. */ + /* Set the type that's the representation of the designated type. */ gnat_desig_rep = Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv; - is_unconstrained_array - = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep); - - /* If we are pointing to an incomplete type whose completion is an - unconstrained array, make dummy fat and thin pointer types to it. - Likewise if the type itself is dummy or an unconstrained array. */ - if (is_unconstrained_array - && (Present (gnat_desig_full) - || (present_gnu_tree (gnat_desig_equiv) - && TYPE_IS_DUMMY_P - (TREE_TYPE (get_gnu_tree (gnat_desig_equiv)))) - || (!in_main_unit - && defer_incomplete_level != 0 - && !present_gnu_tree (gnat_desig_equiv)) - || (in_main_unit - && is_from_limited_with - && Present (Freeze_Node (gnat_desig_equiv))))) - { - if (present_gnu_tree (gnat_desig_rep)) - gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep)); - else - { - gnu_desig_type = make_dummy_type (gnat_desig_rep); - made_dummy = true; - } - - /* If the call above got something that has a pointer, the pointer - is our type. This could have happened either because the type - was elaborated or because somebody else executed the code. */ - if (!TYPE_POINTER_TO (gnu_desig_type)) - build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type); - gnu_type = TYPE_POINTER_TO (gnu_desig_type); - } /* If we already know what the full type is, use it. */ - else if (Present (gnat_desig_full) - && present_gnu_tree (gnat_desig_full)) + if (Present (gnat_desig_full) && present_gnu_tree (gnat_desig_full)) gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full)); /* Get the type of the thing we are to point to and build a pointer to it. If it is a reference to an incomplete or private type with a - full view that is a record, make a dummy type node and get the - actual type later when we have verified it is safe. */ + full view that is a record or an array, make a dummy type node and + get the actual type later when we have verified it is safe. */ else if ((!in_main_unit && !present_gnu_tree (gnat_desig_equiv) && Present (gnat_desig_full) - && !present_gnu_tree (gnat_desig_full) - && Is_Record_Type (gnat_desig_full)) + && (Is_Record_Type (gnat_desig_full) + || Is_Array_Type (gnat_desig_full))) /* Likewise if we are pointing to a record or array and we are to defer elaborating incomplete types. We do this as this - access type may be the full view of a private type. Note - that the unconstrained array case is handled above. */ + access type may be the full view of a private type. */ || ((!in_main_unit || imported_p) && defer_incomplete_level != 0 && !present_gnu_tree (gnat_desig_equiv) @@ -3889,11 +3918,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) in which case we make the dummy type and it will be reused when the declaration is finally processed. In both cases, the pointer eventually created below will be automatically - adjusted when the freeze node is processed. Note that the - unconstrained array case is handled above. */ - || (in_main_unit - && is_from_limited_with - && Present (Freeze_Node (gnat_desig_rep)))) + adjusted when the freeze node is processed. */ + || (in_main_unit + && is_from_limited_with + && Present (Freeze_Node (gnat_desig_rep)))) { gnu_desig_type = make_dummy_type (gnat_desig_equiv); made_dummy = true; @@ -3911,7 +3939,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If expansion is disabled, the equivalent type of a concurrent type is absent, so build a dummy pointer type. */ else if (type_annotate_only && No (gnat_desig_equiv)) - gnu_type = ptr_void_type_node; + gnu_type = ptr_type_node; /* Finally, handle the default case where we can just elaborate our designated type. */ @@ -3926,8 +3954,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) break; } + /* For an unconstrained array, make dummy fat & thin pointer types. */ + if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep)) + { + /* If the processing above got something that has a pointer, then + we are done. This could have happened either because the type + was elaborated or because somebody else executed the code. */ + if (!TYPE_POINTER_TO (gnu_desig_type)) + build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type); + gnu_type = TYPE_POINTER_TO (gnu_desig_type); + } + /* If we haven't done it yet, build the pointer type the usual way. */ - if (!gnu_type) + else if (!gnu_type) { /* Modify the designated type if we are pointing only to constant objects, but don't do it for unconstrained arrays. */ @@ -3989,8 +4028,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) process_attributes (&gnu_type, &attr_list, false, gnat_entity); gnu_decl = create_type_decl (gnu_entity_name, gnu_type, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); + artificial_p, debug_info_p, + gnat_entity); this_made_decl = true; gnu_type = TREE_TYPE (gnu_decl); save_gnu_tree (gnat_entity, gnu_decl, false); @@ -4030,7 +4069,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) case E_Access_Protected_Subprogram_Type: case E_Anonymous_Access_Protected_Subprogram_Type: if (type_annotate_only && No (gnat_equiv_type)) - gnu_type = ptr_void_type_node; + gnu_type = ptr_type_node; else { /* The run-time representation is the equivalent type. */ @@ -4173,7 +4212,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || imported_p || (Convention (gnat_entity) == Convention_Intrinsic && Has_Pragma_Inline_Always (gnat_entity))); - bool artificial_flag = !Comes_From_Source (gnat_entity); /* The semantics of "pure" in Ada essentially matches that of "const" in the back-end. In particular, both properties are orthogonal to the "nothrow" property if the EH circuitry is explicit in the @@ -4182,9 +4220,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) Ada subprograms that can throw have side effects since they can trigger an "abnormal" transfer of control flow; thus they can be neither "const" nor "pure" in the back-end sense. */ - bool const_flag - = (Exception_Mechanism == Back_End_Exceptions - && Is_Pure (gnat_entity)); + bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_entity)); bool volatile_flag = No_Return (gnat_entity); bool return_by_direct_ref_p = false; bool return_by_invisi_ref_p = false; @@ -4205,6 +4241,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) of its type, so we must elaborate that type now. */ if (Present (Alias (gnat_entity))) { + const Entity_Id gnat_renamed = Renamed_Object (gnat_entity); + if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0); @@ -4217,6 +4255,33 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (Is_Itype (Etype (gnat_temp))) gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); + /* Materialize renamed subprograms in the debugging information + when the renamed object is compile time known. We can consider + such renamings as imported declarations. + + Because the parameters in generics instantiation are generally + materialized as renamings, we ofter end up having both the + renamed subprogram and the renaming in the same context and with + the same name: in this case, renaming is both useless debug-wise + and potentially harmful as name resolution in the debugger could + return twice the same entity! So avoid this case. */ + if (debug_info_p && !artificial_p + && !(get_debug_scope (gnat_entity, NULL) + == get_debug_scope (gnat_renamed, NULL) + && Name_Equals (Chars (gnat_entity), + Chars (gnat_renamed))) + && Present (gnat_renamed) + && (Ekind (gnat_renamed) == E_Function + || Ekind (gnat_renamed) == E_Procedure) + && gnu_decl + && TREE_CODE (gnu_decl) == FUNCTION_DECL) + { + tree decl = build_decl (input_location, IMPORTED_DECL, + gnu_entity_name, void_type_node); + IMPORTED_DECL_ASSOCIATED_DECL (decl) = gnu_decl; + gnat_pushdecl (decl, gnat_entity); + } + break; } @@ -4235,7 +4300,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) to let developers be notified on demand without risking false positives with common default sets of options. */ - if (gnu_builtin_decl == NULL_TREE && warn_shadow) + if (!gnu_builtin_decl && warn_shadow) post_error ("?gcc intrinsic not found for&!", gnat_entity); } @@ -4254,7 +4319,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) we are only annotating types, break circularities here. */ if (type_annotate_only && is_from_limited_with_of_main (gnat_return_type)) - gnu_return_type = ptr_void_type_node; + gnu_return_type = void_type_node; else gnu_return_type = gnat_to_gnu_type (gnat_return_type); @@ -4262,7 +4327,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) type the pointer type and make a note of that. */ if (Returns_By_Ref (gnat_entity)) { - gnu_return_type = build_pointer_type (gnu_return_type); + gnu_return_type = build_reference_type (gnu_return_type); return_by_direct_ref_p = true; } @@ -4280,7 +4345,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) the actual return type is the pointer type. */ else if (Requires_Transient_Scope (gnat_return_type)) { - gnu_return_type = build_pointer_type (gnu_return_type); + gnu_return_type = build_reference_type (gnu_return_type); return_unconstrained_p = true; } @@ -4311,12 +4376,23 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type))) { tree orig_type = gnu_return_type; + tree max_return_size + = max_size (TYPE_SIZE (gnu_return_type), true); + + /* If the size overflows to 0, set it to an arbitrary positive + value so that assignments in the type are preserved. Their + actual size is independent of this positive value. */ + if (TREE_CODE (max_return_size) == INTEGER_CST + && TREE_OVERFLOW (max_return_size) + && integer_zerop (max_return_size)) + { + max_return_size = copy_node (bitsize_unit_node); + TREE_OVERFLOW (max_return_size) = 1; + } gnu_return_type - = maybe_pad_type (gnu_return_type, - max_size (TYPE_SIZE (gnu_return_type), - true), - 0, gnat_entity, false, false, definition, + = maybe_pad_type (gnu_return_type, max_return_size, 0, + gnat_entity, false, false, definition, true); /* Declare it now since it will never be declared otherwise. @@ -4334,7 +4410,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If the return type has a size that overflows, we cannot have a function that returns that type. This usage doesn't make sense anyway, so give an error here. */ - if (TYPE_SIZE_UNIT (gnu_return_type) + if (!return_by_invisi_ref_p + && TYPE_SIZE_UNIT (gnu_return_type) && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type))) { @@ -4366,7 +4443,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (type_annotate_only && is_from_limited_with_of_main (gnat_param_type)) { - gnu_param_type = ptr_void_type_node; + gnu_param_type = void_type_node; fake_param_type = true; } else @@ -4603,15 +4680,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p) const_flag = false; - if (const_flag || volatile_flag) - { - const int quals - = (const_flag ? TYPE_QUAL_CONST : 0) - | (volatile_flag ? TYPE_QUAL_VOLATILE : 0); - - gnu_type = change_qualified_type (gnu_type, quals); - } - /* If we have a builtin decl for that function, use it. Check if the profiles are compatible and warn if they are not. The checker is expected to post extra diagnostics in this case. */ @@ -4660,7 +4728,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) save_gnu_tree (gnat_entity, NULL_TREE, false); /* Convert the type of the object to a reference type that can - alias everything as per 13.3(19). */ + alias everything as per RM 13.3(19). */ gnu_type = build_reference_type_for_mode (gnu_type, ptr_mode, true); if (gnu_address) @@ -4669,23 +4737,34 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type, gnu_address, false, Is_Public (gnat_entity), - extern_flag, false, NULL, gnat_entity); + extern_flag, false, false, artificial_p, + debug_info_p, NULL, gnat_entity); DECL_BY_REF_P (gnu_decl) = 1; } else if (kind == E_Subprogram_Type) { process_attributes (&gnu_type, &attr_list, false, gnat_entity); + + if (const_flag || volatile_flag) + { + const int quals + = (const_flag ? TYPE_QUAL_CONST : 0) + | (volatile_flag ? TYPE_QUAL_VOLATILE : 0); + gnu_type = change_qualified_type (gnu_type, quals); + } + gnu_decl - = create_type_decl (gnu_entity_name, gnu_type, artificial_flag, + = create_type_decl (gnu_entity_name, gnu_type, artificial_p, debug_info_p, gnat_entity); } else { gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type, - gnu_param_list, inline_status, - public_flag, extern_flag, artificial_flag, + gnu_param_list, inline_status, const_flag, + public_flag, extern_flag, volatile_flag, + artificial_p, debug_info_p, attr_list, gnat_entity); /* This is unrelated to the stub built right above. */ DECL_STUBBED_P (gnu_decl) @@ -4703,13 +4782,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) case E_Record_Type_With_Private: case E_Record_Subtype_With_Private: { + bool is_from_limited_with + = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity)); /* Get the "full view" of this entity. If this is an incomplete entity from a limited with, treat its non-limited view as the full view. Otherwise, use either the full view or the underlying full view, whichever is present. This is used in all the tests below. */ Entity_Id full_view - = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity)) + = is_from_limited_with ? Non_Limited_View (gnat_entity) : Present (Full_View (gnat_entity)) ? Full_View (gnat_entity) @@ -4745,10 +4826,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* Otherwise, if we are not defining the type now, get the type from the full view. But always get the type from the full view - for define on use types, since otherwise we won't see them! */ + for define on use types, since otherwise we won't see them. + Likewise if this is a non-limited view not declared in the main + unit, which can happen for incomplete formal types instantiated + on a type coming from a limited_with clause. */ else if (!definition || (Is_Itype (full_view) && No (Freeze_Node (gnat_entity))) - || (Is_Itype (gnat_entity) && No (Freeze_Node (full_view)))) + || (Is_Itype (gnat_entity) && No (Freeze_Node (full_view))) + || (is_from_limited_with + && !In_Extended_Main_Code_Unit (full_view))) { gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0); maybe_present = true; @@ -4772,13 +4858,52 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) maybe_present = true; break; - case E_Task_Type: - case E_Task_Subtype: case E_Protected_Type: case E_Protected_Subtype: - /* Concurrent types are always transformed into their record type. */ + case E_Task_Type: + case E_Task_Subtype: + /* If we are just annotating types and have no equivalent record type, + just return void_type, except for root types that have discriminants + because the discriminants will very likely be used in the declarative + part of the associated body so they need to be translated. */ if (type_annotate_only && No (gnat_equiv_type)) - gnu_type = void_type_node; + { + if (Has_Discriminants (gnat_entity) + && Root_Type (gnat_entity) == gnat_entity) + { + tree gnu_field_list = NULL_TREE; + Entity_Id gnat_field; + + /* This is a minimal version of the E_Record_Type handling. */ + gnu_type = make_node (RECORD_TYPE); + TYPE_NAME (gnu_type) = gnu_entity_name; + + for (gnat_field = First_Stored_Discriminant (gnat_entity); + Present (gnat_field); + gnat_field = Next_Stored_Discriminant (gnat_field)) + { + tree gnu_field + = gnat_to_gnu_field (gnat_field, gnu_type, false, + definition, debug_info_p); + + save_gnu_tree (gnat_field, + build3 (COMPONENT_REF, TREE_TYPE (gnu_field), + build0 (PLACEHOLDER_EXPR, gnu_type), + gnu_field, NULL_TREE), + true); + + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + } + + finish_record_type (gnu_type, nreverse (gnu_field_list), 0, + false); + } + else + gnu_type = void_type_node; + } + + /* Concurrent types are always transformed into their record type. */ else gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0); maybe_present = true; @@ -4898,12 +5023,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnat_entity); } } - else if (Is_Atomic (gnat_entity) && !gnu_size + else if (Is_Atomic_Or_VFA (gnat_entity) && !gnu_size && tree_fits_uhwi_p (TYPE_SIZE (gnu_type)) && integer_pow2p (TYPE_SIZE (gnu_type))) align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (TYPE_SIZE (gnu_type))); - else if (Is_Atomic (gnat_entity) && gnu_size + else if (Is_Atomic_Or_VFA (gnat_entity) && gnu_size && tree_fits_uhwi_p (gnu_size) && integer_pow2p (gnu_size)) align = MIN (BIGGEST_ALIGNMENT, tree_to_uhwi (gnu_size)); @@ -4935,16 +5060,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) tree size = TYPE_SIZE (gnu_type); TYPE_SIZE (gnu_type) - = elaborate_expression_1 (size, gnat_entity, - get_identifier ("SIZE"), - definition, false); + = elaborate_expression_1 (size, gnat_entity, "SIZE", definition, + false); /* ??? For now, store the size as a multiple of the alignment in bytes so that we can see the alignment from the tree. */ TYPE_SIZE_UNIT (gnu_type) = elaborate_expression_2 (TYPE_SIZE_UNIT (gnu_type), gnat_entity, - get_identifier ("SIZE_A_UNIT"), - definition, false, + "SIZE_A_UNIT", definition, false, TYPE_ALIGN (gnu_type)); /* ??? gnu_type may come from an existing type so the MULT_EXPR node @@ -4978,8 +5101,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { TYPE_SIZE (union_type) = elaborate_expression_1 (TYPE_SIZE (union_type), - gnat_entity, - get_identifier ("VSIZE"), + gnat_entity, "VSIZE", definition, false); /* ??? For now, store the size as a multiple of the @@ -4987,9 +5109,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) from the tree. */ TYPE_SIZE_UNIT (union_type) = elaborate_expression_2 (TYPE_SIZE_UNIT (union_type), - gnat_entity, - get_identifier - ("VSIZE_A_UNIT"), + gnat_entity, "VSIZE_A_UNIT", definition, false, TYPE_ALIGN (union_type)); @@ -4997,10 +5117,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) alignment in bytes so that we can see the alignment from the tree. */ DECL_FIELD_OFFSET (variant_part) - = elaborate_expression_2 (offset, - gnat_entity, - get_identifier ("VOFFSET"), - definition, false, + = elaborate_expression_2 (offset, gnat_entity, + "VOFFSET", definition, false, DECL_OFFSET_ALIGN (variant_part)); } @@ -5013,8 +5131,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ada_size = TYPE_SIZE (gnu_type); else ada_size - = elaborate_expression_1 (ada_size, gnat_entity, - get_identifier ("RM_SIZE"), + = elaborate_expression_1 (ada_size, gnat_entity, "RM_SIZE", definition, false); SET_TYPE_ADA_SIZE (gnu_type, ada_size); } @@ -5037,9 +5154,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) { DECL_FIELD_OFFSET (gnu_field) = elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field), - gnat_temp, - get_identifier ("OFFSET"), - definition, false, + gnat_temp, "OFFSET", definition, + false, DECL_OFFSET_ALIGN (gnu_field)); /* ??? The context of gnu_field is not necessarily gnu_type @@ -5050,26 +5166,38 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } } - if (Is_Atomic (gnat_entity)) + if (Is_Atomic_Or_VFA (gnat_entity)) check_ok_for_atomic_type (gnu_type, gnat_entity, false); /* If this is not an unconstrained array type, set some flags. */ if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) { - if (Treat_As_Volatile (gnat_entity)) - gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); - if (Present (Alignment_Clause (gnat_entity))) TYPE_USER_ALIGN (gnu_type) = 1; if (Universal_Aliasing (gnat_entity)) - TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1; + TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1; + + /* If it is passed by reference, force BLKmode to ensure that + objects of this type will always be put in memory. */ + if (TYPE_MODE (gnu_type) != BLKmode + && AGGREGATE_TYPE_P (gnu_type) + && TYPE_BY_REFERENCE_P (gnu_type)) + SET_TYPE_MODE (gnu_type, BLKmode); + + if (Treat_As_Volatile (gnat_entity)) + { + const int quals + = TYPE_QUAL_VOLATILE + | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0); + gnu_type = change_qualified_type (gnu_type, quals); + } } if (!gnu_decl) gnu_decl = create_type_decl (gnu_entity_name, gnu_type, - !Comes_From_Source (gnat_entity), - debug_info_p, gnat_entity); + artificial_p, debug_info_p, + gnat_entity); else { TREE_TYPE (gnu_decl) = gnu_type; @@ -5196,15 +5324,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* If we are just annotating types and the type is tagged, the tag and the parent components are not generated by the front-end so - sizes must be adjusted if there is no representation clause. */ + alignment and sizes must be adjusted if there is no rep clause. */ if (type_annotate_only && Is_Tagged_Type (gnat_entity) + && Unknown_RM_Size (gnat_entity) && !VOID_TYPE_P (gnu_type) && (!TYPE_FIELDS (gnu_type) || integer_zerop (bit_position (TYPE_FIELDS (gnu_type))))) { - tree pointer_size = bitsize_int (POINTER_SIZE), offset; - Uint uint_size; + tree offset; if (Is_Derived_Type (gnat_entity)) { @@ -5213,7 +5341,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) Set_Alignment (gnat_entity, Alignment (gnat_parent)); } else - offset = pointer_size; + { + unsigned int align + = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT; + offset = bitsize_int (POINTER_SIZE); + Set_Alignment (gnat_entity, UI_From_Int (align)); + } if (TYPE_FIELDS (gnu_type)) offset @@ -5221,10 +5354,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_size = size_binop (PLUS_EXPR, gnu_size, offset); gnu_size = round_up (gnu_size, POINTER_SIZE); - uint_size = annotate_value (gnu_size); - Set_Esize (gnat_entity, uint_size); + Uint uint_size = annotate_value (gnu_size); Set_RM_Size (gnat_entity, uint_size); + Set_Esize (gnat_entity, uint_size); } + + /* If there is a rep clause, only adjust alignment and Esize. */ + else if (type_annotate_only && Is_Tagged_Type (gnat_entity)) + { + unsigned int align + = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT; + Set_Alignment (gnat_entity, UI_From_Int (align)); + gnu_size = round_up (gnu_size, POINTER_SIZE); + Set_Esize (gnat_entity, annotate_value (gnu_size)); + } + + /* Otherwise no adjustment is needed. */ else Set_Esize (gnat_entity, annotate_value (gnu_size)); } @@ -5233,22 +5378,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type))); } - /* If we really have a ..._DECL node, set a couple of flags on it. But we - cannot do so if we are reusing the ..._DECL node made for an equivalent - type or an alias or a renamed object as the predicates don't apply to it - but to GNAT_ENTITY. */ - if (DECL_P (gnu_decl) - && !(is_type && gnat_equiv_type != gnat_entity) - && !Present (Alias (gnat_entity)) - && !(Present (Renamed_Object (gnat_entity)) && saved)) - { - if (!Comes_From_Source (gnat_entity)) - DECL_ARTIFICIAL (gnu_decl) = 1; - - if (!debug_info_p) - DECL_IGNORED_P (gnu_decl) = 1; - } - /* If we haven't already, associate the ..._DECL node that we just made with the input GNAT entity node. */ if (!saved) @@ -5437,7 +5566,8 @@ get_minimal_subprog_decl (Entity_Id gnat_entity) return create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE, - is_disabled, true, true, true, attr_list, gnat_entity); + is_disabled, false, true, true, false, true, false, + attr_list, gnat_entity); } /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is @@ -5640,8 +5770,23 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, gnat_array); } + /* If the component type is a padded type made for a non-bit-packed array + of scalars with reverse storage order, we need to propagate the reverse + storage order to the padding type since it is the innermost enclosing + aggregate type around the scalar. */ + if (TYPE_IS_PADDING_P (gnu_type) + && Reverse_Storage_Order (gnat_array) + && !Is_Bit_Packed_Array (gnat_array) + && Is_Scalar_Type (gnat_type)) + gnu_type = set_reverse_storage_order_on_pad_type (gnu_type); + if (Has_Volatile_Components (gnat_array)) - gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE); + { + const int quals + = TYPE_QUAL_VOLATILE + | (Has_Atomic_Components (gnat_array) ? TYPE_QUAL_ATOMIC : 0); + gnu_type = change_qualified_type (gnu_type, quals); + } return gnu_type; } @@ -5667,6 +5812,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, bool ro_param = in_param && !Address_Taken (gnat_param); bool by_return = false, by_component_ptr = false; bool by_ref = false; + bool restricted_aliasing_p = false; tree gnu_param; /* Copy-return is used only for the first parameter of a valued procedure. @@ -5712,7 +5858,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, if (Convention (gnat_subprog) == Convention_Intrinsic && Present (Interface_Name (gnat_subprog)) && Is_Descendent_Of_Address (Etype (gnat_param))) - gnu_param_type = ptr_void_type_node; + gnu_param_type = ptr_type_node; /* Arrays are passed as pointers to element type for foreign conventions. */ if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE) @@ -5757,15 +5903,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, || (!foreign && default_pass_by_ref (gnu_param_type))))) { + gnu_param_type = build_reference_type (gnu_param_type); /* We take advantage of 6.2(12) by considering that references built for parameters whose type isn't by-ref and for which the mechanism hasn't - been forced to by-ref are restrict-qualified in the C sense. */ - bool restrict_p + been forced to by-ref allow only a restricted form of aliasing. */ + restricted_aliasing_p = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference; - gnu_param_type = build_reference_type (gnu_param_type); - if (restrict_p) - gnu_param_type - = change_qualified_type (gnu_param_type, TYPE_QUAL_RESTRICT); by_ref = true; } @@ -5813,6 +5956,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, DECL_POINTS_TO_READONLY_P (gnu_param) = (ro_param && (by_ref || by_component_ptr)); DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param); + DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p; /* If no Mechanism was specified, indicate what we're using, then back-annotate it. */ @@ -5922,7 +6066,7 @@ compile_time_known_address_p (Node_Id gnat_address) inequality HB >= LB-1 is true. LB and HB are the low and high bounds. */ static bool -cannot_be_superflat_p (Node_Id gnat_range) +cannot_be_superflat (Node_Id gnat_range) { Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range); Node_Id scalar_range; @@ -5978,6 +6122,57 @@ constructor_address_p (tree gnu_expr) return (TREE_CODE (gnu_expr) == ADDR_EXPR && TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == CONSTRUCTOR); } + +/* Return true if the size in units represented by GNU_SIZE can be handled by + an allocation. If STATIC_P is true, consider only what can be done with a + static allocation. */ + +static bool +allocatable_size_p (tree gnu_size, bool static_p) +{ + /* We can allocate a fixed size if it is a valid for the middle-end. */ + if (TREE_CODE (gnu_size) == INTEGER_CST) + return valid_constant_size_p (gnu_size); + + /* We can allocate a variable size if this isn't a static allocation. */ + else + return !static_p; +} + +/* Return true if GNU_EXPR needs a conversion to GNU_TYPE when used as the + initial value of an object of GNU_TYPE. */ + +static bool +initial_value_needs_conversion (tree gnu_type, tree gnu_expr) +{ + /* Do not convert if the object's type is unconstrained because this would + generate useless evaluations of the CONSTRUCTOR to compute the size. */ + if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE + || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) + return false; + + /* Do not convert if the object's type is a padding record whose field is of + self-referential size because we want to copy only the actual data. */ + if (type_is_padding_self_referential (gnu_type)) + return false; + + /* Do not convert a call to a function that returns with variable size since + we want to use the return slot optimization in this case. */ + if (TREE_CODE (gnu_expr) == CALL_EXPR + && return_type_with_variable_size_p (TREE_TYPE (gnu_expr))) + return false; + + /* Do not convert to a record type with a variant part from a record type + without one, to keep the object simpler. */ + if (TREE_CODE (gnu_type) == RECORD_TYPE + && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE + && get_variant_part (gnu_type) + && !get_variant_part (TREE_TYPE (gnu_expr))) + return false; + + /* In all the other cases, convert the expression to the object's type. */ + return true; +} /* Given GNAT_ENTITY, elaborate all expressions that are required to be elaborated at the point of its definition, but do nothing else. */ @@ -6001,11 +6196,11 @@ elaborate_entity (Entity_Id gnat_entity) are needed until after the front stops generating bogus conversions on bounds of real types. */ if (!Raises_Constraint_Error (gnat_lb)) - elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"), - true, false, Needs_Debug_Info (gnat_entity)); + elaborate_expression (gnat_lb, gnat_entity, "L", true, false, + Needs_Debug_Info (gnat_entity)); if (!Raises_Constraint_Error (gnat_hb)) - elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"), - true, false, Needs_Debug_Info (gnat_entity)); + elaborate_expression (gnat_hb, gnat_entity, "U", true, false, + Needs_Debug_Info (gnat_entity)); break; } @@ -6028,7 +6223,7 @@ elaborate_entity (Entity_Id gnat_entity) /* Ignore access discriminants. */ if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr)))) elaborate_expression (Node (gnat_discriminant_expr), - gnat_entity, get_entity_name (gnat_field), + gnat_entity, get_entity_char (gnat_field), true, false, false); } break; @@ -6036,35 +6231,19 @@ elaborate_entity (Entity_Id gnat_entity) } } -/* Return true if the size in units represented by GNU_SIZE can be handled by - an allocation. If STATIC_P is true, consider only what can be done with a - static allocation. */ - -static bool -allocatable_size_p (tree gnu_size, bool static_p) -{ - /* We can allocate a fixed size if it is a valid for the middle-end. */ - if (TREE_CODE (gnu_size) == INTEGER_CST) - return valid_constant_size_p (gnu_size); - - /* We can allocate a variable size if this isn't a static allocation. */ - else - return !static_p; -} - /* Prepend to ATTR_LIST an entry for an attribute with provided TYPE, NAME, ARGS and ERROR_POINT. */ static void prepend_one_attribute (struct attrib **attr_list, - enum attr_type attr_type, + enum attrib_type attrib_type, tree attr_name, tree attr_args, Node_Id attr_error_point) { struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib)); - attr->type = attr_type; + attr->type = attrib_type; attr->name = attr_name; attr->args = attr_args; attr->error_point = attr_error_point; @@ -6080,7 +6259,7 @@ prepend_one_attribute_pragma (struct attrib **attr_list, Node_Id gnat_pragma) { const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma); tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE; - enum attr_type etype; + enum attrib_type etype; /* Map the pragma at hand. Skip if this isn't one we know how to handle. */ switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma)))) @@ -6176,15 +6355,15 @@ prepend_attributes (struct attrib **attr_list, Entity_Id gnat_entity) /* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a type definition (either a bound or a discriminant value) for GNAT_ENTITY, - return the GCC tree to use for that expression. GNU_NAME is the suffix - to use if a variable needs to be created and DEFINITION is true if this - is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result; + return the GCC tree to use for that expression. S is the suffix to use + if a variable needs to be created and DEFINITION is true if this is done + for a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result; otherwise, we are just elaborating the expression for side-effects. If NEED_DEBUG is true, we need a variable for debugging purposes even if it isn't needed for code generation. */ static tree -elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name, +elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, const char *s, bool definition, bool need_value, bool need_debug) { tree gnu_expr; @@ -6207,8 +6386,8 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name, need_debug = false; /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */ - gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, - gnu_name, definition, need_debug); + gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity, s, + definition, need_debug); /* Save the expression in case we try to elaborate this entity again. Since it's not a DECL, don't check it. Don't save if it's a discriminant. */ @@ -6221,23 +6400,13 @@ elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name, /* Similar, but take a GNU expression and always return a result. */ static tree -elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, +elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, const char *s, bool definition, bool need_debug) { const bool expr_public_p = Is_Public (gnat_entity); const bool expr_global_p = expr_public_p || global_bindings_p (); bool expr_variable_p, use_variable; - /* In most cases, we won't see a naked FIELD_DECL because a discriminant - reference will have been replaced with a COMPONENT_REF when the type - is being elaborated. However, there are some cases involving child - types where we will. So convert it to a COMPONENT_REF. We hope it - will be at the highest level of the expression in these cases. */ - if (TREE_CODE (gnu_expr) == FIELD_DECL) - gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr), - build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)), - gnu_expr, NULL_TREE); - /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact that an expression cannot contain both a discriminant and a variable. */ if (CONTAINS_PLACEHOLDER_P (gnu_expr)) @@ -6248,31 +6417,18 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, containing the definition is elaborated. If this entity is defined at top level, replace the expression by the variable; otherwise use a SAVE_EXPR if this is necessary. */ - if (CONSTANT_CLASS_P (gnu_expr)) + if (TREE_CONSTANT (gnu_expr)) expr_variable_p = false; else { /* Skip any conversions and simple constant arithmetics to see if the - expression is based on a read-only variable. - ??? This really should remain read-only, but we have to think about - the typing of the tree here. */ + expression is based on a read-only variable. */ tree inner = remove_conversions (gnu_expr, true); inner = skip_simple_constant_arithmetic (inner); if (handled_component_p (inner)) - { - HOST_WIDE_INT bitsize, bitpos; - tree offset; - machine_mode mode; - int unsignedp, volatilep; - - inner = get_inner_reference (inner, &bitsize, &bitpos, &offset, - &mode, &unsignedp, &volatilep, false); - /* If the offset is variable, err on the side of caution. */ - if (offset) - inner = NULL_TREE; - } + inner = get_inner_constant_reference (inner); expr_variable_p = !(inner @@ -6294,19 +6450,17 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, /* Now create it, possibly only for debugging purposes. */ if (use_variable || need_debug) { - /* The following variable creation can happen when processing the body of - subprograms that are defined out of the extended main unit and - inlined. In this case, we are not at the global scope, and thus the + /* The following variable creation can happen when processing the body + of subprograms that are defined out of the extended main unit and + inlined. In this case, we are not at the global scope, and thus the new variable must not be tagged "external", as we used to do here as - long as definition == 0. */ - const bool external_flag = !definition && expr_global_p; + soon as DEFINITION was false. */ tree gnu_decl - = create_var_decl_1 - (create_concat_name (gnat_entity, IDENTIFIER_POINTER (gnu_name)), - NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p, - external_flag, expr_global_p, !need_debug, NULL, gnat_entity); - - DECL_ARTIFICIAL (gnu_decl) = 1; + = create_var_decl (create_concat_name (gnat_entity, s), NULL_TREE, + TREE_TYPE (gnu_expr), gnu_expr, true, + expr_public_p, !definition && expr_global_p, + expr_global_p, false, true, need_debug, + NULL, gnat_entity); /* Using this variable at debug time (if need_debug is true) requires a proper location. The back-end will compute a location for this @@ -6314,7 +6468,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, Returning the variable ensures the caller will use it in generated code. Note that there is no need for a location if the debug info contains an integer constant. - FIXME: when the encoding-based debug scheme is dropped, move this + TODO: when the encoding-based debug scheme is dropped, move this condition to the top-level IF block: we will not need to create a variable anymore in such cases, then. */ if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr))) @@ -6327,7 +6481,7 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, /* Similar, but take an alignment factor and make it explicit in the tree. */ static tree -elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, +elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, const char *s, bool definition, bool need_debug, unsigned int align) { tree unit_align = size_int (align / BITS_PER_UNIT); @@ -6336,10 +6490,57 @@ elaborate_expression_2 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, elaborate_expression_1 (size_binop (EXACT_DIV_EXPR, gnu_expr, unit_align), - gnat_entity, gnu_name, definition, + gnat_entity, s, definition, need_debug), unit_align); } + +/* Structure to hold internal data for elaborate_reference. */ + +struct er_data +{ + Entity_Id entity; + bool definition; + unsigned int n; +}; + +/* Wrapper function around elaborate_expression_1 for elaborate_reference. */ + +static tree +elaborate_reference_1 (tree ref, void *data) +{ + struct er_data *er = (struct er_data *)data; + char suffix[16]; + + /* This is what elaborate_expression_1 does if NEED_DEBUG is false. */ + if (TREE_CONSTANT (ref)) + return ref; + + /* If this is a COMPONENT_REF of a fat pointer, elaborate the entire fat + pointer. This may be more efficient, but will also allow us to more + easily find the match for the PLACEHOLDER_EXPR. */ + if (TREE_CODE (ref) == COMPONENT_REF + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0)))) + return build3 (COMPONENT_REF, TREE_TYPE (ref), + elaborate_reference_1 (TREE_OPERAND (ref, 0), data), + TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2)); + + sprintf (suffix, "EXP%d", ++er->n); + return + elaborate_expression_1 (ref, er->entity, suffix, er->definition, false); +} + +/* Elaborate the reference REF to be used as renamed object for GNAT_ENTITY. + DEFINITION is true if this is done for a definition of GNAT_ENTITY and + INIT is set to the first arm of a COMPOUND_EXPR present in REF, if any. */ + +static tree +elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition, + tree *init) +{ + struct er_data er = { gnat_entity, definition, 0 }; + return gnat_rewrite_reference (ref, elaborate_reference_1, &er, init); +} /* Given a GNU tree and a GNAT list of choices, generate an expression to test the value passed against the list of choices. */ @@ -6441,25 +6642,29 @@ adjust_packed (tree field_type, tree record_type, int packed) if (type_has_variable_size (field_type)) return 0; + /* In the other cases, we can honor the packing. */ + if (packed) + return packed; + /* If the alignment of the record is specified and the field type is over-aligned, request Storage_Unit alignment for the field. */ - if (packed == -2) - { - if (TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type)) - return -1; - else - return 0; - } + if (TYPE_ALIGN (record_type) + && TYPE_ALIGN (field_type) > TYPE_ALIGN (record_type)) + return -1; + + /* Likewise if the maximum alignment of the record is specified. */ + if (TYPE_MAX_ALIGN (record_type) + && TYPE_ALIGN (field_type) > TYPE_MAX_ALIGN (record_type)) + return -1; - return packed; + return 0; } /* Return a GCC tree for a field corresponding to GNAT_FIELD to be placed in GNU_RECORD_TYPE. - PACKED is 1 if the enclosing record is packed, -1 if the enclosing - record has Component_Alignment of Storage_Unit, -2 if the enclosing - record has a specified alignment. + PACKED is 1 if the enclosing record is packed or -1 if the enclosing + record has Component_Alignment of Storage_Unit. DEFINITION is true if this field is for a record being defined. @@ -6474,7 +6679,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, const bool is_aliased = Is_Aliased (gnat_field); const bool is_atomic - = (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type)); + = (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type)); const bool is_independent = (Is_Independent (gnat_field) || Is_Independent (gnat_field_type)); const bool is_volatile @@ -6550,7 +6755,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, } } - if (Is_Atomic (gnat_field)) + if (Is_Atomic_Or_VFA (gnat_field)) check_ok_for_atomic_type (gnu_field_type, gnat_field, false); if (Present (Component_Clause (gnat_field))) @@ -6750,6 +6955,15 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, else gnu_pos = NULL_TREE; + /* If the field's type is a padded type made for a scalar field of a record + type with reverse storage order, we need to propagate the reverse storage + order to the padding type since it is the innermost enclosing aggregate + type around the scalar. */ + if (TYPE_IS_PADDING_P (gnu_field_type) + && TYPE_REVERSE_STORAGE_ORDER (gnu_record_type) + && Is_Scalar_Type (gnat_field_type)) + gnu_field_type = set_reverse_storage_order_on_pad_type (gnu_field_type); + gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type)); @@ -6759,11 +6973,15 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed, gnu_size, gnu_pos, packed, Is_Aliased (gnat_field)); Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field)); DECL_ALIASED_P (gnu_field) = Is_Aliased (gnat_field); - TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile; + TREE_SIDE_EFFECTS (gnu_field) = TREE_THIS_VOLATILE (gnu_field) = is_volatile; if (Ekind (gnat_field) == E_Discriminant) - DECL_DISCRIMINANT_NUMBER (gnu_field) - = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); + { + DECL_INVARIANT_P (gnu_field) + = No (Discriminant_Default_Value (gnat_field)); + DECL_DISCRIMINANT_NUMBER (gnu_field) + = UI_To_gnu (Discriminant_Number (gnat_field), sizetype); + } return gnu_field; } @@ -6915,9 +7133,8 @@ typedef struct vinfo GNU_FIELD_LIST. The other calls to this function are recursive calls for the component list of a variant and, in this case, GNU_FIELD_LIST is empty. - PACKED is 1 if this is for a packed record, -1 if this is for a record - with Component_Alignment of Storage_Unit, -2 if this is for a record - with a specified alignment. + PACKED is 1 if this is for a packed record or -1 if this is for a record + with Component_Alignment of Storage_Unit. DEFINITION is true if we are defining this record type. @@ -6956,6 +7173,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, bool debug_info, bool maybe_unused, bool reorder, tree first_free_pos, tree *p_gnu_rep_list) { + const bool needs_xv_encodings + = debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL; bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type); bool variants_have_rep = all_rep; bool layout_with_rep = false; @@ -7066,6 +7285,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, TYPE_NAME (gnu_union_type) = gnu_union_name; TYPE_ALIGN (gnu_union_type) = 0; TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type); + TYPE_REVERSE_STORAGE_ORDER (gnu_union_type) + = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type); } /* If all the fields down to this level have a rep clause, find out @@ -7117,6 +7338,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, record actually gets only the alignment required. */ TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type); TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type); + TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type) + = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type); /* Similarly, if the outer record has a size specified and all the fields have a rep clause, we can propagate the size. */ @@ -7134,7 +7357,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, NULL_TREE, packed, definition, !all_rep_and_size, all_rep, unchecked_union, - true, debug_info, true, reorder, + true, needs_xv_encodings, true, reorder, this_first_free_pos, all_rep || this_first_free_pos ? NULL : &gnu_rep_list); @@ -7209,6 +7432,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, position at this level. */ tree gnu_rep_type = make_node (RECORD_TYPE); tree gnu_rep_part; + TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type) + = TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type); finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info); gnu_rep_part = create_rep_part (gnu_rep_type, gnu_variant_type, @@ -7222,7 +7447,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, if (debug_info) rest_of_record_type_compilation (gnu_variant_type); create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type, - true, debug_info, gnat_component_list); + true, needs_xv_encodings, gnat_component_list); gnu_field = create_field_decl (gnu_variant->name, gnu_variant_type, @@ -7255,7 +7480,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, } finish_record_type (gnu_union_type, nreverse (gnu_variant_list), - all_rep_and_size ? 1 : 0, debug_info); + all_rep_and_size ? 1 : 0, needs_xv_encodings); /* If GNU_UNION_TYPE is our record type, it means we must have an Unchecked_Union with no fields. Verify that and, if so, just @@ -7269,7 +7494,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, } create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type, true, - debug_info, gnat_component_list); + needs_xv_encodings, gnat_component_list); /* Deal with packedness like in gnat_to_gnu_field. */ if (union_field_needs_strict_alignment) @@ -7381,6 +7606,25 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, if (p_gnu_rep_list && gnu_rep_list) *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list); + /* Deal with the annoying case of an extension of a record with variable size + and partial rep clause, for which the _Parent field is forced at offset 0 + and has variable size, which we do not support below. Note that we cannot + do it if the field has fixed size because we rely on the presence of the + REP part built below to trigger the reordering of the fields in a derived + record type when all the fields have a fixed position. */ + else if (gnu_rep_list + && !DECL_CHAIN (gnu_rep_list) + && TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST + && !variants_have_rep + && first_free_pos + && integer_zerop (first_free_pos) + && integer_zerop (bit_position (gnu_rep_list))) + { + DECL_CHAIN (gnu_rep_list) = gnu_field_list; + gnu_field_list = gnu_rep_list; + gnu_rep_list = NULL_TREE; + } + /* Otherwise, sort the fields by bit position and put them into their own record, before the others, if we also have fields without rep clause. */ else if (gnu_rep_list) @@ -7416,6 +7660,8 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list, gnu_field_list = gnu_rep_list; else { + TYPE_REVERSE_STORAGE_ORDER (gnu_rep_type) + = TYPE_REVERSE_STORAGE_ORDER (gnu_record_type); finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info); /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields @@ -7726,12 +7972,19 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type) { /* If there is no entry, this is an inherited component whose position is the same as in the parent type. */ - Set_Component_Bit_Offset - (gnat_field, - Component_Bit_Offset (Original_Record_Component (gnat_field))); + Entity_Id gnat_orig_field = Original_Record_Component (gnat_field); - Set_Esize (gnat_field, - Esize (Original_Record_Component (gnat_field))); + /* If we are just annotating types, discriminants renaming those of + the parent have no entry so deal with them specifically. */ + if (type_annotate_only + && gnat_orig_field == gnat_field + && Ekind (gnat_field) == E_Discriminant) + gnat_orig_field = Corresponding_Discriminant (gnat_field); + + Set_Component_Bit_Offset (gnat_field, + Component_Bit_Offset (gnat_orig_field)); + + Set_Esize (gnat_field, Esize (gnat_orig_field)); } } } @@ -7814,7 +8067,7 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition) tree replacement = convert (TREE_TYPE (gnu_field), elaborate_expression (Node (gnat_constr), gnat_subtype, - get_entity_name (gnat_discrim), + get_entity_char (gnat_discrim), definition, true, false)); subst_pair s = {gnu_field, replacement}; gnu_list.safe_push (s); @@ -8226,6 +8479,9 @@ check_ok_for_atomic_type (tree type, Entity_Id gnat_entity, bool component_p) if (component_p) post_error_ne ("atomic access to component of & cannot be guaranteed", gnat_error_point, gnat_entity); + else if (Is_Volatile_Full_Access (gnat_entity)) + post_error_ne ("volatile full access to & cannot be guaranteed", + gnat_error_point, gnat_entity); else post_error_ne ("atomic access to & cannot be guaranteed", gnat_error_point, gnat_entity); @@ -8285,17 +8541,17 @@ intrin_arglists_compatible_p (intrin_binding_t * inb) /* Sequence position of the last argument we checked. */ int argpos = 0; - while (1) + while (true) { tree ada_type = function_args_iter_cond (&ada_iter); tree btin_type = function_args_iter_cond (&btin_iter); /* If we've exhausted both lists simultaneously, we're done. */ - if (ada_type == NULL_TREE && btin_type == NULL_TREE) + if (!ada_type && !btin_type) break; /* If one list is shorter than the other, they fail to match. */ - if (ada_type == NULL_TREE || btin_type == NULL_TREE) + if (!ada_type || !btin_type) return false; /* If we're done with the Ada args and not with the internal builtin @@ -8348,7 +8604,7 @@ intrin_return_compatible_p (intrin_binding_t * inb) /* If return type is Address (integer type), map it to void *. */ if (Is_Descendent_Of_Address (Etype (inb->gnat_entity))) - ada_return_type = ptr_void_type_node; + ada_return_type = ptr_type_node; /* Check return types compatibility otherwise. Note that this handles void/void as well. */ @@ -8661,12 +8917,14 @@ copy_and_substitute_in_size (tree new_type, tree old_type, TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type)); } -/* Add a parallel type to GNU_TYPE, the translation of GNAT_ENTITY, which is - the implementation type of a packed array type (Is_Packed_Array_Impl_Type). - The parallel type is the original array type if it has been translated. */ +/* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is + the implementation type of a packed array type (Is_Packed_Array_Impl_Type), + the original array type if it has been translated. This association is a + parallel type for GNAT encodings or a debug type for standard DWARF. Note + that for standard DWARF, we also want to get the original type name. */ static void -add_parallel_type_for_packed_array (tree gnu_type, Entity_Id gnat_entity) +associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity) { Entity_Id gnat_original_array_type = Underlying_Type (Original_Array_Type (gnat_entity)); @@ -8680,7 +8938,18 @@ add_parallel_type_for_packed_array (tree gnu_type, Entity_Id gnat_entity) if (TYPE_IS_DUMMY_P (gnu_original_array_type)) return; - add_parallel_type (gnu_type, gnu_original_array_type); + if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL) + { + tree original_name = TYPE_NAME (gnu_original_array_type); + + if (TREE_CODE (original_name) == TYPE_DECL) + original_name = DECL_NAME (original_name); + + SET_TYPE_ORIGINAL_PACKED_ARRAY (gnu_type, gnu_original_array_type); + TYPE_NAME (gnu_type) = original_name; + } + else + add_parallel_type (gnu_type, gnu_original_array_type); } /* Given a type T, a FIELD_DECL F, and a replacement value R, return a @@ -8872,6 +9141,13 @@ rm_size (tree gnu_type) fully-qualified name, possibly with type information encoding. Otherwise, return the name. */ +static const char * +get_entity_char (Entity_Id gnat_entity) +{ + Get_Encoded_Name (gnat_entity); + return ggc_strdup (Name_Buffer); +} + tree get_entity_name (Entity_Id gnat_entity) { |