OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[Ada] Put_Image attribute 

2020-06-05  Bob Duff  <duff@adacore.com>

gcc/ada/

	* exp_attr.adb, exp_ch11.adb, exp_imgv.adb, exp_tss.ads,
	par-ch4.adb, sem_attr.adb, sem_util.ads: Misc cleanup.
This commit is contained in:
Bob Duff 2020-01-31 08:28:45 -05:00 committed by Pierre-Marie de Rodat
parent c3c80e3c3a
commit e0fd1b9c9d
7 changed files with 21 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/exp_attr.adb
View File

@ -3732,8 +3732,6 @@ package body Exp_Attr is
-- Image --
-----------
-- Image attribute is handled in separate unit Exp_Imgv
when Attribute_Image =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
@ -3743,7 +3741,7 @@ package body Exp_Attr is
return;
end if;
Expand_Image_Attribute (N);
Exp_Imgv.Expand_Image_Attribute (N);
---------
-- Img --
@ -3752,7 +3750,7 @@ package body Exp_Attr is
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
Expand_Image_Attribute (N);
Exp_Imgv.Expand_Image_Attribute (N);
-----------
-- Input --
@ -7243,8 +7241,6 @@ package body Exp_Attr is
-- Value --
-----------
-- Value attribute is handled in separate unit Exp_Imgv
when Attribute_Value =>
Exp_Imgv.Expand_Value_Attribute (N);
@ -7264,8 +7260,6 @@ package body Exp_Attr is
-- Wide_Image --
----------------
-- Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Image =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
@ -7280,8 +7274,6 @@ package body Exp_Attr is
-- Wide_Wide_Image --
---------------------
-- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Wide_Image =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
@ -7374,8 +7366,6 @@ package body Exp_Attr is
-- Wide_Wide_Width --
---------------------
-- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Wide_Width =>
Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
@ -7383,8 +7373,6 @@ package body Exp_Attr is
-- Wide_Width --
----------------
-- Wide_Width attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Width =>
Exp_Imgv.Expand_Width_Attribute (N, Wide);
@ -7392,8 +7380,6 @@ package body Exp_Attr is
-- Width --
-----------
-- Width attribute is handled in separate unit Exp_Imgv
when Attribute_Width =>
Exp_Imgv.Expand_Width_Attribute (N, Normal);

4
gcc/ada/exp_ch11.adb
View File

@ -1505,7 +1505,7 @@ package body Exp_Ch11 is
Actions => New_List (
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))),
Expression => RCE));
Expression => RCE));
else
Rewrite (N,
@ -1514,7 +1514,7 @@ package body Exp_Ch11 is
Make_Raise_Statement (Loc,
Name => Name (N),
Expression => Expression (N))),
Expression => RCE));
Expression => RCE));
end if;
Analyze_And_Resolve (N, Typ);

15
gcc/ada/exp_imgv.adb
View File

@ -58,7 +58,7 @@ package body Exp_Imgv is
Pref : Entity_Id;
Attr_Name : Name_Id;
Str_Typ : Entity_Id);
-- AI12-00124: Rewrite attribute 'Image when it is applied to an object
-- AI12-0124: 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
@ -263,7 +263,7 @@ package body Exp_Imgv is
-- tv = Long_Long_Integer?(Expr) [convert with no scaling]
-- pm = typ'Scale (typ = subtype of expression)
-- For enumeration types other than those declared packages Standard
-- For enumeration types other than those declared in package Standard
-- or System, Snn, Pnn, are expanded as above, but the call looks like:
-- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
@ -474,23 +474,24 @@ package body Exp_Imgv is
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);
-- Enable speed-optimized expansion of user-defined enumeration types
-- if we are compiling with optimizations enabled and enumeration type
-- literals are generated. Otherwise the call will be expanded into a
-- call to the runtime library.
elsif Optimization_Level > 0
if Optimization_Level > 0
and then not Global_Discard_Names
and then Is_User_Defined_Enumeration_Type (Root_Type (Entity (Pref)))
and then Is_User_Defined_Enumeration_Type (Rtyp)
then
Expand_User_Defined_Enumeration_Image;
return;
end if;
Ptyp := Entity (Pref);
Rtyp := Root_Type (Ptyp);
-- Build declarations of Snn and Pnn to be inserted
Ins_List := New_List (

7
gcc/ada/exp_tss.ads
View File

@ -170,12 +170,9 @@ package Exp_Tss is
-- be explicitly frozen, so the N_Freeze_Entity node always exists).
function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id;
-- Finds the TSS with the given name associated with the given type
-- If no such TSS exists, then Empty is returned;
function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id;
-- Finds the TSS with the given name associated with the given type. If
-- no such TSS exists, then Empty is returned.
-- Finds the TSS with the given name associated with the given type.
-- If no such TSS exists, then Empty is returned.
function Same_TSS (E1, E2 : Entity_Id) return Boolean;
-- Returns True if E1 and E2 are the same kind of TSS, even if the names

2
gcc/ada/par-ch4.adb
View File

@ -51,7 +51,7 @@ package body Ch4 is
-- or a type. For those attributes, a left parenthesis after the attribute
-- should not be analyzed as the beginning of a parameters list because it
-- may denote a slice operation (X'Img (1 .. 2)) or a type conversion
-- (X'Class (Y)). The Ada 2012 attribute 'Old is in this category.
-- (X'Class (Y)).
-- Note: Loop_Entry is in this list because, although it can take an
-- optional argument (the loop name), we can't distinguish that at parse

8
gcc/ada/sem_attr.adb
View File

@ -1430,12 +1430,12 @@ package body Sem_Attr is
begin
Check_SPARK_05_Restriction_On_Attribute;
-- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for
-- AI12-0124: 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.
-- or a type. If the prefix is an object, there is no argument.
if Attr_Id = Attribute_Img
or else (Ada_Version > Ada_2005 and then Is_Object_Image (P))
or else (Ada_Version >= Ada_2012 and then Is_Object_Image (P))
then
Check_E0;
Set_Etype (N, Str_Typ);
@ -1465,7 +1465,7 @@ package body Sem_Attr is
or else not Is_Type (Entity (P))
or else not Is_Scalar_Type (P_Type)
then
if Ada_Version > Ada_2005 then
if Ada_Version >= Ada_2012 then
Error_Attr_P
("prefix of % attribute must be a scalar type or a scalar "
& "object name");

9
gcc/ada/sem_util.ads
View File

@ -1836,13 +1836,8 @@ package Sem_Util is
-- 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.
-- Returns True if an 'Img, 'Image, 'Wide_Image, or 'Wide_Wide_Image
-- attribute is applied to an object.
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both