===================================================================
@@ -36,6 +36,7 @@
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
@@ -52,6 +53,17 @@
-- Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
-- Shouldn't this be in einfo.adb or sem_aux.adb???
+ procedure Rewrite_Object_Image
+ (N : Node_Id;
+ Pref : Entity_Id;
+ Attr_Name : Name_Id;
+ Str_Typ : Entity_Id);
+ -- AI12-00124: Rewrite attribute 'Image when it is applied to an object
+ -- reference as an attribute applied to a type. N denotes the node to be
+ -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name
+ -- and Str_Typ specify which specific string type and 'Image attribute to
+ -- apply (e.g. Name_Wide_Image and Standard_Wide_String).
+
------------------------------------
-- Build_Enumeration_Image_Tables --
------------------------------------
@@ -254,10 +266,10 @@
Loc : constant Source_Ptr := Sloc (N);
Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
- Ptyp : constant Entity_Id := Entity (Pref);
- Rtyp : constant Entity_Id := Root_Type (Ptyp);
Expr : constant Node_Id := Relocate_Node (First (Exprs));
Imid : RE_Id;
+ Ptyp : Entity_Id;
+ Rtyp : Entity_Id;
Tent : Entity_Id;
Ttyp : Entity_Id;
Proc_Ent : Entity_Id;
@@ -273,6 +285,14 @@
Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
begin
+ if Is_Object_Image (Pref) then
+ Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
+ return;
+ end if;
+
+ Ptyp := Entity (Pref);
+ Rtyp := Root_Type (Ptyp);
+
-- Build declarations of Snn and Pnn to be inserted
Ins_List := New_List (
@@ -791,11 +811,19 @@
procedure Expand_Wide_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
- Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
- Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Pref : constant Entity_Id := Prefix (N);
+ Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Rtyp : Entity_Id;
begin
+ if Is_Object_Image (Pref) then
+ Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
+ return;
+ end if;
+
+ Rtyp := Root_Type (Entity (Pref));
+
Insert_Actions (N, New_List (
-- Rnn : Wide_String (1 .. base_typ'Width);
@@ -882,12 +910,20 @@
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
+ Pref : constant Entity_Id := Prefix (N);
+ Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
+ Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Rtyp : Entity_Id;
- Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
- Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
+ begin
+ if Is_Object_Image (Pref) then
+ Rewrite_Object_Image
+ (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
+ return;
+ end if;
- begin
+ Rtyp := Root_Type (Entity (Pref));
+
Insert_Actions (N, New_List (
-- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
@@ -1373,4 +1409,23 @@
and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
end Has_Decimal_Small;
+ --------------------------
+ -- Rewrite_Object_Image --
+ --------------------------
+
+ procedure Rewrite_Object_Image
+ (N : Node_Id;
+ Pref : Entity_Id;
+ Attr_Name : Name_Id;
+ Str_Typ : Entity_Id)
+ is
+ begin
+ Rewrite (N,
+ Make_Attribute_Reference (Sloc (N),
+ Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)),
+ Attribute_Name => Attr_Name,
+ Expressions => New_List (Relocate_Node (Pref))));
+
+ Analyze_And_Resolve (N, Str_Typ);
+ end Rewrite_Object_Image;
end Exp_Imgv;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 2000-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -70,20 +70,20 @@
-- declarations are not constructed, and the fields remain Empty.
procedure Expand_Image_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Image.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Image.
procedure Expand_Wide_Image_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Wide_Image.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Wide_Image.
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Wide_Wide_Image.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Wide_Wide_Image.
procedure Expand_Value_Attribute (N : Node_Id);
- -- This procedure is called from Exp_Attr to expand an occurrence
- -- of the attribute Value.
+ -- This procedure is called from Exp_Attr to expand an occurrence of the
+ -- attribute Value.
type Atype is (Normal, Wide, Wide_Wide);
-- Type of attribute in call to Expand_Width_Attribute
===================================================================
@@ -1594,34 +1594,10 @@
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);
- -- AI12-00124: Rewrite attribute 'Image when it is applied to an object
- -- reference as 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 --
------------------------------
@@ -3637,11 +3613,6 @@
-- 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.
@@ -3658,7 +3629,7 @@
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
- Rewrite_Object_Reference_Image (Name_Image, Standard_String);
+ Exp_Imgv.Expand_Image_Attribute (N);
-----------
-- Input --
@@ -7004,12 +6975,6 @@
-- 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.
@@ -7026,12 +6991,6 @@
-- 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.
===================================================================
@@ -13773,21 +13773,6 @@
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 --
----------------------------
@@ -14139,6 +14124,27 @@
or else Null_Present (Component_List (Type_Definition (Decl))));
end Is_Null_Record_Type;
+ ---------------------
+ -- Is_Object_Image --
+ ---------------------
+
+ function Is_Object_Image (Prefix : Node_Id) return Boolean is
+ begin
+ -- When the type of the prefix is not scalar then the prefix is not
+ -- valid in any senario.
+
+ if not Is_Scalar_Type (Etype (Prefix)) then
+ return False;
+ end if;
+
+ -- Here we test for the case that the prefix is not a type and assume
+ -- if it is not then it must be a named value or an object reference.
+ -- This is because the parser always checks that prefix's of attributes
+ -- are named.
+
+ return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix)));
+ end Is_Object_Image;
+
-------------------------
-- Is_Object_Reference --
-------------------------
@@ -14222,9 +14228,9 @@
return not Nkind_In (Original_Node (N), N_Case_Expression,
N_If_Expression);
- -- A view conversion of a tagged object is an object reference
+ when N_Type_Conversion =>
+ -- A view conversion of a tagged object is an object reference
- when N_Type_Conversion =>
return Is_Tagged_Type (Etype (Subtype_Mark (N)))
and then Is_Tagged_Type (Etype (Expression (N)))
and then Is_Object_Reference (Expression (N));
===================================================================
@@ -1598,18 +1598,6 @@
-- 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).
-
- -- AI12-00124: 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.
@@ -1683,6 +1671,15 @@
-- Determine whether T is declared with a null record definition or a
-- null component list.
+ function Is_Object_Image (Prefix : Node_Id) return Boolean;
+ -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
+ -- is applied to a given object or named value prefix (see below).
+
+ -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar
+ -- types, so that the prefix of any 'Image attribute can be an object, a
+ -- named value, or a type, and there is no need for an argument in the
+ -- case it is an object reference.
+
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both
-- variable and constant objects return True (compare Is_Variable).
===================================================================
@@ -261,6 +261,12 @@
-- when the above criteria are met. Spec_Id denotes the entity of the
-- subprogram [body] or Empty if the attribute is illegal.
+ procedure Analyze_Image_Attribute (Str_Typ : Entity_Id);
+ -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and
+ -- 'Wide_Wide_Image. The routine checks that the prefix is valid and
+ -- sets the entity type to the one specified by Str_Typ (e.g.
+ -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
+
procedure Bad_Attribute_For_Predicate;
-- Output error message for use of a predicate (First, Last, Range) not
-- allowed with a type that has predicates. If the type is a generic
@@ -363,10 +369,6 @@
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 attribute 'Image is an object reference and
- -- set the type of the prefix to Str_Typ.
-
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
@@ -1427,6 +1429,82 @@
end if;
end Analyze_Attribute_Old_Result;
+ -----------------------------
+ -- Analyze_Image_Attribute --
+ -----------------------------
+
+ procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is
+ begin
+ Check_SPARK_05_Restriction_On_Attribute;
+
+ -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for
+ -- scalar types, so that the prefix can be an object, a named value,
+ -- or a type, and there is no need for an argument in this case.
+
+ if Attr_Id = Attribute_Img
+ or else (Ada_Version > Ada_2005 and then Is_Object_Image (P))
+ then
+ Check_E0;
+ Set_Etype (N, Str_Typ);
+
+ if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then
+ Error_Attr_P
+ ("prefix of % attribute must be a scalar object name");
+ end if;
+ else
+ Check_E1;
+ Set_Etype (N, Str_Typ);
+
+ -- Check that the prefix type is scalar - much in the same way as
+ -- Check_Scalar_Type but with custom error messages to denote the
+ -- variants of 'Image attributes.
+
+ if Is_Entity_Name (P)
+ and then Is_Type (Entity (P))
+ and then Ekind (Entity (P)) = E_Incomplete_Type
+ and then Present (Full_View (Entity (P)))
+ then
+ P_Type := Full_View (Entity (P));
+ Set_Entity (P, P_Type);
+ end if;
+
+ if not Is_Entity_Name (P)
+ or else not Is_Type (Entity (P))
+ or else not Is_Scalar_Type (P_Type)
+ then
+ if Ada_Version > Ada_2005 then
+ Error_Attr_P
+ ("prefix of % attribute must be a scalar type or a scalar "
+ & "object name");
+ else
+ Error_Attr_P ("prefix of % attribute must be a scalar type");
+ end if;
+
+ elsif Is_Protected_Self_Reference (P) then
+ Error_Attr_P
+ ("prefix of % attribute denotes current instance "
+ & "(RM 9.4(21/2))");
+ end if;
+
+ Resolve (E1, P_Base_Type);
+ Validate_Non_Static_Attribute_Function_Call;
+ end if;
+
+ Check_Enum_Image;
+
+ -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
+ -- to avoid giving a duplicate message for when Image attributes
+ -- applied to object references get expanded into type-based Image
+ -- attributes.
+
+ if Restriction_Check_Required (No_Fixed_IO)
+ and then Comes_From_Source (N)
+ and then Is_Fixed_Point_Type (P_Type)
+ then
+ Check_Restriction (No_Fixed_IO, P);
+ end if;
+ end Analyze_Image_Attribute;
+
---------------------------------
-- Bad_Attribute_For_Predicate --
---------------------------------
@@ -2164,33 +2242,6 @@
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 --
----------------------------
@@ -4073,16 +4124,6 @@
-----------
when Attribute_Image =>
- Check_SPARK_05_Restriction_On_Attribute;
-
- if Is_Image_Applied_To_Object (P, P_Type) then
- Check_Object_Reference_Image (Standard_String);
- return;
- end if;
-
- Check_Scalar_Type;
- Set_Etype (N, Standard_String);
-
if Is_Real_Type (P_Type) then
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
@@ -4091,31 +4132,14 @@
end if;
end if;
- if Is_Enumeration_Type (P_Type) then
- Check_Restriction (No_Enumeration_Maps, N);
- end if;
+ Analyze_Image_Attribute (Standard_String);
- Check_E1;
- Resolve (E1, P_Base_Type);
- Check_Enum_Image;
- Validate_Non_Static_Attribute_Function_Call;
-
- -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source
- -- to avoid giving a duplicate message for Img expanded into Image.
-
- if Restriction_Check_Required (No_Fixed_IO)
- and then Comes_From_Source (N)
- and then Is_Fixed_Point_Type (P_Type)
- then
- Check_Restriction (No_Fixed_IO, P);
- end if;
-
---------
-- Img --
---------
when Attribute_Img =>
- Check_Object_Reference_Image (Standard_String);
+ Analyze_Image_Attribute (Standard_String);
-----------
-- Input --
@@ -6995,51 +7019,15 @@
----------------
when Attribute_Wide_Image =>
- Check_SPARK_05_Restriction_On_Attribute;
+ Analyze_Image_Attribute (Standard_Wide_String);
- 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;
- Resolve (E1, P_Base_Type);
- Validate_Non_Static_Attribute_Function_Call;
-
- -- 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;
-
---------------------
-- Wide_Wide_Image --
---------------------
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;
+ Analyze_Image_Attribute (Standard_Wide_Wide_String);
- Check_Scalar_Type;
- Set_Etype (N, Standard_Wide_Wide_String);
- Check_E1;
- Resolve (E1, P_Base_Type);
- Validate_Non_Static_Attribute_Function_Call;
-
- -- 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;
-
----------------
-- Wide_Value --
----------------