This patch completes the implementation of Ada 2012 static predicates, by adding support for case expressions that can be transformed into a statically evaluable expression on values of the subtype. Compiling:
gcc -c -gnata test_predicate.adb must yield: test_predicate.adb:11:20: warning: static expression fails static predicate check on "Weekend" test_predicate.adb:19:25: warning: static expression fails static predicate check on "French_School" --- with Text_IO; use Text_IO; procedure Test_Predicate is type Days is (Sun, Mon, Tue, Wed, Thu, Fri, Sat); subtype Weekend is Days with Static_Predicate => (case Weekend is when Sat | Sun => True, when Mon .. Fri => False); W : Weekend := Tue; subtype French_School is Days with Static_Predicate => (case French_School is when Mon | Tue => True, when Wed => False, when Thu..Fri => True, when Sat | Sun => False); J : French_School := Wed; begin Put_Line (W'Img); end Test_Predicate; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-07-16 Ed Schonberg <schonb...@adacore.com> * exp_ch4.adb (Expand_N_Case_Expression): Do not expand case expression if it is the specification of a subtype predicate: it will be expanded when the return statement is analyzed, or when a static predicate is transformed into a static expression for evaluation by the front-end. * sem_ch13.adb (Get_RList): If the expression for a static predicate is a case expression, extract the alternatives of the branches with a True value to create the required statically evaluable expression.
Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 212648) +++ exp_ch4.adb (working copy) @@ -4927,6 +4927,16 @@ return; end if; + -- If the case expression is a predicate specification, do not + -- expand, because it will be converted to the proper predicate + -- form when building the predicate function. + + if Ekind_In (Current_Scope, E_Function, E_Procedure) + and then Is_Predicate_Function (Current_Scope) + then + return; + end if; + -- We expand -- case X is when A => AX, when B => BX ... Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 212656) +++ sem_ch13.adb (working copy) @@ -7584,12 +7584,47 @@ when N_Qualified_Expression => return Get_RList (Expression (Exp)); + when N_Case_Expression => + declare + Alt : Node_Id; + Choices : List_Id; + Dep : Node_Id; + + begin + if not Is_Entity_Name (Expression (Expr)) + or else Etype (Expression (Expr)) /= Typ + then + Error_Msg_N + ("expression must denaote subtype", Expression (Expr)); + return False_Range; + end if; + + -- Collect discrete choices in all True alternatives + + Choices := New_List; + Alt := First (Alternatives (Exp)); + while Present (Alt) loop + Dep := Expression (Alt); + + if not Is_Static_Expression (Dep) then + raise Non_Static; + + elsif Is_True (Expr_Value (Dep)) then + Append_List_To (Choices, + New_Copy_List (Discrete_Choices (Alt))); + end if; + + Next (Alt); + end loop; + + return Membership_Entries (First (Choices)); + end; + -- Expression with actions: if no actions, dig out expression when N_Expression_With_Actions => if Is_Empty_List (Actions (Exp)) then return Get_RList (Expression (Exp)); - else raise Non_Static; end if;