Skip to content

R
riscv-gcc-1
Commit dfd99a80 by Thomas Quinot Committed by Arnaud Charlet
Options

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
parent a05e99a2
Showing with 64 additions and 24 deletions
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment