Skip to content

R
riscv-gcc-1
Commit 86cde7b1 by Robert Dewar Committed by Arnaud Charlet
Options

exp_util.ads, [...]: This patch replaces a number of occurrences of explicit… 

exp_util.ads, [...]: This patch replaces a number of occurrences of explicit tests for N_Null with...

2007-08-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* exp_util.ads, exp_util.adb: 
	This patch replaces a number of occurrences of explicit tests for N_Null
	with calls to Known_Null. This improves tracking of null values, since
	Known_Null also catches null constants, and variables currently known to
	be null, so we get better tracking.
	(Ensure_Defined): create an itype reference only in the scope of the
	itype.
	(Side_Effect_Free): A selected component of an access type that
	denotes a component with a rep clause must be treated as not
	side-effect free, because if it is part of a linked structure its
	value may be affected by a renaming.
	(Expand_Subtype_From_Expr): For limited objects initialized with build
	in place function calls, do nothing; otherwise we prematurely introduce
	an N_Reference node in the expression initializing the object, which
	breaks the circuitry that detects and adds the additional arguments to
	the called function. Bug found working in the new patch for statically
	allocated dispatch tables.
	(Is_Library_Level_Tagged_Type): New subprogram.
	(Remove_Side_Effects): If the expression of an elementary type is an
	operator treat as a function call.
	(Make_Literal_Range): If the index type of the array is not integer, use
	attributes properly to compute the constraint on the resulting aggregate
	which is a string.

	* freeze.ads, freeze.adb (Freeze_Entity): If the entity is a
	class-wide type whose base type is an incomplete private type, leave
	class-wide type unfrozen so that freeze nodes can be generated
	properly at a later point.
	(Freeze_Entity, array case): Handle case of pragma Pack and component
	size attributre clause for same array.

From-SVN: r127419
parent b2e1beb3
Showing with 316 additions and 155 deletions
gcc/ada/exp_util.adb
...@@ -31,6 +31,7 @@ with Einfo; use Einfo; ...@@ -31,6 +31,7 @@ with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr; with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Inline; use Inline; with Inline; use Inline;
with Itypes; use Itypes; with Itypes; use Itypes;
...@@ -89,8 +90,8 @@ package body Exp_Util is ...@@ -89,8 +90,8 @@ package body Exp_Util is
Pos : out Entity_Id; Pos : out Entity_Id;
Prefix : Entity_Id; Prefix : Entity_Id;
Sum : Node_Id; Sum : Node_Id;
Decls : in out List_Id; Decls : List_Id;
Stats : in out List_Id); Stats : List_Id);
-- Common processing for Task_Array_Image and Task_Record_Image. -- Common processing for Task_Array_Image and Task_Record_Image.
-- Create local variables and assign prefix of name to result string. -- Create local variables and assign prefix of name to result string.
...@@ -125,8 +126,14 @@ package body Exp_Util is ...@@ -125,8 +126,14 @@ package body Exp_Util is
Literal_Typ : Entity_Id) return Node_Id; Literal_Typ : Entity_Id) return Node_Id;
-- Produce a Range node whose bounds are: -- Produce a Range node whose bounds are:
-- Low_Bound (Literal_Type) .. -- Low_Bound (Literal_Type) ..
-- Low_Bound (Literal_Type) + Length (Literal_Typ) - 1 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
-- this is used for expanding declarations like X : String := "sdfgdfg"; -- this is used for expanding declarations like X : String := "sdfgdfg";
--
-- If the index type of the target array is not integer, we generate:
-- Low_Bound (Literal_Type) ..
-- Literal_Type'Val
-- (Literal_Type'Pos (Low_Bound (Literal_Type))
-- + (Length (Literal_Typ) -1))
function New_Class_Wide_Subtype function New_Class_Wide_Subtype
(CW_Typ : Entity_Id; (CW_Typ : Entity_Id;
...@@ -400,8 +407,8 @@ package body Exp_Util is ...@@ -400,8 +407,8 @@ package body Exp_Util is
T : Entity_Id; T : Entity_Id;
-- Entity for name at one index position -- Entity for name at one index position
Decls : List_Id := New_List; Decls : constant List_Id := New_List;
Stats : List_Id := New_List; Stats : constant List_Id := New_List;
begin begin
Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
...@@ -680,7 +687,7 @@ package body Exp_Util is ...@@ -680,7 +687,7 @@ package body Exp_Util is
begin begin
Append_To (Stats, Append_To (Stats,
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc))); Expression => New_Occurrence_Of (Res, Loc)));
Spec := Make_Function_Specification (Loc, Spec := Make_Function_Specification (Loc,
...@@ -709,8 +716,8 @@ package body Exp_Util is ...@@ -709,8 +716,8 @@ package body Exp_Util is
Pos : out Entity_Id; Pos : out Entity_Id;
Prefix : Entity_Id; Prefix : Entity_Id;
Sum : Node_Id; Sum : Node_Id;
Decls : in out List_Id; Decls : List_Id;
Stats : in out List_Id) Stats : List_Id)
is is
begin begin
Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L')); Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
...@@ -805,8 +812,8 @@ package body Exp_Util is ...@@ -805,8 +812,8 @@ package body Exp_Util is
Sel : Entity_Id; Sel : Entity_Id;
-- Entity for selector name -- Entity for selector name
Decls : List_Id := New_List; Decls : constant List_Id := New_List;
Stats : List_Id := New_List; Stats : constant List_Id := New_List;
begin begin
Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
...@@ -1052,37 +1059,18 @@ package body Exp_Util is ...@@ -1052,37 +1059,18 @@ package body Exp_Util is
procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
IR : Node_Id; IR : Node_Id;
P : Node_Id;
begin begin
if Is_Itype (Typ) then -- An itype reference must only be created if this is a local
IR := Make_Itype_Reference (Sloc (N)); -- itype, so that gigi can elaborate it on the proper objstack.
Set_Itype (IR, Typ);
if not In_Open_Scopes (Scope (Typ)) if Is_Itype (Typ)
and then Is_Subprogram (Current_Scope) and then Scope (Typ) = Current_Scope
and then Scope (Current_Scope) /= Standard_Standard
then then
-- Insert node in front of subprogram, to avoid scope anomalies IR := Make_Itype_Reference (Sloc (N));
-- in gigi. Set_Itype (IR, Typ);
P := Parent (N);
while Present (P)
and then Nkind (P) /= N_Subprogram_Body
loop
P := Parent (P);
end loop;
if Present (P) then
Insert_Action (P, IR);
else
Insert_Action (N, IR);
end if;
else
Insert_Action (N, IR); Insert_Action (N, IR);
end if; end if;
end if;
end Ensure_Defined; end Ensure_Defined;
--------------------- ---------------------
...@@ -1318,6 +1306,15 @@ package body Exp_Util is ...@@ -1318,6 +1306,15 @@ package body Exp_Util is
then then
null; null;
-- For limited objects initialized with build in place function calls,
-- nothing to be done; otherwise we prematurely introduce an N_Reference
-- node in the expression initializing the object, which breaks the
-- circuitry that detects and adds the additional arguments to the
-- called function.
elsif Is_Build_In_Place_Function_Call (Exp) then
null;
else else
Remove_Side_Effects (Exp); Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic, Rewrite (Subtype_Indic,
...@@ -2948,6 +2945,16 @@ package body Exp_Util is ...@@ -2948,6 +2945,16 @@ package body Exp_Util is
return True; return True;
end Is_All_Null_Statements; end Is_All_Null_Statements;
----------------------------------
-- Is_Library_Level_Tagged_Type --
----------------------------------
function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
begin
return Is_Tagged_Type (Typ)
and then Is_Library_Level_Entity (Typ);
end Is_Library_Level_Tagged_Type;
----------------------------------------- -----------------------------------------
-- Is_Predefined_Dispatching_Operation -- -- Is_Predefined_Dispatching_Operation --
----------------------------------------- -----------------------------------------
...@@ -3386,7 +3393,7 @@ package body Exp_Util is ...@@ -3386,7 +3393,7 @@ package body Exp_Util is
if Warn then if Warn then
Error_Msg_F Error_Msg_F
("?this code can never be executed and has been deleted", N); ("?this code can never be executed and has been deleted!", N);
end if; end if;
-- Recurse into block statements and bodies to process declarations -- Recurse into block statements and bodies to process declarations
...@@ -3514,7 +3521,7 @@ package body Exp_Util is ...@@ -3514,7 +3521,7 @@ package body Exp_Util is
Get_Current_Value_Condition (N, Op, Val); Get_Current_Value_Condition (N, Op, Val);
if Nkind (Val) = N_Null then if Known_Null (Val) then
if Op = N_Op_Eq then if Op = N_Op_Eq then
return False; return False;
elsif Op = N_Op_Ne then elsif Op = N_Op_Ne then
...@@ -3578,11 +3585,19 @@ package body Exp_Util is ...@@ -3578,11 +3585,19 @@ package body Exp_Util is
Val : Node_Id; Val : Node_Id;
begin begin
-- Constant null value is for sure null
if Ekind (E) = E_Constant
and then Known_Null (Constant_Value (E))
then
return True;
end if;
-- First check if we are in decisive conditional -- First check if we are in decisive conditional
Get_Current_Value_Condition (N, Op, Val); Get_Current_Value_Condition (N, Op, Val);
if Nkind (Val) = N_Null then if Known_Null (Val) then
if Op = N_Op_Eq then if Op = N_Op_Eq then
return True; return True;
elsif Op = N_Op_Ne then elsif Op = N_Op_Ne then
...@@ -3799,23 +3814,44 @@ package body Exp_Util is ...@@ -3799,23 +3814,44 @@ package body Exp_Util is
is is
Lo : constant Node_Id := Lo : constant Node_Id :=
New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ)); New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
Index : constant Entity_Id := Etype (Lo);
Hi : Node_Id;
Length_Expr : constant Node_Id :=
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Integer_Literal (Loc,
Intval => String_Literal_Length (Literal_Typ)),
Right_Opnd =>
Make_Integer_Literal (Loc, 1));
begin begin
Set_Analyzed (Lo, False); Set_Analyzed (Lo, False);
if Is_Integer_Type (Index) then
Hi :=
Make_Op_Add (Loc,
Left_Opnd => New_Copy_Tree (Lo),
Right_Opnd => Length_Expr);
else
Hi :=
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Val,
Prefix => New_Occurrence_Of (Index, Loc),
Expressions => New_List (
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
Prefix => New_Occurrence_Of (Index, Loc),
Expressions => New_List (New_Copy_Tree (Lo))),
Right_Opnd => Length_Expr)));
end if;
return return
Make_Range (Loc, Make_Range (Loc,
Low_Bound => Lo, Low_Bound => Lo,
High_Bound => Hi);
High_Bound =>
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => New_Copy_Tree (Lo),
Right_Opnd =>
Make_Integer_Literal (Loc,
String_Literal_Length (Literal_Typ))),
Right_Opnd => Make_Integer_Literal (Loc, 1)));
end Make_Literal_Range; end Make_Literal_Range;
---------------------------- ----------------------------
...@@ -4401,10 +4437,23 @@ package body Exp_Util is ...@@ -4401,10 +4437,23 @@ package body Exp_Util is
return Side_Effect_Free (Expression (N)); return Side_Effect_Free (Expression (N));
-- A selected component is side effect free only if it is a -- A selected component is side effect free only if it is a
-- side effect free prefixed reference. -- side effect free prefixed reference. If it designates a
-- component with a rep. clause it must be treated has having
-- a potential side effect, because it may be modified through
-- a renaming, and a subsequent use of the renaming as a macro
-- will yield the wrong value. This complex interaction between
-- renaming and removing side effects is a reminder that the
-- latter has become a headache to maintain, and that it should
-- be removed in favor of the gcc mechanism to capture values ???
when N_Selected_Component => when N_Selected_Component =>
if Nkind (Parent (N)) = N_Explicit_Dereference
and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
then
return False;
else
return Safe_Prefixed_Reference (N); return Safe_Prefixed_Reference (N);
end if;
-- A range is side effect free if the bounds are side effect free -- A range is side effect free if the bounds are side effect free
...@@ -4419,8 +4468,8 @@ package body Exp_Util is ...@@ -4419,8 +4468,8 @@ package body Exp_Util is
return Side_Effect_Free (Discrete_Range (N)) return Side_Effect_Free (Discrete_Range (N))
and then Safe_Prefixed_Reference (N); and then Safe_Prefixed_Reference (N);
-- A type conversion is side effect free if the expression -- A type conversion is side effect free if the expression to be
-- to be converted is side effect free. -- converted is side effect free.
when N_Type_Conversion => when N_Type_Conversion =>
return Side_Effect_Free (Expression (N)); return Side_Effect_Free (Expression (N));
...@@ -4496,8 +4545,7 @@ package body Exp_Util is ...@@ -4496,8 +4545,7 @@ package body Exp_Util is
return False; return False;
elsif Is_Entity_Name (N) then elsif Is_Entity_Name (N) then
return return Ekind (Entity (N)) = E_In_Parameter;
Ekind (Entity (N)) = E_In_Parameter;
elsif Nkind (N) = N_Indexed_Component elsif Nkind (N) = N_Indexed_Component
or else Nkind (N) = N_Selected_Component or else Nkind (N) = N_Selected_Component
...@@ -4523,19 +4571,19 @@ package body Exp_Util is ...@@ -4523,19 +4571,19 @@ package body Exp_Util is
Scope_Suppress := (others => True); Scope_Suppress := (others => True);
-- If it is a scalar type and we need to capture the value, just -- If it is a scalar type and we need to capture the value, just make
-- make a copy. Likewise for a function call. And if we have a -- a copy. Likewise for a function or operator call. And if we have a
-- volatile variable and Nam_Req is not set (see comments above -- volatile variable and Nam_Req is not set (see comments above for
-- for Side_Effect_Free). -- Side_Effect_Free).
if Is_Elementary_Type (Exp_Type) if Is_Elementary_Type (Exp_Type)
and then (Variable_Ref and then (Variable_Ref
or else Nkind (Exp) = N_Function_Call or else Nkind (Exp) = N_Function_Call
or else Nkind (Exp) in N_Op
or else (not Name_Req or else (not Name_Req
and then Is_Entity_Name (Exp) and then Is_Entity_Name (Exp)
and then Treat_As_Volatile (Entity (Exp)))) and then Treat_As_Volatile (Entity (Exp))))
then then
Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R')); Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Set_Etype (Def_Id, Exp_Type); Set_Etype (Def_Id, Exp_Type);
Res := New_Reference_To (Def_Id, Loc); Res := New_Reference_To (Def_Id, Loc);
......
gcc/ada/exp_util.ads
...@@ -438,6 +438,10 @@ package Exp_Util is ...@@ -438,6 +438,10 @@ package Exp_Util is
-- False otherwise. True for an empty list. It is an error to call this -- False otherwise. True for an empty list. It is an error to call this
-- routine with No_List as the argument. -- routine with No_List as the argument.
function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean;
-- Return True if Typ is a library level tagged type. Currently we use
-- this information to build statically allocated dispatch tables.
function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-251): Determines if E is a predefined primitive operation -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
...@@ -628,7 +632,7 @@ package Exp_Util is ...@@ -628,7 +632,7 @@ package Exp_Util is
-- control to escape doing the undefer call. -- control to escape doing the undefer call.
private private
pragma Inline (Force_Evaluation);
pragma Inline (Duplicate_Subexpr); pragma Inline (Duplicate_Subexpr);
pragma Inline (Force_Evaluation);
pragma Inline (Is_Library_Level_Tagged_Type);
end Exp_Util; end Exp_Util;
gcc/ada/freeze.adb
...@@ -369,7 +369,7 @@ package body Freeze is ...@@ -369,7 +369,7 @@ package body Freeze is
and then Etype (Old_S) /= Standard_Void_Type) and then Etype (Old_S) /= Standard_Void_Type)
then then
Call_Node := Call_Node :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Call_Name, Name => Call_Name,
...@@ -377,12 +377,12 @@ package body Freeze is ...@@ -377,12 +377,12 @@ package body Freeze is
elsif Ekind (Old_S) = E_Enumeration_Literal then elsif Ekind (Old_S) = E_Enumeration_Literal then
Call_Node := Call_Node :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Old_S, Loc)); Expression => New_Occurrence_Of (Old_S, Loc));
elsif Nkind (Nam) = N_Character_Literal then elsif Nkind (Nam) = N_Character_Literal then
Call_Node := Call_Node :=
Make_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Call_Name); Expression => Call_Name);
else else
...@@ -2235,7 +2235,9 @@ package body Freeze is ...@@ -2235,7 +2235,9 @@ package body Freeze is
Set_Is_Frozen (E, False); Set_Is_Frozen (E, False);
return No_List; return No_List;
elsif not After_Last_Declaration then elsif not After_Last_Declaration
and then not Freezing_Library_Level_Tagged_Type
then
Error_Msg_Node_1 := F_Type; Error_Msg_Node_1 := F_Type;
Error_Msg Error_Msg
("type& must be fully defined before this point", ("type& must be fully defined before this point",
...@@ -2465,7 +2467,7 @@ package body Freeze is ...@@ -2465,7 +2467,7 @@ package body Freeze is
then then
Error_Msg_N Error_Msg_N
("stand alone atomic constant must be " & ("stand alone atomic constant must be " &
"imported ('R'M 'C.6(13))", E); "imported ('R'M C.6(13))", E);
elsif Has_Rep_Pragma (E, Name_Volatile) elsif Has_Rep_Pragma (E, Name_Volatile)
or else or else
...@@ -2473,7 +2475,7 @@ package body Freeze is ...@@ -2473,7 +2475,7 @@ package body Freeze is
then then
Error_Msg_N Error_Msg_N
("stand alone volatile constant must be " & ("stand alone volatile constant must be " &
"imported ('R'M 'C.6(13))", E); "imported (RM C.6(13))", E);
end if; end if;
end if; end if;
...@@ -2530,6 +2532,100 @@ package body Freeze is ...@@ -2530,6 +2532,100 @@ package body Freeze is
if E /= Base_Type (E) then if E /= Base_Type (E) then
-- Before we do anything else, a specialized test for the case of
-- a size given for an array where the array needs to be packed,
-- but was not so the size cannot be honored. This would of course
-- be caught by the backend, and indeed we don't catch all cases.
-- The point is that we can give a better error message in those
-- cases that we do catch with the circuitry here. Also if pragma
-- Implicit_Packing is set, this is where the packing occurs.
-- The reason we do this so early is that the processing in the
-- automatic packing case affects the layout of the base type, so
-- it must be done before we freeze the base type.
if Is_Array_Type (E) then
declare
Lo, Hi : Node_Id;
Ctyp : constant Entity_Id := Component_Type (E);
begin
-- Check enabling conditions. These are straightforward
-- except for the test for a limited composite type. This
-- eliminates the rare case of a array of limited components
-- where there are issues of whether or not we can go ahead
-- and pack the array (since we can't freely pack and unpack
-- arrays if they are limited).
-- Note that we check the root type explicitly because the
-- whole point is we are doing this test before we have had
-- a chance to freeze the base type (and it is that freeze
-- action that causes stuff to be inherited).
if Present (Size_Clause (E))
and then Known_Static_Esize (E)
and then not Is_Packed (E)
and then not Has_Pragma_Pack (E)
and then Number_Dimensions (E) = 1
and then not Has_Component_Size_Clause (E)
and then Known_Static_Esize (Ctyp)
and then not Is_Limited_Composite (E)
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
if Compile_Time_Known_Value (Lo)
and then Compile_Time_Known_Value (Hi)
and then Known_Static_RM_Size (Ctyp)
and then RM_Size (Ctyp) < 64
then
declare
Lov : constant Uint := Expr_Value (Lo);
Hiv : constant Uint := Expr_Value (Hi);
Len : constant Uint := UI_Max
(Uint_0,
Hiv - Lov + 1);
Rsiz : constant Uint := RM_Size (Ctyp);
SZ : constant Node_Id := Size_Clause (E);
Btyp : constant Entity_Id := Base_Type (E);
-- What we are looking for here is the situation where
-- the RM_Size given would be exactly right if there
-- was a pragma Pack (resulting in the component size
-- being the same as the RM_Size). Furthermore, the
-- component type size must be an odd size (not a
-- multiple of storage unit)
begin
if RM_Size (E) = Len * Rsiz
and then Rsiz mod System_Storage_Unit /= 0
then
-- For implicit packing mode, just set the
-- component size silently
if Implicit_Packing then
Set_Component_Size (Btyp, Rsiz);
Set_Is_Bit_Packed_Array (Btyp);
Set_Is_Packed (Btyp);
Set_Has_Non_Standard_Rep (Btyp);
-- Otherwise give an error message
else
Error_Msg_NE
("size given for& too small", SZ, E);
Error_Msg_N
("\use explicit pragma Pack "
& "or use pragma Implicit_Packing", SZ);
end if;
end if;
end;
end if;
end if;
end;
end if;
-- If ancestor subtype present, freeze that first. -- If ancestor subtype present, freeze that first.
-- Note that this will also get the base type frozen. -- Note that this will also get the base type frozen.
...@@ -2558,7 +2654,6 @@ package body Freeze is ...@@ -2558,7 +2654,6 @@ package body Freeze is
if Is_Array_Type (E) then if Is_Array_Type (E) then
declare declare
Ctyp : constant Entity_Id := Component_Type (E); Ctyp : constant Entity_Id := Component_Type (E);
Pnod : Node_Id;
Non_Standard_Enum : Boolean := False; Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type -- Set true if any of the index types is an enumeration type
...@@ -2644,46 +2739,75 @@ package body Freeze is ...@@ -2644,46 +2739,75 @@ package body Freeze is
if Csiz /= 0 then if Csiz /= 0 then
declare declare
A : constant Uint := Alignment_In_Bits (Ctyp); A : constant Uint := Alignment_In_Bits (Ctyp);
begin begin
if Csiz < A then if Csiz < A then
Csiz := A; Csiz := A;
end if; end if;
end; end;
end if; end if;
end if; end if;
-- Case of component size that may result in packing
if 1 <= Csiz and then Csiz <= 64 then if 1 <= Csiz and then Csiz <= 64 then
declare
Ent : constant Entity_Id :=
First_Subtype (E);
Pack_Pragma : constant Node_Id :=
Get_Rep_Pragma (Ent, Name_Pack);
Comp_Size_C : constant Node_Id :=
Get_Attribute_Definition_Clause
(Ent, Attribute_Component_Size);
begin
-- Warn if we have pack and component size so that
-- the pack is ignored.
-- We set the component size for all cases 1-64 -- Note: here we must check for the presence of a
-- component size before checking for a Pack pragma
-- to deal with the case where the array type is a
-- derived type whose parent is currently private.
Set_Component_Size (Base_Type (E), Csiz); if Present (Comp_Size_C)
and then Has_Pragma_Pack (Ent)
then
Error_Msg_Sloc := Sloc (Comp_Size_C);
Error_Msg_NE
("?pragma Pack for& ignored!",
Pack_Pragma, Ent);
Error_Msg_N
("\?explicit component size given#!",
Pack_Pragma);
end if;
-- Check for base type of 8, 16, 32 bits, where the -- Set component size if not already set by a
-- subtype has a length one less than the base type -- component size clause.
-- and is unsigned (e.g. Natural subtype of Integer).
if not Present (Comp_Size_C) then
Set_Component_Size (E, Csiz);
end if;
-- Check for base type of 8, 16, 32 bits, where an
-- unsigned subtype has a length one less than the
-- base type (e.g. Natural subtype of Integer).
-- In such cases, if a component size was not set -- In such cases, if a component size was not set
-- explicitly, then generate a warning. -- explicitly, then generate a warning.
if Has_Pragma_Pack (E) if Has_Pragma_Pack (E)
and then not Has_Component_Size_Clause (E) and then not Present (Comp_Size_C)
and then and then
(Csiz = 7 or else Csiz = 15 or else Csiz = 31) (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
and then Esize (Base_Type (Ctyp)) = Csiz + 1 and then Esize (Base_Type (Ctyp)) = Csiz + 1
then then
Error_Msg_Uint_1 := Csiz; Error_Msg_Uint_1 := Csiz;
Pnod :=
Get_Rep_Pragma (First_Subtype (E), Name_Pack);
if Present (Pnod) then if Present (Pack_Pragma) then
Error_Msg_N Error_Msg_N
("pragma Pack causes component size to be ^?", ("?pragma Pack causes component size "
Pnod); & "to be ^!", Pack_Pragma);
Error_Msg_N Error_Msg_N
("\use Component_Size to set desired value", ("\?use Component_Size to set "
Pnod); & "desired value!", Pack_Pragma);
end if; end if;
end if; end if;
...@@ -2696,18 +2820,18 @@ package body Freeze is ...@@ -2696,18 +2820,18 @@ package body Freeze is
or else Csiz = 64 or else Csiz = 64
or else (Csiz = 24 and then Alignment (Ctyp) = 1) or else (Csiz = 24 and then Alignment (Ctyp) = 1)
then then
-- Here the array was requested to be packed, but -- Here the array was requested to be packed,
-- the packing request had no effect, so Is_Packed -- but the packing request had no effect, so
-- is reset. -- Is_Packed is reset.
-- Note: semantically this means that we lose track -- Note: semantically this means that we lose
-- of the fact that a derived type inherited a -- track of the fact that a derived type
-- pragma Pack that was non-effective, but that -- inherited a pragma Pack that was non-
-- seems fine. -- effective, but that seems fine.
-- We regard a Pack pragma as a request to set a -- We regard a Pack pragma as a request to set
-- representation characteristic, and this request -- a representation characteristic, and this
-- may be ignored. -- request may be ignored.
Set_Is_Packed (Base_Type (E), False); Set_Is_Packed (Base_Type (E), False);
...@@ -2718,6 +2842,7 @@ package body Freeze is ...@@ -2718,6 +2842,7 @@ package body Freeze is
Set_Is_Bit_Packed_Array (Base_Type (E)); Set_Is_Bit_Packed_Array (Base_Type (E));
Set_Is_Packed (Base_Type (E)); Set_Is_Packed (Base_Type (E));
end if; end if;
end;
end if; end if;
end; end;
...@@ -2755,63 +2880,6 @@ package body Freeze is ...@@ -2755,63 +2880,6 @@ package body Freeze is
end; end;
end if; end if;
-- Check one common case of a size given where the array
-- needs to be packed, but was not so the size cannot be
-- honored. This would of course be caught by the backend,
-- and indeed we don't catch all cases. The point is that
-- we can give a better error message in those cases that
-- we do catch with the circuitry here.
declare
Lo, Hi : Node_Id;
Ctyp : constant Entity_Id := Component_Type (E);
begin
if Present (Size_Clause (E))
and then Known_Static_Esize (E)
and then not Is_Bit_Packed_Array (E)
and then not Has_Pragma_Pack (E)
and then Number_Dimensions (E) = 1
and then not Has_Component_Size_Clause (E)
and then Known_Static_Esize (Ctyp)
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
if Compile_Time_Known_Value (Lo)
and then Compile_Time_Known_Value (Hi)
and then Known_Static_RM_Size (Ctyp)
and then RM_Size (Ctyp) < 64
then
declare
Lov : constant Uint := Expr_Value (Lo);
Hiv : constant Uint := Expr_Value (Hi);
Len : constant Uint :=
UI_Max (Uint_0, Hiv - Lov + 1);
Rsiz : constant Uint := RM_Size (Ctyp);
-- What we are looking for here is the situation where
-- the RM_Size given would be exactly right if there
-- was a pragma Pack (resulting in the component size
-- being the same as the RM_Size). Furthermore, the
-- component type size must be an odd size (not a
-- multiple of storage unit)
begin
if RM_Size (E) = Len * Rsiz
and then Rsiz mod System_Storage_Unit /= 0
then
Error_Msg_NE
("size given for& too small",
Size_Clause (E), E);
Error_Msg_N
("\explicit pragma Pack is required",
Size_Clause (E));
end if;
end;
end if;
end if;
end;
-- If any of the index types was an enumeration type with -- If any of the index types was an enumeration type with
-- a non-standard rep clause, then we indicate that the -- a non-standard rep clause, then we indicate that the
-- array type is always packed (even if it is not bit packed). -- array type is always packed (even if it is not bit packed).
...@@ -2871,6 +2939,16 @@ package body Freeze is ...@@ -2871,6 +2939,16 @@ package body Freeze is
elsif Is_Class_Wide_Type (E) then elsif Is_Class_Wide_Type (E) then
Freeze_And_Append (Root_Type (E), Loc, Result); Freeze_And_Append (Root_Type (E), Loc, Result);
-- If the base type of the class-wide type is still incomplete,
-- the class-wide remains unfrozen as well. This is legal when
-- E is the formal of a primitive operation of some other type
-- which is being frozen.
if not Is_Frozen (Root_Type (E)) then
Set_Is_Frozen (E, False);
return Result;
end if;
-- If the Class_Wide_Type is an Itype (when type is the anonymous -- If the Class_Wide_Type is an Itype (when type is the anonymous
-- parent of a derived type) and it is a library-level entity, -- parent of a derived type) and it is a library-level entity,
-- generate an itype reference for it. Otherwise, its first -- generate an itype reference for it. Otherwise, its first
...@@ -2967,9 +3045,34 @@ package body Freeze is ...@@ -2967,9 +3045,34 @@ package body Freeze is
elsif Is_Incomplete_Or_Private_Type (E) elsif Is_Incomplete_Or_Private_Type (E)
and then not Is_Generic_Type (E) and then not Is_Generic_Type (E)
then then
-- The construction of the dispatch table associated with library
-- level tagged types forces freezing of all the primitives of the
-- type, which may cause premature freezing of the partial view.
-- For example:
-- package Pkg is
-- type T is tagged private;
-- type DT is new T with private;
-- procedure Prim (X : in out T; Y : in out DT'class);
-- private
-- type T is tagged null record;
-- Obj : T;
-- type DT is new T with null record;
-- end;
-- In this case the type will be frozen later by the usual
-- mechanism: an object declaration, an instantiation, or the
-- end of a declarative part.
if Is_Library_Level_Tagged_Type (E)
and then not Present (Full_View (E))
then
Set_Is_Frozen (E, False);
return Result;
-- Case of full view present -- Case of full view present
if Present (Full_View (E)) then elsif Present (Full_View (E)) then
-- If full view has already been frozen, then no further -- If full view has already been frozen, then no further
-- processing is required -- processing is required
...@@ -4783,7 +4886,8 @@ package body Freeze is ...@@ -4783,7 +4886,8 @@ package body Freeze is
return True; return True;
end; end;
else return not Is_Private_Type (T) else
return not Is_Private_Type (T)
or else Present (Full_View (Base_Type (T))); or else Present (Full_View (Base_Type (T)));
end if; end if;
end Is_Fully_Defined; end Is_Fully_Defined;
...@@ -4818,7 +4922,6 @@ package body Freeze is ...@@ -4818,7 +4922,6 @@ package body Freeze is
end if; end if;
Formal := First_Formal (E); Formal := First_Formal (E);
while Present (Formal) loop while Present (Formal) loop
if Present (Default_Value (Formal)) then if Present (Default_Value (Formal)) then
...@@ -4841,7 +4944,7 @@ package body Freeze is ...@@ -4841,7 +4944,7 @@ package body Freeze is
and then not Vax_Float (Etype (Dcopy))) and then not Vax_Float (Etype (Dcopy)))
or else Nkind (Dcopy) = N_Character_Literal or else Nkind (Dcopy) = N_Character_Literal
or else Nkind (Dcopy) = N_String_Literal or else Nkind (Dcopy) = N_String_Literal
or else Nkind (Dcopy) = N_Null or else Known_Null (Dcopy)
or else (Nkind (Dcopy) = N_Attribute_Reference or else (Nkind (Dcopy) = N_Attribute_Reference
and then and then
Attribute_Name (Dcopy) = Name_Null_Parameter) Attribute_Name (Dcopy) = Name_Null_Parameter)
...@@ -5180,7 +5283,7 @@ package body Freeze is ...@@ -5180,7 +5283,7 @@ package body Freeze is
Error_Msg_N Error_Msg_N
("\use pragma Import for & to " & ("\use pragma Import for & to " &
"suppress initialization ('R'M B.1(24))?", "suppress initialization (RM B.1(24))?",
Nam); Nam);
end if; end if;
end Warn_Overlay; end Warn_Overlay;
......
gcc/ada/freeze.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -121,6 +121,12 @@ package Freeze is ...@@ -121,6 +121,12 @@ package Freeze is
-- base types, where the freeze node is preallocated at the point of -- base types, where the freeze node is preallocated at the point of
-- declaration, so that the First_Subtype_Link field can be set. -- declaration, so that the First_Subtype_Link field can be set.
Freezing_Library_Level_Tagged_Type : Boolean := False;
-- Flag used to indicate that we are freezing the primitives of a library
-- level tagged types. Used to disable checks on premature freezing.
-- More documentation needed??? why is this flag needed? what are these
-- checks? why do they need disabling in some cases?
----------------- -----------------
-- Subprograms -- -- Subprograms --
----------------- -----------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment