git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

2011-10-24 Sergey Rybin <rybin@adacore.com frybin> 

* gnat_ugn.texi: For gnatelim, move the note about using the GNAT
	driver for getting the project support into gnatelim section.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Minor correction to documentation on address
	clause.

2011-10-24  Hristian Kirtchev  <kirtchev@adacore.com>

	* s-finmas.adb (Attach): Synchronize and call the unprotected version.
	(Attach_Unprotected): New routine.
	(Delete_Finalize_Address): Removed.
	(Delete_Finalize_Address_Unprotected): New routine.
	(Detach): Synchronize and call the unprotected version.
	(Detach_Unprotected): Remove locking.
	(Finalize): Add various comment on synchronization. Lock the critical
	region and call the unprotected versions of routines.
	(Finalize_Address): Removed.
	(Finalize_Address_Unprotected): New routine.
	(Set_Finalize_Address): Synchronize and call
	the unprotected version.
	(Set_Finalize_Address_Unprotected): New routine.
	(Set_Heterogeneous_Finalize_Address): Removed.
	(Set_Heterogeneous_Finalize_Address_Unprotected): New routine.
	(Set_Is_Heterogeneous): Add comment on synchronization and
	locking.
	* s-finmas.ads: Flag Finalization_Started is no longer atomic
	because synchronization uses task locking / unlocking.
	(Attach): Add comment on usage.
	(Attach_Unprotected): New routine.
	(Delete_Finalize_Address): Renamed to
	Delete_Finalize_Address_Unprotected.
	(Detach): Add comment on usage.
	(Detach_Unprotected): New routine.
	(Finalize_Address): Renamed to Finalize_Address_Unprotected.
	(Set_Finalize_Address): Add comment on usage.
	(Set_Finalize_Address_Unprotected): New routine.
	(Set_Heterogeneous_Finalize_Address): Renamed to
	Set_Heterogeneous_Finalize_Address_Unprotected.
	* s-stposu.adb (Allocate_Any_Controlled): Add local variable
	Allocation_Locked. Add various comments on synchronization. Lock
	the critical region and call the unprotected version of
	routines.
	(Deallocate_Any_Controlled): Add various comments on
	synchronization. Lock the critical region and call the unprotected
	version of routines.

2011-10-24  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Set_Fixed_Range): The bounds of a fixed point type
	are universal and must carry the corresponding type.
	* sem_eval.adb (Check_Non_Static_Context): If the type of the
	expression is universal real, as may be the case for a fixed point
	expression with constant operands in the context of a conversion,
	there is nothing to check.
	* s-finmas.adb: Minor reformatting

From-SVN: r180368
This commit is contained in:
Arnaud Charlet 2011-10-24 11:19:15 +02:00
parent 02b76a8d70
commit 86f0e17adc
8 changed files with 303 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
gcc/ada/ChangeLog
View File

@ -1,3 +1,63 @@
2011-10-24 Sergey Rybin <rybin@adacore.com frybin>
* gnat_ugn.texi: For gnatelim, move the note about using the GNAT
driver for getting the project support into gnatelim section.
2011-10-24 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Minor correction to documentation on address
clause.
2011-10-24 Hristian Kirtchev <kirtchev@adacore.com>
* s-finmas.adb (Attach): Synchronize and call the unprotected version.
(Attach_Unprotected): New routine.
(Delete_Finalize_Address): Removed.
(Delete_Finalize_Address_Unprotected): New routine.
(Detach): Synchronize and call the unprotected version.
(Detach_Unprotected): Remove locking.
(Finalize): Add various comment on synchronization. Lock the critical
region and call the unprotected versions of routines.
(Finalize_Address): Removed.
(Finalize_Address_Unprotected): New routine.
(Set_Finalize_Address): Synchronize and call
the unprotected version.
(Set_Finalize_Address_Unprotected): New routine.
(Set_Heterogeneous_Finalize_Address): Removed.
(Set_Heterogeneous_Finalize_Address_Unprotected): New routine.
(Set_Is_Heterogeneous): Add comment on synchronization and
locking.
* s-finmas.ads: Flag Finalization_Started is no longer atomic
because synchronization uses task locking / unlocking.
(Attach): Add comment on usage.
(Attach_Unprotected): New routine.
(Delete_Finalize_Address): Renamed to
Delete_Finalize_Address_Unprotected.
(Detach): Add comment on usage.
(Detach_Unprotected): New routine.
(Finalize_Address): Renamed to Finalize_Address_Unprotected.
(Set_Finalize_Address): Add comment on usage.
(Set_Finalize_Address_Unprotected): New routine.
(Set_Heterogeneous_Finalize_Address): Renamed to
Set_Heterogeneous_Finalize_Address_Unprotected.
* s-stposu.adb (Allocate_Any_Controlled): Add local variable
Allocation_Locked. Add various comments on synchronization. Lock
the critical region and call the unprotected version of
routines.
(Deallocate_Any_Controlled): Add various comments on
synchronization. Lock the critical region and call the unprotected
version of routines.
2011-10-24 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Set_Fixed_Range): The bounds of a fixed point type
are universal and must carry the corresponding type.
* sem_eval.adb (Check_Non_Static_Context): If the type of the
expression is universal real, as may be the case for a fixed point
expression with constant operands in the context of a conversion,
there is nothing to check.
* s-finmas.adb: Minor reformatting
2011-10-23 Eric Botcazou <ebotcazou@adacore.com> 2011-10-23 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/decl.c (create_concat_name): Add explicit cast. * gcc-interface/decl.c (create_concat_name): Add explicit cast.

4
gcc/ada/gnat_rm.texi
View File

@ -11925,9 +11925,7 @@ The type of the item is non-elementary (e.g.@: a record or array).
@item @item
There is explicit or implicit initialization required for the object. There is explicit or implicit initialization required for the object.
Note that access values are always implicitly initialized, and also Note that access values are always implicitly initialized.
in GNAT, certain bit-packed arrays (those having a dynamic length or
a length greater than 64) will also be implicitly initialized to zero.
@item @item
The address value is non-static. Here GNAT is more permissive than the The address value is non-static. Here GNAT is more permissive than the

10
gcc/ada/gnat_ugn.texi
View File

@ -10092,9 +10092,6 @@ and some of the techniques for making your program run faster.
It then documents the @command{gnatelim} tool and unused subprogram/data It then documents the @command{gnatelim} tool and unused subprogram/data
elimination feature, which can reduce the size of program executables. elimination feature, which can reduce the size of program executables.
Note: to invoke @command{gnatelim} with a project file, use the @code{gnat}
driver (see @ref{The GNAT Driver and Project Files}).
@ifnottex @ifnottex
@menu @menu
* Performance Considerations:: * Performance Considerations::
@ -11018,6 +11015,10 @@ indicate that the analysed set of sources is incomplete to make up a
partition and that some subprogram bodies are missing are not generated. partition and that some subprogram bodies are missing are not generated.
@end table @end table
@noindent
Note: to invoke @command{gnatelim} with a project file, use the @code{gnat}
driver (see @ref{The GNAT Driver and Project Files}).
@node Processing Precompiled Libraries @node Processing Precompiled Libraries
@subsection Processing Precompiled Libraries @subsection Processing Precompiled Libraries
@ -12832,6 +12833,7 @@ the configuration file describing the corresponding naming scheme;
see the description of the @command{gnatpp} see the description of the @command{gnatpp}
switches below. Another possibility is to use a project file and to switches below. Another possibility is to use a project file and to
call @command{gnatpp} through the @command{gnat} driver call @command{gnatpp} through the @command{gnat} driver
(see @ref{The GNAT Driver and Project Files}).
The @command{gnatpp} command has the form The @command{gnatpp} command has the form
@ -13959,7 +13961,7 @@ in files with names that do not follow the GNAT file naming rules, you have to
provide the configuration file describing the corresponding naming scheme (see provide the configuration file describing the corresponding naming scheme (see
the description of the @command{gnatmetric} switches below.) the description of the @command{gnatmetric} switches below.)
Alternatively, you may use a project file and invoke @command{gnatmetric} Alternatively, you may use a project file and invoke @command{gnatmetric}
through the @command{gnat} driver. through the @command{gnat} driver (see @ref{The GNAT Driver and Project Files}).
The @command{gnatmetric} command has the form The @command{gnatmetric} command has the form

173
gcc/ada/s-finmas.adb
View File

@ -77,18 +77,28 @@ package body System.Finalization_Masters is
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
begin begin
Lock_Task.all; Lock_Task.all;
Attach_Unprotected (N, L);
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
Unlock_Task.all; Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above -- Note: No need to unlock in case of an exception because the above
-- code can never raise one. -- code can never raise one.
end Attach; end Attach;
------------------------
-- Attach_Unprotected --
------------------------
procedure Attach_Unprotected
(N : not null FM_Node_Ptr;
L : not null FM_Node_Ptr)
is
begin
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
end Attach_Unprotected;
--------------- ---------------
-- Base_Pool -- -- Base_Pool --
--------------- ---------------
@ -100,16 +110,14 @@ package body System.Finalization_Masters is
return Master.Base_Pool; return Master.Base_Pool;
end Base_Pool; end Base_Pool;
----------------------------- -----------------------------------------
-- Delete_Finalize_Address -- -- Delete_Finalize_Address_Unprotected --
----------------------------- -----------------------------------------
procedure Delete_Finalize_Address (Obj : System.Address) is procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
begin begin
Lock_Task.all;
Finalize_Address_Table.Remove (Obj); Finalize_Address_Table.Remove (Obj);
Unlock_Task.all; end Delete_Finalize_Address_Unprotected;
end Delete_Finalize_Address;
------------ ------------
-- Detach -- -- Detach --
@ -117,20 +125,27 @@ package body System.Finalization_Masters is
procedure Detach (N : not null FM_Node_Ptr) is procedure Detach (N : not null FM_Node_Ptr) is
begin begin
if N.Prev /= null and then N.Next /= null then Lock_Task.all;
Lock_Task.all; Detach_Unprotected (N);
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end Detach;
------------------------
-- Detach_Unprotected --
------------------------
procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
begin
if N.Prev /= null and then N.Next /= null then
N.Prev.Next := N.Next; N.Prev.Next := N.Next;
N.Next.Prev := N.Prev; N.Next.Prev := N.Prev;
N.Prev := null; N.Prev := null;
N.Next := null; N.Next := null;
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
end if; end if;
end Detach; end Detach_Unprotected;
-------------- --------------
-- Finalize -- -- Finalize --
@ -158,10 +173,14 @@ package body System.Finalization_Masters is
-- Start of processing for Finalize -- Start of processing for Finalize
begin begin
-- It is possible for multiple tasks to cause the finalization of the Lock_Task.all;
-- same master. Let only one task finalize the objects.
-- Synchronization:
-- Read - allocation, finalization
-- Write - finalization
if Master.Finalization_Started then if Master.Finalization_Started then
Unlock_Task.all;
return; return;
end if; end if;
@ -170,12 +189,19 @@ package body System.Finalization_Masters is
-- is explicitly deallocated or the associated access type is about to -- is explicitly deallocated or the associated access type is about to
-- go out of scope. -- go out of scope.
-- Synchronization:
-- Read - allocation, finalization
-- Write - finalization
Master.Finalization_Started := True; Master.Finalization_Started := True;
while not Is_Empty_List (Master.Objects'Unchecked_Access) loop while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
Curr_Ptr := Master.Objects.Next; Curr_Ptr := Master.Objects.Next;
Detach (Curr_Ptr); -- Synchronization:
-- Write - allocation, deallocation, finalization
Detach_Unprotected (Curr_Ptr);
-- Skip the list header in order to offer proper object layout for -- Skip the list header in order to offer proper object layout for
-- finalization. -- finalization.
@ -185,20 +211,28 @@ package body System.Finalization_Masters is
-- Retrieve TSS primitive Finalize_Address depending on the master's -- Retrieve TSS primitive Finalize_Address depending on the master's
-- mode of operation. -- mode of operation.
-- Synchronization:
-- Read - allocation, finalization
-- Write - outside
if Master.Is_Homogeneous then if Master.Is_Homogeneous then
-- Synchronization:
-- Read - finalization
-- Write - allocation, outside
Cleanup := Master.Finalize_Address; Cleanup := Master.Finalize_Address;
else else
Cleanup := Finalize_Address (Obj_Addr); -- Synchronization:
-- Read - finalization
-- Write - allocation, deallocation
Cleanup := Finalize_Address_Unprotected (Obj_Addr);
end if; end if;
-- If Finalize_Address is not available, then this is most likely an
-- error in the expansion of the designated type or the allocator.
pragma Assert (Cleanup /= null);
begin begin
Cleanup (Obj_Addr); Cleanup (Obj_Addr);
exception exception
when Fin_Occur : others => when Fin_Occur : others =>
if not Raised then if not Raised then
@ -210,11 +244,22 @@ package body System.Finalization_Masters is
-- When the master is a heterogeneous collection, destroy the object -- When the master is a heterogeneous collection, destroy the object
-- - Finalize_Address pair since it is no longer needed. -- - Finalize_Address pair since it is no longer needed.
-- Synchronization:
-- Read - finalization
-- Write - outside
if not Master.Is_Homogeneous then if not Master.Is_Homogeneous then
Delete_Finalize_Address (Obj_Addr);
-- Synchronization:
-- Read - finalization
-- Write - allocation, deallocation, finalization
Delete_Finalize_Address_Unprotected (Obj_Addr);
end if; end if;
end loop; end loop;
Unlock_Task.all;
-- If the finalization of a particular object failed or Finalize_Address -- If the finalization of a particular object failed or Finalize_Address
-- was not set, reraise the exception now. -- was not set, reraise the exception now.
@ -234,20 +279,16 @@ package body System.Finalization_Masters is
return Master.Finalize_Address; return Master.Finalize_Address;
end Finalize_Address; end Finalize_Address;
---------------------- ----------------------------------
-- Finalize_Address -- -- Finalize_Address_Unprotected --
---------------------- ----------------------------------
function Finalize_Address function Finalize_Address_Unprotected
(Obj : System.Address) return Finalize_Address_Ptr (Obj : System.Address) return Finalize_Address_Ptr
is is
Result : Finalize_Address_Ptr;
begin begin
Lock_Task.all; return Finalize_Address_Table.Get (Obj);
Result := Finalize_Address_Table.Get (Obj); end Finalize_Address_Unprotected;
Unlock_Task.all;
return Result;
end Finalize_Address;
-------------------------- --------------------------
-- Finalization_Started -- -- Finalization_Started --
@ -463,36 +504,40 @@ package body System.Finalization_Masters is
Fin_Addr_Ptr : Finalize_Address_Ptr) Fin_Addr_Ptr : Finalize_Address_Ptr)
is is
begin begin
-- TSS primitive Finalize_Address is set at the point of allocation, -- Synchronization:
-- either through Allocate_Any_Controlled or through this routine. -- Read - finalization
-- Since multiple tasks can allocate on the same finalization master, -- Write - allocation, outside
-- access to this attribute must be protected.
Lock_Task.all; Lock_Task.all;
Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Addr_Ptr;
end if;
Unlock_Task.all; Unlock_Task.all;
end Set_Finalize_Address; end Set_Finalize_Address;
---------------------------------------- --------------------------------------
-- Set_Heterogeneous_Finalize_Address -- -- Set_Finalize_Address_Unprotected --
---------------------------------------- --------------------------------------
procedure Set_Heterogeneous_Finalize_Address procedure Set_Finalize_Address_Unprotected
(Master : in out Finalization_Master;
Fin_Addr_Ptr : Finalize_Address_Ptr)
is
begin
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Addr_Ptr;
end if;
end Set_Finalize_Address_Unprotected;
----------------------------------------------------
-- Set_Heterogeneous_Finalize_Address_Unprotected --
----------------------------------------------------
procedure Set_Heterogeneous_Finalize_Address_Unprotected
(Obj : System.Address; (Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr) Fin_Addr_Ptr : Finalize_Address_Ptr)
is is
begin begin
-- Protected access is required in this case because
-- Finalize_Address_Table is a global data structure.
Lock_Task.all;
Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
Unlock_Task.all; end Set_Heterogeneous_Finalize_Address_Unprotected;
end Set_Heterogeneous_Finalize_Address;
-------------------------- --------------------------
-- Set_Is_Heterogeneous -- -- Set_Is_Heterogeneous --
@ -500,7 +545,13 @@ package body System.Finalization_Masters is
procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
begin begin
-- Synchronization:
-- Read - finalization
-- Write - outside
Lock_Task.all;
Master.Is_Homogeneous := False; Master.Is_Homogeneous := False;
Unlock_Task.all;
end Set_Is_Heterogeneous; end Set_Is_Heterogeneous;
end System.Finalization_Masters; end System.Finalization_Masters;

26
gcc/ada/s-finmas.ads
View File

@ -74,13 +74,23 @@ package System.Finalization_Masters is
for Finalization_Master_Ptr'Storage_Size use 0; for Finalization_Master_Ptr'Storage_Size use 0;
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr); procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr);
-- Compiler interface, do not call from withing the run-time. Prepend a
-- node to a specific finalization master.
procedure Attach_Unprotected
(N : not null FM_Node_Ptr;
L : not null FM_Node_Ptr);
-- Prepend a node to a specific finalization master -- Prepend a node to a specific finalization master
procedure Delete_Finalize_Address (Obj : System.Address); procedure Delete_Finalize_Address_Unprotected (Obj : System.Address);
-- Destroy the relation pair object - Finalize_Address from the internal -- Destroy the relation pair object - Finalize_Address from the internal
-- hash table. -- hash table.
procedure Detach (N : not null FM_Node_Ptr); procedure Detach (N : not null FM_Node_Ptr);
-- Compiler interface, do not call from within the run-time. Remove a node
-- from an arbitrary finalization master.
procedure Detach_Unprotected (N : not null FM_Node_Ptr);
-- Remove a node from an arbitrary finalization master -- Remove a node from an arbitrary finalization master
overriding procedure Finalize (Master : in out Finalization_Master); overriding procedure Finalize (Master : in out Finalization_Master);
@ -93,7 +103,7 @@ package System.Finalization_Masters is
-- Return a reference to the TSS primitive Finalize_Address associated with -- Return a reference to the TSS primitive Finalize_Address associated with
-- a master. -- a master.
function Finalize_Address function Finalize_Address_Unprotected
(Obj : System.Address) return Finalize_Address_Ptr; (Obj : System.Address) return Finalize_Address_Ptr;
-- Retrieve the Finalize_Address primitive associated with a particular -- Retrieve the Finalize_Address primitive associated with a particular
-- object. -- object.
@ -119,9 +129,15 @@ package System.Finalization_Masters is
procedure Set_Finalize_Address procedure Set_Finalize_Address
(Master : in out Finalization_Master; (Master : in out Finalization_Master;
Fin_Addr_Ptr : Finalize_Address_Ptr); Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Compiler interface, do not call from within the run-time. Set the clean
-- up routine of a finalization master
procedure Set_Finalize_Address_Unprotected
(Master : in out Finalization_Master;
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Set the clean up routine of a finalization master -- Set the clean up routine of a finalization master
procedure Set_Heterogeneous_Finalize_Address procedure Set_Heterogeneous_Finalize_Address_Unprotected
(Obj : System.Address; (Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr); Fin_Addr_Ptr : Finalize_Address_Ptr);
-- Add a relation pair object - Finalize_Address to the internal hash -- Add a relation pair object - Finalize_Address to the internal hash
@ -165,11 +181,9 @@ private
-- is used only when the master is in homogeneous mode. -- is used only when the master is in homogeneous mode.
Finalization_Started : Boolean := False; Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization -- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario -- of a master. The allocations must raise Program_Error. This scenario
-- may arise in a multitask environment. The flag is atomic because it -- may arise in a multitask environment.
-- is accessed without Lock_Task / Unlock_Task.
end record; end record;
-- Since RTSfind cannot contain names of the form RE_"+", the following -- Since RTSfind cannot contain names of the form RE_"+", the following

65
gcc/ada/s-stposu.adb
View File

@ -109,6 +109,9 @@ package body System.Storage_Pools.Subpools is
N_Size : Storage_Count; N_Size : Storage_Count;
Subpool : Subpool_Handle := null; Subpool : Subpool_Handle := null;
Allocation_Locked : Boolean;
-- This flag stores the state of the associated collection
Header_And_Padding : Storage_Offset; Header_And_Padding : Storage_Offset;
-- This offset includes the size of a FM_Node plus any additional -- This offset includes the size of a FM_Node plus any additional
-- padding due to a larger alignment. -- padding due to a larger alignment.
@ -156,22 +159,22 @@ package body System.Storage_Pools.Subpools is
-- failed to create one. This is a serious error. -- failed to create one. This is a serious error.
if Context_Master = null then if Context_Master = null then
raise Program_Error with "missing master in pool allocation"; raise Program_Error
end if; with "missing master in pool allocation";
-- If a subpool is present, then this is the result of erroneous -- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should -- allocator expansion. This is not a serious error, but it should
-- still be detected. -- still be detected.
if Context_Subpool /= null then elsif Context_Subpool /= null then
raise Program_Error with "subpool not required in pool allocation"; raise Program_Error
end if; with "subpool not required in pool allocation";
-- If the allocation is intended to be on a subpool, but the access -- If the allocation is intended to be on a subpool, but the access
-- type's pool does not support subpools, then this is the result of -- type's pool does not support subpools, then this is the result of
-- erroneous end-user code. -- erroneous end-user code.
if On_Subpool then elsif On_Subpool then
raise Program_Error raise Program_Error
with "pool of access type does not support subpools"; with "pool of access type does not support subpools";
end if; end if;
@ -187,10 +190,18 @@ package body System.Storage_Pools.Subpools is
if Is_Controlled then if Is_Controlled then
-- Synchronization:
-- Read - allocation, finalization
-- Write - finalization
Lock_Task.all;
Allocation_Locked := Finalization_Started (Master.all);
Unlock_Task.all;
-- Do not allow the allocation of controlled objects while the -- Do not allow the allocation of controlled objects while the
-- associated master is being finalized. -- associated master is being finalized.
if Finalization_Started (Master.all) then if Allocation_Locked then
raise Program_Error with "allocation after finalization started"; raise Program_Error with "allocation after finalization started";
end if; end if;
@ -240,6 +251,7 @@ package body System.Storage_Pools.Subpools is
-- Step 4: Attachment -- Step 4: Attachment
if Is_Controlled then if Is_Controlled then
Lock_Task.all;
-- Map the allocated memory into a FM_Node record. This converts the -- Map the allocated memory into a FM_Node record. This converts the
-- top of the allocated bits into a list header. If there is padding -- top of the allocated bits into a list header. If there is padding
@ -262,7 +274,10 @@ package body System.Storage_Pools.Subpools is
-- Prepend the allocated object to the finalization master -- Prepend the allocated object to the finalization master
Attach (N_Ptr, Objects (Master.all)); -- Synchronization:
-- Write - allocation, deallocation, finalization
Attach_Unprotected (N_Ptr, Objects (Master.all));
-- Move the address from the hidden list header to the start of the -- Move the address from the hidden list header to the start of the
-- object. This operation effectively hides the list header. -- object. This operation effectively hides the list header.
@ -275,8 +290,17 @@ package body System.Storage_Pools.Subpools is
-- 2) Named access types -- 2) Named access types
-- 3) Most cases of anonymous access types usage -- 3) Most cases of anonymous access types usage
-- Synchronization:
-- Read - allocation, finalization
-- Write - outside
if Master.Is_Homogeneous then if Master.Is_Homogeneous then
Set_Finalize_Address (Master.all, Fin_Address);
-- Synchronization:
-- Read - finalization
-- Write - allocation, outside
Set_Finalize_Address_Unprotected (Master.all, Fin_Address);
-- Heterogeneous masters service the following: -- Heterogeneous masters service the following:
@ -284,10 +308,16 @@ package body System.Storage_Pools.Subpools is
-- 2) Certain cases of anonymous access types usage -- 2) Certain cases of anonymous access types usage
else else
Set_Heterogeneous_Finalize_Address (Addr, Fin_Address); -- Synchronization:
-- Read - finalization
-- Write - allocation, deallocation
Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address);
Finalize_Address_Table_In_Use := True; Finalize_Address_Table_In_Use := True;
end if; end if;
Unlock_Task.all;
-- Non-controlled allocation -- Non-controlled allocation
else else
@ -341,12 +371,18 @@ package body System.Storage_Pools.Subpools is
-- Step 1: Detachment -- Step 1: Detachment
if Is_Controlled then if Is_Controlled then
Lock_Task.all;
-- Destroy the relation pair object - Finalize_Address since it is no -- Destroy the relation pair object - Finalize_Address since it is no
-- longer needed. -- longer needed.
if Finalize_Address_Table_In_Use then if Finalize_Address_Table_In_Use then
Delete_Finalize_Address (Addr);
-- Synchronization:
-- Read - finalization
-- Write - allocation, deallocation
Delete_Finalize_Address_Unprotected (Addr);
end if; end if;
-- Account for possible padding space before the header due to a -- Account for possible padding space before the header due to a
@ -376,7 +412,10 @@ package body System.Storage_Pools.Subpools is
-- action does not need to know the prior context used during -- action does not need to know the prior context used during
-- allocation. -- allocation.
Detach (N_Ptr); -- Synchronization:
-- Write - allocation, deallocation, finalization
Detach_Unprotected (N_Ptr);
-- Move the address from the object to the beginning of the list -- Move the address from the object to the beginning of the list
-- header. -- header.
@ -388,6 +427,8 @@ package body System.Storage_Pools.Subpools is
N_Size := Storage_Size + Header_And_Padding; N_Size := Storage_Size + Header_And_Padding;
Unlock_Task.all;
else else
N_Addr := Addr; N_Addr := Addr;
N_Size := Storage_Size; N_Size := Storage_Size;

25
gcc/ada/sem_ch3.adb
View File

@ -19570,17 +19570,16 @@ package body Sem_Ch3 is
-- do not know the exact end points at the time of the declaration. This -- do not know the exact end points at the time of the declaration. This
-- is true for three reasons: -- is true for three reasons:
-- A size clause may affect the fudging of the end-points -- A size clause may affect the fudging of the end-points.
-- A small clause may affect the values of the end-points -- A small clause may affect the values of the end-points.
-- We try to include the end-points if it does not affect the size -- We try to include the end-points if it does not affect the size.
-- This means that the actual end-points must be established at the point -- This means that the actual end-points must be established at the
-- when the type is frozen. Meanwhile, we first narrow the range as -- point when the type is frozen. Meanwhile, we first narrow the range
-- permitted (so that it will fit if necessary in a small specified size), -- as permitted (so that it will fit if necessary in a small specified
-- and then build a range subtree with these narrowed bounds. -- size), and then build a range subtree with these narrowed bounds.
-- Set_Fixed_Range constructs the range from real literal values, and
-- Set_Fixed_Range constructs the range from real literal values, and sets -- sets the range as the Scalar_Range of the given fixed-point type entity.
-- the range as the Scalar_Range of the given fixed-point type entity.
-- The parent of this range is set to point to the entity so that it is -- The parent of this range is set to point to the entity so that it is
-- properly hooked into the tree (unlike normal Scalar_Range entries for -- properly hooked into the tree (unlike normal Scalar_Range entries for
@ -19605,6 +19604,12 @@ package body Sem_Ch3 is
begin begin
Set_Scalar_Range (E, S); Set_Scalar_Range (E, S);
Set_Parent (S, E); Set_Parent (S, E);
-- Before the freeze point, the bounds of a fixed point are universal
-- and carry the corresponding type.
Set_Etype (Low_Bound (S), Universal_Real);
Set_Etype (High_Bound (S), Universal_Real);
end Set_Fixed_Range; end Set_Fixed_Range;
---------------------------------- ----------------------------------

67
gcc/ada/sem_eval.adb
View File

@ -250,27 +250,32 @@ package body Sem_Eval is
and not Range_Checks_Suppressed (T); and not Range_Checks_Suppressed (T);
begin begin
-- Ignore cases of non-scalar types or error types -- Ignore cases of non-scalar types, error types, or universal real
-- types that have no usable bounds.
if T = Any_Type or else not Is_Scalar_Type (T) then if T = Any_Type
or else not Is_Scalar_Type (T)
or else T = Universal_Fixed
or else T = Universal_Real
then
return; return;
end if; end if;
-- At this stage we have a scalar type. If we have an expression -- At this stage we have a scalar type. If we have an expression that
-- that raises CE, then we already issued a warning or error msg -- raises CE, then we already issued a warning or error msg so there
-- so there is nothing more to be done in this routine. -- is nothing more to be done in this routine.
if Raises_Constraint_Error (N) then if Raises_Constraint_Error (N) then
return; return;
end if; end if;
-- Now we have a scalar type which is not marked as raising a -- Now we have a scalar type which is not marked as raising a constraint
-- constraint error exception. The main purpose of this routine -- error exception. The main purpose of this routine is to deal with
-- is to deal with static expressions appearing in a non-static -- static expressions appearing in a non-static context. That means
-- context. That means that if we do not have a static expression -- that if we do not have a static expression then there is not much
-- then there is not much to do. The one case that we deal with -- to do. The one case that we deal with here is that if we have a
-- here is that if we have a floating-point value that is out of -- floating-point value that is out of range, then we post a warning
-- range, then we post a warning that an infinity will result. -- that an infinity will result.
if not Is_Static_Expression (N) then if not Is_Static_Expression (N) then
if Is_Floating_Point_Type (T) if Is_Floating_Point_Type (T)
@ -283,17 +288,17 @@ package body Sem_Eval is
return; return;
end if; end if;
-- Here we have the case of outer level static expression of -- Here we have the case of outer level static expression of scalar
-- scalar type, where the processing of this procedure is needed. -- type, where the processing of this procedure is needed.
-- For real types, this is where we convert the value to a machine -- For real types, this is where we convert the value to a machine
-- number (see RM 4.9(38)). Also see ACVC test C490001. We should -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
-- only need to do this if the parent is a constant declaration, -- need to do this if the parent is a constant declaration, since in
-- since in other cases, gigi should do the necessary conversion -- other cases, gigi should do the necessary conversion correctly, but
-- correctly, but experimentation shows that this is not the case -- experimentation shows that this is not the case on all machines, in
-- on all machines, in particular if we do not convert all literals -- particular if we do not convert all literals to machine values in
-- to machine values in non-static contexts, then ACVC test C490001 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
-- fails on Sparc/Solaris and SGI/Irix. -- and SGI/Irix.
if Nkind (N) = N_Real_Literal if Nkind (N) = N_Real_Literal
and then not Is_Machine_Number (N) and then not Is_Machine_Number (N)
@ -320,12 +325,12 @@ package body Sem_Eval is
elsif not UR_Is_Zero (Realval (N)) then elsif not UR_Is_Zero (Realval (N)) then
-- Note: even though RM 4.9(38) specifies biased rounding, -- Note: even though RM 4.9(38) specifies biased rounding, this
-- this has been modified by AI-100 in order to prevent -- has been modified by AI-100 in order to prevent confusing
-- confusing differences in rounding between static and -- differences in rounding between static and non-static
-- non-static expressions. AI-100 specifies that the effect -- expressions. AI-100 specifies that the effect of such rounding
-- of such rounding is implementation dependent, and in GNAT -- is implementation dependent, and in GNAT we round to nearest
-- we round to nearest even to match the run-time behavior. -- even to match the run-time behavior.
Set_Realval Set_Realval
(N, Machine (Base_Type (T), Realval (N), Round_Even, N)); (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
@ -455,10 +460,10 @@ package body Sem_Eval is
-- simple cases can be recognized. -- simple cases can be recognized.
function Is_Same_Value (L, R : Node_Id) return Boolean; function Is_Same_Value (L, R : Node_Id) return Boolean;
-- Returns True iff L and R represent expressions that definitely -- Returns True iff L and R represent expressions that definitely have
-- have identical (but not necessarily compile time known) values -- identical (but not necessarily compile time known) values Indeed the
-- Indeed the caller is expected to have already dealt with the -- caller is expected to have already dealt with the cases of compile
-- cases of compile time known values, so these are not tested here. -- time known values, so these are not tested here.
----------------------- -----------------------
-- Compare_Decompose -- -- Compare_Decompose --