[Ada] fix bug in handling of elaboration
Arnaud Charlet
charlet@adacore.com
Thu Feb 10 18:44:00 GMT 2005
Tested under i686-linux, commited on mainline.
An initialization call can mention a function F declared in some unit P
that is not in the context of the current compilation. This can also
happen when using object notation with a call to a classwide operation:
the operation is declared in the root package of the class, but the
current compilation only has a with_clause on a package that declares
some other member of the class. In both these cases, the must be some
other unit Q in the context, from which the current unit imports a type
or an object that brings in the function. We locate Q from the subtype
of the object being declared, or from the type of the first actual in
the call to the classwide operation. An Elaborate_All_Desirable on Q
will ensure that P itself is fully elaborated before the current unit.
The following test case (main procedure try.adb) must compile and execute
quietly:
package A1 is
type Rec is tagged record value : Integer := 15; end record;
function G (X : Rec'Class) return Integer;
end A1;
with B;
package body A1 is
function G (X : Rec'Class) return Integer is
begin return X.Value * B.Func; end;
end A1;
with A1;
package A2 is type Rec2 is new A1.Rec with null record; end A2;
with A2;
package a3 is
Thing: A2.Rec2;
Val3 : Integer := Thing.G; -- A1.Thing
end;
package B is function func return integer; end;
with D;
package body B is
type enum is (this, that, theother);
table : array (enum) of integer;
function func return Integer is begin return (table (theother)); end;
begin
table := (3, 7, 19);
end B;
package D is type unrelated is (it); end;
with a3;
with text_io; use text_io;
procedure try is
begin
if (a3.val3) /= 285 then put_line ("*** FAILED ***"); end if;
end;
2005-02-09 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Selected_Component): Create Actual_Subtype even
with expansion disabled. The actual subtype is needed among other
places when the selected component appears in the context of a loop
bound, and denotes a packed array.
(Operator_Check): Always use the first subtype in the
error message, to avoid the appearance of internal base types.
(Transform_Object_Operation): Copy each actual in full
to the parameter associations of the constructed call, rather than
using the shallow copy mechanism of New_Copy_List. This ensures that
the chaining of named associations is done properly.
(Complete_Object_Operation): Rewrite node, rather than
replacing it, so that we can trace back to the original selected
component.
* sem_elab.adb (Set_Elaboration_Constraint): For initialization calls,
and calls that use object notation, if the called function is not
declared in a withed unit, place the elaboration constraint on the
unit in the context that makes the function accessible.
(Check_Elab_Subtype_Declaration): Check whether a subtype declaration
imposes an elaboration constraint between two packages.
-------------- next part --------------
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.35
diff -u -p -r1.35 sem_ch4.adb
--- sem_ch4.adb 3 Jan 2005 15:41:36 -0000 1.35
+++ sem_ch4.adb 10 Feb 2005 11:48:12 -0000
@@ -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- --
@@ -2650,10 +2650,7 @@ package body Sem_Ch4 is
-- not make an actual subtype, we end up getting a direct
-- reference to a discriminant which will not do.
- -- Comment needs revision, "in all other cases" does not
- -- reasonably describe the situation below with an elsif???
-
- elsif Expander_Active then
+ else
Act_Decl :=
Build_Actual_Subtype_Of_Component (Etype (Comp), N);
Insert_Action (N, Act_Decl);
@@ -2675,9 +2672,6 @@ package body Sem_Ch4 is
Set_Etype (N, Subt);
end;
end if;
-
- else
- Set_Etype (N, Etype (Comp));
end if;
return;
@@ -4400,7 +4394,7 @@ package body Sem_Ch4 is
and then not Is_Overloaded (R)
and then Base_Type (Etype (L)) = Base_Type (Etype (R))
then
- Error_Msg_Node_2 := Etype (R);
+ Error_Msg_Node_2 := First_Subtype (Etype (R));
Error_Msg_N ("there is no applicable operator& for}", N);
else
@@ -4799,7 +4793,7 @@ package body Sem_Ch4 is
begin
Set_Name (Call_Node, New_Copy_Tree (Subprog));
Set_Analyzed (Call_Node, False);
- Replace (Node_To_Replace, Call_Node);
+ Rewrite (Node_To_Replace, Call_Node);
Analyze (Node_To_Replace);
end Complete_Object_Operation;
@@ -4830,8 +4824,19 @@ package body Sem_Ch4 is
then
Node_To_Replace := Parent_Node;
- Append_List_To (Actuals,
- New_Copy_List (Parameter_Associations (Parent_Node)));
+ -- Copy list of actuals in full before attempting to resolve call.
+ -- This is necessary to ensure that the chaining of named actuals
+ -- that happens during matching is done on a separate copy.
+
+ declare
+ Actual : Node_Id;
+ begin
+ Actual := First (Parameter_Associations (Parent_Node));
+ while Present (Actual) loop
+ Append (New_Copy_Tree (Actual), Actuals);
+ Next (Actual);
+ end loop;
+ end;
if Nkind (Parent_Node) = N_Procedure_Call_Statement then
Call_Node :=
Index: sem_elab.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_elab.adb,v
retrieving revision 1.16
diff -u -p -r1.16 sem_elab.adb
--- sem_elab.adb 27 Oct 2004 13:54:38 -0000 1.16
+++ sem_elab.adb 10 Feb 2005 11:48:12 -0000
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
@@ -159,7 +159,7 @@ package body Sem_Elab is
-- Local Subprograms --
-----------------------
- -- Note: Outer_Scope in all these calls represents the scope of
+ -- Note: Outer_Scope in all following specs represents the scope of
-- interest of the outer level call. If it is set to Standard_Standard,
-- then it means the outer level call was at elaboration level, and that
-- thus all calls are of interest. If it was set to some other scope,
@@ -224,6 +224,29 @@ package body Sem_Elab is
-- to Check_Internal_Call. Outer_Scope is the outer level scope for
-- the original call.
+ procedure Set_Elaboration_Constraint
+ (Call : Node_Id;
+ Subp : Entity_Id;
+ Scop : Entity_Id);
+ -- The current unit U may depend semantically on some unit P which is not
+ -- in the current context. If there is an elaboration call that reaches P,
+ -- we need to indicate that P requires an Elaborate_All, but this is not
+ -- effective in U's ali file, if there is no with_clause for P. In this
+ -- case we add the Elaborate_All on the unit Q that directly or indirectly
+ -- makes P available. This can happen in two cases:
+ --
+ -- a) Q declares a subtype of a type declared in P, and the call is an
+ -- initialization call for an object of that subtype.
+ --
+ -- b) Q declares an object of some tagged type whose root type is
+ -- declared in P, and the initialization call uses object notation on
+ -- that object to reach a primitive operation or a classwide operation
+ -- declared in P.
+ --
+ -- If P appears in the context of U, the current processing is correct.
+ -- Otherwise we must identify these two cases to retrieve Q and place the
+ -- Elaborate_All_Desirable on it.
+
function Has_Generic_Body (N : Node_Id) return Boolean;
-- N is a generic package instantiation node, and this routine determines
-- if this package spec does in fact have a generic body. If so, then
@@ -308,11 +331,16 @@ package body Sem_Elab is
-- elaboration check is required.
W_Scope : Entity_Id;
- -- Top level scope of directly called entity for subprogram.
- -- This differs from E_Scope in the case where renamings or
- -- derivations are involved, since it does not follow these
- -- links, thus W_Scope is always in a visible unit. This is
- -- the scope for the Elaborate_All if one is needed.
+ -- Top level scope of directly called entity for subprogram. This
+ -- differs from E_Scope in the case where renamings or derivations
+ -- are involved, since it does not follow these links. W_Scope is
+ -- generally in a visible unit, and it is this scope that may require
+ -- an Elaborate_All. However, there are some cases (initialization
+ -- calls and calls involving object notation) where W_Scope might not
+ -- be in the context of the current unit, and there is an intermediate
+ -- package that is, in which case the Elaborate_All has to be placed
+ -- on this intedermediate package. These special cases are handled in
+ -- Set_Elaboration_Constraint.
Body_Acts_As_Spec : Boolean;
-- Set to true if call is to body acting as spec (no separate spec)
@@ -751,8 +779,7 @@ package body Sem_Elab is
-- Set indication for binder to generate Elaborate_All
- Set_Elaborate_All_Desirable (W_Scope);
- Set_Suppress_Elaboration_Warnings (W_Scope, True);
+ Set_Elaboration_Constraint (N, E, W_Scope);
end if;
end if;
@@ -1345,6 +1372,12 @@ package body Sem_Elab is
return;
end if;
+ -- Nothing to do if the instantiation is not in the main unit.
+
+ if not In_Extended_Main_Code_Unit (N) then
+ return;
+ end if;
+
Ent := Get_Generic_Entity (N);
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
@@ -2000,6 +2033,96 @@ package body Sem_Elab is
In_Task_Activation := False;
end Check_Task_Activation;
+ --------------------------------
+ -- Set_Elaboration_Constraint --
+ --------------------------------
+
+ procedure Set_Elaboration_Constraint
+ (Call : Node_Id;
+ Subp : Entity_Id;
+ Scop : Entity_Id)
+ is
+ Elab_Unit : Entity_Id;
+ Init_Call : constant Boolean :=
+ Chars (Subp) = Name_Initialize
+ and then Comes_From_Source (Subp)
+ and then Present (Parameter_Associations (Call))
+ and then Is_Controlled
+ (Etype (First (Parameter_Associations (Call))));
+ begin
+ -- If the unit is mentioned in a with_clause of the current
+ -- unit, it is visible, and we can set the elaboration flag.
+
+ if Is_Immediately_Visible (Scop)
+ or else
+ (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
+ then
+ Set_Elaborate_All_Desirable (Scop);
+ Set_Suppress_Elaboration_Warnings (Scop, True);
+ return;
+ end if;
+
+ -- If this is not an initialization call or a call using object notation
+ -- we know that the unit of the called entity is in the context, and
+ -- we can set the flag as well. The unit need not be visible if the call
+ -- occurs within an instantiation.
+
+ if Is_Init_Proc (Subp)
+ or else Init_Call
+ or else Nkind (Original_Node (Call)) = N_Selected_Component
+ then
+ null; -- detailed processing follows.
+
+ else
+ Set_Elaborate_All_Desirable (Scop);
+ Set_Suppress_Elaboration_Warnings (Scop, True);
+ return;
+ end if;
+
+ -- If the unit is not in the context, there must be an intermediate
+ -- unit that is, on which we need to place to elaboration flag.
+
+ if Is_Init_Proc (Subp)
+ or else Init_Call
+ then
+ -- The initialization call is on an object whose type is not
+ -- declared in the same scope as the subprogram. The type of
+ -- the object must be a subtype of the type of operation. This
+ -- object is the first actual in the call.
+
+ declare
+ Typ : constant Entity_Id :=
+ Etype (First (Parameter_Associations (Call)));
+ begin
+ Elab_Unit := Scope (Typ);
+
+ while (Present (Elab_Unit))
+ and then not Is_Compilation_Unit (Elab_Unit)
+ loop
+ Elab_Unit := Scope (Elab_Unit);
+ end loop;
+ end;
+ elsif Nkind (Original_Node (Call)) = N_Selected_Component then
+
+ -- If original node uses selected component notation, the
+ -- prefix is visible and determines the scope that must be
+ -- elaborated. After rewriting, the prefix is the first actual
+ -- in the call.
+
+ Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
+
+ else
+ -- Using previously computed scope. If the elaboration check is
+ -- done after analysis, the scope is not visible any longer, but
+ -- must still be in the context.
+
+ Elab_Unit := Scop;
+ end if;
+
+ Set_Elaborate_All_Desirable (Elab_Unit);
+ Set_Suppress_Elaboration_Warnings (Elab_Unit, True);
+ end Set_Elaboration_Constraint;
+
----------------------
-- Has_Generic_Body --
----------------------
More information about the Gcc-patches
mailing list