-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
-- Ada 2005: implementation of AI-310. An abstract non-dispatching
-- operation is not a candidate interpretation.
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean;
+ -- AI05-0139: Generalized indexing to support iterators over containers
+
function Try_Indexed_Call
(N : Node_Id;
Nam : Entity_Id;
-- subprogram, and the call F (X) interpreted as F.all (X). In this case
-- the call may be overloaded with both interpretations.
- function Try_Object_Operation (N : Node_Id) return Boolean;
+ function Try_Object_Operation
+ (N : Node_Id;
+ CW_Test_Only : Boolean := False) return Boolean;
-- Ada 2005 (AI-252): Support the object.operation notation. If node N
-- is a call in this notation, it is transformed into a normal subprogram
-- call where the prefix is a parameter, and True is returned. If node
- -- N is not of this form, it is unchanged, and False is returned.
+ -- N is not of this form, it is unchanged, and False is returned. if
+ -- CW_Test_Only is true then N is an N_Selected_Component node which
+ -- is part of a call to an entry or procedure of a tagged concurrent
+ -- type and this routine is invoked to search for class-wide subprograms
+ -- conflicting with the target entity.
procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo);
Nam := Opnd;
elsif Nkind (Opnd) = N_Function_Call then
Nam := Name (Opnd);
- else
+ elsif Ada_Version >= Ada_2012 then
+ declare
+ It : Interp;
+ I : Interp_Index;
+
+ begin
+ Get_First_Interp (Opnd, I, It);
+ while Present (It.Nam) loop
+ if Has_Implicit_Dereference (It.Typ) then
+ Error_Msg_N
+ ("can be interpreted as implicit dereference", Opnd);
+ return;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+
return;
end if;
C : Node_Id;
begin
+ Check_SPARK_Restriction ("allocator is not allowed", N);
+
-- Deal with allocator restrictions
-- In accordance with H.4(7), the No_Allocators restriction only applies
exit;
end if;
- -- The other case is appearence in a subprogram body. This may
+ -- The other case is appearance in a subprogram body. This may
-- be a violation if this is a library level subprogram, and it
-- turns out to be used as the main program, but only the
-- binder knows that, so just record the occurrence.
end loop;
end if;
- -- Analyze the allocator
+ -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
+ -- any. The expected type for the name is any type. A non-overloading
+ -- rule then requires it to be of a type descended from
+ -- System.Storage_Pools.Subpools.Subpool_Handle.
+
+ -- This isn't exactly what the AI says, but it seems to be the right
+ -- rule. The AI should be fixed.???
+
+ declare
+ Subpool : constant Node_Id := Subpool_Handle_Name (N);
+
+ begin
+ if Present (Subpool) then
+ Analyze (Subpool);
+
+ if Is_Overloaded (Subpool) then
+ Error_Msg_N ("ambiguous subpool handle", Subpool);
+ end if;
+
+ -- Check that Etype (Subpool) is descended from Subpool_Handle
+
+ Resolve (Subpool);
+ end if;
+ end;
+
+ -- Analyze the qualified expression or subtype indication
if Nkind (E) = N_Qualified_Expression then
Acc_Type := Create_Itype (E_Allocator_Type, N);
Find_Type (Subtype_Mark (E));
-- Analyze the qualified expression, and apply the name resolution
- -- rule given in 4.7 (3).
+ -- rule given in 4.7(3).
Analyze (E);
Type_Id := Etype (E);
Resolve (Expression (E), Type_Id);
+ -- Allocators generated by the build-in-place expansion mechanism
+ -- are explicitly marked as coming from source but do not need to be
+ -- checked for limited initialization. To exclude this case, ensure
+ -- that the parent of the allocator is a source node.
+
if Is_Limited_Type (Type_Id)
and then Comes_From_Source (N)
+ and then Comes_From_Source (Parent (N))
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Type_Id, Expression (E)) then
-- and the allocated object is unconstrained.
elsif Ada_Version >= Ada_2005
- and then Has_Constrained_Partial_View (Base_Typ)
+ and then Effectively_Has_Constrained_Partial_View
+ (Typ => Base_Typ,
+ Scop => Current_Scope)
then
Error_Msg_N
- ("constraint no allowed when type " &
+ ("constraint not allowed when type " &
"has a constrained partial view", Constraint (E));
end if;
Check_Restriction (No_Tasking, N);
Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Task_Allocators, N);
+ end if;
- -- Check that an allocator with task parts isn't for a nested access
- -- type when restriction No_Task_Hierarchy applies.
+ -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
+ -- type is nested, and the designated type needs finalization. The rule
+ -- is conservative in that class-wide types need finalization.
- if not Is_Library_Level_Entity (Acc_Type) then
- Check_Restriction (No_Task_Hierarchy, N);
- end if;
+ if Needs_Finalization (Designated_Type (Acc_Type))
+ and then not Is_Library_Level_Entity (Acc_Type)
+ then
+ Check_Restriction (No_Nested_Finalization, N);
end if;
-- Check that an allocator of a nested access type doesn't create a
-- Flag indicates whether an interpretation of the prefix is a
-- parameterless call that returns an access_to_subprogram.
+ procedure Check_Mixed_Parameter_And_Named_Associations;
+ -- Check that parameter and named associations are not mixed. This is
+ -- a restriction in SPARK mode.
+
function Name_Denotes_Function return Boolean;
-- If the type of the name is an access to subprogram, this may be the
-- type of a name, or the return type of the function being called. If
procedure No_Interpretation;
-- Output error message when no valid interpretation exists
+ --------------------------------------------------
+ -- Check_Mixed_Parameter_And_Named_Associations --
+ --------------------------------------------------
+
+ procedure Check_Mixed_Parameter_And_Named_Associations is
+ Actual : Node_Id;
+ Named_Seen : Boolean;
+
+ begin
+ Named_Seen := False;
+
+ Actual := First (Actuals);
+ while Present (Actual) loop
+ case Nkind (Actual) is
+ when N_Parameter_Association =>
+ if Named_Seen then
+ Check_SPARK_Restriction
+ ("named association cannot follow positional one",
+ Actual);
+ exit;
+ end if;
+ when others =>
+ Named_Seen := True;
+ end case;
+
+ Next (Actual);
+ end loop;
+ end Check_Mixed_Parameter_And_Named_Associations;
+
---------------------------
-- Name_Denotes_Function --
---------------------------
-- Start of processing for Analyze_Call
begin
+ if Restriction_Check_Required (SPARK) then
+ Check_Mixed_Parameter_And_Named_Associations;
+ end if;
+
-- Initialize the type of the result of the call to the error type,
-- which will be reset if the type is successfully resolved.
Get_First_Interp (FirstX, I, It);
while Present (It.Nam) loop
- -- For each intepretation of the first expression, we only
- -- add the intepretation if every other expression in the
+ -- For each interpretation of the first expression, we only
+ -- add the interpretation if every other expression in the
-- case expression alternatives has a compatible type.
Alt := Next (First (Alternatives (N)));
return;
end if;
+ Check_SPARK_Restriction ("conditional expression is not allowed", N);
+
Else_Expr := Next (Then_Expr);
if Comes_From_Source (N) then
begin
Set_Etype (N, Any_Type);
+
+ -- Shouldn't the following statement be down in the ELSE of the
+ -- following loop? ???
+
Get_First_Interp (Then_Expr, I, It);
- while Present (It.Nam) loop
- -- For each possible intepretation of the Then Expression,
- -- add it only if the else expression has a compatible type.
+ -- if no Else_Expression the conditional must be boolean
- -- Is this right if Else_Expr is empty?
+ if No (Else_Expr) then
+ Set_Etype (N, Standard_Boolean);
- if Has_Compatible_Type (Else_Expr, It.Typ) then
- Add_One_Interp (N, It.Typ, It.Typ);
- end if;
+ -- Else_Expression Present. For each possible intepretation of
+ -- the Then_Expression, add it only if the Else_Expression has
+ -- a compatible type.
- Get_Next_Interp (I, It);
- end loop;
+ else
+ while Present (It.Nam) loop
+ if Has_Compatible_Type (Else_Expr, It.Typ) then
+ Add_One_Interp (N, It.Typ, It.Typ);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end if;
end;
end if;
end Analyze_Conditional_Expression;
-- Start of processing for Analyze_Explicit_Dereference
begin
+ -- If source node, check SPARK restriction. We guard this with the
+ -- source node check, because ???
+
+ if Comes_From_Source (N) then
+ Check_SPARK_Restriction ("explicit dereference is not allowed", N);
+ end if;
+
+ -- In formal verification mode, keep track of all reads and writes
+ -- through explicit dereferences.
+
+ if Alfa_Mode then
+ Alfa.Generate_Dereference (N);
+ end if;
+
Analyze (P);
Set_Etype (N, Any_Type);
then
return;
+ elsif Try_Container_Indexing (N, P, Exp) then
+ return;
+
elsif Array_Type = Any_Type then
Set_Etype (N, Any_Type);
end loop;
Set_Etype (N, Component_Type (Array_Type));
+ Check_Implicit_Dereference (N, Etype (N));
if Present (Index) then
Error_Msg_N
end loop;
if Found and then No (Index) and then No (Exp) then
- Add_One_Interp (N,
- Etype (Component_Type (Typ)),
- Etype (Component_Type (Typ)));
+ declare
+ CT : constant Entity_Id :=
+ Base_Type (Component_Type (Typ));
+ begin
+ Add_One_Interp (N, CT, CT);
+ Check_Implicit_Dereference (N, CT);
+ end;
end if;
+
+ elsif Try_Container_Indexing (N, P, First (Exprs)) then
+ return;
+
end if;
Get_Next_Interp (I, It);
end if;
-- If not a range, it can be a subtype mark, or else it is a degenerate
- -- membership test with a singleton value, i.e. a test for equality.
+ -- membership test with a singleton value, i.e. a test for equality,
+ -- if the types are compatible.
else
Analyze (R);
+
if Is_Entity_Name (R)
and then Is_Type (Entity (R))
then
Find_Type (R);
Check_Fully_Declared (Entity (R), R);
- elsif Ada_Version >= Ada_2012 then
+ elsif Ada_Version >= Ada_2012
+ and then Has_Compatible_Type (R, Etype (L))
+ then
if Nkind (N) = N_In then
Rewrite (N,
Make_Op_Eq (Loc,
return;
else
- -- In previous version of the language this is an error that will
- -- be diagnosed below.
+ -- In all versions of the language, if we reach this point there
+ -- is a previous error that will be diagnosed below.
Find_Type (R);
end if;
procedure Analyze_Null (N : Node_Id) is
begin
+ Check_SPARK_Restriction ("null is not allowed", N);
+
Set_Etype (N, Any_Access);
end Analyze_Null;
procedure Indicate_Name_And_Type is
begin
Add_One_Interp (N, Nam, Etype (Nam));
+ Check_Implicit_Dereference (N, Etype (Nam));
Success := True;
-- If the prefix of the call is a name, indicate the entity
Actual := First_Actual (N);
Formal := First_Formal (Nam);
- -- If we are analyzing a call rewritten from object notation,
- -- skip first actual, which may be rewritten later as an
- -- explicit dereference.
+ -- If we are analyzing a call rewritten from object notation, skip
+ -- first actual, which may be rewritten later as an explicit
+ -- dereference.
if Must_Skip then
Next_Actual (Actual);
if Present (Next_Actual (Act2)) then
return;
+ end if;
- elsif Op_Name = Name_Op_Add
- or else Op_Name = Name_Op_Subtract
- or else Op_Name = Name_Op_Multiply
- or else Op_Name = Name_Op_Divide
- or else Op_Name = Name_Op_Mod
- or else Op_Name = Name_Op_Rem
- or else Op_Name = Name_Op_Expon
- then
- Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
+ -- Otherwise action depends on operator
- elsif Op_Name = Name_Op_And
- or else Op_Name = Name_Op_Or
- or else Op_Name = Name_Op_Xor
- then
- Find_Boolean_Types (Act1, Act2, Op_Id, N);
+ case Op_Name is
+ when Name_Op_Add |
+ Name_Op_Subtract |
+ Name_Op_Multiply |
+ Name_Op_Divide |
+ Name_Op_Mod |
+ Name_Op_Rem |
+ Name_Op_Expon =>
+ Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
- elsif Op_Name = Name_Op_Lt
- or else Op_Name = Name_Op_Le
- or else Op_Name = Name_Op_Gt
- or else Op_Name = Name_Op_Ge
- then
- Find_Comparison_Types (Act1, Act2, Op_Id, N);
+ when Name_Op_And |
+ Name_Op_Or |
+ Name_Op_Xor =>
+ Find_Boolean_Types (Act1, Act2, Op_Id, N);
- elsif Op_Name = Name_Op_Eq
- or else Op_Name = Name_Op_Ne
- then
- Find_Equality_Types (Act1, Act2, Op_Id, N);
+ when Name_Op_Lt |
+ Name_Op_Le |
+ Name_Op_Gt |
+ Name_Op_Ge =>
+ Find_Comparison_Types (Act1, Act2, Op_Id, N);
- elsif Op_Name = Name_Op_Concat then
- Find_Concatenation_Types (Act1, Act2, Op_Id, N);
+ when Name_Op_Eq |
+ Name_Op_Ne =>
+ Find_Equality_Types (Act1, Act2, Op_Id, N);
- -- Is this else null correct, or should it be an abort???
+ when Name_Op_Concat =>
+ Find_Concatenation_Types (Act1, Act2, Op_Id, N);
- else
- null;
- end if;
+ -- Is this when others, or should it be an abort???
+
+ when others =>
+ null;
+ end case;
-- Unary operator case
else
- if Op_Name = Name_Op_Subtract or else
- Op_Name = Name_Op_Add or else
- Op_Name = Name_Op_Abs
- then
- Find_Unary_Types (Act1, Op_Id, N);
+ case Op_Name is
+ when Name_Op_Subtract |
+ Name_Op_Add |
+ Name_Op_Abs =>
+ Find_Unary_Types (Act1, Op_Id, N);
- elsif
- Op_Name = Name_Op_Not
- then
- Find_Negation_Types (Act1, Op_Id, N);
+ when Name_Op_Not =>
+ Find_Negation_Types (Act1, Op_Id, N);
- -- Is this else null correct, or should it be an abort???
+ -- Is this when others correct, or should it be an abort???
- else
- null;
- end if;
+ when others =>
+ null;
+ end case;
end if;
end Analyze_Operator_Call;
T := It.Typ;
end if;
- if Is_Record_Type (T) then
+ -- Locate the component. For a private prefix the selector can denote
+ -- a discriminant.
+
+ if Is_Record_Type (T) or else Is_Private_Type (T) then
-- If the prefix is a class-wide type, the visible components are
-- those of the base type.
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Add_One_Interp (N, Etype (Comp), Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (Comp));
-- This also specifies a candidate to resolve the name.
-- Further overloading will be resolved from context.
begin
Set_Etype (Ent, Standard_Void_Type);
+ Set_Scope (Ent, Current_Scope);
Set_Parent (Ent, N);
+ Check_SPARK_Restriction ("quantified expression is not allowed", N);
+
+ -- If expansion is enabled (and not in Alfa mode), the condition is
+ -- analyzed after rewritten as a loop. So we only need to set the type.
+
+ if Operating_Mode /= Check_Semantics
+ and then not Alfa_Mode
+ then
+ Set_Etype (N, Standard_Boolean);
+ return;
+ end if;
+
if Present (Loop_Parameter_Specification (N)) then
Iterator :=
Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Loop_Parameter_Specification (N));
+ Loop_Parameter_Specification =>
+ Loop_Parameter_Specification (N));
else
Iterator :=
Make_Iteration_Scheme (Loc,
Set_Parent (Iterator, N);
Analyze_Iteration_Scheme (Iterator);
- -- The loop specification may have been converted into an
- -- iterator specification during its analysis. Update the
- -- quantified node accordingly.
+ -- The loop specification may have been converted into an iterator
+ -- specification during its analysis. Update the quantified node
+ -- accordingly.
if Present (Iterator_Specification (Iterator)) then
Set_Iterator_Specification
Analyze (Condition (N));
End_Scope;
-
Set_Etype (N, Standard_Boolean);
end Analyze_Quantified_Expression;
-- of the high bound.
procedure Check_Universal_Expression (N : Node_Id);
- -- In Ada83, reject bounds of a universal range that are not
- -- literals or entity names.
+ -- In Ada 83, reject bounds of a universal range that are not literals
+ -- or entity names.
-----------------------
-- Check_Common_Type --
-- be done transitively, so note the new original discriminant.
if Nkind (Sel) = N_Identifier
+ and then In_Instance
and then Present (Original_Discriminant (Sel))
then
Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
New_Occurrence_Of (Comp, Sloc (N)));
Set_Original_Discriminant (Selector_Name (N), Comp);
Set_Etype (N, Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (Comp));
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
Set_Etype (N, Etype (Comp));
end if;
+ Check_Implicit_Dereference (N, Etype (N));
return;
end if;
-- which can appear in expanded code in a tag check.
if Ekind (Type_To_Use) = E_Record_Type_With_Private
- and then Chars (Selector_Name (N)) /= Name_uTag
+ and then Chars (Selector_Name (N)) /= Name_uTag
then
exit when Comp = Last_Entity (Type_To_Use);
end if;
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
+ Check_Implicit_Dereference (N, Etype (N));
if Is_Generic_Type (Prefix_Type)
or else Is_Generic_Type (Root_Type (Prefix_Type))
Set_Entity_With_Style_Check (Sel, Comp);
Generate_Reference (Comp, Sel);
+ -- The selector is not overloadable, so we have a candidate
+ -- interpretation.
+
+ Has_Candidate := True;
+
else
goto Next_Comp;
end if;
then
return;
end if;
+
+ -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
+ -- entry or procedure of a tagged concurrent type we must check
+ -- if there are class-wide subprograms covering the primitive. If
+ -- true then Try_Object_Operation reports the error.
+
+ if Has_Candidate
+ and then Is_Concurrent_Type (Prefix_Type)
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+
+ -- Duplicate the call. This is required to avoid problems with
+ -- the tree transformations performed by Try_Object_Operation.
+
+ and then
+ Try_Object_Operation
+ (N => Sinfo.Name (New_Copy_Tree (Parent (N))),
+ CW_Test_Only => True)
+ then
+ return;
+ end if;
end if;
if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
+
-- Case of a prefix of a protected type: selector might denote
-- an invisible private component.
-- Finally, the formal and the actual may be private extensions,
-- but the generic is declared in a child unit of the parent, and
- -- an addtional step is needed to retrieve the proper scope.
+ -- an additional step is needed to retrieve the proper scope.
elsif In_Instance
and then Present (Parent_Subtype (Etype (Base_Type (Prefix_Type))))
Error_Msg_Node_2 := First_Subtype (Prefix_Type);
Error_Msg_NE ("no selector& for}", N, Sel);
+ -- Add information in the case of an incomplete prefix
+
+ if Is_Incomplete_Type (Type_To_Use) then
+ declare
+ Inc : constant Entity_Id := First_Subtype (Type_To_Use);
+
+ begin
+ if From_With_Type (Scope (Type_To_Use)) then
+ Error_Msg_NE
+ ("\limited view of& has no components", N, Inc);
+
+ else
+ Error_Msg_NE
+ ("\premature usage of incomplete type&", N, Inc);
+
+ if Nkind (Parent (Inc)) =
+ N_Incomplete_Type_Declaration
+ then
+ -- Record location of premature use in entity so that
+ -- a continuation message is generated when the
+ -- completion is seen.
+
+ Set_Premature_Use (Parent (Inc), N);
+ end if;
+ end if;
+ end;
+ end if;
+
Check_Misspelled_Selector (Type_To_Use, Sel);
end if;
-- Start of processing for Analyze_Slice
begin
+ if Comes_From_Source (N) then
+ Check_SPARK_Restriction ("slice is not allowed", N);
+ end if;
+
Analyze (P);
Analyze (D);
null;
else
- -- Save candidate type for subsquent error message, if any
+ -- Save candidate type for subsequent error message, if any
if not Is_Limited_Type (T1) then
Candidate_Type := T1;
end if;
if T1 /= Standard_Void_Type
- and then not Is_Limited_Type (T1)
- and then not Is_Limited_Composite (T1)
and then Has_Compatible_Type (R, T1)
+ and then
+ ((not Is_Limited_Type (T1)
+ and then not Is_Limited_Composite (T1))
+
+ or else
+ (Is_Array_Type (T1)
+ and then not Is_Limited_Type (Component_Type (T1))
+ and then Available_Full_View_Of_Component (T1)))
then
if Found
and then Base_Type (T1) /= Base_Type (T_F)
Error_Msg_NE -- CODEFIX
("operator for} is not directly visible!",
N, First_Subtype (Candidate_Type));
- Error_Msg_N -- CODEFIX
- ("use clause would make operation legal!", N);
+
+ declare
+ U : constant Node_Id :=
+ Cunit (Get_Source_Unit (Candidate_Type));
+ begin
+ if Unit_Is_Visible (U) then
+ Error_Msg_N -- CODEFIX
+ ("use clause would make operation legal!", N);
+ else
+ Error_Msg_NE -- CODEFIX
+ ("add with_clause and use_clause for&!",
+ N, Defining_Entity (Unit (U)));
+ end if;
+ end;
return;
-- If either operand is a junk operand (e.g. package name), then
Remove_Interp (I);
exit;
- -- In Ada 2005, this operation does not participate in Overload
+ -- In Ada 2005, this operation does not participate in overload
-- resolution. If the operation is defined in a predefined
-- unit, it is one of the operations declared abstract in some
-- variants of System, and it must be removed as well.
end if;
end Remove_Abstract_Operations;
+ ----------------------------
+ -- Try_Container_Indexing --
+ ----------------------------
+
+ function Try_Container_Indexing
+ (N : Node_Id;
+ Prefix : Node_Id;
+ Expr : Node_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Disc : Entity_Id;
+ Func : Entity_Id;
+ Func_Name : Node_Id;
+ Indexing : Node_Id;
+
+ begin
+
+ -- Check whether type has a specified indexing aspect
+
+ Func_Name := Empty;
+
+ if Is_Variable (Prefix) then
+ Func_Name := Find_Aspect (Etype (Prefix), Aspect_Variable_Indexing);
+ end if;
+
+ if No (Func_Name) then
+ Func_Name := Find_Aspect (Etype (Prefix), Aspect_Constant_Indexing);
+ end if;
+
+ -- If aspect does not exist the expression is illegal. Error is
+ -- diagnosed in caller.
+
+ if No (Func_Name) then
+
+ -- The prefix itself may be an indexing of a container
+ -- rewrite as such and re-analyze.
+
+ if Has_Implicit_Dereference (Etype (Prefix)) then
+ Build_Explicit_Dereference
+ (Prefix, First_Discriminant (Etype (Prefix)));
+ return Try_Container_Indexing (N, Prefix, Expr);
+
+ else
+ return False;
+ end if;
+ end if;
+
+ if not Is_Overloaded (Func_Name) then
+ Func := Entity (Func_Name);
+ Indexing := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Func, Loc),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+ Rewrite (N, Indexing);
+ Analyze (N);
+
+ -- The return type of the indexing function is a reference type, so
+ -- add the dereference as a possible interpretation.
+
+ Disc := First_Discriminant (Etype (Func));
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ else
+ Indexing := Make_Function_Call (Loc,
+ Name => Make_Identifier (Loc, Chars (Func_Name)),
+ Parameter_Associations =>
+ New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
+
+ Rewrite (N, Indexing);
+
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+
+ begin
+ Get_First_Interp (Func_Name, I, It);
+ Set_Etype (N, Any_Type);
+ while Present (It.Nam) loop
+ Analyze_One_Call (N, It.Nam, False, Success);
+ if Success then
+ Set_Etype (Name (N), It.Typ);
+ Set_Entity (Name (N), It.Nam);
+
+ -- Add implicit dereference interpretation
+
+ Disc := First_Discriminant (Etype (It.Nam));
+ while Present (Disc) loop
+ if Has_Implicit_Dereference (Disc) then
+ Add_One_Interp
+ (N, Disc, Designated_Type (Etype (Disc)));
+ exit;
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ exit;
+ end if;
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ if Etype (N) = Any_Type then
+ Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr));
+ Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
+ else
+ Analyze (N);
+ end if;
+
+ return True;
+ end Try_Container_Indexing;
+
-----------------------
-- Try_Indirect_Call --
-----------------------
-- Try_Object_Operation --
--------------------------
- function Try_Object_Operation (N : Node_Id) return Boolean is
+ function Try_Object_Operation
+ (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean
+ is
K : constant Node_Kind := Nkind (Parent (N));
Is_Subprg_Call : constant Boolean := Nkind_In
(K, N_Procedure_Call_Statement,
Call : Node_Id;
Subp : Entity_Id) return Entity_Id;
-- If the subprogram is a valid interpretation, record it, and add
- -- to the list of interpretations of Subprog.
+ -- to the list of interpretations of Subprog. Otherwise return Empty.
procedure Complete_Object_Operation
(Call_Node : Node_Id;
First_Actual := First (Parameter_Associations (Call_Node));
-- For cross-reference purposes, treat the new node as being in
- -- the source if the original one is.
+ -- the source if the original one is. Set entity and type, even
+ -- though they may be overwritten during resolution if overloaded.
Set_Comes_From_Source (Subprog, Comes_From_Source (N));
Set_Comes_From_Source (Call_Node, Comes_From_Source (N));
and then not Inside_A_Generic
then
Set_Entity (Selector_Name (N), Entity (Subprog));
+ Set_Etype (Selector_Name (N), Etype (Entity (Subprog)));
end if;
-- If need be, rewrite first actual as an explicit dereference
----------------------
procedure Report_Ambiguity (Op : Entity_Id) is
- Access_Formal : constant Boolean :=
- Is_Access_Type (Etype (First_Formal (Op)));
Access_Actual : constant Boolean :=
Is_Access_Type (Etype (Prefix (N)));
+ Access_Formal : Boolean := False;
begin
Error_Msg_Sloc := Sloc (Op);
+ if Present (First_Formal (Op)) then
+ Access_Formal := Is_Access_Type (Etype (First_Formal (Op)));
+ end if;
+
if Access_Formal and then not Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N
Hom := Current_Entity (Subprog);
- -- Find operation whose first parameter is of the class-wide
- -- type, a subtype thereof, or an anonymous access to same.
+ -- Find a non-hidden operation whose first parameter is of the
+ -- class-wide type, a subtype thereof, or an anonymous access
+ -- to same.
while Present (Hom) loop
- if (Ekind (Hom) = E_Procedure
- or else
- Ekind (Hom) = E_Function)
+ if Ekind_In (Hom, E_Procedure, E_Function)
+ and then not Is_Hidden (Hom)
and then Scope (Hom) = Scope (Anc_Type)
and then Present (First_Formal (Hom))
and then
(Designated_Type (Etype (First_Formal (Hom)))) =
Cls_Type))
then
+ -- If the context is a procedure call, ignore functions
+ -- in the name of the call.
+
+ if Ekind (Hom) = E_Function
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+ and then N = Name (Parent (N))
+ then
+ goto Next_Hom;
+
+ -- If the context is a function call, ignore procedures
+ -- in the name of the call.
+
+ elsif Ekind (Hom) = E_Procedure
+ and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
+ then
+ goto Next_Hom;
+ end if;
+
Set_Etype (Call_Node, Any_Type);
Set_Is_Overloaded (Call_Node, False);
Success := False;
end if;
end if;
- Hom := Homonym (Hom);
+ <<Next_Hom>>
+ Hom := Homonym (Hom);
end loop;
end Traverse_Homonyms;
-- Start of processing for Try_Class_Wide_Operation
begin
+ -- If we are searching only for conflicting class-wide subprograms
+ -- then initialize directly Matching_Op with the target entity.
+
+ if CW_Test_Only then
+ Matching_Op := Entity (Selector_Name (N));
+ end if;
+
-- Loop through ancestor types (including interfaces), traversing
-- the homonym chain of the subprogram, trying out those homonyms
-- whose first formal has the class-wide type of the ancestor, or
return;
end if;
- if Try_Primitive_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- or else
- Try_Class_Wide_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace)
- then
- null;
- end if;
+ declare
+ Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
+ CW_Result : Boolean;
+ Prim_Result : Boolean;
+ pragma Unreferenced (CW_Result);
+
+ begin
+ if not CW_Test_Only then
+ Prim_Result :=
+ Try_Primitive_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ end if;
+
+ -- Check if there is a class-wide subprogram covering the
+ -- primitive. This check must be done even if a candidate
+ -- was found in order to report ambiguous calls.
+
+ if not (Prim_Result) then
+ CW_Result :=
+ Try_Class_Wide_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+
+ -- If we found a primitive we search for class-wide subprograms
+ -- using a duplicate of the call node (done to avoid missing its
+ -- decoration if there is no ambiguity).
+
+ else
+ CW_Result :=
+ Try_Class_Wide_Operation
+ (Call_Node => Dup_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ end if;
+ end;
end Try_One_Prefix_Interpretation;
-----------------------------
or else
(Ekind (Typ) = E_Anonymous_Access_Type
- and then Designated_Type (Typ) = Base_Type (Corr_Type));
+ and then
+ Base_Type (Designated_Type (Typ)) = Base_Type (Corr_Type));
end Valid_First_Argument_Of;
-- Start of processing for Try_Primitive_Operation
end if;
if Etype (New_Call_Node) /= Any_Type then
- Complete_Object_Operation
- (Call_Node => New_Call_Node,
- Node_To_Replace => Node_To_Replace);
- return True;
+
+ -- No need to complete the tree transformations if we are only
+ -- searching for conflicting class-wide subprograms
+
+ if CW_Test_Only then
+ return False;
+ else
+ Complete_Object_Operation
+ (Call_Node => New_Call_Node,
+ Node_To_Replace => Node_To_Replace);
+ return True;
+ end if;
elsif Present (Candidate) then
OSDN Git Service
