From 29077c18417c523c5fd2790613ba4ea2988660c4 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 27 Jan 2014 17:52:29 +0100 Subject: [PATCH] [multiple changes] 2014-01-27 Robert Dewar * scn.adb (Check_End_Of_Line): Removed. (Error_Long_Line): Removed. (Determine_License): Use versions of above routines from Scanner. * scng.adb (Check_End_Of_Line): Moved to spec. (Error_Long_Line): Removed, no longer used. * scng.ads (Check_End_Of_Line): Moved here from body. 2014-01-27 Tristan Gingold * exp_ch7.adb (Build_Cleanup_Statements): Call Build_Protected_Subprogram_Call_Cleanup to insert the cleanup for protected body. * exp_ch9.adb (Build_Protected_Subprogram_Body): Likewise. Remove Service_Name variable. (Build_Protected_SUbprogam_Call_Cleanup): New procedure that factorize code from the above subprograms. * exp_ch9.ads (Build_Protected_Subprogram_Call_Cleanup): New procedure. From-SVN: r207143 --- gcc/ada/ChangeLog | 20 ++++++ gcc/ada/exp_ch7.adb | 81 ++------------------- gcc/ada/exp_ch9.adb | 104 ++++++++++++++++++++++----- gcc/ada/exp_ch9.ads | 12 +++- gcc/ada/scn.adb | 37 +--------- gcc/ada/scng.adb | 166 ++++++++++++++++++++------------------------ gcc/ada/scng.ads | 6 +- 7 files changed, 207 insertions(+), 219 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ef6ddae443..048cf2ae9f2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2014-01-27 Robert Dewar + + * scn.adb (Check_End_Of_Line): Removed. + (Error_Long_Line): Removed. + (Determine_License): Use versions of above routines from Scanner. + * scng.adb (Check_End_Of_Line): Moved to spec. + (Error_Long_Line): Removed, no longer used. + * scng.ads (Check_End_Of_Line): Moved here from body. + +2014-01-27 Tristan Gingold + + * exp_ch7.adb (Build_Cleanup_Statements): Call + Build_Protected_Subprogram_Call_Cleanup to insert the cleanup + for protected body. + * exp_ch9.adb (Build_Protected_Subprogram_Body): Likewise. + Remove Service_Name variable. + (Build_Protected_SUbprogam_Call_Cleanup): New procedure that + factorize code from the above subprograms. + * exp_ch9.ads (Build_Protected_Subprogram_Call_Cleanup): New procedure. + 2014-01-27 Hristian Kirtchev * einfo.adb (Has_Option): Reimplemented. diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index ed3dc4c93fd..1e0c9bbd3fe 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -511,7 +511,6 @@ package body Exp_Ch7 is declare Spec : constant Node_Id := Parent (Corresponding_Spec (N)); Conc_Typ : Entity_Id; - Nam : Node_Id; Param : Node_Id; Param_Typ : Entity_Id; @@ -532,81 +531,15 @@ package body Exp_Ch7 is pragma Assert (Present (Param)); - -- If the associated protected object has entries, a protected - -- procedure has to service entry queues. In this case generate: + -- Historical note: In earlier versions of GNAT, there was code + -- at this point to generate stuff to service entry queues. But + -- that was wrong thinking. This was useless and resulted in + -- incoherencies between code generated with and without -gnatp. - -- Service_Entries (_object._object'Access); + -- All that is needed at this stage is a normal cleanup call - if Nkind (Specification (N)) = N_Procedure_Specification - and then Has_Entries (Conc_Typ) - then - case Corresponding_Runtime_Package (Conc_Typ) is - when System_Tasking_Protected_Objects_Entries => - Nam := New_Reference_To (RTE (RE_Service_Entries), Loc); - - when System_Tasking_Protected_Objects_Single_Entry => - Nam := New_Reference_To (RTE (RE_Service_Entry), Loc); - - when others => - raise Program_Error; - end case; - - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => Nam, - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Reference_To ( - Defining_Identifier (Param), Loc), - Selector_Name => - Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)))); - - else - -- Generate: - -- Unlock (_object._object'Access); - - case Corresponding_Runtime_Package (Conc_Typ) is - when System_Tasking_Protected_Objects_Entries => - Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc); - - when System_Tasking_Protected_Objects_Single_Entry => - Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc); - - when System_Tasking_Protected_Objects => - Nam := New_Reference_To (RTE (RE_Unlock), Loc); - - when others => - raise Program_Error; - end case; - - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => Nam, - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => - New_Reference_To - (Defining_Identifier (Param), Loc), - Selector_Name => - Make_Identifier (Loc, Name_uObject)), - Attribute_Name => Name_Unchecked_Access)))); - end if; - - -- Generate: - -- Abort_Undefer; - - if Abort_Allowed then - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => Empty_List)); - end if; + Build_Protected_Subprogram_Call_Cleanup + (Specification (N), Conc_Typ, Loc, Stmts); end; -- Add a call to Expunge_Unactivated_Tasks for dynamically allocated diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6adf7b384f4..96a09279ce4 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -4150,7 +4150,6 @@ package body Exp_Ch9 is Sub_Body : Node_Id; Lock_Name : Node_Id; Lock_Stmt : Node_Id; - Service_Name : Node_Id; R : Node_Id; Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning @@ -4235,15 +4234,12 @@ package body Exp_Ch9 is case Corresponding_Runtime_Package (Pid) is when System_Tasking_Protected_Objects_Entries => Lock_Name := New_Reference_To (RTE (RE_Lock_Entries), Loc); - Service_Name := New_Reference_To (RTE (RE_Service_Entries), Loc); when System_Tasking_Protected_Objects_Single_Entry => Lock_Name := New_Reference_To (RTE (RE_Lock_Entry), Loc); - Service_Name := New_Reference_To (RTE (RE_Service_Entry), Loc); when System_Tasking_Protected_Objects => Lock_Name := New_Reference_To (RTE (Lock_Kind), Loc); - Service_Name := New_Reference_To (RTE (RE_Unlock), Loc); when others => raise Program_Error; @@ -4282,20 +4278,7 @@ package body Exp_Ch9 is Append (Unprot_Call, Stmts); end if; - Append ( - Make_Procedure_Call_Statement (Loc, - Name => Service_Name, - Parameter_Associations => - New_List (New_Copy_Tree (Object_Parm))), - Stmts); - - if Abort_Allowed then - Append ( - Make_Procedure_Call_Statement (Loc, - Name => New_Reference_To (RTE (RE_Abort_Undefer), Loc), - Parameter_Associations => Empty_List), - Stmts); - end if; + Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); if Nkind (Op_Spec) = N_Function_Specification then Append (Return_Stmt, Stmts); @@ -4388,6 +4371,91 @@ package body Exp_Ch9 is end if; end Build_Protected_Subprogram_Call; + --------------------------------------------- + -- Build_Protected_Subprogram_Call_Cleanup -- + --------------------------------------------- + + procedure Build_Protected_Subprogram_Call_Cleanup + (Op_Spec : Node_Id; + Conc_Typ : Node_Id; + Loc : Source_Ptr; + Stmts : List_Id) + is + Nam : Node_Id; + + begin + -- If the associated protected object has entries, a protected + -- procedure has to service entry queues. In this case generate: + + -- Service_Entries (_object._object'Access); + + if Nkind (Op_Spec) = N_Procedure_Specification + and then Has_Entries (Conc_Typ) + then + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Nam := New_Reference_To (RTE (RE_Service_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Nam := New_Reference_To (RTE (RE_Service_Entry), Loc); + + when others => + raise Program_Error; + end case; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uObject), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + + else + -- Generate: + -- Unlock (_object._object'Access); + + case Corresponding_Runtime_Package (Conc_Typ) is + when System_Tasking_Protected_Objects_Entries => + Nam := New_Reference_To (RTE (RE_Unlock_Entries), Loc); + + when System_Tasking_Protected_Objects_Single_Entry => + Nam := New_Reference_To (RTE (RE_Unlock_Entry), Loc); + + when System_Tasking_Protected_Objects => + Nam := New_Reference_To (RTE (RE_Unlock), Loc); + + when others => + raise Program_Error; + end case; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => Nam, + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uObject), + Selector_Name => Make_Identifier (Loc, Name_uObject)), + Attribute_Name => Name_Unchecked_Access)))); + end if; + + -- Generate: + -- Abort_Undefer; + + if Abort_Allowed then + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (RTE (RE_Abort_Undefer), Loc), + Parameter_Associations => Empty_List)); + end if; + end Build_Protected_Subprogram_Call_Cleanup; + ------------------------- -- Build_Selected_Name -- ------------------------- diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads index 65b0c195302..db1e6904c72 100644 --- a/gcc/ada/exp_ch9.ads +++ b/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -112,6 +112,16 @@ package Exp_Ch9 is -- External is False if the call is to another protected subprogram within -- the same object. + procedure Build_Protected_Subprogram_Call_Cleanup + (Op_Spec : Node_Id; + Conc_Typ : Node_Id; + Loc : Source_Ptr; + Stmts : List_Id); + -- Append to Stmts the cleanups after a call to a protected subprogram + -- whose specification is Op_Spec. Conc_Typ is the concurrent type and Loc + -- the sloc for appended statements. The cleanup will either unlock the + -- protected object or serve pending entries. + procedure Build_Task_Activation_Call (N : Node_Id); -- This procedure is called for constructs that can be task activators, -- i.e. task bodies, subprogram bodies, package bodies and blocks. If the diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index 9f8ce2078d4..cc88ab9c125 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -25,7 +25,6 @@ with Atree; use Atree; with Csets; use Csets; -with Hostparm; use Hostparm; with Namet; use Namet; with Opt; use Opt; with Restrict; use Restrict; @@ -44,32 +43,11 @@ package body Scn is -- make sure that we only post an error message for incorrect use of a -- keyword as an identifier once for a given keyword). - procedure Check_End_Of_Line; - -- Called when end of line encountered. Checks that line is not too long, - -- and that other style checks for the end of line are met. - function Determine_License return License_Type; -- Scan header of file and check that it has an appropriate GNAT-style -- header with a proper license statement. Returns GPL, Unrestricted, -- or Modified_GPL depending on header. If none of these, returns Unknown. - procedure Error_Long_Line; - -- Signal error of excessively long line - - ----------------------- - -- Check_End_Of_Line -- - ----------------------- - - procedure Check_End_Of_Line is - Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start); - begin - if Style_Check then - Style.Check_Line_Terminator (Len); - elsif Len > Max_Line_Length then - Error_Long_Line; - end if; - end Check_End_Of_Line; - ----------------------- -- Determine_License -- ----------------------- @@ -182,7 +160,7 @@ package body Scn is Skip_EOL; - Check_End_Of_Line; + Scanner.Check_End_Of_Line; if Source (Scan_Ptr) /= EOF then @@ -219,17 +197,6 @@ package body Scn is return Scanner.Determine_Token_Casing; end Determine_Token_Casing; - --------------------- - -- Error_Long_Line -- - --------------------- - - procedure Error_Long_Line is - begin - Error_Msg - ("this line is too long", - Current_Line_Start + Source_Ptr (Max_Line_Length)); - end Error_Long_Line; - ------------------------ -- Initialize_Scanner -- ------------------------ diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb index ef3d665554a..8b08949601a 100644 --- a/gcc/ada/scng.adb +++ b/gcc/ada/scng.adb @@ -259,6 +259,82 @@ package body Scng is end case; end Accumulate_Token_Checksum_GNAT_5_03; + ----------------------- + -- Check_End_Of_Line -- + ----------------------- + + procedure Check_End_Of_Line is + Len : constant Int := + Int (Scan_Ptr) - + Int (Current_Line_Start) - + Wide_Char_Byte_Count; + + -- Start of processing for Check_End_Of_Line + + begin + if Style_Check then + Style.Check_Line_Terminator (Len); + end if; + + -- Deal with checking maximum line length + + if Style_Check and Style_Check_Max_Line_Length then + Style.Check_Line_Max_Length (Len); + + -- If style checking is inactive, check maximum line length against + -- standard value. + + elsif Len > Max_Line_Length then + Error_Msg + ("this line is too long", + Current_Line_Start + Source_Ptr (Max_Line_Length)); + end if; + + -- Now one more checking circuit. Normally we are only enforcing a limit + -- of physical characters, with tabs counting as one character. But if + -- after tab expansion we would have a total line length that exceeded + -- 32766, that would really cause trouble, because column positions + -- would exceed the maximum we allow for a column count. Note: the limit + -- is 32766 rather than 32767, since we use a value of 32767 for special + -- purposes (see Sinput). Now we really do not want to go messing with + -- tabs in the normal case, so what we do is to check for a line that + -- has more than 4096 physical characters. Any shorter line could not + -- be a problem, even if it was all tabs. + + if Len >= 4096 then + declare + Col : Natural; + Ptr : Source_Ptr; + + begin + Col := 1; + Ptr := Current_Line_Start; + loop + exit when Ptr = Scan_Ptr; + + if Source (Ptr) = ASCII.HT then + Col := (Col - 1 + 8) / 8 * 8 + 1; + else + Col := Col + 1; + end if; + + if Col > 32766 then + Error_Msg + ("this line is longer than 32766 characters", + Current_Line_Start); + raise Unrecoverable_Error; + end if; + + Ptr := Ptr + 1; + end loop; + end; + end if; + + -- Reset wide character byte count for next line + + Wide_Char_Byte_Count := 0; + end Check_End_Of_Line; + ---------------------------- -- Determine_Token_Casing -- ---------------------------- @@ -336,10 +412,6 @@ package body Scng is Wptr : Source_Ptr; -- Used to remember start of last wide character scanned - procedure Check_End_Of_Line; - -- Called when end of line encountered. Checks that line is not too - -- long, and that other style checks for the end of line are met. - function Double_Char_Token (C : Character) return Boolean; -- This function is used for double character tokens like := or <>. It -- checks if the character following Source (Scan_Ptr) is C, and if so @@ -359,9 +431,6 @@ package body Scng is -- past the illegal character, which may still leave us pointing to -- junk, not much we can do if the escape sequence is messed up! - procedure Error_Long_Line; - -- Signal error of excessively long line - procedure Error_No_Double_Underline; -- Signal error of two underline or punctuation characters in a row. -- Called with Scan_Ptr pointing to second underline/punctuation char. @@ -388,78 +457,6 @@ package body Scng is -- Returns True if the scan pointer is pointing to the start of a wide -- character sequence, does not modify the scan pointer in any case. - ----------------------- - -- Check_End_Of_Line -- - ----------------------- - - procedure Check_End_Of_Line is - Len : constant Int := - Int (Scan_Ptr) - - Int (Current_Line_Start) - - Wide_Char_Byte_Count; - - begin - if Style_Check then - Style.Check_Line_Terminator (Len); - end if; - - -- Deal with checking maximum line length - - if Style_Check and Style_Check_Max_Line_Length then - Style.Check_Line_Max_Length (Len); - - -- If style checking is inactive, check maximum line length against - -- standard value. - - elsif Len > Max_Line_Length then - Error_Long_Line; - end if; - - -- Now one more checking circuit. Normally we are only enforcing a - -- limit of physical characters, with tabs counting as one character. - -- But if after tab expansion we would have a total line length that - -- exceeded 32766, that would really cause trouble, because column - -- positions would exceed the maximum we allow for a column count. - -- Note: the limit is 32766 rather than 32767, since we use a value - -- of 32767 for special purposes (see Sinput). Now we really do not - -- want to go messing with tabs in the normal case, so what we do is - -- to check for a line that has more than 4096 physical characters. - -- Any shorter line could not be a problem, even if it was all tabs. - - if Len >= 4096 then - declare - Col : Natural; - Ptr : Source_Ptr; - - begin - Col := 1; - Ptr := Current_Line_Start; - loop - exit when Ptr = Scan_Ptr; - - if Source (Ptr) = ASCII.HT then - Col := (Col - 1 + 8) / 8 * 8 + 1; - else - Col := Col + 1; - end if; - - if Col > 32766 then - Error_Msg - ("this line is longer than 32766 characters", - Current_Line_Start); - raise Unrecoverable_Error; - end if; - - Ptr := Ptr + 1; - end loop; - end; - end if; - - -- Reset wide character byte count for next line - - Wide_Char_Byte_Count := 0; - end Check_End_Of_Line; - ----------------------- -- Double_Char_Token -- ----------------------- @@ -505,17 +502,6 @@ package body Scng is Error_Msg ("illegal wide character", Wptr); end Error_Illegal_Wide_Character; - --------------------- - -- Error_Long_Line -- - --------------------- - - procedure Error_Long_Line is - begin - Error_Msg - ("this line is too long", - Current_Line_Start + Source_Ptr (Max_Line_Length)); - end Error_Long_Line; - ------------------------------- -- Error_No_Double_Underline -- ------------------------------- diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads index d9035119f4b..32ecc67d0ad 100644 --- a/gcc/ada/scng.ads +++ b/gcc/ada/scng.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -56,6 +56,10 @@ generic package Scng is + procedure Check_End_Of_Line; + -- Called when end of line encountered. Checks that line is not too long, + -- and that other style checks for the end of line are met. + procedure Initialize_Scanner (Index : Source_File_Index); -- Initialize lexical scanner for scanning a new file referenced by Index. -- Initialize_Scanner does not call Scan. -- 2.30.2