This patch introduces a new access-before-elaboration check which attempts to
detect an indirect call to a primitive of a tagged type through dispatching
where the body of the primitive has not been elaborated yet. The check uses a
flag which is set after the body of the primitive is elaborated and verified
within the body itself.
------------
-- Source --
------------
-- pack1.ads
package Pack1 is
type Parent is abstract tagged null record;
function Prim (Obj : Parent) return Boolean is abstract;
function Call_Any_Prim (Obj : Parent'Class) return Boolean;
end Pack1;
-- pack1.adb
package body Pack1 is
function Call_Any_Prim (Obj : Parent'Class) return Boolean is
begin
return Prim (Obj);
end Call_Any_Prim;
end Pack1;
-- pack2.ads
with Pack1; use Pack1;
package Pack2 is
Body_Elaborated : Boolean := False;
type Child is new Parent with record
Flag : Boolean;
end record;
overriding function Prim (Obj : Child) return Boolean;
Obj : Child;
ABE : constant Boolean := Call_Any_Prim (Obj);
end Pack2;
-- pack2.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Pack2 is
function Prim (Obj : Child) return Boolean is
begin
Put_Line ("Prim");
if not Body_Elaborated then
raise Program_Error with "Pack2 not elaborated";
end if;
return Obj.Flag;
end Prim;
begin
Body_Elaborated := True;
Put_Line ("Pack2 elaborated");
end Pack2;
-- main.adb
with Pack2;
procedure Main is begin null; end Main;
----------------------------
-- Compilation and output --
----------------------------
$ gnatmake -q main.adb
$ ./main
raised PROGRAM_ERROR : pack2.adb:4 access before elaboration
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-04-27 Hristian Kirtchev <kirtc...@adacore.com>
* checks.adb Add with and use clauses for Sem_Disp.
(Install_Primitive_Elaboration_Check): New routine.
* checks.ads (Install_Primitive_Elaboration_Check): New routine.
* exp_attr.adb (Expand_N_Attribute_Reference): Clean up the
processing of 'Elaborated.
* exp_ch6.adb (Expand_N_Subprogram_Body): Install a primitive
elaboration check.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 247305)
+++ exp_attr.adb (working copy)
@@ -3025,16 +3025,15 @@
-- Note: The Elaborated attribute is never passed to the back end
when Attribute_Elaborated => Elaborated : declare
- Ent : constant Entity_Id := Entity (Pref);
+ Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref));
begin
- if Present (Elaboration_Entity (Ent)) then
+ if Present (Elab_Id) then
Rewrite (N,
Make_Op_Ne (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Uint_0)));
+ Left_Opnd => New_Occurrence_Of (Elab_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
+
Analyze_And_Resolve (N, Typ);
else
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
Index: checks.adb
===================================================================
--- checks.adb (revision 247320)
+++ checks.adb (working copy)
@@ -48,6 +48,7 @@
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@@ -7734,6 +7735,203 @@
Mark_Non_Null;
end Install_Null_Excluding_Check;
+ -----------------------------------------
+ -- Install_Primitive_Elaboration_Check --
+ -----------------------------------------
+
+ procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is
+
+ function Within_Compilation_Unit_Instance
+ (Subp_Id : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp_Id appears within an instance which
+ -- acts as a compilation unit.
+
+ --------------------------------------
+ -- Within_Compilation_Unit_Instance --
+ --------------------------------------
+
+ function Within_Compilation_Unit_Instance
+ (Subp_Id : Entity_Id) return Boolean
+ is
+ Pack : Entity_Id;
+
+ begin
+ -- Examine the scope chain looking for a compilation-unit-level
+ -- instance.
+
+ Pack := Scope (Subp_Id);
+ while Present (Pack) and then Pack /= Standard_Standard loop
+ if Ekind (Pack) = E_Package
+ and then Is_Generic_Instance (Pack)
+ and then Nkind (Parent (Unit_Declaration_Node (Pack))) =
+ N_Compilation_Unit
+ then
+ return True;
+ end if;
+
+ Pack := Scope (Pack);
+ end loop;
+
+ return False;
+ end Within_Compilation_Unit_Instance;
+
+ -- Local declarations
+
+ Context : constant Node_Id := Parent (Subp_Body);
+ Loc : constant Source_Ptr := Sloc (Subp_Body);
+ Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body);
+ Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
+
+ Decls : List_Id;
+ Flag_Id : Entity_Id;
+ Set_Ins : Node_Id;
+ Tag_Typ : Entity_Id;
+
+ -- Start of processing for Install_Primitive_Elaboration_Check
+
+ begin
+ -- Do not generate an elaboration check in compilation modes where
+ -- expansion is not desirable.
+
+ if ASIS_Mode or GNATprove_Mode then
+ return;
+
+ -- Do not generate an elaboration check if the related subprogram is
+ -- not subjected to accessibility checks.
+
+ elsif Elaboration_Checks_Suppressed (Subp_Id) then
+ return;
+
+ -- Do not consider subprograms which act as compilation units, because
+ -- they cannot be the target of a dispatching call.
+
+ elsif Nkind (Context) = N_Compilation_Unit then
+ return;
+
+ -- Only nonabstract library-level source primitives are considered for
+ -- this check.
+
+ elsif not
+ (Comes_From_Source (Subp_Id)
+ and then Is_Library_Level_Entity (Subp_Id)
+ and then Is_Primitive (Subp_Id)
+ and then not Is_Abstract_Subprogram (Subp_Id))
+ then
+ return;
+
+ -- Do not consider inlined primitives, because once the body is inlined
+ -- the reference to the elaboration flag will be out of place and will
+ -- result in an undefined symbol.
+
+ elsif Is_Inlined (Subp_Id) or else Has_Pragma_Inline (Subp_Id) then
+ return;
+
+ -- Do not generate a duplicate elaboration check. This happens only in
+ -- the case of primitives completed by an expression function, as the
+ -- corresponding body is apparently analyzed and expanded twice.
+
+ elsif Analyzed (Subp_Body) then
+ return;
+
+ -- Do not consider primitives which occur within an instance that acts
+ -- as a compilation unit. Such an instance defines its spec and body out
+ -- of order (body is first) within the tree, which causes the reference
+ -- to the elaboration flag to appear as an undefined symbol.
+
+ elsif Within_Compilation_Unit_Instance (Subp_Id) then
+ return;
+ end if;
+
+ Tag_Typ := Find_Dispatching_Type (Subp_Id);
+
+ -- Only tagged primitives may be the target of a dispatching call
+
+ if No (Tag_Typ) then
+ return;
+
+ -- Do not consider finalization-related primitives, because they may
+ -- need to be called while elaboration is taking place.
+
+ elsif Is_Controlled (Tag_Typ)
+ and then Nam_In (Chars (Subp_Id), Name_Adjust,
+ Name_Finalize,
+ Name_Initialize)
+ then
+ return;
+ end if;
+
+ -- Create the declaration of the elaboration flag. The name carries a
+ -- unique counter in case of name overloading.
+
+ Flag_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Subp_Id), 'F', -1));
+ Set_Is_Frozen (Flag_Id);
+
+ -- Insert the declaration of the elaboration flag in front of the
+ -- primitive spec and analyze it in the proper context.
+
+ Push_Scope (Scope (Subp_Id));
+
+ -- Generate:
+ -- F : Boolean := False;
+
+ Insert_Action (Subp_Decl,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc)));
+ Pop_Scope;
+
+ -- Prevent the compiler from optimizing the elaboration check by killing
+ -- the current value of the flag and the associated assignment.
+
+ Set_Current_Value (Flag_Id, Empty);
+ Set_Last_Assignment (Flag_Id, Empty);
+
+ -- Add a check at the top of the body declarations to ensure that the
+ -- elaboration flag has been set.
+
+ Decls := Declarations (Subp_Body);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Declarations (Subp_Body, Decls);
+ end if;
+
+ -- Generate:
+ -- if not F then
+ -- raise Program_Error with "access before elaboration";
+ -- end if;
+
+ Prepend_To (Decls,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd => New_Occurrence_Of (Flag_Id, Loc)),
+ Reason => PE_Access_Before_Elaboration));
+
+ Analyze (First (Decls));
+
+ -- Set the elaboration flag once the body has been elaborated. Insert
+ -- the statement after the subprogram stub when the primitive body is
+ -- a subunit.
+
+ if Nkind (Context) = N_Subunit then
+ Set_Ins := Corresponding_Stub (Context);
+ else
+ Set_Ins := Subp_Body;
+ end if;
+
+ -- Generate:
+ -- F := True;
+
+ Insert_After_And_Analyze (Set_Ins,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Flag_Id, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)));
+ end Install_Primitive_Elaboration_Check;
+
--------------------------
-- Install_Static_Check --
--------------------------
Index: checks.ads
===================================================================
--- checks.ads (revision 247293)
+++ checks.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -337,6 +337,12 @@
-- Determines whether an access node requires a runtime access check and
-- if so inserts the appropriate run-time check.
+ procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id);
+ -- Insert a check which ensures that subprogram body Subp_Body has been
+ -- properly elaborated. The check is installed only when Subp_Body is the
+ -- body of a nonabstract library-level primitive of a tagged type. Further
+ -- restrictions may apply, see the body for details.
+
function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id;
-- This function is used by top level overflow checking routines to do a
-- mark/release operation on the secondary stack around bignum operations.
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 247293)
+++ exp_ch6.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -5632,6 +5632,13 @@
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
+
+ -- If the body belongs to a nonabstract library-level source primitive
+ -- of a tagged type, install an elaboration check which ensures that a
+ -- dispatching call targeting the primitive will not execute the body
+ -- without it being previously elaborated.
+
+ Install_Primitive_Elaboration_Check (N);
end Expand_N_Subprogram_Body;
-----------------------------------
