From: Arnaud Charlet Date: Mon, 2 May 2016 09:08:44 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=3ba1a9eb6ec22706bdb084db2f1ab31a32d4dde8;p=gcc.git [multiple changes] 2016-05-02 Ed Schonberg * 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 * 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 * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 590ecee24b8..2722c7dfd66 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2016-05-02 Ed Schonberg + + * 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 + + * 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 + + * 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 * 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 f3a6f69f250..6cac7211ec0 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 3a0fcbe60fe..d071f02e737 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 719e4ed0e98..99827081d0b 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