From e0fd1b9c9d906f9693bb4e7d56a37ec5adf4bc0a Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Fri, 31 Jan 2020 08:28:45 -0500 Subject: [PATCH] [Ada] Put_Image attribute 2020-06-05 Bob Duff 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. --- gcc/ada/exp_attr.adb | 18 ++---------------- gcc/ada/exp_ch11.adb | 4 ++-- gcc/ada/exp_imgv.adb | 15 ++++++++------- gcc/ada/exp_tss.ads | 7 ++----- gcc/ada/par-ch4.adb | 2 +- gcc/ada/sem_attr.adb | 8 ++++---- gcc/ada/sem_util.ads | 9 ++------- 7 files changed, 21 insertions(+), 42 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 1c9b971e927..1545b5f44c1 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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); diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index c980558dcd7..acc53b19b1a 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -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); diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index 29aa145957b..4f2a67f5838 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -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 ( diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads index 37b04185152..59234ff8d6f 100644 --- a/gcc/ada/exp_tss.ads +++ b/gcc/ada/exp_tss.ads @@ -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 diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 68d56649fad..63e9790b96e 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index f4e38a0daed..5e6ad38030c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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"); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 13bbc6a76f8..391711c7d01 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 -- 2.30.2