gcc/ada/

	PR ada/17317
	* par-ch4.adb (Is_Parameterless_Attribute): New map.
	(P_Name, Scan_Apostrophe block): Parse left parenthesis following
	attribute name or not depending on the new map.

	* sem-attr.adb (Analyze_Attribute): Parameterless attributes
	returning a string or a type will not be called with improper
	arguments.

	* sem-attr.ads (Attribute_Class_Array): Move to snames.ads.

	* snames.ads (Attribute_Class_Array): Moved from sem-attr.ads.

    gcc/testsuite/
	PR ada/17317
	* gnat.dg/specs/attribute_parsing.ads: New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@130496 138bc75d-0d04-0410-961f-82ee72b054a4

7 files changed, 59 insertions, 84 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 31f9d19ba51..7b7383cf96d 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -4,6 +4,19 @@
 	* par-ch3.adb (P_Variant_Part): Signal an error when anything other
 	than an identifier is used after "case" in a variant_part.
 
+	PR ada/17317
+	* par-ch4.adb (Is_Parameterless_Attribute): New map.
+	(P_Name, Scan_Apostrophe block): Parse left parenthesis following
+	attribute name or not depending on the new map.
+
+	* sem-attr.adb (Analyze_Attribute): Parameterless attributes
+	returning a string or a type will not be called with improper
+	arguments.
+
+	* sem-attr.ads (Attribute_Class_Array): Move to snames.ads.
+
+	* snames.ads (Attribute_Class_Array): Moved from sem-attr.ads.
+
 2007-11-26  Andreas Krebbel  <krebbel1@de.ibm.com>
 
         PR 34081/C++
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 89f3345e887..ee63c42f551 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -32,6 +32,25 @@ with Stringt; use Stringt;
 separate (Par)
 package body Ch4 is
 
+   ---------------
+   -- Local map --
+   ---------------
+
+   Is_Parameterless_Attribute : constant Attribute_Class_Array :=
+     (Attribute_Body_Version => True,
+      Attribute_External_Tag => True,
+      Attribute_Img          => True,
+      Attribute_Version      => True,
+      Attribute_Base         => True,
+      Attribute_Class        => True,
+      Attribute_Stub_Type    => True,
+      others                 => False);
+   --  This map contains True for parameterless attributes that return a
+   --  string 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)).
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -486,7 +505,10 @@ package body Ch4 is
 
             --  Scan attribute arguments/designator
 
-            if Token = Tok_Left_Paren then
+            if Token = Tok_Left_Paren
+                 and then
+               not Is_Parameterless_Attribute (Get_Attribute_Id (Attr_Name))
+            then
                Set_Expressions (Name_Node, New_List);
                Scan; -- past left paren
 
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index ce66987c87e..9821b6f10c3 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -2188,7 +2188,7 @@ package body Sem_Attr is
          Typ : Entity_Id;
 
       begin
-         Check_Either_E0_Or_E1;
+         Check_E0;
          Find_Type (P);
          Typ := Entity (P);
 
@@ -2207,37 +2207,9 @@ package body Sem_Attr is
          end if;
 
          Set_Etype (N, Base_Type (Entity (P)));
-
-         --  If we have an expression present, then really this is a conversion
-         --  and the tree must be reformed. Note that this is one of the cases
-         --  in which we do a replace rather than a rewrite, because the
-         --  original tree is junk.
-
-         if Present (E1) then
-            Replace (N,
-              Make_Type_Conversion (Loc,
-                Subtype_Mark =>
-                  Make_Attribute_Reference (Loc,
-                    Prefix => Prefix (N),
-                    Attribute_Name => Name_Base),
-                Expression => Relocate_Node (E1)));
-
-            --  E1 may be overloaded, and its interpretations preserved
-
-            Save_Interps (E1, Expression (N));
-            Analyze (N);
-
-         --  For other cases, set the proper type as the entity of the
-         --  attribute reference, and then rewrite the node to be an
-         --  occurrence of the referenced base type. This way, no one
-         --  else in the compiler has to worry about the base attribute.
-
-         else
-            Set_Entity (N, Base_Type (Entity (P)));
-            Rewrite (N,
-              New_Reference_To (Entity (N), Loc));
-            Analyze (N);
-         end if;
+         Set_Entity (N, Base_Type (Entity (P)));
+         Rewrite (N, New_Reference_To (Entity (N), Loc));
+         Analyze (N);
       end Base;
 
       ---------
@@ -2377,55 +2349,10 @@ package body Sem_Attr is
       -- Class --
       -----------
 
-      when Attribute_Class => Class : declare
-         P : constant Entity_Id := Prefix (N);
-
-      begin
+      when Attribute_Class =>
          Check_Restriction (No_Dispatch, N);
-         Check_Either_E0_Or_E1;
-
-         --  If we have an expression present, then really this is a conversion
-         --  and the tree must be reformed into a proper conversion. This is a
-         --  Replace rather than a Rewrite, because the original tree is junk.
-         --  If expression is overloaded, propagate interpretations to new one.
-
-         if Present (E1) then
-            Replace (N,
-              Make_Type_Conversion (Loc,
-                Subtype_Mark =>
-                  Make_Attribute_Reference (Loc,
-                    Prefix => P,
-                    Attribute_Name => Name_Class),
-                Expression => Relocate_Node (E1)));
-
-            Save_Interps (E1, Expression (N));
-
-            --  Ada 2005 (AI-251): In case of abstract interfaces we have to
-            --  analyze and resolve the type conversion to generate the code
-            --  that displaces the reference to the base of the object.
-
-            if Is_Interface (Etype (P))
-              or else Is_Interface (Etype (E1))
-            then
-               Analyze_And_Resolve (N, Etype (P));
-
-               --  However, the attribute is a name that occurs in a context
-               --  that imposes its own type. Leave the result unanalyzed,
-               --  so that type checking with the context type take place.
-               --  on the new conversion node, otherwise Resolve is a noop.
-
-               Set_Analyzed (N, False);
-
-            else
-               Analyze (N);
-            end if;
-
-         --  Otherwise we just need to find the proper type
-
-         else
-            Find_Type (N);
-         end if;
-      end Class;
+         Check_E0;
+         Find_Type (N);
 
       ------------------
       -- Code_Address --
@@ -3018,6 +2945,7 @@ package body Sem_Attr is
 
       when Attribute_Img => Img :
       begin
+         Check_E0;
          Set_Etype (N, Standard_String);
 
          if not Is_Scalar_Type (P_Type)
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 1ca903915d5..45cb8e0a6fa 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -38,9 +38,6 @@ with Types;   use Types;
 
 package Sem_Attr is
 
-   type Attribute_Class_Array is array (Attribute_Id) of Boolean;
-   --  Type used to build attribute classification flag arrays
-
    -----------------------------------------
    -- Implementation Dependent Attributes --
    -----------------------------------------
diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads
index b7a7ab12fc1..f2e7be91568 100644
--- a/gcc/ada/snames.ads
+++ b/gcc/ada/snames.ads
@@ -1521,6 +1521,13 @@ package Snames is
       Task_Dispatching_FIFO_Within_Priorities);
    --  Id values used to identify task dispatching policies
 
+   ------------------
+   -- Helper types --
+   ------------------
+
+   type Attribute_Class_Array is array (Attribute_Id) of Boolean;
+   --  Type used to build attribute classification flag arrays
+
    -----------------
    -- Subprograms --
    -----------------
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index fc5de7d497a..692ca74a395 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -3,6 +3,9 @@
 	PR ada/15803
 	* gnat.dg/specs/variant_part.ads: New test.
 
+	PR ada/17317
+	* gnat.dg/specs/attribute_parsing.ads: New test.
+
 2007-11-28  Jakub Jelinek  <jakub@redhat.com>
 
 	PR tree-optimization/34140
diff --git a/gcc/testsuite/gnat.dg/specs/attribute_parsing.ads b/gcc/testsuite/gnat.dg/specs/attribute_parsing.ads
new file mode 100644
index 00000000000..7722a9ae1ef
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/attribute_parsing.ads
@@ -0,0 +1,5 @@
+-- { dg-do compile }
+package Attribute_Parsing is
+   I : constant Integer := 12345;
+   S : constant String := I'Img (1 .. 2);
+end Attribute_Parsing;