-- a valid pair for the given operator, and record the corresponding
-- interpretation of the operator node. The node N may be an operator
-- node (the usual case) or a function call whose prefix is an operator
- -- designator. In both cases Op_Id is the operator name itself.
+ -- designator. In both cases Op_Id is the operator name itself.
procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
-- Give detailed information on overloaded call where none of the
Set_Name (N, P);
Set_Parameter_Associations (N, Exprs);
- -- Analyze actuals prior to analyzing the call itself.
+ -- Analyze actuals prior to analyzing the call itself
Actual := First (Parameter_Associations (N));
while Present (Actual) loop
-- access to subprogram. in which case this is an indirect call.
elsif Is_Access_Type (Subp_Type)
- and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
+ and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
then
Is_Indexed := Try_Indirect_Call (N, Nam, Subp_Type);
end if;
and then not Comes_From_Source (Nam)
then
Error_Msg_NE
- (" =='> in call to &#(inherited)!", Actual, Nam);
+ ("\\ =='> in call to inherited operation & #!",
+ Actual, Nam);
elsif Ekind (Nam) = E_Subprogram_Type then
declare
(Associated_Node_For_Itype (Nam));
begin
Error_Msg_NE (
- " =='> in call to dereference of &#!",
+ "\\ =='> in call to dereference of &#!",
Actual, Access_To_Subprogram_Typ);
end;
else
- Error_Msg_NE (" =='> in call to &#!", Actual, Nam);
+ Error_Msg_NE
+ ("\\ =='> in call to &#!", Actual, Nam);
end if;
end if;
Name : constant Node_Id := Prefix (N);
Sel : constant Node_Id := Selector_Name (N);
Comp : Entity_Id;
- Entity_List : Entity_Id;
Prefix_Type : Entity_Id;
+
+ Type_To_Use : Entity_Id;
+ -- In most cases this is the Prefix_Type, but if the Prefix_Type is
+ -- a class-wide type, we use its root type, whose components are
+ -- present in the class-wide type.
+
Pent : Entity_Id := Empty;
Act_Decl : Node_Id;
In_Scope : Boolean;
-- in what follows, either to retrieve a component of to find
-- a primitive operation. If the prefix is an explicit dereference,
-- set the type of the prefix to reflect this transformation.
+ -- If the non-limited view is itself an incomplete type, get the
+ -- full view if available.
if Is_Incomplete_Type (Prefix_Type)
and then From_With_Type (Prefix_Type)
and then Present (Non_Limited_View (Prefix_Type))
then
- Prefix_Type := Non_Limited_View (Prefix_Type);
+ Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type));
if Nkind (N) = N_Explicit_Dereference then
Set_Etype (Prefix (N), Prefix_Type);
Prefix_Type := Base_Type (Prefix_Type);
end if;
- Entity_List := Prefix_Type;
+ Type_To_Use := Prefix_Type;
-- For class-wide types, use the entity list of the root type. This
-- indirection is specially important for private extensions because
-- only the root type get switched (not the class-wide type).
if Is_Class_Wide_Type (Prefix_Type) then
- Entity_List := Root_Type (Prefix_Type);
+ Type_To_Use := Root_Type (Prefix_Type);
end if;
- Comp := First_Entity (Entity_List);
+ Comp := First_Entity (Type_To_Use);
-- If the selector has an original discriminant, the node appears in
-- an instance. Replace the discriminant with the corresponding one
-- If the prefix is a private extension, check only the visible
-- components of the partial view.
- if Ekind (Prefix_Type) = E_Record_Type_With_Private then
- exit when Comp = Last_Entity (Prefix_Type);
+ if Ekind (Type_To_Use) = E_Record_Type_With_Private then
+ exit when Comp = Last_Entity (Type_To_Use);
end if;
Next_Entity (Comp);
-- do the same here.
if No (Full_View (Prefix_Type)) then
- Entity_List := Root_Type (Base_Type (Prefix_Type));
- Comp := First_Entity (Entity_List);
+ Type_To_Use := Root_Type (Base_Type (Prefix_Type));
+ Comp := First_Entity (Type_To_Use);
end if;
while Present (Comp) loop
Error_Msg_Node_2 := Entity (Name);
Error_Msg_NE ("no selector& for&", N, Sel);
- Check_Misspelled_Selector (Entity_List, Sel);
+ Check_Misspelled_Selector (Type_To_Use, Sel);
elsif Is_Generic_Type (Prefix_Type)
and then Ekind (Prefix_Type) = E_Record_Type_With_Private
Error_Msg_Node_2 := First_Subtype (Prefix_Type);
Error_Msg_NE ("no selector& for}", N, Sel);
- Check_Misspelled_Selector (Entity_List, Sel);
+ Check_Misspelled_Selector (Type_To_Use, Sel);
end if;
Op_Id : Entity_Id;
N : Node_Id)
is
- Op_Name : constant Name_Id := Chars (Op_Id);
+ Op_Name : constant Name_Id := Chars (Op_Id);
function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean;
-- Check whether the fixed-point type Typ has a user-defined operator
------------------
function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is
+ Bas : constant Entity_Id := Base_Type (Typ);
Ent : Entity_Id;
F1 : Entity_Id;
F2 : Entity_Id;
F2 := Next_Formal (F1);
-- The operation counts as primitive if either operand or
- -- result are of the given type, and both operands are fixed
- -- point types.
+ -- result are of the given base type, and both operands are
+ -- fixed point types.
- if (Etype (F1) = Typ
+ if (Base_Type (Etype (F1)) = Bas
and then Is_Fixed_Point_Type (Etype (F2)))
or else
- (Etype (F2) = Typ
+ (Base_Type (Etype (F2)) = Bas
and then Is_Fixed_Point_Type (Etype (F1)))
or else
- (Etype (Ent) = Typ
+ (Base_Type (Etype (Ent)) = Bas
and then Is_Fixed_Point_Type (Etype (F1))
and then Is_Fixed_Point_Type (Etype (F2)))
then
if (Nkind (N) not in N_Op
or else not Treat_Fixed_As_Integer (N))
and then
- (not (Ada_Version >= Ada_05 and then Has_Fixed_Op (T1, Op_Id))
+ (not Has_Fixed_Op (T1, Op_Id)
or else Nkind (Parent (N)) = N_Type_Conversion)
then
Add_One_Interp (N, Op_Id, Universal_Fixed);
or else not Treat_Fixed_As_Integer (N))
and then T1 = Universal_Real
and then
- (not (Ada_Version >= Ada_05 and then Has_Fixed_Op (T1, Op_Id))
+ (not Has_Fixed_Op (T1, Op_Id)
or else Nkind (Parent (N)) = N_Type_Conversion)
then
Add_One_Interp (N, Op_Id, Universal_Fixed);
--------------------------------
procedure Remove_Abstract_Operations (N : Node_Id) is
- I : Interp_Index;
- It : Interp;
- Abstract_Op : Entity_Id := Empty;
+ Abstract_Op : Entity_Id := Empty;
+ Address_Kludge : Boolean := False;
+ I : Interp_Index;
+ It : Interp;
-- AI-310: If overloaded, remove abstract non-dispatching operations. We
-- activate this if either extensions are enabled, or if the abstract
end if;
if Is_Descendent_Of_Address (Etype (Formal)) then
+ Address_Kludge := True;
Remove_Interp (I);
end if;
then
Abstract_Op := It.Nam;
+ if Is_Descendent_Of_Address (It.Typ) then
+ Address_Kludge := True;
+ Remove_Interp (I);
+ exit;
+
-- In Ada 2005, this operation does not participate in Overload
-- resolution. If the operation is defined in in a predefined
-- unit, it is one of the operations declared abstract in some
-- variants of System, and it must be removed as well.
- if Ada_Version >= Ada_05
- or else Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (It.Nam)))
- or else Is_Descendent_Of_Address (It.Typ)
+ elsif Ada_Version >= Ada_05
+ or else Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (It.Nam)))
then
Remove_Interp (I);
exit;
-- on systems where Address is a visible integer type.
if Is_Overloaded (N)
- and then Nkind (N) in N_Op
+ and then Nkind (N) in N_Op
and then Is_Integer_Type (Etype (N))
then
if Nkind (N) in N_Binary_Op then
end;
end if;
- -- If the removal has left no valid interpretations, emit
- -- error message now and label node as illegal.
+ -- If the removal has left no valid interpretations, emit an error
+ -- message now and label node as illegal.
if Present (Abstract_Op) then
Get_First_Interp (N, I, It);
Error_Msg_Sloc := Sloc (Abstract_Op);
Error_Msg_NE
("cannot call abstract operation& declared#", N, Abstract_Op);
+
+ -- In Ada 2005, an abstract operation may disable predefined
+ -- operators. Since the context is not yet known, we mark the
+ -- predefined operators as potentially hidden. Do not include
+ -- predefined operators when addresses are involved since this
+ -- case is handled separately.
+
+ elsif Ada_Version >= Ada_05
+ and then not Address_Kludge
+ then
+ while Present (It.Nam) loop
+ if Is_Numeric_Type (It.Typ)
+ and then Scope (It.Typ) = Standard_Standard
+ then
+ Set_Abstract_Op (I, Abstract_Op);
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
end if;
end if;
end if;
Subprog : constant Node_Id :=
Make_Identifier (Sloc (Selector_Name (N)),
Chars => Chars (Selector_Name (N)));
- -- Identifier on which possible interpretations will be collected.
+ -- Identifier on which possible interpretations will be collected
Success : Boolean := False;
Make_Explicit_Dereference (Sloc (Obj), Obj));
Analyze (First_Actual);
+ -- If we need to introduce an explicit dereference, verify that
+ -- the resulting actual is compatible with the mode of the formal.
+
+ if Ekind (First_Formal (Entity (Subprog))) /= E_In_Parameter
+ and then Is_Access_Constant (Etype (Obj))
+ then
+ Error_Msg_NE
+ ("expect variable in call to&", Prefix (N), Entity (Subprog));
+ end if;
+
-- Conversely, if the formal is an access parameter and the
-- object is not, replace the actual with a 'Access reference.
-- Its analysis will check that the object is aliased.
if not Is_Aliased_View (Obj) then
Error_Msg_NE
("object in prefixed call to& must be aliased"
- & " ('R'M'-2005 4.3.1 (13))",
+ & " (RM-2005 4.3.1 (13))",
Prefix (First_Actual), Subprog);
end if;
Cls_Type := Class_Wide_Type (Anc_Type);
Hom := Current_Entity (Subprog);
+
+ -- Find 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
and then Scope (Hom) = Scope (Anc_Type)
and then Present (First_Formal (Hom))
and then
- (Etype (First_Formal (Hom)) = Cls_Type
+ (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
or else
(Is_Access_Type (Etype (First_Formal (Hom)))
and then
Ekind (Etype (First_Formal (Hom))) =
E_Anonymous_Access_Type
and then
- Designated_Type (Etype (First_Formal (Hom))) =
+ Base_Type
+ (Designated_Type (Etype (First_Formal (Hom)))) =
Cls_Type))
then
Set_Etype (Call_Node, Any_Type);
-- The type may have be obtained through a limited_with clause,
-- in which case the primitive operations are available on its
- -- non-limited view.
+ -- non-limited view. If still incomplete, retrieve full view.
if Ekind (Obj_Type) = E_Incomplete_Type
and then From_With_Type (Obj_Type)
then
- Obj_Type := Non_Limited_View (Obj_Type);
+ Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type));
end if;
-- If the object is not tagged, or the type is still an incomplete
Success : Boolean := False;
+ function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id;
+ -- For tagged types the candidate interpretations are found in
+ -- the list of primitive operations of the type and its ancestors.
+ -- For formal tagged types we have to find the operations declared
+ -- in the same scope as the type (including in the generic formal
+ -- part) because the type itself carries no primitive operations,
+ -- except for formal derived types that inherit the operations of
+ -- the parent and progenitors.
+
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
-- are checked in the subsequent call to Analyze_One_Call.
+ ------------------------------
+ -- Collect_Generic_Type_Ops --
+ ------------------------------
+
+ function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id is
+ Bas : constant Entity_Id := Base_Type (T);
+ Candidates : constant Elist_Id := New_Elmt_List;
+ Subp : Entity_Id;
+ Formal : Entity_Id;
+
+ begin
+ if Is_Derived_Type (T) then
+ return Primitive_Operations (T);
+
+ else
+ -- Scan the list of entities declared in the same scope as
+ -- the type. In general this will be an open scope, given that
+ -- the call we are analyzing can only appear within a generic
+ -- declaration or body (either the one that declares T, or a
+ -- child unit).
+
+ Subp := First_Entity (Scope (T));
+ while Present (Subp) loop
+ if Is_Overloadable (Subp) then
+ Formal := First_Formal (Subp);
+
+ if Present (Formal)
+ and then Is_Controlling_Formal (Formal)
+ and then
+ (Base_Type (Etype (Formal)) = Bas
+ or else
+ (Is_Access_Type (Etype (Formal))
+ and then Designated_Type (Etype (Formal)) = Bas))
+ then
+ Append_Elmt (Subp, Candidates);
+ end if;
+ end if;
+
+ Next_Entity (Subp);
+ end loop;
+
+ return Candidates;
+ end if;
+ end Collect_Generic_Type_Ops;
+
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
if Is_Concurrent_Type (Obj_Type) then
Corr_Type := Corresponding_Record_Type (Obj_Type);
Elmt := First_Elmt (Primitive_Operations (Corr_Type));
- else
+
+ elsif not Is_Generic_Type (Obj_Type) then
Corr_Type := Obj_Type;
Elmt := First_Elmt (Primitive_Operations (Obj_Type));
+
+ else
+ Corr_Type := Obj_Type;
+ Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
end if;
while Present (Elmt) loop
OSDN Git Service
