OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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

From-SVN: r148701
This commit is contained in:
Arnaud Charlet 2009-06-19 14:23:38 +02:00
parent 0eed21bd6a
commit 659819b971
8 changed files with 72 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/ada/ChangeLog
View File

@ -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,

5
gcc/ada/a-einuoc.ads
View File

@ -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

12
gcc/ada/makeutl.adb
View File

@ -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;

3
gcc/ada/makeutl.ads
View File

@ -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);

3
gcc/ada/prj-ext.adb
View File

@ -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

128
gcc/ada/s-tposen.adb
View File

@ -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;

18
gcc/ada/s-tposen.ads
View File

@ -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

30
gcc/ada/sem_ch12.adb
View File

@ -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;