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
+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
(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;
-----------------
function Has_Symbols return Boolean is
- Actual : Node_Id;
+ Actual : Node_Id;
+ Actual_Str : Node_Id;
begin
Actual := First (Actuals);
-- 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);
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 --
-------------------------
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
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;
----------------------
projects / thirdparty / gcc.git / commitdiff
