-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
+with Impunit; use Impunit;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Lib.Xref; use Lib.Xref;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch12; use Sem_Ch12;
with Sem_Disp; use Sem_Disp;
+with Sem_Dist; use Sem_Dist;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
-- Compiling subunits --
------------------------
- -- Subunits must be compiled in the environment of the corresponding
- -- stub, that is to say with the same visibility into the parent (and its
+ -- Subunits must be compiled in the environment of the corresponding stub,
+ -- that is to say with the same visibility into the parent (and its
-- context) that is available at the point of the stub declaration, but
-- with the additional visibility provided by the context clause of the
-- subunit itself. As a result, compilation of a subunit forces compilation
-- of the parent (see description in lib-). At the point of the stub
- -- declaration, Analyze is called recursively to compile the proper body
- -- of the subunit, but without reinitializing the names table, nor the
- -- scope stack (i.e. standard is not pushed on the stack). In this fashion
- -- the context of the subunit is added to the context of the parent, and
- -- the subunit is compiled in the correct environment. Note that in the
- -- course of processing the context of a subunit, Standard will appear
- -- twice on the scope stack: once for the parent of the subunit, and
- -- once for the unit in the context clause being compiled. However, the
- -- two sets of entities are not linked by homonym chains, so that the
- -- compilation of any context unit happens in a fresh visibility
- -- environment.
+ -- declaration, Analyze is called recursively to compile the proper body of
+ -- the subunit, but without reinitializing the names table, nor the scope
+ -- stack (i.e. standard is not pushed on the stack). In this fashion the
+ -- context of the subunit is added to the context of the parent, and the
+ -- subunit is compiled in the correct environment. Note that in the course
+ -- of processing the context of a subunit, Standard will appear twice on
+ -- the scope stack: once for the parent of the subunit, and once for the
+ -- unit in the context clause being compiled. However, the two sets of
+ -- entities are not linked by homonym chains, so that the compilation of
+ -- any context unit happens in a fresh visibility environment.
-------------------------------
-- Processing of USE Clauses --
-- contains the full declaration. To simplify the swap, the defining
-- occurrence that currently holds the private declaration points to the
-- full declaration. During semantic processing the defining occurrence
- -- also points to a list of private dependents, that is to say access
- -- types or composite types whose designated types or component types are
+ -- also points to a list of private dependents, that is to say access types
+ -- or composite types whose designated types or component types are
-- subtypes or derived types of the private type in question. After the
-- full declaration has been seen, the private dependents are updated to
-- indicate that they have full definitions.
-- an instance of the parent.
procedure Chain_Use_Clause (N : Node_Id);
- -- Chain use clause onto list of uses clauses headed by First_Use_Clause
- -- in the top scope table entry.
+ -- Chain use clause onto list of uses clauses headed by First_Use_Clause in
+ -- the proper scope table entry. This is usually the current scope, but it
+ -- will be an inner scope when installing the use clauses of the private
+ -- declarations of a parent unit prior to compiling the private part of a
+ -- child unit. This chain is traversed when installing/removing use clauses
+ -- when compiling a subunit or instantiating a generic body on the fly,
+ -- when it is necessary to save and restore full environments.
function Has_Implicit_Character_Literal (N : Node_Id) return Boolean;
-- Find a type derived from Character or Wide_Character in the prefix of N.
function Has_Private_With (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-262): Determines if the current compilation unit has a
- -- private with on E
+ -- private with on E.
procedure Find_Expanded_Name (N : Node_Id);
-- Selected component is known to be expanded name. Verify legality
function Has_Implicit_Operator (N : Node_Id) return Boolean;
-- N is an expanded name whose selector is an operator name (eg P."+").
- -- A declarative part contains an implicit declaration of an operator
- -- if it has a declaration of a type to which one of the predefined
- -- operators apply. The existence of this routine is an artifact of
- -- our implementation: a more straightforward but more space-consuming
- -- choice would be to make all inherited operators explicit in the
- -- symbol table.
+ -- declarative part contains an implicit declaration of an operator if it
+ -- has a declaration of a type to which one of the predefined operators
+ -- apply. The existence of this routine is an implementation artifact. A
+ -- more straightforward but more space-consuming choice would be to make
+ -- all inherited operators explicit in the symbol table.
procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id);
-- A subprogram defined by a renaming declaration inherits the parameter
-- subprogram, which are then used to recheck the default values.
function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
- -- Prefix is appropriate for record if it is of a record type, or
- -- an access to such.
+ -- Prefix is appropriate for record if it is of a record type, or an access
+ -- to such.
function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
- -- True if it is of a task type, a protected type, or else an access
- -- to one of these types.
+ -- True if it is of a task type, a protected type, or else an access to one
+ -- of these types.
+
+ procedure Note_Redundant_Use (Clause : Node_Id);
+ -- Mark the name in a use clause as redundant if the corresponding entity
+ -- is already use-visible. Emit a warning if the use clause comes from
+ -- source and the proper warnings are enabled.
procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible
-- Analyze_Exception_Renaming --
--------------------------------
- -- The language only allows a single identifier, but the tree holds
- -- an identifier list. The parser has already issued an error message
- -- if there is more than one element in the list.
+ -- The language only allows a single identifier, but the tree holds an
+ -- identifier list. The parser has already issued an error message if
+ -- there is more than one element in the list.
procedure Analyze_Exception_Renaming (N : Node_Id) is
Id : constant Node_Id := Defining_Identifier (N);
procedure Analyze_Expanded_Name (N : Node_Id) is
begin
- -- If the entity pointer is already set, this is an internal node, or
- -- a node that is analyzed more than once, after a tree modification.
- -- In such a case there is no resolution to perform, just set the type.
- -- For completeness, analyze prefix as well.
+ -- If the entity pointer is already set, this is an internal node, or a
+ -- node that is analyzed more than once, after a tree modification. In
+ -- such a case there is no resolution to perform, just set the type. For
+ -- completeness, analyze prefix as well.
if Present (Entity (N)) then
if Is_Type (Entity (N)) then
procedure Analyze_Generic_Package_Renaming (N : Node_Id) is
begin
- -- Apply the Text_IO Kludge here, since we may be renaming
- -- one of the subpackages of Text_IO, then join common routine.
+ -- Apply the Text_IO Kludge here, since we may be renaming one of the
+ -- subpackages of Text_IO, then join common routine.
Text_IO_Kludge (Name (N));
Set_Renamed_Object (New_P, Old_P);
end if;
+ Set_Is_Pure (New_P, Is_Pure (Old_P));
+ Set_Is_Preelaborated (New_P, Is_Preelaborated (Old_P));
+
Set_Etype (New_P, Etype (Old_P));
Set_Has_Completion (New_P);
Check_Library_Unit_Renaming (N, Old_P);
end if;
-
end Analyze_Generic_Renaming;
-----------------------------
T : Entity_Id;
T2 : Entity_Id;
+ function In_Generic_Scope (E : Entity_Id) return Boolean;
+ -- Determine whether entity E is inside a generic cope
+
+ ----------------------
+ -- In_Generic_Scope --
+ ----------------------
+
+ function In_Generic_Scope (E : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Scope (E);
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Generic_Unit (S) then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Generic_Scope;
+
+ -- Start of processing for Analyze_Object_Renaming
+
begin
if Nam = Error then
return;
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Enter_Name (Id);
- -- The renaming of a component that depends on a discriminant
- -- requires an actual subtype, because in subsequent use of the object
- -- Gigi will be unable to locate the actual bounds. This explicit step
- -- is required when the renaming is generated in removing side effects
- -- of an already-analyzed expression.
+ -- The renaming of a component that depends on a discriminant requires
+ -- an actual subtype, because in subsequent use of the object Gigi will
+ -- be unable to locate the actual bounds. This explicit step is required
+ -- when the renaming is generated in removing side effects of an
+ -- already-analyzed expression.
if Nkind (Nam) = N_Selected_Component
and then Analyzed (Nam)
Set_Etype (Nam, T);
end if;
+ -- Complete analysis of the subtype mark in any case, for ASIS use.
+
+ if Present (Subtype_Mark (N)) then
+ Find_Type (Subtype_Mark (N));
+ end if;
+
elsif Present (Subtype_Mark (N)) then
Find_Type (Subtype_Mark (N));
T := Entity (Subtype_Mark (N));
- Analyze_And_Resolve (Nam, T);
+ Analyze (Nam);
+
+ if Nkind (Nam) = N_Type_Conversion
+ and then not Is_Tagged_Type (T)
+ then
+ Error_Msg_N
+ ("renaming of conversion only allowed for tagged types", Nam);
+ end if;
+
+ Resolve (Nam, T);
-- Ada 2005 (AI-230/AI-254): Access renaming
then
Error_Msg_N ("(Ada 2005): the renamed object is not "
& "access-to-constant ('R'M 8.5.1(6))", N);
-
- elsif Null_Exclusion_Present (Access_Definition (N)) then
- Error_Msg_N ("(Ada 2005): null-excluding attribute ignored "
- & "('R'M 8.5.1(6))?", N);
end if;
end if;
- -- An object renaming requires an exact match of the type;
- -- class-wide matching is not allowed.
+ -- Special processing for renaming function return object
+
+ if Nkind (Nam) = N_Function_Call
+ and then Comes_From_Source (Nam)
+ then
+ case Ada_Version is
+
+ -- Usage is illegal in Ada 83
+
+ when Ada_83 =>
+ Error_Msg_N
+ ("(Ada 83) cannot rename function return object", Nam);
+
+ -- In Ada 95, warn for odd case of renaming parameterless function
+ -- call if this is not a limited type (where this is useful)
+
+ when others =>
+ if Warn_On_Object_Renames_Function
+ and then No (Parameter_Associations (Nam))
+ and then not Is_Limited_Type (Etype (Nam))
+ then
+ Error_Msg_N
+ ("?renaming function result object is suspicious",
+ Nam);
+ Error_Msg_NE
+ ("\?function & will be called only once",
+ Nam, Entity (Name (Nam)));
+ Error_Msg_N
+ ("\?suggest using an initialized constant object instead",
+ Nam);
+ end if;
+ end case;
+ end if;
+
+ -- An object renaming requires an exact match of the type. Class-wide
+ -- matching is not allowed.
if Is_Class_Wide_Type (T)
and then Base_Type (Etype (Nam)) /= Base_Type (T)
end if;
T2 := Etype (Nam);
+
+ -- (Ada 2005: AI-326): Handle wrong use of incomplete type
+
+ if Nkind (Nam) = N_Explicit_Dereference
+ and then Ekind (Etype (T2)) = E_Incomplete_Type
+ then
+ Error_Msg_N ("invalid use of incomplete type", Id);
+ return;
+ end if;
+
+ -- Ada 2005 (AI-327)
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Nam) = N_Attribute_Reference
+ and then Attribute_Name (Nam) = Name_Priority
+ then
+ null;
+
+ elsif Ada_Version >= Ada_05
+ and then Nkind (Nam) in N_Has_Entity
+ then
+ declare
+ Error_Node : Node_Id;
+ Nam_Decl : Node_Id;
+ Nam_Ent : Entity_Id;
+ Subtyp_Decl : Node_Id;
+
+ begin
+ if Nkind (Nam) = N_Attribute_Reference then
+ Nam_Ent := Entity (Prefix (Nam));
+ else
+ Nam_Ent := Entity (Nam);
+ end if;
+
+ Nam_Decl := Parent (Nam_Ent);
+ Subtyp_Decl := Parent (Etype (Nam_Ent));
+
+ if Has_Null_Exclusion (N)
+ and then not Has_Null_Exclusion (Nam_Decl)
+ then
+ -- Ada 2005 (AI-423): If the object name denotes a generic
+ -- formal object of a generic unit G, and the object renaming
+ -- declaration occurs within the body of G or within the body
+ -- of a generic unit declared within the declarative region
+ -- of G, then the declaration of the formal object of G must
+ -- have a null exclusion.
+
+ if Is_Formal_Object (Nam_Ent)
+ and then In_Generic_Scope (Id)
+ then
+ if Present (Subtype_Mark (Nam_Decl)) then
+ Error_Node := Subtype_Mark (Nam_Decl);
+ else
+ pragma Assert
+ (Ada_Version >= Ada_05
+ and then Present (Access_Definition (Nam_Decl)));
+
+ Error_Node := Access_Definition (Nam_Decl);
+ end if;
+
+ Error_Msg_N
+ ("`NOT NULL` required in formal object declaration",
+ Error_Node);
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("\because of renaming at# ('R'M 8.5.4(4))", Error_Node);
+
+ -- Ada 2005 (AI-423): Otherwise, the subtype of the object name
+ -- shall exclude null.
+
+ elsif Nkind (Subtyp_Decl) = N_Subtype_Declaration
+ and then not Has_Null_Exclusion (Subtyp_Decl)
+ then
+ Error_Msg_N
+ ("`NOT NULL` required for subtype & ('R'M 8.5.1(4.6/2))",
+ Defining_Identifier (Subtyp_Decl));
+ end if;
+ end if;
+ end;
+ end if;
+
Set_Ekind (Id, E_Variable);
Init_Size_Align (Id);
if T = Any_Type or else Etype (Nam) = Any_Type then
return;
- -- Verify that the renamed entity is an object or a function call.
- -- It may have been rewritten in several ways.
+ -- Verify that the renamed entity is an object or a function call. It
+ -- may have been rewritten in several ways.
elsif Is_Object_Reference (Nam) then
if Comes_From_Source (N)
and then Is_Function_Attribute_Name
(Attribute_Name (Original_Node (Nam))))
- -- Weird but legal, equivalent to renaming a function call
+ -- Weird but legal, equivalent to renaming a function call.
+ -- Illegal if the literal is the result of constant-folding an
+ -- attribute reference that is not a function.
or else (Is_Entity_Name (Nam)
- and then Ekind (Entity (Nam)) = E_Enumeration_Literal)
+ and then Ekind (Entity (Nam)) = E_Enumeration_Literal
+ and then
+ Nkind (Original_Node (Nam)) /= N_Attribute_Reference)
or else (Nkind (Nam) = N_Type_Conversion
and then Is_Tagged_Type (Entity (Subtype_Mark (Nam))))
then
null;
- else
- if Nkind (Nam) = N_Type_Conversion then
- Error_Msg_N
- ("renaming of conversion only allowed for tagged types", Nam);
+ elsif Nkind (Nam) = N_Type_Conversion then
+ Error_Msg_N
+ ("renaming of conversion only allowed for tagged types", Nam);
- else
- Error_Msg_N ("expect object name in renaming", Nam);
- end if;
+ -- Ada 2005 (AI-327)
+
+ elsif Ada_Version >= Ada_05
+ and then Nkind (Nam) = N_Attribute_Reference
+ and then Attribute_Name (Nam) = Name_Priority
+ then
+ null;
+
+ else
+ Error_Msg_N ("expect object name in renaming", Nam);
end if;
Set_Etype (Id, T2);
return;
end if;
- -- Apply Text_IO kludge here, since we may be renaming one of
- -- the children of Text_IO
+ -- Apply Text_IO kludge here, since we may be renaming one of the
+ -- children of Text_IO
Text_IO_Kludge (Name (N));
Enter_Name (New_P);
Analyze (Name (N));
+
if Is_Entity_Name (Name (N)) then
Old_P := Entity (Name (N));
else
Error_Msg_N
("expect package name in renaming", Name (N));
- -- Ada 2005 (AI-50217): Limited withed packages can not be renamed
-
- elsif Ekind (Old_P) = E_Package
- and then From_With_Type (Old_P)
- then
- Error_Msg_N
- ("limited withed package cannot be renamed", Name (N));
-
elsif Ekind (Old_P) /= E_Package
and then not (Ekind (Old_P) = E_Generic_Package
and then In_Open_Scopes (Old_P))
Set_Etype (New_P, Standard_Void_Type);
else
- -- Entities in the old package are accessible through the
- -- renaming entity. The simplest implementation is to have
- -- both packages share the entity list.
+ -- Entities in the old package are accessible through the renaming
+ -- entity. The simplest implementation is to have both packages share
+ -- the entity list.
Set_Ekind (New_P, E_Package);
Set_Etype (New_P, Standard_Void_Type);
if Present (Renamed_Object (Old_P)) then
Set_Renamed_Object (New_P, Renamed_Object (Old_P));
else
- Set_Renamed_Object (New_P, Old_P);
+ Set_Renamed_Object (New_P, Old_P);
end if;
Set_Has_Completion (New_P);
and then Chars (New_P) = Chars (Generic_Parent (Spec))
then
declare
- E : Entity_Id := First_Entity (Old_P);
+ E : Entity_Id;
+
begin
+ E := First_Entity (Old_P);
while Present (E)
and then E /= New_P
loop
return;
end if;
- -- Otherwise, find renamed entity, and build body of New_S as a call
- -- to it.
+ -- Otherwise find renamed entity and build body of New_S as a call to it
Old_S := Find_Renamed_Entity (N, Selector_Name (Nam), New_S);
Check_Subtype_Conformant (New_S, Old_S, N);
Generate_Reference (New_S, Defining_Entity (N), 'b');
Style.Check_Identifier (Defining_Entity (N), New_S);
+
+ else
+ -- Only mode conformance required for a renaming_as_declaration
+
+ Check_Mode_Conformant (New_S, Old_S, N);
end if;
Inherit_Renamed_Profile (New_S, Old_S);
Generate_Reference (New_S, Defining_Entity (N), 'b');
Style.Check_Identifier (Defining_Entity (N), New_S);
end if;
+
else
Error_Msg_N ("no entry family matches specification", N);
end if;
---------------------------------
procedure Analyze_Subprogram_Renaming (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Save_AV : constant Ada_Version_Type := Ada_Version;
+ Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N);
+ Is_Actual : constant Boolean := Present (Formal_Spec);
+ Inst_Node : Node_Id := Empty;
Nam : constant Node_Id := Name (N);
New_S : Entity_Id;
- Old_S : Entity_Id := Empty;
+ Old_S : Entity_Id := Empty;
Rename_Spec : Entity_Id;
- Is_Actual : Boolean := False;
- Inst_Node : Node_Id := Empty;
+ Save_AV : constant Ada_Version_Type := Ada_Version;
+ Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit;
+ Spec : constant Node_Id := Specification (N);
+
+ procedure Check_Null_Exclusion
+ (Ren : Entity_Id;
+ Sub : Entity_Id);
+ -- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
+ -- following AI rules:
+ --
+ -- If Ren is a renaming of a formal subprogram and one of its
+ -- parameters has a null exclusion, then the corresponding formal
+ -- in Sub must also have one. Otherwise the subtype of the Sub's
+ -- formal parameter must exclude null.
+ --
+ -- If Ren is a renaming of a formal function and its retrun
+ -- profile has a null exclusion, then Sub's return profile must
+ -- have one. Otherwise the subtype of Sub's return profile must
+ -- exclude null.
function Original_Subprogram (Subp : Entity_Id) return Entity_Id;
- -- Find renamed entity when the declaration is a renaming_as_body
- -- and the renamed entity may itself be a renaming_as_body. Used to
- -- enforce rule that a renaming_as_body is illegal if the declaration
- -- occurs before the subprogram it completes is frozen, and renaming
- -- indirectly renames the subprogram itself.(Defect Report 8652/0027).
+ -- Find renamed entity when the declaration is a renaming_as_body and
+ -- the renamed entity may itself be a renaming_as_body. Used to enforce
+ -- rule that a renaming_as_body is illegal if the declaration occurs
+ -- before the subprogram it completes is frozen, and renaming indirectly
+ -- renames the subprogram itself.(Defect Report 8652/0027).
+
+ --------------------------
+ -- Check_Null_Exclusion --
+ --------------------------
+
+ procedure Check_Null_Exclusion
+ (Ren : Entity_Id;
+ Sub : Entity_Id)
+ is
+ Ren_Formal : Entity_Id;
+ Sub_Formal : Entity_Id;
+
+ begin
+ -- Parameter check
+
+ Ren_Formal := First_Formal (Ren);
+ Sub_Formal := First_Formal (Sub);
+ while Present (Ren_Formal)
+ and then Present (Sub_Formal)
+ loop
+ if Has_Null_Exclusion (Parent (Ren_Formal))
+ and then
+ not (Has_Null_Exclusion (Parent (Sub_Formal))
+ or else Can_Never_Be_Null (Etype (Sub_Formal)))
+ then
+ Error_Msg_NE
+ ("`NOT NULL` required for parameter &",
+ Parent (Sub_Formal), Sub_Formal);
+ end if;
+
+ Next_Formal (Ren_Formal);
+ Next_Formal (Sub_Formal);
+ end loop;
+
+ -- Return profile check
+
+ if Nkind (Parent (Ren)) = N_Function_Specification
+ and then Nkind (Parent (Sub)) = N_Function_Specification
+ and then Has_Null_Exclusion (Parent (Ren))
+ and then
+ not (Has_Null_Exclusion (Parent (Sub))
+ or else Can_Never_Be_Null (Etype (Sub)))
+ then
+ Error_Msg_N
+ ("return must specify `NOT NULL`",
+ Result_Definition (Parent (Sub)));
+ end if;
+ end Check_Null_Exclusion;
-------------------------
-- Original_Subprogram --
-- is missing an argument when it is analyzed.
if Nkind (Nam) = N_Attribute_Reference then
- Attribute_Renaming (N);
- return;
+
+ -- In the case of an abstract formal subprogram association, rewrite
+ -- an actual given by a stream attribute as the name of the
+ -- corresponding stream primitive of the type.
+
+ -- In a generic context the stream operations are not generated, and
+ -- this must be treated as a normal attribute reference, to be
+ -- expanded in subsequent instantiations.
+
+ if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec)
+ and then Expander_Active
+ then
+ declare
+ Stream_Prim : Entity_Id;
+ Prefix_Type : constant Entity_Id := Entity (Prefix (Nam));
+
+ begin
+ -- The class-wide forms of the stream attributes are not
+ -- primitive dispatching operations (even though they
+ -- internally dispatch to a stream attribute).
+
+ if Is_Class_Wide_Type (Prefix_Type) then
+ Error_Msg_N
+ ("attribute must be a primitive dispatching operation",
+ Nam);
+ return;
+ end if;
+
+ -- Retrieve the primitive subprogram associated with the
+ -- attribute. This can only be a stream attribute, since those
+ -- are the only ones that are dispatching (and the actual for
+ -- an abstract formal subprogram must be dispatching
+ -- operation).
+
+ case Attribute_Name (Nam) is
+ when Name_Input =>
+ Stream_Prim :=
+ Find_Prim_Op (Prefix_Type, TSS_Stream_Input);
+ when Name_Output =>
+ Stream_Prim :=
+ Find_Prim_Op (Prefix_Type, TSS_Stream_Output);
+ when Name_Read =>
+ Stream_Prim :=
+ Find_Prim_Op (Prefix_Type, TSS_Stream_Read);
+ when Name_Write =>
+ Stream_Prim :=
+ Find_Prim_Op (Prefix_Type, TSS_Stream_Write);
+ when others =>
+ Error_Msg_N
+ ("attribute must be a primitive dispatching operation",
+ Nam);
+ return;
+ end case;
+
+ -- Rewrite the attribute into the name of its corresponding
+ -- primitive dispatching subprogram. We can then proceed with
+ -- the usual processing for subprogram renamings.
+
+ declare
+ Prim_Name : constant Node_Id :=
+ Make_Identifier (Sloc (Nam),
+ Chars => Chars (Stream_Prim));
+ begin
+ Set_Entity (Prim_Name, Stream_Prim);
+ Rewrite (Nam, Prim_Name);
+ Analyze (Nam);
+ end;
+ end;
+
+ -- Normal processing for a renaming of an attribute
+
+ else
+ Attribute_Renaming (N);
+ return;
+ end if;
end if;
-- Check whether this declaration corresponds to the instantiation
-- of a formal subprogram.
- -- If this is an instantiation, the corresponding actual is frozen
- -- and error messages can be made more precise. If this is a default
- -- subprogram, the entity is already established in the generic, and
- -- is not retrieved by visibility. If it is a default with a box, the
+ -- If this is an instantiation, the corresponding actual is frozen and
+ -- error messages can be made more precise. If this is a default
+ -- subprogram, the entity is already established in the generic, and is
+ -- not retrieved by visibility. If it is a default with a box, the
-- candidate interpretations, if any, have been collected when building
- -- the renaming declaration. If overloaded, the proper interpretation
- -- is determined in Find_Renamed_Entity. If the entity is an operator,
+ -- the renaming declaration. If overloaded, the proper interpretation is
+ -- determined in Find_Renamed_Entity. If the entity is an operator,
-- Find_Renamed_Entity applies additional visibility checks.
- if Present (Corresponding_Formal_Spec (N)) then
- Is_Actual := True;
- Inst_Node := Unit_Declaration_Node (Corresponding_Formal_Spec (N));
+ if Is_Actual then
+ Inst_Node := Unit_Declaration_Node (Formal_Spec);
if Is_Entity_Name (Nam)
and then Present (Entity (Nam))
-- If there is an immediately visible homonym of the operator
-- and the declaration has a default, this is worth a warning
-- because the user probably did not intend to get the pre-
- -- defined operator, visible in the generic declaration.
- -- To find if there is an intended candidate, analyze the
- -- renaming again in the current context.
+ -- defined operator, visible in the generic declaration. To
+ -- find if there is an intended candidate, analyze the renaming
+ -- again in the current context.
elsif Scope (Old_S) = Standard_Standard
and then Present (Default_Name (Inst_Node))
and then In_Open_Scopes (Scope (Hidden))
and then Is_Immediately_Visible (Hidden)
and then Comes_From_Source (Hidden)
- and then Hidden /= Old_S
+ and then Hidden /= Old_S
then
Error_Msg_Sloc := Sloc (Hidden);
Error_Msg_N ("?default subprogram is resolved " &
-- for it at the freezing point.
Set_Corresponding_Spec (N, Rename_Spec);
- Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S);
- -- The body is created when the entity is frozen. If the context
- -- is generic, freeze_all is not invoked, so we need to indicate
- -- that the entity has a completion.
+ if Nkind (Unit_Declaration_Node (Rename_Spec)) =
+ N_Abstract_Subprogram_Declaration
+ then
+ -- Input and Output stream functions are abstract if the object
+ -- type is abstract. However, these functions may receive explicit
+ -- declarations in representation clauses, making the attribute
+ -- subprograms usable as defaults in subsequent type extensions.
+ -- In this case we rewrite the declaration to make the subprogram
+ -- non-abstract. We remove the previous declaration, and insert
+ -- the new one at the point of the renaming, to prevent premature
+ -- access to unfrozen types. The new declaration reuses the
+ -- specification of the previous one, and must not be analyzed.
+
+ pragma Assert (Is_TSS (Rename_Spec, TSS_Stream_Output)
+ or else Is_TSS (Rename_Spec, TSS_Stream_Input));
- Set_Has_Completion (Rename_Spec, Inside_A_Generic);
+ declare
+ Old_Decl : constant Node_Id :=
+ Unit_Declaration_Node (Rename_Spec);
+ New_Decl : constant Node_Id :=
+ Make_Subprogram_Declaration (Sloc (N),
+ Specification =>
+ Relocate_Node (Specification (Old_Decl)));
+ begin
+ Remove (Old_Decl);
+ Insert_After (N, New_Decl);
+ Set_Is_Abstract_Subprogram (Rename_Spec, False);
+ Set_Analyzed (New_Decl);
+ end;
+ end if;
+
+ Set_Corresponding_Body (Unit_Declaration_Node (Rename_Spec), New_S);
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N ("(Ada 83) renaming cannot serve as a body", N);
end if;
- Set_Convention (New_S, Convention (Rename_Spec));
+ Set_Convention (New_S, Convention (Rename_Spec));
Check_Fully_Conformant (New_S, Rename_Spec);
Set_Public_Status (New_S);
- -- Indicate that the entity in the declaration functions like
- -- the corresponding body, and is not a new entity.
+ -- Indicate that the entity in the declaration functions like the
+ -- corresponding body, and is not a new entity. The body will be
+ -- constructed later at the freeze point, so indicate that the
+ -- completion has not been seen yet.
Set_Ekind (New_S, E_Subprogram_Body);
New_S := Rename_Spec;
+ Set_Has_Completion (Rename_Spec, False);
+
+ -- 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);
+
+ elsif Must_Not_Override (Specification (N))
+ and then Is_Overriding_Operation (Rename_Spec)
+ then
+ Error_Msg_NE
+ ("subprogram& overrides inherited operation", N, Rename_Spec);
+ end if;
else
Generate_Definition (New_S);
New_Overloaded_Entity (New_S);
+
if Is_Entity_Name (Nam)
and then Is_Intrinsic_Subprogram (Entity (Nam))
then
end if;
end if;
- -- There is no need for elaboration checks on the new entity, which
- -- may be called before the next freezing point where the body will
- -- appear. Elaboration checks refer to the real entity, not the one
- -- created by the renaming declaration.
+ -- There is no need for elaboration checks on the new entity, which may
+ -- be called before the next freezing point where the body will appear.
+ -- Elaboration checks refer to the real entity, not the one created by
+ -- the renaming declaration.
Set_Kill_Elaboration_Checks (New_S, True);
elsif Nkind (Nam) = N_Selected_Component then
-- Renamed entity is an entry or protected subprogram. For those
- -- cases an explicit body is built (at the point of freezing of
- -- this entity) that contains a call to the renamed entity.
+ -- cases an explicit body is built (at the point of freezing of this
+ -- entity) that contains a call to the renamed entity.
Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec));
return;
then
Error_Msg_N ("expect valid subprogram name in renaming", N);
return;
-
end if;
- -- Most common case: subprogram renames subprogram. No body is
- -- generated in this case, so we must indicate that the declaration
- -- is complete as is.
+ -- Most common case: subprogram renames subprogram. No body is generated
+ -- in this case, so we must indicate the declaration is complete as is.
if No (Rename_Spec) then
- Set_Has_Completion (New_S);
+ Set_Has_Completion (New_S);
+ Set_Is_Pure (New_S, Is_Pure (Entity (Nam)));
+ Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam)));
+
+ -- Ada 2005 (AI-423): Check the consistency of null exclusions
+ -- between a subprogram and its renaming.
+
+ if Ada_Version >= Ada_05 then
+ Check_Null_Exclusion
+ (Ren => New_S,
+ Sub => Entity (Nam));
+ end if;
end if;
- -- Find the renamed entity that matches the given specification.
- -- Disable Ada_83 because there is no requirement of full conformance
- -- between renamed entity and new entity, even though the same circuit
- -- is used.
+ -- Find the renamed entity that matches the given specification. Disable
+ -- Ada_83 because there is no requirement of full conformance between
+ -- renamed entity and new entity, even though the same circuit is used.
+
+ -- This is a bit of a kludge, which introduces a really irregular use of
+ -- Ada_Version[_Explicit]. Would be nice to find cleaner way to do this
+ -- ???
Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95);
+ Ada_Version_Explicit := Ada_Version;
if No (Old_S) then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
Generate_Reference (Old_S, Nam);
end if;
- -- For a renaming-as-body, require subtype conformance,
- -- but if the declaration being completed has not been
- -- frozen, then inherit the convention of the renamed
- -- subprogram prior to checking conformance (unless the
- -- renaming has an explicit convention established; the
+ -- For a renaming-as-body, require subtype conformance, but if the
+ -- declaration being completed has not been frozen, then inherit the
+ -- convention of the renamed subprogram prior to checking conformance
+ -- (unless the renaming has an explicit convention established; the
-- rule stated in the RM doesn't seem to address this ???).
if Present (Rename_Spec) then
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,
+ -- the renaming_as_body is a completion.
+
+ if Inside_A_Generic then
+ if Is_Frozen (Rename_Spec)
+ and then Is_Intrinsic_Subprogram (Old_S)
+ then
+ Error_Msg_N
+ ("subprogram in renaming_as_body cannot be intrinsic",
+ Name (N));
+ end if;
+
+ Set_Has_Completion (Rename_Spec);
+ end if;
+
elsif Ekind (Old_S) /= E_Operator then
Check_Mode_Conformant (New_S, Old_S);
Set_Alias (New_S, Old_S);
end if;
- -- Note that we do not set Is_Intrinsic_Subprogram if we have
- -- a renaming as body, since the entity in this case is not an
- -- intrinsic (it calls an intrinsic, but we have a real body
- -- for this call, and it is in this body that the required
- -- intrinsic processing will take place).
+ -- Note that we do not set Is_Intrinsic_Subprogram if we have a
+ -- renaming as body, since the entity in this case is not an
+ -- intrinsic (it calls an intrinsic, but we have a real body for
+ -- this call, and it is in this body that the required intrinsic
+ -- processing will take place).
- -- Also, if this is a renaming of inequality, the renamed
- -- operator is intrinsic, but what matters is the corresponding
- -- equality operator, which may be user-defined.
+ -- Also, if this is a renaming of inequality, the renamed operator
+ -- is intrinsic, but what matters is the corresponding equality
+ -- operator, which may be user-defined.
Set_Is_Intrinsic_Subprogram
(New_S,
-- indicate that the renaming is an abstract dispatching operation
-- with a controlling type.
- if Is_Actual
- and then Is_Abstract (Corresponding_Formal_Spec (N))
- then
+ if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) then
+
-- Mark the renaming as abstract here, so Find_Dispatching_Type
-- see it as corresponding to a generic association for a
-- formal abstract subprogram
- Set_Is_Abstract (New_S);
+ Set_Is_Abstract_Subprogram (New_S);
declare
New_S_Ctrl_Type : constant Entity_Id :=
Set_Is_Dispatching_Operation (New_S);
Check_Controlling_Formals (New_S_Ctrl_Type, New_S);
- -- In the case where the actual in the formal subprogram
- -- is itself a formal abstract subprogram association,
- -- there's no dispatch table component or position to
- -- inherit.
+ -- If the actual in the formal subprogram is itself a
+ -- formal abstract subprogram association, there's no
+ -- dispatch table component or position to inherit.
if Present (DTC_Entity (Old_S)) then
Set_DTC_Entity (New_S, DTC_Entity (Old_S));
end if;
Set_Convention (New_S, Convention (Old_S));
- Set_Is_Abstract (New_S, Is_Abstract (Old_S));
+
+ if Is_Abstract_Subprogram (Old_S) then
+ if Present (Rename_Spec) then
+ Error_Msg_N
+ ("a renaming-as-body cannot rename an abstract subprogram",
+ N);
+ Set_Has_Completion (Rename_Spec);
+ else
+ Set_Is_Abstract_Subprogram (New_S);
+ end if;
+ end if;
+
Check_Library_Unit_Renaming (N, Old_S);
- -- Pathological case: procedure renames entry in the scope of
- -- its task. Entry is given by simple name, but body must be built
- -- for procedure. Of course if called it will deadlock.
+ -- Pathological case: procedure renames entry in the scope of its
+ -- task. Entry is given by simple name, but body must be built for
+ -- procedure. Of course if called it will deadlock.
if Ekind (Old_S) = E_Entry then
Set_Has_Completion (New_S, False);
-- where the formal subprogram is also abstract.
if (Ekind (Old_S) = E_Procedure or else Ekind (Old_S) = E_Function)
- and then Is_Abstract (Old_S)
- and then not Is_Abstract (Corresponding_Formal_Spec (N))
+ and then Is_Abstract_Subprogram (Old_S)
+ and then not Is_Abstract_Subprogram (Formal_Spec)
then
Error_Msg_N
("abstract subprogram not allowed as generic actual", Nam);
end if;
else
- -- A common error is to assume that implicit operators for types
- -- are defined in Standard, or in the scope of a subtype. In those
- -- cases where the renamed entity is given with an expanded name,
- -- it is worth mentioning that operators for the type are not
- -- declared in the scope given by the prefix.
+ -- A common error is to assume that implicit operators for types are
+ -- defined in Standard, or in the scope of a subtype. In those cases
+ -- where the renamed entity is given with an expanded name, it is
+ -- worth mentioning that operators for the type are not declared in
+ -- the scope given by the prefix.
if Nkind (Nam) = N_Expanded_Name
and then Nkind (Selector_Name (Nam)) = N_Operator_Symbol
declare
T : constant Entity_Id :=
Base_Type (Etype (First_Formal (New_S)));
-
begin
Error_Msg_Node_2 := Prefix (Nam);
Error_Msg_NE
end if;
end if;
+ -- Ada 2005 AI 404: if the new subprogram is dispatching, verify that
+ -- controlling access parameters are known non-null for the renamed
+ -- subprogram. Test also applies to a subprogram instantiation that
+ -- is dispatching. Test is skipped if some previous error was detected
+ -- that set Old_S to Any_Id.
+
+ if Ada_Version >= Ada_05
+ and then Old_S /= Any_Id
+ and then not Is_Dispatching_Operation (Old_S)
+ and then Is_Dispatching_Operation (New_S)
+ then
+ declare
+ Old_F : Entity_Id;
+ New_F : Entity_Id;
+
+ begin
+ Old_F := First_Formal (Old_S);
+ New_F := First_Formal (New_S);
+ while Present (Old_F) loop
+ if Ekind (Etype (Old_F)) = E_Anonymous_Access_Type
+ and then Is_Controlling_Formal (New_F)
+ and then not Can_Never_Be_Null (Old_F)
+ then
+ Error_Msg_N ("access parameter is controlling,", New_F);
+ Error_Msg_NE
+ ("\corresponding parameter of& "
+ & "must be explicitly null excluding", New_F, Old_S);
+ end if;
+
+ Next_Formal (Old_F);
+ Next_Formal (New_F);
+ end loop;
+ end;
+ end if;
+
+ -- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
+
+ if Comes_From_Source (N)
+ and then Present (Old_S)
+ and then Nkind (Old_S) = N_Defining_Operator_Symbol
+ and then Nkind (New_S) = N_Defining_Operator_Symbol
+ and then Chars (Old_S) /= Chars (New_S)
+ then
+ Error_Msg_NE
+ ("?& is being renamed as a different operator",
+ New_S, Old_S);
+ end if;
+
Ada_Version := Save_AV;
+ Ada_Version_Explicit := Save_AV_Exp;
end Analyze_Subprogram_Renaming;
-------------------------
Set_Hidden_By_Use_Clause (N, No_Elist);
-- Use clause is not allowed in a spec of a predefined package
- -- declaration except that packages whose file name starts a-n
- -- are OK (these are children of Ada.Numerics, and such packages
- -- are never loaded by Rtsfind).
+ -- declaration except that packages whose file name starts a-n are OK
+ -- (these are children of Ada.Numerics, and such packages are never
+ -- loaded by Rtsfind).
if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
and then Name_Buffer (1 .. 3) /= "a-n"
-- Loop through package names to identify referenced packages
Pack_Name := First (Names (N));
-
while Present (Pack_Name) loop
Analyze (Pack_Name);
and then Nkind (Pack_Name) = N_Expanded_Name
then
declare
- Pref : Node_Id := Prefix (Pack_Name);
+ Pref : Node_Id;
begin
+ Pref := Prefix (Pack_Name);
while Nkind (Pref) = N_Expanded_Name loop
Pref := Prefix (Pref);
end loop;
-- use visible.
Pack_Name := First (Names (N));
-
while Present (Pack_Name) loop
-
if Is_Entity_Name (Pack_Name) then
Pack := Entity (Pack_Name);
Next (Pack_Name);
end loop;
-
end Analyze_Use_Package;
----------------------
end if;
Id := First (Subtype_Marks (N));
-
while Present (Id) loop
Find_Type (Id);
Use_One_Type (Id);
if Nkind (Parent (N)) = N_Compilation_Unit then
- if Nkind (Id) = N_Identifier then
- Error_Msg_N ("Type is not directly visible", Id);
+ if Nkind (Id) = N_Identifier then
+ Error_Msg_N ("type is not directly visible", Id);
elsif Is_Child_Unit (Scope (Entity (Id)))
and then Scope (Entity (Id)) /= System_Aux_Id
return False;
elsif In_Use (Pack) then
- Set_Redundant_Use (Pack_Name, True);
+ Note_Redundant_Use (Pack_Name);
return False;
elsif Present (Renamed_Object (Pack))
and then In_Use (Renamed_Object (Pack))
then
- Set_Redundant_Use (Pack_Name, True);
+ Note_Redundant_Use (Pack_Name);
return False;
else
else
Param_Spec := First (Parameter_Specifications (Spec));
-
while Present (Param_Spec) loop
Form_Num := Form_Num + 1;
-- Note that there is no Expr_List in this case anyway
if Aname = Name_AST_Entry then
-
declare
Ent : Entity_Id;
Decl : Node_Id;
-- Case of renaming a function
if Nkind (Spec) = N_Function_Specification then
-
if Is_Procedure_Attribute_Name (Aname) then
Error_Msg_N ("attribute can only be renamed as procedure", Nam);
return;
end if;
- Find_Type (Subtype_Mark (Spec));
- Rewrite (Subtype_Mark (Spec),
- New_Reference_To (Base_Type (Entity (Subtype_Mark (Spec))), Loc));
+ Find_Type (Result_Definition (Spec));
+ Rewrite (Result_Definition (Spec),
+ New_Reference_To (
+ Base_Type (Entity (Result_Definition (Spec))), Loc));
Body_Node :=
Make_Subprogram_Body (Loc,
Statements => New_List (Attr_Node)));
end if;
- Rewrite (N, Body_Node);
- Analyze (N);
+ -- In case of tagged types we add the body of the generated function to
+ -- the freezing actions of the type (because in the general case such
+ -- type is still not frozen). We exclude from this processing generic
+ -- formal subprograms found in instantiations and AST_Entry renamings.
+
+ if not Present (Corresponding_Formal_Spec (N))
+ and then Etype (Nam) /= RTE (RE_AST_Handler)
+ then
+ declare
+ P : constant Entity_Id := Prefix (Nam);
+
+ begin
+ Find_Type (P);
+
+ if Is_Tagged_Type (Etype (P)) then
+ Ensure_Freeze_Node (Etype (P));
+ Append_Freeze_Action (Etype (P), Body_Node);
+ else
+ Rewrite (N, Body_Node);
+ Analyze (N);
+ Set_Etype (New_S, Base_Type (Etype (New_S)));
+ end if;
+ end;
+
+ -- Generic formal subprograms or AST_Handler renaming
+
+ else
+ Rewrite (N, Body_Node);
+ Analyze (N);
+ Set_Etype (New_S, Base_Type (Etype (New_S)));
+ end if;
if Is_Compilation_Unit (New_S) then
Error_Msg_N
("a library unit can only rename another library unit", N);
end if;
- Set_Etype (New_S, Base_Type (Etype (New_S)));
-
-- We suppress elaboration warnings for the resulting entity, since
-- clearly they are not needed, and more particularly, in the case
-- of a generic formal subprogram, the resulting entity can appear
----------------------
procedure Chain_Use_Clause (N : Node_Id) is
+ Pack : Entity_Id;
+ Level : Int := Scope_Stack.Last;
+
begin
+ if not Is_Compilation_Unit (Current_Scope)
+ or else not Is_Child_Unit (Current_Scope)
+ then
+ null; -- Common case
+
+ elsif Defining_Entity (Parent (N)) = Current_Scope then
+ null; -- Common case for compilation unit
+
+ else
+ -- If declaration appears in some other scope, it must be in some
+ -- parent unit when compiling a child.
+
+ Pack := Defining_Entity (Parent (N));
+ if not In_Open_Scopes (Pack) then
+ null; -- default as well
+
+ else
+ -- Find entry for parent unit in scope stack
+
+ while Scope_Stack.Table (Level).Entity /= Pack loop
+ Level := Level - 1;
+ end loop;
+ end if;
+ end if;
+
Set_Next_Use_Clause (N,
- Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
- Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := N;
+ Scope_Stack.Table (Level).First_Use_Clause);
+ Scope_Stack.Table (Level).First_Use_Clause := N;
end Chain_Use_Clause;
---------------------------
and then Item /= N
loop
if Nkind (Item) = N_With_Clause
+
+ -- Protect the frontend against previous critical errors
+
+ and then Nkind (Name (Item)) /= N_Selected_Component
and then Entity (Name (Item)) = Pack
then
Par := Nam;
if Nkind (Parent (N)) /= N_Compilation_Unit then
return;
- elsif Scope (Old_E) /= Standard_Standard
+ -- Check for library unit. Note that we used to check for the scope
+ -- being Standard here, but that was wrong for Standard itself.
+
+ elsif not Is_Compilation_Unit (Old_E)
and then not Is_Child_Unit (Old_E)
then
Error_Msg_N ("renamed unit must be a library unit", Name (N));
begin
Id := First_Entity (Current_Scope);
-
while Present (Id) loop
-- An entity in the current scope is not necessarily the first one
-- on its homonym chain. Find its predecessor if any,
Prev := Empty;
end if;
- Outer := Homonym (Id);
Set_Is_Immediately_Visible (Id, False);
+ Outer := Homonym (Id);
while Present (Outer) and then Scope (Outer) = Current_Scope loop
Outer := Homonym (Outer);
end loop;
F : Entity_Id) return Boolean
is
T : constant Entity_Id := Etype (F);
-
begin
return In_Use (T)
and then Scope (T) = Scope (Op);
begin
Pack_Name := First (Names (N));
-
while Present (Pack_Name) loop
Pack := Entity (Pack_Name);
if Ekind (Pack) = E_Package then
-
if In_Open_Scopes (Pack) then
null;
elsif not Redundant_Use (Pack_Name) then
Set_In_Use (Pack, False);
- Id := First_Entity (Pack);
+ Set_Current_Use_Clause (Pack, Empty);
+ Id := First_Entity (Pack);
while Present (Id) loop
-- Preserve use-visibility of operators that are primitive
if Present (Renamed_Object (Pack)) then
Set_In_Use (Renamed_Object (Pack), False);
+ Set_Current_Use_Clause (Renamed_Object (Pack), Empty);
end if;
if Chars (Pack) = Name_System
and then Present_System_Aux
then
Id := First_Entity (System_Aux_Id);
-
while Present (Id) loop
Set_Is_Potentially_Use_Visible (Id, False);
else
Set_Redundant_Use (Pack_Name, False);
end if;
-
end if;
Next (Pack_Name);
if Present (Hidden_By_Use_Clause (N)) then
Elmt := First_Elmt (Hidden_By_Use_Clause (N));
-
while Present (Elmt) loop
Set_Is_Immediately_Visible (Node (Elmt));
Next_Elmt (Elmt);
begin
Id := First (Subtype_Marks (N));
-
while Present (Id) loop
-- A call to rtsfind may occur while analyzing a use_type clause,
T := Entity (Id);
- if T = Any_Type then
+ if T = Any_Type
+ or else From_With_Type (T)
+ then
null;
- -- Note that the use_Type clause may mention a subtype of the
- -- type whose primitive operations have been made visible. Here
- -- as elsewhere, it is the base type that matters for visibility.
+ -- Note that the use_Type clause may mention a subtype of the type
+ -- whose primitive operations have been made visible. Here as
+ -- elsewhere, it is the base type that matters for visibility.
elsif In_Open_Scopes (Scope (Base_Type (T))) then
null;
Set_In_Use (T, False);
Set_In_Use (Base_Type (T), False);
Op_List := Collect_Primitive_Operations (T);
- Elmt := First_Elmt (Op_List);
+ Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
-
if Nkind (Node (Elmt)) = N_Defining_Operator_Symbol then
Set_Is_Potentially_Use_Visible (Node (Elmt), False);
end if;
return False;
else
Inst := Current_Scope;
-
while Present (Inst)
and then Ekind (Inst) /= E_Package
and then not Is_Generic_Instance (Inst)
end if;
Act := First_Entity (Inst);
-
while Present (Act) loop
if Ekind (Act) = E_Package then
if Nvis_Is_Private_Subprg then
pragma Assert (Nkind (E2) = N_Defining_Identifier
- and then Ekind (E2) = E_Function
- and then Scope (E2) = Standard_Standard
- and then Has_Private_With (E2));
+ and then Ekind (E2) = E_Function
+ and then Scope (E2) = Standard_Standard
+ and then Has_Private_With (E2));
-- Find the sloc corresponding to the private with'ed unit
- Comp_Unit := Cunit (Current_Sem_Unit);
- Item := First (Context_Items (Comp_Unit));
+ Comp_Unit := Cunit (Current_Sem_Unit);
Error_Msg_Sloc := No_Location;
+ Item := First (Context_Items (Comp_Unit));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
Ent := Homonyms;
while Present (Ent) loop
if Is_Potentially_Use_Visible (Ent) then
-
if not Hidden then
Error_Msg_N ("multiple use clauses cause hiding!", N);
Hidden := True;
and then
Nkind (Parent (Parent (N))) = N_Use_Package_Clause
then
- Error_Msg_NE
- ("\possibly missing with_clause for&", N, Ent);
+ Error_Msg_Qual_Level := 99;
+ Error_Msg_NE ("\\missing `WITH &;`", N, Ent);
+ Error_Msg_Qual_Level := 0;
end if;
end if;
<<Continue>>
Ent := Homonym (Ent);
end loop;
-
end if;
end Nvis_Messages;
Case_Str : constant String := Name_Buffer (1 .. Name_Len);
Case_Stm : constant Node_Id := Parent (Parent (N));
Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
+ Case_Rtp : constant Entity_Id := Root_Type (Case_Typ);
Lit : Node_Id;
begin
if Is_Enumeration_Type (Case_Typ)
- and then Case_Typ /= Standard_Character
- and then Case_Typ /= Standard_Wide_Character
- and then Case_Typ /= Standard_Wide_Wide_Character
+ and then Case_Rtp /= Standard_Character
+ and then Case_Rtp /= Standard_Wide_Character
+ and then Case_Rtp /= Standard_Wide_Wide_Character
then
Lit := First_Literal (Case_Typ);
Get_Name_String (Chars (Lit));
-- this is a very common error for beginners to make).
if Chars (N) = Name_Put or else Chars (N) = Name_Put_Line then
- Error_Msg_N ("\possible missing with of 'Text_'I'O!", N);
+ Error_Msg_N
+ ("\\possible missing `WITH Ada.Text_'I'O; " &
+ "USE Ada.Text_'I'O`!", N);
+
+ -- Another special check if N is the prefix of a selected
+ -- component which is a known unit, add message complaining
+ -- about missing with for this unit.
+
+ elsif Nkind (Parent (N)) = N_Selected_Component
+ and then N = Prefix (Parent (N))
+ and then Is_Known_Unit (Parent (N))
+ then
+ Error_Msg_Node_2 := Selector_Name (Parent (N));
+ Error_Msg_N ("\\missing `WITH &.&;`", Prefix (Parent (N)));
end if;
-- Now check for possible misspellings
Get_Name_String (N);
if Is_Bad_Spelling_Of
- (Name_Buffer (1 .. Name_Len), S)
+ (S, Name_Buffer (1 .. Name_Len))
then
Ematch := E;
exit;
end;
end if;
- -- Make entry in undefined references table unless the full
- -- errors switch is set, in which case by refraining from
- -- generating the table entry, we guarantee that we get an
- -- error message for every undefined reference.
+ -- Make entry in undefined references table unless the full errors
+ -- switch is set, in which case by refraining from generating the
+ -- table entry, we guarantee that we get an error message for every
+ -- undefined reference.
if not All_Errors_Mode then
Urefs.Increment_Last;
begin
E2 := Homonym (E);
-
while Present (E2) loop
if Is_Immediately_Visible (E2) then
else
if In_Instance then
- Inst := Current_Scope;
-- Find current instance
+ Inst := Current_Scope;
while Present (Inst)
and then Inst /= Standard_Standard
loop
end loop;
E2 := E;
-
while Present (E2) loop
if From_Actual_Package (E2)
or else
Nvis_Messages;
return;
+ elsif
+ Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+ then
+ -- A use-clause in the body of a system file creates conflict
+ -- with some entity in a user scope, while rtsfind is active.
+ -- Keep only the entity coming from another predefined unit.
+
+ E2 := E;
+ while Present (E2) loop
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Sloc (E2))))
+ then
+ E := E2;
+ goto Found;
+ end if;
+
+ E2 := Homonym (E2);
+ end loop;
+
+ -- Entity must exist because predefined unit is correct
+
+ raise Program_Error;
+
else
Nvis_Messages;
return;
E2 := Homonym (E);
while Present (E2) loop
if Is_Immediately_Visible (E2) then
- for J in Level + 1 .. Scope_Stack.Last loop
- if Scope_Stack.Table (J).Entity = Scope (E2)
- or else Scope_Stack.Table (J).Entity = E2
- then
- Level := J;
- E := E2;
- exit;
- end if;
- end loop;
+
+ -- If a generic package contains a local declaration that
+ -- has the same name as the generic, there may be a visibility
+ -- conflict in an instance, where the local declaration must
+ -- also hide the name of the corresponding package renaming.
+ -- We check explicitly for a package declared by a renaming,
+ -- whose renamed entity is an instance that is on the scope
+ -- stack, and that contains a homonym in the same scope. Once
+ -- we have found it, we know that the package renaming is not
+ -- immediately visible, and that the identifier denotes the
+ -- other entity (and its homonyms if overloaded).
+
+ if Scope (E) = Scope (E2)
+ and then Ekind (E) = E_Package
+ and then Present (Renamed_Object (E))
+ and then Is_Generic_Instance (Renamed_Object (E))
+ and then In_Open_Scopes (Renamed_Object (E))
+ and then Comes_From_Source (N)
+ then
+ Set_Is_Immediately_Visible (E, False);
+ E := E2;
+
+ else
+ for J in Level + 1 .. Scope_Stack.Last loop
+ if Scope_Stack.Table (J).Entity = Scope (E2)
+ or else Scope_Stack.Table (J).Entity = E2
+ then
+ Level := J;
+ E := E2;
+ exit;
+ end if;
+ end loop;
+ end if;
end if;
E2 := Homonym (E2);
if Comes_From_Source (N)
and then Is_Remote_Access_To_Subprogram_Type (E)
and then Expander_Active
+ and then Get_PCS_Name /= Name_No_DSA
then
Rewrite (N,
New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
then
Premature_Usage (N);
- -- If the entity is overloadable, collect all interpretations
- -- of the name for subsequent overload resolution. We optimize
- -- a bit here to do this only if we have an overloadable entity
- -- that is not on its own on the homonym chain.
+ -- If the entity is overloadable, collect all interpretations of the
+ -- name for subsequent overload resolution. We optimize a bit here to
+ -- do this only if we have an overloadable entity that is not on its
+ -- own on the homonym chain.
elsif Is_Overloadable (E)
and then (Present (Homonym (E)) or else Current_Entity (N) /= E)
-- to the discriminant in the initialization procedure.
else
- -- Entity is unambiguous, indicate that it is referenced here
- -- One slightly odd case is that we do not want to set the
- -- Referenced flag if the entity is a label, and the identifier
- -- is the label in the source, since this is not a reference
- -- from the point of view of the user
+ -- Entity is unambiguous, indicate that it is referenced here One
+ -- slightly odd case is that we do not want to set the Referenced
+ -- flag if the entity is a label, and the identifier is the label
+ -- in the source, since this is not a reference from the point of
+ -- view of the user
if Nkind (Parent (N)) = N_Label then
declare
else
Generate_Reference (E, N);
+ Check_Nested_Access (E);
end if;
- -- Set Entity, with style check if need be. If this is a
- -- discriminant reference, it must be replaced by the
- -- corresponding discriminal, that is to say the parameter
- -- of the initialization procedure that corresponds to the
- -- discriminant. If this replacement is being performed, there
+ -- Set Entity, with style check if need be. For a discriminant
+ -- reference, replace by the corresponding discriminal, i.e. the
+ -- parameter of the initialization procedure that corresponds to
+ -- the discriminant. If this replacement is being performed, there
-- is no style check to perform.
-- This replacement must not be done if we are currently
elsif Is_Concurrent_Type (Scope (E)) then
declare
- P : Node_Id := Parent (N);
+ P : Node_Id;
begin
+ P := Parent (N);
while Present (P)
and then Nkind (P) /= N_Parameter_Specification
and then Nkind (P) /= N_Component_Declaration
Id := Current_Entity (Selector);
- while Present (Id) loop
-
- if Scope (Id) = P_Name then
- Candidate := Id;
+ declare
+ Is_New_Candidate : Boolean;
- if Is_Child_Unit (Id) then
- exit when Is_Visible_Child_Unit (Id)
- or else Is_Immediately_Visible (Id);
+ begin
+ while Present (Id) loop
+ if Scope (Id) = P_Name then
+ Candidate := Id;
+ Is_New_Candidate := True;
+
+ -- Ada 2005 (AI-217): Handle shadow entities associated with types
+ -- declared in limited-withed nested packages. We don't need to
+ -- handle E_Incomplete_Subtype entities because the entities in
+ -- the limited view are always E_Incomplete_Type entities (see
+ -- Build_Limited_Views). Regarding the expression used to evaluate
+ -- the scope, it is important to note that the limited view also
+ -- has shadow entities associated nested packages. For this reason
+ -- the correct scope of the entity is the scope of the real entity
+
+ elsif From_With_Type (Id)
+ and then Is_Type (Id)
+ and then Ekind (Id) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Id))
+ and then Scope (Non_Limited_View (Id)) = P_Name
+ then
+ Candidate := Non_Limited_View (Id);
+ Is_New_Candidate := True;
else
- exit when not Is_Hidden (Id)
- or else Is_Immediately_Visible (Id);
+ Is_New_Candidate := False;
end if;
- end if;
- Id := Homonym (Id);
- end loop;
+ if Is_New_Candidate then
+ if Is_Child_Unit (Id) then
+ exit when Is_Visible_Child_Unit (Id)
+ or else Is_Immediately_Visible (Id);
+
+ else
+ exit when not Is_Hidden (Id)
+ or else Is_Immediately_Visible (Id);
+ end if;
+ end if;
+
+ Id := Homonym (Id);
+ end loop;
+ end;
if No (Id)
and then (Ekind (P_Name) = E_Procedure
if Present (Candidate) then
+ -- If we know that the unit is a child unit we can give a more
+ -- accurate error message.
+
if Is_Child_Unit (Candidate) then
- Error_Msg_N
- ("missing with_clause for child unit &", Selector);
+
+ -- If the candidate is a private child unit and we are in
+ -- the visible part of a public unit, specialize the error
+ -- message. There might be a private with_clause for it,
+ -- but it is not currently active.
+
+ if Is_Private_Descendant (Candidate)
+ and then Ekind (Current_Scope) = E_Package
+ and then not In_Private_Part (Current_Scope)
+ and then not Is_Private_Descendant (Current_Scope)
+ then
+ Error_Msg_N ("private child unit& is not visible here",
+ Selector);
+
+ -- Normal case where we have a missing with for a child unit
+
+ else
+ Error_Msg_Qual_Level := 99;
+ Error_Msg_NE ("missing `WITH &;`", Selector, Candidate);
+ Error_Msg_Qual_Level := 0;
+ end if;
+
+ -- Here we don't know that this is a child unit
+
else
Error_Msg_NE ("& is not a visible entity of&", N, Selector);
end if;
else
-- Within the instantiation of a child unit, the prefix may
- -- denote the parent instance, but the selector has the
- -- name of the original child. Find whether we are within
- -- the corresponding instance, and get the proper entity, which
+ -- denote the parent instance, but the selector has the name
+ -- of the original child. Find whether we are within the
+ -- corresponding instance, and get the proper entity, which
-- can only be an enclosing scope.
if O_Name /= P_Name
and then Chars (P) = Chars (Selector)
then
Id := S;
- goto found;
+ goto Found;
end if;
end if;
end;
end if;
- if Chars (P_Name) = Name_Ada
- and then Scope (P_Name) = Standard_Standard
- then
- Error_Msg_Node_2 := Selector;
- Error_Msg_NE ("missing with for `&.&`", N, P_Name);
+ -- If this is a selection from Ada, System or Interfaces, then
+ -- we assume a missing with for the corresponding package.
+
+ if Is_Known_Unit (N) then
+ if not Error_Posted (N) then
+ Error_Msg_Node_2 := Selector;
+ Error_Msg_N ("missing `WITH &.&;`", Prefix (N));
+ end if;
- -- If this is a selection from a dummy package, then
- -- suppress the error message, of course the entity
- -- is missing if the package is missing!
+ -- If this is a selection from a dummy package, then suppress
+ -- the error message, of course the entity is missing if the
+ -- package is missing!
elsif Sloc (Error_Msg_Node_2) = No_Location then
null;
-- Here we have the case of an undefined component
else
-
Error_Msg_NE ("& not declared in&", N, Selector);
-- Check for misspelling of some entity in prefix
and then Is_Compilation_Unit
(Generic_Parent (Parent (Entity (Prefix (N)))))
then
- Error_Msg_NE
- ("\possible missing with clause on child unit&",
- N, Selector);
+ Error_Msg_Node_2 := Selector;
+ Error_Msg_N ("\missing `WITH &.&;`", Prefix (N));
end if;
end if;
end if;
end if;
end if;
- <<found>>
+ <<Found>>
if Comes_From_Source (N)
and then Is_Remote_Access_To_Subprogram_Type (Id)
+ and then Present (Equivalent_Type (Id))
then
+ -- If we are not actually generating distribution code (i.e. the
+ -- current PCS is the dummy non-distributed version), then the
+ -- Equivalent_Type will be missing, and Id should be treated as
+ -- a regular access-to-subprogram type.
+
Id := Equivalent_Type (Id);
Set_Chars (Selector, Chars (Id));
end if;
and then
Nkind (Parent (Parent (N))) /= N_Attribute_Reference))
then
- -- It is an entry call after all, either to the current task
- -- (which will deadlock) or to an enclosing task.
+ -- It is an entry call after all, either to the current task (which
+ -- will deadlock) or to an enclosing task.
Analyze_Selected_Component (N);
return;
Change_Selected_Component_To_Expanded_Name (N);
-- Do style check and generate reference, but skip both steps if this
- -- entity has homonyms, since we may not have the right homonym set
- -- yet. The proper homonym will be set during the resolve phase.
+ -- entity has homonyms, since we may not have the right homonym set yet.
+ -- The proper homonym will be set during the resolve phase.
if Has_Homonym (Id) then
Set_Entity (N, Id);
Set_Etype (N, Get_Full_View (Etype (Id)));
end if;
- -- If the Ekind of the entity is Void, it means that all homonyms
- -- are hidden from all visibility (RM 8.3(5,14-20)).
+ -- If the Ekind of the entity is Void, it means that all homonyms are
+ -- hidden from all visibility (RM 8.3(5,14-20)).
if Ekind (Id) = E_Void then
Premature_Usage (N);
H := Homonym (H);
end loop;
- -- If an extension of System is present, collect possible
- -- explicit overloadings declared in the extension.
+ -- If an extension of System is present, collect possible explicit
+ -- overloadings declared in the extension.
if Chars (P_Name) = Name_System
and then Scope (P_Name) = Standard_Standard
if Nkind (Selector_Name (N)) = N_Operator_Symbol
and then Scope (Id) /= Standard_Standard
then
- -- In addition to user-defined operators in the given scope,
- -- there may be an implicit instance of the predefined
- -- operator. The operator (defined in Standard) is found
- -- in Has_Implicit_Operator, and added to the interpretations.
- -- Procedure Add_One_Interp will determine which hides which.
+ -- In addition to user-defined operators in the given scope, there
+ -- may be an implicit instance of the predefined operator. The
+ -- operator (defined in Standard) is found in Has_Implicit_Operator,
+ -- and added to the interpretations. Procedure Add_One_Interp will
+ -- determine which hides which.
if Has_Implicit_Operator (N) then
null;
-- to this enclosing instance, we know that the default was properly
-- resolved when analyzing the generic, so we prefer the local
-- candidates to those that are external. This is not always the case
- -- but is a reasonable heuristic on the use of nested generics.
- -- The proper solution requires a full renaming model.
-
- function Within (Inner, Outer : Entity_Id) return Boolean;
- -- Determine whether a candidate subprogram is defined within
- -- the enclosing instance. If yes, it has precedence over outer
- -- candidates.
+ -- but is a reasonable heuristic on the use of nested generics. The
+ -- proper solution requires a full renaming model.
function Is_Visible_Operation (Op : Entity_Id) return Boolean;
-- If the renamed entity is an implicit operator, check whether it is
- -- visible because its operand type is properly visible. This
- -- check applies to explicit renamed entities that appear in the
- -- source in a renaming declaration or a formal subprogram instance,
- -- but not to default generic actuals with a name.
+ -- visible because its operand type is properly visible. This check
+ -- applies to explicit renamed entities that appear in the source in a
+ -- renaming declaration or a formal subprogram instance, but not to
+ -- default generic actuals with a name.
+
+ function Report_Overload return Entity_Id;
+ -- List possible interpretations, and specialize message in the
+ -- case of a generic actual.
+
+ function Within (Inner, Outer : Entity_Id) return Boolean;
+ -- Determine whether a candidate subprogram is defined within the
+ -- enclosing instance. If yes, it has precedence over outer candidates.
------------------------
-- Enclosing_Instance --
end if;
S := Scope (Current_Scope);
-
while S /= Standard_Standard loop
-
if Is_Generic_Instance (S) then
return S;
end if;
------------
function Within (Inner, Outer : Entity_Id) return Boolean is
- Sc : Entity_Id := Scope (Inner);
+ Sc : Entity_Id;
begin
+ Sc := Scope (Inner);
while Sc /= Standard_Standard loop
-
if Sc = Outer then
return True;
else
return False;
end Within;
- function Report_Overload return Entity_Id;
- -- List possible interpretations, and specialize message in the
- -- case of a generic actual.
+ ---------------------
+ -- Report_Overload --
+ ---------------------
function Report_Overload return Entity_Id is
begin
if Is_Actual then
Error_Msg_NE
("ambiguous actual subprogram&, " &
- "possible interpretations: ", N, Nam);
+ "possible interpretations:", N, Nam);
else
Error_Msg_N
("ambiguous subprogram, " &
- "possible interpretations: ", N);
+ "possible interpretations:", N);
end if;
List_Interps (Nam, N);
else
Get_First_Interp (Nam, Ind, It);
-
while Present (It.Nam) loop
-
if Entity_Matches_Spec (It.Nam, New_S)
and then Is_Visible_Operation (It.Nam)
then
It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S));
if It1 = No_Interp then
-
Inst := Enclosing_Instance;
if Present (Inst) then
-
if Within (It.Nam, Inst) then
return (It.Nam);
-
elsif Within (Old_S, Inst) then
return (Old_S);
-
else
return Report_Overload;
end if;
if Nkind (P) = N_Error then
return;
- -- If the selector already has an entity, the node has been
- -- constructed in the course of expansion, and is known to be
- -- valid. Do not verify that it is defined for the type (it may
- -- be a private component used in the expansion of record equality).
+ -- If the selector already has an entity, the node has been constructed
+ -- in the course of expansion, and is known to be valid. Do not verify
+ -- that it is defined for the type (it may be a private component used
+ -- in the expansion of record equality).
elsif Present (Entity (Selector_Name (N))) then
declare
Typ : constant Entity_Id := Etype (N);
Decl : constant Node_Id := Declaration_Node (Typ);
-
begin
if Nkind (Decl) = N_Subtype_Declaration
and then not Analyzed (Decl)
begin
Get_First_Interp (P, Ind, It);
-
while Present (It.Nam) loop
-
if In_Open_Scopes (It.Nam) then
if Found then
Error_Msg_N (
else
-- If no interpretation as an expanded name is possible, it
-- must be a selected component of a record returned by a
- -- function call. Reformat prefix as a function call, the
- -- rest is done by type resolution. If the prefix is a
- -- procedure or entry, as is P.X; this is an error.
+ -- function call. Reformat prefix as a function call, the rest
+ -- is done by type resolution. If the prefix is procedure or
+ -- entry, as is P.X; this is an error.
if Ekind (P_Name) /= E_Function
and then (not Is_Overloaded (P)
or else
Nkind (Parent (N)) = N_Procedure_Call_Statement)
then
-
-- Prefix may mention a package that is hidden by a local
-- declaration: let the user know. Scan the full homonym
-- chain, the candidate package may be anywhere on it.
T := Base_Type (Entity (Prefix (N)));
- -- Case of non-tagged type
+ -- Case type is not known to be tagged. Its appearance in the
+ -- prefix of the 'Class attribute indicates that the full view
+ -- will be tagged.
if not Is_Tagged_Type (T) then
if Ekind (T) = E_Incomplete_Type then
-- type. The full type will have to be tagged, of course.
Set_Is_Tagged_Type (T);
+ Set_Primitive_Operations (T, New_Elmt_List);
Make_Class_Wide_Type (T);
Set_Entity (N, Class_Wide_Type (T));
Set_Etype (N, Class_Wide_Type (T));
and then not Is_Generic_Type (T)
and then In_Private_Part (Scope (T))
then
- -- The Class attribute can be applied to an untagged
- -- private type fulfilled by a tagged type prior to
- -- the full type declaration (but only within the
- -- parent package's private part). Create the class-wide
- -- type now and check that the full type is tagged
- -- later during its analysis. Note that we do not
- -- mark the private type as tagged, unlike the case
- -- of incomplete types, because the type must still
+ -- The Class attribute can be applied to an untagged private
+ -- type fulfilled by a tagged type prior to the full type
+ -- declaration (but only within the parent package's private
+ -- part). Create the class-wide type now and check that the
+ -- full type is tagged later during its analysis. Note that
+ -- we do not mark the private type as tagged, unlike the
+ -- case of incomplete types, because the type must still
-- appear untagged to outside units.
- if not Present (Class_Wide_Type (T)) then
+ if No (Class_Wide_Type (T)) then
Make_Class_Wide_Type (T);
end if;
Set_Etype (N, Class_Wide_Type (T));
else
- -- Should we introduce a type Any_Tagged and use
- -- Wrong_Type here, it would be a bit more consistent???
+ -- Should we introduce a type Any_Tagged and use Wrong_Type
+ -- here, it would be a bit more consistent???
Error_Msg_NE
("tagged type required, found}",
-- Case of tagged type
else
- C := Class_Wide_Type (Entity (Prefix (N)));
+ if Is_Concurrent_Type (T) then
+ if No (Corresponding_Record_Type (Entity (Prefix (N)))) then
+
+ -- Previous error. Use current type, which at least
+ -- provides some operations.
+
+ C := Entity (Prefix (N));
+
+ else
+ C := Class_Wide_Type
+ (Corresponding_Record_Type (Entity (Prefix (N))));
+ end if;
+
+ else
+ C := Class_Wide_Type (Entity (Prefix (N)));
+ end if;
+
Set_Entity_With_Style_Check (N, C);
Generate_Reference (C, N);
Set_Etype (N, C);
Set_Etype (N, T);
end if;
+ elsif Attribute_Name (N) = Name_Stub_Type then
+
+ -- This is handled in Analyze_Attribute
+
+ Analyze (N);
+
-- All other attributes are invalid in a subtype mark
else
then
Error_Msg_Sloc := Sloc (T_Name);
Error_Msg_N ("subtype mark required in this context", N);
- Error_Msg_NE ("\found & declared#", N, T_Name);
+ Error_Msg_NE ("\\found & declared#", N, T_Name);
Set_Entity (N, Any_Type);
else
if In_Open_Scopes (T_Name) then
if Ekind (Base_Type (T_Name)) = E_Task_Type then
- Error_Msg_N ("task type cannot be used as type mark " &
- "within its own body", N);
+
+ -- In Ada 2005, a task name can be used in an access
+ -- definition within its own body.
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Parent (N)) = N_Access_Definition
+ then
+ Set_Entity (N, T_Name);
+ Set_Etype (N, T_Name);
+ return;
+
+ else
+ Error_Msg_N
+ ("task type cannot be used as type mark " &
+ "within its own spec or body", N);
+ end if;
+
+ elsif Ekind (Base_Type (T_Name)) = E_Protected_Type then
+
+ -- In Ada 2005, a protected name can be used in an access
+ -- definition within its own body.
+
+ if Ada_Version >= Ada_05
+ and then Nkind (Parent (N)) = N_Access_Definition
+ then
+ Set_Entity (N, T_Name);
+ Set_Etype (N, T_Name);
+ return;
+
+ else
+ Error_Msg_N
+ ("protected type cannot be used as type mark " &
+ "within its own spec or body", N);
+ end if;
+
else
Error_Msg_N ("type declaration cannot refer to itself", N);
end if;
procedure Add_Implicit_Operator
(T : Entity_Id;
Op_Type : Entity_Id := Empty);
- -- Add implicit interpretation to node N, using the type for which
- -- a predefined operator exists. If the operator yields a boolean
- -- type, the Operand_Type is implicitly referenced by the operator,
- -- and a reference to it must be generated.
+ -- Add implicit interpretation to node N, using the type for which a
+ -- predefined operator exists. If the operator yields a boolean type,
+ -- the Operand_Type is implicitly referenced by the operator, and a
+ -- reference to it must be generated.
---------------------------
-- Add_Implicit_Operator --
-- Start of processing for Has_Implicit_Operator
begin
-
if Ekind (P) = E_Package
and then not In_Open_Scopes (P)
then
-- array of Boolean type.
when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor =>
-
while Id /= Priv_Id loop
-
if Valid_Boolean_Arg (Id)
and then Id = Base_Type (Id)
then
-- Equality: look for any non-limited type (result is Boolean)
when Name_Op_Eq | Name_Op_Ne =>
-
while Id /= Priv_Id loop
-
if Is_Type (Id)
and then not Is_Limited_Type (Id)
and then Id = Base_Type (Id)
-- Comparison operators: scalar type, or array of scalar
when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
-
while Id /= Priv_Id loop
if (Is_Scalar_Type (Id)
or else (Is_Array_Type (Id)
Name_Op_Multiply |
Name_Op_Divide |
Name_Op_Expon =>
-
while Id /= Priv_Id loop
if Is_Numeric_Type (Id)
and then Id = Base_Type (Id)
-- Concatenation: any one-dimensional array type
when Name_Op_Concat =>
-
while Id /= Priv_Id loop
if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
and then Id = Base_Type (Id)
-- subtype of Name_Id that would restrict to operators ???
when others => null;
-
end case;
-- If we fall through, then we do not have an implicit operator
function In_Open_Scopes (S : Entity_Id) return Boolean is
begin
- -- Since there are several scope stacks maintained by Scope_Stack each
- -- delineated by Standard (see comments by definition of Scope_Stack)
- -- it is necessary to end the search when Standard is reached.
+ -- Several scope stacks are maintained by Scope_Stack. The base of the
+ -- currently active scope stack is denoted by the Is_Active_Stack_Base
+ -- flag in the scope stack entry. Note that the scope stacks used to
+ -- simply be delimited implicitly by the presence of Standard_Standard
+ -- at their base, but there now are cases where this is not sufficient
+ -- because Standard_Standard actually may appear in the middle of the
+ -- active set of scopes.
for J in reverse 0 .. Scope_Stack.Last loop
if Scope_Stack.Table (J).Entity = S then
return True;
end if;
- -- We need Is_Active_Stack_Base to tell us when to stop rather
- -- than checking for Standard_Standard because there are cases
- -- where Standard_Standard appears in the middle of the active
- -- set of scopes. This affects the declaration and overriding
- -- of private inherited operations in instantiations of generic
- -- child units.
+ -- Check Is_Active_Stack_Base to tell us when to stop, as there are
+ -- cases where Standard_Standard appears in the middle of the active
+ -- set of scopes. This affects the declaration and overriding of
+ -- private inherited operations in instantiations of generic child
+ -- units.
exit when Scope_Stack.Table (J).Is_Active_Stack_Base;
end loop;
begin
if Ekind (Old_S) = E_Operator then
-
New_F := First_Formal (New_S);
while Present (New_F) loop
(Clause : Node_Id;
Force_Installation : Boolean := False)
is
- U : Node_Id := Clause;
+ U : Node_Id;
P : Node_Id;
Id : Entity_Id;
begin
+ U := Clause;
while Present (U) loop
-- Case of USE package
if Nkind (U) = N_Use_Package_Clause then
P := First (Names (U));
-
while Present (P) loop
Id := Entity (P);
if Ekind (Id) = E_Package then
-
if In_Use (Id) then
- Set_Redundant_Use (P, True);
+ Note_Redundant_Use (P);
elsif Present (Renamed_Object (Id))
and then In_Use (Renamed_Object (Id))
then
- Set_Redundant_Use (P, True);
+ Note_Redundant_Use (P);
elsif Force_Installation or else Applicable_Use (P) then
Use_One_Package (Id, U);
Next (P);
end loop;
- -- case of USE TYPE
+ -- Case of USE TYPE
else
P := First (Subtype_Marks (U));
-
while Present (P) loop
if not Is_Entity_Name (P)
or else No (Entity (P))
-- Determine if given type has components (i.e. is either a record
-- type or a type that has discriminants).
+ --------------------
+ -- Has_Components --
+ --------------------
+
function Has_Components (T1 : Entity_Id) return Boolean is
begin
return Is_Record_Type (T1)
or else (Is_Private_Type (T1) and then Has_Discriminants (T1))
- or else (Is_Task_Type (T1) and then Has_Discriminants (T1));
+ or else (Is_Task_Type (T1) and then Has_Discriminants (T1))
+ or else (Is_Incomplete_Type (T1)
+ and then From_With_Type (T1)
+ and then Present (Non_Limited_View (T1))
+ and then Is_Record_Type (Non_Limited_View (T1)));
end Has_Components;
-- Start of processing for Is_Appropriate_For_Record
return
Present (T)
and then (Has_Components (T)
- or else (Is_Access_Type (T)
- and then
- Has_Components (Designated_Type (T))));
+ or else (Is_Access_Type (T)
+ and then Has_Components (Designated_Type (T))));
end Is_Appropriate_For_Record;
+ ------------------------
+ -- Note_Redundant_Use --
+ ------------------------
+
+ procedure Note_Redundant_Use (Clause : Node_Id) is
+ Pack_Name : constant Entity_Id := Entity (Clause);
+ Cur_Use : constant Node_Id := Current_Use_Clause (Pack_Name);
+ Decl : constant Node_Id := Parent (Clause);
+
+ Prev_Use : Node_Id := Empty;
+ Redundant : Node_Id := Empty;
+ -- The Use_Clause which is actually redundant. In the simplest case
+ -- it is Pack itself, but when we compile a body we install its
+ -- context before that of its spec, in which case it is the use_clause
+ -- in the spec that will appear to be redundant, and we want the
+ -- warning to be placed on the body. Similar complications appear when
+ -- the redundancy is between a child unit and one of its ancestors.
+
+ begin
+ Set_Redundant_Use (Clause, True);
+
+ if not Comes_From_Source (Clause)
+ or else In_Instance
+ or else not Warn_On_Redundant_Constructs
+ then
+ return;
+ end if;
+
+ if not Is_Compilation_Unit (Current_Scope) then
+
+ -- If the use_clause is in an inner scope, it is made redundant
+ -- by some clause in the current context, with one exception:
+ -- If we're compiling a nested package body, and the use_clause
+ -- comes from the corresponding spec, the clause is not necessarily
+ -- fully redundant, so we should not warn. If a warning was
+ -- warranted, it would have been given when the spec was processed.
+
+ if Nkind (Parent (Decl)) = N_Package_Specification then
+ declare
+ Package_Spec_Entity : constant Entity_Id :=
+ Defining_Unit_Name (Parent (Decl));
+ begin
+ if In_Package_Body (Package_Spec_Entity) then
+ return;
+ end if;
+ end;
+ end if;
+
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
+ declare
+ Cur_Unit : constant Unit_Number_Type := Get_Source_Unit (Cur_Use);
+ New_Unit : constant Unit_Number_Type := Get_Source_Unit (Clause);
+ Scop : Entity_Id;
+
+ begin
+ if Cur_Unit = New_Unit then
+
+ -- Redundant clause in same body
+
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ elsif Cur_Unit = Current_Sem_Unit then
+
+ -- If the new clause is not in the current unit it has been
+ -- analyzed first, and it makes the other one redundant.
+ -- However, if the new clause appears in a subunit, Cur_Unit
+ -- is still the parent, and in that case the redundant one
+ -- is the one appearing in the subunit.
+
+ if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ -- Most common case: redundant clause in body,
+ -- original clause in spec. Current scope is spec entity.
+
+ elsif
+ Current_Scope =
+ Defining_Entity (
+ Unit (Library_Unit (Cunit (Current_Sem_Unit))))
+ then
+ Redundant := Cur_Use;
+ Prev_Use := Clause;
+
+ else
+ -- The new clause may appear in an unrelated unit, when
+ -- the parents of a generic are being installed prior to
+ -- instantiation. In this case there must be no warning.
+ -- We detect this case by checking whether the current top
+ -- of the stack is related to the current compilation.
+
+ Scop := Current_Scope;
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Is_Compilation_Unit (Scop)
+ and then not Is_Child_Unit (Scop)
+ then
+ return;
+
+ elsif Scop = Cunit_Entity (Current_Sem_Unit) then
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ Redundant := Cur_Use;
+ Prev_Use := Clause;
+ end if;
+
+ elsif New_Unit = Current_Sem_Unit then
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+
+ else
+ -- Neither is the current unit, so they appear in parent or
+ -- sibling units. Warning will be emitted elsewhere.
+
+ return;
+ end if;
+ end;
+
+ elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
+ and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit))))
+ then
+ -- Use_clause is in child unit of current unit, and the child
+ -- unit appears in the context of the body of the parent, so it
+ -- has been installed first, even though it is the redundant one.
+ -- Depending on their placement in the context, the visible or the
+ -- private parts of the two units, either might appear as redundant,
+ -- but the message has to be on the current unit.
+
+ if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then
+ Redundant := Cur_Use;
+ Prev_Use := Clause;
+ else
+ Redundant := Clause;
+ Prev_Use := Cur_Use;
+ end if;
+
+ -- If the new use clause appears in the private part of a parent unit
+ -- it may appear to be redudant w.r.t. a use clause in a child unit,
+ -- but the previous use clause was needed in the visible part of the
+ -- child, and no warning should be emitted.
+
+ if Nkind (Parent (Decl)) = N_Package_Specification
+ and then
+ List_Containing (Decl) = Private_Declarations (Parent (Decl))
+ then
+ declare
+ Par : constant Entity_Id := Defining_Entity (Parent (Decl));
+ Spec : constant Node_Id :=
+ Specification (Unit (Cunit (Current_Sem_Unit)));
+
+ begin
+ if Is_Compilation_Unit (Par)
+ and then Par /= Cunit_Entity (Current_Sem_Unit)
+ and then Parent (Cur_Use) = Spec
+ and then
+ List_Containing (Cur_Use) = Visible_Declarations (Spec)
+ then
+ return;
+ end if;
+ end;
+ end if;
+
+ else
+ null;
+ end if;
+
+ if Present (Redundant) then
+ Error_Msg_Sloc := Sloc (Prev_Use);
+ Error_Msg_NE (
+ "& is already use_visible through declaration #?",
+ Redundant, Pack_Name);
+ end if;
+ end Note_Redundant_Use;
+
+ ---------------
+ -- Pop_Scope --
+ ---------------
+
+ procedure Pop_Scope is
+ SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+
+ begin
+ if Debug_Flag_E then
+ Write_Info;
+ end if;
+
+ Scope_Suppress := SST.Save_Scope_Suppress;
+ Local_Entity_Suppress.Set_Last (SST.Save_Local_Entity_Suppress);
+
+ if Debug_Flag_W then
+ Write_Str ("--> exiting scope: ");
+ Write_Name (Chars (Current_Scope));
+ Write_Str (", Depth=");
+ Write_Int (Int (Scope_Stack.Last));
+ Write_Eol;
+ end if;
+
+ End_Use_Clauses (SST.First_Use_Clause);
+
+ -- If the actions to be wrapped are still there they will get lost
+ -- causing incomplete code to be generated. It is better to abort in
+ -- this case (and we do the abort even with assertions off since the
+ -- penalty is incorrect code generation)
+
+ if SST.Actions_To_Be_Wrapped_Before /= No_List
+ or else
+ SST.Actions_To_Be_Wrapped_After /= No_List
+ then
+ return;
+ end if;
+
+ -- Free last subprogram name if allocated, and pop scope
+
+ Free (SST.Last_Subprogram_Name);
+ Scope_Stack.Decrement_Last;
+ end Pop_Scope;
+
---------------
- -- New_Scope --
+ -- Push_Scope --
---------------
- procedure New_Scope (S : Entity_Id) is
+ procedure Push_Scope (S : Entity_Id) is
E : Entity_Id;
begin
SST.Actions_To_Be_Wrapped_After := No_List;
SST.First_Use_Clause := Empty;
SST.Is_Active_Stack_Base := False;
+ SST.Previous_Visibility := False;
end;
if Debug_Flag_W then
Write_Eol;
end if;
- -- Copy from Scope (S) the categorization flags to S, this is not
- -- done in case Scope (S) is Standard_Standard since propagation
- -- is from library unit entity inwards.
+ -- Deal with copying flags from the previous scope to this one. This
+ -- is not necessary if either scope is standard, or if the new scope
+ -- is a child unit.
if S /= Standard_Standard
and then Scope (S) /= Standard_Standard
return;
end if;
+ -- Copy categorization flags from Scope (S) to S, this is not done
+ -- when Scope (S) is Standard_Standard since propagation is from
+ -- library unit entity inwards. Copy other relevant attributes as
+ -- well (Discard_Names in particular).
+
-- We only propagate inwards for library level entities,
-- inner level subprograms do not inherit the categorization.
if Is_Library_Level_Entity (S) then
- Set_Is_Preelaborated (S, Is_Preelaborated (E));
+ Set_Is_Preelaborated (S, Is_Preelaborated (E));
Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
+ Set_Discard_Names (S, Discard_Names (E));
+ Set_Suppress_Value_Tracking_On_Call
+ (S, Suppress_Value_Tracking_On_Call (E));
Set_Categorization_From_Scope (E => S, Scop => E);
end if;
end if;
- end New_Scope;
-
- ---------------
- -- Pop_Scope --
- ---------------
-
- procedure Pop_Scope is
- SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
-
- begin
- if Debug_Flag_E then
- Write_Info;
- end if;
-
- Scope_Suppress := SST.Save_Scope_Suppress;
- Local_Entity_Suppress.Set_Last (SST.Save_Local_Entity_Suppress);
-
- if Debug_Flag_W then
- Write_Str ("--> exiting scope: ");
- Write_Name (Chars (Current_Scope));
- Write_Str (", Depth=");
- Write_Int (Int (Scope_Stack.Last));
- Write_Eol;
- end if;
-
- End_Use_Clauses (SST.First_Use_Clause);
-
- -- If the actions to be wrapped are still there they will get lost
- -- causing incomplete code to be generated. It is better to abort in
- -- this case (and we do the abort even with assertions off since the
- -- penalty is incorrect code generation)
-
- if SST.Actions_To_Be_Wrapped_Before /= No_List
- or else
- SST.Actions_To_Be_Wrapped_After /= No_List
- then
- return;
- end if;
-
- -- Free last subprogram name if allocated, and pop scope
-
- Free (SST.Last_Subprogram_Name);
- Scope_Stack.Decrement_Last;
- end Pop_Scope;
+ end Push_Scope;
---------------------
-- Premature_Usage --
begin
-- Within an instance, the analysis of the actual for a formal object
- -- does not see the name of the object itself. This is significant
- -- only if the object is an aggregate, where its analysis does not do
- -- any name resolution on component associations. (see 4717-008). In
- -- such a case, look for the visible homonym on the chain.
+ -- does not see the name of the object itself. This is significant only
+ -- if the object is an aggregate, where its analysis does not do any
+ -- name resolution on component associations. (see 4717-008). In such a
+ -- case, look for the visible homonym on the chain.
if In_Instance
and then Present (Homonym (E))
function Present_System_Aux (N : Node_Id := Empty) return Boolean is
Loc : Source_Ptr;
- Aux_Name : Name_Id;
+ Aux_Name : Unit_Name_Type;
Unum : Unit_Number_Type;
Withn : Node_Id;
With_Sys : Node_Id;
The_Unit : Node_Id;
function Find_System (C_Unit : Node_Id) return Entity_Id;
- -- Scan context clause of compilation unit to find a with_clause
+ -- Scan context clause of compilation unit to find with_clause
-- for System.
-----------------
begin
With_Clause := First (Context_Items (C_Unit));
-
while Present (With_Clause) loop
if (Nkind (With_Clause) = N_With_Clause
and then Chars (Name (With_Clause)) = Name_System)
System_Aux_Id :=
Defining_Entity (Specification (Unit (Cunit (Unum))));
- Withn := Make_With_Clause (Loc,
- Name =>
- Make_Expanded_Name (Loc,
- Chars => Chars (System_Aux_Id),
- Prefix =>
- New_Reference_To (Scope (System_Aux_Id), Loc),
- Selector_Name =>
- New_Reference_To (System_Aux_Id, Loc)));
+ Withn :=
+ Make_With_Clause (Loc,
+ Name =>
+ Make_Expanded_Name (Loc,
+ Chars => Chars (System_Aux_Id),
+ Prefix => New_Reference_To (Scope (System_Aux_Id), Loc),
+ Selector_Name => New_Reference_To (System_Aux_Id, Loc)));
Set_Entity (Name (Withn), System_Aux_Id);
- Set_Library_Unit (Withn, Cunit (Unum));
- Set_Corresponding_Spec (Withn, System_Aux_Id);
- Set_First_Name (Withn, True);
- Set_Implicit_With (Withn, True);
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec (Withn, System_Aux_Id);
+ Set_First_Name (Withn, True);
+ Set_Implicit_With (Withn, True);
Insert_After (With_Sys, Withn);
Mark_Rewrite_Insertion (Withn);
end if;
E := First_Entity (S);
-
while Present (E) loop
if Is_Child_Unit (E) then
Set_Is_Immediately_Visible (E,
-- must be restored in any case. Their declarations may appear
-- after the private part of the parent.
- if not Full_Vis
- and then Present (E)
- then
+ if not Full_Vis then
while Present (E) loop
if Is_Child_Unit (E) then
Set_Is_Immediately_Visible (E,
end if;
if Is_Child_Unit (S)
- and not In_Child -- check only for current unit.
+ and not In_Child -- check only for current unit
then
In_Child := True;
- -- restore visibility of parents according to whether the child
+ -- Restore visibility of parents according to whether the child
-- is private and whether we are in its visible part.
Comp_Unit := Parent (Unit_Declaration_Node (S));
End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
end if;
- -- If the call is from within a compilation unit, as when
- -- called from Rtsfind, make current entries in scope stack
- -- invisible while we analyze the new unit.
+ -- If the call is from within a compilation unit, as when called from
+ -- Rtsfind, make current entries in scope stack invisible while we
+ -- analyze the new unit.
for J in reverse 0 .. SS_Last loop
exit when Scope_Stack.Table (J).Entity = Standard_Standard
S := Scope_Stack.Table (J).Entity;
Set_Is_Immediately_Visible (S, False);
- E := First_Entity (S);
+ E := First_Entity (S);
while Present (E) loop
Set_Is_Immediately_Visible (E, False);
Next_Entity (E);
begin
if Present (L) then
Decl := First (L);
-
while Present (Decl) loop
if Nkind (Decl) = N_Use_Package_Clause then
Chain_Use_Clause (Decl);
- Pack_Name := First (Names (Decl));
+ Pack_Name := First (Names (Decl));
while Present (Pack_Name) loop
Pack := Entity (Pack_Name);
elsif Nkind (Decl) = N_Use_Type_Clause then
Chain_Use_Clause (Decl);
- Id := First (Subtype_Marks (Decl));
+ Id := First (Subtype_Marks (Decl));
while Present (Id) loop
if Entity (Id) /= Any_Type then
Use_One_Type (Id);
end if;
Set_In_Use (P);
+ Set_Current_Use_Clause (P, N);
-- Ada 2005 (AI-50217): Check restriction
if In_Instance then
Current_Instance := Current_Scope;
-
while not Is_Generic_Instance (Current_Instance) loop
Current_Instance := Scope (Current_Instance);
end loop;
if Present (Renamed_Object (P)) then
Set_In_Use (Renamed_Object (P));
+ Set_Current_Use_Clause (Renamed_Object (P), N);
Real_P := Renamed_Object (P);
else
Real_P := P;
or else Private_With_OK) -- Ada 2005 (AI-262)
loop
Prev := Current_Entity (Id);
-
while Present (Prev) loop
if Is_Immediately_Visible (Prev)
and then (not Is_Overloadable (Prev)
goto Next_Usable_Entity;
- -- A use clause within an instance hides outer global
- -- entities, which are not used to resolve local entities
- -- in the instance. Note that the predefined entities in
- -- Standard could not have been hidden in the generic by
- -- a use clause, and therefore remain visible. Other
- -- compilation units whose entities appear in Standard must
- -- be hidden in an instance.
+ -- A use clause within an instance hides outer global entities,
+ -- which are not used to resolve local entities in the
+ -- instance. Note that the predefined entities in Standard
+ -- could not have been hidden in the generic by a use clause,
+ -- and therefore remain visible. Other compilation units whose
+ -- entities appear in Standard must be hidden in an instance.
-- To determine whether an entity is external to the instance
-- we compare the scope depth of its scope with that of the
Append_Elmt (Prev, Hidden_By_Use_Clause (N));
end if;
- -- A user-defined operator is not use-visible if the
- -- predefined operator for the type is immediately visible,
- -- which is the case if the type of the operand is in an open
- -- scope. This does not apply to user-defined operators that
- -- have operands of different types, because the predefined
- -- mixed mode operations (multiplication and division) apply to
- -- universal types and do not hide anything.
+ -- A user-defined operator is not use-visible if the predefined
+ -- operator for the type is immediately visible, which is the case
+ -- if the type of the operand is in an open scope. This does not
+ -- apply to user-defined operators that have operands of different
+ -- types, because the predefined mixed mode operations (multiply
+ -- and divide) apply to universal types and do not hide anything.
elsif Ekind (Prev) = E_Operator
and then Operator_Matches_Spec (Prev, Id)
Next_Entity (Id);
end loop;
- -- Child units are also made use-visible by a use clause, but they
- -- may appear after all visible declarations in the parent entity list.
+ -- Child units are also made use-visible by a use clause, but they may
+ -- appear after all visible declarations in the parent entity list.
while Present (Id) loop
-
if Is_Child_Unit (Id)
and then Is_Visible_Child_Unit (Id)
then
if In_Open_Scopes (Scope (T)) then
null;
+ elsif From_With_Type (T) then
+ Error_Msg_N
+ ("incomplete type from limited view "
+ & "cannot appear in use clause", Id);
+
-- If the subtype mark designates a subtype in a different package,
-- we have to check that the parent type is visible, otherwise the
-- use type clause is a noop. Not clear how to do that???
elsif not Redundant_Use (Id) then
Set_In_Use (T);
Op_List := Collect_Primitive_Operations (T);
- Elmt := First_Elmt (Op_List);
+ Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
-
if (Nkind (Node (Elmt)) = N_Defining_Operator_Symbol
or else Chars (Node (Elmt)) in Any_Operator_Name)
and then not Is_Hidden (Node (Elmt))
procedure Write_Scopes is
S : Entity_Id;
-
begin
for J in reverse 1 .. Scope_Stack.Last loop
S := Scope_Stack.Table (J).Entity;
OSDN Git Service
