+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,
-- --
-- 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- --
-- 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
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
-- 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;
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);
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
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;
-- 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;
--------------------------
-- 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;
--------------------
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
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;
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;
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
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
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);
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;
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);
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);
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;
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;
OSDN Git Service
