From 05dbb83f9e3b783de3d666348b1d1a0e7895b09f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 May 2017 11:17:13 +0200 Subject: [PATCH] [multiple changes] 2017-05-02 Eric Botcazou * einfo.ads (Corresponding_Record_Component): New alias for Node21 used for E_Component and E_Discriminant. * einfo.adb (Corresponding_Record_Component): New function. (Set_Corresponding_Record_Component): New procedure. (Write_Field21_Name): Handle Corresponding_Record_Component. * sem_ch3.adb (Inherit_Component): Set Corresponding_Record_Component for every component in the untagged case. Clear it afterwards for non-girder discriminants. * gcc-interface/decl.c (gnat_to_gnu_entity) : For a derived untagged type with discriminants and constraints, apply the constraints to the layout of the parent type to deduce the layout. (field_is_aliased): Delete. (components_to_record): Test DECL_ALIASED_P directly. (annotate_rep): Check that fields are present except for an extension. (create_field_decl_from): Add DEBUG_INFO_P parameter and pass it in recursive and other calls. Add guard for the manual CSE on the size. (is_stored_discriminant): New predicate. (copy_and_substitute_in_layout): Consider only stored discriminants and check that original fields are present in the old type. Deal with derived types. Adjust call to create_variant_part_from. 2017-05-02 Ed Schonberg * exp_ch6.adb (Expand_Call_Helper): When locating the accessibility entity created for an access parameter, handle properly a reference to a formal of an enclosing subprogram. if the reference appears in an inherited class-wide condition, it is the rewriting of the reference in the ancestor expression, but the accessibility entity must be that of the current formal. 2017-05-02 Javier Miranda * exp_ch4.adb (Expand_Non_Binary_Modular_Op): New subprogram. (Expand_N_Op_Add, Expand_N_Op_Divide, Expand_N_Op_Minus, Expand_N_Op_Multiply, Expand_N_Op_Or, Expand_N_Op_Subtract): Call Expand_Non_Binary_Modular_Op. From-SVN: r247482 --- gcc/ada/ChangeLog | 44 ++ gcc/ada/einfo.adb | 18 + gcc/ada/einfo.ads | 14 + gcc/ada/exp_ch4.adb | 263 ++++++++++++ gcc/ada/exp_ch6.adb | 10 + gcc/ada/gcc-interface/decl.c | 787 ++++++++++++++++++----------------- gcc/ada/sem_ch3.adb | 2 + 7 files changed, 756 insertions(+), 382 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 30cd0b1b767..7892b6953a1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2017-05-02 Eric Botcazou + + * einfo.ads (Corresponding_Record_Component): New alias + for Node21 used for E_Component and E_Discriminant. + * einfo.adb (Corresponding_Record_Component): New function. + (Set_Corresponding_Record_Component): New procedure. + (Write_Field21_Name): Handle Corresponding_Record_Component. + * sem_ch3.adb (Inherit_Component): Set + Corresponding_Record_Component for every component in + the untagged case. Clear it afterwards for non-girder + discriminants. + * gcc-interface/decl.c (gnat_to_gnu_entity) + : For a derived untagged type with discriminants + and constraints, apply the constraints to the layout of the + parent type to deduce the layout. + (field_is_aliased): Delete. + (components_to_record): Test DECL_ALIASED_P directly. + (annotate_rep): Check that fields are present except for + an extension. + (create_field_decl_from): Add DEBUG_INFO_P + parameter and pass it in recursive and other calls. Add guard + for the manual CSE on the size. + (is_stored_discriminant): New predicate. + (copy_and_substitute_in_layout): Consider only + stored discriminants and check that original fields are present + in the old type. Deal with derived types. Adjust call to + create_variant_part_from. + +2017-05-02 Ed Schonberg + + * exp_ch6.adb (Expand_Call_Helper): When locating the + accessibility entity created for an access parameter, handle + properly a reference to a formal of an enclosing subprogram. if + the reference appears in an inherited class-wide condition, it + is the rewriting of the reference in the ancestor expression, + but the accessibility entity must be that of the current formal. + +2017-05-02 Javier Miranda + + * exp_ch4.adb (Expand_Non_Binary_Modular_Op): New subprogram. + (Expand_N_Op_Add, Expand_N_Op_Divide, Expand_N_Op_Minus, + Expand_N_Op_Multiply, Expand_N_Op_Or, Expand_N_Op_Subtract): + Call Expand_Non_Binary_Modular_Op. + 2017-05-02 Eric Botcazou * sem_ch3.adb (Build_Derived_Private_Type): If the parent type diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 2d283db30da..1a4621e7c1a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -185,6 +185,7 @@ package body Einfo is -- Scalar_Range Node20 -- Accept_Address Elist21 + -- Corresponding_Record_Component Node21 -- Default_Expr_Function Node21 -- Discriminant_Constraint Elist21 -- Interface_Name Node21 @@ -950,6 +951,12 @@ package body Einfo is return Node18 (Id); end Corresponding_Protected_Entry; + function Corresponding_Record_Component (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + return Node21 (Id); + end Corresponding_Record_Component; + function Corresponding_Record_Type (Id : E) return E is begin pragma Assert (Is_Concurrent_Type (Id)); @@ -4083,6 +4090,12 @@ package body Einfo is Set_Node18 (Id, V); end Set_Corresponding_Protected_Entry; + procedure Set_Corresponding_Record_Component (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Component, E_Discriminant)); + Set_Node21 (Id, V); + end Set_Corresponding_Record_Component; + procedure Set_Corresponding_Record_Type (Id : E; V : E) is begin pragma Assert (Is_Concurrent_Type (Id)); @@ -10402,6 +10415,11 @@ package body Einfo is when Entry_Kind => Write_Str ("Accept_Address"); + when E_Component + | E_Discriminant + => + Write_Str ("Corresponding_Record_Component"); + when E_In_Parameter => Write_Str ("Default_Expr_Function"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index f2b9d932887..176685ea286 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -762,6 +762,14 @@ package Einfo is -- Defined in subprogram bodies. Set for subprogram bodies that implement -- a protected type entry to point to the entity for the entry. +-- Corresponding_Record_Component (Node21) +-- Defined in components of a derived untagged record type, including +-- discriminants. For a regular component or a girder discriminant, +-- points to the corresponding component in the parent type. Set to +-- Empty for a non-girder discriminant. It is used by the back end to +-- ensure the layout of the derived type matches that of the parent +-- type when there is no representation clause on the derived type. + -- Corresponding_Record_Type (Node18) -- Defined in protected and task types and subtypes. References the -- entity for the corresponding record type constructed by the expander @@ -5815,6 +5823,7 @@ package Einfo is -- Prival (Node17) -- Renamed_Object (Node18) (always Empty) -- Discriminant_Checking_Func (Node20) + -- Corresponding_Record_Component (Node21) -- Original_Record_Component (Node22) -- DT_Offset_To_Top_Func (Node25) -- Related_Type (Node27) @@ -5908,6 +5917,7 @@ package Einfo is -- Renamed_Object (Node18) (always Empty) -- Corresponding_Discriminant (Node19) -- Discriminant_Default_Value (Node20) + -- Corresponding_Record_Component (Node21) -- Original_Record_Component (Node22) -- CR_Discriminant (Node23) -- Is_Completely_Hidden (Flag103) @@ -6943,6 +6953,7 @@ package Einfo is function Corresponding_Function (Id : E) return E; function Corresponding_Procedure (Id : E) return E; function Corresponding_Protected_Entry (Id : E) return E; + function Corresponding_Record_Component (Id : E) return E; function Corresponding_Record_Type (Id : E) return E; function Corresponding_Remote_Type (Id : E) return E; function CR_Discriminant (Id : E) return E; @@ -7632,6 +7643,7 @@ package Einfo is procedure Set_Corresponding_Function (Id : E; V : E); procedure Set_Corresponding_Procedure (Id : E; V : E); procedure Set_Corresponding_Protected_Entry (Id : E; V : E); + procedure Set_Corresponding_Record_Component (Id : E; V : E); procedure Set_Corresponding_Record_Type (Id : E; V : E); procedure Set_Corresponding_Remote_Type (Id : E; V : E); procedure Set_CR_Discriminant (Id : E; V : E); @@ -8435,6 +8447,7 @@ package Einfo is pragma Inline (Corresponding_Discriminant); pragma Inline (Corresponding_Equality); pragma Inline (Corresponding_Protected_Entry); + pragma Inline (Corresponding_Record_Component); pragma Inline (Corresponding_Record_Type); pragma Inline (Corresponding_Remote_Type); pragma Inline (CR_Discriminant); @@ -8960,6 +8973,7 @@ package Einfo is pragma Inline (Set_Corresponding_Discriminant); pragma Inline (Set_Corresponding_Equality); pragma Inline (Set_Corresponding_Protected_Entry); + pragma Inline (Set_Corresponding_Record_Component); pragma Inline (Set_Corresponding_Record_Type); pragma Inline (Set_Corresponding_Remote_Type); pragma Inline (Set_CR_Discriminant); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index eccfcd21993..cc797a01a61 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -128,6 +128,11 @@ package body Exp_Ch4 is -- Common expansion processing for Boolean operators (And, Or, Xor) for the -- case of array type arguments. + procedure Expand_Non_Binary_Modular_Op (N : Node_Id); + -- Generating C code convert non-binary modular arithmetic operations into + -- code that relies on the frontend expansion of operator Mod. No expansion + -- is performed if N is not a non-binary modular operand. + procedure Expand_Short_Circuit_Operator (N : Node_Id); -- Common expansion processing for short-circuit boolean operators @@ -3957,6 +3962,217 @@ package body Exp_Ch4 is end if; end Expand_Membership_Minimize_Eliminate_Overflow; + ---------------------------------- + -- Expand_Non_Binary_Modular_Op -- + ---------------------------------- + + procedure Expand_Non_Binary_Modular_Op (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + procedure Expand_Modular_Addition; + -- Expand the modular addition handling the special case of adding a + -- constant. + + procedure Expand_Modular_Op; + -- Compute the general rule: (lhs OP rhs) mod Modulus + + procedure Expand_Modular_Subtraction; + -- Expand the modular addition handling the special case of subtracting + -- a constant. + + ----------------------------- + -- Expand_Modular_Addition -- + ----------------------------- + + procedure Expand_Modular_Addition is + begin + -- If this is not the addition of a constant then compute it using + -- the general rule: (lhs + rhs) mod Modulus + + if Nkind (Right_Opnd (N)) /= N_Integer_Literal then + Expand_Modular_Op; + + -- If this is an addition of a constant, convert it to a subtraction + -- plus a conditional expression since we can compute it faster than + -- computing the modulus. + + -- modMinusRhs = Modulus - rhs + -- if lhs < modMinusRhs then lhs + rhs + -- else lhs - modMinusRhs + + else + declare + Mod_Minus_Right : constant Uint := + Modulus (Typ) - Intval (Right_Opnd (N)); + + Exprs : constant List_Id := New_List; + Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); + Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); + Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, + Loc); + begin + Set_Left_Opnd (Cond_Expr, + New_Copy_Tree (Left_Opnd (N))); + Set_Right_Opnd (Cond_Expr, + Make_Integer_Literal (Loc, Mod_Minus_Right)); + Append_To (Exprs, Cond_Expr); + + Set_Left_Opnd (Then_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Then_Expr, + Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); + Append_To (Exprs, Then_Expr); + + Set_Left_Opnd (Else_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Else_Expr, + Make_Integer_Literal (Loc, Mod_Minus_Right)); + Append_To (Exprs, Else_Expr); + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_If_Expression (Loc, Expressions => Exprs))); + end; + end if; + end Expand_Modular_Addition; + + ----------------------- + -- Expand_Modular_Op -- + ----------------------- + + procedure Expand_Modular_Op is + Op_Expr : constant Node_Id := New_Op_Node (Nkind (N), Loc); + Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc); + + begin + -- Convert non-binary modular type operands into integer or integer + -- values. Thus we avoid never-ending loops expanding them, and we + -- also ensure that the backend never receives non-binary modular + -- type expressions. + + if Nkind_In (Nkind (N), N_Op_And, N_Op_Or) then + Set_Left_Opnd (Op_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Op_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Right_Opnd (N)))); + Set_Left_Opnd (Mod_Expr, + Unchecked_Convert_To (Standard_Integer, Op_Expr)); + else + Set_Left_Opnd (Op_Expr, + Unchecked_Convert_To (Standard_Integer, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Op_Expr, + Unchecked_Convert_To (Standard_Integer, + New_Copy_Tree (Right_Opnd (N)))); + Set_Left_Opnd (Mod_Expr, Op_Expr); + end if; + + Set_Right_Opnd (Mod_Expr, + Make_Integer_Literal (Loc, Modulus (Typ))); + + Rewrite (N, + Unchecked_Convert_To (Typ, Mod_Expr)); + end Expand_Modular_Op; + + -------------------------------- + -- Expand_Modular_Subtraction -- + -------------------------------- + + procedure Expand_Modular_Subtraction is + begin + -- If this is not the addition of a constant then compute it using + -- the general rule: (lhs + rhs) mod Modulus + + if Nkind (Right_Opnd (N)) /= N_Integer_Literal then + Expand_Modular_Op; + + -- If this is an addition of a constant, convert it to a subtraction + -- plus a conditional expression since we can compute it faster than + -- computing the modulus. + + -- modMinusRhs = Modulus - rhs + -- if lhs < rhs then lhs + modMinusRhs + -- else lhs - rhs + + else + declare + Mod_Minus_Right : constant Uint := + Modulus (Typ) - Intval (Right_Opnd (N)); + + Exprs : constant List_Id := New_List; + Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc); + Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc); + Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract, + Loc); + begin + Set_Left_Opnd (Cond_Expr, + New_Copy_Tree (Left_Opnd (N))); + Set_Right_Opnd (Cond_Expr, + Make_Integer_Literal (Loc, Intval (Right_Opnd (N)))); + Append_To (Exprs, Cond_Expr); + + Set_Left_Opnd (Then_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Then_Expr, + Make_Integer_Literal (Loc, Mod_Minus_Right)); + Append_To (Exprs, Then_Expr); + + Set_Left_Opnd (Else_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Left_Opnd (N)))); + Set_Right_Opnd (Else_Expr, + Unchecked_Convert_To (Standard_Unsigned, + New_Copy_Tree (Right_Opnd (N)))); + Append_To (Exprs, Else_Expr); + + Rewrite (N, + Unchecked_Convert_To (Typ, + Make_If_Expression (Loc, Expressions => Exprs))); + end; + end if; + end Expand_Modular_Subtraction; + + -- Start of processing for Expand_Non_Binary_Modular_Op + + begin + -- No action needed if we are not generating C code for a non-binary + -- modular operand. + + if not Modify_Tree_For_C + or else not Non_Binary_Modulus (Typ) + then + return; + end if; + + case Nkind (N) is + when N_Op_Add => + Expand_Modular_Addition; + + when N_Op_Subtract => + Expand_Modular_Subtraction; + + when N_Op_Minus => + -- Expand -expr into (0 - expr) + + Rewrite (N, + Make_Op_Subtract (Loc, + Left_Opnd => Make_Integer_Literal (Loc, 0), + Right_Opnd => Right_Opnd (N))); + Analyze_And_Resolve (N, Typ); + + when others => + Expand_Modular_Op; + end case; + + Analyze_And_Resolve (N, Typ); + end Expand_Non_Binary_Modular_Op; + ------------------------ -- Expand_N_Allocator -- ------------------------ @@ -6639,6 +6855,13 @@ package body Exp_Ch4 is -- Overflow checks for floating-point if -gnateF mode active Check_Float_Op_Overflow (N); + + -- Generating C code convert non-binary modular additions into code that + -- relies on the frontend expansion of operator Mod. + + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); + end if; end Expand_N_Op_Add; --------------------- @@ -6662,7 +6885,13 @@ package body Exp_Ch4 is elsif Is_Intrinsic_Subprogram (Entity (N)) then Expand_Intrinsic_Call (N, Entity (N)); + end if; + + -- Generating C code convert non-binary modular operators into code that + -- relies on the frontend expansion of operator Mod. + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); end if; end Expand_N_Op_And; @@ -6904,6 +7133,13 @@ package body Exp_Ch4 is -- Overflow checks for floating-point if -gnateF mode active Check_Float_Op_Overflow (N); + + -- Generating C code convert non-binary modular divisions into code that + -- relies on the frontend expansion of operator Mod. + + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); + end if; end Expand_N_Op_Divide; -------------------- @@ -8406,6 +8642,13 @@ package body Exp_Ch4 is Analyze_And_Resolve (N, Typ); end if; + + -- Generating C code convert non-binary modular minus into code that + -- relies on the frontend expansion of operator Mod. + + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); + end if; end Expand_N_Op_Minus; --------------------- @@ -8882,6 +9125,13 @@ package body Exp_Ch4 is -- Overflow checks for floating-point if -gnateF mode active Check_Float_Op_Overflow (N); + + -- Generating C code convert non-binary modular multiplications into + -- code that relies on the frontend expansion of operator Mod. + + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); + end if; end Expand_N_Op_Multiply; -------------------- @@ -9191,7 +9441,13 @@ package body Exp_Ch4 is elsif Is_Intrinsic_Subprogram (Entity (N)) then Expand_Intrinsic_Call (N, Entity (N)); + end if; + + -- Generating C code convert non-binary modular operators into code that + -- relies on the frontend expansion of operator Mod. + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); end if; end Expand_N_Op_Or; @@ -9625,6 +9881,13 @@ package body Exp_Ch4 is -- Overflow checks for floating-point if -gnateF mode active Check_Float_Op_Overflow (N); + + -- Generating C code convert non-binary modular subtractions into code + -- that relies on the frontend expansion of operator Mod. + + if Modify_Tree_For_C then + Expand_Non_Binary_Modular_Op (N); + end if; end Expand_N_Op_Subtract; --------------------- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 0317dc39e21..3fb546805ff 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2938,6 +2938,16 @@ package body Exp_Ch6 is and then Is_Aliased_View (Prev_Orig) then Prev_Orig := Prev; + + -- If the actual is a formal of an enclosing subprogram it is + -- the right entity, even if it is a rewriting. This happens + -- when the call is within an inherited condition or predicate. + + elsif Is_Entity_Name (Actual) + and then Is_Formal (Entity (Actual)) + and then In_Open_Scopes (Scope (Entity (Actual))) + then + Prev_Orig := Prev; end if; -- Ada 2005 (AI-251): Thunks must propagate the extra actuals of diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 75b0475fe5e..af4574d2c62 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -224,20 +224,21 @@ static Uint annotate_value (tree); static void annotate_rep (Entity_Id, tree); static tree build_position_list (tree, bool, tree, tree, unsigned int, tree); static vec build_subst_list (Entity_Id, Entity_Id, bool); -static vec build_variant_list (tree, - vec , - vec ); +static vec build_variant_list (tree, vec, + vec); static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool); static void set_rm_size (Uint, tree, Entity_Id); static unsigned int validate_alignment (Uint, Entity_Id, unsigned int); static void check_ok_for_atomic_type (tree, Entity_Id, bool); static tree create_field_decl_from (tree, tree, tree, tree, tree, - vec ); + vec); static tree create_rep_part (tree, tree, tree); static tree get_rep_part (tree); -static tree create_variant_part_from (tree, vec , tree, - tree, vec ); -static void copy_and_substitute_in_size (tree, tree, vec ); +static tree create_variant_part_from (tree, vec, tree, + tree, vec, bool); +static void copy_and_substitute_in_size (tree, tree, vec); +static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree, + vec, bool); static void associate_original_type_to_packed_array (tree, Entity_Id); static const char *get_entity_char (Entity_Id); @@ -486,8 +487,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If the entity is a discriminant of an extended tagged type used to rename a discriminant of the parent type, return the latter. */ - if (Is_Tagged_Type (gnat_record) - && Present (Corresponding_Discriminant (gnat_entity))) + if (kind == E_Discriminant + && Present (Corresponding_Discriminant (gnat_entity)) + && Is_Tagged_Type (gnat_record)) { gnu_decl = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), @@ -507,7 +509,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnu_decl = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), gnu_expr, definition); - saved = true; + /* GNU_DECL contains a PLACEHOLDER_EXPR for discriminants. */ + if (kind == E_Discriminant) + saved = true; break; } @@ -2995,7 +2999,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) Node_Id full_definition = Declaration_Node (gnat_entity); Node_Id record_definition = Type_Definition (full_definition); Node_Id gnat_constr; - Entity_Id gnat_field; + Entity_Id gnat_field, gnat_parent_type; tree gnu_field, gnu_field_list = NULL_TREE; tree gnu_get_parent; /* Set PACKED in keeping with gnat_to_gnu_field. */ @@ -3229,15 +3233,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { /* If this is a record extension and this discriminant is the renaming of another discriminant, we've handled it above. */ - if (Present (Parent_Subtype (gnat_entity)) - && 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) + if (is_extension && Present (Corresponding_Discriminant (gnat_field))) continue; @@ -3262,7 +3258,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } /* If we have a derived untagged type that renames discriminants in - the root type, the (stored) discriminants are a just copy of the + the root type, the (stored) discriminants are just a copy of the discriminants of the root type. This means that any constraints added by the renaming in the derivation are disregarded as far as the layout of the derived type is concerned. To rescue them, @@ -3280,30 +3276,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && Ekind (Entity (Node (gnat_constr))) == E_Discriminant) { Entity_Id gnat_discr = Entity (Node (gnat_constr)); - tree gnu_discr_type, gnu_ref; - - /* If the scope of the discriminant is not the record type, - this means that we're processing the implicit full view - of a type derived from a private discriminated type: in - this case, the Stored_Constraint list is simply copied - from the partial view, see Build_Derived_Private_Type. - So we need to retrieve the corresponding discriminant - of the implicit full view, otherwise we will abort. */ - if (Scope (gnat_discr) != gnat_entity) - { - Entity_Id field; - for (field = First_Entity (gnat_entity); - Present (field); - field = Next_Entity (field)) - if (Ekind (field) == E_Discriminant - && same_discriminant_p (gnat_discr, field)) - break; - gcc_assert (Present (field)); - gnat_discr = field; - } - - gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr)); - gnu_ref + tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr)); + tree gnu_ref = gnat_to_gnu_entity (Original_Record_Component (gnat_discr), NULL_TREE, false); @@ -3328,28 +3302,59 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } } - /* Add the fields into the record type and finish it up. */ - components_to_record (Component_List (record_definition), gnat_entity, - gnu_field_list, gnu_type, packed, definition, - false, all_rep, is_unchecked_union, artificial_p, - debug_info_p, false, - all_rep ? NULL_TREE : bitsize_zero_node, NULL); + /* If this is a derived type with discriminants and these discriminants + affect the initial shape it has inherited, factor them in. But for + an Unchecked_Union (it must be an Itype), just process the type. */ + if (has_discr + && !is_extension + && !Has_Record_Rep_Clause (gnat_entity) + && Stored_Constraint (gnat_entity) != No_Elist + && (gnat_parent_type = Underlying_Type (Etype (gnat_entity))) + && Is_Record_Type (gnat_parent_type) + && !Is_Unchecked_Union (gnat_parent_type)) + { + tree gnu_parent_type + = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type)); + + if (TYPE_IS_PADDING_P (gnu_parent_type)) + gnu_parent_type = TREE_TYPE (TYPE_FIELDS (gnu_parent_type)); + + vec gnu_subst_list + = build_subst_list (gnat_entity, gnat_parent_type, definition); + + /* Set the layout of the type to match that of the parent type, + doing required substitutions. */ + copy_and_substitute_in_layout (gnat_entity, gnat_parent_type, + gnu_type, gnu_parent_type, + gnu_subst_list, debug_info_p); + } + else + { + /* Add the fields into the record type and finish it up. */ + components_to_record (Component_List (record_definition), + gnat_entity, gnu_field_list, gnu_type, + packed, definition, false, all_rep, + is_unchecked_union, artificial_p, + debug_info_p, false, + all_rep ? NULL_TREE : bitsize_zero_node, + NULL); + + /* If there are entities in the chain corresponding to components + that we did not elaborate, ensure we elaborate their types if + they are Itypes. */ + for (gnat_temp = First_Entity (gnat_entity); + Present (gnat_temp); + gnat_temp = Next_Entity (gnat_temp)) + if ((Ekind (gnat_temp) == E_Component + || Ekind (gnat_temp) == E_Discriminant) + && Is_Itype (Etype (gnat_temp)) + && !present_gnu_tree (gnat_temp)) + gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false); + } /* Fill in locations of fields. */ annotate_rep (gnat_entity, gnu_type); - /* If there are any entities in the chain corresponding to components - that we did not elaborate, ensure we elaborate their types if they - are Itypes. */ - for (gnat_temp = First_Entity (gnat_entity); - Present (gnat_temp); - gnat_temp = Next_Entity (gnat_temp)) - if ((Ekind (gnat_temp) == E_Component - || Ekind (gnat_temp) == E_Discriminant) - && Is_Itype (Etype (gnat_temp)) - && !present_gnu_tree (gnat_temp)) - gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false); - /* If this is a record type associated with an exception definition, equate its fields to those of the standard exception type. This will make it possible to convert between them. */ @@ -3403,7 +3408,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else { Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity); - tree gnu_base_type; if (!definition) { @@ -3411,7 +3415,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) this_deferred = true; } - gnu_base_type + tree gnu_base_type = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type)); if (present_gnu_tree (gnat_entity)) @@ -3436,24 +3440,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* When the subtype has discriminants and these discriminants affect the initial shape it has inherited, factor them in. But for an - Unchecked_Union (it must be an Itype), just return the type. - We can't just test Is_Constrained because private subtypes without - discriminants of types with discriminants with default expressions - are Is_Constrained but aren't constrained! */ - if (IN (Ekind (gnat_base_type), Record_Kind) - && !Is_Unchecked_Union (gnat_base_type) + Unchecked_Union (it must be an Itype), just return the type. */ + if (Has_Discriminants (gnat_entity) + && Stored_Constraint (gnat_entity) != No_Elist && !Is_For_Access_Subtype (gnat_entity) - && Has_Discriminants (gnat_entity) - && Is_Constrained (gnat_entity) - && Stored_Constraint (gnat_entity) != No_Elist) + && Is_Record_Type (gnat_base_type) + && !Is_Unchecked_Union (gnat_base_type)) { vec gnu_subst_list = build_subst_list (gnat_entity, gnat_base_type, definition); - tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part; - tree gnu_pos_list, gnu_field_list = NULL_TREE; - bool selected_variant = false, all_constant_pos = true; - Entity_Id gnat_field; - vec gnu_variant_list; + tree gnu_unpad_base_type; gnu_type = make_node (RECORD_TYPE); TYPE_NAME (gnu_type) = gnu_entity_name; @@ -3464,8 +3460,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) = 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 - match that of the old one, doing required substitutions. */ + /* Set the size, alignment and alias set of the type to match + those of the base type, doing required substitutions. */ copy_and_substitute_in_size (gnu_type, gnu_base_type, gnu_subst_list); @@ -3474,265 +3470,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) else gnu_unpad_base_type = gnu_base_type; - /* Look for REP and variant parts in the base type. */ - gnu_rep_part = get_rep_part (gnu_unpad_base_type); - gnu_variant_part = get_variant_part (gnu_unpad_base_type); - - /* If there is a variant part, we must compute whether the - constraints statically select a particular variant. If - so, we simply drop the qualified union and flatten the - list of fields. Otherwise we'll build a new qualified - union for the variants that are still relevant. */ - if (gnu_variant_part) - { - variant_desc *v; - unsigned int i; - - gnu_variant_list - = build_variant_list (TREE_TYPE (gnu_variant_part), - gnu_subst_list, - vNULL); - - /* If all the qualifiers are unconditionally true, the - innermost variant is statically selected. */ - selected_variant = true; - FOR_EACH_VEC_ELT (gnu_variant_list, i, v) - if (!integer_onep (v->qual)) - { - selected_variant = false; - break; - } - - /* Otherwise, create the new variants. */ - if (!selected_variant) - FOR_EACH_VEC_ELT (gnu_variant_list, i, v) - { - tree old_variant = v->type; - tree new_variant = make_node (RECORD_TYPE); - tree suffix - = concat_name (DECL_NAME (gnu_variant_part), - IDENTIFIER_POINTER - (DECL_NAME (v->field))); - 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; - } - } - else - { - gnu_variant_list.create (0); - selected_variant = false; - } - - /* Make a list of fields and their position in the base type. */ - gnu_pos_list - = build_position_list (gnu_unpad_base_type, - gnu_variant_list.exists () - && !selected_variant, - size_zero_node, bitsize_zero_node, - BIGGEST_ALIGNMENT, NULL_TREE); - - /* Now go down every component in the subtype and compute its - size and position from those of the component in the base - type and from the constraints of the subtype. */ - for (gnat_field = First_Entity (gnat_entity); - Present (gnat_field); - gnat_field = Next_Entity (gnat_field)) - if ((Ekind (gnat_field) == E_Component - || Ekind (gnat_field) == E_Discriminant) - && !(Present (Corresponding_Discriminant (gnat_field)) - && Is_Tagged_Type (gnat_base_type)) - && Underlying_Type - (Scope (Original_Record_Component (gnat_field))) - == gnat_base_type) - { - Name_Id gnat_name = Chars (gnat_field); - Entity_Id gnat_old_field - = Original_Record_Component (gnat_field); - tree gnu_old_field - = gnat_to_gnu_field_decl (gnat_old_field); - tree gnu_context = DECL_CONTEXT (gnu_old_field); - tree gnu_field, gnu_field_type, gnu_size, gnu_pos; - tree gnu_cont_type, gnu_last = NULL_TREE; - - /* If the type is the same, retrieve the GCC type from the - old field to take into account possible adjustments. */ - if (Etype (gnat_field) == Etype (gnat_old_field)) - gnu_field_type = TREE_TYPE (gnu_old_field); - else - gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); - - /* If there was a component clause, the field types must be - the same for the type and subtype, so copy the data from - the old field to avoid recomputation here. Also if the - field is justified modular and the optimization in - gnat_to_gnu_field was applied. */ - if (Present (Component_Clause (gnat_old_field)) - || (TREE_CODE (gnu_field_type) == RECORD_TYPE - && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) - && TREE_TYPE (TYPE_FIELDS (gnu_field_type)) - == TREE_TYPE (gnu_old_field))) - { - gnu_size = DECL_SIZE (gnu_old_field); - gnu_field_type = TREE_TYPE (gnu_old_field); - } - - /* If the old field was packed and of constant size, we - have to get the old size here, as it might differ from - what the Etype conveys and the latter might overlap - onto the following field. Try to arrange the type for - possible better packing along the way. */ - else if (DECL_PACKED (gnu_old_field) - && TREE_CODE (DECL_SIZE (gnu_old_field)) - == INTEGER_CST) - { - gnu_size = DECL_SIZE (gnu_old_field); - if (RECORD_OR_UNION_TYPE_P (gnu_field_type) - && !TYPE_FAT_POINTER_P (gnu_field_type) - && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))) - gnu_field_type - = make_packable_type (gnu_field_type, true); - } - - else - gnu_size = TYPE_SIZE (gnu_field_type); - - /* If the context of the old field is the base type or its - REP part (if any), put the field directly in the new - type; otherwise look up the context in the variant list - and put the field either in the new type if there is a - selected variant or in one of the new variants. */ - if (gnu_context == gnu_unpad_base_type - || (gnu_rep_part - && gnu_context == TREE_TYPE (gnu_rep_part))) - gnu_cont_type = gnu_type; - else - { - variant_desc *v; - unsigned int i; - tree rep_part; - - FOR_EACH_VEC_ELT (gnu_variant_list, i, v) - if (gnu_context == v->type - || ((rep_part = get_rep_part (v->type)) - && gnu_context == TREE_TYPE (rep_part))) - break; - if (v) - { - if (selected_variant) - gnu_cont_type = gnu_type; - else - gnu_cont_type = v->new_type; - } - else - /* The front-end may pass us "ghost" components if - it fails to recognize that a constrained subtype - is statically constrained. Discard them. */ - continue; - } - - /* Now create the new field modeled on the old one. */ - gnu_field - = create_field_decl_from (gnu_old_field, gnu_field_type, - gnu_cont_type, gnu_size, - gnu_pos_list, gnu_subst_list); - gnu_pos = DECL_FIELD_OFFSET (gnu_field); - - /* Put it in one of the new variants directly. */ - if (gnu_cont_type != gnu_type) - { - DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type); - TYPE_FIELDS (gnu_cont_type) = gnu_field; - } - - /* To match the layout crafted in components_to_record, - if this is the _Tag or _Parent field, put it before - any other fields. */ - else if (gnat_name == Name_uTag - || gnat_name == Name_uParent) - gnu_field_list = chainon (gnu_field_list, gnu_field); - - /* Similarly, if this is the _Controller field, put - it before the other fields except for the _Tag or - _Parent field. */ - else if (gnat_name == Name_uController && gnu_last) - { - DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last); - DECL_CHAIN (gnu_last) = gnu_field; - } - - /* Otherwise, if this is a regular field, put it after - the other fields. */ - else - { - DECL_CHAIN (gnu_field) = gnu_field_list; - gnu_field_list = gnu_field; - if (!gnu_last) - gnu_last = gnu_field; - if (TREE_CODE (gnu_pos) != INTEGER_CST) - all_constant_pos = false; - } - - save_gnu_tree (gnat_field, gnu_field, false); - } - - /* If there is a variant list, a selected variant and the fields - all have a constant position, put them in order of increasing - position to match that of constant CONSTRUCTORs. Likewise if - there is no variant list but a REP part, since the latter has - been flattened in the process. */ - if (((gnu_variant_list.exists () && selected_variant) - || (!gnu_variant_list.exists () && gnu_rep_part)) - && all_constant_pos) - { - const int len = list_length (gnu_field_list); - tree *field_arr = XALLOCAVEC (tree, len), t; - int i; - - for (t = gnu_field_list, i = 0; t; t = DECL_CHAIN (t), i++) - field_arr[i] = t; - - qsort (field_arr, len, sizeof (tree), compare_field_bitpos); - - gnu_field_list = NULL_TREE; - for (i = 0; i < len; i++) - { - DECL_CHAIN (field_arr[i]) = gnu_field_list; - gnu_field_list = field_arr[i]; - } - } - - /* If there is a variant list and no selected variant, we need - to create the nest of variant parts from the old nest. */ - else if (gnu_variant_list.exists () && !selected_variant) - { - tree new_variant_part - = create_variant_part_from (gnu_variant_part, - gnu_variant_list, gnu_type, - gnu_pos_list, gnu_subst_list); - DECL_CHAIN (new_variant_part) = gnu_field_list; - gnu_field_list = new_variant_part; - } - - /* Now go through the entities again looking for Itypes that - we have not elaborated but should (e.g., Etypes of fields - that have Original_Components). */ - for (gnat_field = First_Entity (gnat_entity); - Present (gnat_field); gnat_field = Next_Entity (gnat_field)) - if ((Ekind (gnat_field) == E_Discriminant - || Ekind (gnat_field) == E_Component) - && !present_gnu_tree (Etype (gnat_field))) - gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false); - - /* We will output additional debug info manually below. */ - finish_record_type (gnu_type, nreverse (gnu_field_list), 2, - false); - compute_record_mode (gnu_type); + /* Set the layout of the type to match that of the base type, + doing required substitutions. We will output debug info + manually below so pass false as last argument. */ + copy_and_substitute_in_layout (gnat_entity, gnat_base_type, + gnu_type, gnu_unpad_base_type, + gnu_subst_list, false); /* Fill in locations of fields. */ annotate_rep (gnat_entity, gnu_type); @@ -3772,9 +3515,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) true, debug_info_p, NULL, gnat_entity); } - - gnu_variant_list.release (); - gnu_subst_list.release (); } /* Otherwise, go down all the components in the new type and make @@ -7410,17 +7150,6 @@ field_is_artificial (tree field) return false; } -/* Return true if FIELD is a non-artificial aliased field. */ - -static bool -field_is_aliased (tree field) -{ - if (field_is_artificial (field)) - return false; - - return DECL_ALIASED_P (field); -} - /* Return true if FIELD is a non-artificial field with self-referential size. */ @@ -7655,7 +7384,7 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, /* And record information for the final layout. */ if (field_has_self_size (gnu_field)) has_self_field = true; - else if (has_self_field && field_is_aliased (gnu_field)) + else if (has_self_field && DECL_ALIASED_P (gnu_field)) has_aliased_after_self_field = true; } } @@ -8003,7 +7732,7 @@ components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type, DECL_FIELD_OFFSET (gnu_field) = size_zero_node; SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT); DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node; - if (field_is_aliased (gnu_field)) + if (DECL_ALIASED_P (gnu_field)) SET_TYPE_ALIGN (gnu_record_type, MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (TREE_TYPE (gnu_field)))); @@ -8505,19 +8234,22 @@ purpose_member_field (const_tree elem, tree list) static void annotate_rep (Entity_Id gnat_entity, tree gnu_type) { - Entity_Id gnat_field; - tree gnu_list; + /* For an extension, the inherited components have not been translated because + they are fetched from the _Parent component on the fly. */ + const bool is_extension + = Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity); /* We operate by first making a list of all fields and their position (we can get the size easily) and then update all the sizes in the tree. */ - gnu_list + tree gnu_list = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node, BIGGEST_ALIGNMENT, NULL_TREE); - for (gnat_field = First_Entity (gnat_entity); + for (Entity_Id gnat_field = First_Entity (gnat_entity); Present (gnat_field); gnat_field = Next_Entity (gnat_field)) - if (Ekind (gnat_field) == E_Component + if ((Ekind (gnat_field) == E_Component + && (is_extension || present_gnu_tree (gnat_field))) || (Ekind (gnat_field) == E_Discriminant && !Is_Unchecked_Union (Scope (gnat_field)))) { @@ -8564,7 +8296,7 @@ annotate_rep (Entity_Id gnat_entity, tree gnu_type) Set_Esize (gnat_field, annotate_value (DECL_SIZE (TREE_PURPOSE (t)))); } - else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity)) + else if (is_extension) { /* If there is no entry, this is an inherited component whose position is the same as in the parent type. */ @@ -8665,7 +8397,7 @@ build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition) (Node (gnat_constr), gnat_subtype, get_entity_char (gnat_discrim), definition, true, false)); - subst_pair s = {gnu_field, replacement}; + subst_pair s = { gnu_field, replacement }; gnu_list.safe_push (s); } @@ -8699,7 +8431,7 @@ build_variant_list (tree qual_union_type, vec subst_list, if (!integer_zerop (qual)) { tree variant_type = TREE_TYPE (gnu_field), variant_subpart; - variant_desc v = {variant_type, gnu_field, qual, NULL_TREE}; + variant_desc v = { variant_type, gnu_field, qual, NULL_TREE }; gnu_list.safe_push (v); @@ -9350,13 +9082,14 @@ get_variant_part (tree record_type) the list of variants to be used and RECORD_TYPE is the type of the parent. POS_LIST is a position list describing the layout of fields present in OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this - layout. */ + layout. DEBUG_INFO_P is true if we need to write debug information. */ static tree create_variant_part_from (tree old_variant_part, vec variant_list, tree record_type, tree pos_list, - vec subst_list) + vec subst_list, + bool debug_info_p) { tree offset = DECL_FIELD_OFFSET (old_variant_part); tree old_union_type = TREE_TYPE (old_variant_part); @@ -9374,7 +9107,9 @@ create_variant_part_from (tree old_variant_part, /* If the position of the variant part is constant, subtract it from the size of the type of the parent to get the new size. This manual CSE reduces the code size when not optimizing. */ - if (TREE_CODE (offset) == INTEGER_CST) + if (TREE_CODE (offset) == INTEGER_CST + && TYPE_SIZE (record_type) + && TYPE_SIZE_UNIT (record_type)) { tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part); tree first_bit = bit_from_pos (offset, bitpos); @@ -9414,17 +9149,17 @@ create_variant_part_from (tree old_variant_part, { tree new_variant_subpart = create_variant_part_from (old_variant_subpart, variant_list, - new_variant, pos_list, subst_list); + new_variant, pos_list, subst_list, + debug_info_p); DECL_CHAIN (new_variant_subpart) = field_list; field_list = new_variant_subpart; } - /* Finish up the new variant and create the field. No need for debug - info thanks to the XVS type. */ - finish_record_type (new_variant, nreverse (field_list), 2, false); + /* Finish up the new variant and create the field. */ + finish_record_type (new_variant, nreverse (field_list), 2, debug_info_p); compute_record_mode (new_variant); - create_type_decl (TYPE_NAME (new_variant), new_variant, true, false, - Empty); + create_type_decl (TYPE_NAME (new_variant), new_variant, true, + debug_info_p, Empty); new_field = create_field_decl_from (old_field, new_variant, new_union_type, @@ -9436,13 +9171,13 @@ create_variant_part_from (tree old_variant_part, union_field_list = new_field; } - /* Finish up the union type and create the variant part. No need for debug - info thanks to the XVS type. Note that we don't reverse the field list - because VARIANT_LIST has been traversed in reverse order. */ - finish_record_type (new_union_type, union_field_list, 2, false); + /* Finish up the union type and create the variant part. Note that we don't + reverse the field list because VARIANT_LIST has been traversed in reverse + order. */ + finish_record_type (new_union_type, union_field_list, 2, debug_info_p); compute_record_mode (new_union_type); - create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, false, - Empty); + create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, + debug_info_p, Empty); new_variant_part = create_field_decl_from (old_variant_part, new_union_type, record_type, @@ -9509,6 +9244,294 @@ copy_and_substitute_in_size (tree new_type, tree old_type, TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type)); } +/* Return true if DISC is a stored discriminant of RECORD_TYPE. */ + +static inline bool +is_stored_discriminant (Entity_Id discr, Entity_Id record_type) +{ + if (Is_Tagged_Type (record_type)) + return No (Corresponding_Discriminant (discr)); + else if (Ekind (record_type) == E_Record_Type) + return Original_Record_Component (discr) == discr; + else + return true; +} + +/* Copy the layout from {GNAT,GNU}_OLD_TYPE to {GNAT,GNU}_NEW_TYPE, which are + both record types, after applying the substitutions described in SUBST_LIST. + DEBUG_INFO_P is true if we need to write debug information for NEW_TYPE. */ + +static void +copy_and_substitute_in_layout (Entity_Id gnat_new_type, + Entity_Id gnat_old_type, + tree gnu_new_type, + tree gnu_old_type, + vec gnu_subst_list, + bool debug_info_p) +{ + const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype); + tree gnu_field_list = NULL_TREE; + bool selected_variant, all_constant_pos = true; + vec gnu_variant_list; + + /* Look for REP and variant parts in the old type. */ + tree gnu_rep_part = get_rep_part (gnu_old_type); + tree gnu_variant_part = get_variant_part (gnu_old_type); + + /* If there is a variant part, we must compute whether the constraints + statically select a particular variant. If so, we simply drop the + qualified union and flatten the list of fields. Otherwise we will + build a new qualified union for the variants that are still relevant. */ + if (gnu_variant_part) + { + variant_desc *v; + unsigned int i; + + gnu_variant_list = build_variant_list (TREE_TYPE (gnu_variant_part), + gnu_subst_list, vNULL); + + /* If all the qualifiers are unconditionally true, the innermost variant + is statically selected. */ + selected_variant = true; + FOR_EACH_VEC_ELT (gnu_variant_list, i, v) + if (!integer_onep (v->qual)) + { + selected_variant = false; + break; + } + + /* Otherwise, create the new variants. */ + if (!selected_variant) + FOR_EACH_VEC_ELT (gnu_variant_list, i, v) + { + tree old_variant = v->type; + tree new_variant = make_node (RECORD_TYPE); + tree suffix + = concat_name (DECL_NAME (gnu_variant_part), + IDENTIFIER_POINTER (DECL_NAME (v->field))); + TYPE_NAME (new_variant) + = concat_name (TYPE_NAME (gnu_new_type), + IDENTIFIER_POINTER (suffix)); + TYPE_REVERSE_STORAGE_ORDER (new_variant) + = TYPE_REVERSE_STORAGE_ORDER (gnu_new_type); + copy_and_substitute_in_size (new_variant, old_variant, + gnu_subst_list); + v->new_type = new_variant; + } + } + else + { + gnu_variant_list.create (0); + selected_variant = false; + } + + /* Make a list of fields and their position in the old type. */ + tree gnu_pos_list + = build_position_list (gnu_old_type, + gnu_variant_list.exists () && !selected_variant, + size_zero_node, bitsize_zero_node, + BIGGEST_ALIGNMENT, NULL_TREE); + + /* Now go down every component in the new type and compute its size and + position from those of the component in the old type and the stored + constraints of the new type. */ + Entity_Id gnat_field, gnat_old_field; + for (gnat_field = First_Entity (gnat_new_type); + Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || (Ekind (gnat_field) == E_Discriminant + && is_stored_discriminant (gnat_field, gnat_new_type))) + && (gnat_old_field = is_subtype + ? Original_Record_Component (gnat_field) + : Corresponding_Record_Component (gnat_field)) + && Underlying_Type (Scope (gnat_old_field)) == gnat_old_type + && present_gnu_tree (gnat_old_field)) + { + Name_Id gnat_name = Chars (gnat_field); + tree gnu_old_field = get_gnu_tree (gnat_old_field); + if (TREE_CODE (gnu_old_field) == COMPONENT_REF) + gnu_old_field = TREE_OPERAND (gnu_old_field, 1); + tree gnu_context = DECL_CONTEXT (gnu_old_field); + tree gnu_field, gnu_field_type, gnu_size, gnu_pos; + tree gnu_cont_type, gnu_last = NULL_TREE; + + /* If the type is the same, retrieve the GCC type from the + old field to take into account possible adjustments. */ + if (Etype (gnat_field) == Etype (gnat_old_field)) + gnu_field_type = TREE_TYPE (gnu_old_field); + else + gnu_field_type = gnat_to_gnu_type (Etype (gnat_field)); + + /* If there was a component clause, the field types must be the same + for the old and new types, so copy the data from the old field to + avoid recomputation here. Also if the field is justified modular + and the optimization in gnat_to_gnu_field was applied. */ + if (Present (Component_Clause (gnat_old_field)) + || (TREE_CODE (gnu_field_type) == RECORD_TYPE + && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type) + && TREE_TYPE (TYPE_FIELDS (gnu_field_type)) + == TREE_TYPE (gnu_old_field))) + { + gnu_size = DECL_SIZE (gnu_old_field); + gnu_field_type = TREE_TYPE (gnu_old_field); + } + + /* If the old field was packed and of constant size, we have to get the + old size here as it might differ from what the Etype conveys and the + latter might overlap with the following field. Try to arrange the + type for possible better packing along the way. */ + else if (DECL_PACKED (gnu_old_field) + && TREE_CODE (DECL_SIZE (gnu_old_field)) == INTEGER_CST) + { + gnu_size = DECL_SIZE (gnu_old_field); + if (RECORD_OR_UNION_TYPE_P (gnu_field_type) + && !TYPE_FAT_POINTER_P (gnu_field_type) + && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type))) + gnu_field_type = make_packable_type (gnu_field_type, true); + } + + else + gnu_size = TYPE_SIZE (gnu_field_type); + + /* If the context of the old field is the old type or its REP part, + put the field directly in the new type; otherwise look up the + context in the variant list and put the field either in the new + type if there is a selected variant or in one new variant. */ + if (gnu_context == gnu_old_type + || (gnu_rep_part && gnu_context == TREE_TYPE (gnu_rep_part))) + gnu_cont_type = gnu_new_type; + else + { + variant_desc *v; + unsigned int i; + tree rep_part; + + FOR_EACH_VEC_ELT (gnu_variant_list, i, v) + if (gnu_context == v->type + || ((rep_part = get_rep_part (v->type)) + && gnu_context == TREE_TYPE (rep_part))) + break; + + if (v) + gnu_cont_type = selected_variant ? gnu_new_type : v->new_type; + else + /* The front-end may pass us "ghost" components if it fails to + recognize that a constrain statically selects a particular + variant. Discard them. */ + continue; + } + + /* Now create the new field modeled on the old one. */ + gnu_field + = create_field_decl_from (gnu_old_field, gnu_field_type, + gnu_cont_type, gnu_size, + gnu_pos_list, gnu_subst_list); + gnu_pos = DECL_FIELD_OFFSET (gnu_field); + + /* If the context is a variant, put it in the new variant directly. */ + if (gnu_cont_type != gnu_new_type) + { + DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type); + TYPE_FIELDS (gnu_cont_type) = gnu_field; + } + + /* To match the layout crafted in components_to_record, if this is + the _Tag or _Parent field, put it before any other fields. */ + else if (gnat_name == Name_uTag || gnat_name == Name_uParent) + gnu_field_list = chainon (gnu_field_list, gnu_field); + + /* Similarly, if this is the _Controller field, put it before the + other fields except for the _Tag or _Parent field. */ + else if (gnat_name == Name_uController && gnu_last) + { + DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last); + DECL_CHAIN (gnu_last) = gnu_field; + } + + /* Otherwise, put it after the other fields. */ + else + { + DECL_CHAIN (gnu_field) = gnu_field_list; + gnu_field_list = gnu_field; + if (!gnu_last) + gnu_last = gnu_field; + if (TREE_CODE (gnu_pos) != INTEGER_CST) + all_constant_pos = false; + } + + /* For a stored discriminant in a derived type, replace the field. */ + if (!is_subtype && Ekind (gnat_field) == E_Discriminant) + { + tree gnu_ref = get_gnu_tree (gnat_field); + TREE_OPERAND (gnu_ref, 1) = gnu_field; + } + else + save_gnu_tree (gnat_field, gnu_field, false); + } + + /* If there is a variant list, a selected variant and the fields all have a + constant position, put them in order of increasing position to match that + of constant CONSTRUCTORs. Likewise if there is no variant list but a REP + part, since the latter has been flattened in the process. */ + if ((gnu_variant_list.exists () ? selected_variant : gnu_rep_part != NULL) + && all_constant_pos) + { + const int len = list_length (gnu_field_list); + tree *field_arr = XALLOCAVEC (tree, len), t = gnu_field_list; + + for (int i = 0; t; t = DECL_CHAIN (t), i++) + field_arr[i] = t; + + qsort (field_arr, len, sizeof (tree), compare_field_bitpos); + + gnu_field_list = NULL_TREE; + for (int i = 0; i < len; i++) + { + DECL_CHAIN (field_arr[i]) = gnu_field_list; + gnu_field_list = field_arr[i]; + } + } + + /* If there is a variant list and no selected variant, we need to create the + nest of variant parts from the old nest. */ + else if (gnu_variant_list.exists () && !selected_variant) + { + tree new_variant_part + = create_variant_part_from (gnu_variant_part, gnu_variant_list, + gnu_new_type, gnu_pos_list, + gnu_subst_list, debug_info_p); + DECL_CHAIN (new_variant_part) = gnu_field_list; + gnu_field_list = new_variant_part; + } + + gnu_variant_list.release (); + gnu_subst_list.release (); + + gnu_field_list = nreverse (gnu_field_list); + + /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE. + Otherwise sizes and alignment must be computed independently. */ + if (is_subtype) + { + finish_record_type (gnu_new_type, gnu_field_list, 2, debug_info_p); + compute_record_mode (gnu_new_type); + } + else + finish_record_type (gnu_new_type, gnu_field_list, 1, debug_info_p); + + /* Now go through the entities again looking for Itypes that we have not yet + elaborated (e.g. Etypes of fields that have Original_Components). */ + for (Entity_Id gnat_field = First_Entity (gnat_new_type); + Present (gnat_field); + gnat_field = Next_Entity (gnat_field)) + if ((Ekind (gnat_field) == E_Component + || Ekind (gnat_field) == E_Discriminant) + && Is_Itype (Etype (gnat_field)) + && !present_gnu_tree (Etype (gnat_field))) + gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false); +} + /* 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 @@ -9544,9 +9567,9 @@ associate_original_type_to_packed_array (tree gnu_type, Entity_Id gnat_entity) add_parallel_type (gnu_type, gnu_original_array_type); } -/* Given a type T, a FIELD_DECL F, and a replacement value R, return a - type with all size expressions that contain F in a PLACEHOLDER_EXPR - updated by replacing F with R. +/* Given a type T, a FIELD_DECL F, and a replacement value R, return an + equivalent type with adjusted size expressions where all occurrences + of references to F in a PLACEHOLDER_EXPR have been replaced by R. The function doesn't update the layout of the type, i.e. it assumes that the substitution is purely formal. That's why the replacement diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 73c2f51f801..fcbf86e8cc4 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -18147,6 +18147,7 @@ package body Sem_Ch3 is if not Is_Tagged then Set_Original_Record_Component (New_C, New_C); + Set_Corresponding_Record_Component (New_C, Old_C); end if; -- Set the proper type of an access discriminant @@ -18245,6 +18246,7 @@ package body Sem_Ch3 is and then Original_Record_Component (Corr_Discrim) = Old_C then Set_Original_Record_Component (Discrim, New_C); + Set_Corresponding_Record_Component (Discrim, Empty); end if; Next_Discriminant (Discrim); -- 2.30.2