diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 36 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 147 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/nlists.adb | 71 | ||||
| -rw-r--r-- | gcc/ada/nlists.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/s-auxdec-vms_64.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_intr.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_scil.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 40 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/sprint.ads | 3 |
19 files changed, 387 insertions, 82 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d472b28..70105c9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +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 diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 8f08dcc..529fb33 100644 --- a/gcc/ada/debug.adb +++ b/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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ddc4fc2..cb5c4c0 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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; diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index fad8c15..a91daf1 100644 --- a/gcc/ada/exp_ch4.ads +++ b/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); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 461539d..95a063c 100644 --- a/gcc/ada/exp_intr.adb +++ b/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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 07771c8..634a03f 100644 --- a/gcc/ada/exp_util.adb +++ b/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 diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 09bd85a..fe4d27c 100644 --- a/gcc/ada/nlists.adb +++ b/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 -- ---------------- diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 3753936..cecf3a2 100644 --- a/gcc/ada/nlists.ads +++ b/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. diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index be90c03..1480a44 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/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, "-"); diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 1eeffcc..30ed723 100644 --- a/gcc/ada/sem.adb +++ b/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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 80fad0b..946f7b8 100644 --- a/gcc/ada/sem_ch4.adb +++ b/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); diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index 6c8d1a3..a6db3aa 100644 --- a/gcc/ada/sem_ch4.ads +++ b/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); diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 2fb0999..63cecbd 100644 --- a/gcc/ada/sem_intr.adb +++ b/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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 44adf31..eaaa26f 100644 --- a/gcc/ada/sem_res.adb +++ b/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 -- ------------------------------- diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index 1722841..8436cf0 100644 --- a/gcc/ada/sem_scil.adb +++ b/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 | diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 8a5c6bc..8a9d253 100644 --- a/gcc/ada/sinfo.adb +++ b/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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 9a95b13..f6754a8 100644 --- a/gcc/ada/sinfo.ads +++ b/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) diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index b19dc51..aa8e880 100644 --- a/gcc/ada/sprint.adb +++ b/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)); diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 59c371a..7c2b3cb 100644 --- a/gcc/ada/sprint.ads +++ b/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) |