diff mbox

[Ada] Implement new Expression_With_Actions node

Message ID 20100617155451.GA26562@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet June 17, 2010, 3:54 p.m. UTC
This patch is the front end work for implementing a new node type
Expression_With_Actions. This is currently used if the debug flag
-gnatd.X is set and a short circuit form has right hand operand
actions. The sprint syntax is do action; action ... in expression end.
This test program:

procedure ExprActions (A, B, C : Natural; M, N : String) is
begin
   if (A = 23 and then M (1 .. A) = N (1 .. B))
     or else M (A .. B) = M (B .. C)
   then
      null;
   end if;
end ExprActions;

Now generates the following -gnatG output if -gnatd.X is set:

Source recreated from tree for Expractions (body)


procedure expractions (a : natural; b : natural; c : natural; m :
  string; n : string) is
   subtype expractions__S2b is string (n'first(1) .. n'last(1));
   subtype expractions__S1b is string (m'first(1) .. m'last(1));
begin
   if (a = 23 and then
      do
         [constraint_error when
           a >= 1 and then (1 < m'first(1) or else integer(a) > m'last(
             1))
           "range check failed"]
         reference expractions__T4b[constraint_error when
           b >= 1 and then (1 < n'first(1) or else integer(b) > n'last(
             1))
           "range check failed"]
         reference expractions__T6b
      in m (1 .. a) = n (1 .. b) end
   ) or else
      do
         [constraint_error when
           b >= a and then (integer(a) < m'first(1) or else integer(b) >
             m'last(1))
           "range check failed"]
         reference expractions__T8b[constraint_error when
           c >= b and then (integer(b) < m'first(1) or else integer(c) >
             m'last(1))
           "range check failed"]
         reference expractions__T10b
      in m (a .. b) = m (b .. c) end
    then
      null;
   end if;
   return;
end expractions;

This patch does not include the required gigi adjustments to process
this new node (which is why it is under a debug flag for now), so with
only this patch, the above test compiled with -gnatd.X will blowup
in gigi. Eric will commit the corresponding support for
N_Expression_With_Actions in gigi later.

The motivation behind this is to avoid the problem with the old style
expansion of short circuit forms with right operand actions. The old
style introduced a boolean temporary which caused problems with
coverage analysis.

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

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

	* debug.adb: New debug flag -gnatd.X to use Expression_With_Actions
	node when expanding short circuit form with actions present for right
	opnd.
	* exp_ch4.adb: Minor reformatting
	(Expand_Short_Circuit_Operator): Use new Expression_With_Actions node if
	right opeand has actions present, and debug flag -gnatd.X is set.
	* exp_util.adb (Insert_Actions): Handle case of Expression_With_Actions
	node.
	* nlists.adb (Prepend_List): New procedure
	(Prepend_List_To): New procedure
	* nlists.ads (Prepend_List): New procedure
	(Prepend_List_To): New procedure
	* sem.adb: Add processing for Expression_With_Actions
	* sem_ch4.adb (Analyze_Expression_With_Actions): New procedure
	* sem_ch4.ads (Analyze_Expression_With_Actions): New procedure
	* sem_res.adb: Add processing for Expression_With_Actions.
	* sem_scil.adb: Add processing for Expression_With_Actions
	* sinfo.ads, sinfo.adb (N_Expression_With_Actions): New node.
	* sprint.ads, sprint.adb: Add processing for Expression_With_Actions
diff mbox

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 160923)
+++ exp_util.adb	(working copy)
@@ -2417,6 +2417,13 @@  package body Exp_Util is
                   end if;
                end;
 
+            --  Case of appearing within an Expressions_With_Actions node. We
+            --  prepend the actions to the list of actions already there.
+
+            when N_Expression_With_Actions =>
+               Prepend_List (Ins_Actions, Actions (P));
+               return;
+
             --  Case of appearing in the condition of a while expression or
             --  elsif. We insert the actions into the Condition_Actions field.
             --  They will be moved further out when the while loop or elsif
Index: nlists.adb
===================================================================
--- nlists.adb	(revision 160923)
+++ nlists.adb	(working copy)
@@ -1055,6 +1055,77 @@  package body Nlists is
       Set_List_Link (Node, To);
    end Prepend;
 
+   ------------------
+   -- Prepend_List --
+   ------------------
+
+   procedure Prepend_List (List : List_Id; To : List_Id) is
+
+      procedure Prepend_List_Debug;
+      pragma Inline (Prepend_List_Debug);
+      --  Output debug information if Debug_Flag_N set
+
+      ------------------------
+      -- Prepend_List_Debug --
+      ------------------------
+
+      procedure Prepend_List_Debug is
+      begin
+         if Debug_Flag_N then
+            Write_Str ("Prepend list ");
+            Write_Int (Int (List));
+            Write_Str (" to list ");
+            Write_Int (Int (To));
+            Write_Eol;
+         end if;
+      end Prepend_List_Debug;
+
+   --  Start of processing for Prepend_List
+
+   begin
+      if Is_Empty_List (List) then
+         return;
+
+      else
+         declare
+            F : constant Node_Id := First (To);
+            L : constant Node_Id := Last (List);
+            N : Node_Id;
+
+         begin
+            pragma Debug (Prepend_List_Debug);
+
+            N := L;
+            loop
+               Set_List_Link (N, To);
+               N := Prev (N);
+               exit when No (N);
+            end loop;
+
+            if No (F) then
+               Set_Last (To, L);
+            else
+               Set_Next (L, F);
+            end if;
+
+            Set_Prev (F, L);
+            Set_First (To, First (List));
+
+            Set_First (List, Empty);
+            Set_Last  (List, Empty);
+         end;
+      end if;
+   end Prepend_List;
+
+   ---------------------
+   -- Prepend_List_To --
+   ---------------------
+
+   procedure Prepend_List_To (To : List_Id; List : List_Id) is
+   begin
+      Prepend_List (List, To);
+   end Prepend_List_To;
+
    ----------------
    -- Prepend_To --
    ----------------
Index: nlists.ads
===================================================================
--- nlists.ads	(revision 160923)
+++ nlists.ads	(working copy)
@@ -259,6 +259,14 @@  package Nlists is
    pragma Inline (Prepend_To);
    --  Like Prepend, but arguments are the other way round
 
+   procedure Prepend_List (List : List_Id; To : List_Id);
+   --  Prepends node list List to the start of node list To. On return,
+   --  List is reset to be empty.
+
+   procedure Prepend_List_To (To : List_Id; List : List_Id);
+   pragma Inline (Prepend_List_To);
+   --  Like Prepend_List, but arguments are the other way round
+
    procedure Remove (Node : Node_Id);
    --  Removes Node, which must be a node that is a member of a node list,
    --  from this node list. The contents of Node are not otherwise affected.
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 160923)
+++ sinfo.adb	(working copy)
@@ -147,6 +147,7 @@  package body Sinfo is
       pragma Assert (False
         or else NT (N).Nkind = N_And_Then
         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
         or else NT (N).Nkind = N_Or_Else);
       return List1 (N);
@@ -1178,6 +1179,7 @@  package body Sinfo is
         or else NT (N).Nkind = N_Discriminant_Association
         or else NT (N).Nkind = N_Discriminant_Specification
         or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Expression_With_Actions
         or else NT (N).Nkind = N_Free_Statement
         or else NT (N).Nkind = N_Mod_Clause
         or else NT (N).Nkind = N_Modular_Type_Definition
@@ -3058,6 +3060,7 @@  package body Sinfo is
       pragma Assert (False
         or else NT (N).Nkind = N_And_Then
         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
         or else NT (N).Nkind = N_Or_Else);
       Set_List1_With_Parent (N, Val);
@@ -4080,6 +4083,7 @@  package body Sinfo is
         or else NT (N).Nkind = N_Discriminant_Association
         or else NT (N).Nkind = N_Discriminant_Specification
         or else NT (N).Nkind = N_Exception_Declaration
+        or else NT (N).Nkind = N_Expression_With_Actions
         or else NT (N).Nkind = N_Free_Statement
         or else NT (N).Nkind = N_Mod_Clause
         or else NT (N).Nkind = N_Modular_Type_Definition
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 160923)
+++ sinfo.ads	(working copy)
@@ -6611,6 +6611,38 @@  package Sinfo is
       --  Has_Private_View (Flag11-Sem) set in generic units.
       --  plus fields for expression
 
+      -----------------------------
+      -- Expression with Actions --
+      -----------------------------
+
+      --  This node is created by the analyzer/expander to handle some
+      --  expansion cases, notably short circuit forms where there are
+      --  actions associated with the right hand operand.
+
+      --  The N_Expression_With_Actions node represents an expression with
+      --  an associated set of actions (which are executable statements).
+      --  The required semantics is that the set of actions is executed in
+      --  the order in which it appears just before the expression is
+      --  evaluated (and these actions must only be executed if the value
+      --  of the expression is evaluated). The node is considered to be
+      --  a subexpression, whose value is the value of the Expression after
+      --  executing all the actions.
+
+      --  Sprint syntax:  do
+      --                    action;
+      --                    action;
+      --                    ...
+      --                    action;
+      --                  in expression end
+
+      --  N_Expression_With_Actions
+      --  Actions (List1)
+      --  Expression (Node3)
+      --  plus fields for expression
+
+      --  Note: the actions list is always non-null, since we would
+      --  never have created this node if there weren't some actions.
+
       --------------------
       -- Free Statement --
       --------------------
@@ -7195,6 +7227,7 @@  package Sinfo is
 
       N_Conditional_Expression,
       N_Explicit_Dereference,
+      N_Expression_With_Actions,
       N_Function_Call,
       N_Indexed_Component,
       N_Integer_Literal,
@@ -10984,6 +11017,13 @@  package Sinfo is
         4 => False,   --  Entity (Node4-Sem)
         5 => False),  --  Etype (Node5-Sem)
 
+     N_Expression_With_Actions =>
+       (1 => True,    --  Actions (List1)
+        2 => False,   --  unused
+        3 => True,    --  Expression (Node3)
+        4 => False,   --  unused
+        5 => False),  --  unused
+
      N_Free_Statement =>
        (1 => False,   --  Storage_Pool (Node1-Sem)
         2 => False,   --  Procedure_To_Call (Node2-Sem)
Index: sem_scil.adb
===================================================================
--- sem_scil.adb	(revision 160923)
+++ sem_scil.adb	(working copy)
@@ -544,6 +544,7 @@  package body Sem_SCIL is
                N_Exception_Handler                      |
                N_Expanded_Name                          |
                N_Explicit_Dereference                   |
+               N_Expression_With_Actions                |
                N_Extension_Aggregate                    |
                N_Floating_Point_Definition              |
                N_Formal_Decimal_Fixed_Point_Definition  |
Index: debug.adb
===================================================================
--- debug.adb	(revision 160923)
+++ debug.adb	(working copy)
@@ -141,7 +141,7 @@  package body Debug is
    --  d.U
    --  d.V
    --  d.W  Print out debugging information for Walk_Library_Items
-   --  d.X
+   --  d.X  Use Expression_With_Actions for short-circuited forms
    --  d.Y
    --  d.Z
 
@@ -579,6 +579,13 @@  package body Debug is
    --       the order in which units are walked. This is primarily for SofCheck
    --       Inspector.
 
+   --  d.X  By default, the compiler uses an elaborate rewriting framework for
+   --       short-circuited forms where the right hand condition generates
+   --       actions to be inserted. Use of this switch causes the compiler to
+   --       use the much simpler Expression_With_Actions node for this purpose.
+   --       It is a debug flag to aid transitional implementation in gigi and
+   --       the back end. As soon as that works fine, we will remove this flag.
+
    --  d1   Error messages have node numbers where possible. Normally error
    --       messages have only source locations. This option is useful when
    --       debugging errors caused by expanded code, where the source location
Index: sem.adb
===================================================================
--- sem.adb	(revision 160925)
+++ sem.adb	(working copy)
@@ -221,6 +221,9 @@  package body Sem is
          when N_Explicit_Dereference =>
             Analyze_Explicit_Dereference (N);
 
+         when N_Expression_With_Actions =>
+            Analyze_Expression_With_Actions (N);
+
          when N_Extended_Return_Statement =>
             Analyze_Extended_Return_Statement (N);
 
@@ -1709,7 +1712,7 @@  package body Sem is
 
          if Nkind (Unit (Withed_Unit)) = N_Package_Body
            and then Is_Generic_Instance
-             (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
+                      (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
          then
             Do_Withed_Unit (Library_Unit (Withed_Unit));
          end if;
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 160923)
+++ sem_res.adb	(working copy)
@@ -163,9 +163,10 @@  package body Sem_Res is
    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);
+   procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Equality_Op               (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Explicit_Dereference      (N : Node_Id; Typ : Entity_Id);
-   procedure Resolve_Entity_Name               (N : Node_Id; Typ : Entity_Id);
+   procedure Resolve_Expression_With_Actions   (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Indexed_Component         (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Integer_Literal           (N : Node_Id; Typ : Entity_Id);
    procedure Resolve_Logical_Op                (N : Node_Id; Typ : Entity_Id);
@@ -1842,6 +1843,7 @@  package body Sem_Res is
             --  Check that Typ is a remote access-to-subprogram type
 
             if Is_Remote_Access_To_Subprogram_Type (Typ) then
+
                --  Prefix (N) must statically denote a remote subprogram
                --  declared in a package specification.
 
@@ -2542,12 +2544,15 @@  package body Sem_Res is
             when N_Expanded_Name
                              => Resolve_Entity_Name              (N, Ctx_Type);
 
-            when N_Extension_Aggregate
-                             => Resolve_Extension_Aggregate      (N, Ctx_Type);
-
             when N_Explicit_Dereference
                              => Resolve_Explicit_Dereference     (N, Ctx_Type);
 
+            when N_Expression_With_Actions
+                             => Resolve_Expression_With_Actions  (N, Ctx_Type);
+
+            when N_Extension_Aggregate
+                             => Resolve_Extension_Aggregate      (N, Ctx_Type);
+
             when N_Function_Call
                              => Resolve_Call                     (N, Ctx_Type);
 
@@ -6494,6 +6499,15 @@  package body Sem_Res is
 
    end Resolve_Explicit_Dereference;
 
+   -------------------------------------
+   -- Resolve_Expression_With_Actions --
+   -------------------------------------
+
+   procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is
+   begin
+      Set_Etype (N, Typ);
+   end Resolve_Expression_With_Actions;
+
    -------------------------------
    -- Resolve_Indexed_Component --
    -------------------------------
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 160923)
+++ exp_ch4.adb	(working copy)
@@ -323,10 +323,8 @@  package body Exp_Ch4 is
          if Nkind (Op1) = N_Op_Not then
             if Kind = N_Op_And then
                Proc_Name := RTE (RE_Vector_Nor);
-
             elsif Kind = N_Op_Or then
                Proc_Name := RTE (RE_Vector_Nand);
-
             else
                Proc_Name := RTE (RE_Vector_Xor);
             end if;
@@ -334,14 +332,11 @@  package body Exp_Ch4 is
          else
             if Kind = N_Op_And then
                Proc_Name := RTE (RE_Vector_And);
-
             elsif Kind = N_Op_Or then
                Proc_Name := RTE (RE_Vector_Or);
-
             elsif Nkind (Op2) = N_Op_Not then
                Proc_Name := RTE (RE_Vector_Nxor);
                Arg2 := Right_Opnd (Op2);
-
             else
                Proc_Name := RTE (RE_Vector_Xor);
             end if;
@@ -352,15 +347,15 @@  package body Exp_Ch4 is
              Name => New_Occurrence_Of (Proc_Name, Loc),
              Parameter_Associations => New_List (
                Target,
-                  Make_Attribute_Reference (Loc,
-                    Prefix => Arg1,
-                    Attribute_Name => Name_Address),
-                  Make_Attribute_Reference (Loc,
-                    Prefix => Arg2,
-                    Attribute_Name => Name_Address),
-                 Make_Attribute_Reference (Loc,
-                   Prefix => Op1,
-                    Attribute_Name => Name_Length)));
+               Make_Attribute_Reference (Loc,
+                 Prefix         => Arg1,
+                 Attribute_Name => Name_Address),
+               Make_Attribute_Reference (Loc,
+                 Prefix         => Arg2,
+                 Attribute_Name => Name_Address),
+               Make_Attribute_Reference (Loc,
+                 Prefix         => Op1,
+                 Attribute_Name => Name_Length)));
       end if;
 
       Rewrite (N, Call_Node);
@@ -8718,8 +8713,9 @@  package body Exp_Ch4 is
    -- Expand_Short_Circuit_Operator --
    -----------------------------------
 
-   --  Expand into conditional expression if Actions present, and also deal
-   --  with optimizing case of arguments being True or False.
+   --  Deal with special expansion if actions are present for the right operand
+   --  and deal with optimizing case of arguments being True or False. We also
+   --  deal with the special case of non-standard boolean values.
 
    procedure Expand_Short_Circuit_Operator (N : Node_Id) is
       Loc     : constant Source_Ptr := Sloc (N);
@@ -8727,6 +8723,7 @@  package body Exp_Ch4 is
       Kind    : constant Node_Kind  := Nkind (N);
       Left    : constant Node_Id    := Left_Opnd (N);
       Right   : constant Node_Id    := Right_Opnd (N);
+      LocR    : constant Source_Ptr := Sloc (Right);
       Actlist : List_Id;
 
       Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
@@ -8800,63 +8797,88 @@  package body Exp_Ch4 is
          return;
       end if;
 
-      --  If Actions are present, we expand
-
-      --     left AND THEN right
-
-      --  into
+      --  If Actions are present for the right operand, we have to do some
+      --  special processing. We can't just let these actions filter back into
+      --  code preceding the short circuit (which is what would have happened
+      --  if we had not trapped them in the short-circuit form), since they
+      --  must only be executed if the right operand of the short circuit is
+      --  executed and not otherwise.
 
-      --     C : Boolean := False;
-      --     IF left THEN
-      --        Actions;
-      --        IF right THEN
-      --           C := True;
-      --        END IF;
-      --     END IF;
-
-      --  and finally rewrite the operator into a reference to C. Similarly
-      --  for left OR ELSE right, with negated values. Note that this rewriting
-      --  preserves two invariants that traces-based coverage analysis depends
-      --  upon:
-
-      --    - there is exactly one conditional jump for each operand;
-
-      --    - for each possible values of the expression, there is exactly
-      --      one location in the generated code that is branched to
-      --      (the inner assignment in one case, the point just past the
-      --      outer END IF; in the other case).
+      --  the temporary variable C.
 
       if Present (Actions (N)) then
          Actlist := Actions (N);
 
-         Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
+         --  The old approach is to expand:
 
-         Insert_Action (N,
-           Make_Object_Declaration (Loc,
-             Defining_Identifier =>
-               Op_Var,
-             Object_Definition =>
-               New_Occurrence_Of (Standard_Boolean, Loc),
-             Expression =>
-               New_Occurrence_Of (Shortcut_Ent, Loc)));
-
-         Append_To (Actlist,
-           Make_Implicit_If_Statement (Right,
-             Condition       => Make_Test_Expr (Right),
-             Then_Statements => New_List (
-               Make_Assignment_Statement (Sloc (Right),
-                 Name =>
-                   New_Occurrence_Of (Op_Var, Sloc (Right)),
-                 Expression =>
-                   New_Occurrence_Of
-                     (Boolean_Literals (not Shortcut_Value), Sloc (Right))))));
+         --     left AND THEN right
 
-         Insert_Action (N,
-           Make_Implicit_If_Statement (Left,
-             Condition       => Make_Test_Expr (Left),
-             Then_Statements => Actlist));
+         --  into
 
-         Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
+         --     C : Boolean := False;
+         --     IF left THEN
+         --        Actions;
+         --        IF right THEN
+         --           C := True;
+         --        END IF;
+         --     END IF;
+
+         --  and finally rewrite the operator into a reference to C. Similarly
+         --  for left OR ELSE right, with negated values. Note that this
+         --  rewrite causes some difficulties for coverage analysis because
+         --  of the introduction of the new variable C, which obscures the
+         --  structure of the test.
+
+         --  We use this "old approach" by default for now, unless the
+         --  special debug switch gnatd.X is used.
+
+         if not Debug_Flag_Dot_XX then
+            Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
+
+            Insert_Action (N,
+              Make_Object_Declaration (Loc,
+                Defining_Identifier =>
+                  Op_Var,
+                Object_Definition   =>
+                  New_Occurrence_Of (Standard_Boolean, Loc),
+                Expression          =>
+                  New_Occurrence_Of (Shortcut_Ent, Loc)));
+
+            Append_To (Actlist,
+              Make_Implicit_If_Statement (Right,
+                Condition       => Make_Test_Expr (Right),
+                Then_Statements => New_List (
+                  Make_Assignment_Statement (LocR,
+                    Name       => New_Occurrence_Of (Op_Var, LocR),
+                    Expression =>
+                      New_Occurrence_Of
+                        (Boolean_Literals (not Shortcut_Value), LocR)))));
+
+            Insert_Action (N,
+              Make_Implicit_If_Statement (Left,
+                Condition       => Make_Test_Expr (Left),
+                Then_Statements => Actlist));
+
+            Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
+            Analyze_And_Resolve (N, Standard_Boolean);
+
+         --  The new approach, activated for now by the use of debug flag
+         --  -gnatd.X is to use the new Expression_With_Actions node for the
+         --  right operand of the short-circuit form. This should solve the
+         --  traceability problems for coverage analysis.
+
+         else
+            Rewrite (Right,
+              Make_Expression_With_Actions (LocR,
+                Expression => Relocate_Node (Right),
+                Actions    => Actlist));
+            Analyze_And_Resolve (Right, Standard_Boolean);
+         end if;
+
+         --  Special processing necessary for SCIL generation for AND THEN
+         --  with a function call as the right operand.
+
+         --  What is this about, and is it needed for both cases above???
 
          if Generate_SCIL
            and then Kind = N_And_Then
@@ -8865,7 +8887,6 @@  package body Exp_Ch4 is
             Adjust_SCIL_Node (N, Right);
          end if;
 
-         Analyze_And_Resolve (N, Standard_Boolean);
          Adjust_Result_Type (N, Typ);
          return;
       end if;
Index: sem_ch4.adb
===================================================================
--- sem_ch4.adb	(revision 160923)
+++ sem_ch4.adb	(working copy)
@@ -1589,6 +1589,25 @@  package body Sem_Ch4 is
       Check_Parameterless_Call (N);
    end Analyze_Expression;
 
+   -------------------------------------
+   -- Analyze_Expression_With_Actions --
+   -------------------------------------
+
+   procedure Analyze_Expression_With_Actions (N : Node_Id) is
+      A : Node_Id;
+
+   begin
+      A := First (Actions (N));
+      loop
+         Analyze (A);
+         Next (A);
+         exit when No (A);
+      end loop;
+
+      Analyze_Expression (Expression (N));
+      Set_Etype (N, Etype (Expression (N)));
+   end Analyze_Expression_With_Actions;
+
    ------------------------------------
    -- Analyze_Indexed_Component_Form --
    ------------------------------------
@@ -6119,8 +6138,8 @@  package body Sem_Ch4 is
          First_Actual : Node_Id;
 
       begin
-         --  Place the name of the operation, with its interpretations, on the
-         --  rewritten call.
+         --  Place the name of the operation, with its interpretations,
+         --  on the rewritten call.
 
          Set_Name (Call_Node, Subprog);
 
Index: sem_ch4.ads
===================================================================
--- sem_ch4.ads	(revision 160923)
+++ sem_ch4.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -35,6 +35,7 @@  package Sem_Ch4  is
    procedure Analyze_Conditional_Expression             (N : Node_Id);
    procedure Analyze_Equality_Op                        (N : Node_Id);
    procedure Analyze_Explicit_Dereference               (N : Node_Id);
+   procedure Analyze_Expression_With_Actions            (N : Node_Id);
    procedure Analyze_Logical_Op                         (N : Node_Id);
    procedure Analyze_Membership_Op                      (N : Node_Id);
    procedure Analyze_Negation                           (N : Node_Id);
Index: sprint.adb
===================================================================
--- sprint.adb	(revision 160923)
+++ sprint.adb	(working copy)
@@ -1509,6 +1509,20 @@  package body Sprint is
             Write_Char_Sloc ('.');
             Write_Str_Sloc ("all");
 
+         when N_Expression_With_Actions =>
+            Indent_Begin;
+            Write_Indent_Str_Sloc ("do");
+            Indent_Begin;
+            Write_Indent;
+            Sprint_Node_List (Actions (Node));
+            Indent_End;
+            Write_Indent;
+            Write_Str_With_Col_Check_Sloc ("in ");
+            Sprint_Node (Expression (Node));
+            Write_Str_With_Col_Check (" end");
+            Indent_End;
+            Write_Indent;
+
          when N_Extended_Return_Statement =>
             Write_Indent_Str_Sloc ("return ");
             Sprint_Node_List (Return_Object_Declarations (Node));
Index: sprint.ads
===================================================================
--- sprint.ads	(revision 160923)
+++ sprint.ads	(working copy)
@@ -53,8 +53,8 @@  package Sprint is
    --    Convert wi Rounded_Result           target@(source)
    --    Divide wi Treat_Fixed_As_Integer    x #/ y
    --    Divide wi Rounded_Result            x @/ y
+   --    Expression with actions             do action; .. action; in expr end
    --    Expression with range check         {expression}
-   --    Operator with range check           {operator} (e.g. {+})
    --    Free statement                      free expr [storage_pool = xxx]
    --    Freeze entity with freeze actions   freeze entityname [ actions ]
    --    Implicit call to run time routine   $routine-name
@@ -69,6 +69,7 @@  package Sprint is
    --    Multiple concatenation              expr && expr && expr ... && expr
    --    Multiply wi Treat_Fixed_As_Integer  x #* y
    --    Multiply wi Rounded_Result          x @* y
+   --    Operator with range check           {operator} (e.g. {+})
    --    Others choice for cleanup           when all others
    --    Pop exception label                 %pop_xxx_exception_label
    --    Push exception label                %push_xxx_exception_label (label)