Patchwork [Ada] Implement case expressions

login
register
mail settings
Submitter Arnaud Charlet
Date June 18, 2010, 9:42 a.m.
Message ID <20100618094226.GA16335@adacore.com>
Download mbox | patch
Permalink /patch/56157/
State New
Headers show

Comments

Arnaud Charlet - June 18, 2010, 9:42 a.m.
This patch implements a new Ada 2012 feature, case expressions, under
control of the -gnatX switch. This allows the use of the proposed
new construct as illustrated by the following example:
  X := (case Y is when 1 => 2, when 2 => 3, when others => 31)
The implementation is complete, and works for some simple examples
like the following one:

with Text_IO; use Text_IO;
procedure caseexp_1 is
begin
   for J in 1 .. 3 loop
      Put_Line
        (Integer'Image
           ((case J is when 1 => 2, when 2 => 32, when 3 => 45)));
   end loop;
end caseexp_1;

which, compiled with -gnatX generates the output
 2
 32
 45
as expected

However, there are still some problems with the use of unconstrained
array results (e.g. strings) which need more work.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case
	expression (cannot count on a particular branch being executed).
	* exp_ch4.adb (Expand_N_Case_Expression): New procedure.
	* exp_ch4.ads (Expand_N_Case_Expression): New procedure.
	* exp_util.adb (Insert_Actions): Deal with proper insertion of actions
	within case expression.
	* expander.adb (Expand): Add call to Expand_N_Case_Expression
	* par-ch4.adb Add calls to P_Case_Expression at appropriate points
	(P_Case_Expression): New procedure
	(P_Case_Expression_Alternative): New procedure
	* par.adb (P_Case_Expression): New procedure
	* par_sco.adb (Process_Decisions): Add dummy place holder entry for
	N_Case_Expression.
	* sem.adb (Analyze): Add call to Analyze_Case_Expression
	* sem_case.ads (Analyze_Choices): Also used for case expressions now,
	this is a documentation change only.
	* sem_ch4.ads, sem_ch4.adb (Analyze_Case_Expression): New procedure.
	* sem_ch6.adb (Fully_Conformant_Expressions): Add handling of case
	expressions.
	* sem_eval.ads, sem_eval.adb (Eval_Case_Expression): New procedure.
	* sem_res.adb (Resolve_Case_Expression): New procedure.
	* sem_scil.adb (Find_SCIL_Node): Add processing for
	N_Case_Expression_Alternative.
	* sinfo.ads, sinfo.adb (N_Case_Expression): New node.
	(N_Case_Expression_Alternative): New node.
	* sprint.adb (Sprint_Node_Actual): Add processing for new nodes
	N_Case_Expression and N_Case_Expression_Alternative.

Patch

Index: par_sco.adb
===================================================================
--- par_sco.adb	(revision 160959)
+++ par_sco.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2009, Free Software Foundation, Inc.           --
+--          Copyright (C) 2009-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -573,6 +573,11 @@  package body Par_SCO is
                   return Skip;
                end;
 
+            --  Case expression
+
+            when N_Case_Expression =>
+               return OK; -- ???
+
             --  Conditional expression, processed like an if statement
 
             when N_Conditional_Expression =>
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 160966)
+++ exp_util.adb	(working copy)
@@ -2417,6 +2417,21 @@  package body Exp_Util is
                   end if;
                end;
 
+            --  Alternative of case expression, we place the action in
+            --  the Actions field of the case expression alternative, this
+            --  will be handled when the case expression is expanded.
+
+            when N_Case_Expression_Alternative =>
+               if Present (Actions (P)) then
+                  Insert_List_After_And_Analyze
+                    (Last (Actions (P)), Ins_Actions);
+               else
+                  Set_Actions (P, Ins_Actions);
+                  Analyze_List (Then_Actions (P));
+               end if;
+
+               return;
+
             --  Case of appearing within an Expressions_With_Actions node. We
             --  prepend the actions to the list of actions already there.
 
@@ -2679,6 +2694,7 @@  package body Exp_Util is
                N_Access_To_Object_Definition            |
                N_Aggregate                              |
                N_Allocator                              |
+               N_Case_Expression                        |
                N_Case_Statement_Alternative             |
                N_Character_Literal                      |
                N_Compilation_Unit                       |
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 160961)
+++ sinfo.adb	(working copy)
@@ -146,6 +146,7 @@  package body Sinfo is
    begin
       pragma Assert (False
         or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_Case_Expression_Alternative
         or else NT (N).Nkind = N_Compilation_Unit_Aux
         or else NT (N).Nkind = N_Expression_With_Actions
         or else NT (N).Nkind = N_Freeze_Entity
@@ -230,6 +231,7 @@  package body Sinfo is
       (N : Node_Id) return List_Id is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Case_Expression
         or else NT (N).Nkind = N_Case_Statement
         or else NT (N).Nkind = N_In
         or else NT (N).Nkind = N_Not_In);
@@ -792,6 +794,7 @@  package body Sinfo is
       (N : Node_Id) return List_Id is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Case_Expression_Alternative
         or else NT (N).Nkind = N_Case_Statement_Alternative
         or else NT (N).Nkind = N_Variant);
       return List4 (N);
@@ -1170,6 +1173,8 @@  package body Sinfo is
         or else NT (N).Nkind = N_Assignment_Statement
         or else NT (N).Nkind = N_At_Clause
         or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Case_Expression
+        or else NT (N).Nkind = N_Case_Expression_Alternative
         or else NT (N).Nkind = N_Case_Statement
         or else NT (N).Nkind = N_Code_Statement
         or else NT (N).Nkind = N_Component_Association
@@ -3067,6 +3072,7 @@  package body Sinfo is
    begin
       pragma Assert (False
         or else NT (N).Nkind = N_And_Then
+        or else NT (N).Nkind = N_Case_Expression_Alternative
         or else NT (N).Nkind = N_Compilation_Unit_Aux
         or else NT (N).Nkind = N_Expression_With_Actions
         or else NT (N).Nkind = N_Freeze_Entity
@@ -3151,6 +3157,7 @@  package body Sinfo is
       (N : Node_Id; Val : List_Id) is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Case_Expression
         or else NT (N).Nkind = N_Case_Statement
         or else NT (N).Nkind = N_In
         or else NT (N).Nkind = N_Not_In);
@@ -3713,6 +3720,7 @@  package body Sinfo is
       (N : Node_Id; Val : List_Id) is
    begin
       pragma Assert (False
+        or else NT (N).Nkind = N_Case_Expression_Alternative
         or else NT (N).Nkind = N_Case_Statement_Alternative
         or else NT (N).Nkind = N_Variant);
       Set_List4_With_Parent (N, Val);
@@ -4082,6 +4090,8 @@  package body Sinfo is
         or else NT (N).Nkind = N_Assignment_Statement
         or else NT (N).Nkind = N_At_Clause
         or else NT (N).Nkind = N_Attribute_Definition_Clause
+        or else NT (N).Nkind = N_Case_Expression
+        or else NT (N).Nkind = N_Case_Expression_Alternative
         or else NT (N).Nkind = N_Case_Statement
         or else NT (N).Nkind = N_Code_Statement
         or else NT (N).Nkind = N_Component_Association
@@ -6050,7 +6060,6 @@  package body Sinfo is
              T = V8;
    end Nkind_In;
 
-
    function Nkind_In
      (T  : Node_Kind;
       V1 : Node_Kind;
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 160961)
+++ sinfo.ads	(working copy)
@@ -6543,10 +6543,46 @@  package Sinfo is
    --  reconstructed tree printed by Sprint, and the node descriptions here
    --  show this syntax.
 
-   --  Note: Conditional_Expression is in this section for historical reasons.
-   --  We will move it to its appropriate place when it is officially approved
-   --  as an extension (and then we will know what the exact grammar and place
-   --  in the Reference Manual is!)
+   --  Note: Case_Expression and Conditional_Expression is in this section for
+   --  now, since they are extensions. We will move them to their appropriate
+   --  places when they are officially approved as extensions (and then we will
+   --  know what the exact grammar and place in the Reference Manual is!)
+
+      ---------------------
+      -- Case Expression --
+      ---------------------
+
+      --  CASE_EXPRESSION ::=
+      --    case EXPRESSION is
+      --      CASE_EXPRESSION_ALTERNATIVE
+      --      {CASE_EXPRESSION_ALTERNATIVE}
+
+      --  Note that the Alternatives cannot include pragmas (this constrasts
+      --  with the situation of case statements where pragmas are allowed).
+
+      --  N_Case_Expression
+      --  Sloc points to CASE
+      --  Expression (Node3)
+      --  Alternatives (List4)
+
+      ---------------------------------
+      -- Case Expression Alternative --
+      ---------------------------------
+
+      --  CASE_STATEMENT_ALTERNATIVE ::=
+      --    when DISCRETE_CHOICE_LIST =>
+      --      EXPRESSION
+
+      --  N_Case_Expression_Alternative
+      --  Sloc points to WHEN
+      --  Actions (List1)
+      --  Discrete_Choices (List4)
+      --  Expression (Node3)
+
+      --  Note: The Actions field temporarily holds any actions associated with
+      --  evaluation of the Expression. During expansion of the case expression
+      --  these actions are wrapped into the an N_Expressions_With_Actions node
+      --  replacing the original expression.
 
       ----------------------------
       -- Conditional Expression --
@@ -7259,6 +7295,7 @@  package Sinfo is
 
       N_Aggregate,
       N_Allocator,
+      N_Case_Expression,
       N_Extension_Aggregate,
       N_Range,
       N_Real_Literal,
@@ -7437,6 +7474,7 @@  package Sinfo is
       N_Abstract_Subprogram_Declaration,
       N_Access_Definition,
       N_Access_To_Object_Definition,
+      N_Case_Expression_Alternative,
       N_Case_Statement_Alternative,
       N_Compilation_Unit,
       N_Compilation_Unit_Aux,
@@ -10260,6 +10298,20 @@  package Sinfo is
         4 => False,   --  unused
         5 => False),  --  unused
 
+     N_Case_Expression =>
+       (1 => False,   --  unused
+        2 => False,   --  unused
+        3 => True,    --  Expression (Node3)
+        4 => True,    --  Alternatives (List4)
+        5 => False),  --  unused
+
+     N_Case_Expression_Alternative =>
+       (1 => False,   --  Actions (List1-Sem)
+        2 => False,   --  unused
+        3 => True,    --  Statements (List3)
+        4 => True,    --  Expression (Node4)
+        5 => False),  --  unused
+
      N_Case_Statement =>
        (1 => False,   --  unused
         2 => False,   --  unused
Index: sem_scil.adb
===================================================================
--- sem_scil.adb	(revision 160959)
+++ sem_scil.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2009, Free Software Foundation, Inc.           --
+--          Copyright (C) 2009-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -317,6 +317,15 @@  package body Sem_SCIL is
                   return Found_Node;
                end if;
 
+            --  Actions of case expressions
+
+            when N_Case_Expression_Alternative =>
+               if Present (Actions (P))
+                 and then Find_SCIL_Node (Actions (P))
+               then
+                  return Found_Node;
+               end if;
+
             --  Actions of conditional expressions
 
             when N_Conditional_Expression =>
@@ -513,6 +522,7 @@  package body Sem_SCIL is
                N_Access_To_Object_Definition            |
                N_Aggregate                              |
                N_Allocator                              |
+               N_Case_Expression                        |
                N_Case_Statement_Alternative             |
                N_Character_Literal                      |
                N_Compilation_Unit                       |
Index: checks.adb
===================================================================
--- checks.adb	(revision 160959)
+++ checks.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -5293,6 +5295,16 @@  package body Checks is
                   return False;
                end if;
 
+               --  If we are in a case eexpression, and not part of the
+               --  expression, then we return False, since a particular
+               --  branch may not always be elaborated
+
+               if Nkind (P) = N_Case_Expression
+                 and then N /= Expression (P)
+               then
+                  return False;
+               end if;
+
                --  While traversing the parent chain, we find that N
                --  belongs to a statement, thus it may never appear in
                --  a declarative region.
Index: sem.adb
===================================================================
--- sem.adb	(revision 160959)
+++ sem.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -158,6 +158,9 @@  package body Sem is
          when N_Block_Statement =>
             Analyze_Block_Statement (N);
 
+         when N_Case_Expression =>
+            Analyze_Case_Expression (N);
+
          when N_Case_Statement =>
             Analyze_Case_Statement (N);
 
@@ -632,6 +635,7 @@  package body Sem is
            N_Access_Function_Definition             |
            N_Access_Procedure_Definition            |
            N_Access_To_Object_Definition            |
+           N_Case_Expression_Alternative            |
            N_Case_Statement_Alternative             |
            N_Compilation_Unit_Aux                   |
            N_Component_Association                  |
Index: par-ch4.adb
===================================================================
--- par-ch4.adb	(revision 160959)
+++ par-ch4.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -63,6 +63,7 @@  package body Ch4 is
 
    function P_Aggregate_Or_Paren_Expr                 return Node_Id;
    function P_Allocator                               return Node_Id;
+   function P_Case_Expression_Alternative             return Node_Id;
    function P_Record_Or_Array_Component_Association   return Node_Id;
    function P_Factor                                  return Node_Id;
    function P_Primary                                 return Node_Id;
@@ -1164,6 +1167,13 @@  package body Ch4 is
          T_Right_Paren;
          return Expr_Node;
 
+      --  Case expression case
+
+      elsif Token = Tok_Case then
+         Expr_Node := P_Case_Expression;
+         T_Right_Paren;
+         return Expr_Node;
+
       --  Note: the mechanism used here of rescanning the initial expression
       --  is distinctly unpleasant, but it saves a lot of fiddling in scanning
       --  out the discrete choice list.
@@ -1570,12 +1580,14 @@  package body Ch4 is
    end P_Expression;
 
    --  This function is identical to the normal P_Expression, except that it
-   --  also permits the appearence of a conditional expression without the
-   --  usual surrounding parentheses.
+   --  also permits the appearence of a case of conditional expression without
+   --  the usual surrounding parentheses.
 
    function P_Expression_If_OK return Node_Id is
    begin
-      if Token = Tok_If then
+      if Token = Tok_Case then
+         return P_Case_Expression;
+      elsif Token = Tok_If then
          return P_Conditional_Expression;
       else
          return P_Expression;
@@ -1672,11 +1684,13 @@  package body Ch4 is
       end if;
    end P_Expression_Or_Range_Attribute;
 
-   --  Version that allows a non-parenthesized conditional expression
+   --  Version that allows a non-parenthesized case or conditional expression
 
    function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
    begin
-      if Token = Tok_If then
+      if Token = Tok_Case then
+         return P_Case_Expression;
+      elsif Token = Tok_If then
          return P_Conditional_Expression;
       else
          return P_Expression_Or_Range_Attribute;
@@ -2352,6 +2367,32 @@  package body Ch4 is
                   return P_Identifier;
                end if;
 
+            --  Deal with CASE (possible unparenthesized case expression)
+
+            when Tok_Case =>
+
+               --  If this looks like a real case, defined as a CASE appearing
+               --  the start of a new line, then we consider we have a missing
+               --  operand.
+
+               if Token_Is_At_Start_Of_Line then
+                  Error_Msg_AP ("missing operand");
+                  return Error;
+
+               --  If this looks like a case expression, then treat it that way
+               --  with an error message.
+
+               elsif Extensions_Allowed then
+                  Error_Msg_SC
+                    ("case expression must be parenthesized");
+                  return P_Case_Expression;
+
+               --  Otherwise treat as misused identifier
+
+               else
+                  return P_Identifier;
+               end if;
+
             --  Anything else is illegal as the first token of a primary, but
             --  we test for a reserved identifier so that it is treated nicely
 
@@ -2620,6 +2663,95 @@  package body Ch4 is
       return Alloc_Node;
    end P_Allocator;
 
+   -----------------------
+   -- P_Case_Expression --
+   -----------------------
+
+   function P_Case_Expression return Node_Id is
+      Loc        : constant Source_Ptr := Token_Ptr;
+      Case_Node  : Node_Id;
+      Save_State : Saved_Scan_State;
+
+   begin
+      if not Extensions_Allowed then
+         Error_Msg_SC ("|case expression is an Ada extension");
+         Error_Msg_SC ("\|use -gnatX switch to compile this unit");
+      end if;
+
+      Scan; -- past CASE
+      Case_Node :=
+        Make_Case_Expression (Loc,
+          Expression   => P_Expression_No_Right_Paren,
+          Alternatives => New_List);
+      T_Is;
+
+      --  We now have scanned out CASE expression IS, scan alternatives
+
+      loop
+         T_When;
+         Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
+
+         --  Missing comma if WHEN (more alternatives present)
+
+         if Token = Tok_When then
+            T_Comma;
+
+         --  If comma/WHEN, skip comma and we have another alternative
+
+         elsif Token = Tok_Comma then
+            Save_Scan_State (Save_State);
+            Scan; -- past comma
+
+            if Token /= Tok_When then
+               Restore_Scan_State (Save_State);
+               exit;
+            end if;
+
+         --  If no comma or WHEN, definitely done
+
+         else
+            exit;
+         end if;
+      end loop;
+
+      --  If we have an END CASE, diagnose as not needed
+
+      if Token = Tok_End then
+         Error_Msg_SC
+           ("`END CASE` not allowed at end of case expression");
+         Scan; -- past END
+
+         if Token = Tok_Case then
+            Scan; -- past CASE;
+         end if;
+      end if;
+
+      --  Return the Case_Expression node
+
+      return Case_Node;
+   end P_Case_Expression;
+
+   -----------------------------------
+   -- P_Case_Expression_Alternative --
+   -----------------------------------
+
+   --  CASE_STATEMENT_ALTERNATIVE ::=
+   --    when DISCRETE_CHOICE_LIST =>
+   --      EXPRESSION
+
+   --  The caller has checked that and scanned past the initial WHEN token
+   --  Error recovery: can raise Error_Resync
+
+   function P_Case_Expression_Alternative return Node_Id is
+      Case_Alt_Node : Node_Id;
+   begin
+      Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
+      Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
+      TF_Arrow;
+      Set_Expression (Case_Alt_Node, P_Expression);
+      return Case_Alt_Node;
+   end P_Case_Expression_Alternative;
+
    ------------------------------
    -- P_Conditional_Expression --
    ------------------------------
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 160969)
+++ sem_res.adb	(working copy)
@@ -160,6 +160,7 @@  package body Sem_Res is
    procedure Resolve_Allocator                 (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Arithmetic_Op             (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Call                      (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Case_Expression           (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Character_Literal         (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Comparison_Op             (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Conditional_Expression    (N : Node_Id; Typ : Entity_Id);
@@ -2187,6 +2188,9 @@  package body Sem_Res is
                   Set_Entity (N, Seen);
                   Generate_Reference (Seen, N);
 
+               elsif Nkind (N) = N_Case_Expression then
+                  Set_Etype (N, Expr_Type);
+
                elsif Nkind (N) = N_Character_Literal then
                   Set_Etype (N, Expr_Type);
 
@@ -2542,6 +2546,9 @@  package body Sem_Res is
             when N_Attribute_Reference
                              => Resolve_Attribute                (N, Ctx_Type);
 
+            when N_Case_Expression
+                             => Resolve_Case_Expression          (N, Ctx_Type);
+
             when N_Character_Literal
                              => Resolve_Character_Literal        (N, Ctx_Type);
 
@@ -2640,7 +2647,6 @@  package body Sem_Res is
 
             when N_Unchecked_Type_Conversion =>
                Resolve_Unchecked_Type_Conversion                 (N, Ctx_Type);
-
          end case;
 
          --  If the subexpression was replaced by a non-subexpression, then
@@ -5471,6 +5477,24 @@  package body Sem_Res is
       Warn_On_Overlapping_Actuals (Nam, N);
    end Resolve_Call;
 
+   -----------------------------
+   -- Resolve_Case_Expression --
+   -----------------------------
+
+   procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is
+      Alt : Node_Id;
+
+   begin
+      Alt := First (Alternatives (N));
+      while Present (Alt) loop
+         Resolve (Expression (Alt), Typ);
+         Next (Alt);
+      end loop;
+
+      Set_Etype (N, Typ);
+      Eval_Case_Expression (N);
+   end Resolve_Case_Expression;
+
    -------------------------------
    -- Resolve_Character_Literal --
    -------------------------------
Index: expander.adb
===================================================================
--- expander.adb	(revision 160959)
+++ expander.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -163,6 +163,9 @@  package body Expander is
                when N_Block_Statement =>
                   Expand_N_Block_Statement (N);
 
+               when N_Case_Expression =>
+                  Expand_N_Case_Expression (N);
+
                when N_Case_Statement =>
                   Expand_N_Case_Statement (N);
 
@@ -470,7 +473,6 @@  package body Expander is
 
          Debug_A_Exit ("expanding  ", N, "  (done)");
       end if;
-
    end Expand;
 
    ---------------------------
Index: par.adb
===================================================================
--- par.adb	(revision 160959)
+++ par.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -676,8 +676,13 @@  function Par (Configuration_Pragmas : Bo
       function P_Simple_Expression                    return Node_Id;
       function P_Simple_Expression_Or_Range_Attribute return Node_Id;
 
+      function P_Case_Expression return Node_Id;
+      --  Scans out a case expression. Called with Token pointing to the CASE
+      --  keyword, and returns pointing to the terminating right parent,
+      --  semicolon, or comma, but does not consume this terminating token.
+
       function P_Conditional_Expression return Node_Id;
-      --  Scans out a conditional expression. Called with token pointing to
+      --  Scans out a conditional expression. Called with Token pointing to
       --  the IF keyword, and returns pointing to the terminating right paren,
       --  semicolon or comma, but does not consume this terminating token.
 
Index: sem_case.ads
===================================================================
--- sem_case.ads	(revision 160959)
+++ sem_case.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1996-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1996-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -68,7 +68,7 @@  package Sem_Case is
       --  Processing to carry out for a non static Choice
 
       with procedure Process_Associated_Node (A : Node_Id);
-      --  Associated to each case alternative, aggregate component
+      --  Associated with each case alternative, aggregate component
       --  association or record variant A there is a node or list of nodes
       --  that need semantic processing. This routine implements that
       --  processing.
@@ -76,9 +76,9 @@  package Sem_Case is
    package Generic_Choices_Processing is
 
       function Number_Of_Choices (N : Node_Id) return Nat;
-      --  Iterates through the choices of N, (N can be a case statement,
-      --  array aggregate or record variant), counting all the Choice nodes
-      --  except for the Others choice.
+      --  Iterates through the choices of N, (N can be a case expression, case
+      --  statement, array aggregate or record variant), counting all the
+      --  Choice nodes except for the Others choice.
 
       procedure Analyze_Choices
         (N              : Node_Id;
@@ -87,10 +87,10 @@  package Sem_Case is
          Last_Choice    : out Nat;
          Raises_CE      : out Boolean;
          Others_Present : out Boolean);
-      --  From a case statement, array aggregate or record variant N, this
-      --  routine analyzes the corresponding list of discrete choices.
-      --  Subtyp is the subtype of the discrete choices. The type against
-      --  which the discrete choices must be resolved is its base type.
+      --  From a case expression, case statement, array aggregate or record
+      --  variant N, this routine analyzes the corresponding list of discrete
+      --  choices. Subtyp is the subtype of the discrete choices. The type
+      --  against which the discrete choices must be resolved is its base type.
       --
       --  On entry Choice_Table must be big enough to contain all the discrete
       --  choices encountered. The lower bound of Choice_Table must be one.
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 160969)
+++ exp_ch4.adb	(working copy)
@@ -3878,6 +3878,137 @@  package body Exp_Ch4 is
    procedure Expand_N_And_Then (N : Node_Id)
      renames Expand_Short_Circuit_Operator;
 
+   ------------------------------
+   -- Expand_N_Case_Expression --
+   ------------------------------
+
+   procedure Expand_N_Case_Expression (N : Node_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      Typ     : constant Entity_Id  := Etype (N);
+      Cstmt   : Node_Id;
+      Tnn     : Entity_Id;
+      Pnn     : Entity_Id;
+      Actions : List_Id;
+      Ttyp    : Entity_Id;
+      Alt     : Node_Id;
+      Fexp    : Node_Id;
+
+   begin
+      --  We expand
+
+      --    case X is when A => AX, when B => BX ...
+
+      --  to
+
+      --    do
+      --       Tnn : typ;
+      --       case X is
+      --          when A =>
+      --             Tnn := AX;
+      --          when B =>
+      --             Tnn := BX;
+      --          ...
+      --       end case;
+      --    in Tnn end;
+
+      --  However, this expansion is wrong for limited types, and also
+      --  wrong for unconstrained types (since the bounds may not be the
+      --  same in all branches). Furthermore it involves an extra copy
+      --  for large objects. So we take care of this by using the following
+      --  modified expansion for non-scalar types:
+
+      --    do
+      --       type Pnn is access all typ;
+      --       Tnn : Pnn;
+      --       case X is
+      --          when A =>
+      --             T := AX'Unrestricted_Access;
+      --          when B =>
+      --             T := BX'Unrestricted_Access;
+      --          ...
+      --       end case;
+      --    in Tnn.all end;
+
+      Cstmt :=
+        Make_Case_Statement (Loc,
+          Expression   => Expression (N),
+          Alternatives => New_List);
+
+      Actions := New_List;
+
+      --  Scalar case
+
+      if Is_Scalar_Type (Typ) then
+         Ttyp := Typ;
+
+      else
+         Pnn := Make_Temporary (Loc, 'P');
+         Append_To (Actions,
+           Make_Full_Type_Declaration (Loc,
+             Defining_Identifier => Pnn,
+             Type_Definition =>
+               Make_Access_To_Object_Definition (Loc,
+                 All_Present => True,
+                 Subtype_Indication =>
+                   New_Reference_To (Typ, Loc))));
+         Ttyp := Pnn;
+      end if;
+
+      Tnn := Make_Temporary (Loc, 'T');
+      Append_To (Actions,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Tnn,
+          Object_Definition   => New_Occurrence_Of (Ttyp, Loc)));
+
+      --  Now process the alternatives
+
+      Alt := First (Alternatives (N));
+      while Present (Alt) loop
+         declare
+            Aexp : Node_Id             := Expression (Alt);
+            Aloc : constant Source_Ptr := Sloc (Aexp);
+
+         begin
+            if not Is_Scalar_Type (Typ) then
+               Aexp :=
+                 Make_Attribute_Reference (Aloc,
+                   Prefix         => Relocate_Node (Aexp),
+                   Attribute_Name => Name_Unrestricted_Access);
+            end if;
+
+            Append_To
+              (Alternatives (Cstmt),
+               Make_Case_Statement_Alternative (Sloc (Alt),
+                 Discrete_Choices => Discrete_Choices (Alt),
+                 Statements       => New_List (
+                   Make_Assignment_Statement (Aloc,
+                     Name       => New_Occurrence_Of (Tnn, Loc),
+                     Expression => Aexp))));
+         end;
+
+         Next (Alt);
+      end loop;
+
+      Append_To (Actions, Cstmt);
+
+      --  Construct and return final expression with actions
+
+      if Is_Scalar_Type (Typ) then
+         Fexp := New_Occurrence_Of (Tnn, Loc);
+      else
+         Fexp :=
+           Make_Explicit_Dereference (Loc,
+             Prefix => New_Occurrence_Of (Tnn, Loc));
+      end if;
+
+      Rewrite (N,
+        Make_Expression_With_Actions (Loc,
+          Expression => Fexp,
+          Actions    => Actions));
+
+      Analyze_And_Resolve (N, Typ);
+   end Expand_N_Case_Expression;
+
    -------------------------------------
    -- Expand_N_Conditional_Expression --
    -------------------------------------
Index: exp_ch4.ads
===================================================================
--- exp_ch4.ads	(revision 160959)
+++ exp_ch4.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -31,6 +31,7 @@  package Exp_Ch4 is
 
    procedure Expand_N_Allocator                   (N : Node_Id);
    procedure Expand_N_And_Then                    (N : Node_Id);
+   procedure Expand_N_Case_Expression             (N : Node_Id);
    procedure Expand_N_Conditional_Expression      (N : Node_Id);
    procedure Expand_N_Explicit_Dereference        (N : Node_Id);
    procedure Expand_N_In                          (N : Node_Id);
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 160959)
+++ sem_ch4.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -43,6 +43,7 @@  with Restrict; use Restrict;
 with Rident;   use Rident;
 with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
+with Sem_Case; use Sem_Case;
 with Sem_Cat;  use Sem_Cat;
 with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch6;  use Sem_Ch6;
@@ -52,8 +53,9 @@  with Sem_Disp; use Sem_Disp;
 with Sem_Dist; use Sem_Dist;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
-with Sem_Util; use Sem_Util;
 with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
 with Stand;    use Stand;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
@@ -1048,6 +1053,141 @@  package body Sem_Ch4 is
       end if;
    end Analyze_Call;
 
+   -----------------------------
+   -- Analyze_Case_Expression --
+   -----------------------------
+
+   procedure Analyze_Case_Expression (N : Node_Id) is
+      Expr      : constant Node_Id := Expression (N);
+      FirstX    : constant Node_Id := Expression (First (Alternatives (N)));
+      Alt       : Node_Id;
+      Exp_Type  : Entity_Id;
+      Exp_Btype : Entity_Id;
+
+      Last_Choice    : Nat;
+      Dont_Care      : Boolean;
+      Others_Present : Boolean;
+
+      procedure Non_Static_Choice_Error (Choice : Node_Id);
+      --  Error routine invoked by the generic instantiation below when
+      --  the case expression has a non static choice.
+
+      package Case_Choices_Processing is new
+        Generic_Choices_Processing
+          (Get_Alternatives          => Alternatives,
+           Get_Choices               => Discrete_Choices,
+           Process_Empty_Choice      => No_OP,
+           Process_Non_Static_Choice => Non_Static_Choice_Error,
+           Process_Associated_Node   => No_OP);
+      use Case_Choices_Processing;
+
+      Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
+
+      -----------------------------
+      -- Non_Static_Choice_Error --
+      -----------------------------
+
+      procedure Non_Static_Choice_Error (Choice : Node_Id) is
+      begin
+         Flag_Non_Static_Expr
+           ("choice given in case expression is not static!", Choice);
+      end Non_Static_Choice_Error;
+
+   --  Start of processing for Analyze_Case_Expression
+
+   begin
+      if Comes_From_Source (N) then
+         Check_Compiler_Unit (N);
+      end if;
+
+      Analyze_And_Resolve (Expr, Any_Discrete);
+      Check_Unset_Reference (Expr);
+      Exp_Type := Etype (Expr);
+      Exp_Btype := Base_Type (Exp_Type);
+
+      Alt := First (Alternatives (N));
+      while Present (Alt) loop
+         Analyze (Expression (Alt));
+         Next (Alt);
+      end loop;
+
+      if not Is_Overloaded (FirstX) then
+         Set_Etype (N, Etype (FirstX));
+
+      else
+         declare
+            I  : Interp_Index;
+            It : Interp;
+
+         begin
+            Set_Etype (N, Any_Type);
+
+            Get_First_Interp (FirstX, I, It);
+            while Present (It.Nam) loop
+
+               --  For each intepretation of the first expression, we only
+               --  add the intepretation if every other expression in the
+               --  case expression alternatives has a compatible type.
+
+               Alt := Next (First (Alternatives (N)));
+               while Present (Alt) loop
+                  exit when not Has_Compatible_Type (Expression (Alt), It.Typ);
+                  Next (Alt);
+               end loop;
+
+               if No (Alt) then
+                  Add_One_Interp (N, It.Typ, It.Typ);
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end;
+      end if;
+
+      Exp_Btype := Base_Type (Exp_Type);
+
+      --  The expression must be of a discrete type which must be determinable
+      --  independently of the context in which the expression occurs, but
+      --  using the fact that the expression must be of a discrete type.
+      --  Moreover, the type this expression must not be a character literal
+      --  (which is always ambiguous).
+
+      --  If error already reported by Resolve, nothing more to do
+
+      if Exp_Btype = Any_Discrete
+        or else Exp_Btype = Any_Type
+      then
+         return;
+
+      elsif Exp_Btype = Any_Character then
+         Error_Msg_N
+           ("character literal as case expression is ambiguous", Expr);
+         return;
+      end if;
+
+      --  If the case expression is a formal object of mode in out, then
+      --  treat it as having a nonstatic subtype by forcing use of the base
+      --  type (which has to get passed to Check_Case_Choices below).  Also
+      --  use base type when the case expression is parenthesized.
+
+      if Paren_Count (Expr) > 0
+        or else (Is_Entity_Name (Expr)
+                  and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter)
+      then
+         Exp_Type := Exp_Btype;
+      end if;
+
+      --  Call instantiated Analyze_Choices which does the rest of the work
+
+      Analyze_Choices
+        (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+
+      if Exp_Type = Universal_Integer and then not Others_Present then
+         Error_Msg_N
+           ("case on universal integer requires OTHERS choice", Expr);
+      end if;
+   end Analyze_Case_Expression;
+
    ---------------------------
    -- Analyze_Comparison_Op --
    ---------------------------
@@ -1263,8 +1403,13 @@  package body Sem_Ch4 is
          Analyze_Expression (Else_Expr);
       end if;
 
+      --  If then expression not overloaded, then that decides the type
+
       if not Is_Overloaded (Then_Expr) then
          Set_Etype (N, Etype (Then_Expr));
+
+      --  Case where then expression is overloaded
+
       else
          declare
             I  : Interp_Index;
@@ -1274,6 +1419,12 @@  package body Sem_Ch4 is
             Set_Etype (N, Any_Type);
             Get_First_Interp (Then_Expr, I, It);
             while Present (It.Nam) loop
+
+               --  For each possible intepretation of the Then Expression,
+               --  add it only if the else expression has a compatible type.
+
+               --  Is this right if Else_Expr is empty?
+
                if Has_Compatible_Type (Else_Expr, It.Typ) then
                   Add_One_Interp (N, It.Typ, It.Typ);
                end if;
Index: sem_ch4.ads
===================================================================
--- sem_ch4.ads	(revision 160959)
+++ sem_ch4.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -30,6 +30,7 @@  package Sem_Ch4  is
    procedure Analyze_Allocator                          (N : Node_Id);
    procedure Analyze_Arithmetic_Op                      (N : Node_Id);
    procedure Analyze_Call                               (N : Node_Id);
+   procedure Analyze_Case_Expression                    (N : Node_Id);
    procedure Analyze_Comparison_Op                      (N : Node_Id);
    procedure Analyze_Concatenation                      (N : Node_Id);
    procedure Analyze_Conditional_Expression             (N : Node_Id);
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 160962)
+++ sem_ch6.adb	(working copy)
@@ -6074,8 +6083,9 @@  package body Sem_Ch6 is
             when N_Aggregate =>
                return
                  FCL (Expressions (E1), Expressions (E2))
-                   and then FCL (Component_Associations (E1),
-                                 Component_Associations (E2));
+                   and then
+                 FCL (Component_Associations (E1),
+                      Component_Associations (E2));
 
             when N_Allocator =>
                if Nkind (Expression (E1)) = N_Qualified_Expression
@@ -6145,6 +6155,38 @@  package body Sem_Ch6 is
                    and then
                  FCE (Right_Opnd (E1), Right_Opnd (E2));
 
+            when N_Case_Expression =>
+               declare
+                  Alt1 : Node_Id;
+                  Alt2 : Node_Id;
+
+               begin
+                  if not FCE (Expression (E1), Expression (E2)) then
+                     return False;
+
+                  else
+                     Alt1 := First (Alternatives (E1));
+                     Alt2 := First (Alternatives (E2));
+                     loop
+                        if Present (Alt1) /= Present (Alt2) then
+                           return False;
+                        elsif No (Alt1) then
+                           return True;
+                        end if;
+
+                        if not FCE (Expression (Alt1), Expression (Alt2))
+                          or else not FCL (Discrete_Choices (Alt1),
+                                           Discrete_Choices (Alt2))
+                        then
+                           return False;
+                        end if;
+
+                        Next (Alt1);
+                        Next (Alt2);
+                     end loop;
+                  end if;
+               end;
+
             when N_Character_Literal =>
                return
                  Char_Literal_Value (E1) = Char_Literal_Value (E2);
@@ -6152,7 +6194,8 @@  package body Sem_Ch6 is
             when N_Component_Association =>
                return
                  FCL (Choices (E1), Choices (E2))
-                   and then FCE (Expression (E1), Expression (E2));
+                   and then
+                 FCE (Expression (E1), Expression (E2));
 
             when N_Conditional_Expression =>
                return
@@ -6173,13 +6216,15 @@  package body Sem_Ch6 is
             when N_Function_Call =>
                return
                  FCE (Name (E1), Name (E2))
-                   and then FCL (Parameter_Associations (E1),
-                                 Parameter_Associations (E2));
+                   and then
+                 FCL (Parameter_Associations (E1),
+                      Parameter_Associations (E2));
 
             when N_Indexed_Component =>
                return
                  FCE (Prefix (E1), Prefix (E2))
-                   and then FCL (Expressions (E1), Expressions (E2));
+                   and then
+                 FCL (Expressions (E1), Expressions (E2));
 
             when N_Integer_Literal =>
                return (Intval (E1) = Intval (E2));
@@ -6203,12 +6248,14 @@  package body Sem_Ch6 is
             when N_Qualified_Expression =>
                return
                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
-                   and then FCE (Expression (E1), Expression (E2));
+                   and then
+                 FCE (Expression (E1), Expression (E2));
 
             when N_Range =>
                return
                  FCE (Low_Bound (E1), Low_Bound (E2))
-                   and then FCE (High_Bound (E1), High_Bound (E2));
+                   and then
+                 FCE (High_Bound (E1), High_Bound (E2));
 
             when N_Real_Literal =>
                return (Realval (E1) = Realval (E2));
@@ -6216,12 +6263,14 @@  package body Sem_Ch6 is
             when N_Selected_Component =>
                return
                  FCE (Prefix (E1), Prefix (E2))
-                   and then FCE (Selector_Name (E1), Selector_Name (E2));
+                   and then
+                 FCE (Selector_Name (E1), Selector_Name (E2));
 
             when N_Slice =>
                return
                  FCE (Prefix (E1), Prefix (E2))
-                   and then FCE (Discrete_Range (E1), Discrete_Range (E2));
+                   and then
+                 FCE (Discrete_Range (E1), Discrete_Range (E2));
 
             when N_String_Literal =>
                declare
@@ -6250,17 +6299,20 @@  package body Sem_Ch6 is
             when N_Type_Conversion =>
                return
                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
-                   and then FCE (Expression (E1), Expression (E2));
+                   and then
+                 FCE (Expression (E1), Expression (E2));
 
             when N_Unary_Op =>
                return
                  Entity (E1) = Entity (E2)
-                   and then FCE (Right_Opnd (E1), Right_Opnd (E2));
+                   and then
+                 FCE (Right_Opnd (E1), Right_Opnd (E2));
 
             when N_Unchecked_Type_Conversion =>
                return
                  FCE (Subtype_Mark (E1), Subtype_Mark (E2))
-                   and then FCE (Expression (E1), Expression (E2));
+                   and then
+                 FCE (Expression (E1), Expression (E2));
 
             --  All other node types cannot appear in this context. Strictly
             --  we should raise a fatal internal error. Instead we just ignore
Index: sem_eval.adb
===================================================================
--- sem_eval.adb	(revision 160969)
+++ sem_eval.adb	(working copy)
@@ -1666,6 +1666,27 @@  package body Sem_Eval is
       end if;
    end Eval_Call;
 
+   --------------------------
+   -- Eval_Case_Expression --
+   --------------------------
+
+   --  Right now we do not attempt folding of any case expressions, and the
+   --  language does not require it, so the only required processing is to
+   --  do the check for all expressions appearing in the case expression.
+
+   procedure Eval_Case_Expression (N : Node_Id) is
+      Alt : Node_Id;
+
+   begin
+      Check_Non_Static_Context (Expression (N));
+
+      Alt := First (Alternatives (N));
+      while Present (Alt) loop
+         Check_Non_Static_Context (Expression (Alt));
+         Next (Alt);
+      end loop;
+   end Eval_Case_Expression;
+
    ------------------------
    -- Eval_Concatenation --
    ------------------------
@@ -1783,15 +1804,14 @@  package body Sem_Eval is
    -- Eval_Conditional_Expression --
    ---------------------------------
 
-   --  This GNAT internal construct can never be statically folded, so the
-   --  only required processing is to do the check for non-static context
-   --  for the two expression operands.
+   --  We never attempt folding of conditional expressions (and the language)
+   --  does not require it, so the only required processing is to do the check
+   --  for non-static context for the then and else expressions.
 
    procedure Eval_Conditional_Expression (N : Node_Id) is
       Condition : constant Node_Id := First (Expressions (N));
       Then_Expr : constant Node_Id := Next (Condition);
       Else_Expr : constant Node_Id := Next (Then_Expr);
-
    begin
       Check_Non_Static_Context (Then_Expr);
       Check_Non_Static_Context (Else_Expr);
Index: sem_eval.ads
===================================================================
--- sem_eval.ads	(revision 160959)
+++ sem_eval.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -282,6 +282,7 @@  package Sem_Eval is
    procedure Eval_Allocator              (N : Node_Id);
    procedure Eval_Arithmetic_Op          (N : Node_Id);
    procedure Eval_Call                   (N : Node_Id);
+   procedure Eval_Case_Expression        (N : Node_Id);
    procedure Eval_Character_Literal      (N : Node_Id);
    procedure Eval_Concatenation          (N : Node_Id);
    procedure Eval_Conditional_Expression (N : Node_Id);
Index: sprint.adb
===================================================================
--- sprint.adb	(revision 160969)
+++ sprint.adb	(working copy)
@@ -1084,6 +1084,32 @@  package body Sprint is
 
             Write_Char (';');
 
+         when N_Case_Expression =>
+            declare
+               Alt : Node_Id;
+
+            begin
+               Write_Str_With_Col_Check_Sloc ("(case ");
+               Sprint_Node (Expression (Node));
+               Write_Str_With_Col_Check (" is");
+
+               Alt := First (Alternatives (Node));
+               loop
+                  Sprint_Node (Alt);
+                  Next (Alt);
+                  exit when No (Alt);
+                  Write_Char (',');
+               end loop;
+
+               Write_Char (')');
+            end;
+
+         when N_Case_Expression_Alternative =>
+            Write_Str_With_Col_Check (" when ");
+            Sprint_Bar_List (Discrete_Choices (Node));
+            Write_Str (" => ");
+            Sprint_Node (Expression (Node));
+
          when N_Case_Statement =>
             Write_Indent_Str_Sloc ("case ");
             Sprint_Node (Expression (Node));