checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case expression (cannot count on a particular branch being executed).

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.

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

	* par-ch7.adb, sem_warn.adb, types.ads, par-ch3.adb: Minor reformatting.
	* gnat1drv.adb: Fix typo.

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

	* par-prag.adb (Prag, case Style_Checks): All_Checks sets gnat style
	for -gnatg.
	* sem_prag.adb (Analyze_Pragma, case Style_Checks): All_Checks sets
	gnat style for -gnatg.
	* gnat_rm.texi: Add documentation for ALL_CHECKS in GNAT mode.

From-SVN: r160971

1 files changed, 131 insertions, 0 deletions

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 821103c..9a67fa9c 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -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 --
    -------------------------------------