From ae33543ca51ec15393064ab2075fed28c33ce2d0 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 23 Jan 2017 11:29:17 +0000 Subject: [PATCH] scans.ads: New token At_Sign. 2017-01-23 Ed Schonberg * scans.ads: New token At_Sign. Remove '@' from list of illegal characters for future version of the language. '@' is legal name. * scng.ads, scng.adb (Scan): Handle '@' appropriately. * scn.adb (Scan_Reserved_Identifier): An occurrence of '@' denotes a Target_Name. * par-ch4.adb (P_Name, P_Primary): Handle Target_Name. * sinfo.ads, sinfo.adb (N_Target_Name): New non-terminal node. (Has_Target_Names): New flag on N_Assignment_Statement, to indicate that RHS has occurrences of N_Target_Name. * sem.adb: Call Analyze_Target_Name. * sem_ch5.ads, sem_ch5.adb (Analyze_Target_Name): New subpogram. (urrent_LHS): Global variable that denotes LHS of assignment, used in the analysis of Target_Name nodes. * sem_res.adb (Resolve_Target_Name): New procedure. * exp_ch5.adb (Expand_Assign_With_Target_Names): (AI12-0125): N is an assignment statement whose RHS contains occurences of @ that designate the value of the LHS of the assignment. If the LHS is side-effect free the target names can be replaced with a copy of the LHS; otherwise the semantics of the assignment is described in terms of a procedure with an in-out parameter, and expanded as such. (Expand_N_Assignment_Statement): Call Expand_Assign_With_Target_Names when needed. * exp_util.adb (Insert_Actions): Take into account N_Target_Name. * sprint.adb: Handle N_Target_Name. From-SVN: r244783 --- gcc/ada/ChangeLog | 28 ++++++++++ gcc/ada/exp_ch5.adb | 122 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/exp_util.adb | 1 + gcc/ada/par-ch4.adb | 23 ++++++-- gcc/ada/scans.ads | 21 ++++++-- gcc/ada/scn.adb | 10 +++- gcc/ada/scng.adb | 20 ++++++- gcc/ada/scng.ads | 6 ++- gcc/ada/sem.adb | 3 ++ gcc/ada/sem_ch5.adb | 45 ++++++++++++++++ gcc/ada/sem_ch5.ads | 3 +- gcc/ada/sem_res.adb | 13 +++++ gcc/ada/sinfo.adb | 16 ++++++ gcc/ada/sinfo.ads | 34 ++++++++++++ gcc/ada/sprint.adb | 3 ++ 15 files changed, 333 insertions(+), 15 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 72ba34ba215..8a676d89a61 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2017-01-23 Ed Schonberg + + * scans.ads: New token At_Sign. Remove '@' from list of illegal + characters for future version of the language. '@' is legal name. + * scng.ads, scng.adb (Scan): Handle '@' appropriately. + * scn.adb (Scan_Reserved_Identifier): An occurrence of '@' + denotes a Target_Name. + * par-ch4.adb (P_Name, P_Primary): Handle Target_Name. + * sinfo.ads, sinfo.adb (N_Target_Name): New non-terminal node. + (Has_Target_Names): New flag on N_Assignment_Statement, to + indicate that RHS has occurrences of N_Target_Name. + * sem.adb: Call Analyze_Target_Name. + * sem_ch5.ads, sem_ch5.adb (Analyze_Target_Name): New subpogram. + (urrent_LHS): Global variable that denotes LHS of assignment, + used in the analysis of Target_Name nodes. + * sem_res.adb (Resolve_Target_Name): New procedure. + * exp_ch5.adb (Expand_Assign_With_Target_Names): (AI12-0125): + N is an assignment statement whose RHS contains occurences of @ + that designate the value of the LHS of the assignment. If the + LHS is side-effect free the target names can be replaced with + a copy of the LHS; otherwise the semantics of the assignment + is described in terms of a procedure with an in-out parameter, + and expanded as such. + (Expand_N_Assignment_Statement): Call + Expand_Assign_With_Target_Names when needed. + * exp_util.adb (Insert_Actions): Take into account N_Target_Name. + * sprint.adb: Handle N_Target_Name. + 2017-01-23 Eric Botcazou * checks.adb: Minor fix in comment. diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index c372a726cf0..17233c2554a 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -115,6 +115,13 @@ package body Exp_Ch5 is -- clause (this last case is required because holes in the tagged type -- might be filled with components from child types). + procedure Expand_Assign_With_Target_Names (N : Node_Id); + -- (AI12-0125): N is an assignment statement whose RHS contains occurrences + -- of @ that designate the value of the LHS of the assignment. If the LHS + -- is side-effect free the target names can be replaced with a copy of the + -- LHS; otherwise the semantics of the assignment is described in terms of + -- a procedure with an in-out parameter, and expanded as such. + procedure Expand_Formal_Container_Loop (N : Node_Id); -- Use the primitives specified in an Iterable aspect to expand a loop -- over a so-called formal container, primarily for SPARK usage. @@ -1605,6 +1612,111 @@ package body Exp_Ch5 is end; end Expand_Assign_Record; + ------------------------------------- + -- Expand_Assign_With_Target_Names -- + ------------------------------------- + + procedure Expand_Assign_With_Target_Names (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + LHS : constant Node_Id := Name (N); + RHS : constant Node_Id := Expression (N); + Ent : Entity_Id; + + New_RHS : Node_Id; + + function Replace_Target (N : Node_Id) return Traverse_Result; + -- Replace occurrences of the target name by the proper entity: either + -- the entity of the LHS in simple cases, or the formal of the + -- constructed procedure otherwise. + + -------------------- + -- Replace_Target -- + -------------------- + + function Replace_Target (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Target_Name then + Rewrite (N, New_Occurrence_Of (Ent, Sloc (N))); + end if; + + Set_Analyzed (N, False); + return OK; + end Replace_Target; + + procedure Replace_Target_Name is new Traverse_Proc (Replace_Target); + + begin + + New_RHS := New_Copy_Tree (RHS); + + if Is_Entity_Name (LHS) + and then not Is_Renaming_Of_Object (Entity (LHS)) + then + Ent := Entity (LHS); + Replace_Target_Name (New_RHS); + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => Relocate_Node (LHS), + Expression => New_RHS)); + + elsif Side_Effect_Free (LHS) then + Ent := Make_Temporary (Loc, 'T'); + Insert_Before_And_Analyze (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Object_Definition => New_Occurrence_Of (Etype (LHS), Loc), + Expression => New_Copy_Tree (LHS))); + Replace_Target_Name (New_RHS); + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => Relocate_Node (LHS), + Expression => New_RHS)); + + else + Ent := Make_Temporary (Loc, 'T'); + + declare + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('P')); + Formals : constant List_Id := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Ent, + In_Present => True, + Out_Present => True, + Parameter_Type => New_Occurrence_Of (Etype (LHS), Loc))); + Spec : constant Node_Id := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Formals); + Subp_Body : Node_Id; + Call : Node_Id; + begin + Replace_Target_Name (New_RHS); + + Subp_Body := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Ent, Loc), + Expression => New_RHS)))); + + Insert_Before_And_Analyze (N, Subp_Body); + Call := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc, Loc), + Parameter_Associations => New_List (Relocate_Node (LHS))); + Rewrite (N, Call); + end; + end if; + + -- Analyze rewritten node, either as assignment or procedure call. + + Analyze (N); + end Expand_Assign_With_Target_Names; + ----------------------------------- -- Expand_N_Assignment_Statement -- ----------------------------------- @@ -1647,6 +1759,16 @@ package body Exp_Ch5 is Check_Valid_Lvalue_Subscripts (Lhs); end if; + -- Separate expansion if RHS contain target names. Note that assignment + -- may already have been expanded if RHS is aggregate. + + if Nkind (N) = N_Assignment_Statement + and then Has_Target_Names (N) + then + Expand_Assign_With_Target_Names (N); + return; + end if; + -- Ada 2005 (AI-327): Handle assignment to priority of protected object -- Rewrite an assignment to X'Priority into a run-time call diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1cbffd1a96c..f181bede2f9 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5930,6 +5930,7 @@ package body Exp_Util is | N_String_Literal | N_Subtype_Indication | N_Subunit + | N_Target_Name | N_Task_Definition | N_Terminate_Alternative | N_Triggering_Alternative diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index f52b6ad5ca4..af2ed879ca5 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -1,4 +1,4 @@ ------------------------------------------------------------------------------- +----------------------------------------------------------------------------- -- -- -- GNAT COMPILER COMPONENTS -- -- -- @@ -145,7 +145,7 @@ package body Ch4 is -- | INDEXED_COMPONENT | SLICE -- | SELECTED_COMPONENT | ATTRIBUTE -- | TYPE_CONVERSION | FUNCTION_CALL - -- | CHARACTER_LITERAL + -- | CHARACTER_LITERAL | TARGET_NAME -- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL @@ -181,6 +181,8 @@ package body Ch4 is -- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME + -- TARGET_NAME ::= @ (AI12-0125-3: abbreviation for LHS) + -- Note: syntactically a procedure call looks just like a function call, -- so this routine is in practice used to scan out procedure calls as well. @@ -229,6 +231,10 @@ package body Ch4 is end if; -- Loop through designators in qualified name + -- AI12-0125 : target_name + if Token = Tok_At_Sign then + Scan_Reserved_Identifier (Force_Msg => False); + end if; Name_Node := Token_Node; @@ -2332,8 +2338,8 @@ package body Ch4 is if Token = Tok_Dot then Error_Msg_SC ("prefix for selection is not a name"); - -- If qualified expression, comment and continue, otherwise something - -- is pretty nasty so do an Error_Resync call. + -- If qualified expression, comment and continue, otherwise + -- something is pretty nasty so do an Error_Resync call. if Ada_Version < Ada_2012 and then Nkind (Node1) = N_Qualified_Expression @@ -2791,6 +2797,15 @@ package body Ch4 is Error_Msg_SC ("parentheses required for unary minus"); Scan; -- past minus + when Tok_At_Sign => -- AI12-0125 : target_name + if not Extensions_Allowed then + Error_Msg_SC ("target name is an Ada 2020 extension"); + Error_Msg_SC ("\compile with -gnatX"); + end if; + + Node1 := P_Name; + return Node1; + -- Anything else is illegal as the first token of a primary, but -- we test for some common errors, to improve error messages. diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index afbdf96aab2..8ff3f9d0e29 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -61,6 +61,8 @@ package Scans is Tok_Identifier, -- identifier Name, Lit_Or_Name, Desig + Tok_At_Sign, -- @ AI12-0125-3 : target name + Tok_Double_Asterisk, -- ** Tok_Ampersand, -- & Binary_Addop @@ -213,8 +215,10 @@ package Scans is -- also when scanning project files (where it is needed because of ???) Tok_Special, - -- Used only in preprocessor scanning (to represent one of the - -- characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The + -- AI12-0125-03 : target name as abbreviation for LHS + + -- Otherwise used only in preprocessor scanning (to represent one of + -- the characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The -- character value itself is stored in Scans.Special_Character. Tok_SPARK_Hide, @@ -269,12 +273,13 @@ package Scans is -- of Pascal style not equal operator). subtype Token_Class_Name is - Token_Type range Tok_Char_Literal .. Tok_Identifier; + Token_Type range Tok_Char_Literal .. Tok_At_Sign; -- First token of name (4.1), -- (identifier, char literal, operator symbol) + -- Includes '@' after Ada2012 corrigendum. subtype Token_Class_Desig is - Token_Type range Tok_Operator_Symbol .. Tok_Identifier; + Token_Type range Tok_Operator_Symbol .. Tok_At_Sign; -- Token which can be a Designator (identifier, operator symbol) subtype Token_Class_Namext is @@ -397,6 +402,11 @@ package Scans is -- file being compiled. This CRC includes only program tokens, and -- excludes comments. + Limited_Checksum : Word := 0; + -- Used to accumulate a CRC representing significant tokens in the + -- limited view of a package, i.e. visible type names and related + -- tagged indicators. + First_Non_Blank_Location : Source_Ptr := No_Location; -- init for -gnatVa -- Location of first non-blank character on the line containing the -- current token (i.e. the location of the character whose column number @@ -461,8 +471,9 @@ package Scans is -- Wide_Character). Special_Character : Character; + -- AI12-0125-03 : '@' as target name is handled elsewhere. -- Valid only when Token = Tok_Special. Returns one of the characters - -- '#', '$', '?', '@', '`', '\', '^', '~', or '_'. + -- '#', '$', '?', '`', '\', '^', '~', or '_'. -- -- Why only this set? What about wide characters??? diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index cc88ab9c125..ef0311619d5 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -383,6 +383,14 @@ package body Scn is Token_Chars : constant String := Token_Type'Image (Token); begin + -- AI12-0125 : '@' denotes the target_name, i.e. serves as an + -- abbreviation for the LHS of an assignment. + + if Token = Tok_At_Sign then + Token_Node := New_Node (N_Target_Name, Token_Ptr); + return; + end if; + -- We have in Token_Chars the image of the Token name, i.e. Tok_xxx. -- This code extracts the xxx and makes an identifier out of it. diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index 3e2d7fa03fa..6c9cab7fbd9 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -158,6 +158,7 @@ package body Scng is | Tok_And | Tok_Apostrophe | Tok_Array + | Tok_At_Sign | Tok_Asterisk | Tok_At | Tok_Body @@ -302,6 +303,7 @@ package body Scng is | Tok_Array | Tok_Asterisk | Tok_At + | Tok_At_Sign | Tok_Body | Tok_Box | Tok_Char_Literal @@ -1609,6 +1611,19 @@ package body Scng is return; end if; + when '@' => + if not Extensions_Allowed then + Error_Illegal_Character; + Scan_Ptr := Scan_Ptr + 1; + + else + -- AI12-0125-03 : @ is target_name + Accumulate_Checksum ('@'); + Scan_Ptr := Scan_Ptr + 1; + Token := Tok_At_Sign; + return; + end if; + -- Asterisk (can be multiplication operator or double asterisk which -- is the exponentiation compound delimiter). @@ -2421,8 +2436,9 @@ package body Scng is Error_Illegal_Character; -- Invalid graphic characters - - when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' => + -- Note that '@' is handled elsewhere, because following AI12-125 + -- it denotes the target_name of an assignment. + when '#' | '$' | '?' | '`' | '\' | '^' | '~' => -- If Set_Special_Character has been called for this character, -- set Scans.Special_Character and return a Special token. diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads index 32ecc67d0ad..d25ed54e51c 100644 --- a/gcc/ada/scng.ads +++ b/gcc/ada/scng.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -78,8 +78,10 @@ package Scng is -- either a keyword or an identifier. See also package Casing. procedure Set_Special_Character (C : Character); - -- Indicate that one of the following character '#', '$', '?', '@', '`', + -- Indicate that one of the following character '#', '$', '?', '`', -- '\', '^', '_' or '~', when found is a Special token. + -- AI12-0125-03 : target name (ES) is not in this list because '@' is + -- handled as a special token as abbreviation of LHS of assignment. procedure Reset_Special_Characters; -- Indicate that there is no characters that are Special tokens., which diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 18a0af75348..36b561e79c9 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -563,6 +563,9 @@ package body Sem is when N_Subunit => Analyze_Subunit (N); + when N_Target_Name => + Analyze_Target_Name (N); + when N_Task_Body => Analyze_Task_Body (N); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 6962262df18..6abcdb26d8d 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -64,6 +64,11 @@ with Uintp; use Uintp; package body Sem_Ch5 is + Current_LHS : Node_Id := Empty; + -- Holds the left-hand side of the assignment statement being analyzed. + -- Used to determine the type of a target_name appearing on the RHS, for + -- AI12-0125 and the use of '@' as an abbreviation for the LHS. + Unblocked_Exit_Count : Nat := 0; -- This variable is used when processing if statements, case statements, -- and block statements. It counts the number of exit points that are not @@ -279,6 +284,9 @@ package body Sem_Ch5 is -- Start of processing for Analyze_Assignment begin + -- Save LHS for use in target names (AI12-125). + Current_LHS := Lhs; + Mark_Coextensions (N, Rhs); -- Analyze the target of the assignment first in case the expression @@ -558,8 +566,20 @@ package body Sem_Ch5 is -- Now we can complete the resolution of the right hand side Set_Assignment_Type (Lhs, T1); + Resolve (Rhs, T1); + -- If the right-hand side contains target names, expansion has been + -- disabled to prevent expansion that might move target names out of + -- the context of the assignment statement. Restore the expander mode + -- now so that assignment statement can be properly expanded. + + if Nkind (N) = N_Assignment_Statement + and then Has_Target_Names (N) + then + Expander_Mode_Restore; + end if; + -- This is the point at which we check for an unset reference Check_Unset_Reference (Rhs); @@ -918,6 +938,7 @@ package body Sem_Ch5 is Analyze_Dimension (N); <> + Current_LHS := Empty; Restore_Ghost_Mode (Mode); end Analyze_Assignment; @@ -3513,6 +3534,30 @@ package body Sem_Ch5 is null; end Analyze_Null_Statement; + ------------------------- + -- Analyze_Target_Name -- + ------------------------- + + procedure Analyze_Target_Name (N : Node_Id) is + begin + if No (Current_LHS) then + Error_Msg_N ("target name can only appear within an assignment", N); + Set_Etype (N, Any_Type); + else + Set_Has_Target_Names (Parent (Current_LHS)); + Set_Etype (N, Etype (Current_LHS)); + + -- Disable expansion for the rest of the analysis of the current + -- right-hand side. The enclosing assignment statement will be + -- rewritten during expansion, together with occurrences of the + -- target name. + + if Expander_Active then + Expander_Mode_Save_And_Set (False); + end if; + end if; + end Analyze_Target_Name; + ------------------------ -- Analyze_Statements -- ------------------------ diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index 9c2908384e6..0f4ac500ca0 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -41,6 +41,7 @@ package Sem_Ch5 is procedure Analyze_Loop_Parameter_Specification (N : Node_Id); procedure Analyze_Loop_Statement (N : Node_Id); procedure Analyze_Null_Statement (N : Node_Id); + procedure Analyze_Target_Name (N : Node_Id); procedure Analyze_Statements (L : List_Id); procedure Analyze_Label_Entity (E : Entity_Id); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e2c65f15e0a..33d3b60c619 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -203,6 +203,7 @@ package body Sem_Res is procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id); procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); @@ -2985,6 +2986,9 @@ package body Sem_Res is when N_String_Literal => Resolve_String_Literal (N, Ctx_Type); + when N_Target_Name => + Resolve_Target_Name (N, Ctx_Type); + when N_Type_Conversion => Resolve_Type_Conversion (N, Ctx_Type); @@ -10638,6 +10642,15 @@ package body Sem_Res is end; end Resolve_String_Literal; + ------------------------- + -- Resolve_Target_Name -- + ------------------------- + + procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id) is + begin + Set_Etype (N, Typ); + end Resolve_Target_Name; + ----------------------------- -- Resolve_Type_Conversion -- ----------------------------- diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index ef521167e37..d52c43c17d8 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1606,6 +1606,14 @@ package body Sinfo is return Flag5 (N); end Has_Storage_Size_Pragma; + function Has_Target_Names + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + return Flag8 (N); + end Has_Target_Names; + function Has_Wide_Character (N : Node_Id) return Boolean is begin @@ -4898,6 +4906,14 @@ package body Sinfo is Set_Flag5 (N, Val); end Set_Has_Storage_Size_Pragma; + procedure Set_Has_Target_Names + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Assignment_Statement); + Set_Flag8 (N, Val); + end Set_Has_Target_Names; + procedure Set_Has_Wide_Character (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index e63229a41f8..56c774500e6 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1543,6 +1543,10 @@ package Sinfo is -- code outside the Character range but within Wide_Character range) -- appears in the string. Used to implement pragma preference rules. + -- Has_Target_Names (Flag8-Sem) + -- Present in assignment statements. Indicates that the RHS contains + -- target names (see AI12-0125-3) and must be expanded accordingly. + -- Has_Wide_Wide_Character (Flag13-Sem) -- Present in string literals, set if any wide character (i.e. character -- code outside the Wide_Character range) appears in the string. Used to @@ -4794,6 +4798,7 @@ package Sinfo is -- Forwards_OK (Flag5-Sem) -- Backwards_OK (Flag6-Sem) -- No_Ctrl_Actions (Flag7-Sem) + -- Has_Target_Names (Flag8-Sem) -- Componentwise_Assignment (Flag14-Sem) -- Suppress_Assignment_Checks (Flag18-Sem) @@ -4808,6 +4813,19 @@ package Sinfo is -- case the front end must generate an extra temporary and initialize -- this temporary as required (the temporary itself is not atomic). + ------------------ + -- Target_Name -- + ------------------ + + -- N_Target_Name + -- Sloc points to @ + -- Etype (Node5-Sem) + + -- Note (Ada 2020): node is used during analysis as a placeholder for + -- the value of the LHS of the enclosing assignment statement. Node is + -- eventually rewritten together with enclosing assignment, and backends + -- are not aware of it. + ----------------------- -- 5.3 If Statement -- ----------------------- @@ -8463,6 +8481,7 @@ package Sinfo is N_Reference, N_Selected_Component, N_Slice, + N_Target_Name, N_Type_Conversion, N_Unchecked_Expression, N_Unchecked_Type_Conversion, @@ -9385,6 +9404,9 @@ package Sinfo is function Has_Storage_Size_Pragma (N : Node_Id) return Boolean; -- Flag5 + function Has_Target_Names + (N : Node_Id) return Boolean; -- Flag8 + function Has_Wide_Character (N : Node_Id) return Boolean; -- Flag11 @@ -10438,6 +10460,9 @@ package Sinfo is procedure Set_Has_Storage_Size_Pragma (N : Node_Id; Val : Boolean := True); -- Flag5 + procedure Set_Has_Target_Names + (N : Node_Id; Val : Boolean := True); -- Flag8 + procedure Set_Has_Wide_Character (N : Node_Id; Val : Boolean := True); -- Flag11 @@ -11737,6 +11762,13 @@ package Sinfo is 4 => False, -- unused 5 => False), -- unused + N_Target_Name => + (1 => False, -- unused + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- unused + 5 => False), -- Etype (Node5-Sem) + N_If_Statement => (1 => True, -- Condition (Node1) 2 => True, -- Then_Statements (List2) @@ -12944,6 +12976,7 @@ package Sinfo is pragma Inline (Has_Private_View); pragma Inline (Has_Relative_Deadline_Pragma); pragma Inline (Has_Storage_Size_Pragma); + pragma Inline (Has_Target_Names); pragma Inline (Has_Wide_Character); pragma Inline (Has_Wide_Wide_Character); pragma Inline (Header_Size_Added); @@ -13292,6 +13325,7 @@ package Sinfo is pragma Inline (Set_Has_Self_Reference); pragma Inline (Set_Has_SP_Choice); pragma Inline (Set_Has_Storage_Size_Pragma); + pragma Inline (Set_Has_Target_Names); pragma Inline (Set_Has_Wide_Character); pragma Inline (Set_Has_Wide_Wide_Character); pragma Inline (Set_Header_Size_Added); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index a357fb2da84..bed39b52df4 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3287,6 +3287,9 @@ package body Sprint is Extra_Blank_Line; Sprint_Node (Proper_Body (Node)); + when N_Target_Name => + Write_Char ('@'); + when N_Task_Body => Write_Indent_Str_Sloc ("task body "); Write_Id (Defining_Identifier (Node)); -- 2.30.2