sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide access discriminan...

	* sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide
	access discriminant within a type extension that constrains its
	parent discriminants.

From-SVN: r47643

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 72e747da933a1667114e6116626b1851adb68a44..ea362f117316abc7a80bc9d835fa972d67aa61eb 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2001-12-04  Ed Schonberg <schonber@gnat.com>
+
+       * sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide 
+       access discriminant within a type extension that constrains its 
+       parent discriminants.
+
 2001-12-04  Ed Schonberg <schonber@gnat.com>
 
        * sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication 

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 287064542a2cbd221ebc75cd8e9a8904587cbc41..98b5fdf690b7f7ea40f13cc5f92575c558eda4ed 100644 (file)
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.1 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -6278,18 +6278,29 @@ package body Sem_Attr is
                      if not Covers (Designated_Type (Typ), Nom_Subt)
                        and then not Covers (Nom_Subt, Designated_Type (Typ))
                      then
-                        if Is_Anonymous_Tagged_Base
-                             (Nom_Subt, Etype (Designated_Type (Typ)))
-                        then
-                           null;
 
-                        else
-                           Error_Msg_NE
-                             ("type of prefix: & not compatible", P, Nom_Subt);
-                           Error_Msg_NE
-                             ("\with &, the expected designated type",
-                               P, Designated_Type (Typ));
-                        end if;
+                        declare
+                           Desig : Entity_Id;
+
+                        begin
+                           Desig := Designated_Type (Typ);
+
+                           if Is_Class_Wide_Type (Desig) then
+                              Desig := Etype (Desig);
+                           end if;
+
+                           if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
+                              null;
+
+                           else
+                              Error_Msg_NE
+                                ("type of prefix: & not compatible",
+                                  P, Nom_Subt);
+                              Error_Msg_NE
+                                ("\with &, the expected designated type",
+                                  P, Designated_Type (Typ));
+                           end if;
+                        end;
                      end if;
 
                   elsif not Covers (Designated_Type (Typ), Nom_Subt)