[Ada] Put_Image attribute

Message ID 20200605122338.GA56627@adacore.com
State New
Headers show
Series
  • [Ada] Put_Image attribute
Related show

Commit Message

Pierre-Marie de Rodat June 5, 2020, 12:23 p.m.
Misc cleanup in preparation for further work on Put_Image and Image.
Mostly removal of redundant or obvious comments.

Tested on x86_64-pc-linux-gnu, committed on trunk

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.

Patch

--- gcc/ada/exp_attr.adb
+++ 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);
 

--- gcc/ada/exp_ch11.adb
+++ 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);

--- gcc/ada/exp_imgv.adb
+++ 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 (

--- gcc/ada/exp_tss.ads
+++ 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

--- gcc/ada/par-ch4.adb
+++ 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

--- gcc/ada/sem_attr.adb
+++ 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");

--- gcc/ada/sem_util.ads
+++ 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