[Ada] A static predicate can be specified by a Case expression.

[Arnaud Charlet]

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  <schonberg@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.

-------------- next part --------------
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;