+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>
(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
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;
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),
System_Machine_Code,
System_Mantissa,
System_Memcop,
+ System_Memory,
System_Multiprocessors,
System_Pack_03,
System_Pack_05,
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
RE_Mantissa_Value => System_Mantissa,
+ RE_Free => System_Memory,
+
RE_CPU_Range => System_Multiprocessors,
RE_Bits_03 => System_Pack_03,
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
-- 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);
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
-----------------------
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;
----------------
projects / gcc.git / commitdiff