2009-06-19 Emmanuel Briot <briot@adacore.com>

	* prj-ext.adb, makeutl.adb, makeutl.ads (Executable_Prefix_Path): Now
	make sure we always return a name ending with a path separator.

2009-06-19  Javier Miranda  <miranda@adacore.com>

	* sem_ch12.adb (Instantiate_Package_Body, Instantiate_Subprogram_Body):
	Save and restore the visibility of the parent when installed.

2009-06-19  Jose Ruiz  <ruiz@adacore.com>

	* s-tposen.ads (Protection_Entry): Replace fields L, Ceiling, and Owner
	by Common which contains all these fields.

	* s-tposen.adb (Initialize_Protection_Entry, Lock_Entry,
	Lock_Read_Only_Entry, Timed_Protected_Single_Entry_Call, Unlock_Entry):
	Remove code duplication in this package by means of calling the
	equivalent code in s-taprob.

2009-06-19  Robert Dewar  <dewar@adacore.com>

	* a-einuoc.ads: Minor reformatting



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@148701 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 72 insertions, 151 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 131904c1fc8..194ac3706b4 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,27 @@
+2009-06-19  Emmanuel Briot  <briot@adacore.com>
+
+	* prj-ext.adb, makeutl.adb, makeutl.ads (Executable_Prefix_Path): Now
+	make sure we always return a name ending with a path separator.
+
+2009-06-19  Javier Miranda  <miranda@adacore.com>
+
+	* sem_ch12.adb (Instantiate_Package_Body, Instantiate_Subprogram_Body):
+	Save and restore the visibility of the parent when installed.
+
+2009-06-19  Jose Ruiz  <ruiz@adacore.com>
+
+	* s-tposen.ads (Protection_Entry): Replace fields L, Ceiling, and Owner
+	by Common which contains all these fields.
+
+	* s-tposen.adb (Initialize_Protection_Entry, Lock_Entry,
+	Lock_Read_Only_Entry, Timed_Protected_Single_Entry_Call, Unlock_Entry):
+	Remove code duplication in this package by means of calling the
+	equivalent code in s-taprob.
+
+2009-06-19  Robert Dewar  <dewar@adacore.com>
+
+	* a-einuoc.ads: Minor reformatting
+
 2009-06-19  Ed Falis  <falis@adacore.com>
 
 	* a-einuoc.ads, s-osinte-vxworks.ads, s-vxwext.ads, s-vxwext-kernel.adb,
diff --git a/gcc/ada/a-einuoc.ads b/gcc/ada/a-einuoc.ads
index e075df95122..8d772b01f52 100644
--- a/gcc/ada/a-einuoc.ads
+++ b/gcc/ada/a-einuoc.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---            Copyright (C) 2000-2009, Free Software Foundation, Inc.       --
+--          Copyright (C) 2000-2009, 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- --
@@ -35,7 +35,6 @@
 --  be made in a conforming manner.
 
 function Ada.Exceptions.Is_Null_Occurrence
-  (X    : Exception_Occurrence)
-  return Boolean;
+  (X : Exception_Occurrence) return Boolean;
 pragma Preelaborate (Ada.Exceptions.Is_Null_Occurrence);
 --  This function yields True if X is Null_Occurrence, and False otherwise
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index 17c34ff51f7..46169d5fa62 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -229,7 +229,8 @@ package body Makeutl is
             return "";
          end if;
 
-         return Normalize_Pathname (Exec (Exec'First .. Path_Last - 4));
+         return Normalize_Pathname (Exec (Exec'First .. Path_Last - 4))
+           & Directory_Separator;
       end Get_Install_Dir;
 
    --  Beginning of Executable_Prefix_Path
@@ -248,12 +249,17 @@ package body Makeutl is
       --  directory prefix.
 
       declare
-         Path : constant String_Access := Locate_Exec_On_Path (Exec_Name);
+         Path : String_Access := Locate_Exec_On_Path (Exec_Name);
       begin
          if Path = null then
             return "";
          else
-            return Get_Install_Dir (Path.all);
+            declare
+               Dir : constant String := Get_Install_Dir (Path.all);
+            begin
+               Free (Path);
+               return Dir;
+            end;
          end if;
       end;
    end Executable_Prefix_Path;
diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads
index c0dc9f16292..ae55ebbe62a 100644
--- a/gcc/ada/makeutl.ads
+++ b/gcc/ada/makeutl.ads
@@ -62,7 +62,8 @@ package Makeutl is
    function Executable_Prefix_Path return String;
    --  Return the absolute path parent directory of the directory where the
    --  current executable resides, if its directory is named "bin", otherwise
-   --  return an empty string.
+   --  return an empty string. When a directory is returned, it is guaranteed
+   --  to end with a directory separator.
 
    procedure Inform (N : Name_Id := No_Name; Msg : String);
    procedure Inform (N : File_Name_Type; Msg : String);
diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb
index 50751c22c3e..37c6296787f 100644
--- a/gcc/ada/prj-ext.adb
+++ b/gcc/ada/prj-ext.adb
@@ -263,8 +263,7 @@ package body Prj.Ext is
                   if Get_Mode = Multi_Language then
                      Add_Str_To_Name_Buffer
                        (Path_Separator & Prefix.all &
-                        Directory_Separator & "share" &
-                        Directory_Separator & "gpr");
+                        "share" & Directory_Separator & "gpr");
                   end if;
 
                   Add_Str_To_Name_Buffer
diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb
index 73e4c9dd2c2..a429903d64b 100644
--- a/gcc/ada/s-tposen.adb
+++ b/gcc/ada/s-tposen.adb
@@ -318,15 +318,9 @@ package body System.Tasking.Protected_Objects.Single_Entry is
       Compiler_Info     : System.Address;
       Entry_Body        : Entry_Body_Access)
    is
-      Init_Priority : Integer := Ceiling_Priority;
    begin
-      if Init_Priority = Unspecified_Priority then
-         Init_Priority := System.Priority'Last;
-      end if;
+      Initialize_Protection (Object.Common'Access, Ceiling_Priority);
 
-      STPO.Initialize_Lock (Init_Priority, Object.L'Access);
-      Object.Ceiling := System.Any_Priority (Init_Priority);
-      Object.Owner := Null_Task;
       Object.Compiler_Info := Compiler_Info;
       Object.Call_In_Progress := null;
       Object.Entry_Body := Entry_Body;
@@ -341,45 +335,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is
    --  Do not call this procedure from within the run-time system.
 
    procedure Lock_Entry (Object : Protection_Entry_Access) is
-      Ceiling_Violation : Boolean;
-
    begin
-      --  If pragma Detect_Blocking is active then, as described in the ARM
-      --  9.5.1, par. 15, we must check whether this is an external call on a
-      --  protected subprogram with the same target object as that of the
-      --  protected action that is currently in progress (i.e., if the caller
-      --  is already the protected object's owner). If this is the case hence
-      --  Program_Error must be raised.
-
-      if Detect_Blocking and then Object.Owner = Self then
-         raise Program_Error;
-      end if;
-
-      STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
-
-      if Ceiling_Violation then
-         raise Program_Error;
-      end if;
-
-      --  We are entering in a protected action, so that we increase the
-      --  protected object nesting level (if pragma Detect_Blocking is
-      --  active), and update the protected object's owner.
-
-      if Detect_Blocking then
-         declare
-            Self_Id : constant Task_Id := Self;
-
-         begin
-            --  Update the protected object's owner
-
-            Object.Owner := Self_Id;
-
-            --  Increase protected object nesting level
-
-            Self_Id.Common.Protected_Action_Nesting :=
-              Self_Id.Common.Protected_Action_Nesting + 1;
-         end;
-      end if;
+      Lock (Object.Common'Access);
    end Lock_Entry;
 
    --------------------------
@@ -391,53 +348,8 @@ package body System.Tasking.Protected_Objects.Single_Entry is
    --  Do not call this procedure from within the runtime system
 
    procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is
-      Ceiling_Violation : Boolean;
-
    begin
-      --  If pragma Detect_Blocking is active then, as described in the ARM
-      --  9.5.1, par. 15, we must check whether this is an external call on a
-      --  protected subprogram with the same target object as that of the
-      --  protected action that is currently in progress (i.e., if the caller
-      --  is already the protected object's owner). If this is the case hence
-      --  Program_Error must be raised.
-
-      --  Note that in this case (getting read access), several tasks may
-      --  have read ownership of the protected object, so that this method of
-      --  storing the (single) protected object's owner does not work
-      --  reliably for read locks. However, this is the approach taken for two
-      --  major reasons: first, this function is not currently being used (it
-      --  is provided for possible future use), and second, it largely
-      --  simplifies the implementation.
-
-      if Detect_Blocking and then Object.Owner = Self then
-         raise Program_Error;
-      end if;
-
-      STPO.Read_Lock (Object.L'Access, Ceiling_Violation);
-
-      if Ceiling_Violation then
-         raise Program_Error;
-      end if;
-
-      --  We are entering in a protected action, so that we increase the
-      --  protected object nesting level (if pragma Detect_Blocking is
-      --  active), and update the protected object's owner.
-
-      if Detect_Blocking then
-         declare
-            Self_Id : constant Task_Id := Self;
-
-         begin
-            --  Update the protected object's owner
-
-            Object.Owner := Self_Id;
-
-            --  Increase protected object nesting level
-
-            Self_Id.Common.Protected_Action_Nesting :=
-              Self_Id.Common.Protected_Action_Nesting + 1;
-         end;
-      end if;
+      Lock_Read_Only (Object.Common'Access);
    end Lock_Read_Only_Entry;
 
    --------------------
@@ -665,7 +577,6 @@ package body System.Tasking.Protected_Objects.Single_Entry is
    is
       Self_Id           : constant Task_Id  := STPO.Self;
       Entry_Call        : Entry_Call_Record renames Self_Id.Entry_Calls (1);
-      Ceiling_Violation : Boolean;
 
    begin
       --  If pragma Detect_Blocking is active then Program_Error must be
@@ -678,11 +589,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
          raise Program_Error with "potentially blocking operation";
       end if;
 
-      STPO.Write_Lock (Object.L'Access, Ceiling_Violation);
-
-      if Ceiling_Violation then
-         raise Program_Error;
-      end if;
+      Lock (Object.Common'Access);
 
       Entry_Call.Mode := Timed_Call;
       Entry_Call.State := Now_Abortable;
@@ -730,32 +637,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
 
    procedure Unlock_Entry (Object : Protection_Entry_Access) is
    begin
-      --  We are exiting from a protected action, so that we decrease the
-      --  protected object nesting level (if pragma Detect_Blocking is
-      --  active), and remove ownership of the protected object.
-
-      if Detect_Blocking then
-         declare
-            Self_Id : constant Task_Id := Self;
-
-         begin
-            --  Calls to this procedure can only take place when being within
-            --  a protected action and when the caller is the protected
-            --  object's owner.
-
-            pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0
-                             and then Object.Owner = Self_Id);
-
-            --  Remove ownership of the protected object
-
-            Object.Owner := Null_Task;
-
-            Self_Id.Common.Protected_Action_Nesting :=
-              Self_Id.Common.Protected_Action_Nesting - 1;
-         end;
-      end if;
-
-      STPO.Unlock (Object.L'Access);
+      Unlock (Object.Common'Access);
    end Unlock_Entry;
 
 end System.Tasking.Protected_Objects.Single_Entry;
diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads
index 4a6e8ddeefd..8c07cfd3ac9 100644
--- a/gcc/ada/s-tposen.ads
+++ b/gcc/ada/s-tposen.ads
@@ -275,10 +275,9 @@ package System.Tasking.Protected_Objects.Single_Entry is
 
 private
    type Protection_Entry is record
-      L : aliased Task_Primitives.Lock;
-      --  The underlying lock associated with a Protection_Entries. Note that
-      --  you should never (un)lock Object.L directly, but instead use
-      --  Lock_Entry/Unlock_Entry.
+      Common : aliased Protection;
+      --  State of the protected object. This part is common to any protected
+      --  object, including those without entries.
 
       Compiler_Info : System.Address;
       --  Pointer to compiler-generated record representing protected object
@@ -286,17 +285,6 @@ private
       Call_In_Progress : Entry_Call_Link;
       --  Pointer to the entry call being executed (if any)
 
-      Ceiling : System.Any_Priority;
-      --  Ceiling priority associated to the protected object
-
-      Owner : Task_Id;
-      --  This field contains the protected object's owner. Null_Task
-      --  indicates that the protected object is not currently being used.
-      --  This information is used for detecting the type of potentially
-      --  blocking operations described in the ARM 9.5.1, par. 15 (external
-      --  calls on a protected subprogram with the same target object as that
-      --  of the protected action).
-
       Entry_Body : Entry_Body_Access;
       --  Pointer to executable code for the entry body of the protected type
 
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index a07832cbd15..a3f7cde4814 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -8562,6 +8562,9 @@ package body Sem_Ch12 is
       Parent_Installed : Boolean := False;
       Save_Style_Check : constant Boolean := Style_Check;
 
+      Par_Ent : Entity_Id := Empty;
+      Par_Vis : Boolean   := False;
+
    begin
       Gen_Body_Id := Corresponding_Body (Gen_Decl);
 
@@ -8637,11 +8640,15 @@ package body Sem_Ch12 is
          if Ekind (Scope (Gen_Unit)) = E_Generic_Package
            and then Nkind (Gen_Id) = N_Expanded_Name
          then
-            Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+            Par_Ent := Entity (Prefix (Gen_Id));
+            Par_Vis := Is_Immediately_Visible (Par_Ent);
+            Install_Parent (Par_Ent, In_Body => True);
             Parent_Installed := True;
 
          elsif Is_Child_Unit (Gen_Unit) then
-            Install_Parent (Scope (Gen_Unit), In_Body => True);
+            Par_Ent := Scope (Gen_Unit);
+            Par_Vis := Is_Immediately_Visible (Par_Ent);
+            Install_Parent (Par_Ent, In_Body => True);
             Parent_Installed := True;
          end if;
 
@@ -8712,6 +8719,10 @@ package body Sem_Ch12 is
 
          if Parent_Installed then
             Remove_Parent (In_Body => True);
+
+            --  Restore the previous visibility of the parent
+
+            Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
          end if;
 
          Restore_Private_Views (Act_Decl_Id);
@@ -8806,6 +8817,9 @@ package body Sem_Ch12 is
       Parent_Installed : Boolean := False;
       Save_Style_Check : constant Boolean := Style_Check;
 
+      Par_Ent : Entity_Id := Empty;
+      Par_Vis : Boolean   := False;
+
    begin
       Gen_Body_Id := Corresponding_Body (Gen_Decl);
 
@@ -8909,11 +8923,15 @@ package body Sem_Ch12 is
          if Ekind (Scope (Gen_Unit)) = E_Generic_Package
            and then Nkind (Gen_Id) = N_Expanded_Name
          then
-            Install_Parent (Entity (Prefix (Gen_Id)), In_Body => True);
+            Par_Ent := Entity (Prefix (Gen_Id));
+            Par_Vis := Is_Immediately_Visible (Par_Ent);
+            Install_Parent (Par_Ent, In_Body => True);
             Parent_Installed := True;
 
          elsif Is_Child_Unit (Gen_Unit) then
-            Install_Parent (Scope (Gen_Unit), In_Body => True);
+            Par_Ent := Scope (Gen_Unit);
+            Par_Vis := Is_Immediately_Visible (Par_Ent);
+            Install_Parent (Par_Ent, In_Body => True);
             Parent_Installed := True;
          end if;
 
@@ -8994,6 +9012,10 @@ package body Sem_Ch12 is
 
          if Parent_Installed then
             Remove_Parent (In_Body => True);
+
+            --  Restore the previous visibility of the parent
+
+            Set_Is_Immediately_Visible (Par_Ent, Par_Vis);
          end if;
 
          Restore_Env;