+2015-05-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Add_Internal_Interface_Entities): Do no generate
+ freeze nodes for these in ASIS mode, because they lead to
+ elaoration order issues in gigi.
+
+2015-05-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Code
+ cleanup. Use Copy_Subprogram_Spec to create a proper spec.
+ (Analyze_Subprogram_Body_Helper): Code cleanup. Do not
+ prepare a stand alone body for inlining in GNATprove mode
+ when inside a generic. (Body_Has_Contract): Reimplemented.
+ (Build_Subprogram_Declaration): New routine.
+ * sem_ch10.adb (Analyze_Compilation_Unit): Capture global
+ references within generic bodies by loading them.
+ * sem_util.adb (Copy_Parameter_List): Code cleanup.
+ (Copy_Subprogram_Spec): New routine.
+ (Is_Contract_Annotation): New routine.
+ * sem_util.ads (Copy_Subprogram_Spec): New routine.
+ (Is_Contract_Annotation): New routine.
+
+2015-05-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute): Do not analyze the generated
+ body of an expression function when the prefix of attribute
+ 'Access is the body.
+
2015-05-12 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Build_Derived_Enumeration_Type): The anonymous base
Subp_Body :=
Unit_Declaration_Node (Corresponding_Body (Subp_Decl));
- -- Analyze the body of the expression function to freeze
- -- the expression. This takes care of the case where the
- -- 'Access is part of dispatch table initialization and
- -- the generated body of the expression function has not
- -- been analyzed yet.
+ -- The body has already been analyzed when the expression
+ -- function acts as a completion.
- if not Analyzed (Subp_Body) then
+ if Analyzed (Subp_Body) then
+ null;
+
+ -- Attribute 'Access may appear within the generated body
+ -- of the expression function subject to the attribute:
+
+ -- function F is (... F'Access ...);
+
+ -- If the expression function is on the scope stack, then
+ -- the body is currently being analyzed. Do not reanalyze
+ -- it because this will lead to infinite recursion.
+
+ elsif In_Open_Scopes (Subp_Id) then
+ null;
+
+ -- Analyze the body of the expression function to freeze
+ -- the expression. This takes care of the case where the
+ -- 'Access is part of dispatch table initialization and
+ -- the generated body of the expression function has not
+ -- been analyzed yet.
+
+ else
Analyze (Subp_Body);
end if;
end if;
Remove_Context (N);
- -- If this is the main unit and we are generating code, we must check
- -- that all generic units in the context have a body if they need it,
- -- even if they have not been instantiated. In the absence of .ali files
- -- for generic units, we must force the load of the body, just to
- -- produce the proper error if the body is absent. We skip this
- -- verification if the main unit itself is generic.
+ -- When generating code for a non-generic main unit, check that withed
+ -- generic units have a body if they need it, even if the units have not
+ -- been instantiated. Force the load of the bodies to produce the proper
+ -- error if the body is absent. The same applies to GNATprove mode, with
+ -- the added benefit of capturing global references within the generic.
+ -- This in turn allows for proper inlining of subprogram bodies without
+ -- a previous declaration.
if Get_Cunit_Unit_Number (N) = Main_Unit
- and then Operating_Mode = Generate_Code
- and then Expander_Active
+ and then ((Operating_Mode = Generate_Code and then Expander_Active)
+ or else
+ (Operating_Mode = Check_Semantics and then GNATprove_Mode))
then
-- Check whether the source for the body of the unit must be included
-- in a standalone library.
then
Nam := Entity (Name (Item));
- -- Compile generic subprogram, unless it is intrinsic or
+ -- Compile the generic subprogram, unless it is intrinsic or
-- imported so no body is required, or generic package body
-- if the package spec requires a body.
if Present (Renamed_Object (Nam)) then
Un :=
- Load_Unit
- (Load_Name => Get_Body_Name
- (Get_Unit_Name
- (Unit_Declaration_Node
- (Renamed_Object (Nam)))),
- Required => False,
- Subunit => False,
- Error_Node => N,
- Renamings => True);
+ Load_Unit
+ (Load_Name =>
+ Get_Body_Name
+ (Get_Unit_Name
+ (Unit_Declaration_Node
+ (Renamed_Object (Nam)))),
+ Required => False,
+ Subunit => False,
+ Error_Node => N,
+ Renamings => True);
else
Un :=
Load_Unit
- (Load_Name => Get_Body_Name
- (Get_Unit_Name (Item)),
+ (Load_Name =>
+ Get_Body_Name (Get_Unit_Name (Item)),
Required => False,
Subunit => False,
Error_Node => N,
-- locally defined tagged types (or compiling with static
-- dispatch tables generation disabled) the corresponding
-- entry of the secondary dispatch table is filled when
- -- such an entity is frozen.
+ -- such an entity is frozen. This is an expansion activity
+ -- that must be suppressed for ASIS because it leads to
+ -- gigi elaboration issues in annotate mode.
- Set_Has_Delayed_Freeze (New_Subp);
+ if not ASIS_Mode then
+ Set_Has_Delayed_Freeze (New_Subp);
+ end if;
end if;
<<Continue>>
-----------------------------------
procedure Analyze_Component_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (Component_Definition (N));
Id : constant Entity_Id := Defining_Identifier (N);
E : constant Node_Id := Expression (N);
Typ : constant Node_Id :=
then
declare
Act_T : constant Entity_Id := Build_Default_Subtype (T, N);
+
begin
Set_Etype (Id, Act_T);
- Set_Component_Definition (N,
+
+ -- Rewrite the component definition to use the constrained
+ -- subtype.
+
+ Rewrite (Component_Definition (N),
Make_Component_Definition (Loc,
Subtype_Indication => New_Occurrence_Of (Act_T, Loc)));
end;
---------------------------------
procedure Analyze_Expression_Function (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- LocX : constant Source_Ptr := Sloc (Expression (N));
- Expr : constant Node_Id := Expression (N);
- Spec : constant Node_Id := Specification (N);
+ Expr : constant Node_Id := Expression (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ LocX : constant Source_Ptr := Sloc (Expr);
+ Spec : constant Node_Id := Specification (N);
Def_Id : Entity_Id;
Inline_Processing_Required := True;
- -- Create a specification for the generated body. Types and defauts in
- -- the profile are copies of the spec, but new entities must be created
- -- for the unit name and the formals.
+ -- Create a specification for the generated body. This must be done
+ -- prior to the analysis of the initial declaration.
- New_Spec := New_Copy_Tree (Spec);
- Set_Defining_Unit_Name (New_Spec,
- Make_Defining_Identifier (Sloc (Defining_Unit_Name (Spec)),
- Chars (Defining_Unit_Name (Spec))));
-
- if Present (Parameter_Specifications (New_Spec)) then
- declare
- Formal_Spec : Node_Id;
- Def : Entity_Id;
-
- begin
- Formal_Spec := First (Parameter_Specifications (New_Spec));
-
- -- Create a new formal parameter at the same source position
-
- while Present (Formal_Spec) loop
- Def := Defining_Identifier (Formal_Spec);
- Set_Defining_Identifier (Formal_Spec,
- Make_Defining_Identifier (Sloc (Def),
- Chars => Chars (Def)));
- Next (Formal_Spec);
- end loop;
- end;
- end if;
-
- Prev := Current_Entity_In_Scope (Defining_Entity (Spec));
+ New_Spec := Copy_Subprogram_Spec (Spec);
+ Prev := Current_Entity_In_Scope (Defining_Entity (Spec));
-- If there are previous overloadable entities with the same name,
-- check whether any of them is completed by the expression function.
procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Body_Spec : constant Node_Id := Specification (N);
+ Body_Spec : Node_Id := Specification (N);
Body_Id : Entity_Id := Defining_Entity (Body_Spec);
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Conformant : Boolean;
-- Check whether unanalyzed body has an aspect or pragma that may
-- generate a SPARK contract.
+ procedure Build_Subprogram_Declaration;
+ -- Create a matching subprogram declaration for subprogram body N
+
procedure Check_Anonymous_Return;
-- Ada 2005: if a function returns an access type that denotes a task,
-- or a type that contains tasks, we must create a master entity for
-----------------------
function Body_Has_Contract return Boolean is
- Decls : constant List_Id := Declarations (N);
- A_Spec : Node_Id;
- A : Aspect_Id;
- Decl : Node_Id;
- P_Id : Pragma_Id;
+ Decls : constant List_Id := Declarations (N);
+ Item : Node_Id;
begin
- -- Check for unanalyzed aspects in the body that will
- -- generate a contract.
+ -- Check for unanalyzed aspects in the body that will generate a
+ -- contract.
if Present (Aspect_Specifications (N)) then
- A_Spec := First (Aspect_Specifications (N));
- while Present (A_Spec) loop
- A := Get_Aspect_Id (Chars (Identifier (A_Spec)));
-
- if A = Aspect_Contract_Cases or else
- A = Aspect_Depends or else
- A = Aspect_Global or else
- A = Aspect_Pre or else
- A = Aspect_Precondition or else
- A = Aspect_Post or else
- A = Aspect_Postcondition
- then
+ Item := First (Aspect_Specifications (N));
+ while Present (Item) loop
+ if Is_Contract_Annotation (Item) then
return True;
end if;
- Next (A_Spec);
+ Next (Item);
end loop;
end if;
-- Check for pragmas that may generate a contract
if Present (Decls) then
- Decl := First (Decls);
- while Present (Decl) loop
- if Nkind (Decl) = N_Pragma then
- P_Id := Get_Pragma_Id (Pragma_Name (Decl));
-
- if P_Id = Pragma_Contract_Cases or else
- P_Id = Pragma_Depends or else
- P_Id = Pragma_Global or else
- P_Id = Pragma_Pre or else
- P_Id = Pragma_Precondition or else
- P_Id = Pragma_Post or else
- P_Id = Pragma_Postcondition
- then
- return True;
- end if;
+ Item := First (Decls);
+ while Present (Item) loop
+ if Nkind (Item) = N_Pragma
+ and then Is_Contract_Annotation (Item)
+ then
+ return True;
end if;
- Next (Decl);
+ Next (Item);
end loop;
end if;
return False;
end Body_Has_Contract;
+ ----------------------------------
+ -- Build_Subprogram_Declaration --
+ ----------------------------------
+
+ procedure Build_Subprogram_Declaration is
+ Asp : Node_Id;
+ Decl : Node_Id;
+ Subp_Decl : Node_Id;
+
+ begin
+ -- Create a matching subprogram spec using the profile of the body.
+ -- The structure of the tree is identical, but has new entities for
+ -- the defining unit name and formal parameters.
+
+ Subp_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Copy_Subprogram_Spec (Body_Spec));
+
+ -- Relocate the aspects of the subprogram body to the new subprogram
+ -- spec because it acts as the initial declaration.
+ -- ??? what about pragmas
+
+ Move_Aspects (N, To => Subp_Decl);
+ Insert_Before_And_Analyze (N, Subp_Decl);
+
+ -- The analysis of the subprogram spec aspects may introduce pragmas
+ -- that need to be analyzed.
+
+ Decl := Next (Subp_Decl);
+ while Present (Decl) loop
+
+ -- Stop the search for pragmas once the body has been reached as
+ -- this terminates the region where pragmas may appear.
+
+ if Decl = N then
+ exit;
+
+ elsif Nkind (Decl) = N_Pragma then
+ Analyze (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ Spec_Id := Defining_Entity (Subp_Decl);
+ Set_Corresponding_Spec (N, Spec_Id);
+
+ -- Mark the generated spec as a source construct to ensure that all
+ -- calls to it are properly registered in ALI files for GNATprove.
+
+ Set_Comes_From_Source (Spec_Id, True);
+
+ -- If aspect SPARK_Mode was specified on the body, it needs to be
+ -- repeated both on the generated spec and the body.
+
+ Asp := Find_Aspect (Spec_Id, Aspect_SPARK_Mode);
+
+ if Present (Asp) then
+ Asp := New_Copy_Tree (Asp);
+ Set_Analyzed (Asp, False);
+ Set_Aspect_Specifications (N, New_List (Asp));
+ end if;
+
+ -- Ensure that the specs of the subprogram declaration and its body
+ -- are identical, otherwise they will appear non-conformant due to
+ -- rewritings in the default values of formal parameters.
+
+ Body_Spec := Copy_Subprogram_Spec (Body_Spec);
+ Set_Specification (N, Body_Spec);
+ Body_Id := Analyze_Subprogram_Specification (Body_Spec);
+ end Build_Subprogram_Declaration;
+
----------------------------
-- Check_Anonymous_Return --
----------------------------
-- to the spec, leading to legality errors.
and then not Body_Has_Contract
+ and then not Inside_A_Generic
then
- declare
- Body_Spec : constant Node_Id :=
- Copy_Separate_Tree (Specification (N));
- New_Decl : constant Node_Id :=
- Make_Subprogram_Declaration (Loc,
- Copy_Separate_Tree (Specification (N)));
-
- SPARK_Mode_Aspect : Node_Id;
- Aspects : List_Id;
- Prag, Aspect : Node_Id;
-
- begin
- Insert_Before (N, New_Decl);
- Move_Aspects (From => N, To => New_Decl);
-
- -- Mark the newly moved aspects as not analyzed, so that
- -- their effect on New_Decl is properly analyzed.
-
- Aspect := First (Aspect_Specifications (New_Decl));
- while Present (Aspect) loop
- Set_Analyzed (Aspect, False);
- Next (Aspect);
- end loop;
-
- Analyze (New_Decl);
-
- -- The analysis of the generated subprogram declaration
- -- may have introduced pragmas that need to be analyzed.
-
- Prag := Next (New_Decl);
- while Prag /= N loop
- Analyze (Prag);
- Next (Prag);
- end loop;
-
- Spec_Id := Defining_Entity (New_Decl);
-
- -- As Body_Id originally comes from source, mark the new
- -- Spec_Id as such, which is required so that calls to
- -- this subprogram are registered in the local effects
- -- stored in ALI files for GNATprove.
-
- Set_Comes_From_Source (Spec_Id, True);
-
- -- If aspect SPARK_Mode was specified on the body, it
- -- needs to be repeated on the generated decl and the
- -- body. Since the original aspect was moved to the
- -- generated decl, copy it for the body.
-
- if Has_Aspect (Spec_Id, Aspect_SPARK_Mode) then
- SPARK_Mode_Aspect :=
- New_Copy (Find_Aspect (Spec_Id, Aspect_SPARK_Mode));
- Set_Analyzed (SPARK_Mode_Aspect, False);
- Aspects := New_List (SPARK_Mode_Aspect);
- Set_Aspect_Specifications (N, Aspects);
- end if;
-
- Set_Specification (N, Body_Spec);
- Body_Id := Analyze_Subprogram_Specification (Body_Spec);
- Set_Corresponding_Spec (N, Spec_Id);
- end;
+ Build_Subprogram_Declaration;
end if;
end if;
and then Full_Analysis
and then not Inside_A_Generic
and then Present (Spec_Id)
- and then Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Declaration
+ and then Nkind (Unit_Declaration_Node (Spec_Id)) =
+ N_Subprogram_Declaration
and then Can_Be_Inlined_In_GNATprove_Mode (Spec_Id, Body_Id)
and then not Body_Has_Contract
then
if No (First_Formal (Subp_Id)) then
return No_List;
else
- Plist := New_List;
+ Plist := New_List;
Formal := First_Formal (Subp_Id);
while Present (Formal) loop
- Append
- (Make_Parameter_Specification (Loc,
+ Append_To (Plist,
+ Make_Parameter_Specification (Loc,
Defining_Identifier =>
- Make_Defining_Identifier (Sloc (Formal),
- Chars => Chars (Formal)),
- In_Present => In_Present (Parent (Formal)),
- Out_Present => Out_Present (Parent (Formal)),
- Parameter_Type =>
+ Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
+ In_Present => In_Present (Parent (Formal)),
+ Out_Present => Out_Present (Parent (Formal)),
+ Parameter_Type =>
New_Occurrence_Of (Etype (Formal), Loc),
- Expression =>
- New_Copy_Tree (Expression (Parent (Formal)))),
- Plist);
+ Expression =>
+ New_Copy_Tree (Expression (Parent (Formal)))));
Next_Formal (Formal);
end loop;
return Plist;
end Copy_Parameter_List;
+ --------------------------
+ -- Copy_Subprogram_Spec --
+ --------------------------
+
+ function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id is
+ Def_Id : Node_Id;
+ Formal_Spec : Node_Id;
+ Result : Node_Id;
+
+ begin
+ -- The structure of the original tree must be replicated without any
+ -- alterations. Use New_Copy_Tree for this purpose.
+
+ Result := New_Copy_Tree (Spec);
+
+ -- Create a new entity for the defining unit name
+
+ Def_Id := Defining_Unit_Name (Result);
+ Set_Defining_Unit_Name (Result,
+ Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
+
+ -- Create new entities for the formal parameters
+
+ if Present (Parameter_Specifications (Result)) then
+ Formal_Spec := First (Parameter_Specifications (Result));
+ while Present (Formal_Spec) loop
+ Def_Id := Defining_Identifier (Formal_Spec);
+ Set_Defining_Identifier (Formal_Spec,
+ Make_Defining_Identifier (Sloc (Def_Id), Chars (Def_Id)));
+
+ Next (Formal_Spec);
+ end loop;
+ end if;
+
+ return Result;
+ end Copy_Subprogram_Spec;
+
--------------------------------
-- Corresponding_Generic_Type --
--------------------------------
or else Is_Task_Interface (T));
end Is_Concurrent_Interface;
+ -----------------------
+ -- Is_Constant_Bound --
+ -----------------------
+
+ function Is_Constant_Bound (Exp : Node_Id) return Boolean is
+ begin
+ if Compile_Time_Known_Value (Exp) then
+ return True;
+
+ elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
+ return Is_Constant_Object (Entity (Exp))
+ or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
+
+ elsif Nkind (Exp) in N_Binary_Op then
+ return Is_Constant_Bound (Left_Opnd (Exp))
+ and then Is_Constant_Bound (Right_Opnd (Exp))
+ and then Scope (Entity (Exp)) = Standard_Standard;
+
+ else
+ return False;
+ end if;
+ end Is_Constant_Bound;
+
---------------------------
-- Is_Container_Element --
---------------------------
end;
end Is_Container_Element;
- -----------------------
- -- Is_Constant_Bound --
- -----------------------
-
- function Is_Constant_Bound (Exp : Node_Id) return Boolean is
- begin
- if Compile_Time_Known_Value (Exp) then
- return True;
+ ----------------------------
+ -- Is_Contract_Annotation --
+ ----------------------------
- elsif Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
- return Is_Constant_Object (Entity (Exp))
- or else Ekind (Entity (Exp)) = E_Enumeration_Literal;
+ function Is_Contract_Annotation (Item : Node_Id) return Boolean is
+ Nam : Name_Id;
- elsif Nkind (Exp) in N_Binary_Op then
- return Is_Constant_Bound (Left_Opnd (Exp))
- and then Is_Constant_Bound (Right_Opnd (Exp))
- and then Scope (Entity (Exp)) = Standard_Standard;
+ begin
+ if Nkind (Item) = N_Aspect_Specification then
+ Nam := Chars (Identifier (Item));
- else
- return False;
+ else pragma Assert (Nkind (Item) = N_Pragma);
+ Nam := Pragma_Name (Item);
end if;
- end Is_Constant_Bound;
+
+ return
+ Nam = Name_Abstract_State
+ or else Nam = Name_Contract_Cases
+ or else Nam = Name_Depends
+ or else Nam = Name_Extensions_Visible
+ or else Nam = Name_Global
+ or else Nam = Name_Initial_Condition
+ or else Nam = Name_Initializes
+ or else Nam = Name_Post
+ or else Nam = Name_Post_Class
+ or else Nam = Name_Postcondition
+ or else Nam = Name_Pre
+ or else Nam = Name_Pre_Class
+ or else Nam = Name_Precondition
+ or else Nam = Name_Refined_Depends
+ or else Nam = Name_Refined_Global
+ or else Nam = Name_Refined_State
+ or else Nam = Name_Test_Case;
+ end Is_Contract_Annotation;
--------------------------------------
-- Is_Controlling_Limited_Procedure --
-- Depends
-- Global
- function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id;
- -- Utility to create a parameter profile for a new subprogram spec, when
- -- the subprogram has a body that acts as spec. This is done for some cases
- -- of inlining, and for private protected ops. Also used to create bodies
- -- for stubbed subprograms.
-
function Copy_Component_List
(R_Typ : Entity_Id;
Loc : Source_Ptr) return List_Id;
-- create a new compatible record type. Loc is the source location assigned
-- to the created nodes.
+ function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id;
+ -- Utility to create a parameter profile for a new subprogram spec, when
+ -- the subprogram has a body that acts as spec. This is done for some cases
+ -- of inlining, and for private protected ops. Also used to create bodies
+ -- for stubbed subprograms.
+
+ function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id;
+ -- Replicate a function or a procedure specification denoted by Spec. The
+ -- resulting tree is an exact duplicate of the original tree. New entities
+ -- are created for the unit name and the formal parameters.
+
function Corresponding_Generic_Type (T : Entity_Id) return Entity_Id;
-- If a type is a generic actual type, return the corresponding formal in
-- the generic parent unit. There is no direct link in the tree for this
-- explicit dereference. The transformation applies when it has the form
-- F (X).Discr.all.
+ function Is_Contract_Annotation (Item : Node_Id) return Boolean;
+ -- Determine whether aspect specification or pragma Item is a contract
+ -- annotation.
+
function Is_Controlling_Limited_Procedure
(Proc_Nam : Entity_Id) return Boolean;
-- Ada 2005 (AI-345): Determine whether Proc_Nam is a primitive procedure
projects / gcc.git / commitdiff