Skip to content

R
riscv-gcc-1
Commit 7ffd9312 by Arnaud Charlet
Options

sem_ch4.adb (Analyze_Selected_Component): Create Actual_Subtype even with expansion disabled. 

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

From-SVN: r94820
parent a3a0db2e
Showing with 149 additions and 21 deletions
gcc/ada/sem_ch4.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -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 :=
......
gcc/ada/sem_elab.adb
......@@ -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 --
----------------------
......
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