From 804fc056d55a4098d7a4a1fc895579aaf1bb3080 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 1 Oct 2012 15:21:34 +0200 Subject: [PATCH] [multiple changes] 2012-10-01 Ed Schonberg * 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 * sem_dim.adb (Has_Symbols): Complain if parameter Symbol has been provided by the user in the dimension output call. From-SVN: r191921 --- gcc/ada/ChangeLog | 15 +++++++++++++++ gcc/ada/checks.adb | 17 ++++++++++++++++ gcc/ada/sem_dim.adb | 46 ++++++++++++++++++++++++++++++++++++++------ gcc/ada/sem_eval.adb | 31 +++++++++++++++++++++++++++++ gcc/ada/sem_eval.ads | 5 +++++ gcc/ada/sem_res.adb | 16 +++++++++++++++ 6 files changed, 124 insertions(+), 6 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 56d54d578cb..cfade45d743 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2012-10-01 Ed Schonberg + + * 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 + + * 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 * checks.adb (Apply_Divide_Checks): New name for diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 3cbec969d3b..12c2b6a2805 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index d7526076a34..4902ae35ca5 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -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); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 888f3b25c1a..933211a2d32 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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 -- ------------------------- diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index a2f69feac33..787e6d346c8 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ee25ef15ee2..d2baee4d645 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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; ----------------------