+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
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
-- 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);
-- 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
projects / thirdparty / gcc.git / commitdiff
