diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2016-05-02 11:08:44 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2016-05-02 11:08:44 +0200 |
commit | 3ba1a9eb6ec22706bdb084db2f1ab31a32d4dde8 (patch) | |
tree | 8f9db14e43b5357d9daae884d4381ba2c6a6b63a /gcc | |
parent | fc1c2d0482260c80cfe8363f96ace9a57f10cbf4 (diff) | |
download | gcc-3ba1a9eb6ec22706bdb084db2f1ab31a32d4dde8.zip gcc-3ba1a9eb6ec22706bdb084db2f1ab31a32d4dde8.tar.gz gcc-3ba1a9eb6ec22706bdb084db2f1ab31a32d4dde8.tar.bz2 |
[multiple changes]
2016-05-02 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Allocator): If the expression does not
have a subtype indication and the type is an unconstrained tagged
type with defaulted discriminants, create an explicit constraint
for it during analysis to prevent out-of-order freezing actions
on generated classwide types.
2016-05-02 Javier Miranda <miranda@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement):
In the runtime check that ensures that the tags of source an
target match, add missing displacement of the pointer to the
objects if they cover interface types.
2016-05-02 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Old): Do not use
base type for attribute when type is discrete: transformation
is not needed for such types, and leads to spurious errors if
the context is a case construct.
From-SVN: r235709
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
-rw-r--r-- | gcc/ada/exp_ch5.adb | 60 | ||||
-rw-r--r-- | gcc/ada/sem_attr.adb | 10 | ||||
-rw-r--r-- | gcc/ada/sem_ch4.adb | 39 |
4 files changed, 115 insertions, 16 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 590ecee..2722c7d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2016-05-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Analyze_Allocator): If the expression does not + have a subtype indication and the type is an unconstrained tagged + type with defaulted discriminants, create an explicit constraint + for it during analysis to prevent out-of-order freezing actions + on generated classwide types. + +2016-05-02 Javier Miranda <miranda@adacore.com> + + * exp_ch5.adb (Expand_N_Assignment_Statement): + In the runtime check that ensures that the tags of source an + target match, add missing displacement of the pointer to the + objects if they cover interface types. + +2016-05-02 Ed Schonberg <schonberg@adacore.com> + + * sem_attr.adb (Analyze_Attribute, case 'Old): Do not use + base type for attribute when type is discrete: transformation + is not needed for such types, and leads to spurious errors if + the context is a case construct. + 2016-05-02 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (elaborate_reference_1): Do not bother about diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index f3a6f69..6cac721 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2240,21 +2240,51 @@ package body Exp_Ch5 is and then Is_Tagged_Type (Typ) and then Is_Tagged_Type (Underlying_Type (Etype (Rhs))) then - Append_To (L, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Lhs), - Selector_Name => - Make_Identifier (Loc, Name_uTag)), - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => Duplicate_Subexpr (Rhs), - Selector_Name => - Make_Identifier (Loc, Name_uTag))), - Reason => CE_Tag_Check_Failed)); + declare + Lhs_Tag : Node_Id; + Rhs_Tag : Node_Id; + + begin + if not Is_Interface (Typ) then + Lhs_Tag := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Selector_Name => + Make_Identifier (Loc, Name_uTag)); + Rhs_Tag := + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Selector_Name => + Make_Identifier (Loc, Name_uTag)); + else + -- Displace the pointer to the base of the objects + -- applying 'Address, which is later expanded into + -- a call to RE_Base_Address. + + Lhs_Tag := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Lhs), + Attribute_Name => Name_Address))); + Rhs_Tag := + Make_Explicit_Dereference (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Duplicate_Subexpr (Rhs), + Attribute_Name => Name_Address))); + end if; + + Append_To (L, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => Lhs_Tag, + Right_Opnd => Rhs_Tag), + Reason => CE_Tag_Check_Failed)); + end; end if; declare diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3a0fcbe..d071f02 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4975,8 +4975,16 @@ package body Sem_Attr is -- and does not suffer from the out-of-order issue described -- above. Thus, this expansion is skipped in SPARK mode. + -- THe expansion is not relevant for discrete types, that will + -- not generate extra declarations, and where use of the base + -- type may lead to spurious errors if context is a case. + if not GNATprove_Mode then - Pref_Typ := Base_Type (Pref_Typ); + + if not Is_Discrete_Type (Pref_Typ) then + Pref_Typ := Base_Type (Pref_Typ); + end if; + Set_Etype (N, Pref_Typ); Set_Etype (P, Pref_Typ); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 719e4ed..9982708 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -583,6 +583,45 @@ package body Sem_Ch4 is -- so that the bounds of the subtype indication are attached to -- the tree in case the allocator is inside a generic unit. + -- Finally, if there is no subtype indication and the type is + -- a tagged unconstrained type with discriminants, the designated + -- object is constrained by their default values, and it is + -- simplest to introduce an explicit constraint now. In some cases + -- this is done during expansion, but freeze actions are certain + -- to be emitted in the proper order if constraint is explicit. + + if Is_Entity_Name (E) and then Expander_Active then + Find_Type (E); + Type_Id := Entity (E); + + if Is_Tagged_Type (Type_Id) + and then Has_Discriminants (Type_Id) + and then not Is_Constrained (Type_Id) + and then Present + (Discriminant_Default_Value (First_Discriminant (Type_Id))) + then + declare + Loc : constant Source_Ptr := Sloc (E); + Discr : Entity_Id := First_Discriminant (Type_Id); + Constr : constant List_Id := New_List; + + begin + if Present (Discriminant_Default_Value (Discr)) then + while Present (Discr) loop + Append (Discriminant_Default_Value (Discr), Constr); + Next_Discriminant (Discr); + end loop; + + Rewrite (E, Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Type_Id, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constr))); + end if; + end; + end if; + end if; + if Nkind (E) = N_Subtype_Indication then -- A constraint is only allowed for a composite type in Ada |