* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149925
138bc75d-0d04-0410-961f-
82ee72b054a4
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.
2009-07-22 Robert Dewar <dewar@adacore.com>
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
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.
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;
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
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
Make_Raise_Program_Error (Loc,
Reason => PE_Access_Before_Elaboration);
+ Reloc_N : Node_Id;
+
begin
Set_Etype (R, Typ);
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);
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;
-- 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
-- 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 --
---------------------------
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;
-------------
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;
------------------------
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
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 --
-----------------
-- 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).
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)
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
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
-- 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
-- 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
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
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
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);
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);
OSDN Git Service
