[multiple changes]

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

	* exp_ch4.ads: Minor code reorganization (specs in alpha order).

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

2010-06-17  Doug Rupp  <rupp@adacore.com>

	* sem_intr.adb (Check_Intrinsic_Operator): Check that the types
	involved both have underlying integer types.
	* exp_intr.adb (Expand_Binary_Operator) New subprogram to expand a call
	to an intrinsic operator when the operand types or sizes are not
	identical.
	* s-auxdec-vms_64.ads: Revert "+" "-" ops back to Address now that
	64/32 Address/Integer works.

From-SVN: r160929

gcc/ada/ChangeLog

+2010-06-17  Robert Dewar  <dewar@adacore.com>
+
+	* exp_ch4.ads: Minor code reorganization (specs in alpha order).
+
+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
+
+2010-06-17  Doug Rupp  <rupp@adacore.com>
+
+	* sem_intr.adb (Check_Intrinsic_Operator): Check that the types
+	involved both have underlying integer types.
+	* exp_intr.adb (Expand_Binary_Operator) New subprogram to expand a call
+	to an intrinsic operator when the operand types or sizes are not
+	identical.
+	* s-auxdec-vms_64.ads: Revert "+" "-" ops back to Address now that
+	64/32 Address/Integer works.
+
 2010-06-17  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch12.adb (Mark_Context): Refine placement of Withed_Body flag, so

gcc/ada/debug.adb

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

gcc/ada/exp_ch4.adb

@@ -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
+      --  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.
 
-      --     left AND THEN right
+      --  the temporary variable C.
 
-      --  into
+      if Present (Actions (N)) then
+         Actlist := Actions (N);
 
-      --     C : Boolean := False;
-      --     IF left THEN
-      --        Actions;
-      --        IF right THEN
-      --           C := True;
-      --        END IF;
-      --     END IF;
+         --  The old approach is to expand:
 
-      --  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:
+         --     left AND THEN right
 
-      --    - there is exactly one conditional jump for each operand;
+         --  into
 
-      --    - 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).
+         --     C : Boolean := False;
+         --     IF left THEN
+         --        Actions;
+         --        IF right THEN
+         --           C := True;
+         --        END IF;
+         --     END IF;
 
-      if Present (Actions (N)) then
-         Actlist := Actions (N);
+         --  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.
 
-         Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
+         --  We use this "old approach" by default for now, unless the
+         --  special debug switch gnatd.X is used.
 
-         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))))));
+         if not Debug_Flag_Dot_XX then
+            Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
 
-         Insert_Action (N,
-           Make_Implicit_If_Statement (Left,
-             Condition       => Make_Test_Expr (Left),
-             Then_Statements => Actlist));
+            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)))));
 
-         Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
+            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;

gcc/ada/exp_ch4.ads

@@ -32,8 +32,8 @@ package Exp_Ch4 is
    procedure Expand_N_Allocator                   (N : Node_Id);
    procedure Expand_N_And_Then                    (N : Node_Id);
    procedure Expand_N_Conditional_Expression      (N : Node_Id);
-   procedure Expand_N_In                          (N : Node_Id);
    procedure Expand_N_Explicit_Dereference        (N : Node_Id);
+   procedure Expand_N_In                          (N : Node_Id);
    procedure Expand_N_Indexed_Component           (N : Node_Id);
    procedure Expand_N_Not_In                      (N : Node_Id);
    procedure Expand_N_Null                        (N : Node_Id);

gcc/ada/exp_intr.adb

@@ -63,6 +63,10 @@ package body Exp_Intr is
    -- Local Subprograms --
    -----------------------
 
+   procedure Expand_Binary_Operator_Call (N : Node_Id);
+   --  Expand a call to an intrinsic arithmetic operator when the operand
+   --  types or sizes are not identical.
+
    procedure Expand_Is_Negative (N : Node_Id);
    --  Expand a call to the intrinsic Is_Negative function
 
@@ -108,6 +112,44 @@ package body Exp_Intr is
    --    Name_Source_Location  - expand string of form file:line
    --    Name_Enclosing_Entity - expand string  with name of enclosing entity
 
+   ---------------------------------
+   -- Expand_Binary_Operator_Call --
+   ---------------------------------
+
+   procedure Expand_Binary_Operator_Call (N : Node_Id) is
+      T1  : constant Entity_Id := Underlying_Type (Left_Opnd  (N));
+      T2  : constant Entity_Id := Underlying_Type (Right_Opnd (N));
+      TR  : constant Entity_Id := Etype (N);
+      T3  : Entity_Id;
+      Res : Node_Id;
+      Siz : Uint;
+
+   begin
+      if Esize (T1) > Esize (T2) then
+         Siz := Esize (T1);
+      else
+         Siz := Esize (T2);
+      end if;
+
+      if Siz > 32 then
+         T3 := RTE (RE_Unsigned_64);
+      else
+         T3 := RTE (RE_Unsigned_32);
+      end if;
+
+      Res := New_Copy (N);
+      Set_Etype (Res, Empty);
+      Set_Entity (Res, Empty);
+
+      Set_Left_Opnd (Res,
+         Unchecked_Convert_To (T3, Relocate_Node (Left_Opnd (N))));
+      Set_Right_Opnd (Res,
+         Unchecked_Convert_To (T3, Relocate_Node (Right_Opnd (N))));
+
+      Rewrite (N, Unchecked_Convert_To (TR, Res));
+      Analyze_And_Resolve (N, TR);
+   end Expand_Binary_Operator_Call;
+
    -----------------------------------------
    -- Expand_Dispatching_Constructor_Call --
    -----------------------------------------
@@ -487,6 +529,9 @@ package body Exp_Intr is
       elsif Present (Alias (E)) then
          Expand_Intrinsic_Call (N,  Alias (E));
 
+      elsif Nkind (N) in N_Binary_Op then
+         Expand_Binary_Operator_Call (N);
+
          --  The only other case is where an external name was specified,
          --  since this is the only way that an otherwise unrecognized
          --  name could escape the checking in Sem_Prag. Nothing needs

gcc/ada/exp_util.adb

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

gcc/ada/nlists.adb

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

gcc/ada/nlists.ads

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

gcc/ada/s-auxdec-vms_64.ads

@@ -107,10 +107,10 @@ package System.Aux_DEC is
    Address_Size       : constant := Standard'Address_Size;
    Short_Address_Size : constant := 32;
 
-   function "+" (Left : Short_Address; Right : Integer) return Short_Address;
-   function "+" (Left : Integer; Right : Short_Address) return Short_Address;
-   function "-" (Left : Short_Address; Right : Short_Address) return Integer;
-   function "-" (Left : Short_Address; Right : Integer) return Short_Address;
+   function "+" (Left : Address; Right : Integer) return Address;
+   function "+" (Left : Integer; Right : Address) return Address;
+   function "-" (Left : Address; Right : Address) return Integer;
+   function "-" (Left : Address; Right : Integer) return Address;
 
    pragma Import (Intrinsic, "+");
    pragma Import (Intrinsic, "-");

gcc/ada/sem.adb

@@ -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;

gcc/ada/sem_ch4.adb

@@ -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);
 

gcc/ada/sem_ch4.ads

@@ -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);

gcc/ada/sem_intr.adb

@@ -54,7 +54,7 @@ package body Sem_Intr is
 
    procedure Check_Intrinsic_Operator (E : Entity_Id; N : Node_Id);
    --  Check that operator is one of the binary arithmetic operators, and
-   --  that the types involved have the same size.
+   --  that the types involved both have underlying integer types..
 
    procedure Check_Shift (E : Entity_Id; N : Node_Id);
    --  Check intrinsic shift subprogram, the two arguments are the same
@@ -198,11 +198,24 @@ package body Sem_Intr is
             T2 := Etype (Next_Formal (First_Formal (E)));
          end if;
 
-         if Root_Type (T1) /= Root_Type (T2)
-           or else Root_Type (T1) /= Root_Type (Ret)
+         if Root_Type (T1) = Root_Type (T2)
+           or else Root_Type (T1) = Root_Type (Ret)
+         then
+            --  Same types, predefined operator will apply
+
+            null;
+
+         elsif Is_Integer_Type (Underlying_Type (T1))
+           and then Is_Integer_Type (Underlying_Type (T2))
+           and then Is_Integer_Type (Underlying_Type (Ret))
          then
+            --  Expansion will introduce conversions if sizes are not equal
+
+            null;
+
+         else
             Errint
-              ("types of intrinsic operator must have the same size", E, N);
+              ("types of intrinsic operator operands do not match", E, N);
          end if;
 
       --  Comparison operators

gcc/ada/sem_res.adb

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

gcc/ada/sem_scil.adb

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

gcc/ada/sinfo.adb

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

gcc/ada/sinfo.ads

@@ -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)

gcc/ada/sprint.adb

@@ -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));

gcc/ada/sprint.ads

@@ -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)