-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
-- references the package in question.
procedure Attribute_Renaming (N : Node_Id);
- -- Analyze renaming of attribute as function. The renaming declaration N
- -- is rewritten as a function body that returns the attribute reference
+ -- Analyze renaming of attribute as subprogram. The renaming declaration N
+ -- is rewritten as a subprogram body that returns the attribute reference
-- applied to the formals of the function.
procedure Check_Frozen_Renaming (N : Node_Id; Subp : Entity_Id);
(Related_Nod => N,
N => Access_Definition (N));
- Analyze_And_Resolve (Nam, T);
+ Analyze (Nam);
+
+ -- Ada 2005 AI05-105: if the declaration has an anonymous access
+ -- type, the renamed object must also have an anonymous type, and
+ -- this is a name resolution rule. This was implicit in the last
+ -- part of the first sentence in 8.5.1.(3/2), and is made explicit
+ -- by this recent AI.
+
+ if not Is_Overloaded (Nam) then
+ if Ekind (Etype (Nam)) /= Ekind (T) then
+ Error_Msg_N
+ ("expect anonymous access type in object renaming", N);
+ end if;
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Typ : Entity_Id := Empty;
+
+ begin
+ Get_First_Interp (Nam, I, It);
+ while Present (It.Typ) loop
+ if No (Typ) then
+ if Ekind (It.Typ) = Ekind (T)
+ and then Covers (T, It.Typ)
+ then
+ Typ := It.Typ;
+ Set_Etype (Nam, Typ);
+ Set_Is_Overloaded (Nam, False);
+ end if;
+ else
+ Error_Msg_N ("ambiguous expression in renaming", N);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ Resolve (Nam, T);
-- Ada 2005 (AI-231): "In the case where the type is defined by an
-- access_definition, the renamed entity shall be of an access-to-
then
Error_Msg_N ("(Ada 2005): the renamed object is not "
& "access-to-constant (RM 8.5.1(6))", N);
+
+ elsif not Constant_Present (Access_Definition (N))
+ and then Is_Access_Constant (Etype (Nam))
+ then
+ Error_Msg_N ("(Ada 2005): the renamed object is not "
+ & "access-to-variable (RM 8.5.1(6))", N);
+ end if;
+
+ if Is_Access_Subprogram_Type (Etype (Nam)) then
+ Check_Subtype_Conformant
+ (Designated_Type (T), Designated_Type (Etype (Nam)));
+
+ elsif not Subtypes_Statically_Match
+ (Designated_Type (T), Designated_Type (Etype (Nam)))
+ then
+ Error_Msg_N
+ ("subtype of renamed object does not statically match", N);
end if;
end if;
if Nkind (Nam) = N_Explicit_Dereference
and then Ekind (Etype (T2)) = E_Incomplete_Type
then
- Error_Msg_N ("invalid use of incomplete type", Id);
+ Error_Msg_NE ("invalid use of incomplete type&", Id, T2);
+ return;
+ elsif Ekind (Etype (T)) = E_Incomplete_Type then
+ Error_Msg_NE ("invalid use of incomplete type&", Id, T);
return;
end if;
Error_Msg_NE
("`NOT NULL` not allowed (type of& already excludes null)",
N, Nam_Ent);
+
end if;
+
+ elsif Has_Null_Exclusion (N)
+ and then No (Access_Definition (N))
+ and then Can_Never_Be_Null (T)
+ then
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)", N, T);
end if;
end;
end if;
-- Ada 2005: check overriding indicator
- if Must_Override (Specification (N))
- and then not Is_Overriding_Operation (Rename_Spec)
- then
- Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
+ if Is_Overriding_Operation (Rename_Spec) then
+ if Must_Not_Override (Specification (N)) then
+ Error_Msg_NE
+ ("subprogram& overrides inherited operation",
+ N, Rename_Spec);
+ elsif
+ Style_Check and then not Must_Override (Specification (N))
+ then
+ Style.Missing_Overriding (N, Rename_Spec);
+ end if;
- elsif Must_Not_Override (Specification (N))
- and then Is_Overriding_Operation (Rename_Spec)
- then
- Error_Msg_NE
- ("subprogram& overrides inherited operation", N, Rename_Spec);
+ elsif Must_Override (Specification (N)) then
+ Error_Msg_NE ("subprogram& is not overriding", N, Rename_Spec);
end if;
-- Normal subprogram renaming (not renaming as body)
-- Most common case: subprogram renames subprogram. No body is generated
-- in this case, so we must indicate the declaration is complete as is.
+ -- and inherit various attributes of the renamed subprogram.
if No (Rename_Spec) then
Set_Has_Completion (New_S);
+ Set_Is_Imported (New_S, Is_Imported (Entity (Nam)));
Set_Is_Pure (New_S, Is_Pure (Entity (Nam)));
Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam)));
Check_Frozen_Renaming (N, Rename_Spec);
-- Check explicitly that renamed entity is not intrinsic, because
- -- in in a generic the renamed body is not built. In this case,
+ -- in a generic the renamed body is not built. In this case,
-- the renaming_as_body is a completion.
if Inside_A_Generic then
procedure Analyze_Use_Type (N : Node_Id) is
E : Entity_Id;
- Id : Entity_Id;
+ Id : Node_Id;
begin
Set_Hidden_By_Use_Clause (N, No_Elist);
Check_In_Previous_With_Clause (N, Prefix (Id));
end if;
end if;
+
+ else
+ -- If the use_type_clause appears in a compilation unit context,
+ -- check whether it comes from a unit that may appear in a
+ -- limited_with_clause, for a better error message.
+
+ if Nkind (Parent (N)) = N_Compilation_Unit
+ and then Nkind (Id) /= N_Identifier
+ then
+ declare
+ Item : Node_Id;
+ Pref : Node_Id;
+
+ function Mentioned (Nam : Node_Id) return Boolean;
+ -- Check whether the prefix of expanded name for the type
+ -- appears in the prefix of some limited_with_clause.
+
+ ---------------
+ -- Mentioned --
+ ---------------
+
+ function Mentioned (Nam : Node_Id) return Boolean is
+ begin
+ return Nkind (Name (Item)) = N_Selected_Component
+ and then
+ Chars (Prefix (Name (Item))) = Chars (Nam);
+ end Mentioned;
+
+ begin
+ Pref := Prefix (Id);
+ Item := First (Context_Items (Parent (N)));
+
+ while Present (Item) and then Item /= N loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Mentioned (Pref)
+ then
+ Change_Error_Text
+ (Get_Msg_Id, "premature usage of incomplete type");
+ end if;
+
+ Next (Item);
+ end loop;
+ end;
+ end if;
end if;
Next (Id);
begin
Generate_Definition (New_S);
- -- This procedure is called in the context of subprogram renaming,
- -- and thus the attribute must be one that is a subprogram. All of
- -- those have at least one formal parameter, with the singular
- -- exception of AST_Entry (which is a real oddity, it is odd that
- -- this can be renamed at all!)
+ -- This procedure is called in the context of subprogram renaming, and
+ -- thus the attribute must be one that is a subprogram. All of those
+ -- have at least one formal parameter, with the singular exception of
+ -- AST_Entry (which is a real oddity, it is odd that this can be renamed
+ -- at all!)
if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then
if Aname /= Name_AST_Entry then
Chars => Chars (Defining_Identifier (Param_Spec))));
-- The expressions in the attribute reference are not freeze
- -- points. Neither is the attribute as a whole, see below.
+ -- points. Neither is the attribute as a whole, see below.
Set_Must_Not_Freeze (Last (Expr_List));
Next (Param_Spec);
end loop;
end if;
- -- Immediate error if too many formals. Other mismatches in numbers
- -- of number of types of parameters are detected when we analyze the
- -- body of the subprogram that we construct.
+ -- Immediate error if too many formals. Other mismatches in number or
+ -- types of parameters are detected when we analyze the body of the
+ -- subprogram that we construct.
if Form_Num > 2 then
Error_Msg_N ("too many formals for attribute", N);
- -- Error if the attribute reference has expressions that look
- -- like formal parameters.
+ -- Error if the attribute reference has expressions that look like
+ -- formal parameters.
elsif Present (Expressions (Nam)) then
Error_Msg_N ("illegal expressions in attribute reference", Nam);
end if;
end if;
- -- AST_Entry is an odd case. It doesn't really make much sense to
- -- allow it to be renamed, but that's the DEC rule, so we have to
- -- do it right. The point is that the AST_Entry call should be made
- -- now, and what the function will return is the returned value.
+ -- AST_Entry is an odd case. It doesn't really make much sense to allow
+ -- it to be renamed, but that's the DEC rule, so we have to do it right.
+ -- The point is that the AST_Entry call should be made now, and what the
+ -- function will return is the returned value.
-- Note that there is no Expr_List in this case anyway
Error_Msg_N
("renamed generic unit must be a library unit", Name (N));
- elsif Ekind (Old_E) = E_Package
- or else Ekind (Old_E) = E_Generic_Package
- then
+ elsif Is_Package_Or_Generic_Package (Old_E) then
+
-- Inherit categorization flags
New_E := Defining_Entity (N);
end if;
-- Operator is visible if prefix of expanded name denotes
- -- scope of type, or else type type is defined in System_Aux
+ -- scope of type, or else type is defined in System_Aux
-- and the prefix denotes System.
return Scope (Btyp) = Scop
Next_Entity (E);
- if not Full_Vis then
+ if not Full_Vis
+ and then Is_Package_Or_Generic_Package (S)
+ then
+ -- We are in the visible part of the package scope
+
exit when E = First_Private_Entity (S);
end if;
end loop;
then
Full_Vis := True;
- elsif (Ekind (S) = E_Package
- or else Ekind (S) = E_Generic_Package)
+ elsif Is_Package_Or_Generic_Package (S)
and then (In_Private_Part (S)
or else In_Package_Body (S))
then
Set_Redundant_Use (Id,
Is_Known_Used or else Is_Potentially_Use_Visible (T));
- if In_Open_Scopes (Scope (T)) then
+ if Ekind (T) = E_Incomplete_Type then
+ Error_Msg_N ("premature usage of incomplete type", Id);
+
+ elsif In_Open_Scopes (Scope (T)) then
null;
-- A limited view cannot appear in a use_type clause. However, an
-- as use visible. The analysis then reinstalls the spec along with
-- its context. The use clause P.T is now recognized as redundant,
-- but in the wrong context. Do not emit a warning in such cases.
+ -- Do not emit a warning either if we are in an instance, there
+ -- is no redundancy between an outer use_clause and one that appears
+ -- within the generic.
and then not Spec_Reloaded_For_Body
+ and then not In_Instance
then
-- The type already has a use clause
if In_Use (T) then
+
+ -- Case where we know the current use clause for the type
+
if Present (Current_Use_Clause (T)) then
- declare
+ Use_Clause_Known : declare
Clause1 : constant Node_Id := Parent (Id);
Clause2 : constant Node_Id := Current_Use_Clause (T);
+ Ent1 : Entity_Id;
+ Ent2 : Entity_Id;
Err_No : Node_Id;
Unit1 : Node_Id;
Unit2 : Node_Id;
+ function Entity_Of_Unit (U : Node_Id) return Entity_Id;
+ -- Return the appropriate entity for determining which unit
+ -- has a deeper scope: the defining entity for U, unless U
+ -- is a package instance, in which case we retrieve the
+ -- entity of the instance spec.
+
+ --------------------
+ -- Entity_Of_Unit --
+ --------------------
+
+ function Entity_Of_Unit (U : Node_Id) return Entity_Id is
+ begin
+ if Nkind (U) = N_Package_Instantiation
+ and then Analyzed (U)
+ then
+ return Defining_Entity (Instance_Spec (U));
+ else
+ return Defining_Entity (U);
+ end if;
+ end Entity_Of_Unit;
+
+ -- Start of processing for Use_Clause_Known
+
begin
+ -- If both current use type clause and the use type
+ -- clause for the type are at the compilation unit level,
+ -- one of the units must be an ancestor of the other, and
+ -- the warning belongs on the descendant.
+
if Nkind (Parent (Clause1)) = N_Compilation_Unit
- and then Nkind (Parent (Clause2)) = N_Compilation_Unit
+ and then
+ Nkind (Parent (Clause2)) = N_Compilation_Unit
then
+ Unit1 := Unit (Parent (Clause1));
+ Unit2 := Unit (Parent (Clause2));
+
-- There is a redundant use type clause in a child unit.
-- Determine which of the units is more deeply nested.
+ -- If a unit is a package instance, retrieve the entity
+ -- and its scope from the instance spec.
- Unit1 := Defining_Entity (Unit (Parent (Clause1)));
- Unit2 := Defining_Entity (Unit (Parent (Clause2)));
+ Ent1 := Entity_Of_Unit (Unit1);
+ Ent2 := Entity_Of_Unit (Unit2);
- if Scope (Unit2) = Standard_Standard then
+ if Scope (Ent2) = Standard_Standard then
Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
Err_No := Clause1;
- elsif Scope (Unit1) = Standard_Standard then
+ elsif Scope (Ent1) = Standard_Standard then
Error_Msg_Sloc := Sloc (Id);
Err_No := Clause2;
- else
- -- Determine which is the descendant unit
+ -- If both units are child units, we determine which one
+ -- is the descendant by the scope distance to the
+ -- ultimate parent unit.
+ else
declare
S1, S2 : Entity_Id;
begin
- S1 := Scope (Unit1);
- S2 := Scope (Unit2);
+ S1 := Scope (Ent1);
+ S2 := Scope (Ent2);
while S1 /= Standard_Standard
- and then S2 /= Standard_Standard
+ and then
+ S2 /= Standard_Standard
loop
S1 := Scope (S1);
S2 := Scope (S2);
Error_Msg_NE
("& is already use-visible through previous "
& "use_type_clause #?", Err_No, Id);
+
+ -- Case where current use type clause and the use type
+ -- clause for the type are not both at the compilation unit
+ -- level. In this case we don't have location information.
+
else
Error_Msg_NE
- ("& is already use-visible through previous use type "
- & "clause?", Id, Id);
+ ("& is already use-visible through previous "
+ & "use type clause?", Id, Id);
end if;
- end;
+ end Use_Clause_Known;
+
+ -- Here if Current_Use_Clause is not set for T, another case
+ -- where we do not have the location information available.
+
else
Error_Msg_NE
- ("& is already use-visible through previous use type "
- & "clause?", Id, Id);
+ ("& is already use-visible through previous "
+ & "use type clause?", Id, Id);
end if;
-- The package where T is declared is already used
OSDN Git Service
