[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

gcc/ada/ChangeLog

+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

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

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);
 

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