-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, 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;
-- 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
Nam : constant Node_Id := Name (N);
begin
- Check_Formal_Restriction ("exception renaming is not allowed", N);
+ Check_SPARK_Restriction ("exception renaming is not allowed", N);
Enter_Name (Id);
Analyze (Nam);
return;
end if;
- Check_Formal_Restriction ("generic renaming is not allowed", N);
+ Check_SPARK_Restriction ("generic renaming is not allowed", N);
Generate_Definition (New_P);
-----------------------------
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_Formal_Restriction ("object renaming is not allowed", N);
+ 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
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;
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;
-- 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 --
-----------------------------
Next (F);
end loop;
- if Ekind (Prim_Op) = E_Function then
+ if Ekind_In (Prim_Op, E_Function, E_Operator) then
return Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
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);
Statements (Handled_Statement_Sequence (New_Body)));
-- The generated body does not freeze. It is analyzed when the
- -- generated operation is frozen.
+ -- generated operation is frozen. This body is only needed if
+ -- expansion is enabled.
- Append_Freeze_Action (Defining_Entity (New_Decl), New_Body);
+ 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 the class-wide operation if one was created
return Result;
end Check_Class_Wide_Actual;
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)
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;
-- 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;
end if;
end if;
- -- If no renamed entity was found, check whether the renaming is for
- -- a defaulted actual subprogram with a class-wide actual.
-
- if Old_S = Any_Id
- and then Is_Actual
- and then From_Default (N)
- then
- Old_S := Check_Class_Wide_Actual;
- 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;
elsif Ekind (Old_S) /= E_Operator then
- -- If this is a default subprogram, it may be for a class-wide
- -- actual, in which case there is no check for mode conformance,
- -- given that the signatures do not match (the source mentions T,
- -- but the actual mentions T'Class).
+ -- 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 Is_Actual
- and then From_Default (N)
- then
+ if CW_Actual then
null;
-
else
Check_Mode_Conformant (New_S, Old_S);
end if;
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;
("?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_Formal_Restriction ("use clause is not allowed", N);
+ Check_SPARK_Restriction ("use clause is not allowed", N);
Set_Hidden_By_Use_Clause (N, No_Elist);
-- type is still not frozen). We exclude from this processing generic
-- formal subprograms found in instantiations and AST_Entry renamings.
- -- We must exclude VM targets because entity AST_Handler is defined in
- -- package System.Aux_Dec which is not available in those platforms.
+ -- 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
(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)
- or else Present (Current_Use_Clause (Base_Type (T))))
- and then Scope (T) = Scope (Op);
+ return In_Use (T) and then Scope (T) = Scope (Op);
end Is_Primitive_Operator_In_Use;
-- Start of processing for End_Use_Package
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);
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;
-- Selector name cannot be a character literal or an operator symbol in
-- SPARK, except for the operator symbol in a renaming.
- if SPARK_Mode or else Restriction_Check_Required (SPARK) then
+ if Restriction_Check_Required (SPARK) then
if Nkind (Selector_Name (N)) = N_Character_Literal then
- Check_Formal_Restriction
+ 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_Formal_Restriction ("operator symbol cannot be prefixed", N);
+ Check_SPARK_Restriction ("operator symbol cannot be prefixed", N);
end if;
end if;
then
-- Do not build the subtype when referencing components of
-- dispatch table wrappers. Required to avoid generating
- -- elaboration code with HI runtimes.
-
- if RTU_Loaded (Ada_Tags)
- and then RTE_Available (RE_Dispatch_Table_Wrapper)
- and then Scope (Selector) = RTE (RE_Dispatch_Table_Wrapper)
- then
- C_Etype := Empty;
+ -- 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.
- elsif RTU_Loaded (Ada_Tags)
- and then RTE_Available (RE_No_Dispatch_Table_Wrapper)
- and then Scope (Selector)
- = RTE (RE_No_Dispatch_Table_Wrapper)
+ 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);
+ Build_Actual_Subtype_Of_Component
+ (Etype (Selector), N);
end if;
else
-- Selector name is restricted in SPARK
if Nkind (N) = N_Expanded_Name
- and then (SPARK_Mode or else Restriction_Check_Required (SPARK))
+ and then Restriction_Check_Required (SPARK)
then
if Is_Subprogram (P_Name) then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("prefix of expanded name cannot be a subprogram", P);
elsif Ekind (P_Name) = E_Loop then
- Check_Formal_Restriction
+ Check_SPARK_Restriction
("prefix of expanded name cannot be a loop statement", P);
end if;
end if;
-- 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_2005
- 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);
elsif Attribute_Name (N) = Name_Base then
Error_Msg_Name_1 := Name_Base;
- Check_Formal_Restriction
+ 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
end if;
end Use_Class_Wide_Operations;
- -- Start of processing for Use_One_Type;
+ -- Start of processing for Use_One_Type
begin
-- It is the type determined by the subtype mark (8.4(8)) whose
OSDN Git Service
