Skip to content

R
riscv-gcc-1
Commit 1c7717c3 by Arnaud Charlet
Options

2008-08-22 Robert Dewar <dewar@adacore.com> 

	* checks.adb:
	(In_Subrange_Of): New calling sequence
	(Determine_Range): Prepare for new processing using base type

	* exp_ch4.adb:
	(Compile_Time_Compare): Use new calling sequence

	* exp_ch5.adb:
	(Compile_Time_Compare): Use new calling sequence

	* sem_eval.adb:
	(Compile_Time_Compare): New calling sequence allows dealing with
	invalid values.
	(In_Subrange_Of): Ditto

	* sem_eval.ads:
	(Compile_Time_Compare): New calling sequence allows dealing with
	invalid values.
	(In_Subrange_Of): Ditto

From-SVN: r139467
parent 23922a2f
Showing with 167 additions and 38 deletions
gcc/ada/ChangeLog
2008-08-22 Doug Rupp <rupp@adacore.com>
* bindgen.adb [VMS] (Gen_Adainit_Ada, Gen_Adainit_C): Import and call
__gnat_set_features.
* init.c
(__gnat_set_features): New function.
(__gnat_features_set): New tracking variable.
(__gl_no_malloc_64): New feature global variable
2008-08-22 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Use_One_Type): Do not emit warning message about redundant
use_type_clause in an instance.
2008-08-22 Bob Duff <duff@adacore.com>
* exp_ch6.ads: Remove pragma Precondition, since it breaks some builds.
2008-08-22 Robert Dewar <dewar@adacore.com>
* exp_ch6.adb: Minor reformatting
* exp_ch7.adb: Minor reformatting
* exp_ch7.ads: Put routines in proper alpha order
* exp_dist.adb: Minor reformatting
2008-08-22 Vincent Celier <celier@adacore.com>
* prj.ads: Minor comment update
2008-08-22 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb (One_Bound): Fix latent bug involving secondary stack
2008-08-22 Ed Schonberg <schonberg@adacore.com>
* exp_tss.adb:
(Base_Init_Proc): For a protected subtype, use the base type of the
corresponding record to locate the propoer initialization procedure.
2008-08-22 Robert Dewar <dewar@adacore.com>
* checks.adb:
(In_Subrange_Of): New calling sequence
(Determine_Range): Prepare for new processing using base type
* exp_ch4.adb:
(Compile_Time_Compare): Use new calling sequence
* exp_ch5.adb:
(Compile_Time_Compare): Use new calling sequence
* sem_eval.adb:
(Compile_Time_Compare): New calling sequence allows dealing with
invalid values.
(In_Subrange_Of): Ditto
* sem_eval.ads:
(Compile_Time_Compare): New calling sequence allows dealing with
invalid values.
(In_Subrange_Of): Ditto
2008-08-22 Pascal Obry <obry@adacore.com>
* adaint.c: Fix possible race condition on win32_wait().
2008-08-22 Bob Duff <duff@adacore.com>
* exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, exp_util.adb, freeze.adb,
gcc/ada/checks.adb
......@@ -2042,7 +2042,9 @@ package body Checks is
and then
Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
and then
(In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
(In_Subrange_Of (S_Typ, Target_Typ,
Assume_Valid => True,
Fixed_Int => Fixed_Int)
or else
Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
then
......@@ -2349,7 +2351,10 @@ package body Checks is
begin
if not Overflow_Checks_Suppressed (Target_Base)
and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
and then not
In_Subrange_Of (Expr_Type, Target_Base,
Assume_Valid => True,
Fixed_Int => Conv_OK)
and then not Float_To_Int
then
Activate_Overflow_Check (N);
......@@ -3021,7 +3026,8 @@ package body Checks is
Lo : out Uint;
Hi : out Uint)
is
Typ : constant Entity_Id := Etype (N);
Typ : Entity_Id := Etype (N);
-- Type to use, may get reset to base type for possibly invalid entity
Lo_Left : Uint;
Hi_Left : Uint;
......@@ -3116,6 +3122,17 @@ package body Checks is
-- overflow situation, which is a separate check, we are talking here
-- only about the expression value).
-- First step, change to use base type if the expression is an entity
-- which we do not know is valid.
-- For now, we do not do this
if False and then Is_Entity_Name (N)
and then not Is_Known_Valid (Entity (N))
then
Typ := Base_Type (Typ);
end if;
-- We use the actual bound unless it is dynamic, in which case use the
-- corresponding base type bound if possible. If we can't get a bound
-- then we figure we can't determine the range (a peculiar case, that
......@@ -4561,7 +4578,7 @@ package body Checks is
-- case the literal has already been labeled as having the subtype of
-- the target.
if In_Subrange_Of (Source_Type, Target_Type)
if In_Subrange_Of (Source_Type, Target_Type, Assume_Valid => True)
and then not
(Nkind (N) = N_Integer_Literal
or else
......@@ -4616,7 +4633,9 @@ package body Checks is
-- The conversions will always work and need no check
elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
elsif In_Subrange_Of
(Target_Type, Source_Base_Type, Assume_Valid => True)
then
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
......@@ -4648,7 +4667,9 @@ package body Checks is
-- If that is the case, we can freely convert the source to the target,
-- and then test the target result against the bounds.
elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
elsif In_Subrange_Of
(Source_Type, Target_Base_Type, Assume_Valid => True)
then
-- We make a temporary to hold the value of the converted value
-- (converted to the base type), and then we will do the test against
......@@ -6811,7 +6832,7 @@ package body Checks is
-- range of the target type.
else
if not In_Subrange_Of (S_Typ, T_Typ) then
if not In_Subrange_Of (S_Typ, T_Typ, Assume_Valid => True) then
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
end if;
end if;
......
gcc/ada/exp_ch4.adb
......@@ -3826,8 +3826,10 @@ package body Exp_Ch4 is
Lo_Orig : constant Node_Id := Original_Node (Lo);
Hi_Orig : constant Node_Id := Original_Node (Hi);
Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo);
Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi);
Lcheck : constant Compare_Result :=
Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
Ucheck : constant Compare_Result :=
Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
Warn1 : constant Boolean :=
Constant_Condition_Warnings
......@@ -9025,7 +9027,8 @@ package body Exp_Ch4 is
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
Res : constant Compare_Result :=
Compile_Time_Compare (Op1, Op2, Assume_Valid => True);
-- Res indicates if compare outcome can be compile time determined
True_Result : Boolean;
......
gcc/ada/exp_ch5.adb
......@@ -614,10 +614,14 @@ package body Exp_Ch5 is
-- or upper bounds at compile time and compare them.
else
Cresult := Compile_Time_Compare (Left_Lo, Right_Lo);
Cresult :=
Compile_Time_Compare
(Left_Lo, Right_Lo, Assume_Valid => True);
if Cresult = Unknown then
Cresult := Compile_Time_Compare (Left_Hi, Right_Hi);
Cresult :=
Compile_Time_Compare
(Left_Hi, Right_Hi, Assume_Valid => True);
end if;
case Cresult is
......
gcc/ada/sem_eval.adb
......@@ -378,11 +378,16 @@ package body Sem_Eval is
--------------------------
function Compile_Time_Compare
(L, R : Node_Id;
Rec : Boolean := False) return Compare_Result
(L, R : Node_Id;
Assume_Valid : Boolean;
Rec : Boolean := False) return Compare_Result
is
Ltyp : constant Entity_Id := Etype (L);
Rtyp : constant Entity_Id := Etype (R);
Ltyp : Entity_Id := Etype (L);
Rtyp : Entity_Id := Etype (R);
-- These get reset to the base type for the case of entities where
-- Is_Known_Valid is not set. This takes care of handling possible
-- invalid representations using the value of the base type, in
-- accordance with RM 13.9.1(10).
procedure Compare_Decompose
(N : Node_Id;
......@@ -739,6 +744,20 @@ package body Sem_Eval is
return Unknown;
end if;
-- Replace types by base types for the case of entities which are
-- not known to have valid representations. This takes care of
-- properly dealing with invalid representations.
if not Assume_Valid then
if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
Ltyp := Base_Type (Ltyp);
end if;
if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
Rtyp := Base_Type (Rtyp);
end if;
end if;
-- Here is where we check for comparisons against maximum bounds of
-- types, where we know that no value can be outside the bounds of
-- the subtype. Note that this routine is allowed to assume that all
......@@ -758,28 +777,32 @@ package body Sem_Eval is
-- See if we can get a decisive check against one operand and
-- a bound of the other operand (four possible tests here).
case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is
case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
Assume_Valid, Rec => True) is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
when others => null;
end case;
case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is
case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
Assume_Valid, Rec => True) is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
when others => null;
end case;
case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is
case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
Assume_Valid, Rec => True) is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
when others => null;
end case;
case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is
case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
Assume_Valid, Rec => True) is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
......@@ -3485,9 +3508,10 @@ package body Sem_Eval is
--------------------
function In_Subrange_Of
(T1 : Entity_Id;
T2 : Entity_Id;
Fixed_Int : Boolean := False) return Boolean
(T1 : Entity_Id;
T2 : Entity_Id;
Assume_Valid : Boolean;
Fixed_Int : Boolean := False) return Boolean
is
L1 : Node_Id;
H1 : Node_Id;
......@@ -3514,9 +3538,9 @@ package body Sem_Eval is
-- Check bounds to see if comparison possible at compile time
if Compile_Time_Compare (L1, L2) in Compare_GE
if Compile_Time_Compare (L1, L2, Assume_Valid) in Compare_GE
and then
Compile_Time_Compare (H1, H2) in Compare_LE
Compile_Time_Compare (H1, H2, Assume_Valid) in Compare_LE
then
return True;
end if;
......@@ -3766,10 +3790,10 @@ package body Sem_Eval is
---------------------
function Is_Out_Of_Range
(N : Node_Id;
Typ : Entity_Id;
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
(N : Node_Id;
Typ : Entity_Id;
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
is
Val : Uint;
Valr : Ureal;
......
gcc/ada/sem_eval.ads
......@@ -133,16 +133,21 @@ package Sem_Eval is
subtype Compare_GE is Compare_Result range EQ .. GE;
subtype Compare_LE is Compare_Result range LT .. EQ;
function Compile_Time_Compare
(L, R : Node_Id;
Rec : Boolean := False) return Compare_Result;
(L, R : Node_Id;
Assume_Valid : Boolean;
Rec : Boolean := False) return Compare_Result;
-- Given two expression nodes, finds out whether it can be determined at
-- compile time how the runtime values will compare. An Unknown result
-- means that the result of a comparison cannot be determined at compile
-- time, otherwise the returned result indicates the known result of the
-- comparison, given as tightly as possible (i.e. EQ or LT is preferred
-- returned value to LE). Rec is a parameter that is set True for a
-- recursive call from within Compile_Time_Compare to avoid some infinite
-- recursion cases. It should never be set by a client.
-- returned value to LE). If Assume_Valid is true, the result reflects
-- the result of assuming that entities involved in the comparison have
-- valid representations. If Assume_Valid is false, then the base type of
-- any involved entity is used so that no assumption of validity is made.
-- Rec is a parameter that is set True for a recursive call from within
-- Compile_Time_Compare to avoid some infinite recursion cases. It should
-- never be set by a client.
procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
-- This procedure is called after it has been determined that Expr is not
......@@ -357,14 +362,17 @@ package Sem_Eval is
-- and Fixed_Int are used as in routine Is_In_Range above.
function In_Subrange_Of
(T1 : Entity_Id;
T2 : Entity_Id;
Fixed_Int : Boolean := False) return Boolean;
(T1 : Entity_Id;
T2 : Entity_Id;
Assume_Valid : Boolean;
Fixed_Int : Boolean := False) return Boolean;
-- Returns True if it can be guaranteed at compile time that the range of
-- values for scalar type T1 are always in the range of scalar type T2. A
-- result of False does not mean that T1 is not in T2's subrange, only that
-- it cannot be determined at compile time. Flag Fixed_Int is used as in
-- routine Is_In_Range above.
-- routine Is_In_Range above. If Assume_Valid is true, the result reflects
-- the result of assuming that entities involved in the comparison have
-- valid representations.
function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is a null range. If it
......
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