[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

7 files changed, 207 insertions, 219 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4ef6dda..048cf2a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+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.
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index ed3dc4c..1e0c9bb 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 6adf7b3..96a0927 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 65b0c19..db1e690 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 9f8ce207..cc88ab9 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 ef3d665..8b08949 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.
@@ -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 --
       -------------------------------
diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads
index d903511..32ecc67 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.