-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
procedure Check_Misspelled_Selector
(Prefix : Entity_Id;
Sel : Node_Id);
- -- Give possible misspelling diagnostic if Sel is likely to be
- -- a misspelling of one of the selectors of the Prefix.
- -- This is called by Analyze_Selected_Component after producing
- -- an invalid selector error message.
+ -- Give possible misspelling diagnostic if Sel is likely to be a mis-
+ -- spelling of one of the selectors of the Prefix. This is called by
+ -- Analyze_Selected_Component after producing an invalid selector error
+ -- message.
function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
- -- Verify that type T is declared in scope S. Used to find intepretations
+ -- Verify that type T is declared in scope S. Used to find interpretations
-- for operators given by expanded names. This is abstracted as a separate
-- function to handle extensions to System, where S is System, but T is
-- declared in the extension.
and then Comes_From_Source (N)
and then not In_Instance_Body
then
- if not OK_For_Limited_Init (Expression (E)) then
+ if not OK_For_Limited_Init (Type_Id, Expression (E)) then
Error_Msg_N ("initialization not allowed for limited types", N);
Explain_Limited_Type (Type_Id, N);
end if;
if Nkind (Constraint (E)) =
N_Index_Or_Discriminant_Constraint
then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("\if qualified expression was meant, " &
"use apostrophe", Constraint (E));
end if;
and then Nkind (Constraint (E)) =
N_Index_Or_Discriminant_Constraint
then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("if qualified expression was meant, " &
"use apostrophe!", Constraint (E));
end if;
Set_Directly_Designated_Type (Acc_Type, Type_Id);
Check_Fully_Declared (Type_Id, N);
- -- Ada 2005 (AI-231)
+ -- Ada 2005 (AI-231): If the designated type is itself an access
+ -- type that excludes null, its default initialization will
+ -- be a null object, and we can insert an unconditional raise
+ -- before the allocator.
if Can_Never_Be_Null (Type_Id) then
- Error_Msg_N ("(Ada 2005) qualified expression required",
- Expression (N));
+ declare
+ Not_Null_Check : constant Node_Id :=
+ Make_Raise_Constraint_Error (Sloc (E),
+ Reason => CE_Null_Not_Allowed);
+ begin
+ if Expander_Active then
+ Insert_Action (N, Not_Null_Check);
+ Analyze (Not_Null_Check);
+ else
+ Error_Msg_N ("null value not allowed here?", E);
+ end if;
+ end;
end if;
-- Check restriction against dynamically allocated protected
procedure Analyze_Call (N : Node_Id) is
Actuals : constant List_Id := Parameter_Associations (N);
- Nam : Node_Id := Name (N);
+ Nam : Node_Id;
X : Interp_Index;
It : Interp;
Nam_Ent : Entity_Id;
Success : Boolean := False;
+ Deref : Boolean := False;
+ -- Flag indicates whether an interpretation of the prefix is a
+ -- parameterless call that returns an access_to_subprogram.
+
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 the name is not an entity then it can denote a protected function.
- -- Until we distinguish Etype from Return_Type, we must use this
- -- routine to resolve the meaning of the name in the call.
+ -- 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
+ -- the name is not an entity then it can denote a protected function.
+ -- Until we distinguish Etype from Return_Type, we must use this routine
+ -- to resolve the meaning of the name in the call.
+
+ procedure No_Interpretation;
+ -- Output error message when no valid interpretation exists
---------------------------
-- Name_Denotes_Function --
end if;
end Name_Denotes_Function;
+ -----------------------
+ -- No_Interpretation --
+ -----------------------
+
+ procedure No_Interpretation is
+ L : constant Boolean := Is_List_Member (N);
+ K : constant Node_Kind := Nkind (Parent (N));
+
+ begin
+ -- If the node is in a list whose parent is not an expression then it
+ -- must be an attempted procedure call.
+
+ if L and then K not in N_Subexpr then
+ if Ekind (Entity (Nam)) = E_Generic_Procedure then
+ Error_Msg_NE
+ ("must instantiate generic procedure& before call",
+ Nam, Entity (Nam));
+ else
+ Error_Msg_N
+ ("procedure or entry name expected", Nam);
+ end if;
+
+ -- Check for tasking cases where only an entry call will do
+
+ elsif not L
+ and then Nkind_In (K, N_Entry_Call_Alternative,
+ N_Triggering_Alternative)
+ then
+ Error_Msg_N ("entry name expected", Nam);
+
+ -- Otherwise give general error message
+
+ else
+ Error_Msg_N ("invalid prefix in call", Nam);
+ end if;
+ end No_Interpretation;
+
-- Start of processing for Analyze_Call
begin
Set_Etype (N, Any_Type);
+ Nam := Name (N);
+
if not Is_Overloaded (Nam) then
-- Only one interpretation to check
-- name, or if it is a function name in the context of a procedure
-- call. In this latter case, we have a call to a parameterless
-- function that returns a pointer_to_procedure which is the entity
- -- being called.
+ -- being called. Finally, F (X) may be a call to a parameterless
+ -- function that returns a pointer to a function with parameters.
elsif Is_Access_Type (Etype (Nam))
and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
and then
(not Name_Denotes_Function
- or else Nkind (N) = N_Procedure_Call_Statement)
+ or else Nkind (N) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) /= N_Explicit_Dereference
+ and then Is_Entity_Name (Nam)
+ and then No (First_Formal (Entity (Nam)))
+ and then Present (Actuals)))
then
Nam_Ent := Designated_Type (Etype (Nam));
Insert_Explicit_Dereference (Nam);
-- If no interpretations, give error message
if not Is_Overloadable (Nam_Ent) then
- declare
- L : constant Boolean := Is_List_Member (N);
- K : constant Node_Kind := Nkind (Parent (N));
-
- begin
- -- If the node is in a list whose parent is not an
- -- expression then it must be an attempted procedure call.
-
- if L and then K not in N_Subexpr then
- if Ekind (Entity (Nam)) = E_Generic_Procedure then
- Error_Msg_NE
- ("must instantiate generic procedure& before call",
- Nam, Entity (Nam));
- else
- Error_Msg_N
- ("procedure or entry name expected", Nam);
- end if;
-
- -- Check for tasking cases where only an entry call will do
-
- elsif not L
- and then Nkind_In (K, N_Entry_Call_Alternative,
- N_Triggering_Alternative)
- then
- Error_Msg_N ("entry name expected", Nam);
-
- -- Otherwise give general error message
+ No_Interpretation;
+ return;
+ end if;
+ end if;
- else
- Error_Msg_N ("invalid prefix in call", Nam);
- end if;
+ -- Operations generated for RACW stub types are called only through
+ -- dispatching, and can never be the static interpretation of a call.
- return;
- end;
- end if;
+ if Is_RACW_Stub_Type_Operation (Nam_Ent) then
+ No_Interpretation;
+ return;
end if;
Analyze_One_Call (N, Nam_Ent, True, Success);
end if;
else
- -- An overloaded selected component must denote overloaded
- -- operations of a concurrent type. The interpretations are
- -- attached to the simple name of those operations.
+ -- An overloaded selected component must denote overloaded operations
+ -- of a concurrent type. The interpretations are attached to the
+ -- simple name of those operations.
if Nkind (Nam) = N_Selected_Component then
Nam := Selector_Name (Nam);
while Present (It.Nam) loop
Nam_Ent := It.Nam;
+ Deref := False;
-- Name may be call that returns an access to subprogram, or more
-- generally an overloaded expression one of whose interpretations
Nam_Ent := Designated_Type (Nam_Ent);
elsif Is_Access_Type (Etype (Nam_Ent))
- and then not Is_Entity_Name (Nam)
+ and then
+ (not Is_Entity_Name (Nam)
+ or else Nkind (N) = N_Procedure_Call_Statement)
and then Ekind (Designated_Type (Etype (Nam_Ent)))
= E_Subprogram_Type
then
Nam_Ent := Designated_Type (Etype (Nam_Ent));
+
+ if Is_Entity_Name (Nam) then
+ Deref := True;
+ end if;
end if;
Analyze_One_Call (N, Nam_Ent, False, Success);
-- guation is done directly in Resolve.
if Success then
- Set_Etype (Nam, It.Typ);
+ if Deref
+ and then Nkind (Parent (N)) /= N_Explicit_Dereference
+ then
+ Set_Entity (Nam, It.Nam);
+ Insert_Explicit_Dereference (Nam);
+ Set_Etype (Nam, Nam_Ent);
+
+ else
+ Set_Etype (Nam, It.Typ);
+ end if;
elsif Nkind_In (Name (N), N_Selected_Component,
N_Function_Call)
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
+
begin
+ if Comes_From_Source (N) then
+ Check_Compiler_Unit (N);
+ end if;
+
Analyze_Expression (Condition);
Analyze_Expression (Then_Expr);
- Analyze_Expression (Else_Expr);
- Set_Etype (N, Etype (Then_Expr));
+
+ if Present (Else_Expr) then
+ Analyze_Expression (Else_Expr);
+ end if;
+
+ if not Is_Overloaded (Then_Expr) then
+ Set_Etype (N, Etype (Then_Expr));
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (Then_Expr, I, It);
+ 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;
+ end if;
end Analyze_Conditional_Expression;
-------------------------
if not Is_Overloaded (P) then
if Is_Access_Type (Etype (P)) then
- -- Set the Etype. We need to go thru Is_For_Access_Subtypes to
+ -- Set the Etype. We need to go through Is_For_Access_Subtypes to
-- avoid other problems caused by the Private_Subtype and it is
-- safe to go to the Base_Type because this is the same as
-- converting the access value to its Base_Type.
and then Is_Overloaded (N)
then
-- The prefix may include access to subprograms and other access
- -- types. If the context selects the interpretation that is a call,
- -- we cannot rewrite the node yet, but we include the result of
- -- the call interpretation.
+ -- types. If the context selects the interpretation that is a
+ -- function call (not a procedure call) we cannot rewrite the node
+ -- yet, but we include the result of the call interpretation.
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
+ and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
then
Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
end if;
Set_Etype (L, T_F);
end if;
-
end Try_One_Interp;
+ procedure Analyze_Set_Membership;
+ -- If a set of alternatives is present, analyze each and find the
+ -- common type to which they must all resolve.
+
+ ----------------------------
+ -- Analyze_Set_Membership --
+ ----------------------------
+
+ procedure Analyze_Set_Membership is
+ Alt : Node_Id;
+ Index : Interp_Index;
+ It : Interp;
+ Candidate_Interps : Node_Id;
+ Common_Type : Entity_Id := Empty;
+
+ begin
+ Analyze (L);
+ Candidate_Interps := L;
+
+ if not Is_Overloaded (L) then
+ Common_Type := Etype (L);
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Analyze (Alt);
+
+ if not Has_Compatible_Type (Alt, Common_Type) then
+ Wrong_Type (Alt, Common_Type);
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ else
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ Analyze (Alt);
+ if not Is_Overloaded (Alt) then
+ Common_Type := Etype (Alt);
+
+ else
+ Get_First_Interp (Alt, Index, It);
+ while Present (It.Typ) loop
+ if not
+ Has_Compatible_Type (Candidate_Interps, It.Typ)
+ then
+ Remove_Interp (Index);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ Get_First_Interp (Alt, Index, It);
+
+ if No (It.Typ) then
+ Error_Msg_N ("alternative has no legal type", Alt);
+ return;
+ end if;
+
+ -- If alternative is not overloaded, we have a unique type
+ -- for all of them.
+
+ Set_Etype (Alt, It.Typ);
+ Get_Next_Interp (Index, It);
+
+ if No (It.Typ) then
+ Set_Is_Overloaded (Alt, False);
+ Common_Type := Etype (Alt);
+ end if;
+
+ Candidate_Interps := Alt;
+ end if;
+
+ Next (Alt);
+ end loop;
+ end if;
+
+ Set_Etype (N, Standard_Boolean);
+
+ if Present (Common_Type) then
+ Set_Etype (L, Common_Type);
+ Set_Is_Overloaded (L, False);
+
+ else
+ Error_Msg_N ("cannot resolve membership operation", N);
+ end if;
+ end Analyze_Set_Membership;
+
-- Start of processing for Analyze_Membership_Op
begin
Analyze_Expression (L);
+ if No (R)
+ and then Extensions_Allowed
+ then
+ Analyze_Set_Membership;
+ return;
+ end if;
+
if Nkind (R) = N_Range
or else (Nkind (R) = N_Attribute_Reference
and then Attribute_Name (R) = Name_Range)
Set_Etype (N, Standard_Boolean);
if Comes_From_Source (N)
+ and then Present (Right_Opnd (N))
and then Is_CPP_Class (Etype (Etype (Right_Opnd (N))))
then
Error_Msg_N ("membership test not applicable to cpp-class types", N);
-- is already known to be compatible, and because this may be an
-- indexing of a call with default parameters.
- Formal : Entity_Id;
- Actual : Node_Id;
- Is_Indexed : Boolean := False;
- Subp_Type : constant Entity_Id := Etype (Nam);
- Norm_OK : Boolean;
+ Formal : Entity_Id;
+ Actual : Node_Id;
+ Is_Indexed : Boolean := False;
+ Is_Indirect : Boolean := False;
+ Subp_Type : constant Entity_Id := Etype (Nam);
+ Norm_OK : Boolean;
function Operator_Hidden_By (Fun : Entity_Id) return Boolean;
-- There may be a user-defined operator that hides the current
-- in prefix notation, so that the rebuilt parameter list has more than
-- one actual.
- if Present (Actuals)
+ if not Is_Overloadable (Nam)
+ and then Ekind (Nam) /= E_Subprogram_Type
+ and then Ekind (Nam) /= E_Entry_Family
+ then
+ return;
+ end if;
+
+ -- An indexing requires at least one actual
+
+ if not Is_Empty_List (Actuals)
and then
(Needs_No_Actuals (Nam)
or else
(N, Nam, Designated_Type (Subp_Type), Must_Skip);
-- The prefix can also be a parameterless function that returns an
- -- access to subprogram. in which case this is an indirect call.
+ -- access to subprogram, in which case this is an indirect call.
+ -- If this succeeds, an explicit dereference is added later on,
+ -- in Analyze_Call or Resolve_Call.
elsif Is_Access_Type (Subp_Type)
and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
then
- Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
+ Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type);
end if;
end if;
- Normalize_Actuals (N, Nam, (Report and not Is_Indexed), Norm_OK);
+ -- If the call has been transformed into a slice, it is of the form
+ -- F (Subtype) where F is parameterless. The node has been rewritten in
+ -- Try_Indexed_Call and there is nothing else to do.
+
+ if Is_Indexed
+ and then Nkind (N) = N_Slice
+ then
+ return;
+ end if;
+
+ Normalize_Actuals
+ (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK);
if not Norm_OK then
+ -- If an indirect call is a possible interpretation, indicate
+ -- success to the caller.
+
+ if Is_Indirect then
+ Success := True;
+ return;
+
-- Mismatch in number or names of parameters
- if Debug_Flag_E then
+ elsif Debug_Flag_E then
Write_Str (" normalization fails in call ");
Write_Int (Int (N));
Write_Str (" with subprogram ");
Write_Eol;
end if;
- if Report and not Is_Indexed then
+ if Report and not Is_Indexed and not Is_Indirect then
-- Ada 2005 (AI-251): Complete the error notification
- -- to help new Ada 2005 users
+ -- to help new Ada 2005 users.
if Is_Class_Wide_Type (Etype (Formal))
and then Is_Interface (Etype (Etype (Formal)))
Formal := First_Formal (Nam);
while Present (Formal) loop
if Chars (Left_Opnd (Actual)) = Chars (Formal) then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("possible misspelling of `='>`!", Actual);
exit;
end if;
if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp)
then
- Set_Entity (Sel, Comp);
- Set_Etype (Sel, Etype (Comp));
- Add_One_Interp (N, Etype (Comp), Etype (Comp));
- -- This also specifies a candidate to resolve the name.
- -- Further overloading will be resolved from context.
+ -- AI05-105: if the context is an object renaming with
+ -- an anonymous access type, the expected type of the
+ -- object must be anonymous. This is a name resolution rule.
- Set_Etype (Nam, It.Typ);
+ if Nkind (Parent (N)) /= N_Object_Renaming_Declaration
+ or else No (Access_Definition (Parent (N)))
+ or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type
+ or else
+ Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type
+ then
+ Set_Entity (Sel, Comp);
+ Set_Etype (Sel, Etype (Comp));
+ Add_One_Interp (N, Etype (Comp), Etype (Comp));
+
+ -- This also specifies a candidate to resolve the name.
+ -- Further overloading will be resolved from context.
+ -- The selector name itself does not carry overloading
+ -- information.
+
+ Set_Etype (Nam, It.Typ);
+
+ else
+ -- Named access type in the context of a renaming
+ -- declaration with an access definition. Remove
+ -- inapplicable candidate.
+
+ Remove_Interp (I);
+ end if;
end if;
Next_Entity (Comp);
Set_Etype (N, Etype (Comp));
Set_Etype (Nam, It.Typ);
- -- For access type case, introduce explicit deference for
- -- more uniform treatment of entry calls. Do this only
- -- once if several interpretations yield an access type.
+ -- For access type case, introduce explicit dereference for
+ -- more uniform treatment of entry calls. Do this only once
+ -- if several interpretations yield an access type.
if Is_Access_Type (Etype (Nam))
and then Nkind (Nam) /= N_Explicit_Dereference
-- If the prefix is a private extension, check only the visible
-- components of the partial view. This must include the tag,
- -- wich can appear in expanded code in a tag check.
+ -- 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
Set_Original_Discriminant (Sel, Comp);
end if;
- -- Before declararing an error, check whether this is tagged
+ -- Before declaring an error, check whether this is tagged
-- private type and a call to a primitive operation.
elsif Ada_Version >= Ada_05
Set_Original_Discriminant (Sel, Comp);
end if;
- -- For access type case, introduce explicit deference for more
- -- uniform treatment of entry calls.
+ -- For access type case, introduce explicit dereference for
+ -- more uniform treatment of entry calls.
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
Error_Msg_NE ("no selector& for}", N, Sel);
Check_Misspelled_Selector (Type_To_Use, Sel);
-
end if;
Set_Entity (Sel, Any_Id);
T : Entity_Id;
begin
+ -- Check if the expression is a function call for which we need to
+ -- adjust a SCIL dispatching node.
+
+ if Generate_SCIL
+ and then Nkind (Expr) = N_Function_Call
+ then
+ Adjust_SCIL_Node (N, Expr);
+ end if;
+
-- If Conversion_OK is set, then the Etype is already set, and the
-- only processing required is to analyze the expression. This is
-- used to construct certain "illegal" conversions which are not
then
Add_One_Interp (N, Op_Id, Etype (Op_Id));
+ -- If the left operand is overloaded, indicate that the
+ -- current type is a viable candidate. This is redundant
+ -- in most cases, but for equality and comparison operators
+ -- where the context does not impose a type on the operands,
+ -- setting the proper type is necessary to avoid subsequent
+ -- ambiguities during resolution, when both user-defined and
+ -- predefined operators may be candidates.
+
+ if Is_Overloaded (Left_Opnd (N)) then
+ Set_Etype (Left_Opnd (N), Etype (F1));
+ end if;
+
if Debug_Flag_E then
Write_Str ("user defined operator ");
Write_Name (Chars (Op_Id));
-- Report at most two suggestions
if Nr_Of_Suggestions = 1 then
- Error_Msg_NE
+ Error_Msg_NE -- CODEFIX
("\possible misspelling of&", Sel, Suggestion_1);
elsif Nr_Of_Suggestions = 2 then
Error_Msg_Node_2 := Suggestion_2;
- Error_Msg_NE
+ Error_Msg_NE -- CODEFIX
("\possible misspelling of& or&", Sel, Suggestion_1);
end if;
end Check_Misspelled_Selector;
if Nkind (Parent (N)) = N_Selected_Component
and then N = Prefix (Parent (N))
then
- Error_Msg_N (
- "\period should probably be semicolon", Parent (N));
+ Error_Msg_N -- CODEFIX
+ ("\period should probably be semicolon", Parent (N));
end if;
elsif Nkind (N) = N_Procedure_Call_Statement
end if;
end Check_Right_Argument;
- -- Start processing for Find_Arithmetic_Types
+ -- Start of processing for Find_Arithmetic_Types
begin
if not Is_Overloaded (L) then
end if;
end Try_One_Interp;
- -- Start processing for Find_Comparison_Types
+ -- Start of processing for Find_Comparison_Types
begin
-- If left operand is aggregate, the right operand has to
Scop : Entity_Id := Empty;
procedure Try_One_Interp (T1 : Entity_Id);
- -- The context of the operator plays no role in resolving the
- -- arguments, so that if there is more than one interpretation
- -- of the operands that is compatible with equality, the construct
- -- is ambiguous and an error can be emitted now, after trying to
- -- disambiguate, i.e. applying preference rules.
+ -- The context of the equality operator plays no role in resolving the
+ -- arguments, so that if there is more than one interpretation of the
+ -- operands that is compatible with equality, the construct is ambiguous
+ -- and an error can be emitted now, after trying to disambiguate, i.e.
+ -- applying preference rules.
--------------------
-- Try_One_Interp --
--------------------
procedure Try_One_Interp (T1 : Entity_Id) is
+ Bas : constant Entity_Id := Base_Type (T1);
+
begin
-- If the operator is an expanded name, then the type of the operand
-- must be defined in the corresponding scope. If the type is
or else T1 = Any_String
or else T1 = Any_Composite
or else (Ekind (T1) = E_Access_Subprogram_Type
- and then not Comes_From_Source (T1))
+ and then not Comes_From_Source (T1))
then
null;
return;
end if;
+
+ -- If we have infix notation, the operator must be usable.
+ -- Within an instance, if the type is already established we
+ -- know it is correct.
+ -- In Ada 2005, the equality on anonymous access types is declared
+ -- in Standard, and is always visible.
+
+ elsif In_Open_Scopes (Scope (Bas))
+ or else Is_Potentially_Use_Visible (Bas)
+ or else In_Use (Bas)
+ or else (In_Use (Scope (Bas))
+ and then not Is_Hidden (Bas))
+ or else (In_Instance
+ and then First_Subtype (T1) = First_Subtype (Etype (R)))
+ or else Ekind (T1) = E_Anonymous_Access_Type
+ then
+ null;
+
+ else
+ -- Save candidate type for subsquent error message, if any
+
+ if not Is_Limited_Type (T1) then
+ Candidate_Type := T1;
+ end if;
+
+ return;
end if;
-- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
and then Valid_Boolean_Arg (Etype (R))
then
Error_Msg_N ("invalid operands for concatenation", N);
- Error_Msg_N ("\maybe AND was meant", N);
+ Error_Msg_N -- CODEFIX
+ ("\maybe AND was meant", N);
return;
-- A special case for comparison of access parameter with null
Error_Msg_N ("access parameter is not allowed to be null", L);
Error_Msg_N ("\(call would raise Constraint_Error)", L);
return;
+
+ -- Another special case for exponentiation, where the right
+ -- operand must be Natural, independently of the base.
+
+ elsif Nkind (N) = N_Op_Expon
+ and then Is_Numeric_Type (Etype (L))
+ and then not Is_Overloaded (R)
+ and then
+ First_Subtype (Base_Type (Etype (R))) /= Standard_Integer
+ and then Base_Type (Etype (R)) /= Universal_Integer
+ then
+ Error_Msg_NE
+ ("exponent must be of type Natural, found}", R, Etype (R));
+ return;
end if;
-- If we fall through then just give general message. Note that in
-- is never appropriate, even when Address is defined as a visible
-- Integer type. The reason is that we would really prefer Address
-- to behave as a private type, even in this case, which is there
- -- only to accomodate oddities of VMS address sizes. If Address is
- -- a visible integer type, we get lots of overload ambiguities.
+ -- only to accommodate oddities of VMS address sizes. If Address
+ -- is a visible integer type, we get lots of overload ambiguities.
if Nkind (N) in N_Binary_Op then
declare
Typ : Entity_Id;
Skip_First : Boolean) return Boolean
is
- Actuals : constant List_Id := Parameter_Associations (N);
- Actual : Node_Id;
- Index : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+ Index : Entity_Id;
begin
Actual := First (Actuals);
return False;
end if;
- if not Has_Compatible_Type (Actual, Etype (Index)) then
+ if Is_Entity_Name (Actual)
+ and then Is_Type (Entity (Actual))
+ and then No (Next (Actual))
+ then
+ Rewrite (N,
+ Make_Slice (Loc,
+ Prefix => Make_Function_Call (Loc,
+ Name => Relocate_Node (Name (N))),
+ Discrete_Range =>
+ New_Occurrence_Of (Entity (Actual), Sloc (Actual))));
+
+ Analyze (N);
+ return True;
+
+ elsif not Has_Compatible_Type (Actual, Etype (Index)) then
return False;
end if;
Call : Node_Id;
Subp : Entity_Id) return Entity_Id
is
+ Arr_Type : Entity_Id;
Comp_Type : Entity_Id;
begin
-- If the call may be an indexed call, retrieve component type of
-- resulting expression, and add possible interpretation.
+ Arr_Type := Empty;
Comp_Type := Empty;
if Nkind (Call) = N_Function_Call
and then Needs_One_Actual (Subp)
then
if Is_Array_Type (Etype (Subp)) then
- Comp_Type := Component_Type (Etype (Subp));
+ Arr_Type := Etype (Subp);
elsif Is_Access_Type (Etype (Subp))
and then Is_Array_Type (Designated_Type (Etype (Subp)))
then
- Comp_Type := Component_Type (Designated_Type (Etype (Subp)));
+ Arr_Type := Designated_Type (Etype (Subp));
end if;
end if;
- if Present (Comp_Type)
- and then Etype (Subprog) /= Comp_Type
- then
- Add_One_Interp (Subprog, Subp, Comp_Type);
+ if Present (Arr_Type) then
+
+ -- Verify that the actuals (excluding the object)
+ -- match the types of the indices.
+
+ declare
+ Actual : Node_Id;
+ Index : Node_Id;
+
+ begin
+ Actual := Next (First_Actual (Call));
+ Index := First_Index (Arr_Type);
+ while Present (Actual) and then Present (Index) loop
+ if not Has_Compatible_Type (Actual, Etype (Index)) then
+ Arr_Type := Empty;
+ exit;
+ end if;
+
+ Next_Actual (Actual);
+ Next_Index (Index);
+ end loop;
+
+ if No (Actual)
+ and then No (Index)
+ and then Present (Arr_Type)
+ then
+ Comp_Type := Component_Type (Arr_Type);
+ end if;
+ end;
+
+ if Present (Comp_Type)
+ and then Etype (Subprog) /= Comp_Type
+ then
+ Add_One_Interp (Subprog, Subp, Comp_Type);
+ end if;
end if;
if Etype (Call) /= Any_Type then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N ("\possible interpretation (inherited)#", N);
else
- Error_Msg_N ("\possible interpretation#", N);
+ Error_Msg_N -- CODEFIX
+ ("\possible interpretation#", N);
end if;
end if;
end Report_Ambiguity;
-- subprogram because that list starts with the subprogram formals.
-- We retrieve the candidate operations from the generic declaration.
+ function Is_Private_Overriding (Op : Entity_Id) return Boolean;
+ -- An operation that overrides an inherited operation in the private
+ -- part of its package may be hidden, but if the inherited operation
+ -- is visible a direct call to it will dispatch to the private one,
+ -- which is therefore a valid candidate.
+
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals
end if;
end Collect_Generic_Type_Ops;
+ ---------------------------
+ -- Is_Private_Overriding --
+ ---------------------------
+
+ function Is_Private_Overriding (Op : Entity_Id) return Boolean is
+ Visible_Op : constant Entity_Id := Homonym (Op);
+
+ begin
+ return Present (Visible_Op)
+ and then not Comes_From_Source (Visible_Op)
+ and then Alias (Visible_Op) = Op
+ and then not Is_Hidden (Visible_Op);
+ end Is_Private_Overriding;
+
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Etype (First_Formal (Op));
+ Typ : Entity_Id := Etype (First_Formal (Op));
begin
+ if Is_Concurrent_Type (Typ)
+ and then Present (Corresponding_Record_Type (Typ))
+ then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
-- Simple case. Object may be a subtype of the tagged type or
-- may be the corresponding record of a synchronized type.
-- corresponding record (base) type.
if Is_Concurrent_Type (Obj_Type) then
+ if not Present (Corresponding_Record_Type (Obj_Type)) then
+ return False;
+ end if;
+
Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
Elmt := First_Elmt (Primitive_Operations (Corr_Type));
-- primitive is also in this list of primitive operations and
-- will be used instead.
- if (Present (Abstract_Interface_Alias (Prim_Op))
- and then Is_Ancestor (Find_Dispatching_Type
- (Alias (Prim_Op)), Corr_Type))
- or else
+ if (Present (Interface_Alias (Prim_Op))
+ and then Is_Ancestor (Find_Dispatching_Type
+ (Alias (Prim_Op)), Corr_Type))
- -- Do not consider hidden primitives unless the type is in an
- -- open scope or we are within an instance, where visibility
- -- is known to be correct.
+ -- Do not consider hidden primitives unless the type is in an
+ -- open scope or we are within an instance, where visibility
+ -- is known to be correct, or else if this is an overriding
+ -- operation in the private part for an inherited operation.
- (Is_Hidden (Prim_Op)
- and then not Is_Immediately_Visible (Obj_Type)
- and then not In_Instance)
+ or else (Is_Hidden (Prim_Op)
+ and then not Is_Immediately_Visible (Obj_Type)
+ and then not In_Instance
+ and then not Is_Private_Overriding (Prim_Op))
then
goto Continue;
end if;
OSDN Git Service
