From a98838ff82af79fcb85e2b7eafa029267a91cd1f Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 10 Sep 2013 14:43:06 +0000 Subject: [PATCH] sem_prag.adb (Get_SPARK_Mode_Id): Handle the case where the pragma may appear without an argument. 2013-09-10 Hristian Kirtchev * 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 * 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 --- gcc/ada/ChangeLog | 18 +++++++++++ gcc/ada/exp_ch4.adb | 74 +++++++++++++++++++++++++++++++++++--------- gcc/ada/rtsfind.ads | 7 ++++- gcc/ada/sem_prag.adb | 30 +++++++++++++----- 4 files changed, 105 insertions(+), 24 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 61fd991bef2d..52e373235c77 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,21 @@ +2013-09-10 Hristian Kirtchev + + * 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 + + * 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 Iain Sandoe diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 6fec955113ce..79789b6978d3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 + -- + -- exception + -- when others => + -- + -- 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), diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index f218cdc7a2bd..511f83348fca 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -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, diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4fe6c57a5bd0..5e532b7e50ef 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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); + + -- Extract the mode from the argument list - Mode := First (Pragma_Argument_Associations (N)); + if Present (Args) then + Mode := First (Pragma_Argument_Associations (N)); + return Get_SPARK_Mode_Id (Chars (Get_Pragma_Arg (Mode))); - 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; ---------------- -- 2.43.5