sem_res.adb (Resolve): special-case resolution of Null in an instance or an…

sem_res.adb (Resolve): special-case resolution of Null in an instance or an inlined body to avoid view...

	* sem_res.adb (Resolve): special-case resolution of Null in an
         instance or an inlined body to avoid view conflicts.

	* sem_ch12.adb (Copy_Generic_Node): for allocators, check for view
         compatibility by retrieving the access type of the generic copy.

From-SVN: r46509

gcc/ada/ChangeLog

+2001-10-25  Ed Schonberg <schonber@gnat.com>
+
+	* sem_res.adb (Resolve): special-case resolution of Null in an 
+         instance or an inlined body to avoid view conflicts.
+	
+	* sem_ch12.adb (Copy_Generic_Node): for allocators, check for view 
+         compatibility by retrieving the access type of the generic copy.
+
 2001-10-25  Robert Dewar <dewar@gnat.com>
 
 	* sem_ch3.adb:

gcc/ada/sem_ch12.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                            $Revision: 1.776 $
+--                            $Revision$
 --                                                                          --
 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
 --                                                                          --
@@ -4197,6 +4197,9 @@ package body Sem_Ch12 is
       --  field may hold a Node_Id, a List_Id, or an Elist_Id, or a plain
       --  value (Sloc, Uint, Char) in which case it need not be copied.
 
+      procedure Copy_Descendants;
+      --  Common utility for various nodes.
+
       function Copy_Generic_Elist (E : Elist_Id) return Elist_Id;
       --  Make copy of element list.
 
@@ -4206,6 +4209,19 @@ package body Sem_Ch12 is
          return      List_Id;
       --  Apply Copy_Node recursively to the members of a node list.
 
+      -----------------------
+      --  Copy_Descendants --
+      -----------------------
+
+      procedure Copy_Descendants is
+      begin
+         Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
+         Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
+         Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
+         Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
+         Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+      end Copy_Descendants;
+
       -----------------------------
       -- Copy_Generic_Descendant --
       -----------------------------
@@ -4606,11 +4622,41 @@ package body Sem_Ch12 is
             end if;
          end if;
 
+         --  Do not copy the associated node, which points to
+         --  the generic copy of the aggregate.
+
          Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
          Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
          Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
          Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
 
+      --  Allocators do not have an identifier denoting the access type,
+      --  so we must locate it through the expression to check whether
+      --  the views are consistent.
+
+      elsif Nkind (N) = N_Allocator
+        and then Nkind (Expression (N)) = N_Qualified_Expression
+        and then Instantiating
+      then
+         declare
+            T : Node_Id := Associated_Node (Subtype_Mark (Expression (N)));
+            Acc_T : Entity_Id;
+
+         begin
+            if Present (T) then
+               --  Retrieve the allocator node in the generic copy.
+
+               Acc_T := Etype (Parent (Parent (T)));
+               if Present (Acc_T)
+                 and then Is_Private_Type (Acc_T)
+               then
+                  Switch_View (Acc_T);
+               end if;
+            end if;
+
+            Copy_Descendants;
+         end;
+
       --  For a proper body, we must catch the case of a proper body that
       --  replaces a stub. This represents the point at which a separate
       --  compilation unit, and hence template file, may be referenced, so
@@ -4632,11 +4678,7 @@ package body Sem_Ch12 is
             --  Now copy the fields of the proper body, using the new
             --  adjustment factor if one was needed as per test above.
 
-            Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
-            Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
-            Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
-            Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
-            Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+            Copy_Descendants;
 
             --  Restore the original adjustment factor in case changed
 
@@ -4659,22 +4701,14 @@ package body Sem_Ch12 is
                New_N := Make_Null_Statement (Sloc (N));
 
             else
-               Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
-               Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
-               Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
-               Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
-               Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+               Copy_Descendants;
             end if;
          end;
 
       --  For the remaining nodes, copy recursively their descendants.
 
       else
-         Set_Field1 (New_N, Copy_Generic_Descendant (Field1 (N)));
-         Set_Field2 (New_N, Copy_Generic_Descendant (Field2 (N)));
-         Set_Field3 (New_N, Copy_Generic_Descendant (Field3 (N)));
-         Set_Field4 (New_N, Copy_Generic_Descendant (Field4 (N)));
-         Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
+         Copy_Descendants;
 
          if Instantiating
            and then Nkind (N) = N_Subprogram_Body

gcc/ada/sem_res.adb

@@ -1670,6 +1670,18 @@ package body Sem_Res is
                Wrong_Type (Expression (N), Designated_Type (Typ));
                Found := True;
 
+            --  Check for view mismatch on Null in instances, for
+            --  which the view-swapping mechanism has no identifier.
+
+            elsif (In_Instance or else In_Inlined_Body)
+              and then (Nkind (N) = N_Null)
+              and then Is_Private_Type (Typ)
+              and then Is_Access_Type (Full_View (Typ))
+            then
+               Resolve (N, Full_View (Typ));
+               Set_Etype (N, Typ);
+               return;
+
             --  Check for an aggregate. Sometimes we can get bogus
             --  aggregates from misuse of parentheses, and we are
             --  about to complain about the aggregate without even
@@ -4522,7 +4534,7 @@ package body Sem_Res is
    begin
       --  For now allow circumvention of the restriction against
       --  anonymous null access values via a debug switch to allow
-      --  for easier trasition.
+      --  for easier transition.
 
       if not Debug_Flag_J
         and then Ekind (Typ) = E_Anonymous_Access_Type