+2017-09-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch5.adb, freeze.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb:
+ Minor reformatting.
+
+2017-09-06 Justin Squirek <squirek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Modified Image
+ attribute cases (Rewrite_Object_Reference_Image): Created to
+ aid the rewriting of new-style 'Image attributes.
+ * sem_attr.adb (Analyze_Attribute): Modified Image attribute cases
+ (Check_Object_Reference_Image): Created to handle verification of
+ 'Image with object-references as prefixes.
+ * sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object):
+ Create predicate to identify cases where an 'Image attribute's
+ prefix applies to an object reference.
+
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* freeze.adb (Freeze_Entity): Do not generate a freeze
Exprs : constant List_Id := Expressions (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
+ procedure Rewrite_Object_Reference_Image
+ (Name : Name_Id;
+ Str_Typ : Entity_Id);
+ -- Rewrite an 'Image attribute applied to an object reference for
+ -- AI12-0012401 into an attribute applied to a type.
+
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
-- Rewrites a stream attribute for Read, Write or Output with the
-- procedure call. Pname is the entity for the procedure to call.
+ ------------------------------------
+ -- Rewrite_Object_Reference_Image --
+ ------------------------------------
+
+ procedure Rewrite_Object_Reference_Image
+ (Name : Name_Id;
+ Str_Typ : Entity_Id) is
+ begin
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Attribute_Name => Name,
+ Expressions => New_List (Relocate_Node (Pref))));
+
+ Analyze_And_Resolve (N, Str_Typ);
+ end Rewrite_Object_Reference_Image;
+
------------------------------
-- Rewrite_Stream_Proc_Call --
------------------------------
-- Image attribute is handled in separate unit Exp_Imgv
when Attribute_Image =>
+ if Is_Image_Applied_To_Object (Pref, Ptyp) then
+ Rewrite_Object_Reference_Image (Name_Image, Standard_String);
+ return;
+ end if;
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Attribute_Name => Name_Image,
- Expressions => New_List (Relocate_Node (Pref))));
-
- Analyze_And_Resolve (N, Standard_String);
+ Rewrite_Object_Reference_Image (Name_Image, Standard_String);
-----------
-- Input --
-- Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Image =>
+ if Is_Image_Applied_To_Object (Pref, Ptyp) then
+ Rewrite_Object_Reference_Image
+ (Name_Wide_Image, Standard_Wide_String);
+ return;
+ end if;
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
-- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Wide_Image =>
+ if Is_Image_Applied_To_Object (Pref, Ptyp) then
+ Rewrite_Object_Reference_Image
+ (Name_Wide_Wide_Image, Standard_Wide_Wide_String);
+ return;
+ end if;
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
-- Link this node to the tree to analyze it
- -- If the parent node is an expression with actions we link it
- -- to N since otherwise Force_Evaluation cannot identify if this
- -- node comes from the Expression and rejects generating the
- -- temporary.
+ -- If the parent node is an expression with actions we link it to
+ -- N since otherwise Force_Evaluation cannot identify if this node
+ -- comes from the Expression and rejects generating the temporary.
if Nkind (Parent (N)) = N_Expression_With_Actions then
Set_Parent (Op_Expr, N);
declare
Stored : constant Elist_Id :=
- Stored_Constraint (Operand_Type);
+ 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.
+ -- object is captured in a selected component.
Disc_S : Entity_Id;
-- Stored discriminant of the operand. If present, it
Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr_Move_Checks (Operand),
- Selector_Name =>
+ Selector_Name =>
Make_Identifier (Loc, Chars (Disc_O))));
Next_Discriminant (Disc_O);
Append_To (Cons,
Make_Range (Loc,
- Low_Bound =>
+ Low_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Duplicate_Subexpr_No_Checks
(Operand, Name_Req => True),
Attribute_Name => Name_First,
High_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Duplicate_Subexpr_No_Checks
(Operand, Name_Req => True),
Attribute_Name => Name_Last,
Odef :=
Make_Subtype_Indication (Loc,
Subtype_Mark => Odef,
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cons));
end if;
New_List (
Decl,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp, Loc),
+ Name => New_Occurrence_Of (Temp, Loc),
Expression => Relocate_Node (N))),
Suppress => All_Checks);
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.
+ -- 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);
if Stored_Constraint (R_Typ) /= No_Elist then
declare
- Discr_Val : Elmt_Id;
Assign : Node_Id;
+ Discr_Val : Elmt_Id;
begin
Discr_Val := First_Elmt (Stored_Constraint (R_Typ));
if Ekind (F) = E_Discriminant
and then Is_Completely_Hidden (F)
and then Present (Corresponding_Record_Component (F))
- and then (not Is_Entity_Name (Node (Discr_Val))
- or else Ekind (Entity (Node (Discr_Val)))
- /= E_Discriminant)
+ and then
+ (not Is_Entity_Name (Node (Discr_Val))
+ or else Ekind (Entity (Node (Discr_Val))) /=
+ E_Discriminant)
then
Assign :=
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
New_Occurrence_Of
(Corresponding_Record_Component (F), Loc)),
- Expression => New_Copy (Node ((Discr_Val))));
+ Expression => New_Copy (Node (Discr_Val)));
Set_Assignment_OK (Name (Assign));
Insert_Action (N, Assign);
Root_Type (Etype (Name (Ass)))
then
Error_Msg_NE
- ("tag-indeterminate expression "
- & " must have designated type& (RM 5.2 (6))",
+ ("tag-indeterminate expression must have designated "
+ & "type& (RM 5.2 (6))",
Call_Node, Root_Type (Etype (Name (Ass))));
else
Propagate_Tag (Name (Ass), Call_Node);
elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
Error_Msg_NE
- ("tag-indeterminate expression must have type&"
- & " (RM 5.2 (6))",
+ ("tag-indeterminate expression must have type & "
+ & "(RM 5.2 (6))",
Call_Node, Root_Type (Etype (Name (Ass))));
else
-- delayed in the parent, so these must also be captured now.
if Has_Delayed_Aspects (E)
- or else May_Inherit_Delayed_Rep_Aspects (E)
+ or else May_Inherit_Delayed_Rep_Aspects (E)
then
Analyze_Aspects_At_Freeze_Point (E);
end if;
Explode_Initialization_Compound_Statement (E);
end if;
- -- Do not generate a freeze node for a generic unit.
+ -- Do not generate a freeze node for a generic unit
if Is_Generic_Unit (E) then
Result := No_List;
function Get_Through_Renamings (E : Entity_Id) return Entity_Id is
begin
case Ekind (E) is
+
-- For subprograms we just need to check once if they are have a
-- Renamed_Entity, because Renamed_Entity is set transitively.
declare
Renamed : constant Entity_Id := Renamed_Object (Obj);
+
begin
if Present (Renamed) then
Obj := Get_Enclosing_Object (Renamed);
-- The renamed expression denotes a non-object,
-- e.g. function call, slicing of a function call,
-- pointer dereference, etc.
+
if No (Obj) then
return Empty;
end if;
procedure Check_Fixed_Point_Type_0;
-- Verify that prefix of attribute N is a fixed type and that
- -- no attribute expressions are present
+ -- no attribute expressions are present.
procedure Check_Floating_Point_Type;
-- Verify that prefix of attribute N is a float type
procedure Check_Floating_Point_Type_0;
-- Verify that prefix of attribute N is a float type and that
- -- no attribute expressions are present
+ -- no attribute expressions are present.
procedure Check_Floating_Point_Type_1;
-- Verify that prefix of attribute N is a float type and that
- -- exactly one attribute expression is present
+ -- exactly one attribute expression is present.
procedure Check_Floating_Point_Type_2;
-- Verify that prefix of attribute N is a float type and that
procedure Check_Object_Reference (P : Node_Id);
-- Check that P is an object reference
+ procedure Check_Object_Reference_Image (Str_Typ : Entity_Id);
+ -- Verify that the prefix of an image attribute....
+
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
end if;
end Check_Object_Reference;
+ ----------------------------------
+ -- Check_Object_Reference_Image --
+ ----------------------------------
+
+ procedure Check_Object_Reference_Image (Str_Typ : Entity_Id) is
+ begin
+ Check_E0;
+ Set_Etype (N, Str_Typ);
+
+ if not Is_Scalar_Type (P_Type)
+ or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
+ then
+ Error_Attr_P
+ ("prefix of % attribute must be scalar object name");
+ end if;
+
+ Check_Enum_Image;
+
+ -- Check restriction No_Fixed_IO
+
+ if Restriction_Check_Required (No_Fixed_IO)
+ and then Is_Fixed_Point_Type (P_Type)
+ then
+ Check_Restriction (No_Fixed_IO, P);
+ end if;
+ end Check_Object_Reference_Image;
+
----------------------------
-- Check_PolyORB_Attribute --
----------------------------
when Attribute_Image =>
Check_SPARK_05_Restriction_On_Attribute;
- -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img for
- -- scalar types, so that the prefix can be an object and not a type,
- -- and there is no need for an argument. Given the vote of confidence
- -- from the ARG, simplest is to transform this new usage of 'Image
- -- into a reference to 'Img.
-
- if Ada_Version > Ada_2005
- and then Is_Object_Reference (P)
- and then Is_Scalar_Type (P_Type)
- then
- if No (Expressions (N)) then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (P),
- Attribute_Name => Name_Img));
-
- -- If the attribute reference includes expressions, the only
- -- possible interpretation is as an indexing of the parameterless
- -- version of 'Image, so rewrite it accordingly.
-
- else
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (P),
- Attribute_Name => Name_Img),
- Expressions => Expressions (N)));
- end if;
-
- Analyze (N);
+ if Is_Image_Applied_To_Object (P, P_Type) then
+ Check_Object_Reference_Image (Standard_String);
return;
-
- else
- Check_Scalar_Type;
end if;
+ Check_Scalar_Type;
Set_Etype (N, Standard_String);
if Is_Real_Type (P_Type) then
---------
when Attribute_Img =>
- Check_E0;
- Set_Etype (N, Standard_String);
-
- if not Is_Scalar_Type (P_Type)
- or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
- then
- Error_Attr_P
- ("prefix of % attribute must be scalar object name");
- end if;
-
- Check_Enum_Image;
-
- -- Check restriction No_Fixed_IO
-
- if Restriction_Check_Required (No_Fixed_IO)
- and then Is_Fixed_Point_Type (P_Type)
- then
- Check_Restriction (No_Fixed_IO, P);
- end if;
+ Check_Object_Reference_Image (Standard_String);
-----------
-- Input --
when Attribute_Wide_Image =>
Check_SPARK_05_Restriction_On_Attribute;
+
+ if Is_Image_Applied_To_Object (P, P_Type) then
+ Check_Object_Reference_Image (Standard_Wide_String);
+ return;
+ end if;
+
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_String);
Check_E1;
---------------------
when Attribute_Wide_Wide_Image =>
+ if Is_Image_Applied_To_Object (P, P_Type) then
+ Check_Object_Reference_Image (Standard_Wide_Wide_String);
+ return;
+ end if;
+
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_Wide_String);
Check_E1;
N_Generic_Subprogram_Declaration);
end Is_Generic_Declaration_Or_Body;
+ --------------------------------
+ -- Is_Image_Applied_To_Object --
+ --------------------------------
+
+ function Is_Image_Applied_To_Object
+ (Prefix : Node_Id;
+ P_Typ : Entity_Id) return Boolean
+ is
+ begin
+ return Ada_Version > Ada_2005
+ and then Is_Object_Reference (Prefix)
+ and then Is_Scalar_Type (P_Typ);
+ end Is_Image_Applied_To_Object;
+
----------------------------
-- Is_Inherited_Operation --
----------------------------
Formal : Entity_Id;
begin
- -- Ada 2005 or later, and formals present
+ -- Ada 2005 or later, and formals present. The first formal must
+ -- be of type that supports prefix notation: a controlling argument,
+ -- a class-wide type, or an access to such.
if Ada_Version >= Ada_2005
and then Present (First_Formal (E))
and then No (Default_Value (First_Formal (E)))
- and then Is_Controlling_Formal (First_Formal (E))
+ and then (Is_Controlling_Formal (First_Formal (E))
+ or else Is_Class_Wide_Type (Etype (First_Formal (E)))
+ or else Is_Anonymous_Access_Type (Etype (First_Formal (E))))
then
Formal := Next_Formal (First_Formal (E));
while Present (Formal) loop
-- Determine whether arbitrary declaration Decl denotes a generic package,
-- a generic subprogram or a generic body.
+ function Is_Image_Applied_To_Object
+ (Prefix : Node_Id;
+ P_Typ : Entity_Id) return Boolean;
+ -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
+ -- can be applied to a given object-reference prefix (see AI12-00124-1).
+
+ -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img for
+ -- scalar types, so that the prefix can be an object and not a type,
+ -- and there is no need for an argument. Given the vote of confidence
+ -- from the ARG, simplest is to transform this new usage of 'Image
+ -- into a reference to 'Img.
+
function Is_Inherited_Operation (E : Entity_Id) return Boolean;
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by a derived type declaration.
projects / gcc.git / commitdiff