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 72e747d..ea362f1 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,11 @@
 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 
        is malformed, use instance of Any_Id to allow analysis to proceed.
        

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2870645..98b5fdf 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)