[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.

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 1c9b971e9273e9b4251fda26979e34e933d21765..1545b5f44c1b5b7a79017aa0ac20b10f4d33bc3c 100644 (file)
--- 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 c980558dcd7513c77ae79bb32616853729519559..acc53b19b1af9a4368bd994e6eec01ab4451f3e7 100644 (file)
--- 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 29aa145957bbb3219fbe167fbe1e8b4003536878..4f2a67f583811d8d8e7354e4a783ae8eb6598f40 100644 (file)
--- 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 37b0418515208d95855189b3840429782d638e70..59234ff8d6f98dafc6f4d952439998d7e1cb8d7d 100644 (file)
--- 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 68d56649fad41c65306a552928f1762b484298f1..63e9790b96eb0b18cbbc11cba68ecf2e4eb4979a 100644 (file)
--- 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 f4e38a0daedc0005725af52b4f824f05e48cbbca..5e6ad38030c2ee834a8a080bfe0890b716f65b12 100644 (file)
--- 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 13bbc6a76f83b9030a28ce6c738264349d218440..391711c7d01f45ffc076f24a0211abf66f5a1564 100644 (file)
--- 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