Commit b887f1a0 by Arnaud Charlet

[multiple changes]

2012-11-06  Geert Bosch  <bosch@adacore.com>

	* eval_fat.adb (Machine, Succ): Fix front end to support static
	evaluation of attributes on targets with both VAX and IEEE float.
	* sem_util.ads, sem_util.adb (Has_Denormals, Has_Signed_Zeros):
	New type-specific functions. Previously we used Denorm_On_Target
	and Signed_Zeros_On_Target directly, but that doesn't work well
	for OpenVMS where a single target supports both floating point
	with and without signed zeros.
	* sem_attr.adb (Attribute_Denorm, Attribute_Signed_Zeros): Use
	new Has_Denormals and Has_Signed_Zeros functions to support both
	IEEE and VAX floating point on a single target.

2012-11-06  Tristan Gingold  <gingold@adacore.com>

	* bindgen.adb (System_Interrupts_Used): New variable.
	(Gen_Adainit): Declare and call
	Install_Restricted_Handlers_Sequential if System.Interrupts is
	used when elaboration policy is sequential.

2012-11-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb: Complete previous change.

From-SVN: r193225
parent 436d9f92
2012-11-06 Geert Bosch <bosch@adacore.com>
* eval_fat.adb (Machine, Succ): Fix front end to support static
evaluation of attributes on targets with both VAX and IEEE float.
* sem_util.ads, sem_util.adb (Has_Denormals, Has_Signed_Zeros):
New type-specific functions. Previously we used Denorm_On_Target
and Signed_Zeros_On_Target directly, but that doesn't work well
for OpenVMS where a single target supports both floating point
with and without signed zeros.
* sem_attr.adb (Attribute_Denorm, Attribute_Signed_Zeros): Use
new Has_Denormals and Has_Signed_Zeros functions to support both
IEEE and VAX floating point on a single target.
2012-11-06 Tristan Gingold <gingold@adacore.com>
* bindgen.adb (System_Interrupts_Used): New variable.
(Gen_Adainit): Declare and call
Install_Restricted_Handlers_Sequential if System.Interrupts is
used when elaboration policy is sequential.
2012-11-06 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb: Complete previous change.
2012-11-06 Tristan Gingold <gingold@adacore.com> 2012-11-06 Tristan Gingold <gingold@adacore.com>
* fe.h (Get_Vax_Real_Literal_As_Signed): Declare. * fe.h (Get_Vax_Real_Literal_As_Signed): Declare.
......
...@@ -82,7 +82,13 @@ package body Bindgen is ...@@ -82,7 +82,13 @@ package body Bindgen is
-- Flag indicating whether the unit System.Tasking.Restricted.Stages is in -- Flag indicating whether the unit System.Tasking.Restricted.Stages is in
-- the closure of the partition. This is set by Resolve_Binder_Options, -- the closure of the partition. This is set by Resolve_Binder_Options,
-- and it used to call a routine to active all the tasks at the end of -- and it used to call a routine to active all the tasks at the end of
-- the elaboration. -- the elaboration when partition elaboration policy is sequential.
System_Interrupts_Used : Boolean := False;
-- Flag indicating whether the unit System.Interrups is in the closure of
-- the partition. This is set by Resolve_Binder_Options, and it used to
-- attach interrupt handlers at the end of the elaboration when partition
-- elaboration policy is sequential.
Lib_Final_Built : Boolean := False; Lib_Final_Built : Boolean := False;
-- Flag indicating whether the finalize_library rountine has been built -- Flag indicating whether the finalize_library rountine has been built
...@@ -488,6 +494,16 @@ package body Bindgen is ...@@ -488,6 +494,16 @@ package body Bindgen is
WBI (""); WBI ("");
end if; end if;
if System_Interrupts_Used
and then Partition_Elaboration_Policy_Specified = 'S'
then
WBI (" procedure Install_Restricted_Handlers_Sequential;");
WBI (" pragma Import (C,"
& "Install_Restricted_Handlers_Sequential," &
" ""__gnat_attach_all_handlers"");");
WBI ("");
end if;
if System_Tasking_Restricted_Stages_Used if System_Tasking_Restricted_Stages_Used
and then Partition_Elaboration_Policy_Specified = 'S' and then Partition_Elaboration_Policy_Specified = 'S'
then then
...@@ -601,7 +617,21 @@ package body Bindgen is ...@@ -601,7 +617,21 @@ package body Bindgen is
WBI (" pragma Import (C, Handler_Installed, " & WBI (" pragma Import (C, Handler_Installed, " &
"""__gnat_handler_installed"");"); """__gnat_handler_installed"");");
-- Import task activation procedure for ravenscar -- Import handlers attach procedure for sequential elaboration
-- policy.
if System_Interrupts_Used
and then Partition_Elaboration_Policy_Specified = 'S'
then
WBI (" procedure Install_Restricted_Handlers_Sequential;");
WBI (" pragma Import (C,"
& "Install_Restricted_Handlers_Sequential," &
" ""__gnat_attach_all_handlers"");");
WBI ("");
end if;
-- Import task activation procedure for sequential elaboration
-- policy.
if System_Tasking_Restricted_Stages_Used if System_Tasking_Restricted_Stages_Used
and then Partition_Elaboration_Policy_Specified = 'S' and then Partition_Elaboration_Policy_Specified = 'S'
...@@ -944,10 +974,16 @@ package body Bindgen is ...@@ -944,10 +974,16 @@ package body Bindgen is
WBI (" Freeze_Dispatching_Domains;"); WBI (" Freeze_Dispatching_Domains;");
end if; end if;
if System_Tasking_Restricted_Stages_Used -- Sequential partition elaboration policy
and then Partition_Elaboration_Policy_Specified = 'S'
then if Partition_Elaboration_Policy_Specified = 'S' then
WBI (" Activate_All_Tasks_Sequential;"); if System_Interrupts_Used then
WBI (" Install_Restricted_Handlers_Sequential;");
end if;
if System_Tasking_Restricted_Stages_Used then
WBI (" Activate_All_Tasks_Sequential;");
end if;
end if; end if;
-- Case of main program is CIL function or procedure -- Case of main program is CIL function or procedure
...@@ -2896,6 +2932,10 @@ package body Bindgen is ...@@ -2896,6 +2932,10 @@ package body Bindgen is
(System_Tasking_Restricted_Stages_Used, (System_Tasking_Restricted_Stages_Used,
"system.tasking.restricted.stages%s"); "system.tasking.restricted.stages%s");
-- Ditto for the use of interrupts
Check_Package (System_Interrupts_Used, "system.interrupts%s");
-- Ditto for the use of dispatching domains -- Ditto for the use of dispatching domains
Check_Package Check_Package
......
...@@ -25,7 +25,7 @@ ...@@ -25,7 +25,7 @@
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Targparm; use Targparm; with Sem_Util; use Sem_Util;
package body Eval_Fat is package body Eval_Fat is
...@@ -505,8 +505,8 @@ package body Eval_Fat is ...@@ -505,8 +505,8 @@ package body Eval_Fat is
Emin_Den : constant UI := Machine_Emin_Value (RT) Emin_Den : constant UI := Machine_Emin_Value (RT)
- Machine_Mantissa_Value (RT) + Uint_1; - Machine_Mantissa_Value (RT) + Uint_1;
begin begin
if X_Exp < Emin_Den or not Denorm_On_Target then if X_Exp < Emin_Den or not Has_Denormals (RT) then
if Signed_Zeros_On_Target and then UR_Is_Negative (X) then if Has_Signed_Zeros (RT) and then UR_Is_Negative (X) then
Error_Msg_N Error_Msg_N
("floating-point value underflows to -0.0?", Enode); ("floating-point value underflows to -0.0?", Enode);
return Ureal_M_0; return Ureal_M_0;
...@@ -517,7 +517,7 @@ package body Eval_Fat is ...@@ -517,7 +517,7 @@ package body Eval_Fat is
return Ureal_0; return Ureal_0;
end if; end if;
elsif Denorm_On_Target then elsif Has_Denormals (RT) then
-- Emin - Mant <= X_Exp < Emin, so result is denormal. Handle -- Emin - Mant <= X_Exp < Emin, so result is denormal. Handle
-- gradual underflow by first computing the number of -- gradual underflow by first computing the number of
...@@ -718,7 +718,7 @@ package body Eval_Fat is ...@@ -718,7 +718,7 @@ package body Eval_Fat is
-- Set exponent such that the radix point will be directly following the -- Set exponent such that the radix point will be directly following the
-- mantissa after scaling. -- mantissa after scaling.
if Denorm_On_Target or Exp /= Emin then if Has_Denormals (RT) or Exp /= Emin then
Exp := Exp - Mantissa; Exp := Exp - Mantissa;
else else
Exp := Exp - 1; Exp := Exp - 1;
......
...@@ -6517,7 +6517,7 @@ package body Sem_Attr is ...@@ -6517,7 +6517,7 @@ package body Sem_Attr is
when Attribute_Denorm => when Attribute_Denorm =>
Fold_Uint Fold_Uint
(N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True); (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), True);
--------------------- ---------------------
-- Descriptor_Size -- -- Descriptor_Size --
...@@ -7631,7 +7631,7 @@ package body Sem_Attr is ...@@ -7631,7 +7631,7 @@ package body Sem_Attr is
when Attribute_Signed_Zeros => when Attribute_Signed_Zeros =>
Fold_Uint Fold_Uint
(N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static); (N, UI_From_Int (Boolean'Pos (Has_Signed_Zeros (P_Type))), Static);
---------- ----------
-- Size -- -- Size --
......
...@@ -709,6 +709,7 @@ package body Sem_Ch8 is ...@@ -709,6 +709,7 @@ package body Sem_Ch8 is
------------------------------ ------------------------------
procedure Check_Constrained_Object is procedure Check_Constrained_Object is
Typ : constant Entity_Id := Etype (Nam);
Subt : Entity_Id; Subt : Entity_Id;
begin begin
...@@ -728,16 +729,20 @@ package body Sem_Ch8 is ...@@ -728,16 +729,20 @@ package body Sem_Ch8 is
-- A renaming of an unchecked union does not have an -- A renaming of an unchecked union does not have an
-- actual subtype. -- actual subtype.
elsif Is_Unchecked_Union (Etype (Nam)) then elsif Is_Unchecked_Union (Typ) then
null; null;
-- If a record is limited its size is invariant. This is the case -- If a record is limited its size is invariant. This is the case
-- in particular with record types with an access discirminant -- in particular with record types with an access discirminant
-- that are used in iterators. This is an optimization, but it -- that are used in iterators. This is an optimization, but it
-- also prevents typing anomalies when the prefix is further -- also prevents typing anomalies when the prefix is further
-- expanded. -- expanded. Limited types with discriminants are included.
elsif Is_Limited_Record (Etype (Nam)) then elsif Is_Limited_Record (Typ)
or else (Ekind (Typ) = E_Limited_Private_Type
and then Has_Discriminants (Typ)
and then Is_Access_Type (Etype (First_Discriminant (Typ))))
then
null; null;
else else
...@@ -747,7 +752,7 @@ package body Sem_Ch8 is ...@@ -747,7 +752,7 @@ package body Sem_Ch8 is
Make_Subtype_Declaration (Loc, Make_Subtype_Declaration (Loc,
Defining_Identifier => Subt, Defining_Identifier => Subt,
Subtype_Indication => Subtype_Indication =>
Make_Subtype_From_Expr (Nam, Etype (Nam)))); Make_Subtype_From_Expr (Nam, Typ)));
Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc)); Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc));
Set_Etype (Nam, Subt); Set_Etype (Nam, Subt);
end if; end if;
......
...@@ -5398,6 +5398,17 @@ package body Sem_Util is ...@@ -5398,6 +5398,17 @@ package body Sem_Util is
N_Package_Specification); N_Package_Specification);
end Has_Declarations; end Has_Declarations;
-------------------
-- Has_Denormals --
-------------------
function Has_Denormals (E : Entity_Id) return Boolean is
begin
return Is_Floating_Point_Type (E)
and then Denorm_On_Target
and then not Vax_Float (E);
end Has_Denormals;
------------------------------------------- -------------------------------------------
-- Has_Discriminant_Dependent_Constraint -- -- Has_Discriminant_Dependent_Constraint --
------------------------------------------- -------------------------------------------
...@@ -6076,6 +6087,17 @@ package body Sem_Util is ...@@ -6076,6 +6087,17 @@ package body Sem_Util is
end if; end if;
end Has_Private_Component; end Has_Private_Component;
----------------------
-- Has_Signed_Zeros --
----------------------
function Has_Signed_Zeros (E : Entity_Id) return Boolean is
begin
return Is_Floating_Point_Type (E)
and then Signed_Zeros_On_Target
and then not Vax_Float (E);
end Has_Signed_Zeros;
----------------------------- -----------------------------
-- Has_Static_Array_Bounds -- -- Has_Static_Array_Bounds --
----------------------------- -----------------------------
......
...@@ -674,6 +674,10 @@ package Sem_Util is ...@@ -674,6 +674,10 @@ package Sem_Util is
function Has_Declarations (N : Node_Id) return Boolean; function Has_Declarations (N : Node_Id) return Boolean;
-- Determines if the node can have declarations -- Determines if the node can have declarations
function Has_Denormals (E : Entity_Id) return Boolean;
-- Determines if the floating-point type E supports denormal numbers.
-- Returns False if E is not a floating-point type.
function Has_Discriminant_Dependent_Constraint function Has_Discriminant_Dependent_Constraint
(Comp : Entity_Id) return Boolean; (Comp : Entity_Id) return Boolean;
-- Returns True if and only if Comp has a constrained subtype that depends -- Returns True if and only if Comp has a constrained subtype that depends
...@@ -708,6 +712,10 @@ package Sem_Util is ...@@ -708,6 +712,10 @@ package Sem_Util is
-- Check if a type has a (sub)component of a private type that has not -- Check if a type has a (sub)component of a private type that has not
-- yet received a full declaration. -- yet received a full declaration.
function Has_Signed_Zeros (E : Entity_Id) return Boolean;
-- Determines if the floating-point type E supports signed zeros.
-- Returns False if E is not a floating-point type.
function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean; function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean;
-- Return whether an array type has static bounds -- Return whether an array type has static bounds
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment