[multiple changes]
2009-07-22 Thomas Quinot <quinot@adacore.com> * sem_elab.adb (Insert_Elab_Check): When relocating an overloaded expression to insert an elab check using a conditional expression, be sure to carry the original list of interpretations to the new location. 2009-07-22 Gary Dismukes <dismukes@adacore.com> * gnat1drv.adb: Fix spelling error. 2009-07-22 Javier Miranda <miranda@adacore.com> * sem_type.ads, sem_type.adb (In_Generic_Actual): Leave this subprogram at the library level and fix a hidden bug in its implementation: its functionality for renaming objects was broken because N_Object_Renaming_Declarations nodes are not a subclass of N_Declaration nodes (as documented in sinfo.ads). * sem_util.adb (Check_Dynamically_Tagged_Expression): Include in this check nodes that are actuals of generic instantiations. 2009-07-22 Ed Schonberg <schonberg@adacore.com> * sinfo.ads, sinfo.adb (Pending_Context): New flag to indicate that the context of a compilation unit is being analyzed. Used to detect circularities created by with_clauses that are not detected by the loading machinery. * sem_ch10.adb (Analyze_Compilation_Unit): Set Pending_Context before analyzing the context of the current compilation unit, to detect possible circularities created by with_clauses. From-SVN: r149925
This commit is contained in:
Arnaud Charlet
parent
4eb317ccce
commit
f625663199
|
|
@ -1,3 +1,33 @@
|
|||
2009-07-22 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* sem_elab.adb (Insert_Elab_Check): When relocating an overloaded
|
||||
expression to insert an elab check using a conditional expression, be
|
||||
sure to carry the original list of interpretations to the new location.
|
||||
|
||||
2009-07-22 Gary Dismukes <dismukes@adacore.com>
|
||||
|
||||
* gnat1drv.adb: Fix spelling error.
|
||||
|
||||
2009-07-22 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* sem_type.ads, sem_type.adb (In_Generic_Actual): Leave this subprogram
|
||||
at the library level and fix a hidden bug in its implementation: its
|
||||
functionality for renaming objects was broken because
|
||||
N_Object_Renaming_Declarations nodes are not a subclass of
|
||||
N_Declaration nodes (as documented in sinfo.ads).
|
||||
* sem_util.adb (Check_Dynamically_Tagged_Expression): Include in this
|
||||
check nodes that are actuals of generic instantiations.
|
||||
|
||||
2009-07-22 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sinfo.ads, sinfo.adb (Pending_Context): New flag to indicate that the
|
||||
context of a compilation unit is being analyzed. Used to detect
|
||||
circularities created by with_clauses that are not detected by the
|
||||
loading machinery.
|
||||
* sem_ch10.adb (Analyze_Compilation_Unit): Set Pending_Context before
|
||||
analyzing the context of the current compilation unit, to detect
|
||||
possible circularities created by with_clauses.
|
||||
|
||||
2009-07-22 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* sem_type.adb (Get_First_Interp): Fix wrong loop exit condition.
|
||||
|
|
|
|||
|
|
@ -159,7 +159,7 @@ procedure Gnat1drv is
|
|||
ASIS_Mode := False;
|
||||
|
||||
-- Suppress overflow checks and access checks since they are handled
|
||||
-- implicitely by CodePeer.
|
||||
-- implicitly by CodePeer.
|
||||
|
||||
-- Turn off dynamic elaboration checks: generates inconsistencies in
|
||||
-- trees between specs compiled as part of a main unit or as part of
|
||||
|
|
|
|||
|
|
@ -661,9 +661,59 @@ package body Sem_Ch10 is
|
|||
end if;
|
||||
|
||||
-- Analyze context (this will call Sem recursively for with'ed units)
|
||||
-- To detect circularities among with-clauses that are not caught during
|
||||
-- loading, we set the Context_Pending flag on the current unit. If the
|
||||
-- flag is already set there is a potential circularity.
|
||||
-- We exclude predefined units from this check because they are known
|
||||
-- to be safe. we also exclude package bodies that are present because
|
||||
-- circularities between bodies are harmless (and necessary).
|
||||
|
||||
if Context_Pending (N) then
|
||||
declare
|
||||
Circularity : Boolean := True;
|
||||
|
||||
begin
|
||||
if Is_Predefined_File_Name
|
||||
(Unit_File_Name (Get_Source_Unit (Unit (N))))
|
||||
then
|
||||
Circularity := False;
|
||||
|
||||
else
|
||||
for U in Main_Unit + 1 .. Last_Unit loop
|
||||
if Nkind (Unit (Cunit (U))) = N_Package_Body
|
||||
and then not Analyzed (Cunit (U))
|
||||
then
|
||||
Circularity := False;
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
if Circularity then
|
||||
Error_Msg_N
|
||||
("circular dependency caused by with_clauses", N);
|
||||
Error_Msg_N
|
||||
("\possibly missing limited_with clause"
|
||||
& " in one of the following", N);
|
||||
|
||||
for U in Main_Unit .. Last_Unit loop
|
||||
if Context_Pending (Cunit (U)) then
|
||||
Error_Msg_Unit_1 := Get_Unit_Name (Unit (Cunit (U)));
|
||||
Error_Msg_N ("\unit$", N);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
raise Unrecoverable_Error;
|
||||
end if;
|
||||
end;
|
||||
else
|
||||
Set_Context_Pending (N);
|
||||
end if;
|
||||
|
||||
Analyze_Context (N);
|
||||
|
||||
Set_Context_Pending (N, False);
|
||||
|
||||
-- If the unit is a package body, the spec is already loaded and must be
|
||||
-- analyzed first, before we analyze the body.
|
||||
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ with Sem_Cat; use Sem_Cat;
|
|||
with Sem_Ch7; use Sem_Ch7;
|
||||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Res; use Sem_Res;
|
||||
with Sem_Type; use Sem_Type;
|
||||
with Sem_Util; use Sem_Util;
|
||||
with Sinfo; use Sinfo;
|
||||
with Sinput; use Sinput;
|
||||
|
|
@ -939,9 +940,7 @@ package body Sem_Elab is
|
|||
Insert_Elab_Check (N,
|
||||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Elaborated,
|
||||
Prefix =>
|
||||
New_Occurrence_Of
|
||||
(Spec_Entity (E_Scope), Loc)));
|
||||
Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
|
||||
end if;
|
||||
|
||||
-- Case of static elaboration model
|
||||
|
|
@ -2415,8 +2414,7 @@ package body Sem_Elab is
|
|||
Make_Attribute_Reference (Loc,
|
||||
Attribute_Name => Name_Elaborated,
|
||||
Prefix =>
|
||||
New_Occurrence_Of
|
||||
(Spec_Entity (Task_Scope), Loc)));
|
||||
New_Occurrence_Of (Spec_Entity (Task_Scope), Loc)));
|
||||
end if;
|
||||
|
||||
else
|
||||
|
|
@ -2852,6 +2850,8 @@ package body Sem_Elab is
|
|||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Access_Before_Elaboration);
|
||||
|
||||
Reloc_N : Node_Id;
|
||||
|
||||
begin
|
||||
Set_Etype (R, Typ);
|
||||
|
||||
|
|
@ -2859,9 +2859,11 @@ package body Sem_Elab is
|
|||
Rewrite (N, R);
|
||||
|
||||
else
|
||||
Reloc_N := Relocate_Node (N);
|
||||
Save_Interps (N, Reloc_N);
|
||||
Rewrite (N,
|
||||
Make_Conditional_Expression (Loc,
|
||||
Expressions => New_List (C, Relocate_Node (N), R)));
|
||||
Expressions => New_List (C, Reloc_N, R)));
|
||||
end if;
|
||||
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
|
|
|
|||
|
|
@ -1147,8 +1147,7 @@ package body Sem_Type is
|
|||
function Disambiguate
|
||||
(N : Node_Id;
|
||||
I1, I2 : Interp_Index;
|
||||
Typ : Entity_Id)
|
||||
return Interp
|
||||
Typ : Entity_Id) return Interp
|
||||
is
|
||||
I : Interp_Index;
|
||||
It : Interp;
|
||||
|
|
@ -1161,13 +1160,6 @@ package body Sem_Type is
|
|||
-- Determine whether one of the candidates is an operation inherited by
|
||||
-- a type that is derived from an actual in an instantiation.
|
||||
|
||||
function In_Generic_Actual (Exp : Node_Id) return Boolean;
|
||||
-- Determine whether the expression is part of a generic actual. At
|
||||
-- the time the actual is resolved the scope is already that of the
|
||||
-- instance, but conceptually the resolution of the actual takes place
|
||||
-- in the enclosing context, and no special disambiguation rules should
|
||||
-- be applied.
|
||||
|
||||
function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
|
||||
-- Determine whether a subprogram is an actual in an enclosing instance.
|
||||
-- An overloading between such a subprogram and one declared outside the
|
||||
|
|
@ -1204,34 +1196,6 @@ package body Sem_Type is
|
|||
-- for special handling of expressions with universal operands, see
|
||||
-- comments to Has_Abstract_Interpretation below.
|
||||
|
||||
-----------------------
|
||||
-- In_Generic_Actual --
|
||||
-----------------------
|
||||
|
||||
function In_Generic_Actual (Exp : Node_Id) return Boolean is
|
||||
Par : constant Node_Id := Parent (Exp);
|
||||
|
||||
begin
|
||||
if No (Par) then
|
||||
return False;
|
||||
|
||||
elsif Nkind (Par) in N_Declaration then
|
||||
if Nkind (Par) = N_Object_Declaration
|
||||
or else Nkind (Par) = N_Object_Renaming_Declaration
|
||||
then
|
||||
return Present (Corresponding_Generic_Association (Par));
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
|
||||
return False;
|
||||
|
||||
else
|
||||
return In_Generic_Actual (Parent (Par));
|
||||
end if;
|
||||
end In_Generic_Actual;
|
||||
|
||||
---------------------------
|
||||
-- Inherited_From_Actual --
|
||||
---------------------------
|
||||
|
|
@ -1260,7 +1224,7 @@ package body Sem_Type is
|
|||
return In_Open_Scopes (Scope (S))
|
||||
and then
|
||||
(Is_Generic_Instance (Scope (S))
|
||||
or else Is_Wrapper_Package (Scope (S)));
|
||||
or else Is_Wrapper_Package (Scope (S)));
|
||||
end Is_Actual_Subprogram;
|
||||
|
||||
-------------
|
||||
|
|
@ -1274,8 +1238,7 @@ package body Sem_Type is
|
|||
return T1 = T2
|
||||
or else
|
||||
(Is_Numeric_Type (T2)
|
||||
and then
|
||||
(T1 = Universal_Real or else T1 = Universal_Integer));
|
||||
and then (T1 = Universal_Real or else T1 = Universal_Integer));
|
||||
end Matches;
|
||||
|
||||
------------------------
|
||||
|
|
@ -1417,9 +1380,8 @@ package body Sem_Type is
|
|||
elsif Present (Act2)
|
||||
and then Nkind (Act2) in N_Op
|
||||
and then Is_Overloaded (Act2)
|
||||
and then (Nkind (Right_Opnd (Act2)) = N_Integer_Literal
|
||||
or else
|
||||
Nkind (Right_Opnd (Act2)) = N_Real_Literal)
|
||||
and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
|
||||
N_Real_Literal)
|
||||
and then Has_Compatible_Type (Act2, Standard_Boolean)
|
||||
then
|
||||
-- The preference rule on the first actual is not
|
||||
|
|
@ -2526,6 +2488,35 @@ package body Sem_Type is
|
|||
return Typ;
|
||||
end Intersect_Types;
|
||||
|
||||
-----------------------
|
||||
-- In_Generic_Actual --
|
||||
-----------------------
|
||||
|
||||
function In_Generic_Actual (Exp : Node_Id) return Boolean is
|
||||
Par : constant Node_Id := Parent (Exp);
|
||||
|
||||
begin
|
||||
if No (Par) then
|
||||
return False;
|
||||
|
||||
elsif Nkind (Par) in N_Declaration then
|
||||
if Nkind (Par) = N_Object_Declaration then
|
||||
return Present (Corresponding_Generic_Association (Par));
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
elsif Nkind (Par) = N_Object_Renaming_Declaration then
|
||||
return Present (Corresponding_Generic_Association (Par));
|
||||
|
||||
elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
|
||||
return False;
|
||||
|
||||
else
|
||||
return In_Generic_Actual (Parent (Par));
|
||||
end if;
|
||||
end In_Generic_Actual;
|
||||
|
||||
-----------------
|
||||
-- Is_Ancestor --
|
||||
-----------------
|
||||
|
|
|
|||
|
|
@ -211,6 +211,12 @@ package Sem_Type is
|
|||
-- interpretations is universal, choose the non-universal one. If either
|
||||
-- node is overloaded, find single common interpretation.
|
||||
|
||||
function In_Generic_Actual (Exp : Node_Id) return Boolean;
|
||||
-- Determine whether the expression is part of a generic actual. At the
|
||||
-- time the actual is resolved the scope is already that of the instance,
|
||||
-- but conceptually the resolution of the actual takes place in the
|
||||
-- enclosing context and no special disambiguation rules should be applied.
|
||||
|
||||
function Is_Ancestor (T1, T2 : Entity_Id) return Boolean;
|
||||
-- T1 is a tagged type (not class-wide). Verify that it is one of the
|
||||
-- ancestors of type T2 (which may or not be class-wide).
|
||||
|
|
|
|||
|
|
@ -1045,7 +1045,12 @@ package body Sem_Util is
|
|||
begin
|
||||
pragma Assert (Is_Tagged_Type (Typ));
|
||||
|
||||
if Comes_From_Source (Related_Nod)
|
||||
-- In order to avoid spurious errors when analyzing the expanded code
|
||||
-- this check is done only for nodes that come from source and for
|
||||
-- actuals of generic instantiations
|
||||
|
||||
if (Comes_From_Source (Related_Nod)
|
||||
or else In_Generic_Actual (Expr))
|
||||
and then (Is_Class_Wide_Type (Etype (Expr))
|
||||
or else Is_Dynamically_Tagged (Expr))
|
||||
and then Is_Tagged_Type (Typ)
|
||||
|
|
|
|||
|
|
@ -549,6 +549,14 @@ package body Sinfo is
|
|||
return List1 (N);
|
||||
end Context_Items;
|
||||
|
||||
function Context_Pending
|
||||
(N : Node_Id) return Boolean is
|
||||
begin
|
||||
pragma Assert (False
|
||||
or else NT (N).Nkind = N_Compilation_Unit);
|
||||
return Flag16 (N);
|
||||
end Context_Pending;
|
||||
|
||||
function Controlling_Argument
|
||||
(N : Node_Id) return Node_Id is
|
||||
begin
|
||||
|
|
@ -3364,6 +3372,14 @@ package body Sinfo is
|
|||
Set_List1_With_Parent (N, Val);
|
||||
end Set_Context_Items;
|
||||
|
||||
procedure Set_Context_Pending
|
||||
(N : Node_Id; Val : Boolean := True) is
|
||||
begin
|
||||
pragma Assert (False
|
||||
or else NT (N).Nkind = N_Compilation_Unit);
|
||||
Set_Flag16 (N, Val);
|
||||
end Set_Context_Pending;
|
||||
|
||||
procedure Set_Controlling_Argument
|
||||
(N : Node_Id; Val : Node_Id) is
|
||||
begin
|
||||
|
|
|
|||
|
|
@ -698,6 +698,13 @@ package Sinfo is
|
|||
-- package Exp_Util, and also the expansion routines for the relevant
|
||||
-- nodes.
|
||||
|
||||
-- Context_Pending (Flag16-Sem)
|
||||
-- This field appears in Compilation_Unit nodes, to indicate that the
|
||||
-- context of the unit is being compiled. Used to detect circularities
|
||||
-- that are not otherwise detected by the loading mechanism. Such
|
||||
-- circularities can occur in the presence of limited and non-limited
|
||||
-- with_clauses that mention the same units.
|
||||
|
||||
-- Controlling_Argument (Node1-Sem)
|
||||
-- This field is set in procedure and function call nodes if the call
|
||||
-- is a dispatching call (it is Empty for a non-dispatching call). It
|
||||
|
|
@ -5393,6 +5400,7 @@ package Sinfo is
|
|||
-- Has_No_Elaboration_Code (Flag17-Sem)
|
||||
-- Body_Required (Flag13-Sem) set for spec if body is required
|
||||
-- Acts_As_Spec (Flag4-Sem) flag for subprogram body with no spec
|
||||
-- Context_Pending (Flag16-Sem)
|
||||
-- First_Inlined_Subprogram (Node3-Sem)
|
||||
|
||||
-- N_Compilation_Unit_Aux
|
||||
|
|
@ -7678,6 +7686,9 @@ package Sinfo is
|
|||
function Context_Installed
|
||||
(N : Node_Id) return Boolean; -- Flag13
|
||||
|
||||
function Context_Pending
|
||||
(N : Node_Id) return Boolean; -- Flag16
|
||||
|
||||
function Context_Items
|
||||
(N : Node_Id) return List_Id; -- List1
|
||||
|
||||
|
|
@ -8578,6 +8589,9 @@ package Sinfo is
|
|||
procedure Set_Context_Items
|
||||
(N : Node_Id; Val : List_Id); -- List1
|
||||
|
||||
procedure Set_Context_Pending
|
||||
(N : Node_Id; Val : Boolean := True); -- Flag16
|
||||
|
||||
procedure Set_Controlling_Argument
|
||||
(N : Node_Id; Val : Node_Id); -- Node1
|
||||
|
||||
|
|
@ -11009,6 +11023,7 @@ package Sinfo is
|
|||
pragma Inline (Constraints);
|
||||
pragma Inline (Context_Installed);
|
||||
pragma Inline (Context_Items);
|
||||
pragma Inline (Context_Pending);
|
||||
pragma Inline (Controlling_Argument);
|
||||
pragma Inline (Conversion_OK);
|
||||
pragma Inline (Corresponding_Body);
|
||||
|
|
@ -11305,6 +11320,7 @@ package Sinfo is
|
|||
pragma Inline (Set_Constraints);
|
||||
pragma Inline (Set_Context_Installed);
|
||||
pragma Inline (Set_Context_Items);
|
||||
pragma Inline (Set_Context_Pending);
|
||||
pragma Inline (Set_Controlling_Argument);
|
||||
pragma Inline (Set_Conversion_OK);
|
||||
pragma Inline (Set_Corresponding_Body);
|
||||
|
|
|
|||
Loading…
Reference in New Issue