[multiple changes]

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb: Minor reformatting.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Build_Invariant_Checks): If the enclosing record
	is an unchecked_union, warn that invariants will not be checked
	on components that have them.

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* freeze.adb (Freeze_Entity): Check for error of
	Type_Invariant'Class applied to a untagged type.
	* sem_ch6.adb (Analyze_Null_Procedure): Unconditionally rewrite
	as null body, so that we perform error checks even if expansion
	is off.

From-SVN: r213324
This commit is contained in:
Arnaud Charlet 2014-07-31 11:35:27 +02:00
parent b4dfdc11a5
commit 2fe258bf93
5 changed files with 53 additions and 13 deletions

View file

@ -1,3 +1,21 @@
2014-07-31 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb: Minor reformatting.
2014-07-31 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Build_Invariant_Checks): If the enclosing record
is an unchecked_union, warn that invariants will not be checked
on components that have them.
2014-07-31 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Entity): Check for error of
Type_Invariant'Class applied to a untagged type.
* sem_ch6.adb (Analyze_Null_Procedure): Unconditionally rewrite
as null body, so that we perform error checks even if expansion
is off.
2014-07-31 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Build_Invariant_Procedure): If body of procedure

View file

@ -3763,7 +3763,15 @@ package body Exp_Ch3 is
if Has_Invariants (Etype (Id))
and then In_Open_Scopes (Scope (R_Type))
then
Append_To (Stmts, Build_Component_Invariant_Call (Id));
if Has_Unchecked_Union (R_Type) then
Error_Msg_NE
("invariants cannot be checked on components of "
& "unchecked_union type&?", Decl, R_Type);
return Empty_List;
else
Append_To (Stmts, Build_Component_Invariant_Call (Id));
end if;
elsif Is_Access_Type (Etype (Id))
and then not Is_Access_Constant (Etype (Id))

View file

@ -4537,6 +4537,24 @@ package body Freeze is
return No_List;
end if;
-- Check for error of Type_Invariant'Class applied to a untagged type
-- (check delayed to freeze time when full type is available).
declare
Prag : constant Node_Id := Get_Pragma (E, Pragma_Invariant);
begin
if Present (Prag)
and then Class_Present (Prag)
and then not Is_Tagged_Type (E)
then
Error_Msg_NE
("Type_Invariant''Class cannot be specified for &",
Prag, E);
Error_Msg_N
("\can only be specified for a tagged type", Prag);
end if;
end;
-- Deal with special cases of freezing for subtype
if E /= Base_Type (E) then

View file

@ -7489,7 +7489,8 @@ package body Sem_Ch13 is
-- the type is already frozen, which is the case when the invariant
-- appears in a private part, and the freezing takes place before the
-- final pass over full declarations.
-- See exp_ch3.Insert_Component_Invariant_Checks for details.
-- See Exp_Ch3.Insert_Component_Invariant_Checks for details.
if Present (SId) then
PDecl := Unit_Declaration_Node (SId);

View file

@ -1391,19 +1391,14 @@ package body Sem_Ch6 is
end if;
else
-- The null procedure is a completion
-- The null procedure is a completion. We unconditionally rewrite
-- this as a null body (even if expansion is not active), because
-- there are various error checks that are applied on this body
-- when it is analyzed (e.g. correct aspect placement).
Is_Completion := True;
if Expander_Active then
Rewrite (N, Null_Body);
Analyze (N);
else
Designator := Analyze_Subprogram_Specification (Spec);
Set_Has_Completion (Designator);
Set_Has_Completion (Prev);
end if;
Rewrite (N, Null_Body);
Analyze (N);
end if;
end Analyze_Null_Procedure;