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>
* 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
There is explicit or implicit initialization required for the object.
Note that access values are always implicitly initialized, and also
in GNAT, certain bit-packed arrays (those having a dynamic length or
a length greater than 64) will also be implicitly initialized to zero.
Note that access values are always implicitly initialized.
@item
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
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
@menu
* 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.
@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
@subsection Processing Precompiled Libraries
@ -12832,6 +12833,7 @@ the configuration file describing the corresponding naming scheme;
see the description of the @command{gnatpp}
switches below. Another possibility is to use a project file and to
call @command{gnatpp} through the @command{gnat} driver
(see @ref{The GNAT Driver and Project Files}).
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
the description of the @command{gnatmetric} switches below.)
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

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
begin
Lock_Task.all;
L.Next.Prev := N;
N.Next := L.Next;
L.Next := N;
N.Prev := L;
Attach_Unprotected (N, L);
Unlock_Task.all;
-- Note: No need to unlock in case of an exception because the above
-- code can never raise one.
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 --
---------------
@ -100,16 +110,14 @@ package body System.Finalization_Masters is
return Master.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
Lock_Task.all;
Finalize_Address_Table.Remove (Obj);
Unlock_Task.all;
end Delete_Finalize_Address;
end Delete_Finalize_Address_Unprotected;
------------
-- Detach --
@ -117,20 +125,27 @@ package body System.Finalization_Masters is
procedure Detach (N : not null FM_Node_Ptr) is
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.Next.Prev := N.Prev;
N.Prev := 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 Detach;
end Detach_Unprotected;
--------------
-- Finalize --
@ -158,10 +173,14 @@ package body System.Finalization_Masters is
-- Start of processing for Finalize
begin
-- It is possible for multiple tasks to cause the finalization of the
-- same master. Let only one task finalize the objects.
Lock_Task.all;
-- Synchronization:
-- Read - allocation, finalization
-- Write - finalization
if Master.Finalization_Started then
Unlock_Task.all;
return;
end if;
@ -170,12 +189,19 @@ package body System.Finalization_Masters is
-- is explicitly deallocated or the associated access type is about to
-- go out of scope.
-- Synchronization:
-- Read - allocation, finalization
-- Write - finalization
Master.Finalization_Started := True;
while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
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
-- finalization.
@ -185,20 +211,28 @@ package body System.Finalization_Masters is
-- Retrieve TSS primitive Finalize_Address depending on the master's
-- mode of operation.
-- Synchronization:
-- Read - allocation, finalization
-- Write - outside
if Master.Is_Homogeneous then
-- Synchronization:
-- Read - finalization
-- Write - allocation, outside
Cleanup := Master.Finalize_Address;
else
Cleanup := Finalize_Address (Obj_Addr);
-- Synchronization:
-- Read - finalization
-- Write - allocation, deallocation
Cleanup := Finalize_Address_Unprotected (Obj_Addr);
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
Cleanup (Obj_Addr);
exception
when Fin_Occur : others =>
if not Raised then
@ -210,11 +244,22 @@ package body System.Finalization_Masters is
-- When the master is a heterogeneous collection, destroy the object
-- - Finalize_Address pair since it is no longer needed.
-- Synchronization:
-- Read - finalization
-- Write - outside
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 loop;
Unlock_Task.all;
-- If the finalization of a particular object failed or Finalize_Address
-- was not set, reraise the exception now.
@ -234,20 +279,16 @@ package body System.Finalization_Masters is
return Master.Finalize_Address;
end Finalize_Address;
----------------------
-- Finalize_Address --
----------------------
----------------------------------
-- Finalize_Address_Unprotected --
----------------------------------
function Finalize_Address
function Finalize_Address_Unprotected
(Obj : System.Address) return Finalize_Address_Ptr
is
Result : Finalize_Address_Ptr;
begin
Lock_Task.all;
Result := Finalize_Address_Table.Get (Obj);
Unlock_Task.all;
return Result;
end Finalize_Address;
return Finalize_Address_Table.Get (Obj);
end Finalize_Address_Unprotected;
--------------------------
-- Finalization_Started --
@ -463,36 +504,40 @@ package body System.Finalization_Masters is
Fin_Addr_Ptr : Finalize_Address_Ptr)
is
begin
-- TSS primitive Finalize_Address is set at the point of allocation,
-- either through Allocate_Any_Controlled or through this routine.
-- Since multiple tasks can allocate on the same finalization master,
-- access to this attribute must be protected.
-- Synchronization:
-- Read - finalization
-- Write - allocation, outside
Lock_Task.all;
if Master.Finalize_Address = null then
Master.Finalize_Address := Fin_Addr_Ptr;
end if;
Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
Unlock_Task.all;
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;
Fin_Addr_Ptr : Finalize_Address_Ptr)
is
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);
Unlock_Task.all;
end Set_Heterogeneous_Finalize_Address;
end Set_Heterogeneous_Finalize_Address_Unprotected;
--------------------------
-- Set_Is_Heterogeneous --
@ -500,7 +545,13 @@ package body System.Finalization_Masters is
procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
begin
-- Synchronization:
-- Read - finalization
-- Write - outside
Lock_Task.all;
Master.Is_Homogeneous := False;
Unlock_Task.all;
end Set_Is_Heterogeneous;
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;
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
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
-- hash table.
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
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
-- a master.
function Finalize_Address
function Finalize_Address_Unprotected
(Obj : System.Address) return Finalize_Address_Ptr;
-- Retrieve the Finalize_Address primitive associated with a particular
-- object.
@ -119,9 +129,15 @@ package System.Finalization_Masters is
procedure Set_Finalize_Address
(Master : in out Finalization_Master;
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
procedure Set_Heterogeneous_Finalize_Address
procedure Set_Heterogeneous_Finalize_Address_Unprotected
(Obj : System.Address;
Fin_Addr_Ptr : Finalize_Address_Ptr);
-- 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.
Finalization_Started : Boolean := False;
pragma Atomic (Finalization_Started);
-- A flag used to detect allocations which occur during the finalization
-- of a master. The allocations must raise Program_Error. This scenario
-- may arise in a multitask environment. The flag is atomic because it
-- is accessed without Lock_Task / Unlock_Task.
-- may arise in a multitask environment.
end record;
-- 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;
Subpool : Subpool_Handle := null;
Allocation_Locked : Boolean;
-- This flag stores the state of the associated collection
Header_And_Padding : Storage_Offset;
-- This offset includes the size of a FM_Node plus any additional
-- 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.
if Context_Master = null then
raise Program_Error with "missing master in pool allocation";
end if;
raise Program_Error
with "missing master in pool allocation";
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
if Context_Subpool /= null then
raise Program_Error with "subpool not required in pool allocation";
end if;
elsif Context_Subpool /= null then
raise Program_Error
with "subpool not required in pool allocation";
-- 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
-- erroneous end-user code.
if On_Subpool then
elsif On_Subpool then
raise Program_Error
with "pool of access type does not support subpools";
end if;
@ -187,10 +190,18 @@ package body System.Storage_Pools.Subpools is
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
-- associated master is being finalized.
if Finalization_Started (Master.all) then
if Allocation_Locked then
raise Program_Error with "allocation after finalization started";
end if;
@ -240,6 +251,7 @@ package body System.Storage_Pools.Subpools is
-- Step 4: Attachment
if Is_Controlled then
Lock_Task.all;
-- 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
@ -262,7 +274,10 @@ package body System.Storage_Pools.Subpools is
-- 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
-- object. This operation effectively hides the list header.
@ -275,8 +290,17 @@ package body System.Storage_Pools.Subpools is
-- 2) Named access types
-- 3) Most cases of anonymous access types usage
-- Synchronization:
-- Read - allocation, finalization
-- Write - outside
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:
@ -284,10 +308,16 @@ package body System.Storage_Pools.Subpools is
-- 2) Certain cases of anonymous access types usage
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;
end if;
Unlock_Task.all;
-- Non-controlled allocation
else
@ -341,12 +371,18 @@ package body System.Storage_Pools.Subpools is
-- Step 1: Detachment
if Is_Controlled then
Lock_Task.all;
-- Destroy the relation pair object - Finalize_Address since it is no
-- longer needed.
if Finalize_Address_Table_In_Use then
Delete_Finalize_Address (Addr);
-- Synchronization:
-- Read - finalization
-- Write - allocation, deallocation
Delete_Finalize_Address_Unprotected (Addr);
end if;
-- 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
-- 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
-- header.
@ -388,6 +427,8 @@ package body System.Storage_Pools.Subpools is
N_Size := Storage_Size + Header_And_Padding;
Unlock_Task.all;
else
N_Addr := Addr;
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
-- is true for three reasons:
-- A size clause may affect the fudging 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
-- A size clause may affect the fudging 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.
-- This means that the actual end-points must be established at the point
-- when the type is frozen. Meanwhile, we first narrow the range as
-- permitted (so that it will fit if necessary in a small specified size),
-- and then build a range subtree with these narrowed bounds.
-- Set_Fixed_Range constructs the range from real literal values, and sets
-- the range as the Scalar_Range of the given fixed-point type entity.
-- This means that the actual end-points must be established at the
-- point when the type is frozen. Meanwhile, we first narrow the range
-- as permitted (so that it will fit if necessary in a small specified
-- size), and then build a range subtree with these narrowed bounds.
-- Set_Fixed_Range constructs the range from real literal values, and
-- sets 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
-- properly hooked into the tree (unlike normal Scalar_Range entries for
@ -19605,6 +19604,12 @@ package body Sem_Ch3 is
begin
Set_Scalar_Range (E, S);
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;
----------------------------------

67
gcc/ada/sem_eval.adb
View File

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