sem_util.adb (Extensions_Visible_Status): Modify the logic to account for non-SPARK...

2014-11-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_util.adb (Extensions_Visible_Status): Modify the logic to account
	for non-SPARK code.
	(Object_Access_Level): In ASIS mode, recognize
	a selected component with an implicit dereference so that it
	yields the same value with and without expansion.

From-SVN: r217839

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b659777cd8cd43b0a0f8e438c86374d651d64d36..7169bf7feb3d746edf907cd33221489ed1101d30 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,11 @@
+2014-11-20  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * sem_util.adb (Extensions_Visible_Status): Modify the logic to account
+       for non-SPARK code.
+       (Object_Access_Level): In ASIS mode, recognize
+       a selected component with an implicit dereference so that it
+       yields the same value with and without expansion.
+
 2014-11-20  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_prag.adb (Analyze_Pragma, case Implemented): In ASIS

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d29cb7672c2f964f60d4ea5224cd1b766df219a9..b2f40e6f1fdb0db8c1359fc563012a32fe715621 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5929,68 +5929,62 @@ package body Sem_Util is
       Subp : Entity_Id;
 
    begin
-      if SPARK_Mode = On then
+      --  When a formal parameter is subject to Extensions_Visible, the pragma
+      --  is stored in the contract of related subprogram.
 
-         --  When a formal parameter is subject to Extensions_Visible, the
-         --  pragma is stored in the contract of related subprogram.
+      if Is_Formal (Id) then
+         Subp := Scope (Id);
 
-         if Is_Formal (Id) then
-            Subp := Scope (Id);
+      elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
+         Subp := Id;
 
-         elsif Is_Subprogram_Or_Generic_Subprogram (Id) then
-            Subp := Id;
+      --  No other construct carries this pragma
 
-         --  No other construct carries this pragma
-
-         else
-            return Extensions_Visible_None;
-         end if;
-
-         Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
-
-         --  Extract the value from the Boolean expression (if any)
+      else
+         return Extensions_Visible_None;
+      end if;
 
-         if Present (Prag) then
-            Arg1 := First (Pragma_Argument_Associations (Prag));
+      Prag := Get_Pragma (Subp, Pragma_Extensions_Visible);
 
-            --  The pragma appears with an argument
+      --  Extract the value from the Boolean expression (if any)
 
-            if Present (Arg1) then
-               Expr := Get_Pragma_Arg (Arg1);
+      if Present (Prag) then
+         Arg1 := First (Pragma_Argument_Associations (Prag));
 
-               --  Guarg against cascading errors when the argument of pragma
-               --  Extensions_Visible is not a valid static Boolean expression.
+         --  The pragma appears with an argument
 
-               if Error_Posted (Expr) then
-                  return Extensions_Visible_None;
+         if Present (Arg1) then
+            Expr := Get_Pragma_Arg (Arg1);
 
-               elsif Is_True (Expr_Value (Expr)) then
-                  return Extensions_Visible_True;
+            --  Guard against cascading errors when the argument of pragma
+            --  Extensions_Visible is not a valid static Boolean expression.
 
-               else
-                  return Extensions_Visible_False;
-               end if;
+            if Error_Posted (Expr) then
+               return Extensions_Visible_None;
 
-            --  Otherwise the pragma defaults to True
+            elsif Is_True (Expr_Value (Expr)) then
+               return Extensions_Visible_True;
 
             else
-               return Extensions_Visible_True;
+               return Extensions_Visible_False;
             end if;
 
-         --  Otherwise pragma Expresions_Visible is not inherited or directly
-         --  specified, its value defaults to "False".
+         --  Otherwise the pragma defaults to True
 
          else
-            return Extensions_Visible_False;
+            return Extensions_Visible_True;
          end if;
 
-      --  When SPARK_Mode is disabled, all semantic checks related to pragma
-      --  Extensions_Visible are disabled as well. Instead of saturating the
-      --  code with "if SPARK_Mode /= Off then" checks, the predicate returns
-      --  a default value.
+      --  Otherwise pragma Extensions_Visible is not inherited or directly
+      --  specified. In SPARK code, its value defaults to "False".
+
+      elsif SPARK_Mode = On then
+         return Extensions_Visible_False;
+
+      --  In non-SPARK code, pragma Extensions_Visible defaults to "True"
 
       else
-         return Extensions_Visible_None;
+         return Extensions_Visible_True;
       end if;
    end Extensions_Visible_Status;
 
@@ -15364,10 +15358,20 @@ package body Sem_Util is
          --  recursive call on the prefix, which will in turn check the level
          --  of the prefix object of the selected discriminant.
 
+         --  In Ada 2012, if the discriminant has implicit dereference and
+         --  the context is a selected component, treat this as an object of
+         --  unknown scope (see below). This is necessary in compile-only mode;
+         --  otherwise expansion will already have transformed the prefix into
+         --  a temporary.
+
          if Nkind (Prefix (Obj)) = N_Selected_Component
            and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
            and then
              Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
+           and then
+             (not Has_Implicit_Dereference
+                    (Entity (Selector_Name (Prefix (Obj))))
+               or else Nkind (Parent (Obj)) /= N_Selected_Component)
          then
             return Object_Access_Level (Prefix (Obj));