[Ada] Crash on potential access-before-elaboration in ZFP

Message ID 20171009204748.GA22063@adacore.com
State New
Headers show
Series
  • [Ada] Crash on potential access-before-elaboration in ZFP
Related show

Commit Message

Pierre-Marie de Rodat Oct. 9, 2017, 8:47 p.m.
This patch update the mechanism which retrieves the enclosing scope of a node
to account for blocks produces by exception handler expansion. These blocks are
not scoping constructs and should not be considered. As a result, an access-
before-elaboration check will no longer cause a crash on ZFP.

------------
-- Source --
------------

--  pack.ads

package Pack is
   procedure Force_Body;
end Pack;

--  pack.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Pack is
   procedure Force_Body is begin null; end Force_Body;

   package Nested is
      function Func (Val : Integer) return Integer;
   end Nested;

   package body Nested is
      procedure Proc is
         Val : Integer;

      begin
         Val := Func (1);
         Put_Line ("ERROR: Program_Error not raised");
      exception
         when Program_Error =>
            Put_Line ("OK");
         when others =>
            Put_Line ("ERROR: unexpected exception");
      end Proc;

      package Elaborator is
      end Elaborator;

      package body Elaborator is
      begin
         Proc;
      end Elaborator;

      function Func (Val : Integer) return Integer is
      begin
         return Val + 1;
      end Func;
   end Nested;
end Pack;

-----------------
-- Compilation --
-----------------

$ gcc -c -gnatws --RTS=zfp pack.adb

Tested on x86_64-pc-linux-gnu, committed on trunk

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

	* sem_unit.adb (Find_Enclosing_Scope): Do not treat a block statement
	as a scoping construct when it is byproduct of exception handling.

Patch

Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 253567)
+++ sem_util.adb	(working copy)
@@ -7929,13 +7929,21 @@ 
 
             --  Special cases
 
-            --  Blocks, loops, and return statements have artificial scopes
+            --  Blocks carry either a source or an internally-generated scope,
+            --  unless the block is a byproduct of exception handling.
 
-            when N_Block_Statement
-               | N_Loop_Statement
-            =>
+            when N_Block_Statement =>
+               if not Exception_Junk (Par) then
+                  return Entity (Identifier (Par));
+               end if;
+
+            --  Loops carry an internally-generated scope
+
+            when N_Loop_Statement =>
                return Entity (Identifier (Par));
 
+            --  Extended return statements carry an internally-generated scope
+
             when N_Extended_Return_Statement =>
                return Return_Statement_Entity (Par);
 
@@ -19511,13 +19519,13 @@ 
          N := Next (Actual_Id);
 
          if Nkind (N) = N_Parameter_Association then
+
             --  In case of a build-in-place call, the call will no longer be a
             --  call; it will have been rewritten.
 
-            if Nkind_In (Parent (Actual_Id),
-                         N_Entry_Call_Statement,
-                         N_Function_Call,
-                         N_Procedure_Call_Statement)
+            if Nkind_In (Parent (Actual_Id), N_Entry_Call_Statement,
+                                             N_Function_Call,
+                                             N_Procedure_Call_Statement)
             then
                return First_Named_Actual (Parent (Actual_Id));
             else
@@ -23257,16 +23265,15 @@ 
          return "unknown subprogram";
       end if;
 
+      --  If the subprogram is a child unit, use its simple name to start the
+      --  construction of the fully qualified name.
+
       if Nkind (Ent) = N_Defining_Program_Unit_Name then
-
-         --  If the subprogram is a child unit, use its simple name to
-         --  start the construction of the fully qualified name.
-
          Append_Entity_Name (Buf, Defining_Identifier (Ent));
-
       else
          Append_Entity_Name (Buf, Ent);
       end if;
+
       return +Buf;
    end Subprogram_Name;