Commit e98668b1 by Arnaud Charlet

[multiple changes]

2012-06-12  Robert Dewar  <dewar@adacore.com>

	* stringt.adb: Minor reformatting.

2012-06-12  Robert Dewar  <dewar@adacore.com>

	* ali-util.adb, stringt.ads: Minor reformatting.

2012-06-12  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Handle the case where
	the original context has been wrapped in a block to avoid
	interference between exception handlers and At_End handlers.
	(Wrap_HSS_In_Block): Mark the block which contains the original
	statements of the context as being a finalization wrapper.
	* sinfo.adb (Is_Finalization_Wrapper): New routine.
	(Set_Is_Finalization_Wrapper): New routine.

	* sinfo.ads: Add new attribute Is_Finalization_Wrapper applicable
	to block statemnts.
	(Is_Finalization_Wrapper): New routine with corresponding pragma Inline.
	(Set_Is_Finalization_Wrapper): New routine with corresponding pragma
	Inline.

2012-06-12  Steve Baird  <baird@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): No longer need to set
	Exception_Extra_Info in CodePeer_Mode.

From-SVN: r188449
parent 175a7536
2012-06-12 Robert Dewar <dewar@adacore.com> 2012-06-12 Robert Dewar <dewar@adacore.com>
* stringt.adb: Minor reformatting.
2012-06-12 Robert Dewar <dewar@adacore.com>
* ali-util.adb, stringt.ads: Minor reformatting.
2012-06-12 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Process_Declarations): Handle the case where
the original context has been wrapped in a block to avoid
interference between exception handlers and At_End handlers.
(Wrap_HSS_In_Block): Mark the block which contains the original
statements of the context as being a finalization wrapper.
* sinfo.adb (Is_Finalization_Wrapper): New routine.
(Set_Is_Finalization_Wrapper): New routine.
* sinfo.ads: Add new attribute Is_Finalization_Wrapper applicable
to block statemnts.
(Is_Finalization_Wrapper): New routine with corresponding pragma Inline.
(Set_Is_Finalization_Wrapper): New routine with corresponding pragma
Inline.
2012-06-12 Steve Baird <baird@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): No longer need to set
Exception_Extra_Info in CodePeer_Mode.
2012-06-12 Robert Dewar <dewar@adacore.com>
* sem_dist.adb, exp_ch7.adb, sem_type.adb, exp_attr.adb, * sem_dist.adb, exp_ch7.adb, sem_type.adb, exp_attr.adb,
sinfo.ads, sem_ch7.adb, exp_alfa.adb, sem_scil.adb, sem_ch12.adb, sinfo.ads, sem_ch7.adb, exp_alfa.adb, sem_scil.adb, sem_ch12.adb,
sem_util.adb, sem_res.adb, sem_attr.adb, sem_elab.adb, exp_ch6.adb, sem_util.adb, sem_res.adb, sem_attr.adb, sem_elab.adb, exp_ch6.adb,
......
...@@ -475,7 +475,9 @@ package body ALI.Util is ...@@ -475,7 +475,9 @@ package body ALI.Util is
-- of the source file in the table if checksums match. -- of the source file in the table if checksums match.
-- ??? It is probably worth updating the ALI file with a new -- ??? It is probably worth updating the ALI file with a new
-- field to avoid recomputing it each time. -- field to avoid recomputing it each time. In any case we ensure
-- that we don't gobble up string table space by doing a mark
-- release around this computation.
Stringt.Mark; Stringt.Mark;
...@@ -495,7 +497,6 @@ package body ALI.Util is ...@@ -495,7 +497,6 @@ package body ALI.Util is
end if; end if;
Stringt.Release; Stringt.Release;
end if; end if;
if (not Read_Only) or else Source.Table (Src).Source_Found then if (not Read_Only) or else Source.Table (Src).Source_Found then
......
...@@ -2094,6 +2094,22 @@ package body Exp_Ch7 is ...@@ -2094,6 +2094,22 @@ package body Exp_Ch7 is
then then
Last_Top_Level_Ctrl_Construct := Decl; Last_Top_Level_Ctrl_Construct := Decl;
end if; end if;
-- Handle the case where the original context has been wrapped in
-- a block to avoid interference between exception handlers and
-- At_End handlers. Treat the block as transparent and process its
-- contents.
elsif Nkind (Decl) = N_Block_Statement
and then Is_Finalization_Wrapper (Decl)
then
if Present (Handled_Statement_Sequence (Decl)) then
Process_Declarations
(Statements (Handled_Statement_Sequence (Decl)),
Preprocess);
end if;
Process_Declarations (Declarations (Decl), Preprocess);
end if; end if;
Prev_Non_Pragma (Decl); Prev_Non_Pragma (Decl);
...@@ -3696,6 +3712,11 @@ package body Exp_Ch7 is ...@@ -3696,6 +3712,11 @@ package body Exp_Ch7 is
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
Handled_Statement_Sequence => HSS); Handled_Statement_Sequence => HSS);
-- Signal the finalization machinery that this particular block
-- contains the original context.
Set_Is_Finalization_Wrapper (Block);
Set_Handled_Statement_Sequence (N, Set_Handled_Statement_Sequence (N,
Make_Handled_Sequence_Of_Statements (Loc, New_List (Block))); Make_Handled_Sequence_Of_Statements (Loc, New_List (Block)));
HSS := Handled_Statement_Sequence (N); HSS := Handled_Statement_Sequence (N);
......
...@@ -265,12 +265,6 @@ procedure Gnat1drv is ...@@ -265,12 +265,6 @@ procedure Gnat1drv is
Force_ALI_Tree_File := True; Force_ALI_Tree_File := True;
Try_Semantics := True; Try_Semantics := True;
-- Enable Exception_Extra_Info for now, to avoid extra messages
-- on controlled operations.
-- ??? To be revised.
Exception_Extra_Info := True;
end if; end if;
-- Set Configurable_Run_Time mode if system.ads flag set -- Set Configurable_Run_Time mode if system.ads flag set
......
...@@ -1806,6 +1806,14 @@ package body Sinfo is ...@@ -1806,6 +1806,14 @@ package body Sinfo is
return Flag11 (N); return Flag11 (N);
end Is_Expanded_Build_In_Place_Call; end Is_Expanded_Build_In_Place_Call;
function Is_Finalization_Wrapper
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Block_Statement);
return Flag9 (N);
end Is_Finalization_Wrapper;
function Is_Folded_In_Parser function Is_Folded_In_Parser
(N : Node_Id) return Boolean is (N : Node_Id) return Boolean is
begin begin
...@@ -4902,6 +4910,14 @@ package body Sinfo is ...@@ -4902,6 +4910,14 @@ package body Sinfo is
Set_Flag11 (N, Val); Set_Flag11 (N, Val);
end Set_Is_Expanded_Build_In_Place_Call; end Set_Is_Expanded_Build_In_Place_Call;
procedure Set_Is_Finalization_Wrapper
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Block_Statement);
Set_Flag9 (N, Val);
end Set_Is_Finalization_Wrapper;
procedure Set_Is_Folded_In_Parser procedure Set_Is_Folded_In_Parser
(N : Node_Id; Val : Boolean := True) is (N : Node_Id; Val : Boolean := True) is
begin begin
......
...@@ -1310,6 +1310,12 @@ package Sinfo is ...@@ -1310,6 +1310,12 @@ package Sinfo is
-- actuals to support a build-in-place style of call have been added to -- actuals to support a build-in-place style of call have been added to
-- the call. -- the call.
-- Is_Finalization_Wrapper (Flag9-Sem);
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
-- objects. The wrapper prevents interference between exception handlers
-- and At_End handlers.
-- Is_In_Discriminant_Check (Flag11-Sem) -- Is_In_Discriminant_Check (Flag11-Sem)
-- This flag is present in a selected component, and is used to indicate -- This flag is present in a selected component, and is used to indicate
-- that the reference occurs within a discriminant check. The -- that the reference occurs within a discriminant check. The
...@@ -4331,6 +4337,7 @@ package Sinfo is ...@@ -4331,6 +4337,7 @@ package Sinfo is
-- Is_Task_Allocation_Block (Flag6) -- Is_Task_Allocation_Block (Flag6)
-- Is_Asynchronous_Call_Block (Flag7) -- Is_Asynchronous_Call_Block (Flag7)
-- Exception_Junk (Flag8-Sem) -- Exception_Junk (Flag8-Sem)
-- Is_Finalization_Wrapper (Flag9-Sem)
------------------------- -------------------------
-- 5.7 Exit Statement -- -- 5.7 Exit Statement --
...@@ -8670,6 +8677,9 @@ package Sinfo is ...@@ -8670,6 +8677,9 @@ package Sinfo is
function Is_Expanded_Build_In_Place_Call function Is_Expanded_Build_In_Place_Call
(N : Node_Id) return Boolean; -- Flag11 (N : Node_Id) return Boolean; -- Flag11
function Is_Finalization_Wrapper
(N : Node_Id) return Boolean; -- Flag9
function Is_Folded_In_Parser function Is_Folded_In_Parser
(N : Node_Id) return Boolean; -- Flag4 (N : Node_Id) return Boolean; -- Flag4
...@@ -9657,6 +9667,9 @@ package Sinfo is ...@@ -9657,6 +9667,9 @@ package Sinfo is
procedure Set_Is_Expanded_Build_In_Place_Call procedure Set_Is_Expanded_Build_In_Place_Call
(N : Node_Id; Val : Boolean := True); -- Flag11 (N : Node_Id; Val : Boolean := True); -- Flag11
procedure Set_Is_Finalization_Wrapper
(N : Node_Id; Val : Boolean := True); -- Flag9
procedure Set_Is_Folded_In_Parser procedure Set_Is_Folded_In_Parser
(N : Node_Id; Val : Boolean := True); -- Flag4 (N : Node_Id; Val : Boolean := True); -- Flag4
...@@ -12014,6 +12027,7 @@ package Sinfo is ...@@ -12014,6 +12027,7 @@ package Sinfo is
pragma Inline (Is_Elsif); pragma Inline (Is_Elsif);
pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Entry_Barrier_Function);
pragma Inline (Is_Expanded_Build_In_Place_Call); pragma Inline (Is_Expanded_Build_In_Place_Call);
pragma Inline (Is_Finalization_Wrapper);
pragma Inline (Is_Folded_In_Parser); pragma Inline (Is_Folded_In_Parser);
pragma Inline (Is_In_Discriminant_Check); pragma Inline (Is_In_Discriminant_Check);
pragma Inline (Is_Machine_Number); pragma Inline (Is_Machine_Number);
...@@ -12338,6 +12352,7 @@ package Sinfo is ...@@ -12338,6 +12352,7 @@ package Sinfo is
pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Elsif);
pragma Inline (Set_Is_Entry_Barrier_Function); pragma Inline (Set_Is_Entry_Barrier_Function);
pragma Inline (Set_Is_Expanded_Build_In_Place_Call); pragma Inline (Set_Is_Expanded_Build_In_Place_Call);
pragma Inline (Set_Is_Finalization_Wrapper);
pragma Inline (Set_Is_Folded_In_Parser); pragma Inline (Set_Is_Folded_In_Parser);
pragma Inline (Set_Is_In_Discriminant_Check); pragma Inline (Set_Is_In_Discriminant_Check);
pragma Inline (Set_Is_Machine_Number); pragma Inline (Set_Is_Machine_Number);
......
...@@ -70,7 +70,7 @@ package body Stringt is ...@@ -70,7 +70,7 @@ package body Stringt is
-- when Start_String is called with a parameter that is the last string -- when Start_String is called with a parameter that is the last string
-- currently allocated in the table. -- currently allocated in the table.
Strings_Last : String_Id := First_String_Id; Strings_Last : String_Id := First_String_Id;
String_Chars_Last : Int := 0; String_Chars_Last : Int := 0;
-- Strings_Last and String_Chars_Last are used by procedure Mark and -- Strings_Last and String_Chars_Last are used by procedure Mark and
-- Release to get a snapshot of the tables and to restore them to their -- Release to get a snapshot of the tables and to restore them to their
......
...@@ -63,12 +63,13 @@ package Stringt is ...@@ -63,12 +63,13 @@ package Stringt is
-- Unlock internal tables, in case back end needs to modify them -- Unlock internal tables, in case back end needs to modify them
procedure Mark; procedure Mark;
-- Take a snapshot of the internal tables -- Take a snapshot of the internal tables. Used in conjunction with Release
-- when computing temporary string values that need not be preserved.
procedure Release; procedure Release;
-- Restore the internal tables to the situation when Mark was last called. -- Restore the internal tables to the situation when Mark was last called.
-- Mark and Release are used when getting checksums of sources in minimal -- If Release is called with no prior call to Mark, the entire string table
-- recompilation mode, to reduce memory usage. -- is cleared to its initial (empty) setting.
procedure Start_String; procedure Start_String;
-- Sets up for storing a new string in the table. To store a string, a -- Sets up for storing a new string in the table. To store a string, a
......
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