diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 76 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch7.adb | 30 |
4 files changed, 112 insertions, 33 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5667112..d91c4b3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2017-09-06 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch7.adb (Has_Referencer): Move up and expand comment + explaining the test used to detect inlining. Use same test + in second occurrence. + (Analyze_Package_Body_Helper): Minor formatting fixes. + +2017-09-06 Ed Schonberg <schonberg@adacore.com> + + * exp_ch4.adb (Handle_Changed_Representation): For an untagged + derived type with a mixture of renamed and constrained parent + discriminants, the constraint for the target must obtain the + discriminant values from both the operand and from the stored + constraint for it, given that the constrained discriminants are + not visible in the object. + * exp_ch5.adb (Make_Field_Assign): The type of the right-hand + side may be derived from that of the left-hand side (as in the + case of an assignment with a change of representation) so the + discriminant to be used in the retrieval of the value of the + component must be the entity in the type of the right-hand side. + 2017-09-06 Hristian Kirtchev <kirtchev@adacore.com> * sem_ch3.adb, sem_ch7.adb, sem_util.adb, g-debpoo.adb, sem_ch4.adb, @@ -11,7 +32,6 @@ * sem_prag.adb: Update description of Eliminate. - 2017-09-06 Ed Schonberg <schonberg@adacore.com> * sem_attr.adb (Analyze_Attribute, case 'Loop_Entry): Handle @@ -179,7 +199,6 @@ * fe.h (Eliminate_Error_Msg): Remove. - 2017-09-05 Richard Sandiford <richard.sandiford@linaro.org> * gcc-interface/utils.c (make_packable_type): Update call to diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index bda0efe..7f64cde 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -10627,7 +10627,6 @@ package body Exp_Ch4 is Temp : Entity_Id; Decl : Node_Id; Odef : Node_Id; - Disc : Node_Id; N_Ix : Node_Id; Cons : List_Id; @@ -10657,22 +10656,69 @@ package body Exp_Ch4 is if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then - Disc := First_Discriminant (Operand_Type); - if Disc /= First_Stored_Discriminant (Operand_Type) then - Disc := First_Stored_Discriminant (Operand_Type); - end if; + -- A change of representation can only apply to untagged + -- types. We need to build the constraint that applies to + -- the target type, using the constraints of the operand. + -- The analysis is complicated if there are both inherited + -- discriminants and constrained discriminants. + -- We iterate over the discriminants of the target, and + -- find the discriminant of the same name: - Cons := New_List; - while Present (Disc) loop - Append_To (Cons, - Make_Selected_Component (Loc, - Prefix => - Duplicate_Subexpr_Move_Checks (Operand), - Selector_Name => - Make_Identifier (Loc, Chars (Disc)))); - Next_Discriminant (Disc); - end loop; + -- a) If there is a corresponding discriminant in the object + -- then the value is a selected component of the operand. + + -- b) Otherwise the value of a constrained discriminant is + -- found in the stored constraint of the operand. + + declare + Stored : constant Elist_Id := + Stored_Constraint (Operand_Type); + + Elmt : Elmt_Id; + + Disc_O : Entity_Id; + -- Discriminant of the operand type. Its value in the + -- the object is captured in a selected component. + + Disc_S : Entity_Id; + -- Stored discriminant of the operand. If present, it + -- corresponds to a constrained discriminant of the + -- parent type. + + Disc_T : Entity_Id; + -- Discriminant of the target type + + begin + Disc_T := First_Discriminant (Target_Type); + Disc_O := First_Discriminant (Operand_Type); + Disc_S := First_Stored_Discriminant (Operand_Type); + + if Present (Stored) then + Elmt := First_Elmt (Stored); + end if; + + Cons := New_List; + while Present (Disc_T) loop + if Present (Disc_O) + and then Chars (Disc_T) = Chars (Disc_O) + then + Append_To (Cons, + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (Operand), + Selector_Name => + Make_Identifier (Loc, Chars (Disc_O)))); + Next_Discriminant (Disc_O); + + elsif Present (Disc_S) then + Append_To (Cons, New_Copy_Tree (Node (Elmt))); + Next_Elmt (Elmt); + end if; + + Next_Discriminant (Disc_T); + end loop; + end; elsif Is_Array_Type (Operand_Type) then N_Ix := First_Index (Target_Type); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 5267024b..59af6ab 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -1448,9 +1448,21 @@ package body Exp_Ch5 is U_U : Boolean := False) return Node_Id is A : Node_Id; + Disc : Entity_Id; Expr : Node_Id; begin + + -- The discriminant entity to be used in the retrieval below must + -- be one in the corresponding type, given that the assignment + -- may be between derived and parent types. + + if Is_Derived_Type (Etype (Rhs)) then + Disc := Find_Component (R_Typ, C); + else + Disc := C; + end if; + -- In the case of an Unchecked_Union, use the discriminant -- constraint value as on the right-hand side of the assignment. @@ -1463,7 +1475,7 @@ package body Exp_Ch5 is Expr := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Rhs), - Selector_Name => New_Occurrence_Of (C, Loc)); + Selector_Name => New_Occurrence_Of (Disc, Loc)); end if; A := diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 1ec3395..e62d7e1 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -392,6 +392,13 @@ package body Sem_Ch7 is -- An inlined subprogram body acts as a referencer + -- Note that we test Has_Pragma_Inline here in addition + -- to Is_Inlined. We are doing this for a client, since + -- we are computing which entities should be public, and + -- it is the client who will decide if actual inlining + -- should occur, so we need to catch all cases where the + -- subprogram may be inlined by the client. + if Is_Inlined (Decl_Id) or else Has_Pragma_Inline (Decl_Id) then @@ -413,18 +420,13 @@ package body Sem_Ch7 is else Decl_Id := Defining_Entity (Decl); - -- An inlined body acts as a referencer. Note that an - -- inlined subprogram remains Is_Public as gigi requires - -- the flag to be set. - - -- Note that we test Has_Pragma_Inline here rather than - -- Is_Inlined. We are compiling this for a client, and - -- it is the client who will decide if actual inlining - -- should occur, so we need to assume that the procedure - -- could be inlined for the purpose of accessing global - -- entities. + -- An inlined body acts as a referencer, see above. Note + -- that an inlined subprogram remains Is_Public as gigi + -- requires the flag to be set. - if Has_Pragma_Inline (Decl_Id) then + if Is_Inlined (Decl_Id) + or else Has_Pragma_Inline (Decl_Id) + then if Top_Level and then not Contains_Subprograms_Refs (Decl) then @@ -915,11 +917,11 @@ package body Sem_Ch7 is -- down the number of global symbols that do not neet public visibility -- as this has two beneficial effects: -- (1) It makes the compilation process more efficient. - -- (2) It gives the code generatormore freedom to optimize within each + -- (2) It gives the code generator more leeway to optimize within each -- unit, especially subprograms. - -- This is done only for top level library packages or child units as - -- the algorithm does a top down traversal of the package body. + -- This is done only for top-level library packages or child units as + -- the algorithm does a top-down traversal of the package body. if (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) and then not Is_Generic_Unit (Spec_Id) |