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

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

4 files changed, 105 insertions, 24 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 61fd991..52e3732 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -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>
 
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 6fec955..79789b6 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
+               --       <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),
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index f218cdc..511f833 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 4fe6c57..5e532b7 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;
 
    ----------------