[multiple changes]

2013-10-10  Hristian Kirtchev  <kirtchev@adacore.com>

	* aspects.adb: Add entries in table Canonical_Aspects for aspects
	Refined_Depends and Refined_Global.
	* aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument,
	Aspect_Names, Aspect_Declay, Aspect_On_Body_Or_Stub_OK for
	aspects Refined_Depends and Refined_Global.
	* einfo.adb (Contract): Subprogram bodies are now valid owners
	of contracts.
	(Set_Contract): Subprogram bodies are now valid
	owners of contracts.
	(Write_Field24_Name): Output the contract
	attribute for subprogram bodies.
	* exp_ch6.adb (Expand_Subprogram_Contract): New routine.
	* exp_ch6.ads (Expand_Subprogram_Contract): New routine.
	* par-prag.adb: Pragmas Refined_Depends and Refined_Global do
	not require any special processing by the parser.
	* sem_ch3.adb (Adjust_D): Renamed to Adjust_Decl.
	(Analyze_Declarations): Code reformatting. Analyze the contract
	of a subprogram body at the end of the declarative region.
	* sem_ch6.adb (Analyze_Generic_Subprogram_Body):
	Subprogram bodies can now have contracts.  Use
	Expand_Subprogram_Contract to handle the various contract
	assertions.
	(Analyze_Subprogram_Body_Contract): New null routine.
	(Analyze_Subprogram_Body_Helper): Subprogram bodies can now have
	contracts.  Use Expand_Subprogram_Contract to handle the various
	contract assertions.
	(Analyze_Subprogram_Contract): Add local
	variable Nam. Update the call to Analyze_PPC_In_Decl_Part. Capture
	the pragma name in Nam.
	(Process_PPCs): Removed.
	* sem_ch6.ads (Analyze_Subprogram_Body_Contract): New routine.
	(Analyze_Subprogram_Contract): Update the comment on usage.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add null
	implementations for aspects Refined_Depends and Refined_Global.
	(Check_Aspect_At_Freeze_Point): Aspects Refined_Depends and
	Refined_Global do not need to be checked at the freeze point.
	* sem_prag.adb: Add entries in table Sig_Flags
	for pragmas Refined_Depends and Refined_Global.
	(Analyze_Contract_Cases_In_Decl_Part): Add local
	variable Restore. Use Restore to pop the scope.
	(Analyze_Depends_In_Decl_Part): Add local variable Restore. Use
	Restore to pop the scope.
	(Analyze_Global_In_Decl_List): Add local variable Restore. Use Restore
	to pop the scope.
	(Analyze_PPC_In_Decl_Part): Renamed to
	Analyze_Pre_Post_Condition_In_Decl_Part.
	(Analyze_Pragma):
	Add null implementations for pragmas Refined_Depends and
	Refined_Global. Refined_Pre and Refined_Post are now
	handled by routine Analyze_Refined_Pre_Post_Condition
	exclusively.
	(Analyze_Refined_Depends_In_Decl_Part): New
	null routine.
	(Analyze_Refined_Global_In_Decl_Part):
	New null routine.
	(Analyze_Refined_Pre_Post):
	Renamed to Analyze_Refined_Pre_Post_Condition.
	(Analyze_Refined_Pre_Post_Condition): Analyze the boolean
	expression.
	(Check_Precondition_Postcondition): Update the call
	to Analyze_PPC_In_Decl_Part.
	* sem_prag.ads: Add entries in table
	Pragma_On_Body_Or_Stub_OK for pragmas Refined_Depends
	and Refined_Global.
	(Analyze_PPC_In_Decl_Part): Renamed
	to Analyze_Pre_Post_Condition_In_Decl_Part.  Update the
	comment on usage.
	(Analyze_Refined_Depends_In_Decl_Part): New routine.
	(Analyze_Refined_Global_In_Decl_Part): New routine.
	(Analyze_Test_Case_In_Decl_Part): Update the comment on usage.
	* sem_util.adb (Add_Contract_Item): Rename formal Item to Prag
	and update all occurrences.  Subprogram body contracts can now
	contain pragmas Refined_Depends and Refined_Global.
	* sem_util.ads (Add_Contract_Item): Rename formal Item to
	Prag. Update the comment on usage.
	* sinfo.ads: Update the comment on structure and usage of
	N_Contract.
	* snames.ads-tmpl: Add new predefined names for Refined_Depends
	and Refined_Global. Add entries in table Pragma_Id for
	Refined_Depends and Refined_Global.

2013-10-10  Robert Dewar  <dewar@adacore.com>

	* types.ads: Minor reformatting.

From-SVN: r203365
This commit is contained in:
Arnaud Charlet 2013-10-10 14:35:07 +02:00
parent c76bf0bffd
commit ea3c0651d3
18 changed files with 1598 additions and 1231 deletions

View File

@ -1,3 +1,90 @@
2013-10-10 Hristian Kirtchev <kirtchev@adacore.com>
* aspects.adb: Add entries in table Canonical_Aspects for aspects
Refined_Depends and Refined_Global.
* aspects.ads: Add entries in tables Aspect_Id, Aspect_Argument,
Aspect_Names, Aspect_Declay, Aspect_On_Body_Or_Stub_OK for
aspects Refined_Depends and Refined_Global.
* einfo.adb (Contract): Subprogram bodies are now valid owners
of contracts.
(Set_Contract): Subprogram bodies are now valid
owners of contracts.
(Write_Field24_Name): Output the contract
attribute for subprogram bodies.
* exp_ch6.adb (Expand_Subprogram_Contract): New routine.
* exp_ch6.ads (Expand_Subprogram_Contract): New routine.
* par-prag.adb: Pragmas Refined_Depends and Refined_Global do
not require any special processing by the parser.
* sem_ch3.adb (Adjust_D): Renamed to Adjust_Decl.
(Analyze_Declarations): Code reformatting. Analyze the contract
of a subprogram body at the end of the declarative region.
* sem_ch6.adb (Analyze_Generic_Subprogram_Body):
Subprogram bodies can now have contracts. Use
Expand_Subprogram_Contract to handle the various contract
assertions.
(Analyze_Subprogram_Body_Contract): New null routine.
(Analyze_Subprogram_Body_Helper): Subprogram bodies can now have
contracts. Use Expand_Subprogram_Contract to handle the various
contract assertions.
(Analyze_Subprogram_Contract): Add local
variable Nam. Update the call to Analyze_PPC_In_Decl_Part. Capture
the pragma name in Nam.
(Process_PPCs): Removed.
* sem_ch6.ads (Analyze_Subprogram_Body_Contract): New routine.
(Analyze_Subprogram_Contract): Update the comment on usage.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add null
implementations for aspects Refined_Depends and Refined_Global.
(Check_Aspect_At_Freeze_Point): Aspects Refined_Depends and
Refined_Global do not need to be checked at the freeze point.
* sem_prag.adb: Add entries in table Sig_Flags
for pragmas Refined_Depends and Refined_Global.
(Analyze_Contract_Cases_In_Decl_Part): Add local
variable Restore. Use Restore to pop the scope.
(Analyze_Depends_In_Decl_Part): Add local variable Restore. Use
Restore to pop the scope.
(Analyze_Global_In_Decl_List): Add local variable Restore. Use Restore
to pop the scope.
(Analyze_PPC_In_Decl_Part): Renamed to
Analyze_Pre_Post_Condition_In_Decl_Part.
(Analyze_Pragma):
Add null implementations for pragmas Refined_Depends and
Refined_Global. Refined_Pre and Refined_Post are now
handled by routine Analyze_Refined_Pre_Post_Condition
exclusively.
(Analyze_Refined_Depends_In_Decl_Part): New
null routine.
(Analyze_Refined_Global_In_Decl_Part):
New null routine.
(Analyze_Refined_Pre_Post):
Renamed to Analyze_Refined_Pre_Post_Condition.
(Analyze_Refined_Pre_Post_Condition): Analyze the boolean
expression.
(Check_Precondition_Postcondition): Update the call
to Analyze_PPC_In_Decl_Part.
* sem_prag.ads: Add entries in table
Pragma_On_Body_Or_Stub_OK for pragmas Refined_Depends
and Refined_Global.
(Analyze_PPC_In_Decl_Part): Renamed
to Analyze_Pre_Post_Condition_In_Decl_Part. Update the
comment on usage.
(Analyze_Refined_Depends_In_Decl_Part): New routine.
(Analyze_Refined_Global_In_Decl_Part): New routine.
(Analyze_Test_Case_In_Decl_Part): Update the comment on usage.
* sem_util.adb (Add_Contract_Item): Rename formal Item to Prag
and update all occurrences. Subprogram body contracts can now
contain pragmas Refined_Depends and Refined_Global.
* sem_util.ads (Add_Contract_Item): Rename formal Item to
Prag. Update the comment on usage.
* sinfo.ads: Update the comment on structure and usage of
N_Contract.
* snames.ads-tmpl: Add new predefined names for Refined_Depends
and Refined_Global. Add entries in table Pragma_Id for
Refined_Depends and Refined_Global.
2013-10-10 Robert Dewar <dewar@adacore.com>
* types.ads: Minor reformatting.
2013-10-10 Thomas Quinot <quinot@adacore.com>
* s-taprop-posix.adb: Add missing comment.

View File

@ -466,6 +466,8 @@ package body Aspects is
Aspect_Pure_05 => Aspect_Pure_05,
Aspect_Pure_12 => Aspect_Pure_12,
Aspect_Pure_Function => Aspect_Pure_Function,
Aspect_Refined_Depends => Aspect_Refined_Depends,
Aspect_Refined_Global => Aspect_Refined_Global,
Aspect_Refined_Post => Aspect_Refined_Post,
Aspect_Refined_Pre => Aspect_Refined_Pre,
Aspect_Remote_Access_Type => Aspect_Remote_Access_Type,

View File

@ -111,6 +111,8 @@ package Aspects is
Aspect_Predicate, -- GNAT
Aspect_Priority,
Aspect_Read,
Aspect_Refined_Depends, -- GNAT
Aspect_Refined_Global, -- GNAT
Aspect_Refined_Post, -- GNAT
Aspect_Refined_Pre, -- GNAT
Aspect_Relative_Deadline,
@ -321,6 +323,8 @@ package Aspects is
Aspect_Predicate => Expression,
Aspect_Priority => Expression,
Aspect_Read => Name,
Aspect_Refined_Depends => Expression,
Aspect_Refined_Global => Expression,
Aspect_Refined_Post => Expression,
Aspect_Refined_Pre => Expression,
Aspect_Relative_Deadline => Expression,
@ -419,6 +423,8 @@ package Aspects is
Aspect_Pure_12 => Name_Pure_12,
Aspect_Pure_Function => Name_Pure_Function,
Aspect_Read => Name_Read,
Aspect_Refined_Depends => Name_Refined_Depends,
Aspect_Refined_Global => Name_Refined_Global,
Aspect_Refined_Post => Name_Refined_Post,
Aspect_Refined_Pre => Name_Refined_Pre,
Aspect_Relative_Deadline => Name_Relative_Deadline,
@ -612,6 +618,8 @@ package Aspects is
Aspect_Pure_12 => Always_Delay,
Aspect_Pure_Function => Always_Delay,
Aspect_Read => Always_Delay,
Aspect_Refined_Depends => Always_Delay,
Aspect_Refined_Global => Always_Delay,
Aspect_Relative_Deadline => Always_Delay,
Aspect_Remote_Access_Type => Always_Delay,
Aspect_Remote_Call_Interface => Always_Delay,
@ -703,7 +711,9 @@ package Aspects is
-- Sem_Prag if the aspects below are implemented by a pragma.
Aspect_On_Body_Or_Stub_OK : constant array (Aspect_Id) of Boolean :=
(Aspect_Refined_Post => True,
(Aspect_Refined_Depends => True,
Aspect_Refined_Global => True,
Aspect_Refined_Post => True,
Aspect_Refined_Pre => True,
Aspect_SPARK_Mode => True,
Aspect_Warnings => True,

View File

@ -1065,7 +1065,7 @@ package body Einfo is
function Contract (Id : E) return N is
begin
pragma Assert
(Ekind_In (Id, E_Entry, E_Entry_Family)
(Ekind_In (Id, E_Entry, E_Entry_Family, E_Subprogram_Body)
or else Is_Subprogram (Id)
or else Is_Generic_Subprogram (Id));
return Node24 (Id);
@ -3651,7 +3651,7 @@ package body Einfo is
procedure Set_Contract (Id : E; V : N) is
begin
pragma Assert
(Ekind_In (Id, E_Entry, E_Entry_Family, E_Void)
(Ekind_In (Id, E_Entry, E_Entry_Family, E_Subprogram_Body, E_Void)
or else Is_Subprogram (Id)
or else Is_Generic_Subprogram (Id));
Set_Node24 (Id, V);
@ -9012,10 +9012,15 @@ package body Einfo is
when E_Entry |
E_Entry_Family |
E_Subprogram_Body |
Subprogram_Kind |
Generic_Subprogram_Kind =>
Write_Str ("Contract");
-- The Subprogram_Kind and Generic_Subrpogram_Kind entries
-- here are odd, since the assertions for [Set_]Contract do not
-- allow these possibilities ???
when others =>
Write_Str ("Field24???");
end case;

File diff suppressed because it is too large Load Diff

View File

@ -82,6 +82,18 @@ package Exp_Ch6 is
-- Subp_Id's body. All generated code is added to list Stmts. If Stmts is
-- empty, a new list is created.
procedure Expand_Subprogram_Contract
(N : Node_Id;
Spec_Id : Entity_Id;
Body_Id : Entity_Id);
-- Expand the contracts of a subprogram body and its correspoding spec (if
-- any). This routine processes all [refined] pre- and postconditions as
-- well as Contract_Cases, invariants and predicates. N is the body of the
-- subprogram. Spec_Id denotes the entity of its specification. Body_Id
-- denotes the entity of the subprogram body. This routine is not a "pure"
-- expansion mechanism as it is invoked during analysis and may perform
-- actions for generic subprograms or set up contract assertions for ASIS.
procedure Freeze_Subprogram (N : Node_Id);
-- generate the appropriate expansions related to Subprogram freeze
-- nodes (e.g. the filling of the corresponding Dispatch Table for

View File

@ -1250,6 +1250,8 @@ begin
Pragma_Pure_12 |
Pragma_Pure_Function |
Pragma_Queuing_Policy |
Pragma_Refined_Depends |
Pragma_Refined_Global |
Pragma_Refined_Post |
Pragma_Refined_Pre |
Pragma_Relative_Deadline |

View File

@ -1928,6 +1928,20 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_SPARK_Mode);
-- Refined_Depends
-- ??? To be implemented
when Aspect_Refined_Depends =>
null;
-- Refined_Global
-- ??? To be implemented
when Aspect_Refined_Global =>
null;
-- Refined_Post
when Aspect_Refined_Post =>
@ -7962,6 +7976,8 @@ package body Sem_Ch13 is
Aspect_Postcondition |
Aspect_Pre |
Aspect_Precondition |
Aspect_Refined_Depends |
Aspect_Refined_Global |
Aspect_Refined_Post |
Aspect_Refined_Pre |
Aspect_SPARK_Mode |

View File

@ -2056,28 +2056,31 @@ package body Sem_Ch3 is
--------------------------
procedure Analyze_Declarations (L : List_Id) is
D : Node_Id;
Freeze_From : Entity_Id := Empty;
Next_Node : Node_Id;
Decl : Node_Id;
procedure Adjust_D;
-- Adjust D not to include implicit label declarations, since these
procedure Adjust_Decl;
-- Adjust Decl not to include implicit label declarations, since these
-- have strange Sloc values that result in elaboration check problems.
-- (They have the sloc of the label as found in the source, and that
-- is ahead of the current declarative part).
--------------
-- Adjust_D --
--------------
-----------------
-- Adjust_Decl --
-----------------
procedure Adjust_D is
procedure Adjust_Decl is
begin
while Present (Prev (D))
and then Nkind (D) = N_Implicit_Label_Declaration
while Present (Prev (Decl))
and then Nkind (Decl) = N_Implicit_Label_Declaration
loop
Prev (D);
Prev (Decl);
end loop;
end Adjust_D;
end Adjust_Decl;
-- Local variables
Freeze_From : Entity_Id := Empty;
Next_Decl : Node_Id;
-- Start of processing for Analyze_Declarations
@ -2086,23 +2089,23 @@ package body Sem_Ch3 is
Check_Later_Vs_Basic_Declarations (L, During_Parsing => False);
end if;
D := First (L);
while Present (D) loop
Decl := First (L);
while Present (Decl) loop
-- Package spec cannot contain a package declaration in SPARK
if Nkind (D) = N_Package_Declaration
if Nkind (Decl) = N_Package_Declaration
and then Nkind (Parent (L)) = N_Package_Specification
then
Check_SPARK_Restriction
("package specification cannot contain a package declaration",
D);
Decl);
end if;
-- Complete analysis of declaration
Analyze (D);
Next_Node := Next (D);
Analyze (Decl);
Next_Decl := Next (Decl);
if No (Freeze_From) then
Freeze_From := First_Entity (Current_Scope);
@ -2124,7 +2127,7 @@ package body Sem_Ch3 is
-- be a freeze point once delayed freezing of bodies is implemented.
-- (This is needed in any case for early instantiations ???).
if No (Next_Node) then
if No (Next_Decl) then
if Nkind_In (Parent (L), N_Component_List,
N_Task_Definition,
N_Protected_Definition)
@ -2136,8 +2139,8 @@ package body Sem_Ch3 is
Freeze_From := First_Entity (Current_Scope);
end if;
Adjust_D;
Freeze_All (Freeze_From, D);
Adjust_Decl;
Freeze_All (Freeze_From, Decl);
Freeze_From := Last_Entity (Current_Scope);
elsif Scope (Current_Scope) /= Standard_Standard
@ -2150,8 +2153,8 @@ package body Sem_Ch3 is
or else No (Private_Declarations (Parent (L)))
or else Is_Empty_List (Private_Declarations (Parent (L)))
then
Adjust_D;
Freeze_All (Freeze_From, D);
Adjust_Decl;
Freeze_All (Freeze_From, Decl);
Freeze_From := Last_Entity (Current_Scope);
end if;
@ -2170,44 +2173,39 @@ package body Sem_Ch3 is
-- care to attach the bodies at a proper place in the tree so as to
-- not cause unwanted freezing at that point.
elsif not Analyzed (Next_Node)
and then (Nkind_In (Next_Node, N_Subprogram_Body,
elsif not Analyzed (Next_Decl)
and then (Nkind_In (Next_Decl, N_Subprogram_Body,
N_Entry_Body,
N_Package_Body,
N_Protected_Body,
N_Task_Body)
or else
Nkind (Next_Node) in N_Body_Stub)
Nkind (Next_Decl) in N_Body_Stub)
then
Adjust_D;
Freeze_All (Freeze_From, D);
Adjust_Decl;
Freeze_All (Freeze_From, Decl);
Freeze_From := Last_Entity (Current_Scope);
end if;
D := Next_Node;
Decl := Next_Decl;
end loop;
-- One more thing to do, we need to scan the declarations to check for
-- any precondition/postcondition pragmas (Pre/Post aspects have by this
-- stage been converted into corresponding pragmas). It is at this point
-- that we analyze the expressions in such pragmas, to implement the
-- delayed visibility requirement.
-- Analyze the contracts of a subprogram declaration or a body now due
-- to delayed visibility requirements of aspects.
declare
Decl : Node_Id;
Subp_Id : Entity_Id;
Decl := First (L);
while Present (Decl) loop
if Nkind (Decl) = N_Subprogram_Body then
Analyze_Subprogram_Body_Contract
(Defining_Unit_Name (Specification (Decl)));
begin
Decl := First (L);
while Present (Decl) loop
if Nkind (Decl) = N_Subprogram_Declaration then
Subp_Id := Defining_Unit_Name (Specification (Decl));
Analyze_Subprogram_Contract (Subp_Id);
end if;
elsif Nkind (Decl) = N_Subprogram_Declaration then
Analyze_Subprogram_Contract
(Defining_Unit_Name (Specification (Decl)));
end if;
Next (Decl);
end loop;
end;
Next (Decl);
end loop;
end Analyze_Declarations;
-----------------------------------

File diff suppressed because it is too large Load Diff

View File

@ -46,9 +46,21 @@ package Sem_Ch6 is
procedure Analyze_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Subprogram_Body (N : Node_Id);
procedure Analyze_Subprogram_Body_Contract (Subp : Entity_Id);
-- Analyze all delayed aspects chained on the contract of subprogram body
-- Subp as if they appeared at the end of a declarative region. The aspects
-- in question are:
-- Refined_Depends
-- Refined_Global
procedure Analyze_Subprogram_Contract (Subp : Entity_Id);
-- Analyze all delayed aspects chained on the contract of subprogram Subp
-- as if they appeared at the end of a declarative region.
-- as if they appeared at the end of a declarative region. The aspects in
-- question are:
-- Contract_Cases
-- Postcondition
-- Precondition
-- Test_Case
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id;
-- Analyze subprogram specification in both subprogram declarations

View File

@ -404,6 +404,7 @@ package body Sem_Prag is
Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
All_Cases : Node_Id;
CCase : Node_Id;
Restore : Boolean := False;
Subp_Decl : Node_Id;
Subp_Id : Entity_Id;
@ -431,6 +432,7 @@ package body Sem_Prag is
-- for subprogram bodies because the formals are already visible.
if Requires_Profile_Installation (N, Subp_Decl) then
Restore := True;
Push_Scope (Subp_Id);
Install_Formals (Subp_Id);
end if;
@ -441,7 +443,7 @@ package body Sem_Prag is
Next (CCase);
end loop;
if Requires_Profile_Installation (N, Subp_Decl) then
if Restore then
End_Scope;
end if;
end if;
@ -1234,6 +1236,9 @@ package body Sem_Prag is
Last_Clause : Node_Id;
Subp_Decl : Node_Id;
Restore_Scope : Boolean := False;
-- Gets set True if we do a Push_Scope needing a Pop_Scope on exit
-- Start of processing for Analyze_Depends_In_Decl_Part
begin
@ -1287,6 +1292,7 @@ package body Sem_Prag is
-- bodies because the formals are already visible.
if Requires_Profile_Installation (N, Subp_Decl) then
Restore_Scope := True;
Push_Scope (Subp_Id);
Install_Formals (Subp_Id);
end if;
@ -1317,7 +1323,7 @@ package body Sem_Prag is
Next (Clause);
end loop;
if Requires_Profile_Installation (N, Subp_Decl) then
if Restore_Scope then
End_Scope;
end if;
@ -1690,6 +1696,9 @@ package body Sem_Prag is
List : Node_Id;
Subp_Decl : Node_Id;
Restore_Scope : Boolean := False;
-- Set True if we do a Push_Scope requiring a Pop_Scope on exit
-- Start of processing for Analyze_Global_In_Decl_List
begin
@ -1714,171 +1723,19 @@ package body Sem_Prag is
-- subprogram declarations.
if Requires_Profile_Installation (N, Subp_Decl) then
Restore_Scope := True;
Push_Scope (Subp_Id);
Install_Formals (Subp_Id);
end if;
Analyze_Global_List (List);
if Requires_Profile_Installation (N, Subp_Decl) then
if Restore_Scope then
End_Scope;
end if;
end if;
end Analyze_Global_In_Decl_Part;
------------------------------
-- Analyze_PPC_In_Decl_Part --
------------------------------
procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is
Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
begin
-- Install formals and push subprogram spec onto scope stack so that we
-- can see the formals from the pragma.
Install_Formals (S);
Push_Scope (S);
-- Preanalyze the boolean expression, we treat this as a spec expression
-- (i.e. similar to a default expression).
-- In ASIS mode, for a pragma generated from a source aspect, analyze
-- directly the the original aspect expression, which is shared with
-- the generated pragma.
if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
Preanalyze_Assert_Expression
(Expression (Corresponding_Aspect (N)), Standard_Boolean);
else
Preanalyze_Assert_Expression
(Get_Pragma_Arg (Arg1), Standard_Boolean);
end if;
-- For a class-wide condition, a reference to a controlling formal must
-- be interpreted as having the class-wide type (or an access to such)
-- so that the inherited condition can be properly applied to any
-- overriding operation (see ARM12 6.6.1 (7)).
if Class_Present (N) then
Class_Wide_Condition : declare
T : constant Entity_Id := Find_Dispatching_Type (S);
ACW : Entity_Id := Empty;
-- Access to T'class, created if there is a controlling formal
-- that is an access parameter.
function Get_ACW return Entity_Id;
-- If the expression has a reference to an controlling access
-- parameter, create an access to T'class for the necessary
-- conversions if one does not exist.
function Process (N : Node_Id) return Traverse_Result;
-- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
-- aspect for a primitive subprogram of a tagged type T, a name
-- that denotes a formal parameter of type T is interpreted as
-- having type T'Class. Similarly, a name that denotes a formal
-- accessparameter of type access-to-T is interpreted as having
-- type access-to-T'Class. This ensures the expression is well-
-- defined for a primitive subprogram of a type descended from T.
-- Note that this replacement is not done for selector names in
-- parameter associations. These carry an entity for reference
-- purposes, but semantically they are just identifiers.
-------------
-- Get_ACW --
-------------
function Get_ACW return Entity_Id is
Loc : constant Source_Ptr := Sloc (N);
Decl : Node_Id;
begin
if No (ACW) then
Decl := Make_Full_Type_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'T'),
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Class_Wide_Type (T), Loc),
All_Present => True));
Insert_Before (Unit_Declaration_Node (S), Decl);
Analyze (Decl);
ACW := Defining_Identifier (Decl);
Freeze_Before (Unit_Declaration_Node (S), ACW);
end if;
return ACW;
end Get_ACW;
-------------
-- Process --
-------------
function Process (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id;
begin
if Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Formal (Entity (N))
and then Nkind (Parent (N)) /= N_Type_Conversion
and then
(Nkind (Parent (N)) /= N_Parameter_Association
or else N /= Selector_Name (Parent (N)))
then
if Etype (Entity (N)) = T then
Typ := Class_Wide_Type (T);
elsif Is_Access_Type (Etype (Entity (N)))
and then Designated_Type (Etype (Entity (N))) = T
then
Typ := Get_ACW;
else
Typ := Empty;
end if;
if Present (Typ) then
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Typ, Loc),
Expression => New_Occurrence_Of (Entity (N), Loc)));
Set_Etype (N, Typ);
end if;
end if;
return OK;
end Process;
procedure Replace_Type is new Traverse_Proc (Process);
-- Start of processing for Class_Wide_Condition
begin
if not Present (T) then
Error_Msg_Name_1 :=
Chars (Identifier (Corresponding_Aspect (N)));
Error_Msg_Name_2 := Name_Class;
Error_Msg_N
("aspect `%''%` can only be specified for a primitive "
& "operation of a tagged type", Corresponding_Aspect (N));
end if;
Replace_Type (Get_Pragma_Arg (Arg1));
end Class_Wide_Condition;
end if;
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the precondition/postcondition is done.
End_Scope;
end Analyze_PPC_In_Decl_Part;
--------------------
-- Analyze_Pragma --
--------------------
@ -1922,15 +1779,9 @@ package body Sem_Prag is
-- In Ada 95 or 05 mode, these are implementation defined pragmas, so
-- should be caught by the No_Implementation_Pragmas restriction.
procedure Analyze_Refined_Pre_Post
(Body_Decl : out Node_Id;
Spec_Id : out Entity_Id;
Legal : out Boolean);
procedure Analyze_Refined_Pre_Post_Condition;
-- Subsidiary routine to the analysis of pragmas Refined_Pre and
-- Refined_Post. Body_Decl is the declaration of the subprogram body
-- [stub] subject to the pragma. Spec_Id is the corresponding spec of
-- the subprogram body [stub]. Flag Legal denotes whether the pragma
-- passes all legality rules.
-- Refined_Post.
procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada
@ -2458,26 +2309,18 @@ package body Sem_Prag is
end if;
end Ada_2012_Pragma;
------------------------------
-- Analyze_Refined_Pre_Post --
------------------------------
----------------------------------------
-- Analyze_Refined_Pre_Post_Condition --
----------------------------------------
procedure Analyze_Refined_Pre_Post
(Body_Decl : out Node_Id;
Spec_Id : out Entity_Id;
Legal : out Boolean)
is
procedure Analyze_Refined_Pre_Post_Condition is
Body_Decl : Node_Id := Parent (N);
Pack_Spec : Node_Id;
Spec_Decl : Node_Id;
Spec_Id : Entity_Id;
Stmt : Node_Id;
begin
-- Assume that the pragma is illegal
Body_Decl := Parent (N);
Spec_Id := Empty;
Legal := False;
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
@ -2576,10 +2419,10 @@ package body Sem_Prag is
return;
end if;
-- If we get here, the placement and legality of the pragma is OK
-- Analyze the boolean expression as a "spec expression"
Legal := True;
end Analyze_Refined_Pre_Post;
Analyze_Pre_Post_Condition_In_Decl_Part (N, Spec_Id);
end Analyze_Refined_Pre_Post_Condition;
--------------------------
-- Check_Ada_83_Warning --
@ -3791,7 +3634,7 @@ package body Sem_Prag is
-- analyzed.
if SPARK_Mode or else ASIS_Mode then
Analyze_PPC_In_Decl_Part
Analyze_Pre_Post_Condition_In_Decl_Part
(N, Defining_Entity (Unit (Parent (PO))));
end if;
@ -16092,32 +15935,35 @@ package body Sem_Prag is
when Pragma_Rational =>
Set_Rational_Profile;
---------------------
-- Refined_Depends --
---------------------
-- ??? To be implemented
when Pragma_Refined_Depends =>
null;
--------------------
-- Refined_Global --
--------------------
-- ??? To be implemented
-- Would be better if these generated an error message saying that
-- the feature was not yet implemented ???
when Pragma_Refined_Global =>
null;
------------------
-- Refined_Post --
------------------
-- pragma Refined_Post (boolean_EXPRESSION);
when Pragma_Refined_Post => Refined_Post : declare
Body_Decl : Node_Id;
Legal : Boolean;
Spec_Id : Entity_Id;
begin
-- Verify the legal placement of the pragma. The pragma is left
-- intentionally semi-analyzed. Process_PPCs does the remaining
-- analysis of the expression when Refined_Post is converted into
-- pragma Check.
Analyze_Refined_Pre_Post (Body_Decl, Spec_Id, Legal);
-- Analyze the expression when code generation is disabled because
-- the contract of the related subprogram will never be processed.
if Legal and then not Expander_Active then
Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean);
end if;
end Refined_Post;
when Pragma_Refined_Post =>
Analyze_Refined_Pre_Post_Condition;
-----------------
-- Refined_Pre --
@ -16125,48 +15971,8 @@ package body Sem_Prag is
-- pragma Refined_Pre (boolean_EXPRESSION);
when Pragma_Refined_Pre => Refined_Pre : declare
Body_Decl : Node_Id;
Legal : Boolean;
Restore : Boolean := False;
Spec_Id : Entity_Id;
begin
Analyze_Refined_Pre_Post (Body_Decl, Spec_Id, Legal);
if Legal then
pragma Assert (Present (Body_Decl));
pragma Assert (Present (Spec_Id));
if Nkind (Body_Decl) = N_Subprogram_Body_Stub
and then No (Library_Unit (Body_Decl))
and then Current_Scope /= Spec_Id
then
Restore := True;
Push_Scope (Spec_Id);
Install_Formals (Spec_Id);
end if;
-- Convert pragma Refined_Pre into pragma Check. The analysis
-- of the generated pragma will take care of the expression.
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Pname)),
Make_Pragma_Argument_Association (Sloc (Arg1),
Expression => Relocate_Node (Get_Pragma_Arg (Arg1))))));
Analyze (N);
if Restore then
Pop_Scope;
end if;
end if;
end Refined_Pre;
when Pragma_Refined_Pre =>
Analyze_Refined_Pre_Post_Condition;
-----------------------
-- Relative_Deadline --
@ -18499,6 +18305,195 @@ package body Sem_Prag is
when Pragma_Exit => null;
end Analyze_Pragma;
---------------------------------------------
-- Analyze_Pre_Post_Condition_In_Decl_Part --
---------------------------------------------
procedure Analyze_Pre_Post_Condition_In_Decl_Part
(Prag : Node_Id;
Subp_Id : Entity_Id)
is
Arg1 : constant Node_Id :=
First (Pragma_Argument_Associations (Prag));
Expr : Node_Id;
Restore : Boolean := False;
begin
-- Ensure that the subprogram and its formals are visible when analyzing
-- the expression of the pragma.
if Current_Scope /= Subp_Id then
Restore := True;
Push_Scope (Subp_Id);
Install_Formals (Subp_Id);
end if;
-- Preanalyze the boolean expression, we treat this as a spec expression
-- (i.e. similar to a default expression).
Expr := Get_Pragma_Arg (Arg1);
-- In ASIS mode, for a pragma generated from a source aspect, analyze
-- the original aspect expression, which is shared with the generated
-- pragma.
if ASIS_Mode and then Present (Corresponding_Aspect (Prag)) then
Expr := Expression (Corresponding_Aspect (Prag));
end if;
Preanalyze_Assert_Expression (Expr, Standard_Boolean);
-- For a class-wide condition, a reference to a controlling formal must
-- be interpreted as having the class-wide type (or an access to such)
-- so that the inherited condition can be properly applied to any
-- overriding operation (see ARM12 6.6.1 (7)).
if Class_Present (Prag) then
Class_Wide_Condition : declare
T : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
ACW : Entity_Id := Empty;
-- Access to T'class, created if there is a controlling formal
-- that is an access parameter.
function Get_ACW return Entity_Id;
-- If the expression has a reference to an controlling access
-- parameter, create an access to T'class for the necessary
-- conversions if one does not exist.
function Process (N : Node_Id) return Traverse_Result;
-- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
-- aspect for a primitive subprogram of a tagged type T, a name
-- that denotes a formal parameter of type T is interpreted as
-- having type T'Class. Similarly, a name that denotes a formal
-- accessparameter of type access-to-T is interpreted as having
-- type access-to-T'Class. This ensures the expression is well-
-- defined for a primitive subprogram of a type descended from T.
-- Note that this replacement is not done for selector names in
-- parameter associations. These carry an entity for reference
-- purposes, but semantically they are just identifiers.
-------------
-- Get_ACW --
-------------
function Get_ACW return Entity_Id is
Loc : constant Source_Ptr := Sloc (Prag);
Decl : Node_Id;
begin
if No (ACW) then
Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'T'),
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Class_Wide_Type (T), Loc),
All_Present => True));
Insert_Before (Unit_Declaration_Node (Subp_Id), Decl);
Analyze (Decl);
ACW := Defining_Identifier (Decl);
Freeze_Before (Unit_Declaration_Node (Subp_Id), ACW);
end if;
return ACW;
end Get_ACW;
-------------
-- Process --
-------------
function Process (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id;
begin
if Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Formal (Entity (N))
and then Nkind (Parent (N)) /= N_Type_Conversion
and then
(Nkind (Parent (N)) /= N_Parameter_Association
or else N /= Selector_Name (Parent (N)))
then
if Etype (Entity (N)) = T then
Typ := Class_Wide_Type (T);
elsif Is_Access_Type (Etype (Entity (N)))
and then Designated_Type (Etype (Entity (N))) = T
then
Typ := Get_ACW;
else
Typ := Empty;
end if;
if Present (Typ) then
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Typ, Loc),
Expression => New_Occurrence_Of (Entity (N), Loc)));
Set_Etype (N, Typ);
end if;
end if;
return OK;
end Process;
procedure Replace_Type is new Traverse_Proc (Process);
-- Start of processing for Class_Wide_Condition
begin
if not Present (T) then
Error_Msg_Name_1 :=
Chars (Identifier (Corresponding_Aspect (Prag)));
Error_Msg_Name_2 := Name_Class;
Error_Msg_N
("aspect `%''%` can only be specified for a primitive "
& "operation of a tagged type", Corresponding_Aspect (Prag));
end if;
Replace_Type (Get_Pragma_Arg (Arg1));
end Class_Wide_Condition;
end if;
-- Remove the subprogram from the scope stack now that the pre-analysis
-- of the precondition/postcondition is done.
if Restore then
End_Scope;
end if;
end Analyze_Pre_Post_Condition_In_Decl_Part;
------------------------------------------
-- Analyze_Refined_Depends_In_Decl_Part --
------------------------------------------
-- ??? To be implemented
procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
pragma Unreferenced (N);
begin
null;
end Analyze_Refined_Depends_In_Decl_Part;
-----------------------------------------
-- Analyze_Refined_Global_In_Decl_Part --
-----------------------------------------
-- ??? To be implemented
procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id) is
pragma Unreferenced (N);
begin
null;
end Analyze_Refined_Global_In_Decl_Part;
------------------------------------
-- Analyze_Test_Case_In_Decl_Part --
------------------------------------
@ -19251,6 +19246,8 @@ package body Sem_Prag is
Pragma_Queuing_Policy => -1,
Pragma_Rational => -1,
Pragma_Ravenscar => -1,
Pragma_Refined_Depends => -1,
Pragma_Refined_Global => -1,
Pragma_Refined_Post => -1,
Pragma_Refined_Pre => -1,
Pragma_Relative_Deadline => -1,

View File

@ -38,11 +38,13 @@ package Sem_Prag is
-- the pragmas below implement an aspect.
Pragma_On_Body_Or_Stub_OK : constant array (Pragma_Id) of Boolean :=
(Pragma_Refined_Post => True,
Pragma_Refined_Pre => True,
Pragma_SPARK_Mode => True,
Pragma_Warnings => True,
others => False);
(Pragma_Refined_Depends => True,
Pragma_Refined_Global => True,
Pragma_Refined_Post => True,
Pragma_Refined_Pre => True,
Pragma_SPARK_Mode => True,
Pragma_Warnings => True,
others => False);
-----------------
-- Subprograms --
@ -60,21 +62,27 @@ package Sem_Prag is
procedure Analyze_Global_In_Decl_Part (N : Node_Id);
-- Perform full analysis of delayed pragma Global
procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id);
-- Special analyze routine for precondition/postcondition pragma that
-- appears within a declarative part where the pragma is associated
-- with a subprogram specification. N is the pragma node, and S is the
-- entity for the related subprogram. This procedure does a preanalysis
-- of the expressions in the pragma as "spec expressions" (see section
-- in Sem "Handling of Default and Per-Object Expressions...").
procedure Analyze_Pre_Post_Condition_In_Decl_Part
(Prag : Node_Id;
Subp_Id : Entity_Id);
-- Perform preanalysis of a [refined] precondition or postcondition that
-- appears on a subprogram declaration or body [stub]. Prag denotes the
-- pragma, Subp_Id is the entity of the related subprogram. The preanalysis
-- of the expression is done as "spec expression" (see section "Handling
-- of Default and Per-Object Expressions in Sem).
procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id);
-- Preform full analysis of delayed pragma Refined_Depends
procedure Analyze_Refined_Global_In_Decl_Part (N : Node_Id);
-- Perform full analysis of delayed pragma Refined_Global
procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id; S : Entity_Id);
-- Special analyze routine for contract-case and test-case pragmas that
-- appears within a declarative part where the pragma is associated with
-- a subprogram specification. N is the pragma node, and S is the entity
-- for the related subprogram. This procedure does a preanalysis of the
-- expressions in the pragma as "spec expressions" (see section in Sem
-- "Handling of Default and Per-Object Expressions...").
-- Perform preanalysis of pragma Test_Case that applies to a subprogram
-- declaration. Parameter N denotes the pragma, S is the entity of the
-- related subprogram. The preanalysis of the expression is done as "spec
-- expression" (see section "Handling of Default and Per-Object Expressions
-- in Sem).
procedure Check_Applicable_Policy (N : Node_Id);
-- N is either an N_Aspect or an N_Pragma node. There are two cases. If

View File

@ -212,25 +212,25 @@ package body Sem_Util is
-- Add_Contract_Item --
-----------------------
procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id) is
procedure Add_Contract_Item (Prag : Node_Id; Subp_Id : Entity_Id) is
Items : constant Node_Id := Contract (Subp_Id);
Nam : Name_Id;
begin
if Present (Items) and then Nkind (Item) = N_Pragma then
Nam := Pragma_Name (Item);
-- The related subprogram [body] must have a contract and the item to be
-- added must be a pragma.
if Nam_In (Nam, Name_Precondition, Name_Postcondition) then
Set_Next_Pragma (Item, Pre_Post_Conditions (Items));
Set_Pre_Post_Conditions (Items, Item);
pragma Assert (Present (Items));
pragma Assert (Nkind (Prag) = N_Pragma);
elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
Set_Next_Pragma (Item, Contract_Test_Cases (Items));
Set_Contract_Test_Cases (Items, Item);
Nam := Pragma_Name (Prag);
elsif Nam_In (Nam, Name_Depends, Name_Global) then
Set_Next_Pragma (Item, Classifications (Items));
Set_Classifications (Items, Item);
-- Contract items related to subprogram bodies
if Ekind (Subp_Id) = E_Subprogram_Body then
if Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then
Set_Next_Pragma (Prag, Classifications (Items));
Set_Classifications (Items, Prag);
-- The pragma is not a proper contract item
@ -238,10 +238,26 @@ package body Sem_Util is
raise Program_Error;
end if;
-- The subprogram has not been properly decorated or the item is illegal
-- Contract items related to subprogram declarations
else
raise Program_Error;
if Nam_In (Nam, Name_Precondition, Name_Postcondition) then
Set_Next_Pragma (Prag, Pre_Post_Conditions (Items));
Set_Pre_Post_Conditions (Items, Prag);
elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then
Set_Next_Pragma (Prag, Contract_Test_Cases (Items));
Set_Contract_Test_Cases (Items, Prag);
elsif Nam_In (Nam, Name_Depends, Name_Global) then
Set_Next_Pragma (Prag, Classifications (Items));
Set_Classifications (Items, Prag);
-- The pragma is not a proper contract item
else
raise Program_Error;
end if;
end if;
end Add_Contract_Item;

View File

@ -43,10 +43,17 @@ package Sem_Util is
-- Add A to the list of access types to process when expanding the
-- freeze node of E.
procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id);
-- Add a contract item (pragma Precondition, Postcondition, Test_Case,
-- Contract_Cases, Global, Depends) to the contract of a subprogram. Item
-- denotes a pragma and Subp_Id is the related subprogram.
procedure Add_Contract_Item (Prag : Node_Id; Subp_Id : Entity_Id);
-- Add one of the following contract item to the contract of a subprogram.
-- Prag denotes a pragma and Subp_Id is the related subprogram [body].
-- Contract_Cases
-- Depends
-- Global
-- Postcondition
-- Precondition
-- Refined_Depends
-- Refined_Global
-- Test_Case
procedure Add_Global_Declaration (N : Node_Id);
-- These procedures adds a declaration N at the library level, to be

View File

@ -7143,11 +7143,10 @@ package Sinfo is
--------------
-- This node is used to hold the various parts of an entry or subprogram
-- contract, consisting in pre- and postconditions on the one hand, and
-- test-cases on the other hand.
-- [body] contract, consisting of precondition, postconditions, contract
-- cases, test cases and global dependencies.
-- It is referenced from an entry, a subprogram or a generic subprogram
-- entity.
-- The node appears in an entry and [generic] subprogram [body] entity.
-- Sprint syntax: <none> as the node should not appear in the tree, but
-- only attached to an entry or [generic] subprogram
@ -7160,9 +7159,10 @@ package Sinfo is
-- Classifications (Node3) (set to Empty if none)
-- Pre_Post_Conditions contains a collection of pragmas that correspond
-- to pre- and postconditions associated with an entry or a subprogram.
-- The pragmas can either come from source or be the byproduct of aspect
-- expansion. The ordering in the list is in LIFO fashion.
-- to pre- and postconditions associated with an entry or a subprogram
-- [body or stub]. The pragmas can either come from source or be the
-- byproduct of aspect expansion. The ordering in the list is in LIFO
-- fashion.
-- Note that there might be multiple preconditions or postconditions
-- in this list, either because they come from separate pragmas in the
@ -7175,8 +7175,8 @@ package Sinfo is
-- Classifications contains pragmas that either categorize subprogram
-- inputs and outputs or establish dependencies between them. Currently
-- pragmas Depends and Global are stored in this list. The ordering is
-- in LIFO fashion.
-- pragmas Depends, Global, Refined_Depends and Refined_Global are
-- stored in this list. The ordering is in LIFO fashion.
-------------------
-- Expanded_Name --

View File

@ -580,6 +580,8 @@ package Snames is
Name_Pure_05 : constant Name_Id := N + $; -- GNAT
Name_Pure_12 : constant Name_Id := N + $; -- GNAT
Name_Pure_Function : constant Name_Id := N + $; -- GNAT
Name_Refined_Depends : constant Name_Id := N + $; -- GNAT
Name_Refined_Global : constant Name_Id := N + $; -- GNAT
Name_Refined_Post : constant Name_Id := N + $; -- GNAT
Name_Refined_Pre : constant Name_Id := N + $; -- GNAT
Name_Relative_Deadline : constant Name_Id := N + $; -- Ada 05
@ -1865,6 +1867,8 @@ package Snames is
Pragma_Pure_05,
Pragma_Pure_12,
Pragma_Pure_Function,
Pragma_Refined_Depends,
Pragma_Refined_Global,
Pragma_Refined_Post,
Pragma_Refined_Pre,
Pragma_Relative_Deadline,

View File

@ -172,7 +172,7 @@ package Types is
for Physical_Line_Number'Size use 32;
-- Line number type, used for storing physical line numbers (i.e. line
-- numbers in the physical file being compiled, unaffected by the presence
-- of source reference pragmas.
-- of source reference pragmas).
type Column_Number is range 0 .. 32767;
for Column_Number'Size use 16;