diff options
Diffstat (limited to 'gcc/ada/exp_ch4.adb')
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 108 |
1 files changed, 78 insertions, 30 deletions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 798da67036e..2f95a84207d 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -944,6 +944,11 @@ package body Exp_Ch4 is Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); + elsif Is_Access_Type (T) + and then Can_Never_Be_Null (T) + then + Install_Null_Excluding_Check (Exp); + elsif Is_Access_Type (DesigT) and then Nkind (Exp) = N_Allocator and then Nkind (Expression (Exp)) /= N_Qualified_Expression @@ -977,8 +982,7 @@ package body Exp_Ch4 is -- not allow sliding, but this check does (a relaxation from Ada 83). if Is_Constrained (DesigT) - and then not Subtypes_Statically_Match - (T, DesigT) + and then not Subtypes_Statically_Match (T, DesigT) then Apply_Constraint_Check (Exp, DesigT, No_Sliding => False); @@ -2637,7 +2641,7 @@ package body Exp_Ch4 is New_Reference_To (Ind_Typ, Loc), New_Reference_To (Defining_Identifier (I_Decl), Loc))); - -- For other index types, computation is safe. + -- For other index types, computation is safe else H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos)); @@ -2668,7 +2672,7 @@ package body Exp_Ch4 is Declare_Decls := New_List (P_Decl, H_Decl, R_Decl); - -- Add constraint check for the modular index case. + -- Add constraint check for the modular index case if Is_Modular_Integer_Type (Ind_Typ) and then Esize (Ind_Typ) < Esize (Standard_Integer) @@ -3440,7 +3444,8 @@ package body Exp_Ch4 is and then Ekind (Etype (Nod)) = E_Anonymous_Access_Type then - Apply_Accessibility_Check (Nod, Typ); + Apply_Accessibility_Check + (Nod, Typ, Insert_Node => Nod); end if; Next_Elmt (Discr); @@ -3873,6 +3878,12 @@ package body Exp_Ch4 is and then Compile_Time_Known_Value (Hi) and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) + + -- Kill warnings in instances, since they may be cases where we + -- have a test in the generic that makes sense with some types + -- and not with other types. + + and then not In_Instance then Substitute_Valid_Check; return; @@ -3886,7 +3897,7 @@ package body Exp_Ch4 is -- legality checks, because we are constant-folding beyond RM 4.9. if Lcheck = LT or else Ucheck = GT then - if Warn1 then + if Warn1 and then not In_Instance then Error_Msg_N ("?range test optimized away", N); Error_Msg_N ("\?value is known to be out of range", N); end if; @@ -3902,7 +3913,7 @@ package body Exp_Ch4 is -- since we know we are in range. elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then - if Warn1 then + if Warn1 and then not In_Instance then Error_Msg_N ("?range test optimized away", N); Error_Msg_N ("\?value is known to be in range", N); end if; @@ -3919,7 +3930,7 @@ package body Exp_Ch4 is -- a comparison against the upper bound. elsif Lcheck in Compare_GE then - if Warn2 then + if Warn2 and then not In_Instance then Error_Msg_N ("?lower bound test optimized away", Lo); Error_Msg_N ("\?value is known to be in range", Lo); end if; @@ -3937,7 +3948,7 @@ package body Exp_Ch4 is -- a comparison against the lower bound. elsif Ucheck in Compare_LE then - if Warn2 then + if Warn2 and then not In_Instance then Error_Msg_N ("?upper bound test optimized away", Hi); Error_Msg_N ("\?value is known to be in range", Hi); end if; @@ -5460,6 +5471,13 @@ package body Exp_Ch4 is -- X ** 0 = 1 (or 1.0) if Expv = 0 then + + -- Call Remove_Side_Effects to ensure that any side effects + -- in the ignored left operand (in particular function calls + -- to user defined functions) are properly executed. + + Remove_Side_Effects (Base); + if Ekind (Typ) in Integer_Kind then Xnode := Make_Integer_Literal (Loc, Intval => 1); else @@ -5934,6 +5952,12 @@ package body Exp_Ch4 is and then Compile_Time_Known_Value (Right) and then Expr_Value (Right) = Uint_1 then + -- Call Remove_Side_Effects to ensure that any side effects in + -- the ignored left operand (in particular function calls to + -- user defined functions) are properly executed. + + Remove_Side_Effects (Left); + Rewrite (N, Make_Integer_Literal (Loc, 0)); Analyze_And_Resolve (N, Typ); return; @@ -5982,17 +6006,17 @@ package body Exp_Ch4 is -------------------------- procedure Expand_N_Op_Multiply (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Lop : constant Node_Id := Left_Opnd (N); - Rop : constant Node_Id := Right_Opnd (N); + Loc : constant Source_Ptr := Sloc (N); + Lop : constant Node_Id := Left_Opnd (N); + Rop : constant Node_Id := Right_Opnd (N); - Lp2 : constant Boolean := - Nkind (Lop) = N_Op_Expon - and then Is_Power_Of_2_For_Shift (Lop); + Lp2 : constant Boolean := + Nkind (Lop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Lop); - Rp2 : constant Boolean := - Nkind (Rop) = N_Op_Expon - and then Is_Power_Of_2_For_Shift (Rop); + Rp2 : constant Boolean := + Nkind (Rop) = N_Op_Expon + and then Is_Power_Of_2_For_Shift (Rop); Ltyp : constant Entity_Id := Etype (Lop); Rtyp : constant Entity_Id := Etype (Rop); @@ -6005,14 +6029,28 @@ package body Exp_Ch4 is if Is_Integer_Type (Typ) then - -- N * 0 = 0 * N = 0 for integer types + -- N * 0 = 0 for integer types - if (Compile_Time_Known_Value (Rop) - and then Expr_Value (Rop) = Uint_0) - or else - (Compile_Time_Known_Value (Lop) - and then Expr_Value (Lop) = Uint_0) + if Compile_Time_Known_Value (Rop) + and then Expr_Value (Rop) = Uint_0 + then + -- Call Remove_Side_Effects to ensure that any side effects in + -- the ignored left operand (in particular function calls to + -- user defined functions) are properly executed. + + Remove_Side_Effects (Lop); + + Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); + Analyze_And_Resolve (N, Typ); + return; + end if; + + -- Similar handling for 0 * N = 0 + + if Compile_Time_Known_Value (Lop) + and then Expr_Value (Lop) = Uint_0 then + Remove_Side_Effects (Rop); Rewrite (N, Make_Integer_Literal (Loc, Uint_0)); Analyze_And_Resolve (N, Typ); return; @@ -6491,6 +6529,12 @@ package body Exp_Ch4 is and then Compile_Time_Known_Value (Right) and then Expr_Value (Right) = Uint_1 then + -- Call Remove_Side_Effects to ensure that any side effects in the + -- ignored left operand (in particular function calls to user defined + -- functions) are properly executed. + + Remove_Side_Effects (Left); + Rewrite (N, Make_Integer_Literal (Loc, 0)); Analyze_And_Resolve (N, Typ); return; @@ -7552,9 +7596,9 @@ package body Exp_Ch4 is -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was - -- expanded from an unchecked or unrestricted access attribute. Note - -- that other checks may still need to be applied below (such as - -- tagged type checks). + -- expanded from an Unchecked_ or Unrestricted_Access attribute. + -- Note that other checks may still need to be applied below (such + -- as tagged type checks). if Is_Entity_Name (Operand) and then @@ -7568,9 +7612,10 @@ package body Exp_Ch4 is and then (Nkind (Original_Node (N)) /= N_Attribute_Reference or else Attribute_Name (Original_Node (N)) = Name_Access) then - Apply_Accessibility_Check (Operand, Target_Type); + Apply_Accessibility_Check + (Operand, Target_Type, Insert_Node => Operand); - -- If the level of the operand type is statically deeper then the + -- If the level of the operand type is statically deeper than the -- level of the target type, then force Program_Error. Note that this -- can only occur for cases where the attribute is within the body of -- an instantiation (otherwise the conversion will already have been @@ -8352,7 +8397,9 @@ package body Exp_Ch4 is -- chain. The Final_Chain that is thus created is shared by the -- access parameter. The access type is tested against the result -- type of the function to exclude allocators whose type is an - -- anonymous access result type. + -- anonymous access result type. We freeze the type at once to + -- ensure that it is properly decorated for the back-end, even + -- if the context and current scope is a loop. if Nkind (Associated_Node_For_Itype (PtrT)) in N_Subprogram_Specification @@ -8369,6 +8416,7 @@ package body Exp_Ch4 is Subtype_Indication => New_Occurrence_Of (T, Loc)))); + Freeze_Before (N, Owner); Build_Final_List (N, Owner); Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); |