aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/exp_util.adb174
-rw-r--r--gcc/ada/exp_util.ads8
-rw-r--r--gcc/ada/freeze.adb345
-rw-r--r--gcc/ada/freeze.ads8
4 files changed, 348 insertions, 187 deletions
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 93798b3..0f84960 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -31,6 +31,7 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
+with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Inline; use Inline;
with Itypes; use Itypes;
@@ -89,8 +90,8 @@ package body Exp_Util is
Pos : out Entity_Id;
Prefix : Entity_Id;
Sum : Node_Id;
- Decls : in out List_Id;
- Stats : in out List_Id);
+ Decls : List_Id;
+ Stats : List_Id);
-- Common processing for Task_Array_Image and Task_Record_Image.
-- Create local variables and assign prefix of name to result string.
@@ -125,8 +126,14 @@ package body Exp_Util is
Literal_Typ : Entity_Id) return Node_Id;
-- Produce a Range node whose bounds are:
-- 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";
+ --
+ -- 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
(CW_Typ : Entity_Id;
@@ -400,8 +407,8 @@ package body Exp_Util is
T : Entity_Id;
-- Entity for name at one index position
- Decls : List_Id := New_List;
- Stats : List_Id := New_List;
+ Decls : constant List_Id := New_List;
+ Stats : constant List_Id := New_List;
begin
Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
@@ -680,7 +687,7 @@ package body Exp_Util is
begin
Append_To (Stats,
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc)));
Spec := Make_Function_Specification (Loc,
@@ -709,8 +716,8 @@ package body Exp_Util is
Pos : out Entity_Id;
Prefix : Entity_Id;
Sum : Node_Id;
- Decls : in out List_Id;
- Stats : in out List_Id)
+ Decls : List_Id;
+ Stats : List_Id)
is
begin
Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
@@ -805,8 +812,8 @@ package body Exp_Util is
Sel : Entity_Id;
-- Entity for selector name
- Decls : List_Id := New_List;
- Stats : List_Id := New_List;
+ Decls : constant List_Id := New_List;
+ Stats : constant List_Id := New_List;
begin
Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
@@ -1052,36 +1059,17 @@ package body Exp_Util is
procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
IR : Node_Id;
- P : Node_Id;
begin
- if Is_Itype (Typ) then
+ -- An itype reference must only be created if this is a local
+ -- itype, so that gigi can elaborate it on the proper objstack.
+
+ if Is_Itype (Typ)
+ and then Scope (Typ) = Current_Scope
+ then
IR := Make_Itype_Reference (Sloc (N));
Set_Itype (IR, Typ);
-
- if not In_Open_Scopes (Scope (Typ))
- and then Is_Subprogram (Current_Scope)
- and then Scope (Current_Scope) /= Standard_Standard
- then
- -- Insert node in front of subprogram, to avoid scope anomalies
- -- in gigi.
-
- 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);
- end if;
+ Insert_Action (N, IR);
end if;
end Ensure_Defined;
@@ -1318,6 +1306,15 @@ package body Exp_Util is
then
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
Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic,
@@ -2948,6 +2945,16 @@ package body Exp_Util is
return True;
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 --
-----------------------------------------
@@ -3386,7 +3393,7 @@ package body Exp_Util is
if Warn then
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;
-- Recurse into block statements and bodies to process declarations
@@ -3514,7 +3521,7 @@ package body Exp_Util is
Get_Current_Value_Condition (N, Op, Val);
- if Nkind (Val) = N_Null then
+ if Known_Null (Val) then
if Op = N_Op_Eq then
return False;
elsif Op = N_Op_Ne then
@@ -3578,11 +3585,19 @@ package body Exp_Util is
Val : Node_Id;
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
Get_Current_Value_Condition (N, Op, Val);
- if Nkind (Val) = N_Null then
+ if Known_Null (Val) then
if Op = N_Op_Eq then
return True;
elsif Op = N_Op_Ne then
@@ -3797,25 +3812,46 @@ package body Exp_Util is
(Loc : Source_Ptr;
Literal_Typ : Entity_Id) return Node_Id
is
- Lo : constant Node_Id :=
- New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
+ Lo : constant Node_Id :=
+ 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
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
Make_Range (Loc,
- Low_Bound => Lo,
-
- 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)));
+ Low_Bound => Lo,
+ High_Bound => Hi);
end Make_Literal_Range;
----------------------------
@@ -4401,10 +4437,23 @@ package body Exp_Util is
return Side_Effect_Free (Expression (N));
-- 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 =>
- return Safe_Prefixed_Reference (N);
+ 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);
+ end if;
-- A range is side effect free if the bounds are side effect free
@@ -4419,8 +4468,8 @@ package body Exp_Util is
return Side_Effect_Free (Discrete_Range (N))
and then Safe_Prefixed_Reference (N);
- -- A type conversion is side effect free if the expression
- -- to be converted is side effect free.
+ -- A type conversion is side effect free if the expression to be
+ -- converted is side effect free.
when N_Type_Conversion =>
return Side_Effect_Free (Expression (N));
@@ -4496,8 +4545,7 @@ package body Exp_Util is
return False;
elsif Is_Entity_Name (N) then
- return
- Ekind (Entity (N)) = E_In_Parameter;
+ return Ekind (Entity (N)) = E_In_Parameter;
elsif Nkind (N) = N_Indexed_Component
or else Nkind (N) = N_Selected_Component
@@ -4523,19 +4571,19 @@ package body Exp_Util is
Scope_Suppress := (others => True);
- -- If it is a scalar type and we need to capture the value, just
- -- make a copy. Likewise for a function call. And if we have a
- -- volatile variable and Nam_Req is not set (see comments above
- -- for Side_Effect_Free).
+ -- If it is a scalar type and we need to capture the value, just make
+ -- 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 for
+ -- Side_Effect_Free).
if Is_Elementary_Type (Exp_Type)
and then (Variable_Ref
or else Nkind (Exp) = N_Function_Call
+ or else Nkind (Exp) in N_Op
or else (not Name_Req
and then Is_Entity_Name (Exp)
and then Treat_As_Volatile (Entity (Exp))))
then
-
Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Set_Etype (Def_Id, Exp_Type);
Res := New_Reference_To (Def_Id, Loc);
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index ccf6740..cd34407 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -438,6 +438,10 @@ package Exp_Util is
-- False otherwise. True for an empty list. It is an error to call this
-- 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;
-- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
@@ -628,7 +632,7 @@ package Exp_Util is
-- control to escape doing the undefer call.
private
- pragma Inline (Force_Evaluation);
pragma Inline (Duplicate_Subexpr);
-
+ pragma Inline (Force_Evaluation);
+ pragma Inline (Is_Library_Level_Tagged_Type);
end Exp_Util;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 6e448b1..44cb73b 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -369,7 +369,7 @@ package body Freeze is
and then Etype (Old_S) /= Standard_Void_Type)
then
Call_Node :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name => Call_Name,
@@ -377,12 +377,12 @@ package body Freeze is
elsif Ekind (Old_S) = E_Enumeration_Literal then
Call_Node :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Old_S, Loc));
elsif Nkind (Nam) = N_Character_Literal then
Call_Node :=
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => Call_Name);
else
@@ -2235,7 +2235,9 @@ package body Freeze is
Set_Is_Frozen (E, False);
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
("type& must be fully defined before this point",
@@ -2465,7 +2467,7 @@ package body Freeze is
then
Error_Msg_N
("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)
or else
@@ -2473,7 +2475,7 @@ package body Freeze is
then
Error_Msg_N
("stand alone volatile constant must be " &
- "imported ('R'M 'C.6(13))", E);
+ "imported (RM C.6(13))", E);
end if;
end if;
@@ -2530,6 +2532,100 @@ package body Freeze is
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.
-- Note that this will also get the base type frozen.
@@ -2558,7 +2654,6 @@ package body Freeze is
if Is_Array_Type (E) then
declare
Ctyp : constant Entity_Id := Component_Type (E);
- Pnod : Node_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration type
@@ -2644,80 +2739,110 @@ package body Freeze is
if Csiz /= 0 then
declare
A : constant Uint := Alignment_In_Bits (Ctyp);
-
begin
if Csiz < A then
Csiz := A;
end if;
end;
end if;
-
end if;
+ -- Case of component size that may result in packing
+
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.
+
+ 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;
- Set_Component_Size (Base_Type (E), Csiz);
+ -- Set component size if not already set by a
+ -- component size clause.
- -- Check for base type of 8, 16, 32 bits, where the
- -- subtype has a length one less than the base type
- -- and is unsigned (e.g. Natural subtype of Integer).
+ if not Present (Comp_Size_C) then
+ Set_Component_Size (E, Csiz);
+ end if;
- -- In such cases, if a component size was not set
- -- explicitly, then generate a warning.
+ -- 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).
- if Has_Pragma_Pack (E)
- and then not Has_Component_Size_Clause (E)
- and then
- (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
- and then Esize (Base_Type (Ctyp)) = Csiz + 1
- then
- Error_Msg_Uint_1 := Csiz;
- Pnod :=
- Get_Rep_Pragma (First_Subtype (E), Name_Pack);
+ -- In such cases, if a component size was not set
+ -- explicitly, then generate a warning.
- if Present (Pnod) then
- Error_Msg_N
- ("pragma Pack causes component size to be ^?",
- Pnod);
- Error_Msg_N
- ("\use Component_Size to set desired value",
- Pnod);
+ if Has_Pragma_Pack (E)
+ and then not Present (Comp_Size_C)
+ and then
+ (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
+ and then Esize (Base_Type (Ctyp)) = Csiz + 1
+ then
+ Error_Msg_Uint_1 := Csiz;
+
+ if Present (Pack_Pragma) then
+ Error_Msg_N
+ ("?pragma Pack causes component size "
+ & "to be ^!", Pack_Pragma);
+ Error_Msg_N
+ ("\?use Component_Size to set "
+ & "desired value!", Pack_Pragma);
+ end if;
end if;
- end if;
- -- Actual packing is not needed for 8, 16, 32, 64.
- -- Also not needed for 24 if alignment is 1.
+ -- Actual packing is not needed for 8, 16, 32, 64.
+ -- Also not needed for 24 if alignment is 1.
- if Csiz = 8
- or else Csiz = 16
- or else Csiz = 32
- or else Csiz = 64
- or else (Csiz = 24 and then Alignment (Ctyp) = 1)
- then
- -- Here the array was requested to be packed, but
- -- the packing request had no effect, so Is_Packed
- -- is reset.
+ if Csiz = 8
+ or else Csiz = 16
+ or else Csiz = 32
+ or else Csiz = 64
+ or else (Csiz = 24 and then Alignment (Ctyp) = 1)
+ then
+ -- Here the array was requested to be packed,
+ -- but the packing request had no effect, so
+ -- Is_Packed is reset.
- -- Note: semantically this means that we lose track
- -- of the fact that a derived type inherited a
- -- pragma Pack that was non-effective, but that
- -- seems fine.
+ -- Note: semantically this means that we lose
+ -- track of the fact that a derived type
+ -- inherited a pragma Pack that was non-
+ -- effective, but that seems fine.
- -- We regard a Pack pragma as a request to set a
- -- representation characteristic, and this request
- -- may be ignored.
+ -- We regard a Pack pragma as a request to set
+ -- a representation characteristic, and this
+ -- request may be ignored.
- Set_Is_Packed (Base_Type (E), False);
+ Set_Is_Packed (Base_Type (E), False);
- -- In all other cases, packing is indeed needed
+ -- In all other cases, packing is indeed needed
- else
- Set_Has_Non_Standard_Rep (Base_Type (E));
- Set_Is_Bit_Packed_Array (Base_Type (E));
- Set_Is_Packed (Base_Type (E));
- end if;
+ else
+ Set_Has_Non_Standard_Rep (Base_Type (E));
+ Set_Is_Bit_Packed_Array (Base_Type (E));
+ Set_Is_Packed (Base_Type (E));
+ end if;
+ end;
end if;
end;
@@ -2755,63 +2880,6 @@ package body Freeze is
end;
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
-- a non-standard rep clause, then we indicate that the
-- array type is always packed (even if it is not bit packed).
@@ -2871,6 +2939,16 @@ package body Freeze is
elsif Is_Class_Wide_Type (E) then
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
-- parent of a derived type) and it is a library-level entity,
-- generate an itype reference for it. Otherwise, its first
@@ -2967,9 +3045,34 @@ package body Freeze is
elsif Is_Incomplete_Or_Private_Type (E)
and then not Is_Generic_Type (E)
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
- if Present (Full_View (E)) then
+ elsif Present (Full_View (E)) then
-- If full view has already been frozen, then no further
-- processing is required
@@ -4783,8 +4886,9 @@ package body Freeze is
return True;
end;
- else return not Is_Private_Type (T)
- or else Present (Full_View (Base_Type (T)));
+ else
+ return not Is_Private_Type (T)
+ or else Present (Full_View (Base_Type (T)));
end if;
end Is_Fully_Defined;
@@ -4818,7 +4922,6 @@ package body Freeze is
end if;
Formal := First_Formal (E);
-
while Present (Formal) loop
if Present (Default_Value (Formal)) then
@@ -4841,7 +4944,7 @@ package body Freeze is
and then not Vax_Float (Etype (Dcopy)))
or else Nkind (Dcopy) = N_Character_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
and then
Attribute_Name (Dcopy) = Name_Null_Parameter)
@@ -5180,7 +5283,7 @@ package body Freeze is
Error_Msg_N
("\use pragma Import for & to " &
- "suppress initialization ('R'M B.1(24))?",
+ "suppress initialization (RM B.1(24))?",
Nam);
end if;
end Warn_Overlay;
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index 125a706..13afe37 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -121,6 +121,12 @@ package Freeze is
-- base types, where the freeze node is preallocated at the point of
-- 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 --
-----------------
generated by cgit v1.1 at 2025-06-04 03:54:00 +0000