Commit 807b4ca2 by Arnaud Charlet

[multiple changes]

2013-04-22  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Contract_Case): New routine.
	(Analyze_Pragma): Aspect/pragma Contract_Cases can
	now be associated with a library level subprogram.
	Add circuitry to detect illegal uses of aspect/pragma Contract_Cases
	in a subprogram body.
	(Chain_Contract_Cases): Rename formal parameter Subp_Decl to
	Subp_Id. Remove local constant Subp. The entity of the subprogram
	is now obtained via the formal paramter.

2013-04-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Analyze_Object_Declaration): Do not set
	Is_Constr_Subt_For_Unc_Aliased on the subtype of the expression,
	if the expression is a source entity.

From-SVN: r198134
parent b2c3b537
2013-04-22 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Contract_Case): New routine.
(Analyze_Pragma): Aspect/pragma Contract_Cases can
now be associated with a library level subprogram.
Add circuitry to detect illegal uses of aspect/pragma Contract_Cases
in a subprogram body.
(Chain_Contract_Cases): Rename formal parameter Subp_Decl to
Subp_Id. Remove local constant Subp. The entity of the subprogram
is now obtained via the formal paramter.
2013-04-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): Do not set
Is_Constr_Subt_For_Unc_Aliased on the subtype of the expression,
if the expression is a source entity.
2013-04-22 Yannick Moy <moy@adacore.com> 2013-04-22 Yannick Moy <moy@adacore.com>
* exp_prag.adb, sinfo.ads, sem_prag.ads: Minor correction of typos in * exp_prag.adb, sinfo.ads, sem_prag.ads: Minor correction of typos in
......
...@@ -3404,7 +3404,14 @@ package body Sem_Ch3 is ...@@ -3404,7 +3404,14 @@ package body Sem_Ch3 is
Set_Is_Constr_Subt_For_U_Nominal (Act_T); Set_Is_Constr_Subt_For_U_Nominal (Act_T);
if Aliased_Present (N) then -- If the expression is a source entity its type is defined
-- elsewhere. Otherwise it is a just-created subtype, and the
-- back-end may need to create a template for it.
if Aliased_Present (N)
and then (not Is_Entity_Name (E)
or else not Comes_From_Source (E))
then
Set_Is_Constr_Subt_For_UN_Aliased (Act_T); Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
end if; end if;
......
...@@ -8628,33 +8628,82 @@ package body Sem_Prag is ...@@ -8628,33 +8628,82 @@ package body Sem_Prag is
-- CONSEQUENCE ::= boolean_EXPRESSION -- CONSEQUENCE ::= boolean_EXPRESSION
when Pragma_Contract_Cases => Contract_Cases : declare when Pragma_Contract_Cases => Contract_Cases : declare
procedure Chain_Contract_Cases (Subp_Decl : Node_Id); Others_Seen : Boolean := False;
procedure Analyze_Contract_Case (Contract_Case : Node_Id);
-- Verify the legality of a single contract case
procedure Chain_Contract_Cases (Subp_Id : Entity_Id);
-- Chain pragma Contract_Cases to the contract of a subprogram. -- Chain pragma Contract_Cases to the contract of a subprogram.
-- Subp_Decl is the declaration of the subprogram. -- Subp_Id is the related subprogram.
---------------------------
-- Analyze_Contract_Case --
---------------------------
procedure Analyze_Contract_Case (Contract_Case : Node_Id) is
Case_Guard : Node_Id;
Extra_Guard : Node_Id;
begin
if Nkind (Contract_Case) = N_Component_Association then
Case_Guard := First (Choices (Contract_Case));
-- Each contract case must have exactly on case guard
Extra_Guard := Next (Case_Guard);
if Present (Extra_Guard) then
Error_Pragma_Arg
("contract case may have only one case guard",
Extra_Guard);
end if;
-- Check the placement of "others" (if available)
if Nkind (Case_Guard) = N_Others_Choice then
if Others_Seen then
Error_Pragma_Arg
("only one others choice allowed in pragma %",
Case_Guard);
else
Others_Seen := True;
end if;
elsif Others_Seen then
Error_Pragma_Arg
("others must be the last choice in pragma %", N);
end if;
-- The contract case is malformed
else
Error_Pragma_Arg
("wrong syntax in contract case", Contract_Case);
end if;
end Analyze_Contract_Case;
-------------------------- --------------------------
-- Chain_Contract_Cases -- -- Chain_Contract_Cases --
-------------------------- --------------------------
procedure Chain_Contract_Cases (Subp_Decl : Node_Id) is procedure Chain_Contract_Cases (Subp_Id : Entity_Id) is
Subp : constant Entity_Id := CTC : Node_Id;
Defining_Unit_Name (Specification (Subp_Decl));
CTC : Node_Id;
begin begin
Check_Duplicate_Pragma (Subp); Check_Duplicate_Pragma (Subp_Id);
CTC := Spec_CTC_List (Contract (Subp)); CTC := Spec_CTC_List (Contract (Subp_Id));
while Present (CTC) loop while Present (CTC) loop
if Chars (Pragma_Identifier (CTC)) = Pname then if Chars (Pragma_Identifier (CTC)) = Pname then
Error_Msg_Name_1 := Pname; Error_Msg_Name_1 := Pname;
Error_Msg_Sloc := Sloc (CTC); Error_Msg_Sloc := Sloc (CTC);
if From_Aspect_Specification (CTC) then if From_Aspect_Specification (CTC) then
Error_Msg_NE Error_Msg_NE
("aspect% for & previously given#", N, Subp); ("aspect% for & previously given#", N, Subp_Id);
else else
Error_Msg_NE Error_Msg_NE
("pragma% for & duplicates pragma#", N, Subp); ("pragma% for & duplicates pragma#", N, Subp_Id);
end if; end if;
raise Pragma_Exit; raise Pragma_Exit;
...@@ -8665,18 +8714,18 @@ package body Sem_Prag is ...@@ -8665,18 +8714,18 @@ package body Sem_Prag is
-- Prepend pragma Contract_Cases to the contract -- Prepend pragma Contract_Cases to the contract
Set_Next_Pragma (N, Spec_CTC_List (Contract (Subp))); Set_Next_Pragma (N, Spec_CTC_List (Contract (Subp_Id)));
Set_Spec_CTC_List (Contract (Subp), N); Set_Spec_CTC_List (Contract (Subp_Id), N);
end Chain_Contract_Cases; end Chain_Contract_Cases;
-- Local variables -- Local variables
Case_Guard : Node_Id; Context : constant Node_Id := Parent (N);
All_Cases : Node_Id;
Decl : Node_Id; Decl : Node_Id;
Extra : Node_Id;
Others_Seen : Boolean := False;
Contract_Case : Node_Id; Contract_Case : Node_Id;
Subp_Decl : Node_Id; Subp_Decl : Node_Id;
Subp_Id : Entity_Id;
-- Start of processing for Contract_Cases -- Start of processing for Contract_Cases
...@@ -8698,91 +8747,94 @@ package body Sem_Prag is ...@@ -8698,91 +8747,94 @@ package body Sem_Prag is
Pragma_Misplaced; Pragma_Misplaced;
end if; end if;
-- Pragma Contract_Cases must be associated with a subprogram -- Aspect/pragma Contract_Cases may be associated with a library
-- level subprogram.
Decl := N; if Nkind (Context) = N_Compilation_Unit_Aux then
while Present (Prev (Decl)) loop Subp_Decl := Unit (Parent (Context));
Decl := Prev (Decl);
if Nkind (Decl) in N_Generic_Declaration then if not Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
Subp_Decl := Decl; N_Subprogram_Declaration)
else then
Subp_Decl := Original_Node (Decl); Pragma_Misplaced;
end if; end if;
-- Skip prior pragmas Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
if Nkind (Subp_Decl) = N_Pragma then -- The aspect/pragma appears in a subprogram body. The placement
null; -- is legal when the body acts as a spec.
-- Skip internally generated code
elsif not Comes_From_Source (Subp_Decl) then
null;
-- We have found the related subprogram
elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, elsif Nkind (Context) = N_Subprogram_Body then
N_Subprogram_Declaration) Subp_Id := Defining_Unit_Name (Specification (Context));
then
exit;
else if Ekind (Subp_Id) = E_Subprogram_Body then
Pragma_Misplaced; Error_Pragma
("pragma % may not appear in a subprogram body that acts "
& "as completion");
end if; end if;
end loop;
-- All contract cases must appear as an aggregate -- Nested subprogram case, the aspect/pragma must apply to the
-- subprogram spec.
if Nkind (Expression (Arg1)) /= N_Aggregate then else
Error_Pragma ("wrong syntax for pragma %"); Decl := N;
return; while Present (Prev (Decl)) loop
end if; Decl := Prev (Decl);
-- Verify the legality of individual contract cases if Nkind (Decl) in N_Generic_Declaration then
Subp_Decl := Decl;
else
Subp_Decl := Original_Node (Decl);
end if;
Contract_Case := -- Skip prior pragmas
First (Component_Associations (Expression (Arg1)));
while Present (Contract_Case) loop
if Nkind (Contract_Case) /= N_Component_Association then
Error_Pragma_Arg
("wrong syntax in contract case", Contract_Case);
return;
end if;
Case_Guard := First (Choices (Contract_Case)); if Nkind (Subp_Decl) = N_Pragma then
null;
-- Each contract case must have exactly on case guard -- Skip internally generated code
Extra := Next (Case_Guard); elsif not Comes_From_Source (Subp_Decl) then
if Present (Extra) then null;
Error_Pragma_Arg
("contract case may have only one case guard", Extra);
return;
end if;
-- Check the placement of "others" (if available) -- We have found the related subprogram
elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration,
N_Subprogram_Declaration)
then
exit;
if Nkind (Case_Guard) = N_Others_Choice then
if Others_Seen then
Error_Pragma_Arg
("only one others choice allowed in pragma %",
Case_Guard);
return;
else else
Others_Seen := True; Pragma_Misplaced;
end if; end if;
end loop;
elsif Others_Seen then Subp_Id := Defining_Unit_Name (Specification (Subp_Decl));
Error_Pragma_Arg end if;
("others must be the last choice in pragma %", N);
return;
end if;
Next (Contract_Case); All_Cases := Expression (Arg1);
end loop;
-- Multiple contract cases appear in aggregate form
if Nkind (All_Cases) = N_Aggregate then
if No (Component_Associations (All_Cases)) then
Error_Pragma ("wrong syntax for pragma %");
-- Individual contract cases appear as component associations
else
Contract_Case := First (Component_Associations (All_Cases));
while Present (Contract_Case) loop
Analyze_Contract_Case (Contract_Case);
Next (Contract_Case);
end loop;
end if;
else
Error_Pragma ("wrong syntax for pragma %");
end if;
Chain_Contract_Cases (Subp_Decl); Chain_Contract_Cases (Subp_Id);
end Contract_Cases; end Contract_Cases;
---------------- ----------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment