From f44fe4302729187c9c771e9b248bd829e651959b Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 15 Mar 2005 17:00:26 +0100 Subject: [PATCH] re PR ada/19900 (ACATS c391002 c432002 ICE categorize_ctor_elements_1) 2005-03-08 Robert Dewar Ed Schonberg Richard Kenner PR ada/19900 * exp_pakd.adb (Create_Packed_Array_Type): Do not set Must_Be_Byte_Aligned for cases where we do not need to use a System.Pack_nn unit. * exp_ch6.adb (Expand_Call): Call Expand_Actuals for functions as well as procedures. Needed now that we do some processing for IN parameters as well. This may well fix some unrelated errors. (Expand_Call): Handle case of unaligned objects (in particular those that come from packed arrays). (Expand_Inlined_Call): If the subprogram is a renaming as body, and the renamed entity is an inherited operation, re-expand the call using the original operation, which is the one to call. Detect attempt to inline parameterless recursive subprogram. (Represented_As_Scalar): Fix to work properly with private types (Is_Possibly_Unaligned_Object): Major rewrite to get a much more accurate estimate. Yields True in far fewer cases than before, improving the quality of code that depends on this test. (Remove_Side_Effects): Properly test for Expansion_Delayed and handle case when it's inside an N_Qualified_Expression. * exp_util.adb (Kill_Dead_Code): For a package declaration, iterate over both visible and private declarations to remove them from tree, and mark subprograms declared in package as eliminated, to prevent spurious use in subsequent compilation of generic units in the context. * exp_util.ads: Minor cleanup in variable names * sem_eval.ads, sem_eval.adb: Minor reformatting (Compile_Time_Known_Bounds): New function From-SVN: r96493 --- gcc/ada/exp_ch6.adb | 183 ++++++++++++++++++++----------- gcc/ada/exp_pakd.adb | 10 +- gcc/ada/exp_util.adb | 250 ++++++++++++++++++++++++++++++++----------- gcc/ada/exp_util.ads | 15 ++- gcc/ada/sem_eval.adb | 45 ++++++-- gcc/ada/sem_eval.ads | 22 ++-- 6 files changed, 370 insertions(+), 155 deletions(-) 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,