diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6305f5dd746..d0ccfb28cdc 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -123,6 +123,9 @@ package body Exp_Ch6 is -- -- For all parameter modes, actuals that denote components and slices -- of packed arrays are expanded into suitable temporaries. + -- + -- For non-scalar objects that are possibly unaligned, add call by copy + -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). procedure Expand_Inlined_Call (N : Node_Id; @@ -501,11 +504,10 @@ package body Exp_Ch6 is -- also takes care of any constraint checks required for the type -- conversion case (on both the way in and the way out). - procedure Add_Packed_Call_By_Copy_Code; - -- This is used when the actual involves a reference to an element - -- of a packed array, where we can appropriately use a simpler - -- approach than the full call by copy code. We just copy the value - -- in and out of an appropriate temporary. + procedure Add_Simple_Call_By_Copy_Code; + -- This is similar to the above, but is used in cases where we know + -- that all that is needed is to simply create a temporary and copy + -- the value in and out of the temporary. procedure Check_Fortran_Logical; -- A value of type Logical that is passed through a formal parameter @@ -532,7 +534,7 @@ package body Exp_Ch6 is Expr : Node_Id; Init : Node_Id; Temp : Entity_Id; - Indic : Node_Id := New_Occurrence_Of (Etype (Formal), Loc); + Indic : Node_Id; Var : Entity_Id; F_Typ : constant Entity_Id := Etype (Formal); V_Typ : Entity_Id; @@ -541,6 +543,17 @@ package body Exp_Ch6 is begin Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + -- Use formal type for temp, unless formal type is an unconstrained + -- array, in which case we don't have to worry about bounds checks, + -- and we use the actual type, since that has appropriate bonds. + + if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then + Indic := New_Occurrence_Of (Etype (Actual), Loc); + else + Indic := New_Occurrence_Of (Etype (Formal), Loc); + end if; + + if Nkind (Actual) = N_Type_Conversion then V_Typ := Etype (Expression (Actual)); @@ -584,7 +597,7 @@ package body Exp_Ch6 is then -- Actual is a one-dimensional array or slice, and the type -- requires no initialization. Create a temporary of the - -- right size, but do copy actual into it (optimization). + -- right size, but do not copy actual into it (optimization). Init := Empty; Indic := @@ -621,11 +634,9 @@ package body Exp_Ch6 is Is_Bit_Packed_Array (Etype (Expression (Actual)))) then if Conversion_OK (Actual) then - Init := - OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + Init := OK_Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); else - Init := - Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); + Init := Convert_To (F_Typ, New_Occurrence_Of (Var, Loc)); end if; elsif Ekind (Formal) = E_In_Parameter then @@ -639,7 +650,7 @@ package body Exp_Ch6 is Make_Object_Declaration (Loc, Defining_Identifier => Temp, Object_Definition => Indic, - Expression => Init); + Expression => Init); Set_Assignment_OK (N_Node); Insert_Action (N, N_Node); @@ -700,21 +711,33 @@ package body Exp_Ch6 is end Add_Call_By_Copy_Code; ---------------------------------- - -- Add_Packed_Call_By_Copy_Code -- + -- Add_Simple_Call_By_Copy_Code -- ---------------------------------- - procedure Add_Packed_Call_By_Copy_Code is + procedure Add_Simple_Call_By_Copy_Code is Temp : Entity_Id; Incod : Node_Id; Outcod : Node_Id; Lhs : Node_Id; Rhs : Node_Id; + Indic : Node_Id; + F_Typ : constant Entity_Id := Etype (Formal); begin - Reset_Packed_Prefix; + -- Use formal type for temp, unless formal type is an unconstrained + -- array, in which case we don't have to worry about bounds checks, + -- and we use the actual type, since that has appropriate bonds. + + if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then + Indic := New_Occurrence_Of (Etype (Actual), Loc); + else + Indic := New_Occurrence_Of (Etype (Formal), Loc); + end if; -- Prepare to generate code + Reset_Packed_Prefix; + Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('T')); Incod := Relocate_Node (Actual); Outcod := New_Copy_Tree (Incod); @@ -729,9 +752,8 @@ package body Exp_Ch6 is Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Temp, - Object_Definition => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => Incod)); + Object_Definition => Indic, + Expression => Incod)); -- The actual is simply a reference to the temporary @@ -754,8 +776,9 @@ package body Exp_Ch6 is Make_Assignment_Statement (Loc, Name => Lhs, Expression => Rhs)); + Set_Assignment_OK (Name (Last (Post_Call))); end if; - end Add_Packed_Call_By_Copy_Code; + end Add_Simple_Call_By_Copy_Code; --------------------------- -- Check_Fortran_Logical -- @@ -930,7 +953,14 @@ package body Exp_Ch6 is -- [in] out parameters. elsif Is_Ref_To_Bit_Packed_Array (Actual) then - Add_Packed_Call_By_Copy_Code; + Add_Simple_Call_By_Copy_Code; + + -- If a non-scalar actual is possibly unaligned, we need a copy + + elsif Is_Possibly_Unaligned_Object (Actual) + and then not Represented_As_Scalar (Etype (Formal)) + then + Add_Simple_Call_By_Copy_Code; -- References to slices of bit packed arrays are expanded @@ -983,7 +1013,7 @@ package body Exp_Ch6 is -- the special processing above for the OUT and IN OUT cases -- could be performed. We could make the test in Exp_Ch4 more -- complex and have it detect the parameter mode, but it is - -- easier simply to handle all cases here. + -- easier simply to handle all cases here.) if Nkind (Actual) = N_Indexed_Component and then Is_Packed (Etype (Prefix (Actual))) @@ -997,7 +1027,14 @@ package body Exp_Ch6 is -- Is this really necessary in all cases??? elsif Is_Ref_To_Bit_Packed_Array (Actual) then - Add_Packed_Call_By_Copy_Code; + Add_Simple_Call_By_Copy_Code; + + -- If a non-scalar actual is possibly unaligned, we need a copy + + elsif Is_Possibly_Unaligned_Object (Actual) + and then not Represented_As_Scalar (Etype (Formal)) + then + Add_Simple_Call_By_Copy_Code; -- Similarly, we have to expand slices of packed arrays here -- because the result must be byte aligned. @@ -1768,13 +1805,10 @@ package body Exp_Ch6 is end loop; end if; - if Ekind (Subp) = E_Procedure - or else (Ekind (Subp) = E_Subprogram_Type - and then Etype (Subp) = Standard_Void_Type) - or else Is_Entry (Subp) - then - Expand_Actuals (N, Subp); - end if; + -- At this point we have all the actuals, so this is the point at + -- which the various expansion activities for actuals is carried out. + + Expand_Actuals (N, Subp); -- If the subprogram is a renaming, or if it is inherited, replace it -- in the call with the name of the actual subprogram being called. @@ -1924,14 +1958,17 @@ package body Exp_Ch6 is Designated_Type (Base_Type (Etype (Ptr))); begin - Obj := Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (T, Ptr), - Selector_Name => New_Occurrence_Of (First_Entity (T), Loc)); + Obj := + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => + New_Occurrence_Of (First_Entity (T), Loc)); - Nam := Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (T, Ptr), - Selector_Name => New_Occurrence_Of ( - Next_Entity (First_Entity (T)), Loc)); + Nam := + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (T, Ptr), + Selector_Name => + New_Occurrence_Of (Next_Entity (First_Entity (T)), Loc)); Nam := Make_Explicit_Dereference (Loc, Nam); @@ -2621,11 +2658,11 @@ package body Exp_Ch6 is -- Start of processing for Expand_Inlined_Call begin - -- Check for special case of To_Address call, and if so, just - -- do an unchecked conversion instead of expanding the call. - -- Not only is this more efficient, but it also avoids a - -- problem with order of elaboration when address clauses - -- are inlined (address expr elaborated at wrong point). + -- Check for special case of To_Address call, and if so, just do an + -- unchecked conversion instead of expanding the call. Not only is this + -- more efficient, but it also avoids problem with order of elaboration + -- when address clauses are inlined (address expr elaborated at wrong + -- point). if Subp = RTE (RE_To_Address) then Rewrite (N, @@ -2635,13 +2672,31 @@ package body Exp_Ch6 is return; end if; + -- Check for an illegal attempt to inline a recursive procedure. If the + -- subprogram has parameters this is detected when trying to supply a + -- binding for parameters that already have one. For parameterless + -- subprograms this must be done explicitly. + + if In_Open_Scopes (Subp) then + Error_Msg_N ("call to recursive subprogram cannot be inlined?", N); + Set_Is_Inlined (Subp, False); + return; + end if; + if Nkind (Orig_Bod) = N_Defining_Identifier then -- Subprogram is a renaming_as_body. Calls appearing after the -- renaming can be replaced with calls to the renamed entity - -- directly, because the subprograms are subtype conformant. + -- directly, because the subprograms are subtype conformant. If + -- the renamed subprogram is an inherited operation, we must redo + -- the expansion because implicit conversions may be needed. Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); + + if Present (Alias (Orig_Bod)) then + Expand_Call (N); + end if; + return; end if; @@ -2685,10 +2740,10 @@ package body Exp_Ch6 is end if; -- If the argument may be a controlling argument in a call within - -- the inlined body, we must preserve its classwide nature to - -- insure that dynamic dispatching take place subsequently. - -- If the formal has a constraint it must be preserved to retain - -- the semantics of the body. + -- the inlined body, we must preserve its classwide nature to insure + -- that dynamic dispatching take place subsequently. If the formal + -- has a constraint it must be preserved to retain the semantics of + -- the body. if Is_Class_Wide_Type (Etype (F)) or else (Is_Access_Type (Etype (F)) @@ -2847,7 +2902,7 @@ package body Exp_Ch6 is end if; -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on - -- conflicting private views that Gigi would ignore. If this is a + -- conflicting private views that Gigi would ignore. If this is -- predefined unit, analyze with checks off, as is done in the non- -- inlined run-time units. @@ -2924,8 +2979,8 @@ package body Exp_Ch6 is elsif Requires_Transient_Scope (Typ) then - -- Verify that the return type of the enclosing function has - -- the same constrained status as that of the expression. + -- Verify that the return type of the enclosing function has the + -- same constrained status as that of the expression. while Ekind (S) /= E_Function loop S := Scope (S); @@ -2968,16 +3023,16 @@ package body Exp_Ch6 is begin -- A special check. If stack checking is enabled, and the return type - -- might generate a large temporary, and the call is not the right - -- side of an assignment, then generate an explicit temporary. We do - -- this because otherwise gigi may generate a large temporary on the - -- fly and this can cause trouble with stack checking. + -- might generate a large temporary, and the call is not the right side + -- of an assignment, then generate an explicit temporary. We do this + -- because otherwise gigi may generate a large temporary on the fly and + -- this can cause trouble with stack checking. -- This is unecessary if the call is the expression in an object - -- declaration, or if it appears outside of any library unit. This - -- can only happen if it appears as an actual in a library-level - -- instance, in which case a temporary will be generated for it once - -- the instance itself is installed. + -- declaration, or if it appears outside of any library unit. This can + -- only happen if it appears as an actual in a library-level instance, + -- in which case a temporary will be generated for it once the instance + -- itself is installed. if May_Generate_Large_Temp (Typ) and then not Rhs_Of_Assign_Or_Decl (N) @@ -2986,10 +3041,10 @@ package body Exp_Ch6 is then if Stack_Checking_Enabled then - -- Note: it might be thought that it would be OK to use a call - -- to Force_Evaluation here, but that's not good enough, because - -- that can results in a 'Reference construct that may still - -- need a temporary. + -- Note: it might be thought that it would be OK to use a call to + -- Force_Evaluation here, but that's not good enough, because + -- that can results in a 'Reference construct that may still need + -- a temporary. declare Loc : constant Source_Ptr := Sloc (N); @@ -3086,9 +3141,9 @@ package body Exp_Ch6 is -- Add poll call if ATC polling is enabled, unless the body will be -- inlined by the back-end. - -- Add return statement if last statement in body is not a return - -- statement (this makes things easier on Gigi which does not want - -- to have to handle a missing return). + -- Add return statement if last statement in body is not a return statement + -- (this makes things easier on Gigi which does not want to have to handle + -- a missing return). -- Add call to Activate_Tasks if body is a task activator diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 1608e437214..a8b010c9a82 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1219,9 +1219,13 @@ package body Exp_Pakd is -- Currently the code in this unit requires that packed arrays -- represented by non-modular arrays of bytes be on a byte - -- boundary. + -- boundary for bit sizes handled by System.Pack_nn units. + -- That's because these units assume the array being accessed + -- starts on a byte boundary. - Set_Must_Be_On_Byte_Boundary (Typ); + if Get_Id (UI_To_Int (Csize)) /= RE_Null then + Set_Must_Be_On_Byte_Boundary (Typ); + end if; end if; end Create_Packed_Array_Type; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 162b939f125..5ef5bae5138 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -29,6 +29,7 @@ with Checks; use Checks; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Exp_Aggr; use Exp_Aggr; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; with Exp_Tss; use Exp_Tss; @@ -2323,50 +2324,135 @@ package body Exp_Util is -- Is_Possibly_Unaligned_Object -- ---------------------------------- - function Is_Possibly_Unaligned_Object (P : Node_Id) return Boolean is + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is + T : constant Entity_Id := Etype (N); + begin - -- If target does not have strict alignment, result is always - -- False, since correctness of code does no depend on alignment. - - if not Target_Strict_Alignment then - return False; - end if; - -- If renamed object, apply test to underlying object - if Is_Entity_Name (P) - and then Is_Object (Entity (P)) - and then Present (Renamed_Object (Entity (P))) + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) then - return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (P))); + return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N))); + end if; + + -- Tagged and controlled types and aliased types are always aligned, + -- as are concurrent types. + + if Is_Aliased (T) + or else Has_Controlled_Component (T) + or else Is_Concurrent_Type (T) + or else Is_Tagged_Type (T) + or else Is_Controlled (T) + then + return False; end if; -- If this is an element of a packed array, may be unaligned - if Is_Ref_To_Bit_Packed_Array (P) then + if Is_Ref_To_Bit_Packed_Array (N) then return True; end if; -- Case of component reference - if Nkind (P) = N_Selected_Component then + if Nkind (N) = N_Selected_Component then + declare + P : constant Node_Id := Prefix (N); + C : constant Entity_Id := Entity (Selector_Name (N)); + M : Nat; + S : Nat; - -- If component reference is for a record that is bit packed - -- or has a specified alignment (that might be too small) or - -- the component reference has a component clause, then the - -- object may be unaligned. + begin + -- If component reference is for an array with non-static bounds, + -- then it is always aligned, we can only unaligned arrays with + -- static bounds (more accurately bounds known at compile time) - if Is_Packed (Etype (Prefix (P))) - or else Known_Alignment (Etype (Prefix (P))) - or else Present (Component_Clause (Entity (Selector_Name (P)))) - then - return True; + if Is_Array_Type (T) + and then not Compile_Time_Known_Bounds (T) + then + return False; + end if; - -- Otherwise, for a component reference, test prefix + -- If component is aliased, it is definitely properly aligned - else - return Is_Possibly_Unaligned_Object (Prefix (P)); - end if; + if Is_Aliased (C) then + return False; + end if; + + -- If component is for a type implemented as a scalar, and the + -- record is packed, and the component is other than the first + -- component of the record, then the component may be unaligned. + + if Is_Packed (Etype (P)) + and then Represented_As_Scalar (Etype (P)) + and then First_Entity (Etype (Entity (P))) /= C + then + return True; + end if; + + -- Compute maximum possible alignment for T + + -- If alignment is known, then that settles things + + if Known_Alignment (T) then + M := UI_To_Int (Alignment (T)); + + -- If alignment is not known, tentatively set max alignment + + else + M := Ttypes.Maximum_Alignment; + + -- We can reduce this if the Esize is known since the default + -- alignment will never be more than the smallest power of 2 + -- that does not exceed this Esize value. + + if Known_Esize (T) then + S := UI_To_Int (Esize (T)); + + while (M / 2) >= S loop + M := M / 2; + end loop; + end if; + end if; + + -- If the component reference is for a record that has a specified + -- alignment, and we either know it is too small, or cannot tell, + -- then the component may be unaligned + + if Known_Alignment (Etype (P)) + and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment + and then M > Alignment (Etype (P)) + then + return True; + end if; + + -- Case of component clause present which may specify an + -- unaligned position. + + if Present (Component_Clause (C)) then + + -- Otherwise we can do a test to make sure that the actual + -- start position in the record, and the length, are both + -- consistent with the required alignment. If not, we know + -- that we are unaligned. + + declare + Align_In_Bits : constant Nat := M * System_Storage_Unit; + begin + if Component_Bit_Offset (C) mod Align_In_Bits /= 0 + or else Esize (C) mod Align_In_Bits /= 0 + then + return True; + end if; + end; + end if; + + -- Otherwise, for a component reference, test prefix + + return Is_Possibly_Unaligned_Object (P); + end; -- If not a component reference, must be aligned @@ -2379,7 +2465,7 @@ package body Exp_Util is -- Is_Possibly_Unaligned_Slice -- --------------------------------- - function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is begin -- ??? GCC3 will eventually handle strings with arbitrary alignments, -- but for now the following check must be disabled. @@ -2390,16 +2476,16 @@ package body Exp_Util is -- For renaming case, go to renamed object - if Is_Entity_Name (P) - and then Is_Object (Entity (P)) - and then Present (Renamed_Object (Entity (P))) + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) then - return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (P))); + return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N))); end if; -- The reference must be a slice - if Nkind (P) /= N_Slice then + if Nkind (N) /= N_Slice then return False; end if; @@ -2407,10 +2493,10 @@ package body Exp_Util is -- component clause, which gigi/gcc does not appear to handle well. -- It is not clear why this special test is needed at all ??? - if Nkind (Prefix (P)) = N_Selected_Component - and then Nkind (Prefix (Prefix (P))) = N_Selected_Component + if Nkind (Prefix (N)) = N_Selected_Component + and then Nkind (Prefix (Prefix (N))) = N_Selected_Component and then - Present (Component_Clause (Entity (Selector_Name (Prefix (P))))) + Present (Component_Clause (Entity (Selector_Name (Prefix (N))))) then return True; end if; @@ -2424,10 +2510,10 @@ package body Exp_Util is -- If it is a slice, then look at the array type being sliced declare - Sarr : constant Node_Id := Prefix (P); + Sarr : constant Node_Id := Prefix (N); -- Prefix of the slice, i.e. the array being sliced - Styp : constant Entity_Id := Etype (Prefix (P)); + Styp : constant Entity_Id := Etype (Prefix (N)); -- Type of the array being sliced Pref : Node_Id; @@ -2519,30 +2605,30 @@ package body Exp_Util is -- Is_Ref_To_Bit_Packed_Array -- -------------------------------- - function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is Result : Boolean; Expr : Node_Id; begin - if Is_Entity_Name (P) - and then Is_Object (Entity (P)) - and then Present (Renamed_Object (Entity (P))) + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) then - return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (P))); + return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N))); end if; - if Nkind (P) = N_Indexed_Component + if Nkind (N) = N_Indexed_Component or else - Nkind (P) = N_Selected_Component + Nkind (N) = N_Selected_Component then - if Is_Bit_Packed_Array (Etype (Prefix (P))) then + if Is_Bit_Packed_Array (Etype (Prefix (N))) then Result := True; else - Result := Is_Ref_To_Bit_Packed_Array (Prefix (P)); + Result := Is_Ref_To_Bit_Packed_Array (Prefix (N)); end if; - if Result and then Nkind (P) = N_Indexed_Component then - Expr := First (Expressions (P)); + if Result and then Nkind (N) = N_Indexed_Component then + Expr := First (Expressions (N)); while Present (Expr) loop Force_Evaluation (Expr); Next (Expr); @@ -2560,25 +2646,25 @@ package body Exp_Util is -- Is_Ref_To_Bit_Packed_Slice -- -------------------------------- - function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is + function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is begin - if Is_Entity_Name (P) - and then Is_Object (Entity (P)) - and then Present (Renamed_Object (Entity (P))) + if Is_Entity_Name (N) + and then Is_Object (Entity (N)) + and then Present (Renamed_Object (Entity (N))) then - return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (P))); + return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N))); end if; - if Nkind (P) = N_Slice - and then Is_Bit_Packed_Array (Etype (Prefix (P))) + if Nkind (N) = N_Slice + and then Is_Bit_Packed_Array (Etype (Prefix (N))) then return True; - elsif Nkind (P) = N_Indexed_Component + elsif Nkind (N) = N_Indexed_Component or else - Nkind (P) = N_Selected_Component + Nkind (N) = N_Selected_Component then - return Is_Ref_To_Bit_Packed_Slice (Prefix (P)); + return Is_Ref_To_Bit_Packed_Slice (Prefix (N)); else return False; @@ -2646,6 +2732,22 @@ package body Exp_Util is Set_Is_Eliminated (Defining_Entity (N)); end if; + elsif Nkind (N) = N_Package_Declaration then + Kill_Dead_Code (Visible_Declarations (Specification (N))); + Kill_Dead_Code (Private_Declarations (Specification (N))); + + declare + E : Entity_Id := First_Entity (Defining_Entity (N)); + begin + while Present (E) loop + if Ekind (E) = E_Operator then + Set_Is_Eliminated (E); + end if; + + Next_Entity (E); + end loop; + end; + -- Recurse into composite statement to kill individual statements, -- in particular instantiations. @@ -3706,8 +3808,22 @@ package body Exp_Util is New_Exp := Make_Reference (Loc, E); end if; - if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then - Set_Expansion_Delayed (E, False); + if Is_Delayed_Aggregate (E) then + + -- The expansion of nested aggregates is delayed until the + -- enclosing aggregate is expanded. As aggregates are often + -- qualified, the predicate applies to qualified expressions + -- as well, indicating that the enclosing aggregate has not + -- been expanded yet. At this point the aggregate is part of + -- a stand-alone declaration, and must be fully expanded. + + if Nkind (E) = N_Qualified_Expression then + Set_Expansion_Delayed (Expression (E), False); + Set_Analyzed (Expression (E), False); + else + Set_Expansion_Delayed (E, False); + end if; + Set_Analyzed (E, False); end if; @@ -3731,6 +3847,18 @@ package body Exp_Util is Scope_Suppress := Svg_Suppress; end Remove_Side_Effects; + --------------------------- + -- Represented_As_Scalar -- + --------------------------- + + function Represented_As_Scalar (T : Entity_Id) return Boolean is + UT : constant Entity_Id := Underlying_Type (T); + begin + return Is_Scalar_Type (UT) + or else (Is_Bit_Packed_Array (UT) + and then Is_Scalar_Type (Packed_Array_Type (UT))); + end Represented_As_Scalar; + ------------------------------------ -- Safe_Unchecked_Type_Conversion -- ------------------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index f75038cbdc5..da3b1335b7d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -417,7 +417,7 @@ package Exp_Util is -- nodes. False otherwise. True for an empty list. It is an error -- to call this routine with No_List as the argument. - function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean; + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed -- array, i.e. whether the designated object is a component of -- a bit packed array, or a subcomponent of such a component. @@ -425,18 +425,18 @@ package Exp_Util is -- to Force_Evaluation, and True is returned. Otherwise False -- is returned, and P is not affected. - function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean; + function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed -- slice, i.e. whether the designated object is bit packed slice -- or a component of a bit packed slice. Return True if so. - function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean; + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; -- Determine whether the node P is a slice of an array where the slice -- result may cause alignment problems because it has an alignment that -- is not compatible with the type. Return True if so. - function Is_Possibly_Unaligned_Object (P : Node_Id) return Boolean; - -- Node P is an object reference. This function returns True if it + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; + -- Node N is an object reference. This function returns True if it -- is possible that the object may not be aligned according to the -- normal default alignment requirement for its type (e.g. if it -- appears in a packed record, or as part of a component that has @@ -511,6 +511,11 @@ package Exp_Util is -- call to Remove_Side_Effects, it is safe to call New_Copy_Tree to -- obtain a copy of the resulting expression. + function Represented_As_Scalar (T : Entity_Id) return Boolean; + -- Returns True iff the implementation of this type in code generation + -- terms is scalar. This is true for scalars in the Ada sense, and for + -- packed arrays which are represented by a scalar (modular) type. + function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean; -- Given the node for an N_Unchecked_Type_Conversion, return True -- if this is an unchecked conversion that Gigi can handle directly. diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index d0d536d68b6..442ca6e2965 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -377,8 +377,7 @@ package body Sem_Eval is function Compile_Time_Compare (L, R : Node_Id; - Rec : Boolean := False) - return Compare_Result + Rec : Boolean := False) return Compare_Result is Ltyp : constant Entity_Id := Etype (L); Rtyp : constant Entity_Id := Etype (R); @@ -795,6 +794,34 @@ package body Sem_Eval is end if; end Compile_Time_Compare; + ------------------------------- + -- Compile_Time_Known_Bounds -- + ------------------------------- + + function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is + Indx : Node_Id; + Typ : Entity_Id; + + begin + if not Is_Array_Type (T) then + return False; + end if; + + Indx := First_Index (T); + while Present (Indx) loop + Typ := Underlying_Type (Etype (Indx)); + if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then + return False; + elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then + return False; + else + Next_Index (Indx); + end if; + end loop; + + return True; + end Compile_Time_Known_Bounds; + ------------------------------ -- Compile_Time_Known_Value -- ------------------------------ @@ -3116,8 +3143,7 @@ package body Sem_Eval is function In_Subrange_Of (T1 : Entity_Id; T2 : Entity_Id; - Fixed_Int : Boolean := False) - return Boolean + Fixed_Int : Boolean := False) return Boolean is L1 : Node_Id; H1 : Node_Id; @@ -3219,8 +3245,7 @@ package body Sem_Eval is (N : Node_Id; Typ : Entity_Id; Fixed_Int : Boolean := False; - Int_Real : Boolean := False) - return Boolean + Int_Real : Boolean := False) return Boolean is Val : Uint; Valr : Ureal; @@ -3400,8 +3425,7 @@ package body Sem_Eval is (N : Node_Id; Typ : Entity_Id; Fixed_Int : Boolean := False; - Int_Real : Boolean := False) - return Boolean + Int_Real : Boolean := False) return Boolean is Val : Uint; Valr : Ureal; @@ -3691,9 +3715,8 @@ package body Sem_Eval is ------------------------------------ function Subtypes_Statically_Compatible - (T1 : Entity_Id; - T2 : Entity_Id) - return Boolean + (T1 : Entity_Id; + T2 : Entity_Id) return Boolean is begin if Is_Scalar_Type (T1) then diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index c7b9e907c95..04f7e97bb25 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -137,8 +137,7 @@ package Sem_Eval is subtype Compare_LE is Compare_Result range LT .. EQ; function Compile_Time_Compare (L, R : Node_Id; - Rec : Boolean := False) - return Compare_Result; + 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 @@ -194,9 +193,8 @@ package Sem_Eval is -- range is not static, or because one or the other bound raises CE). function Subtypes_Statically_Compatible - (T1 : Entity_Id; - T2 : Entity_Id) - return Boolean; + (T1 : Entity_Id; + T2 : Entity_Id) return Boolean; -- Returns true if the subtypes are unconstrained or the constraint on -- on T1 is statically compatible with T2 (as defined by 4.9.1(4)). -- Otherwise returns false. @@ -222,6 +220,11 @@ package Sem_Eval is -- whose constituent expressions are either compile time known values -- or compile time known aggregates. + function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean; + -- If T is an array whose index bounds are all known at compile time, + -- then True is returned, if T is not an array, or one or more of its + -- index bounds is not known at compile time, then False is returned. + function Expr_Value (N : Node_Id) return Uint; -- Returns the folded value of the expression N. This function is called -- in instances where it has already been determined that the expression @@ -330,8 +333,7 @@ package Sem_Eval is (N : Node_Id; Typ : Entity_Id; Fixed_Int : Boolean := False; - Int_Real : Boolean := False) - return Boolean; + Int_Real : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that expression -- N is known to be in range of the subtype Typ. If the values of N or -- of either bouds of Type are unknown at compile time, False will @@ -353,8 +355,7 @@ package Sem_Eval is (N : Node_Id; Typ : Entity_Id; Fixed_Int : Boolean := False; - Int_Real : Boolean := False) - return Boolean; + Int_Real : Boolean := False) return Boolean; -- Returns True if it can be guaranteed at compile time that expression -- N is known to be out of range of the subtype Typ. True is returned -- if Typ is a scalar type, at least one of whose bounds is known at @@ -367,8 +368,7 @@ package Sem_Eval is function In_Subrange_Of (T1 : Entity_Id; T2 : Entity_Id; - Fixed_Int : Boolean := False) - return 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,