[Ada] Predicates and the current instance of a subtype (AI12-0068)

gcc/ada/

	* sem_attr.adb (Analyze_Attribute, Attribute_Constrained): Issue
	a warning if the attribute prefix is a current instance
	reference within an aspect of a type or subtype.
	(Address_Checks): Replace test of Is_Object (Ent) with
	Is_Object_Reference (P) so that testing for current instances
	will be done.
	(Eval_Attribute): Add test for current instance reference, to
	ensure that we still fold array attributes when current
	instances are involved, since value prefixes are allowed for
	array attributes, and will now be excluded by
	Is_Object_Reference.
	* sem_util.ads (Is_Current_Instance_Reference_In_Type_Aspect):
	New exported query function.
	* sem_util.adb (Is_Object_Reference): Return False for the case
	where N is a current instance reference within an
	aspect_specification of a type or subtype (basically if the
	reference occurs within a predicate, invariant, or DIC aspect
	expression).
	(Is_Current_Instance_Reference_In_Type_Aspect): New function
	that tests whether a node is a reference to a current instance
	formal of a predicate, invariant, or
	Default_Initial_Condition (DIC) subprogram.

1 files changed, 59 insertions, 1 deletions

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 40f34fd..7ce78a2 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -15029,6 +15029,59 @@ package body Sem_Util is
       return False;
    end Is_Current_Instance;
 
+   --------------------------------------------------
+   -- Is_Current_Instance_Reference_In_Type_Aspect --
+   --------------------------------------------------
+
+   function Is_Current_Instance_Reference_In_Type_Aspect
+     (N : Node_Id) return Boolean
+   is
+   begin
+      --  When a current_instance is referenced within an aspect_specification
+      --  of a type or subtype, it will show up as a reference to the formal
+      --  parameter of the aspect's associated subprogram rather than as a
+      --  reference to the type or subtype itself (in fact, the original name
+      --  is never even analyzed). We check for predicate, invariant, and
+      --  Default_Initial_Condition subprograms (in theory there could be
+      --  other cases added, in which case this function will need updating).
+
+      if Is_Entity_Name (N) then
+         return Present (Entity (N))
+           and then Ekind (Entity (N)) = E_In_Parameter
+           and then Ekind_In (Scope (Entity (N)), E_Function, E_Procedure)
+           and then
+             (Is_Predicate_Function (Scope (Entity (N)))
+               or else Is_Predicate_Function_M (Scope (Entity (N)))
+               or else Is_Invariant_Procedure (Scope (Entity (N)))
+               or else Is_Partial_Invariant_Procedure (Scope (Entity (N)))
+               or else Is_DIC_Procedure (Scope (Entity (N))));
+
+      else
+         case Nkind (N) is
+            when N_Indexed_Component
+               | N_Slice
+            =>
+               return
+                 Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N));
+
+            when N_Selected_Component =>
+               return
+                 Is_Current_Instance_Reference_In_Type_Aspect (Prefix (N));
+
+            when N_Type_Conversion =>
+               return Is_Current_Instance_Reference_In_Type_Aspect
+                        (Expression (N));
+
+            when N_Qualified_Expression =>
+               return Is_Current_Instance_Reference_In_Type_Aspect
+                        (Expression (N));
+
+            when others =>
+               return False;
+         end case;
+      end if;
+   end Is_Current_Instance_Reference_In_Type_Aspect;
+
    --------------------
    -- Is_Declaration --
    --------------------
@@ -16983,8 +17036,13 @@ package body Sem_Util is
 
    function Is_Object_Reference (N : Node_Id) return Boolean is
    begin
+      --  AI12-0068: Note that a current instance reference in a type or
+      --  subtype's aspect_specification is considered a value, not an object
+      --  (see RM 8.6(18/5)).
+
       if Is_Entity_Name (N) then
-         return Present (Entity (N)) and then Is_Object (Entity (N));
+         return Present (Entity (N)) and then Is_Object (Entity (N))
+           and then not Is_Current_Instance_Reference_In_Type_Aspect (N);
 
       else
          case Nkind (N) is