+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.
declare
Spec : constant Node_Id := Parent (Corresponding_Spec (N));
Conc_Typ : Entity_Id;
- Nam : Node_Id;
Param : Node_Id;
Param_Typ : Entity_Id;
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
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
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;
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);
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 --
-------------------------
-- --
-- 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- --
-- 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
-- --
-- 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- --
with Atree; use Atree;
with Csets; use Csets;
-with Hostparm; use Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Restrict; use Restrict;
-- 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 --
-----------------------
Skip_EOL;
- Check_End_Of_Line;
+ Scanner.Check_End_Of_Line;
if Source (Scan_Ptr) /= EOF then
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 --
------------------------
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 --
----------------------------
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
-- 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.
-- 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 --
-----------------------
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 --
-------------------------------
-- --
-- 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- --
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.
projects / gcc.git / commitdiff