[multiple changes]

2012-10-01  Ed Schonberg  <schonberg@adacore.com>

	* checks.adb (Apply_Predicate_Check): If the predicate is a
	static one and the operand is static, evaluate the predicate at
	compile time.
	* sem_eval.ads, sem_eval.adb (Eval_Static_Predicate_Check): new
	procedure, to evaluate a static predicate check whenever possible.
	* sem_res.adb (Resolve_Type_Conversion): Apply predicate check
	on the conversion if the target type has predicates.

2012-10-01  Vincent Pucci  <pucci@adacore.com>

	* sem_dim.adb (Has_Symbols): Complain if parameter Symbol has been
	provided by the user in the dimension output call.

From-SVN: r191921
This commit is contained in:
Arnaud Charlet 2012-10-01 15:21:34 +02:00
parent a91e9ac73d
commit 804fc056d5
6 changed files with 124 additions and 6 deletions

@ -1,3 +1,18 @@
2012-10-01 Ed Schonberg <schonberg@adacore.com>
* checks.adb (Apply_Predicate_Check): If the predicate is a
static one and the operand is static, evaluate the predicate at
compile time.
* sem_eval.ads, sem_eval.adb (Eval_Static_Predicate_Check): new
procedure, to evaluate a static predicate check whenever possible.
* sem_res.adb (Resolve_Type_Conversion): Apply predicate check
on the conversion if the target type has predicates.
2012-10-01 Vincent Pucci <pucci@adacore.com>
* sem_dim.adb (Has_Symbols): Complain if parameter Symbol has been
provided by the user in the dimension output call.
2012-10-01 Robert Dewar <dewar@adacore.com>
* checks.adb (Apply_Divide_Checks): New name for

@ -2337,6 +2337,23 @@ package body Checks is
(Sloc (N), Reason => SE_Infinite_Recursion));
else
-- If the predicate is a static predicate and the operand is
-- static, the predicate must be evaluated statically. If the
-- evaluation fails this is a static constraint error.
if Is_OK_Static_Expression (N) then
if Present (Static_Predicate (Typ)) then
if Eval_Static_Predicate_Check (N, Typ) then
return;
else
Error_Msg_NE
("static expression fails static predicate check on&",
N, Typ);
end if;
end if;
end if;
Insert_Action (N,
Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
end if;

@ -2703,7 +2703,8 @@ package body Sem_Dim is
-----------------
function Has_Symbols return Boolean is
Actual : Node_Id;
Actual : Node_Id;
Actual_Str : Node_Id;
begin
Actual := First (Actuals);
@ -2711,16 +2712,49 @@ package body Sem_Dim is
-- Look for a symbols parameter association in the list of actuals
while Present (Actual) loop
if Nkind (Actual) = N_Parameter_Association
-- Positional parameter association case when the actual is a
-- string literal.
if Nkind (Actual) = N_String_Literal then
Actual_Str := Actual;
-- Named parameter association case when the selector name is
-- Symbol.
elsif Nkind (Actual) = N_Parameter_Association
and then Chars (Selector_Name (Actual)) = Name_Symbol
then
Actual_Str := Explicit_Actual_Parameter (Actual);
-- Ignore all other cases
else
Actual_Str := Empty;
end if;
if Present (Actual_Str) then
-- Return True if the actual comes from source or if the string
-- of symbols doesn't have the default value (i.e. it is "").
return Comes_From_Source (Actual)
or else
String_Length
(Strval (Explicit_Actual_Parameter (Actual))) /= 0;
if Comes_From_Source (Actual)
or else String_Length (Strval (Actual_Str)) /= 0
then
-- Complain only if the actual comes from source or if it
-- hasn't been fully analyzed yet.
if Comes_From_Source (Actual)
or else not Analyzed (Actual)
then
Error_Msg_N ("Symbol parameter should not be provided",
Actual);
Error_Msg_N ("\reserved for compiler use only", Actual);
end if;
return True;
else
return False;
end if;
end if;
Next (Actual);

@ -3249,6 +3249,37 @@ package body Sem_Eval is
end if;
end Eval_Slice;
---------------------------------
-- Eval_Static_Predicate_Check --
---------------------------------
function Eval_Static_Predicate_Check
(N : Node_Id;
Typ : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Pred : constant List_Id := Static_Predicate (Typ);
Test : Node_Id;
begin
if No (Pred) then
return True;
end if;
-- The static predicate is a list of alternatives in the proper format
-- for an Ada 2012 membership test. If the argument is a literal, the
-- membership test can be evaluated statically. The caller transforms
-- a result of False into a static contraint error.
Test := Make_In (Loc,
Left_Opnd => New_Copy_Tree (N),
Right_Opnd => Empty,
Alternatives => Pred);
Analyze_And_Resolve (Test, Standard_Boolean);
return Nkind (Test) = N_Identifier
and then Entity (Test) = Standard_True;
end Eval_Static_Predicate_Check;
-------------------------
-- Eval_String_Literal --
-------------------------

@ -317,6 +317,11 @@ package Sem_Eval is
procedure Eval_Unary_Op (N : Node_Id);
procedure Eval_Unchecked_Conversion (N : Node_Id);
function Eval_Static_Predicate_Check
(N : Node_Id;
Typ : Entity_Id) return Boolean;
-- Evaluate a static predicate check applied to a scalar literal.
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
-- time evaluation of the node N. Val is the resulting string value from

@ -9713,6 +9713,22 @@ package body Sem_Res is
end if;
end;
end if;
-- Ada 2012: if target type has predicates, the result requires a
-- predicate check. If the context is a call to another predicate
-- check we must prevent infinite recursion.
if Has_Predicates (Target_Typ) then
if Nkind (Parent (N)) = N_Function_Call
and then Present (Name (Parent (N)))
and then Has_Predicates (Entity (Name (Parent (N))))
then
null;
else
Apply_Predicate_Check (N, Target_Typ);
end if;
end if;
end Resolve_Type_Conversion;
----------------------