===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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 =>
===================================================================
@@ -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 |
===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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 |
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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.
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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 |
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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 --
------------------------------
===================================================================
@@ -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 --
-------------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
---------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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.
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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.
===================================================================
@@ -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 --
-------------------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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);
===================================================================
@@ -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
===================================================================
@@ -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);
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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);
===================================================================
@@ -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));
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.