OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR ada/19900 (ACATS c391002 c432002 ICE categorize_ctor_elements_1) 

2005-03-08  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Richard Kenner  <kenner@vlsi1.ultra.nyu.edu>

	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
This commit is contained in:
Robert Dewar 2005-03-15 17:00:26 +01:00 committed by Arnaud Charlet
parent c6823a20b2
commit f44fe43027
6 changed files with 370 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

183
gcc/ada/exp_ch6.adb
View File

@ -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

10
gcc/ada/exp_pakd.adb
View File

@ -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;

250
gcc/ada/exp_util.adb
View File

@ -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 --
------------------------------------

15
gcc/ada/exp_util.ads
View File

@ -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.

45
gcc/ada/sem_eval.adb
View File

@ -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

22
gcc/ada/sem_eval.ads
View File

@ -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,