-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2004, 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- --
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Rident; use Rident;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
-- generic is unit is validated, Set_Instance_Env completes Save_Env.
type Instance_Env is record
- Ada_83 : Boolean;
+ Ada_Version : Ada_Version_Type;
Instantiated_Parent : Assoc;
Exchanged_Views : Elist_Id;
Hidden_Entities : Elist_Id;
F_Copy : List_Id)
return List_Id
is
- Actual_Types : constant Elist_Id := New_Elmt_List;
- Assoc : constant List_Id := New_List;
- Defaults : constant Elist_Id := New_Elmt_List;
+ Actual_Types : constant Elist_Id := New_Elmt_List;
+ Assoc : constant List_Id := New_List;
+ Defaults : constant Elist_Id := New_Elmt_List;
+ Gen_Unit : constant Entity_Id := Defining_Entity
+ (Parent (F_Copy));
Actuals : List_Id;
Actual : Node_Id;
Formal : Node_Id;
Defining_Identifier (Analyzed_Formal));
if No (Match) then
- Error_Msg_NE ("missing actual for instantiation of &",
- Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_Sloc := Sloc (Gen_Unit);
+ Error_Msg_NE
+ ("missing actual&",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
else
Defining_Identifier (Original_Node (Analyzed_Formal)));
if No (Match) then
+ Error_Msg_Sloc := Sloc (Gen_Unit);
Error_Msg_NE
- ("missing actual for instantiation of&",
- Instantiation_Node,
- Defining_Identifier (Formal));
+ ("missing actual&",
+ Instantiation_Node, Defining_Identifier (Formal));
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node, Gen_Unit);
Abandon_Instantiation (Instantiation_Node);
end loop;
if Num_Actuals > Num_Matched then
- Error_Msg_N
- ("unmatched actuals in instantiation", Instantiation_Node);
+ Error_Msg_Sloc := Sloc (Gen_Unit);
+
+ if Present (Selector_Name (Actual)) then
+ Error_Msg_NE
+ ("unmatched actual&",
+ Actual, Selector_Name (Actual));
+ Error_Msg_NE ("\in instantiation of& declared#",
+ Actual, Gen_Unit);
+ else
+ Error_Msg_NE
+ ("unmatched actual in instantiation of& declared#",
+ Actual, Gen_Unit);
+ end if;
end if;
elsif Present (Actuals) then
Error_Msg_N ("premature usage of incomplete type", Def);
elsif Is_Internal (Component_Type (T))
- and then Nkind (Original_Node (Subtype_Indication (Def)))
+ and then Nkind (Original_Node
+ (Subtype_Indication (Component_Definition (Def))))
/= N_Attribute_Reference
then
Error_Msg_N
("only a subtype mark is allowed in a formal",
- Subtype_Indication (Def));
+ Subtype_Indication (Component_Definition (Def)));
end if;
end Analyze_Formal_Array_Type;
end if;
if K = E_Generic_In_Parameter then
- if Is_Limited_Type (T) then
+
+ -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals
+
+ if Ada_Version < Ada_05 and then Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
Explain_Limited_Type (T, N);
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Formal : constant Entity_Id := Defining_Identifier (N);
+ Pack_Id : constant Entity_Id := Defining_Identifier (N);
+ Formal : Entity_Id;
Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
Gen_Id);
Restore_Env;
return;
+
+ elsif In_Open_Scopes (Gen_Unit) then
+ if Is_Compilation_Unit (Gen_Unit)
+ and then Is_Child_Unit (Current_Scope)
+ then
+ -- Special-case the error when the formal is a parent, and
+ -- continue analysis to minimize cascaded errors.
+
+ Error_Msg_N
+ ("generic parent cannot be used as formal package "
+ & "of a child unit",
+ Gen_Id);
+
+ else
+ Error_Msg_N
+ ("generic package cannot be used as a formal package "
+ & "within itself",
+ Gen_Id);
+ Restore_Env;
+ return;
+ end if;
end if;
-- Check for a formal package that is a package renaming.
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
- Set_Instance_Env (Gen_Unit, Formal);
-
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
if In_Extended_Main_Source_Unit (N) then
Generate_Reference (Gen_Unit, N);
end if;
+ Formal := New_Copy (Pack_Id);
New_N :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
- Set_Defining_Unit_Name (Specification (New_N), Formal);
Rewrite (N, New_N);
+ Set_Defining_Unit_Name (Specification (New_N), Formal);
+ Set_Instance_Env (Gen_Unit, Formal);
Enter_Name (Formal);
Set_Ekind (Formal, E_Generic_Package);
Set_Ekind (Formal, E_Package);
Set_Generic_Parent (Specification (N), Gen_Unit);
Set_Has_Completion (Formal, True);
+
+ Set_Ekind (Pack_Id, E_Package);
+ Set_Etype (Pack_Id, Standard_Void_Type);
+ Set_Scope (Pack_Id, Scope (Formal));
+ Set_Has_Completion (Pack_Id, True);
end if;
end Analyze_Formal_Package;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
+ -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause
+
if From_With_Type (Gen_Unit) then
Error_Msg_N
("cannot instantiate a limited withed package", Gen_Id);
if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
declare
- Decl : Node_Id :=
+ Decl : constant Node_Id :=
Original_Node
(Unit_Declaration_Node (Scope (Gen_Unit)));
begin
-- Common error routine for mismatch between the parameters of
-- the actual instance and those of the formal package.
+ function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean;
+ -- The formal may come from a nested formal package, and the actual
+ -- may have been constant-folded. To determine whether the two denote
+ -- the same entity we may have to traverse several definitions to
+ -- recover the ultimate entity that they refer to.
+
+ function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean;
+ -- Similarly, if the formal comes from a nested formal package, the
+ -- actual may designate the formal through multiple renamings, which
+ -- have to be followed to determine the original variable in question.
+
+ --------------------
+ -- Check_Mismatch --
+ --------------------
+
procedure Check_Mismatch (B : Boolean) is
begin
if B then
end if;
end Check_Mismatch;
+ --------------------------------
+ -- Same_Instantiated_Constant --
+ --------------------------------
+
+ function Same_Instantiated_Constant
+ (E1, E2 : Entity_Id) return Boolean
+ is
+ Ent : Entity_Id;
+ begin
+ Ent := E2;
+ while Present (Ent) loop
+ if E1 = Ent then
+ return True;
+
+ elsif Ekind (Ent) /= E_Constant then
+ return False;
+
+ elsif Is_Entity_Name (Constant_Value (Ent)) then
+ if Entity (Constant_Value (Ent)) = E1 then
+ return True;
+ else
+ Ent := Entity (Constant_Value (Ent));
+ end if;
+
+ -- The actual may be a constant that has been folded. Recover
+ -- original name.
+
+ elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then
+ Ent := Entity (Original_Node (Constant_Value (Ent)));
+ else
+ return False;
+ end if;
+ end loop;
+
+ return False;
+ end Same_Instantiated_Constant;
+
+ --------------------------------
+ -- Same_Instantiated_Variable --
+ --------------------------------
+
+ function Same_Instantiated_Variable
+ (E1, E2 : Entity_Id) return Boolean
+ is
+ function Original_Entity (E : Entity_Id) return Entity_Id;
+ -- Follow chain of renamings to the ultimate ancestor.
+
+ ---------------------
+ -- Original_Entity --
+ ---------------------
+
+ function Original_Entity (E : Entity_Id) return Entity_Id is
+ Orig : Entity_Id;
+
+ begin
+ Orig := E;
+ while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration
+ and then Present (Renamed_Object (Orig))
+ and then Is_Entity_Name (Renamed_Object (Orig))
+ loop
+ Orig := Entity (Renamed_Object (Orig));
+ end loop;
+
+ return Orig;
+ end Original_Entity;
+
+ -- Start of processing for Same_Instantiated_Variable
+
+ begin
+ return Ekind (E1) = Ekind (E2)
+ and then Original_Entity (E1) = Original_Entity (E2);
+ end Same_Instantiated_Variable;
+
-- Start of processing for Check_Formal_Package_Instance
begin
if Is_Entity_Name (Expr2) then
if Entity (Expr1) = Entity (Expr2) then
null;
-
- elsif Ekind (Entity (Expr2)) = E_Constant
- and then Is_Entity_Name (Constant_Value (Entity (Expr2)))
- and then
- Entity (Constant_Value (Entity (Expr2))) = Entity (Expr1)
- then
- null;
else
- Check_Mismatch (True);
+ Check_Mismatch
+ (not Same_Instantiated_Constant
+ (Entity (Expr1), Entity (Expr2)));
end if;
else
Check_Mismatch (True);
end if;
+ elsif Is_Entity_Name (Original_Node (Expr1))
+ and then Is_Entity_Name (Expr2)
+ and then
+ Same_Instantiated_Constant
+ (Entity (Original_Node (Expr1)), Entity (Expr2))
+ then
+ null;
+
elsif Nkind (Expr1) = N_Null then
Check_Mismatch (Nkind (Expr1) /= N_Null);
Check_Mismatch (True);
end if;
- elsif Ekind (E1) = E_Variable
- or else Ekind (E1) = E_Package
- then
+ elsif Ekind (E1) = E_Variable then
+ Check_Mismatch (not Same_Instantiated_Variable (E1, E2));
+
+ elsif Ekind (E1) = E_Package then
Check_Mismatch
(Ekind (E1) /= Ekind (E2)
or else Renamed_Object (E1) /= Renamed_Object (E2));
else
-- If the associated node is still defined, the entity in
-- it is global, and must be copied to the instance.
+ -- If this copy is being made for a body to inline, it is
+ -- applied to an instantiated tree, and the entity is already
+ -- present and must be also preserved.
- if Present (Get_Associated_Node (N)) then
- if Nkind (Get_Associated_Node (N)) = Nkind (N) then
- Set_Entity (New_N, Entity (Get_Associated_Node (N)));
- Check_Private_View (N);
+ declare
+ Assoc : constant Node_Id := Get_Associated_Node (N);
+ begin
+ if Present (Assoc) then
+ if Nkind (Assoc) = Nkind (N) then
+ Set_Entity (New_N, Entity (Assoc));
+ Check_Private_View (N);
+
+ 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)
+ and then Expander_Active
+ then
+ -- Inlining case: we are copying a tree that contains
+ -- global entities, which are preserved in the copy
+ -- to be used for subsequent inlining.
- elsif Nkind (Get_Associated_Node (N)) = N_Function_Call then
- Set_Entity (New_N, Entity (Name (Get_Associated_Node (N))));
+ null;
- else
- Set_Entity (New_N, Empty);
+ else
+ Set_Entity (New_N, Empty);
+ end if;
end if;
- end if;
+ end;
end if;
-- For expanded name, we must copy the Prefix and Selector_Name
Saved : Instance_Env;
begin
- Saved.Ada_83 := Ada_83;
+ Saved.Ada_Version := Ada_Version;
Saved.Instantiated_Parent := Current_Instantiated_Parent;
Saved.Exchanged_Views := Exchanged_Views;
Saved.Hidden_Entities := Hidden_Entities;
Generic_Flags.Init;
Generic_Renamings_HTable.Reset;
Circularity_Detected := False;
+ Exchanged_Views := No_Elist;
+ Hidden_Entities := No_Elist;
end Initialize;
----------------------------
end loop;
when others =>
- null;
- pragma Assert (False);
+ raise Program_Error;
end case;
end Find_Matching_Actual;
Gen_Anc : Entity_Id)
return Boolean
is
- Gen_Par : Entity_Id := Generic_Parent (Act_Spec);
+ Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec);
begin
if No (Gen_Par) then
Next_Non_Pragma (Formal_Node);
else
- -- No further formals to match.
+ -- No further formals to match, but the generic
+ -- part may contain inherited operation that are
+ -- not hidden in the enclosing instance.
- exit;
+ Next_Entity (Actual_Ent);
end if;
end loop;
end if;
else
+ Error_Msg_Sloc := Sloc (Scope (Analyzed_S));
+ Error_Msg_NE
+ ("missing actual&", Instantiation_Node, Formal_Sub);
Error_Msg_NE
- ("missing actual for instantiation of &",
- Instantiation_Node, Formal_Sub);
+ ("\in instantiation of & declared#",
+ Instantiation_Node, Scope (Analyzed_S));
Abandon_Instantiation (Instantiation_Node);
end if;
Decl_Node :=
Make_Subprogram_Renaming_Declaration (Loc,
Specification => New_Spec,
- Name => Nam);
+ Name => Nam);
+
+ -- If we do not have an actual and the formal specified <> then
+ -- set to get proper default.
+
+ if No (Actual) and then Box_Present (Formal) then
+ Set_From_Default (Decl_Node);
+ end if;
-- Gather possible interpretations for the actual before analyzing the
-- instance. If overloaded, it will be resolved when analyzing the
Subt_Decl : Node_Id := Empty;
begin
+ -- Sloc for error message on missing actual.
+ Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal)));
+
if Get_Instance_Of (Formal_Id) /= Formal_Id then
Error_Msg_N ("duplicate instantiation of generic parameter", Actual);
end if;
if No (Actual) then
Error_Msg_NE
- ("missing actual for instantiation of &",
+ ("missing actual&",
Instantiation_Node, Formal_Id);
+ Error_Msg_NE
+ ("\in instantiation of & declared#",
+ Instantiation_Node,
+ Scope (Defining_Identifier (Analyzed_Formal)));
Abandon_Instantiation (Instantiation_Node);
end if;
else
Error_Msg_NE
- ("missing actual for instantiation of &",
- Instantiation_Node, Formal_Id);
+ ("missing actual&",
+ Instantiation_Node, Formal_Id);
+ Error_Msg_NE ("\in instantiation of & declared#",
+ Instantiation_Node,
+ Scope (Defining_Identifier (Analyzed_Formal)));
if Is_Scalar_Type
(Etype (Defining_Identifier (Analyzed_Formal)))
if Nkind (Gen_Body) = N_Subprogram_Body_Stub then
-- Either body is not present, or context is non-expanding, as
- -- when compiling a subunit. Mark the instance as completed.
+ -- when compiling a subunit. Mark the instance as completed, and
+ -- diagnose a missing body when needed.
+
+ if Expander_Active
+ and then Operating_Mode = Generate_Code
+ then
+ Error_Msg_N
+ ("missing proper body for instantiation", Gen_Body);
+ end if;
Set_Has_Completion (Anon_Id);
return;
begin
Decl := First (Actual_Decls);
-
- while (Present (Decl)) loop
+ while Present (Decl) loop
if Nkind (Decl) = N_Subtype_Declaration
and then Chars (Defining_Identifier (Decl)) =
Chars (Etype (A_Gen_T))
-- actual must correspond to a discriminant of the formal.
elsif Has_Discriminants (Act_T)
+ and then not Has_Unknown_Discriminants (Act_T)
and then Has_Discriminants (Ancestor)
then
Actual_Discr := First_Discriminant (Act_T);
-- for constrainedness, but the check here is added for
-- completeness.
- elsif Has_Discriminants (Act_T) then
+ elsif Has_Discriminants (Act_T)
+ and then not Has_Unknown_Discriminants (Act_T)
+ then
Error_Msg_NE
("actual for & must not have discriminants", Actual, Gen_T);
Abandon_Instantiation (Actual);
elsif Is_Indefinite_Subtype (Act_T)
and then not Is_Indefinite_Subtype (A_Gen_T)
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
Error_Msg_NE
("actual for & must be a definite subtype", Actual, Gen_T);
elsif not Subtypes_Statically_Match
(Formal_Subt, Etype (Actual_Discr))
- and then Ada_95
+ and then Ada_Version >= Ada_95
then
Error_Msg_NE
("subtypes of actual discriminants must match formal",
Set_In_Private_Part (P);
end if;
+ -- This looks incomplete: what about compilation units that
+ -- were made visible by Install_Parent but should not remain
+ -- visible??? Standard is on the scope stack.
+
elsif not In_Open_Scopes (Scope (P)) then
Set_Is_Immediately_Visible (P, False);
end if;
Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last);
begin
- Ada_83 := Saved.Ada_83;
+ Ada_Version := Saved.Ada_Version;
if No (Current_Instantiated_Parent.Act_Id) then
-- inlining.
Rewrite (N, New_Copy (N2));
- Set_Associated_Node (N, N2);
Set_Analyzed (N, False);
end if;
end if;
begin
-- Regardless of the current mode, predefined units are analyzed in
- -- Ada95 mode, and Ada83 checks don't apply.
+ -- the most current Ada mode, and earlier version Ada checks do not
+ -- apply to predefined units.
if Is_Internal_File_Name
(Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
Renamings_Included => True) then
- Ada_83 := False;
+ Ada_Version := Ada_Version_Type'Last;
end if;
Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
OSDN Git Service
