From: Javier Miranda <mira...@adacore.com>

The compiler does not report an error when 'access is applied to
a non-aliased class-wide interface type object.

gcc/ada/

        * exp_util.ads (Is_Expanded_Class_Wide_Interface_Object_Decl): New
        subprogram.
        * exp_util.adb (Is_Expanded_Class_Wide_Interface_Object_Decl):
        ditto.
        * sem_util.adb (Is_Aliased_View): Handle expanded class-wide type
        object declaration.
        * checks.adb (Is_Aliased_Unconstrained_Component): Protect the
        frontend against calling Is_Aliased_View with Empty. Found working
        on this issue.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/checks.adb   |  2 +-
 gcc/ada/exp_util.adb | 15 +++++++++++++++
 gcc/ada/exp_util.ads |  5 +++++
 gcc/ada/sem_util.adb |  4 ++++
 4 files changed, 25 insertions(+), 1 deletion(-)

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 38fe687bc7a..77043ca07c2 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -1549,7 +1549,7 @@ package body Checks is
       then
          if (Etype (N) = Typ
               or else (Do_Access and then Designated_Type (Typ) = S_Typ))
-           and then not Is_Aliased_View (Lhs)
+           and then (No (Lhs) or else not Is_Aliased_View (Lhs))
          then
             return;
          end if;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index ef8c91dfe94..392bf3a511e 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -8574,6 +8574,21 @@ package body Exp_Util is
                   and then Is_Formal (Entity (N)));
    end Is_Conversion_Or_Reference_To_Formal;
 
+   --------------------------------------------------
+   -- Is_Expanded_Class_Wide_Interface_Object_Decl --
+   --------------------------------------------------
+
+   function Is_Expanded_Class_Wide_Interface_Object_Decl
+      (N : Node_Id) return Boolean is
+   begin
+      return not Comes_From_Source (N)
+        and then Nkind (Original_Node (N)) = N_Object_Declaration
+        and then Nkind (N) = N_Object_Renaming_Declaration
+        and then Is_Class_Wide_Type (Etype (Defining_Identifier (N)))
+        and then Is_Interface (Etype (Defining_Identifier (N)))
+        and then Nkind (Name (N)) = N_Explicit_Dereference;
+   end Is_Expanded_Class_Wide_Interface_Object_Decl;
+
    ------------------------------
    -- Is_Finalizable_Transient --
    ------------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 14d9e345b53..279feb2e6fe 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -773,6 +773,11 @@ package Exp_Util is
    --  Return True if N is a type conversion, or a dereference thereof, or a
    --  reference to a formal parameter.
 
+   function Is_Expanded_Class_Wide_Interface_Object_Decl
+      (N : Node_Id) return Boolean;
+   --  Determine if N is the expanded code for a class-wide interface type
+   --  object declaration.
+
    function Is_Finalizable_Transient
      (Decl : Node_Id;
       N    : Node_Id) return Boolean;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 3f956098c6d..ab7fcf8dfd1 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -15223,6 +15223,10 @@ package body Sem_Util is
       then
          return Is_Aliased_View (Expression (Obj));
 
+      elsif Is_Expanded_Class_Wide_Interface_Object_Decl (Parent (Obj)) then
+         return Is_Aliased
+                  (Defining_Identifier (Original_Node (Parent (Obj))));
+
       --  The dereference of an access-to-object value denotes an aliased view,
       --  but this routine uses the rules of the language so we need to exclude
       --  rewritten constructs that introduce artificial dereferences.
-- 
2.45.2

Reply via email to