diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 69 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.ads | 26 |
6 files changed, 167 insertions, 38 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1ae24d8238a..187b1494c07 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,72 @@ +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, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 40e3057001f..5dac9262e03 100644 --- a/gcc/ada/checks.adb +++ b/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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 808005474b0..6e763729a46 100644 --- a/gcc/ada/exp_ch4.adb +++ b/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; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 0eb681df408..d1c9d884e95 100644 --- a/gcc/ada/exp_ch5.adb +++ b/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 diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 3e90538c3b6..b9c1d13313c 100644 --- a/gcc/ada/sem_eval.adb +++ b/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; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index ca6a5208b99..f294ed43337 100644 --- a/gcc/ada/sem_eval.ads +++ b/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 |
