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