ada: Error missing when 'access is applied to an interface type object

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.

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 38fe687bc7aac0782296b0fa17f144aece8c3999..77043ca07c214c253009396f219952cccce54795 100644 (file)
--- 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 ef8c91dfe949e327ee0e07cfe52cb8ed8027d79f..392bf3a511e6bee691933ec98142e547397ed267 100644 (file)
--- 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 14d9e345b53729220e82bfda867d768bf9faf7f9..279feb2e6fe08764a1de03f950ebbf603f9b75f3 100644 (file)
--- 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 3f956098c6d893bafdf102d3d91d9757f281ac69..ab7fcf8dfd11b5912bffb96194a620a5117f6ab7 100644 (file)
--- 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.