-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
elsif Nkind (Cont_Item) = N_Pragma
and then
- (Chars (Cont_Item) = Name_Elaborate
+ (Pragma_Name (Cont_Item) = Name_Elaborate
or else
- Chars (Cont_Item) = Name_Elaborate_All)
+ Pragma_Name (Cont_Item) = Name_Elaborate_All)
and then not Used_Type_Or_Elab
then
Prag_Unit :=
Set_Acts_As_Spec (N, False);
Set_Is_Child_Unit (Defining_Entity (Unit_Node));
- Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
+ Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS);
end;
end if;
Add_Stub_Constructs (N);
end if;
-
end if;
-- Remove unit from visibility, so that environment is clean for
then
Nam := Entity (Name (Item));
+ -- Compile generic subprogram, unless it is intrinsic or
+ -- imported so no body is required, or generic package body
+ -- if the package spec requires a body.
+
if (Is_Generic_Subprogram (Nam)
- and then not Is_Intrinsic_Subprogram (Nam))
+ and then not Is_Intrinsic_Subprogram (Nam)
+ and then not Is_Imported (Nam))
or else (Ekind (Nam) = E_Generic_Package
and then Unit_Requires_Body (Nam))
then
Item := First (Context_Items (N));
while Present (Item)
and then Nkind (Item) = N_Pragma
- and then Chars (Item) in Configuration_Pragma_Names
+ and then Pragma_Name (Item) in Configuration_Pragma_Names
loop
Analyze (Item);
Next (Item);
else
Optional_Subunit;
end if;
-
end Analyze_Proper_Body;
----------------------------------
begin
New_Nodes_OK := New_Nodes_OK + 1;
Withn :=
- Make_With_Clause (Loc, Name => Build_Unit_Name (Nam));
+ Make_With_Clause (Loc,
+ Name => Build_Unit_Name (Nam));
P := Parent (Unit_Declaration_Node (Ent));
- Set_Library_Unit (Withn, P);
- Set_Corresponding_Spec (Withn, Ent);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
+ Set_Library_Unit (Withn, P);
+ Set_Corresponding_Spec (Withn, Ent);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
-- If the unit is a package declaration, a private_with_clause on a
-- child unit implies that the implicit with on the parent is also
-- private.
if Nkind (Unit (N)) = N_Package_Declaration then
- Set_Private_Present (Withn, Private_Present (Item));
+ Set_Private_Present (Withn, Private_Present (Item));
end if;
Prepend (Withn, Context_Items (N));
if Nkind (Unit) = N_Package_Body
and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
then
- return
- Defining_Entity
- (Specification (Instance_Spec (Original_Node (Unit))));
-
+ return Defining_Entity
+ (Specification (Instance_Spec (Original_Node (Unit))));
elsif Nkind (Unit) = N_Package_Instantiation then
return Defining_Entity (Specification (Instance_Spec (Unit)));
-
else
return Defining_Entity (Unit);
end if;
end if;
Install_Limited_Context_Clauses (N);
-
end Install_Context;
-----------------------------
Item := First (Context_Items (N));
while Present (Item)
and then Nkind (Item) = N_Pragma
- and then Chars (Item) in Configuration_Pragma_Names
+ and then Pragma_Name (Item) in Configuration_Pragma_Names
loop
Next (Item);
end loop;
Item : Node_Id;
Id : Entity_Id;
Prev : Entity_Id;
+
begin
-- Iterate over explicit with clauses, and check whether the scope of
-- each entity is an ancestor of the current unit, in which case it is
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not Limited_Present (Item)
- and then Nkind (Unit (Library_Unit (Item)))
- = N_Package_Declaration
+ and then Nkind (Unit (Library_Unit (Item))) =
+ N_Package_Declaration
then
Decl :=
First (Visible_Declarations
Unum : constant Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
P : constant Entity_Id := Cunit_Entity (Unum);
- Spec : Node_Id; -- To denote a package specification
- Lim_Typ : Entity_Id; -- To denote shadow entities
- Comp_Typ : Entity_Id; -- To denote real entities
+ Spec : Node_Id; -- To denote a package specification
+ Lim_Typ : Entity_Id; -- To denote shadow entities
+ Comp_Typ : Entity_Id; -- To denote real entities
- Lim_Header : Entity_Id; -- Package entity
- Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
- Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
+ Lim_Header : Entity_Id; -- Package entity
+ Last_Lim_E : Entity_Id := Empty; -- Last limited entity built
+ Last_Pub_Lim_E : Entity_Id; -- To set the first private entity
procedure Decorate_Incomplete_Type
(E : Entity_Id;
Set_Non_Limited_View (Lim_Typ, Comp_Typ);
- elsif Nkind (Decl) = N_Private_Type_Declaration
- or else Nkind (Decl) = N_Incomplete_Type_Declaration
+ elsif Nkind_In (Decl, N_Private_Type_Declaration,
+ N_Incomplete_Type_Declaration)
then
Comp_Typ := Defining_Identifier (Decl);
Decorate_Package_Specification (Lim_Typ);
Set_Scope (Lim_Typ, Scope);
- Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
Set_Parent (Lim_Typ, Parent (Comp_Typ));
Set_From_With_Type (Lim_Typ);
-- Build the header of the limited_view
- Lim_Header := Make_Defining_Identifier (Sloc (N),
- Chars => New_Internal_Name (Id_Char => 'Z'));
+ Lim_Header :=
+ Make_Defining_Identifier (Sloc (N),
+ Chars => New_Internal_Name (Id_Char => 'Z'));
Set_Ekind (Lim_Header, E_Package);
Set_Is_Internal (Lim_Header);
Set_Limited_View (P, Lim_Header);
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
then
-
-- If private_with_clause is redundant, remove it from
-- context, as a small optimization to subsequent handling
-- of private_with clauses in other nested packages..
if In_Regular_With_Clause (Entity (Name (Item))) then
declare
Nxt : constant Node_Id := Next (Item);
-
begin
Remove (Item);
Item := Nxt;
P : constant Entity_Id := Scope (Unit_Name);
begin
-
if Debug_Flag_I then
Write_Str ("remove unit ");
Write_Name (Chars (Unit_Name));
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
function Find_Actual_Type
(Typ : Entity_Id;
- Gen_Scope : Entity_Id) return Entity_Id;
+ Gen_Type : Entity_Id) return Entity_Id;
-- When validating the actual types of a child instance, check whether
-- the formal is a formal type of the parent unit, and retrieve the current
-- actual for it. Typ is the entity in the analyzed formal type declaration
-- (component or index type of an array type, or designated type of an
- -- access formal) and Gen_Scope is the scope of the analyzed formal array
+ -- access formal) and Gen_Type is the enclosing analyzed formal array
-- or access type. The desired actual may be a formal of a parent, or may
-- be declared in a formal package of a parent. In both cases it is a
-- generic actual type because it appears within a visible instance.
+ -- Finally, it may be declared in a parent unit without being a formal
+ -- of that unit, in which case it must be retrieved by visibility.
-- Ambiguities may still arise if two homonyms are declared in two formal
-- packages, and the prefix of the formal type may be needed to resolve
-- the ambiguity in the instance ???
procedure Set_Analyzed_Formal is
Kind : Node_Kind;
+
begin
while Present (Analyzed_Formal) loop
Kind := Nkind (Analyzed_Formal);
(Defining_Unit_Name (Specification (Analyzed_Formal)));
when N_Formal_Package_Declaration =>
- exit when
- Kind = N_Formal_Package_Declaration
- or else
- Kind = N_Generic_Package_Declaration
- or else
- Kind = N_Package_Declaration;
+ exit when Nkind_In (Kind, N_Formal_Package_Declaration,
+ N_Generic_Package_Declaration,
+ N_Package_Declaration);
when N_Use_Package_Clause | N_Use_Type_Clause => exit;
exit when
Kind not in N_Formal_Subprogram_Declaration
- and then Kind /= N_Subprogram_Declaration
- and then Kind /= N_Freeze_Entity
- and then Kind /= N_Null_Statement
- and then Kind /= N_Itype_Reference
+ and then not Nkind_In (Kind, N_Subprogram_Declaration,
+ N_Freeze_Entity,
+ N_Null_Statement,
+ N_Itype_Reference)
and then Chars (Defining_Identifier (Formal)) =
Chars (Defining_Identifier (Analyzed_Formal));
end case;
while Present (Actual) loop
if Nkind (Actual) = N_Others_Choice then
Others_Present := True;
+
if Present (Next (Actual)) then
Error_Msg_N ("others must be last association", Actual);
end if;
-- to the outer instantiation.
if Nkind (Named) /= N_Others_Choice
- and then Present (Explicit_Generic_Actual_Parameter (Named))
+ and then Present (Explicit_Generic_Actual_Parameter (Named))
then
Num_Actuals := Num_Actuals + 1;
end if;
if Nkind (Def) = N_Constrained_Array_Definition then
DSS := First (Discrete_Subtype_Definitions (Def));
while Present (DSS) loop
- if Nkind (DSS) = N_Subtype_Indication
- or else Nkind (DSS) = N_Range
- or else Nkind (DSS) = N_Attribute_Reference
+ if Nkind_In (DSS, N_Subtype_Indication,
+ N_Range,
+ N_Attribute_Reference)
then
Error_Msg_N ("only a subtype mark is allowed in a formal", DSS);
end if;
elsif Is_Internal (Component_Type (T))
and then Present (Subtype_Indication (Component_Definition (Def)))
and then Nkind (Original_Node
- (Subtype_Indication (Component_Definition (Def))))
- = N_Subtype_Indication
+ (Subtype_Indication (Component_Definition (Def)))) =
+ N_Subtype_Indication
then
Error_Msg_N
("in a formal, a subtype indication can only be "
end if;
elsif Nkind (Def) = N_Indexed_Component then
-
if Nkind (Prefix (Def)) /= N_Selected_Component then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
Inline_Now := True;
-- In configurable_run_time mode we force the inlining of
- -- predefined subprogram marked Inline_Always, to minimize
+ -- predefined subprograms marked Inline_Always, to minimize
-- the use of the run-time library.
elsif Is_Predefined_File_Name
begin
if Nkind (Decl) = N_Formal_Package_Declaration
or else (Nkind (Decl) = N_Package_Declaration
- and then Is_List_Member (Decl)
- and then Present (Next (Decl))
- and then
- Nkind (Next (Decl)) = N_Formal_Package_Declaration)
+ and then Is_List_Member (Decl)
+ and then Present (Next (Decl))
+ and then
+ Nkind (Next (Decl)) =
+ N_Formal_Package_Declaration)
then
Needs_Body := False;
end if;
Set_Instance_Spec (N, Pack_Decl);
Set_Is_Generic_Instance (Pack_Id);
- Set_Needs_Debug_Info (Pack_Id);
+ Set_Debug_Info_Needed (Pack_Id);
-- Case of not a compilation unit
end if;
Set_Is_Generic_Instance (Anon_Id);
- Set_Needs_Debug_Info (Anon_Id);
+ Set_Debug_Info_Needed (Anon_Id);
Act_Decl_Id := New_Copy (Anon_Id);
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
-------------------------
function Get_Associated_Node (N : Node_Id) return Node_Id is
- Assoc : Node_Id := Associated_Node (N);
+ Assoc : Node_Id;
begin
+ Assoc := Associated_Node (N);
+
if Nkind (Assoc) /= Nkind (N) then
return Assoc;
- elsif Nkind (Assoc) = N_Aggregate
- or else Nkind (Assoc) = N_Extension_Aggregate
- then
+ elsif Nkind_In (Assoc, N_Aggregate, N_Extension_Aggregate) then
return Assoc;
else
if (Nkind (Assoc) = N_Identifier or else Nkind (Assoc) in N_Op)
and then Present (Associated_Node (Assoc))
- and then (Nkind (Associated_Node (Assoc)) = N_Function_Call
- or else
- Nkind (Associated_Node (Assoc)) = N_Explicit_Dereference
- or else
- Nkind (Associated_Node (Assoc)) = N_Integer_Literal
- or else
- Nkind (Associated_Node (Assoc)) = N_Real_Literal
- or else
- Nkind (Associated_Node (Assoc)) = N_String_Literal)
+ and then (Nkind_In (Associated_Node (Assoc), N_Function_Call,
+ N_Explicit_Dereference,
+ N_Integer_Literal,
+ N_Real_Literal,
+ N_String_Literal))
then
Assoc := Associated_Node (Assoc);
end if;
if Kind = N_Formal_Type_Declaration then
return;
- elsif Kind = N_Formal_Object_Declaration
+ elsif Nkind_In (Kind, N_Formal_Object_Declaration,
+ N_Formal_Package_Declaration)
or else Kind in N_Formal_Subprogram_Declaration
- or else Kind = N_Formal_Package_Declaration
then
null;
-- Special casing for identifiers and other entity names and operators
- elsif Nkind (New_N) = N_Identifier
- or else Nkind (New_N) = N_Character_Literal
- or else Nkind (New_N) = N_Expanded_Name
- or else Nkind (New_N) = N_Operator_Symbol
+ elsif Nkind_In (New_N, N_Identifier,
+ N_Character_Literal,
+ N_Expanded_Name,
+ N_Operator_Symbol)
or else Nkind (New_N) in N_Op
then
if not Instantiating then
elsif No (Ent)
or else
- not (Nkind (Ent) = N_Defining_Identifier
- or else
- Nkind (Ent) = N_Defining_Character_Literal
- or else
- Nkind (Ent) = N_Defining_Operator_Symbol)
+ not Nkind_In (Ent, N_Defining_Identifier,
+ N_Defining_Character_Literal,
+ N_Defining_Operator_Symbol)
or else No (Scope (Ent))
or else
(Scope (Ent) = Current_Instantiated_Parent.Gen_Id
and then not Is_Child_Unit (Ent))
- or else (Scope_Depth (Scope (Ent)) >
+ or else
+ (Scope_Depth (Scope (Ent)) >
Scope_Depth (Current_Instantiated_Parent.Gen_Id)
- and then
- Get_Source_Unit (Ent) =
- Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
+ and then
+ Get_Source_Unit (Ent) =
+ Get_Source_Unit (Current_Instantiated_Parent.Gen_Id))
then
Set_Associated_Node (New_N, Empty);
end if;
declare
Assoc : constant Node_Id := Get_Associated_Node (N);
+
begin
if Present (Assoc) then
if Nkind (Assoc) = Nkind (N) then
elsif Nkind (Assoc) = N_Function_Call then
Set_Entity (New_N, Entity (Name (Assoc)));
- elsif (Nkind (Assoc) = N_Defining_Identifier
- or else Nkind (Assoc) = N_Defining_Character_Literal
- or else Nkind (Assoc) = N_Defining_Operator_Symbol)
+ elsif Nkind_In (Assoc, N_Defining_Identifier,
+ N_Defining_Character_Literal,
+ N_Defining_Operator_Symbol)
and then Expander_Active
then
-- Inlining case: we are copying a tree that contains
Set_Assignment_OK (Name (New_N), True);
end if;
- elsif Nkind (N) = N_Aggregate
- or else Nkind (N) = N_Extension_Aggregate
- then
+ elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
if not Instantiating then
Set_Associated_Node (N, New_N);
and then Instantiating
then
declare
- Prag_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
-
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
begin
if Prag_Id = Pragma_Ident
or else Prag_Id = Pragma_Comment
then
New_N := Make_Null_Statement (Sloc (N));
-
else
Copy_Descendants;
end if;
end;
- elsif Nkind (N) = N_Integer_Literal
- or else Nkind (N) = N_Real_Literal
- or else Nkind (N) = N_String_Literal
+ elsif Nkind_In (N, N_Integer_Literal,
+ N_Real_Literal,
+ N_String_Literal)
then
-- No descendant fields need traversing
----------------------
function Find_Actual_Type
- (Typ : Entity_Id;
- Gen_Scope : Entity_Id) return Entity_Id
+ (Typ : Entity_Id;
+ Gen_Type : Entity_Id) return Entity_Id
is
- T : Entity_Id;
+ Gen_Scope : constant Entity_Id := Scope (Gen_Type);
+ T : Entity_Id;
begin
+ -- Special processing only applies to child units
+
if not Is_Child_Unit (Gen_Scope) then
return Get_Instance_Of (Typ);
+ -- If designated or component type is itself a formal of the child unit,
+ -- its instance is available.
+
+ elsif Scope (Typ) = Gen_Scope then
+ return Get_Instance_Of (Typ);
+
+ -- If the array or access type is not declared in the parent unit,
+ -- no special processing needed.
+
elsif not Is_Generic_Type (Typ)
- or else Scope (Typ) = Gen_Scope
+ and then Scope (Gen_Scope) /= Scope (Typ)
then
return Get_Instance_Of (Typ);
+ -- Otherwise, retrieve designated or component type by visibility
+
else
T := Current_Entity (Typ);
while Present (T) loop
or else
(Nkind (Enc_I) = N_Package_Body
and then
- In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
+ In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
then
-- The enclosing package may contain several instances. Rather
-- than computing the earliest point at which to insert its
if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then
return Package_Instantiation (A);
- elsif Nkind (Original_Node (Package_Instantiation (A)))
- = N_Package_Instantiation
+ elsif Nkind (Original_Node (Package_Instantiation (A))) =
+ N_Package_Instantiation
then
return Original_Node (Package_Instantiation (A));
end if;
else
Inst := Next (Decl);
- while Nkind (Inst) /= N_Package_Instantiation
- and then Nkind (Inst) /= N_Formal_Package_Declaration
+ while not Nkind_In (Inst, N_Package_Instantiation,
+ N_Formal_Package_Declaration)
loop
Next (Inst);
end loop;
if Nod = Decls then
return True;
- elsif Nkind (Nod) = N_Subprogram_Body
- or else Nkind (Nod) = N_Package_Body
- or else Nkind (Nod) = N_Task_Body
- or else Nkind (Nod) = N_Protected_Body
- or else Nkind (Nod) = N_Block_Statement
+ elsif Nkind_In (Nod, N_Subprogram_Body,
+ N_Package_Body,
+ N_Task_Body,
+ N_Protected_Body,
+ N_Block_Statement)
then
return False;
elsif Nkind (Nod) = N_Compilation_Unit then
return False;
+
else
Nod := Parent (Nod);
end if;
-- might produce false positives in rare cases, but guarantees
-- that we produce all the instance bodies we will need.
- if (Nkind (Nam) = N_Identifier
+ if (Is_Entity_Name (Nam)
and then Chars (Nam) = Chars (E))
or else (Nkind (Nam) = N_Selected_Component
and then Chars (Selector_Name (Nam)) = Chars (E))
-- Start of processing for Install_Body
begin
+
-- If the body is a subunit, the freeze point is the corresponding
-- stub in the current compilation, not the subunit itself.
Must_Delay :=
(Gen_Unit = Act_Unit
- and then ((Nkind (Gen_Unit) = N_Package_Declaration)
- or else Nkind (Gen_Unit) = N_Generic_Package_Declaration
+ and then (Nkind_In (Gen_Unit, N_Package_Declaration,
+ N_Generic_Package_Declaration)
or else (Gen_Unit = Body_Unit
and then True_Sloc (N) < Sloc (Orig_Body)))
and then Is_In_Main_Unit (Gen_Unit)
end if;
if (Present (Act_E) and then Is_Overloadable (Act_E))
- or else Nkind (Act) = N_Attribute_Reference
- or else Nkind (Act) = N_Indexed_Component
- or else Nkind (Act) = N_Character_Literal
- or else Nkind (Act) = N_Explicit_Dereference
+ or else Nkind_In (Act, N_Attribute_Reference,
+ N_Indexed_Component,
+ N_Character_Literal,
+ N_Explicit_Dereference)
then
return;
end if;
Nam := Actual;
elsif Present (Default_Name (Formal)) then
- if Nkind (Default_Name (Formal)) /= N_Attribute_Reference
- and then Nkind (Default_Name (Formal)) /= N_Selected_Component
- and then Nkind (Default_Name (Formal)) /= N_Indexed_Component
- and then Nkind (Default_Name (Formal)) /= N_Character_Literal
+ if not Nkind_In (Default_Name (Formal), N_Attribute_Reference,
+ N_Selected_Component,
+ N_Indexed_Component,
+ N_Character_Literal)
and then Present (Entity (Default_Name (Formal)))
then
Nam := New_Occurrence_Of (Entity (Default_Name (Formal)), Loc);
-- a child unit.
if Nkind (Actual) = N_Aggregate then
- Pre_Analyze_And_Resolve (Actual, Typ);
+ Pre_Analyze_And_Resolve (Actual, Typ);
end if;
if Is_Limited_Type (Typ)
if Ada_Version >= Ada_05
and then Present (Actual_Decl)
and then
- (Nkind (Actual_Decl) = N_Formal_Object_Declaration
- or else Nkind (Actual_Decl) = N_Object_Declaration)
+ Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
+ N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
and then Has_Null_Exclusion (Actual_Decl)
and then not Has_Null_Exclusion (Analyzed_Formal)
Scope_Suppress := Body_Info.Scope_Suppress;
if No (Gen_Body_Id) then
- Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
- Gen_Body_Id := Corresponding_Body (Gen_Decl);
+
+ -- For imported generic subprogram, no body to compile, complete
+ -- the spec entity appropriately.
+
+ if Is_Imported (Gen_Unit) then
+ Set_Is_Imported (Anon_Id);
+ Set_First_Rep_Item (Anon_Id, First_Rep_Item (Gen_Unit));
+ Set_Interface_Name (Anon_Id, Interface_Name (Gen_Unit));
+ Set_Convention (Anon_Id, Convention (Gen_Unit));
+ Set_Has_Completion (Anon_Id);
+ return;
+
+ -- For other cases, commpile the body
+
+ else
+ Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl));
+ Gen_Body_Id := Corresponding_Body (Gen_Decl);
+ end if;
end if;
Instantiation_Node := Inst_Node;
procedure Validate_Access_Type_Instance is
Desig_Type : constant Entity_Id :=
- Find_Actual_Type
- (Designated_Type (A_Gen_T), Scope (A_Gen_T));
+ Find_Actual_Type (Designated_Type (A_Gen_T), A_Gen_T);
+ Desig_Act : Entity_Id;
begin
if not Is_Access_Type (Act_T) then
-- by an access type declaration (and not by a subtype declaration)
-- must match.
- if not Subtypes_Match
- (Desig_Type, Designated_Type (Base_Type (Act_T)))
+ Desig_Act := Designated_Type (Base_Type (Act_T));
+
+ -- The designated type may have been introduced through a limited_
+ -- with clause, in which case retrieve the non-limited view.
+
+ if Ekind (Desig_Act) = E_Incomplete_Type
+ and then From_With_Type (Desig_Act)
then
+ Desig_Act := Available_View (Desig_Act);
+ end if;
+
+ if not Subtypes_Match
+ (Desig_Type, Desig_Act) then
Error_Msg_NE
("designated type of actual does not match that of formal &",
Actual, Gen_T);
end if;
if not Subtypes_Match
- (Find_Actual_Type (Etype (I1), Scope (A_Gen_T)), T2)
+ (Find_Actual_Type (Etype (I1), A_Gen_T), T2)
then
Error_Msg_NE
("index types of actual do not match those of formal &",
Next_Index (I2);
end loop;
- if not Subtypes_Match (
- Find_Actual_Type (Component_Type (A_Gen_T), Scope (A_Gen_T)),
- Component_Type (Act_T))
+ if not Subtypes_Match
+ (Find_Actual_Type (Component_Type (A_Gen_T), A_Gen_T),
+ Component_Type (Act_T))
then
Error_Msg_NE
("component subtype of actual does not match that of formal &",
("actual must have aliased components to match formal type &",
Actual, Gen_T);
end if;
-
end Validate_Array_Type_Instance;
-----------------------------------------------
else
Kind := Nkind (Parent (E));
return
- Kind = N_Formal_Object_Declaration
- or else Kind = N_Formal_Package_Declaration
- or else Kind = N_Formal_Type_Declaration
+ Nkind_In (Kind, N_Formal_Object_Declaration,
+ N_Formal_Package_Declaration,
+ N_Formal_Type_Declaration)
or else
(Is_Formal_Subprogram (E)
and then
end if;
if Errs /= Serious_Errors_Detected then
+
+ -- Do a minimal analysis of the generic, to prevent spurious
+ -- warnings complaining about the generic being unreferenced,
+ -- before abandoning the instantiation.
+
+ Analyze (Name (N));
+
+ if Is_Entity_Name (Name (N))
+ and then Etype (Name (N)) /= Any_Type
+ then
+ Generate_Reference (Entity (Name (N)), Name (N));
+ Set_Is_Instantiated (Entity (Name (N)));
+ end if;
+
Abandon_Instantiation (Act);
end if;
end if;
Restore_Private_Views (Empty);
end if;
- Current_Instantiated_Parent := Saved.Instantiated_Parent;
- Exchanged_Views := Saved.Exchanged_Views;
- Hidden_Entities := Saved.Hidden_Entities;
- Current_Sem_Unit := Saved.Current_Sem_Unit;
- Parent_Unit_Visible := Saved.Parent_Unit_Visible;
- Instance_Parent_Unit := Saved.Instance_Parent_Unit;
+ Current_Instantiated_Parent := Saved.Instantiated_Parent;
+ Exchanged_Views := Saved.Exchanged_Views;
+ Hidden_Entities := Saved.Hidden_Entities;
+ Current_Sem_Unit := Saved.Current_Sem_Unit;
+ Parent_Unit_Visible := Saved.Parent_Unit_Visible;
+ Instance_Parent_Unit := Saved.Instance_Parent_Unit;
Restore_Opt_Config_Switches (Saved.Switches);
return;
elsif Present (Associated_Formal_Package (Formal)) then
-
Ent := First_Entity (Formal);
while Present (Ent) loop
exit when Ekind (Ent) = E_Package
-- An unusual case of aliasing: the actual may also be directly
-- visible in the generic, and be private there, while it is fully
- -- visible in the context of the instance. The internal subtype is
- -- private in the instance, but has full visibility like its
+ -- visible in the context of the instance. The internal subtype
+ -- is private in the instance, but has full visibility like its
-- parent in the enclosing scope. This enforces the invariant that
-- the privacy status of all private dependents of a type coincide
-- with that of the parent type. This can only happen when a
-- If the actual is itself a formal package for the enclosing
-- generic, or the actual for such a formal package, it remains
- -- visible on exit from the instance, and therefore nothing
- -- needs to be done either, except to keep it accessible.
+ -- visible on exit from the instance, and therefore nothing needs
+ -- to be done either, except to keep it accessible.
if Is_Package
and then Renamed_Object (E) = Pack_Id
---------------
function Is_Global (E : Entity_Id) return Boolean is
- Se : Entity_Id := Scope (E);
+ Se : Entity_Id;
function Is_Instance_Node (Decl : Node_Id) return Boolean;
-- Determine whether the parent node of a reference to a child unit
elsif Is_Child_Unit (E)
and then (Is_Instance_Node (Parent (N2))
- or else (Nkind (Parent (N2)) = N_Expanded_Name
- and then N2 = Selector_Name (Parent (N2))
- and then Is_Instance_Node (Parent (Parent (N2)))))
+ or else (Nkind (Parent (N2)) = N_Expanded_Name
+ and then N2 = Selector_Name (Parent (N2))
+ and then
+ Is_Instance_Node (Parent (Parent (N2)))))
then
return True;
else
+ Se := Scope (E);
while Se /= Gen_Scope loop
if Se = Standard_Standard then
return True;
------------------
function Top_Ancestor (E : Entity_Id) return Entity_Id is
- Par : Entity_Id := E;
+ Par : Entity_Id;
begin
+ Par := E;
while Is_Child_Unit (Par) loop
Par := Scope (Par);
end loop;
-- its value. Otherwise the folding will happen in any instantiation,
elsif Nkind (Parent (N)) = N_Selected_Component
- and then (Nkind (Parent (N2)) = N_Integer_Literal
- or else Nkind (Parent (N2)) = N_Real_Literal)
+ and then Nkind_In (Parent (N2), N_Integer_Literal, N_Real_Literal)
then
if Present (Entity (Original_Node (Parent (N2))))
and then Is_Global (Entity (Original_Node (Parent (N2))))
if N = Empty then
null;
- elsif Nkind (N) = N_Character_Literal
- or else Nkind (N) = N_Operator_Symbol
- then
+ elsif Nkind_In (N, N_Character_Literal, N_Operator_Symbol) then
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
Reset_Entity (N);
Set_Etype (N, Empty);
end if;
- elsif Nkind (N2) = N_Integer_Literal
- or else Nkind (N2) = N_Real_Literal
- or else Nkind (N2) = N_String_Literal
+ elsif Nkind_In (N2, N_Integer_Literal,
+ N_Real_Literal,
+ N_String_Literal)
then
if Present (Original_Node (N2))
and then Nkind (Original_Node (N2)) = Nkind (N)
end if;
end if;
- -- Complete the check on operands, if node has not been
- -- constant-folded.
+ -- Complete operands check if node has not been constant-folded
if Nkind (N) in N_Op then
Save_Entity_Descendants (N);
Set_Etype (N, Empty);
end if;
- elsif
- (Nkind (N2) = N_Integer_Literal
- or else
- Nkind (N2) = N_Real_Literal)
+ elsif Nkind_In (N2, N_Integer_Literal, N_Real_Literal)
and then Is_Entity_Name (Original_Node (N2))
then
-- Name resolves to named number that is constant-folded,
-- traversal, so it needs direct access to node fields.
begin
- if Nkind (N) = N_Aggregate
- or else
- Nkind (N) = N_Extension_Aggregate
- then
+ if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then
N2 := Get_Associated_Node (N);
if No (N2) then
else
Typ := Etype (N2);
- -- In an instance within a generic, use the name of
- -- the actual and not the original generic parameter.
- -- If the actual is global in the current generic it
- -- must be preserved for its instantiation.
+ -- In an instance within a generic, use the name of the
+ -- actual and not the original generic parameter. If the
+ -- actual is global in the current generic it must be
+ -- preserved for its instantiation.
if Nkind (Parent (Typ)) = N_Subtype_Declaration
and then
if Nkind (N2) = Nkind (N)
and then
- (Nkind (Parent (N2)) = N_Procedure_Call_Statement
- or else Nkind (Parent (N2)) = N_Function_Call)
+ Nkind_In (Parent (N2), N_Procedure_Call_Statement,
+ N_Function_Call)
and then Comes_From_Source (Typ)
then
if Is_Immediately_Visible (Scope (Typ)) then
OSDN Git Service
