OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_prag.adb (Get_SPARK_Mode_Id): Handle the case where the pragma may appear without an argument.

Browse Source 
2013-09-10  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Get_SPARK_Mode_Id): Handle the
	case where the pragma may appear without an argument.
	(Analyze_Global_List): Add expanded_name to the list of constructs
	that denote a single item.
	(Collect_Global_List): Add expanded_name to the list of constructs
	that denote a single item.

2013-09-10  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch4.adb (Apply_Accessibility_Check): Add local constant
	Pool_Id and local variables Fin_Call and Free_Stmt. Finalize
	and deallocate a heap-allocated class-wide object after it
	has been determined that it violates the accessibility rules.
	* rtsfind.ads: Add new RTU_Id for System.Memory. Add new RE_Id
	and entry in RE_Unit_Table for RE_Free.

From-SVN: r202451
This commit is contained in:
Hristian Kirtchev 2013-09-10 14:43:06 +00:00 committed by Arnaud Charlet
parent c9b1c957b1
commit a98838ff82
4 changed files with 105 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/ada/ChangeLog
View File

@ -1,3 +1,21 @@
2013-09-10 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Get_SPARK_Mode_Id): Handle the
case where the pragma may appear without an argument.
(Analyze_Global_List): Add expanded_name to the list of constructs
that denote a single item.
(Collect_Global_List): Add expanded_name to the list of constructs
that denote a single item.
2013-09-10 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Apply_Accessibility_Check): Add local constant
Pool_Id and local variables Fin_Call and Free_Stmt. Finalize
and deallocate a heap-allocated class-wide object after it
has been determined that it violates the accessibility rules.
* rtsfind.ads: Add new RTU_Id for System.Memory. Add new RE_Id
and entry in RE_Unit_Table for RE_Free.
2013-09-01 Eric Botcazou <ebotcazou@adacore.com>
Iain Sandoe <iain@codesourcery.com>

74
gcc/ada/exp_ch4.adb
View File

@ -725,20 +725,23 @@ package body Exp_Ch4 is
(Ref : Node_Id;
Built_In_Place : Boolean := False)
is
Cond : Node_Id;
Obj_Ref : Node_Id;
Stmts : List_Id;
Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
Cond : Node_Id;
Fin_Call : Node_Id;
Free_Stmt : Node_Id;
Obj_Ref : Node_Id;
Stmts : List_Id;
begin
if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (DesigT)
and then (Tagged_Type_Expansion or else VM_Target /= No_VM)
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else
(Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope))
and then (Tagged_Type_Expansion or else VM_Target /= No_VM)
then
-- If the allocator was built in place, Ref is already a reference
-- to the access object initialized to the result of the allocator
@ -750,7 +753,7 @@ package body Exp_Ch4 is
if Built_In_Place then
Remove_Side_Effects (Ref);
Obj_Ref := New_Copy (Ref);
Obj_Ref := New_Copy_Tree (Ref);
else
Obj_Ref := New_Reference_To (Ref, Loc);
end if;
@ -759,27 +762,68 @@ package body Exp_Ch4 is
Stmts := New_List;
-- Why don't we free the object ??? discussion and explanation
-- needed of why old approach did not work ???
-- Deallocate the object if the accessibility check fails. This
-- is done only on targets or profiles that support deallocation.
-- Free (Obj_Ref);
if RTE_Available (RE_Free) then
Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
Set_Storage_Pool (Free_Stmt, Pool_Id);
Append_To (Stmts, Free_Stmt);
-- The target or profile cannot deallocate objects
else
Free_Stmt := Empty;
end if;
-- Finalize the object if applicable. Generate:
-- Generate:
-- [Deep_]Finalize (Obj_Ref.all);
if Needs_Finalization (DesigT) then
Append_To (Stmts,
Fin_Call :=
Make_Final_Call (
Obj_Ref =>
Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
Typ => DesigT));
Typ => DesigT);
-- When the target or profile supports deallocation, wrap the
-- finalization call in a block to ensure proper deallocation
-- even if finalization fails. Generate:
-- begin
-- <Fin_Call>
-- exception
-- when others =>
-- <Free_Stmt>
-- raise;
-- end;
if Present (Free_Stmt) then
Fin_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Fin_Call),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
New_Copy_Tree (Free_Stmt),
Make_Raise_Statement (Loc))))));
end if;
Prepend_To (Stmts, Fin_Call);
end if;
-- Signal the accessibility failure through a Program_Error
-- Since we may have a storage leak, I would be inclined to
-- define a new PE_ code that warns of this possibility where
-- the message would be Accessibility_Check_Failed (causing
-- storage leak) ???
Append_To (Stmts,
Make_Raise_Program_Error (Loc,
Condition => New_Reference_To (Standard_True, Loc),

7
gcc/ada/rtsfind.ads
View File

@ -278,6 +278,7 @@ package Rtsfind is
System_Machine_Code,
System_Mantissa,
System_Memcop,
System_Memory,
System_Multiprocessors,
System_Pack_03,
System_Pack_05,
@ -940,7 +941,9 @@ package Rtsfind is
RE_Asm_Input_Operand, -- System.Machine_Code
RE_Asm_Output_Operand, -- System.Machine_Code
RE_Mantissa_Value, -- System_Mantissa
RE_Mantissa_Value, -- System.Mantissa
RE_Free, -- System.Memory
RE_CPU_Range, -- System.Multiprocessors
@ -2197,6 +2200,8 @@ package Rtsfind is
RE_Mantissa_Value => System_Mantissa,
RE_Free => System_Memory,
RE_CPU_Range => System_Multiprocessors,
RE_Bits_03 => System_Pack_03,

30
gcc/ada/sem_prag.adb
View File

@ -1576,7 +1576,10 @@ package body Sem_Prag is
begin
-- Single global item declaration
if Nkind_In (List, N_Identifier, N_Selected_Component) then
if Nkind_In (List, N_Expanded_Name,
N_Identifier,
N_Selected_Component)
then
Analyze_Global_Item (List, Global_Mode);
-- Simple global list or moded global list declaration
@ -16338,7 +16341,7 @@ package body Sem_Prag is
-- SPARK_Mode --
----------------
-- pragma SPARK_Mode (On | Off | Auto);
-- pragma SPARK_Mode [(On | Off | Auto)];
when Pragma_SPARK_Mode => SPARK_Mod : declare
procedure Chain_Pragma (Context : Entity_Id; Prag : Node_Id);
@ -18369,7 +18372,10 @@ package body Sem_Prag is
begin
-- Single global item declaration
if Nkind_In (List, N_Identifier, N_Selected_Component) then
if Nkind_In (List, N_Expanded_Name,
N_Identifier,
N_Selected_Component)
then
Collect_Global_Item (List, Mode);
-- Simple global list or moded global list declaration
@ -18596,16 +18602,24 @@ package body Sem_Prag is
-----------------------
function Get_SPARK_Mode_Id (N : Node_Id) return SPARK_Mode_Id is
Args : List_Id;
Mode : Node_Id;
begin
pragma Assert
(Nkind (N) = N_Pragma
and then Present (Pragma_Argument_Associations (N)));
pragma Assert (Nkind (N) = N_Pragma);
Args := Pragma_Argument_Associations (N);
Mode := First (Pragma_Argument_Associations (N));
-- Extract the mode from the argument list
return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode)));
if Present (Args) then
Mode := First (Pragma_Argument_Associations (N));
return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode)));
-- When SPARK_Mode appears without an argument, the default is ON
else
return SPARK_On;
end if;
end Get_SPARK_Mode_Id;
----------------