-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Snames; use Snames;
with Style; use Style;
with Table;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- Visibility and Name Resolution --
------------------------------------
- -- This package handles name resolution and the collection of
+ -- This package handles name resolution and the collection of possible
-- interpretations for overloaded names, prior to overload resolution.
-- Name resolution is the process that establishes a mapping between source
-- private with on E.
procedure Find_Expanded_Name (N : Node_Id);
- -- Selected component is known to be expanded name. Verify legality of
- -- selector given the scope denoted by prefix.
+ -- The input is a selected component known to be an expanded name. Verify
+ -- legality of selector given the scope denoted by prefix, and change node
+ -- N into a expanded name with a properly set Entity field.
function Find_Renamed_Entity
(N : Node_Id;
-- re-installing use clauses of parent units. N is the use_clause that
-- names P (and possibly other packages).
- procedure Use_One_Type (Id : Node_Id);
+ procedure Use_One_Type (Id : Node_Id; Installed : Boolean := False);
-- Id is the subtype mark from a use type clause. This procedure makes
- -- the primitive operators of the type potentially use-visible.
+ -- the primitive operators of the type potentially use-visible. The
+ -- boolean flag Installed indicates that the clause is being reinstalled
+ -- after previous analysis, and primitive operations are already chained
+ -- on the Used_Operations list of the clause.
procedure Write_Info;
-- Write debugging information on entities declared in current scope
- procedure Write_Scopes;
- pragma Warnings (Off, Write_Scopes);
- -- Debugging information: dump all entities on scope stack
-
--------------------------------
-- Analyze_Exception_Renaming --
--------------------------------
Nam : constant Node_Id := Name (N);
begin
+ Check_SPARK_Restriction ("exception renaming is not allowed", N);
+
Enter_Name (Id);
Analyze (Nam);
return;
end if;
+ Check_SPARK_Restriction ("generic renaming is not allowed", N);
+
Generate_Definition (New_P);
if Current_Scope /= Standard_Standard then
-----------------------------
procedure Analyze_Object_Renaming (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
Dec : Node_Id;
- Nam : constant Node_Id := Name (N);
+ Nam : constant Node_Id := Name (N);
T : Entity_Id;
T2 : Entity_Id;
+ procedure Check_Constrained_Object;
+ -- If the nominal type is unconstrained but the renamed object is
+ -- constrained, as can happen with renaming an explicit dereference or
+ -- a function return, build a constrained subtype from the object. If
+ -- the renaming is for a formal in an accept statement, the analysis
+ -- has already established its actual subtype. This is only relevant
+ -- if the renamed object is an explicit dereference.
+
function In_Generic_Scope (E : Entity_Id) return Boolean;
-- Determine whether entity E is inside a generic cope
+ ------------------------------
+ -- Check_Constrained_Object --
+ ------------------------------
+
+ procedure Check_Constrained_Object is
+ Subt : Entity_Id;
+
+ begin
+ if Nkind_In (Nam, N_Function_Call, N_Explicit_Dereference)
+ and then Is_Composite_Type (Etype (Nam))
+ and then not Is_Constrained (Etype (Nam))
+ and then not Has_Unknown_Discriminants (Etype (Nam))
+ and then Expander_Active
+ then
+ -- If Actual_Subtype is already set, nothing to do
+
+ if Ekind_In (Id, E_Variable, E_Constant)
+ and then Present (Actual_Subtype (Id))
+ then
+ null;
+
+ -- A renaming of an unchecked union does not have an
+ -- actual subtype.
+
+ elsif Is_Unchecked_Union (Etype (Nam)) then
+ null;
+
+ else
+ Subt := Make_Temporary (Loc, 'T');
+ Remove_Side_Effects (Nam);
+ Insert_Action (N,
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_From_Expr (Nam, Etype (Nam))));
+ Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc));
+ Set_Etype (Nam, Subt);
+ end if;
+ end if;
+ end Check_Constrained_Object;
+
----------------------
-- In_Generic_Scope --
----------------------
return;
end if;
+ Check_SPARK_Restriction ("object renaming is not allowed", N);
+
Set_Is_Pure (Id, Is_Pure (Current_Scope));
Enter_Name (Id);
T := Entity (Subtype_Mark (N));
Analyze (Nam);
+ -- Reject renamings of conversions unless the type is tagged, or
+ -- the conversion is implicit (which can occur for cases of anonymous
+ -- access types in Ada 2012).
+
if Nkind (Nam) = N_Type_Conversion
- and then not Is_Tagged_Type (T)
+ and then Comes_From_Source (Nam)
+ and then not Is_Tagged_Type (T)
then
Error_Msg_N
("renaming of conversion only allowed for tagged types", Nam);
Resolve (Nam, T);
+ -- If the renamed object is a function call of a limited type,
+ -- the expansion of the renaming is complicated by the presence
+ -- of various temporaries and subtypes that capture constraints
+ -- of the renamed object. Rewrite node as an object declaration,
+ -- whose expansion is simpler. Given that the object is limited
+ -- there is no copy involved and no performance hit.
+
+ if Nkind (Nam) = N_Function_Call
+ and then Is_Immutably_Limited_Type (Etype (Nam))
+ and then not Is_Constrained (Etype (Nam))
+ and then Comes_From_Source (N)
+ then
+ Set_Etype (Id, T);
+ Set_Ekind (Id, E_Constant);
+ Rewrite (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Etype (Nam), Loc),
+ Expression => Relocate_Node (Nam)));
+ return;
+ end if;
+
+ -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object
+ -- when renaming declaration has a named access type. The Ada 2012
+ -- coverage rules allow an anonymous access type in the context of
+ -- an expected named general access type, but the renaming rules
+ -- require the types to be the same. (An exception is when the type
+ -- of the renaming is also an anonymous access type, which can only
+ -- happen due to a renaming created by the expander.)
+
+ if Nkind (Nam) = N_Type_Conversion
+ and then not Comes_From_Source (Nam)
+ and then Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type
+ and then Ekind (T) /= E_Anonymous_Access_Type
+ then
+ Wrong_Type (Expression (Nam), T); -- Should we give better error???
+ end if;
+
-- Check that a class-wide object is not being renamed as an object
-- of a specific type. The test for access types is needed to exclude
-- cases where the renamed object is a dynamically tagged access
-- Ada 2005 AI05-105: if the declaration has an anonymous access
-- type, the renamed object must also have an anonymous type, and
- -- this is a name resolution rule. This was implicit in the last
- -- part of the first sentence in 8.5.1.(3/2), and is made explicit
- -- by this recent AI.
+ -- this is a name resolution rule. This was implicit in the last part
+ -- of the first sentence in 8.5.1(3/2), and is made explicit by this
+ -- recent AI.
if not Is_Overloaded (Nam) then
if Ekind (Etype (Nam)) /= Ekind (T) then
(Designated_Type (T), Designated_Type (Etype (Nam)));
elsif not Subtypes_Statically_Match
- (Designated_Type (T), Designated_Type (Etype (Nam)))
+ (Designated_Type (T),
+ Available_View (Designated_Type (Etype (Nam))))
then
Error_Msg_N
("subtype of renamed object does not statically match", N);
Nam);
end if;
- -- If the function call returns an unconstrained type, we must
- -- build a constrained subtype for the new entity, in a way
- -- similar to what is done for an object declaration with an
- -- unconstrained nominal type.
-
- if Is_Composite_Type (Etype (Nam))
- and then not Is_Constrained (Etype (Nam))
- and then not Has_Unknown_Discriminants (Etype (Nam))
- and then Expander_Active
- then
- declare
- Loc : constant Source_Ptr := Sloc (N);
- Subt : constant Entity_Id := Make_Temporary (Loc, 'T');
- begin
- Remove_Side_Effects (Nam);
- Insert_Action (N,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Subt,
- Subtype_Indication =>
- Make_Subtype_From_Expr (Nam, Etype (Nam))));
- Rewrite (Subtype_Mark (N), New_Occurrence_Of (Subt, Loc));
- Set_Etype (Nam, Subt);
- end;
- end if;
end case;
end if;
+ Check_Constrained_Object;
+
-- An object renaming requires an exact match of the type. Class-wide
-- matching is not allowed.
T2 := Etype (Nam);
- -- (Ada 2005: AI-326): Handle wrong use of incomplete type
+ -- Ada 2005 (AI-326): Handle wrong use of incomplete type
if Nkind (Nam) = N_Explicit_Dereference
and then Ekind (Etype (T2)) = E_Incomplete_Type
-- Ada 2005 (AI-327)
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Nkind (Nam) = N_Attribute_Reference
and then Attribute_Name (Nam) = Name_Priority
then
null;
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Nkind (Nam) in N_Has_Entity
then
declare
end if;
Set_Ekind (Id, E_Variable);
- Init_Size_Align (Id);
+
+ -- Initialize the object size and alignment. Note that we used to call
+ -- Init_Size_Align here, but that's wrong for objects which have only
+ -- an Esize, not an RM_Size field!
+
+ Init_Object_Size_Align (Id);
if T = Any_Type or else Etype (Nam) = Any_Type then
return;
-- Ada 2005 (AI-327)
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Nkind (Nam) = N_Attribute_Reference
and then Attribute_Name (Nam) = Name_Priority
then
end if;
Set_Renamed_Object (Id, Nam);
+ Analyze_Dimension (N);
end Analyze_Object_Renaming;
------------------------------
---------------------------------
procedure Analyze_Subprogram_Renaming (N : Node_Id) is
- Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N);
- Is_Actual : constant Boolean := Present (Formal_Spec);
+ 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;
-- before the subprogram it completes is frozen, and renaming indirectly
-- renames the subprogram itself.(Defect Report 8652/0027).
+ function Check_Class_Wide_Actual return Entity_Id;
+ -- AI05-0071: In an instance, if the actual for a formal type FT with
+ -- unknown discriminants is a class-wide type CT, and the generic has
+ -- a formal subprogram with a box for a primitive operation of FT,
+ -- then the corresponding actual subprogram denoted by the default is a
+ -- class-wide operation whose body is a dispatching call. We replace the
+ -- generated renaming declaration:
+ --
+ -- procedure P (X : CT) renames P;
+ --
+ -- by a different renaming and a class-wide operation:
+ --
+ -- procedure Pr (X : T) renames P; -- renames primitive operation
+ -- procedure P (X : CT); -- class-wide operation
+ -- ...
+ -- procedure P (X : CT) is begin Pr (X); end; -- dispatching call
+ --
+ -- This rule only applies if there is no explicit visible class-wide
+ -- operation at the point of the instantiation.
+
+ function Has_Class_Wide_Actual return Boolean;
+ -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a
+ -- defaulted formal subprogram when the actual for the controlling
+ -- formal type is class-wide.
+
+ -----------------------------
+ -- Check_Class_Wide_Actual --
+ -----------------------------
+
+ function Check_Class_Wide_Actual return Entity_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ F : Entity_Id;
+ Formal_Type : Entity_Id;
+ Actual_Type : Entity_Id;
+ New_Body : Node_Id;
+ New_Decl : Node_Id;
+ Result : Entity_Id;
+
+ function Make_Call (Prim_Op : Entity_Id) return Node_Id;
+ -- Build dispatching call for body of class-wide operation
+
+ function Make_Spec return Node_Id;
+ -- Create subprogram specification for declaration and body of
+ -- class-wide operation, using signature of renaming declaration.
+
+ ---------------
+ -- Make_Call --
+ ---------------
+
+ function Make_Call (Prim_Op : Entity_Id) return Node_Id is
+ Actuals : List_Id;
+ F : Node_Id;
+
+ begin
+ Actuals := New_List;
+ F := First (Parameter_Specifications (Specification (New_Decl)));
+ while Present (F) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (F))));
+ Next (F);
+ end loop;
+
+ if Ekind_In (Prim_Op, E_Function, E_Operator) then
+ return Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Prim_Op, Loc),
+ Parameter_Associations => Actuals));
+ else
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Prim_Op, Loc),
+ Parameter_Associations => Actuals);
+ end if;
+ end Make_Call;
+
+ ---------------
+ -- Make_Spec --
+ ---------------
+
+ function Make_Spec return Node_Id is
+ Param_Specs : constant List_Id := Copy_Parameter_List (New_S);
+
+ begin
+ if Ekind (New_S) = E_Procedure then
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Unit_Name (Spec))),
+ Parameter_Specifications => Param_Specs);
+ else
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Unit_Name (Spec))),
+ Parameter_Specifications => Param_Specs,
+ Result_Definition =>
+ New_Copy_Tree (Result_Definition (Spec)));
+ end if;
+ end Make_Spec;
+
+ -- Start of processing for Check_Class_Wide_Actual
+
+ begin
+ Result := Any_Id;
+ Formal_Type := Empty;
+ Actual_Type := Empty;
+
+ F := First_Formal (Formal_Spec);
+ while Present (F) loop
+ if Has_Unknown_Discriminants (Etype (F))
+ and then not Is_Class_Wide_Type (Etype (F))
+ and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F)))
+ then
+ Formal_Type := Etype (F);
+ Actual_Type := Etype (Get_Instance_Of (Formal_Type));
+ exit;
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ if Present (Formal_Type) then
+
+ -- Create declaration and body for class-wide operation
+
+ New_Decl :=
+ Make_Subprogram_Declaration (Loc, Specification => Make_Spec);
+
+ New_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => Make_Spec,
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, New_List));
+
+ -- Modify Spec and create internal name for renaming of primitive
+ -- operation.
+
+ Set_Defining_Unit_Name (Spec, Make_Temporary (Loc, 'R'));
+ F := First (Parameter_Specifications (Spec));
+ while Present (F) loop
+ if Nkind (Parameter_Type (F)) = N_Identifier
+ and then Is_Class_Wide_Type (Entity (Parameter_Type (F)))
+ then
+ Set_Parameter_Type (F, New_Occurrence_Of (Actual_Type, Loc));
+ end if;
+ Next (F);
+ end loop;
+
+ New_S := Analyze_Subprogram_Specification (Spec);
+ Result := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+ end if;
+
+ if Result /= Any_Id then
+ Insert_Before (N, New_Decl);
+ Analyze (New_Decl);
+
+ -- Add dispatching call to body of class-wide operation
+
+ Append (Make_Call (Result),
+ Statements (Handled_Statement_Sequence (New_Body)));
+
+ -- The generated body does not freeze. It is analyzed when the
+ -- generated operation is frozen. This body is only needed if
+ -- expansion is enabled.
+
+ if Expander_Active then
+ Append_Freeze_Action (Defining_Entity (New_Decl), New_Body);
+ end if;
+
+ Result := Defining_Entity (New_Decl);
+ end if;
+
+ -- Return the class-wide operation if one was created
+
+ return Result;
+ end Check_Class_Wide_Actual;
+
--------------------------
-- Check_Null_Exclusion --
--------------------------
end if;
end Check_Null_Exclusion;
+ ---------------------------
+ -- Has_Class_Wide_Actual --
+ ---------------------------
+
+ function Has_Class_Wide_Actual return Boolean is
+ F_Nam : Entity_Id;
+ F_Spec : Entity_Id;
+
+ begin
+ if Is_Actual
+ and then Nkind (Nam) in N_Has_Entity
+ and then Present (Entity (Nam))
+ and then Is_Dispatching_Operation (Entity (Nam))
+ then
+ F_Nam := First_Entity (Entity (Nam));
+ F_Spec := First_Formal (Formal_Spec);
+ while Present (F_Nam)
+ and then Present (F_Spec)
+ loop
+ if Is_Controlling_Formal (F_Nam)
+ and then Has_Unknown_Discriminants (Etype (F_Spec))
+ and then not Is_Class_Wide_Type (Etype (F_Spec))
+ and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F_Spec)))
+ then
+ return True;
+ end if;
+
+ Next_Entity (F_Nam);
+ Next_Formal (F_Spec);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Class_Wide_Actual;
+
-------------------------
-- Original_Subprogram --
-------------------------
end if;
end Original_Subprogram;
+ CW_Actual : constant Boolean := Has_Class_Wide_Actual;
+ -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a
+ -- defaulted formal subprogram when the actual for a related formal
+ -- type is class-wide.
+
-- Start of processing for Analyze_Subprogram_Renaming
begin
-- expanded in subsequent instantiations.
if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec)
- and then Expander_Active
+ and then Full_Expander_Active
then
declare
Stream_Prim : Entity_Id;
if Is_Actual then
Inst_Node := Unit_Declaration_Node (Formal_Spec);
- if Is_Entity_Name (Nam)
+ -- Check whether the renaming is for a defaulted actual subprogram
+ -- with a class-wide actual.
+
+ if CW_Actual then
+ New_S := Analyze_Subprogram_Specification (Spec);
+ Old_S := Check_Class_Wide_Actual;
+
+ elsif Is_Entity_Name (Nam)
and then Present (Entity (Nam))
and then not Comes_From_Source (Nam)
and then not Is_Overloaded (Nam)
-- Ada 2005: check overriding indicator
- if Is_Overriding_Operation (Rename_Spec) then
+ if Present (Overridden_Operation (Rename_Spec)) then
if Must_Not_Override (Specification (N)) then
Error_Msg_NE
("subprogram& overrides inherited operation",
Analyze_Renamed_Character (N, New_S, Present (Rename_Spec));
return;
- elsif (not Is_Entity_Name (Nam)
- and then Nkind (Nam) /= N_Operator_Symbol)
+ elsif not Is_Entity_Name (Nam)
or else not Is_Overloadable (Entity (Nam))
then
- Error_Msg_N ("expect valid subprogram name in renaming", N);
+ -- Do not mention the renaming if it comes from an instance
+
+ if not Is_Actual then
+ Error_Msg_N ("expect valid subprogram name in renaming", N);
+ else
+ Error_Msg_NE ("no visible subprogram for formal&", N, Nam);
+ end if;
+
return;
end if;
if No (Old_S) then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+ -- The visible operation may be an inherited abstract operation that
+ -- was overridden in the private part, in which case a call will
+ -- dispatch to the overriding operation. Use the overriding one in
+ -- the renaming declaration, to prevent spurious errors below.
+
+ if Is_Overloadable (Old_S)
+ and then Is_Abstract_Subprogram (Old_S)
+ and then No (DTC_Entity (Old_S))
+ and then Present (Alias (Old_S))
+ and then not Is_Abstract_Subprogram (Alias (Old_S))
+ and then Present (Overridden_Operation (Alias (Old_S)))
+ then
+ Old_S := Alias (Old_S);
+ end if;
+
-- When the renamed subprogram is overloaded and used as an actual
-- of a generic, its entity is set to the first available homonym.
-- We must first disambiguate the name, then set the proper entity.
- if Is_Actual
- and then Is_Overloaded (Nam)
- then
+ if Is_Actual and then Is_Overloaded (Nam) then
Set_Entity (Nam, Old_S);
end if;
end if;
-- when performing a null exclusion check between a renaming and a
-- renamed subprogram that has been found to be illegal.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Entity (Nam) /= Any_Id
then
Check_Null_Exclusion
end if;
if Old_S /= Any_Id then
- if Is_Actual
- and then From_Default (N)
- then
+ if Is_Actual and then From_Default (N) then
+
-- This is an implicit reference to the default actual
Generate_Reference (Old_S, Nam, Typ => 'i', Force => True);
+
else
Generate_Reference (Old_S, Nam);
end if;
end if;
elsif Ekind (Old_S) /= E_Operator then
- Check_Mode_Conformant (New_S, Old_S);
+
+ -- If this a defaulted subprogram for a class-wide actual there is
+ -- no check for mode conformance, given that the signatures don't
+ -- match (the source mentions T but the actual mentions T'Class).
+
+ if CW_Actual then
+ null;
+ else
+ Check_Mode_Conformant (New_S, Old_S);
+ end if;
if Is_Actual
and then Error_Posted (New_S)
if not Is_Actual
and then (Old_S = New_S
- or else (Nkind (Nam) /= N_Expanded_Name
- and then Chars (Old_S) = Chars (New_S)))
+ or else
+ (Nkind (Nam) /= N_Expanded_Name
+ and then Chars (Old_S) = Chars (New_S))
+ or else
+ (Nkind (Nam) = N_Expanded_Name
+ and then Entity (Prefix (Nam)) = Current_Scope
+ and then
+ Chars (Selector_Name (Nam)) = Chars (New_S)))
then
Error_Msg_N ("subprogram cannot rename itself", N);
end if;
-- is dispatching. Test is skipped if some previous error was detected
-- that set Old_S to Any_Id.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Old_S /= Any_Id
and then not Is_Dispatching_Operation (Old_S)
and then Is_Dispatching_Operation (New_S)
end if;
-- A useful warning, suggested by Ada Bug Finder (Ada-Europe 2005)
+ -- is to warn if an operator is being renamed as a different operator.
+ -- If the operator is predefined, examine the kind of the entity, not
+ -- the abbreviated declaration in Standard.
if Comes_From_Source (N)
and then Present (Old_S)
- and then Nkind (Old_S) = N_Defining_Operator_Symbol
+ and then
+ (Nkind (Old_S) = N_Defining_Operator_Symbol
+ or else Ekind (Old_S) = E_Operator)
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);
+ ("?& is being renamed as a different operator", N, Old_S);
end if;
+ -- Check for renaming of obsolescent subprogram
+
+ Check_Obsolescent_2005_Entity (Entity (Nam), Nam);
+
-- Another warning or some utility: if the new subprogram as the same
-- name as the old one, the old one is not hidden by an outer homograph,
-- the new one is not a public symbol, and the old one is otherwise
("?redundant renaming, entity is directly visible", Name (N));
end if;
+ -- Implementation-defined aspect specifications can appear in a renaming
+ -- declaration, but not language-defined ones. The call to procedure
+ -- Analyze_Aspect_Specifications will take care of this error check.
+
+ if Has_Aspects (N) then
+ Analyze_Aspect_Specifications (N, New_S);
+ end if;
+
Ada_Version := Save_AV;
Ada_Version_Explicit := Save_AV_Exp;
end Analyze_Subprogram_Renaming;
-- Start of processing for Analyze_Use_Package
begin
+ Check_SPARK_Restriction ("use clause is not allowed", N);
+
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).
+ -- Use clause 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, which are never loaded by Rtsfind).
if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
and then Name_Buffer (1 .. 3) /= "a-n"
Chain_Use_Clause (N);
end if;
+ -- If the Used_Operations list is already initialized, the clause has
+ -- been analyzed previously, and it is begin reinstalled, for example
+ -- when the clause appears in a package spec and we are compiling the
+ -- corresponding package body. In that case, make the entities on the
+ -- existing list use_visible, and mark the corresponding types In_Use.
+
+ if Present (Used_Operations (N)) then
+ declare
+ Mark : Node_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ Mark := First (Subtype_Marks (N));
+ while Present (Mark) loop
+ Use_One_Type (Mark, Installed => True);
+ Next (Mark);
+ end loop;
+
+ Elmt := First_Elmt (Used_Operations (N));
+ while Present (Elmt) loop
+ Set_Is_Potentially_Use_Visible (Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+
+ return;
+ end if;
+
+ -- Otherwise, create new list and attach to it the operations that
+ -- are made use-visible by the clause.
+
+ Set_Used_Operations (N, New_Elmt_List);
Id := First (Subtype_Marks (N));
while Present (Id) loop
Find_Type (Id);
-- 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))
+ -- We must exclude VM targets and restricted run-time libraries because
+ -- entity AST_Handler is defined in package System.Aux_Dec which is not
+ -- available in those platforms. Note that we cannot use the function
+ -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because
+ -- the ZFP run-time library is not defined as a profile, and we do not
+ -- want to deal with AST_Handler in ZFP mode.
+
+ if VM_Target = No_VM
+ and then not Configurable_Run_Time_Mode
+ and then not Present (Corresponding_Formal_Spec (N))
and then Etype (Nam) /= RTE (RE_AST_Handler)
then
declare
-- The replacement of a discriminant by the corresponding discriminal
-- is not done for a task discriminant that appears in a default
- -- expression of an entry parameter. See Expand_Discriminant in exp_ch2
+ -- expression of an entry parameter. See Exp_Ch2.Expand_Discriminant
-- for details on their handling.
elsif Is_Concurrent_Type (Scope (E)) then
Id : Entity_Id;
Elmt : Elmt_Id;
- function Is_Primitive_Operator
+ function Is_Primitive_Operator_In_Use
(Op : Entity_Id;
F : Entity_Id) return Boolean;
-- Check whether Op is a primitive operator of a use-visible type
- ---------------------------
- -- Is_Primitive_Operator --
- ---------------------------
+ ----------------------------------
+ -- Is_Primitive_Operator_In_Use --
+ ----------------------------------
- function Is_Primitive_Operator
+ function Is_Primitive_Operator_In_Use
(Op : Entity_Id;
F : Entity_Id) return Boolean
is
- T : constant Entity_Id := Etype (F);
+ T : constant Entity_Id := Base_Type (Etype (F));
begin
- return In_Use (T)
- and then Scope (T) = Scope (Op);
- end Is_Primitive_Operator;
+ return In_Use (T) and then Scope (T) = Scope (Op);
+ end Is_Primitive_Operator_In_Use;
-- Start of processing for End_Use_Package
if Nkind (Id) = N_Defining_Operator_Symbol
and then
- (Is_Primitive_Operator (Id, First_Formal (Id))
+ (Is_Primitive_Operator_In_Use
+ (Id, First_Formal (Id))
or else
(Present (Next_Formal (First_Formal (Id)))
and then
- Is_Primitive_Operator
+ Is_Primitive_Operator_In_Use
(Id, Next_Formal (First_Formal (Id)))))
then
null;
procedure End_Use_Type (N : Node_Id) is
Elmt : Elmt_Id;
Id : Entity_Id;
- Op_List : Elist_Id;
- Op : Entity_Id;
T : Entity_Id;
- function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean;
- -- An operator may be primitive in several types, if they are declared
- -- in the same scope as the operator. To determine the use-visiblity of
- -- the operator in such cases we must examine all types in the profile.
-
- ------------------------------
- -- May_Be_Used_Primitive_Of --
- ------------------------------
-
- function May_Be_Used_Primitive_Of (T : Entity_Id) return Boolean is
- begin
- return Scope (Op) = Scope (T)
- and then (In_Use (T) or else Is_Potentially_Use_Visible (T));
- end May_Be_Used_Primitive_Of;
-
-- Start of processing for End_Use_Type
begin
Set_In_Use (Base_Type (T), False);
Set_Current_Use_Clause (T, Empty);
Set_Current_Use_Clause (Base_Type (T), Empty);
- Op_List := Collect_Primitive_Operations (T);
-
- Elmt := First_Elmt (Op_List);
- while Present (Elmt) loop
- Op := Node (Elmt);
-
- if Nkind (Op) = N_Defining_Operator_Symbol then
- declare
- T_First : constant Entity_Id :=
- Base_Type (Etype (First_Formal (Op)));
- T_Res : constant Entity_Id := Base_Type (Etype (Op));
- T_Next : Entity_Id;
-
- begin
- if Present (Next_Formal (First_Formal (Op))) then
- T_Next :=
- Base_Type (Etype (Next_Formal (First_Formal (Op))));
- else
- T_Next := T_First;
- end if;
-
- if not May_Be_Used_Primitive_Of (T_First)
- and then not May_Be_Used_Primitive_Of (T_Next)
- and then not May_Be_Used_Primitive_Of (T_Res)
- then
- Set_Is_Potentially_Use_Visible (Op, False);
- end if;
- end;
- end if;
-
- Next_Elmt (Elmt);
- end loop;
end if;
<<Continue>>
- Next (Id);
+ Next (Id);
end loop;
+
+ if Is_Empty_Elmt_List (Used_Operations (N)) then
+ return;
+
+ else
+ Elmt := First_Elmt (Used_Operations (N));
+ while Present (Elmt) loop
+ Set_Is_Potentially_Use_Visible (Node (Elmt), False);
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
end End_Use_Type;
----------------------
<<Found>> begin
+ -- Check violation of No_Wide_Characters restriction
+
+ Check_Wide_Character_Restriction (E, N);
+
-- When distribution features are available (Get_PCS_Name /=
-- Name_No_DSA), a remote access-to-subprogram type is converted
-- into a record type holding whatever information is needed to
-- Normal case, not a label: generate reference
- -- ??? It is too early to generate a reference here even if
- -- the entity is unambiguous, because the tree is not
- -- sufficiently typed at this point for Generate_Reference to
- -- determine whether this reference modifies the denoted object
- -- (because implicit dereferences cannot be identified prior to
- -- full type resolution).
- --
+ -- ??? It is too early to generate a reference here even if the
+ -- entity is unambiguous, because the tree is not sufficiently
+ -- typed at this point for Generate_Reference to determine
+ -- whether this reference modifies the denoted object (because
+ -- implicit dereferences cannot be identified prior to full type
+ -- resolution).
+
-- The Is_Actual_Parameter routine takes care of one of these
-- cases but there are others probably ???
+ -- If the entity is the LHS of an assignment, and is a variable
+ -- (rather than a package prefix), we can mark it as a
+ -- modification right away, to avoid duplicate references.
+
else
if not Is_Actual_Parameter then
- Generate_Reference (E, N);
+ if Is_LHS (N)
+ and then Ekind (E) /= E_Package
+ and then Ekind (E) /= E_Generic_Package
+ then
+ Generate_Reference (E, N, 'm');
+ else
+ Generate_Reference (E, N);
+ end if;
end if;
Check_Nested_Access (E);
end if;
Set_Entity_Or_Discriminal (N, E);
+
+ if Ada_Version >= Ada_2012
+ and then
+ (Nkind (Parent (N)) in N_Subexpr
+ or else Nkind (Parent (N)) = N_Object_Declaration)
+ then
+ Check_Implicit_Dereference (N, Etype (E));
+ end if;
end if;
end;
end Find_Direct_Name;
Next_Entity (Id);
end loop;
- -- If not found, standard error message.
+ -- If not found, standard error message
Error_Msg_NE ("& not declared in&", N, Selector);
Set_Entity (N, Id);
else
Set_Entity_Or_Discriminal (N, Id);
- Generate_Reference (Id, N);
+
+ if Is_LHS (N) then
+ Generate_Reference (Id, N, 'm');
+ else
+ Generate_Reference (Id, N);
+ end if;
end if;
if Is_Type (Id) then
Set_Etype (N, Get_Full_View (Etype (Id)));
end if;
+ -- Check for violation of No_Wide_Characters
+
+ Check_Wide_Character_Restriction (Id, N);
+
-- If the Ekind of the entity is Void, it means that all homonyms are
-- hidden from all visibility (RM 8.3(5,14-20)).
return Old_S;
end Report_Overload;
- -- Start of processing for Find_Renamed_Entry
+ -- Start of processing for Find_Renamed_Entity
begin
Old_S := Any_Id;
if Present (Inst) then
if Within (It.Nam, Inst) then
- return (It.Nam);
+ if Within (Old_S, Inst) then
+
+ -- Choose the innermost subprogram, which would
+ -- have hidden the outer one in the generic.
+
+ if Scope_Depth (It.Nam) <
+ Scope_Depth (Old_S)
+ then
+ return Old_S;
+ else
+ return It.Nam;
+ end if;
+ end if;
+
elsif Within (Old_S, Inst) then
return (Old_S);
+
else
return Report_Overload;
end if;
+ -- If not within an instance, ambiguity is real
+
else
return Report_Overload;
end if;
end loop;
Set_Entity (Nam, Old_S);
- Set_Is_Overloaded (Nam, False);
+
+ if Old_S /= Any_Id then
+ Set_Is_Overloaded (Nam, False);
+ end if;
end if;
return Old_S;
if Nkind (P) = N_Error then
return;
+ end if;
+
+ -- Selector name cannot be a character literal or an operator symbol in
+ -- SPARK, except for the operator symbol in a renaming.
+
+ if Restriction_Check_Required (SPARK) then
+ if Nkind (Selector_Name (N)) = N_Character_Literal then
+ Check_SPARK_Restriction
+ ("character literal cannot be prefixed", N);
+ elsif Nkind (Selector_Name (N)) = N_Operator_Symbol
+ and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
+ then
+ Check_SPARK_Restriction ("operator symbol cannot be prefixed", N);
+ end if;
+ end if;
-- 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
+ if Present (Entity (Selector_Name (N))) then
if No (Etype (N))
or else Etype (N) = Any_Type
then
and then (not Is_Entity_Name (P)
or else Chars (Entity (P)) /= Name_uInit)
then
- C_Etype :=
- Build_Actual_Subtype_Of_Component (
- Etype (Selector), N);
+ -- Do not build the subtype when referencing components of
+ -- dispatch table wrappers. Required to avoid generating
+ -- elaboration code with HI runtimes. JVM and .NET use a
+ -- modified version of Ada.Tags which does not contain RE_
+ -- Dispatch_Table_Wrapper and RE_No_Dispatch_Table_Wrapper.
+ -- Avoid raising RE_Not_Available exception in those cases.
+
+ if VM_Target = No_VM
+ and then RTU_Loaded (Ada_Tags)
+ and then
+ ((RTE_Available (RE_Dispatch_Table_Wrapper)
+ and then Scope (Selector) =
+ RTE (RE_Dispatch_Table_Wrapper))
+ or else
+ (RTE_Available (RE_No_Dispatch_Table_Wrapper)
+ and then Scope (Selector) =
+ RTE (RE_No_Dispatch_Table_Wrapper)))
+ then
+ C_Etype := Empty;
+
+ else
+ C_Etype :=
+ Build_Actual_Subtype_Of_Component
+ (Etype (Selector), N);
+ end if;
+
else
C_Etype := Empty;
end if;
Analyze_Selected_Component (N);
+ -- Reference to type name in predicate/invariant expression
+
elsif Is_Appropriate_For_Entry_Prefix (P_Type)
and then not In_Open_Scopes (P_Name)
and then (not Is_Concurrent_Type (Etype (P_Name))
Analyze_Selected_Component (N);
elsif (In_Open_Scopes (P_Name)
- and then Ekind (P_Name) /= E_Void
- and then not Is_Overloadable (P_Name))
+ and then Ekind (P_Name) /= E_Void
+ and then not Is_Overloadable (P_Name))
or else (Is_Concurrent_Type (Etype (P_Name))
- and then In_Open_Scopes (Etype (P_Name)))
+ and then In_Open_Scopes (Etype (P_Name)))
then
-- Prefix denotes an enclosing loop, block, or task, i.e. an
-- enclosing construct that is not a subprogram or accept.
-- The subprogram may be a renaming (of an enclosing scope) as
-- in the case of the name of the generic within an instantiation.
- if (Ekind (P_Name) = E_Procedure
- or else Ekind (P_Name) = E_Function)
+ if Ekind_In (P_Name, E_Procedure, E_Function)
and then Present (Alias (P_Name))
and then Is_Generic_Instance (Alias (P_Name))
then
end if;
end if;
+ -- Selector name is restricted in SPARK
+
+ if Nkind (N) = N_Expanded_Name
+ and then Restriction_Check_Required (SPARK)
+ then
+ if Is_Subprogram (P_Name) then
+ Check_SPARK_Restriction
+ ("prefix of expanded name cannot be a subprogram", P);
+ elsif Ekind (P_Name) = E_Loop then
+ Check_SPARK_Restriction
+ ("prefix of expanded name cannot be a loop statement", P);
+ end if;
+ end if;
+
else
-- If prefix is not the name of an entity, it must be an expression,
-- whose type is appropriate for a record. This is determined by
-- is completed in the current scope, and not for a limited
-- view of a type.
- if not Is_Tagged_Type (T)
- and then Ada_Version >= Ada_05
- then
- if From_With_Type (T) then
+ if Ada_Version >= Ada_2005 then
+
+ -- Test whether the Available_View of a limited type view
+ -- is tagged, since the limited view may not be marked as
+ -- tagged if the type itself has an untagged incomplete
+ -- type view in its package.
+
+ if From_With_Type (T)
+ and then not Is_Tagged_Type (Available_View (T))
+ then
Error_Msg_N
("prefix of Class attribute must be tagged", N);
Set_Etype (N, Any_Type);
end if;
Set_Is_Tagged_Type (T);
- Set_Primitive_Operations (T, New_Elmt_List);
+ Set_Direct_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));
-- Base attribute, not allowed in Ada 83
elsif Attribute_Name (N) = Name_Base then
+ Error_Msg_Name_1 := Name_Base;
+ Check_SPARK_Restriction
+ ("attribute% is only allowed as prefix of another attribute", N);
+
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Error_Msg_N
("(Ada 83) Base attribute not allowed in subtype mark", N);
("prefix of Base attribute must be scalar type",
Prefix (N));
- elsif Sloc (Typ) = Standard_Location
+ elsif Warn_On_Redundant_Constructs
and then Base_Type (Typ) = Typ
- and then Warn_On_Redundant_Constructs
then
Error_Msg_NE -- CODEFIX
("?redundant attribute, & is its own base type", N, Typ);
T := Base_Type (Typ);
-- Rewrite attribute reference with type itself (see similar
- -- processing in Analyze_Attribute, case Base). Preserve
- -- prefix if present, for other legality checks.
+ -- processing in Analyze_Attribute, case Base). Preserve prefix
+ -- if present, for other legality checks.
if Nkind (Prefix (N)) = N_Expanded_Name then
Rewrite (N,
-- nor anywhere else in the declaration because entries
-- cannot have access parameters.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Nkind (Parent (N)) = N_Access_Definition
then
Set_Entity (N, T_Name);
-- In Ada 2005, a protected name can be used in an access
-- definition within its own body.
- if Ada_Version >= Ada_05
+ if Ada_Version >= Ada_2005
and then Nkind (Parent (N)) = N_Access_Definition
then
Set_Entity (N, T_Name);
while Present (Id)
and then Id /= Priv_Id
loop
- if Is_Standard_Character_Type (Id)
- and then Id = Base_Type (Id)
- then
+ if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then
+
-- We replace the node with the literal itself, resolve as a
-- character, and set the type correctly.
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
+ if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then
Add_Implicit_Operator (Id);
return True;
end if;
while Id /= Priv_Id loop
if Is_Type (Id)
and then not Is_Limited_Type (Id)
- and then Id = Base_Type (Id)
+ and then Is_Base_Type (Id)
then
Add_Implicit_Operator (Standard_Boolean, Id);
return True;
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)
- and then Is_Scalar_Type (Component_Type (Id))))
- and then Id = Base_Type (Id)
+ or else (Is_Array_Type (Id)
+ and then Is_Scalar_Type (Component_Type (Id))))
+ and then Is_Base_Type (Id)
then
Add_Implicit_Operator (Standard_Boolean, Id);
return True;
Name_Op_Divide |
Name_Op_Expon =>
while Id /= Priv_Id loop
- if Is_Numeric_Type (Id)
- and then Id = Base_Type (Id)
- then
+ if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then
Add_Implicit_Operator (Id);
return True;
end if;
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)
+ if Is_Array_Type (Id)
+ and then Number_Dimensions (Id) = 1
+ and then Is_Base_Type (Id)
then
Add_Implicit_Operator (Id);
return True;
end Has_Implicit_Operator;
+ -----------------------------------
+ -- Has_Loop_In_Inner_Open_Scopes --
+ -----------------------------------
+
+ function Has_Loop_In_Inner_Open_Scopes (S : Entity_Id) return Boolean is
+ begin
+ -- 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
+
+ -- S was reached without seing a loop scope first
+
+ if Scope_Stack.Table (J).Entity = S then
+ return False;
+
+ -- S was not yet reached, so it contains at least one inner loop
+
+ elsif Ekind (Scope_Stack.Table (J).Entity) = E_Loop then
+ return True;
+ end if;
+
+ -- 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.
+
+ pragma Assert (not Scope_Stack.Table (J).Is_Active_Stack_Base);
+ end loop;
+
+ raise Program_Error; -- unreachable
+ end Has_Loop_In_Inner_Open_Scopes;
+
--------------------
-- In_Open_Scopes --
--------------------
procedure Pop_Scope is
SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
+ S : constant Entity_Id := SST.Entity;
begin
if Debug_Flag_E then
Write_Info;
end if;
+ -- Set Default_Storage_Pool field of the library unit if necessary
+
+ if Ekind_In (S, E_Package, E_Generic_Package)
+ and then
+ Nkind (Parent (Unit_Declaration_Node (S))) = N_Compilation_Unit
+ then
+ declare
+ Aux : constant Node_Id :=
+ Aux_Decls_Node (Parent (Unit_Declaration_Node (S)));
+ begin
+ if No (Default_Storage_Pool (Aux)) then
+ Set_Default_Storage_Pool (Aux, Default_Pool);
+ end if;
+ end;
+ end if;
+
Scope_Suppress := SST.Save_Scope_Suppress;
Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top;
Check_Policy_List := SST.Save_Check_Policy_List;
+ Default_Pool := SST.Save_Default_Storage_Pool;
if Debug_Flag_W then
- Write_Str ("--> exiting scope: ");
+ Write_Str ("<-- exiting scope: ");
Write_Name (Chars (Current_Scope));
Write_Str (", Depth=");
Write_Int (Int (Scope_Stack.Last));
or else
SST.Actions_To_Be_Wrapped_After /= No_List
then
- return;
+ raise Program_Error;
end if;
-- Free last subprogram name if allocated, and pop scope
---------------
procedure Push_Scope (S : Entity_Id) is
- E : Entity_Id;
+ E : constant Entity_Id := Scope (S);
begin
if Ekind (S) = E_Void then
SST.Save_Scope_Suppress := Scope_Suppress;
SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
SST.Save_Check_Policy_List := Check_Policy_List;
+ SST.Save_Default_Storage_Pool := Default_Pool;
if Scope_Stack.Last > Scope_Stack.First then
SST.Component_Alignment_Default := Scope_Stack.Table
and then Scope (S) /= Standard_Standard
and then not Is_Child_Unit (S)
then
- E := Scope (S);
-
if Nkind (E) not in N_Entity then
return;
end if;
Set_Categorization_From_Scope (E => S, Scop => E);
end if;
end if;
+
+ if Is_Child_Unit (S)
+ and then Present (E)
+ and then Ekind_In (E, E_Package, E_Generic_Package)
+ and then
+ Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit
+ then
+ declare
+ Aux : constant Node_Id :=
+ Aux_Decls_Node (Parent (Unit_Declaration_Node (E)));
+ begin
+ if Present (Default_Storage_Pool (Aux)) then
+ Default_Pool := Default_Storage_Pool (Aux);
+ end if;
+ end;
+ end if;
end Push_Scope;
---------------------
and then Scope (Id) /= Scope (Prev)
and then Used_As_Generic_Actual (Scope (Prev))
and then Used_As_Generic_Actual (Scope (Id))
- and then List_Containing (Current_Use_Clause (Scope (Prev))) /=
- List_Containing (Current_Use_Clause (Scope (Id)))
+ and then not In_Same_List (Current_Use_Clause (Scope (Prev)),
+ Current_Use_Clause (Scope (Id)))
then
Set_Is_Potentially_Use_Visible (Prev, False);
Append_Elmt (Prev, Hidden_By_Use_Clause (N));
-- Use_One_Type --
------------------
- procedure Use_One_Type (Id : Node_Id) is
+ procedure Use_One_Type (Id : Node_Id; Installed : Boolean := False) is
Elmt : Elmt_Id;
Is_Known_Used : Boolean;
Op_List : Elist_Id;
-- type clause is in the spec of the same package. Even though the spec
-- was analyzed first, its context is reloaded when analysing the body.
+ procedure Use_Class_Wide_Operations (Typ : Entity_Id);
+ -- AI05-150: if the use_type_clause carries the "all" qualifier,
+ -- class-wide operations of ancestor types are use-visible if the
+ -- ancestor type is visible.
+
----------------------------
-- Spec_Reloaded_For_Body --
----------------------------
return False;
end Spec_Reloaded_For_Body;
- -- Start of processing for Use_One_Type;
+ -------------------------------
+ -- Use_Class_Wide_Operations --
+ -------------------------------
+
+ procedure Use_Class_Wide_Operations (Typ : Entity_Id) is
+ Scop : Entity_Id;
+ Ent : Entity_Id;
+
+ function Is_Class_Wide_Operation_Of
+ (Op : Entity_Id;
+ T : Entity_Id) return Boolean;
+ -- Determine whether a subprogram has a class-wide parameter or
+ -- result that is T'Class.
+
+ ---------------------------------
+ -- Is_Class_Wide_Operation_Of --
+ ---------------------------------
+
+ function Is_Class_Wide_Operation_Of
+ (Op : Entity_Id;
+ T : Entity_Id) return Boolean
+ is
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Formal (Op);
+ while Present (Formal) loop
+ if Etype (Formal) = Class_Wide_Type (T) then
+ return True;
+ end if;
+ Next_Formal (Formal);
+ end loop;
+
+ if Etype (Op) = Class_Wide_Type (T) then
+ return True;
+ end if;
+
+ return False;
+ end Is_Class_Wide_Operation_Of;
+
+ -- Start of processing for Use_Class_Wide_Operations
+
+ begin
+ Scop := Scope (Typ);
+ if not Is_Hidden (Scop) then
+ Ent := First_Entity (Scop);
+ while Present (Ent) loop
+ if Is_Overloadable (Ent)
+ and then Is_Class_Wide_Operation_Of (Ent, Typ)
+ and then not Is_Potentially_Use_Visible (Ent)
+ then
+ Set_Is_Potentially_Use_Visible (Ent);
+ Append_Elmt (Ent, Used_Operations (Parent (Id)));
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end if;
+
+ if Is_Derived_Type (Typ) then
+ Use_Class_Wide_Operations (Etype (Base_Type (Typ)));
+ end if;
+ end Use_Class_Wide_Operations;
+
+ -- Start of processing for Use_One_Type
begin
-- It is the type determined by the subtype mark (8.4(8)) whose
end if;
Set_Current_Use_Clause (T, Parent (Id));
- Op_List := Collect_Primitive_Operations (T);
- 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))
- then
- Set_Is_Potentially_Use_Visible (Node (Elmt));
- end if;
+ -- Iterate over primitive operations of the type. If an operation is
+ -- already use_visible, it is the result of a previous use_clause,
+ -- and already appears on the corresponding entity chain. If the
+ -- clause is being reinstalled, operations are already use-visible.
- Next_Elmt (Elmt);
- end loop;
+ if Installed then
+ null;
+
+ else
+ Op_List := Collect_Primitive_Operations (T);
+ 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))
+ and then not Is_Potentially_Use_Visible (Node (Elmt))
+ then
+ Set_Is_Potentially_Use_Visible (Node (Elmt));
+ Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
+
+ elsif Ada_Version >= Ada_2012
+ and then All_Present (Parent (Id))
+ and then not Is_Hidden (Node (Elmt))
+ and then not Is_Potentially_Use_Visible (Node (Elmt))
+ then
+ Set_Is_Potentially_Use_Visible (Node (Elmt));
+ Append_Elmt (Node (Elmt), Used_Operations (Parent (Id)));
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ if Ada_Version >= Ada_2012
+ and then All_Present (Parent (Id))
+ and then Is_Tagged_Type (T)
+ then
+ Use_Class_Wide_Operations (T);
+ end if;
end if;
-- If warning on redundant constructs, check for unnecessary WITH
begin
S1 := Scope (Ent1);
S2 := Scope (Ent2);
- while S1 /= Standard_Standard
- and then
- S2 /= Standard_Standard
+ while Present (S1)
+ and then Present (S2)
+ and then S1 /= Standard_Standard
+ and then S2 /= Standard_Standard
loop
S1 := Scope (S1);
S2 := Scope (S2);
Write_Eol;
end Write_Info;
- -----------------
- -- Write_Scopes --
- -----------------
+ --------
+ -- ws --
+ --------
- procedure Write_Scopes is
+ procedure ws is
S : Entity_Id;
begin
for J in reverse 1 .. Scope_Stack.Last loop
Write_Name (Chars (S));
Write_Eol;
end loop;
- end Write_Scopes;
+ end ws;
end Sem_Ch8;
OSDN Git Service
