exp_ch4.adb (Expand_Allocator_Expression): Pass Allocator => True to…

exp_ch4.adb (Expand_Allocator_Expression): Pass Allocator => True to Make_Adjust_Call done for a newly-allocated object.

2006-02-13  Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* exp_ch4.adb (Expand_Allocator_Expression): Pass Allocator => True to
	Make_Adjust_Call done for a newly-allocated object.

	* exp_ch7.ads, exp_ch7.adb (Expand_Cleanup_Actions): If the statements
	in a subprogram are wrapped in a cleanup block, indicate that the
	subprogram contains an inner block with an exception handler.
	(Make_Adjust_Call): New Boolean formal Allocator indicating whether the
	Adjust call is for a newly-allocated object. In that case we must not
	assume that the finalization list chain pointers are correct (since they
	come from a bit-for-bit copy of the original object's pointers) so if
	the attach level would otherwise be zero (no change), we set it to 4
	instead to cause the pointers to be reset to null.

	* s-finimp.adb (Attach_To_Final_List): New attach level: 4, meaning
	reset chain pointers to null.

From-SVN: r111060

gcc/ada/exp_ch4.adb

@@ -494,8 +494,8 @@ package body Exp_Ch4 is
 
          if Java_VM then
 
-            --  Suppress the tag assignment when Java_VM because JVM tags
-            --  are represented implicitly in objects.
+            --  Suppress the tag assignment when Java_VM because JVM tags are
+            --  represented implicitly in objects.
 
             null;
 
@@ -507,10 +507,10 @@ package body Exp_Ch4 is
            and then Is_Tagged_Type (Underlying_Type (T))
          then
             TagT := Underlying_Type (T);
-            TagR := Unchecked_Convert_To (Underlying_Type (T),
-                      Make_Explicit_Dereference (Loc,
-                        New_Reference_To (Temp, Loc)));
-
+            TagR :=
+              Unchecked_Convert_To (Underlying_Type (T),
+                Make_Explicit_Dereference (Loc,
+                  Prefix => New_Reference_To (Temp, Loc)));
          end if;
 
          if Present (TagT) then
@@ -593,11 +593,12 @@ package body Exp_Ch4 is
 
                       Unchecked_Convert_To (T,
                         Make_Explicit_Dereference (Loc,
-                          New_Reference_To (Temp, Loc))),
+                          Prefix => New_Reference_To (Temp, Loc))),
 
                       Typ          => T,
                       Flist_Ref    => Flist,
-                      With_Attach  => Attach));
+                      With_Attach  => Attach,
+                      Allocator    => True));
                end if;
             end;
          end if;
@@ -3040,8 +3041,7 @@ package body Exp_Ch4 is
 
    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
    begin
-      --  The only processing required is an insertion of an explicit
-      --  dereference call for the checked storage pool case.
+      --  Insert explicit dereference call for the checked storage pool case
 
       Insert_Dereference_Action (Prefix (N));
    end Expand_N_Explicit_Dereference;
@@ -4798,11 +4798,11 @@ package body Exp_Ch4 is
       --  Signed integer cases, done using either Integer or Long_Long_Integer.
       --  It is not worth having routines for Short_[Short_]Integer, since for
       --  most machines it would not help, and it would generate more code that
-      --  might need certification in the HI-E case.
+      --  might need certification when a certified run time is required.
 
       --  In the integer cases, we have two routines, one for when overflow
-      --  checks are required, and one when they are not required, since
-      --  there is a real gain in ommitting checks on many machines.
+      --  checks are required, and one when they are not required, since there
+      --  is a real gain in omitting checks on many machines.
 
       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
         or else (Rtyp = Base_Type (Standard_Long_Integer)
@@ -8226,6 +8226,14 @@ package body Exp_Ch4 is
 
            or else Is_Interface (Left_Type)
          then
+            --  Issue error if IW_Membership operation not available in a
+            --  configurable run time setting.
+
+            if not RTE_Available (RE_IW_Membership) then
+               Error_Msg_CRT ("abstract interface types", N);
+               return Empty;
+            end if;
+
             return
               Make_Function_Call (Loc,
                  Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),

gcc/ada/exp_ch7.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1248,6 +1248,12 @@ package body Exp_Ch7 is
          Set_End_Label (Handled_Statement_Sequence (N), End_Lab);
          Wrapped := True;
 
+         --  Comment needed here, see RH for 1.306 ???
+
+         if Nkind (N) = N_Subprogram_Body then
+            Set_Has_Nested_Block_With_Handler (Current_Scope);
+         end if;
+
       --  Otherwise we do not wrap
 
       else
@@ -1957,10 +1963,11 @@ package body Exp_Ch7 is
    -----------------------
 
    function Make_Adjust_Call
-     (Ref          : Node_Id;
-      Typ          : Entity_Id;
-      Flist_Ref    : Node_Id;
-      With_Attach  : Node_Id) return List_Id
+     (Ref         : Node_Id;
+      Typ         : Entity_Id;
+      Flist_Ref   : Node_Id;
+      With_Attach : Node_Id;
+      Allocator   : Boolean := False) return List_Id
    is
       Loc    : constant Source_Ptr := Sloc (Ref);
       Res    : constant List_Id    := New_List;
@@ -2018,8 +2025,19 @@ package body Exp_Ch7 is
          Attach := Make_Integer_Literal (Loc, 0);
       end if;
 
+      --  Special case for allocators: need initialization of the chain
+      --  pointers. For the 0 case, reset them to null.
+
+      if Allocator then
+         pragma Assert (Nkind (Attach) = N_Integer_Literal);
+
+         if Intval (Attach) = 0 then
+            Set_Intval (Attach, Uint_4);
+         end if;
+      end if;
+
       --  Generate:
-      --    Deep_Adjust (Flist_Ref, Ref, With_Attach);
+      --    Deep_Adjust (Flist_Ref, Ref, Attach);
 
       if Has_Controlled_Component (Utyp)
         or else Is_Class_Wide_Type (Typ)
@@ -2158,7 +2176,7 @@ package body Exp_Ch7 is
                Pid := Corresponding_Concurrent_Type (Param_Type);
             end if;
 
-            exit when not Present (Param) or else Present (Pid);
+            exit when No (Param) or else Present (Pid);
             Next (Param);
          end loop;
 

gcc/ada/exp_ch7.ads

@@ -108,7 +108,8 @@ package Exp_Ch7 is
      (Ref         : Node_Id;
       Typ         : Entity_Id;
       Flist_Ref   : Node_Id;
-      With_Attach : Node_Id) return List_Id;
+      With_Attach : Node_Id;
+      Allocator   : Boolean := False) return List_Id;
    --  Ref is an expression (with no-side effect and is not required to
    --  have been previously analyzed) that references the object to be
    --  adjusted. Typ is the expected type of Ref, which is a controlled
@@ -126,6 +127,12 @@ package Exp_Ch7 is
    --  details are in the body. The objects must be attached when the adjust
    --  takes place after an initialization expression but not when it takes
    --  place after a regular assignment.
+   --
+   --  If Allocator is True, we are adjusting a newly-created object. The
+   --  existing chaining pointers should not be left unchanged, because they
+   --  may come from a bit-for-bit copy of those from an initializing object.
+   --  So, when this flag is True, if the chaining pointers should otherwise
+   --  be left unset, instead they are reset to null.
 
    function Make_Final_Call
      (Ref         : Node_Id;

gcc/ada/s-finimp.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -60,8 +60,8 @@ package body System.Finalization_Implementation is
      new Unchecked_Conversion (Address, RC_Ptr);
 
    procedure Raise_Exception_No_Defer
-     (E       : in Exception_Id;
-      Message : in String := "");
+     (E       : Exception_Id;
+      Message : String := "");
    pragma Import (Ada, Raise_Exception_No_Defer,
      "ada__exceptions__raise_exception_no_defer");
    pragma No_Return (Raise_Exception_No_Defer);
@@ -214,6 +214,13 @@ package body System.Finalization_Implementation is
             P.Next := L;
             L := Obj'Unchecked_Access;
          end;
+
+      --  Make the object completely unattached (case of a library-level,
+      --  Finalize_Storage_Only object).
+
+      elsif Nb_Link = 4 then
+         Obj.Prev := null;
+         Obj.Next := null;
       end if;
    end Attach_To_Final_List;