[multiple changes]
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. From-SVN: r223048
This commit is contained in:
Arnaud Charlet
parent
cb2e147086
commit
8d1fe980a2
|
|
@ -1,3 +1,31 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -10675,13 +10675,31 @@ package body Sem_Attr is
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -1020,16 +1020,18 @@ package body Sem_Ch10 is
|
|||
|
||||
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.
|
||||
|
|
@ -1066,7 +1068,7 @@ package body Sem_Ch10 is
|
|||
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.
|
||||
|
||||
|
|
@ -1080,20 +1082,21 @@ package body Sem_Ch10 is
|
|||
|
||||
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,
|
||||
|
|
|
|||
|
|
@ -1772,9 +1772,13 @@ package body Sem_Ch3 is
|
|||
-- 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>>
|
||||
|
|
@ -1794,7 +1798,7 @@ package body Sem_Ch3 is
|
|||
-----------------------------------
|
||||
|
||||
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 :=
|
||||
|
|
@ -2137,9 +2141,14 @@ package body Sem_Ch3 is
|
|||
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;
|
||||
|
|
|
|||
|
|
@ -268,10 +268,10 @@ package body Sem_Ch6 is
|
|||
---------------------------------
|
||||
|
||||
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;
|
||||
|
||||
|
|
@ -293,36 +293,11 @@ package body Sem_Ch6 is
|
|||
|
||||
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.
|
||||
|
|
@ -2272,7 +2247,7 @@ package body Sem_Ch6 is
|
|||
|
||||
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;
|
||||
|
|
@ -2309,6 +2284,9 @@ package body Sem_Ch6 is
|
|||
-- 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
|
||||
|
|
@ -2486,63 +2464,114 @@ package body Sem_Ch6 is
|
|||
-----------------------
|
||||
|
||||
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 --
|
||||
----------------------------
|
||||
|
|
@ -3221,68 +3250,9 @@ package body Sem_Ch6 is
|
|||
-- 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;
|
||||
|
||||
|
|
@ -3777,7 +3747,8 @@ package body Sem_Ch6 is
|
|||
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
|
||||
|
|
|
|||
|
|
@ -4412,21 +4412,19 @@ package body Sem_Util is
|
|||
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;
|
||||
|
|
@ -4435,6 +4433,43 @@ package body Sem_Util is
|
|||
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 --
|
||||
--------------------------------
|
||||
|
|
@ -10299,6 +10334,29 @@ package body Sem_Util is
|
|||
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 --
|
||||
---------------------------
|
||||
|
|
@ -10478,28 +10536,40 @@ package body Sem_Util is
|
|||
end;
|
||||
end Is_Container_Element;
|
||||
|
||||
-----------------------
|
||||
-- Is_Constant_Bound --
|
||||
-----------------------
|
||||
----------------------------
|
||||
-- Is_Contract_Annotation --
|
||||
----------------------------
|
||||
|
||||
function Is_Contract_Annotation (Item : Node_Id) return Boolean is
|
||||
Nam : Name_Id;
|
||||
|
||||
function Is_Constant_Bound (Exp : Node_Id) return Boolean is
|
||||
begin
|
||||
if Compile_Time_Known_Value (Exp) then
|
||||
return True;
|
||||
if Nkind (Item) = N_Aspect_Specification then
|
||||
Nam := Chars (Identifier (Item));
|
||||
|
||||
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;
|
||||
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 --
|
||||
|
|
|
|||
|
|
@ -397,12 +397,6 @@ package Sem_Util is
|
|||
-- 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;
|
||||
|
|
@ -410,6 +404,17 @@ package Sem_Util is
|
|||
-- 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
|
||||
|
|
@ -1186,6 +1191,10 @@ package Sem_Util is
|
|||
-- 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue