+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,
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
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);
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;
-- 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
-- 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
-- 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 =>
-- 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
-- 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;
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
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;
-- 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
--------------------------
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;
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
-- 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;
--------------------
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;
-- 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;
---------------------
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;
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
-- 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
projects / platform / upstream / gcc.git / commitdiff