Skip to content

R
riscv-gcc-1
Commit 29077c18 by Arnaud Charlet
Options

[multiple changes] 

2014-01-27  Robert Dewar  <dewar@adacore.com>

	* 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  <gingold@adacore.com>

	* 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
parent 2757c5bf
Showing with 207 additions and 219 deletions
gcc/ada/ChangeLog
2014-01-27 Robert Dewar <dewar@adacore.com>
* 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 <gingold@adacore.com>
* 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 <kirtchev@adacore.com>
* einfo.adb (Has_Option): Reimplemented.
......
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
......
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 --
-------------------------
......
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
......
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 --
------------------------
......
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.
......@@ -389,78 +458,6 @@ package body Scng is
-- 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 --
-------------------------------
......
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.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment