-- a temporary. Then check the converted value against the range of the
-- target subtype.
- procedure Convert_And_Check_Range is
- -- To what does the following comment belong???
- -- We make a temporary to hold the value of the converted value
- -- (converted to the base type), and then we will do the test against
- -- this temporary.
- --
- -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
- -- [constraint_error when Tnn not in Target_Type]
- --
- -- The conversion itself is replaced by an occurrence of Tnn
+ -----------------------------
+ -- Convert_And_Check_Range --
+ -----------------------------
+ procedure Convert_And_Check_Range is
Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
- -- To what does the following comment belong???
- -- Follow the conversion with the explicit range check. Note that we
- -- suppress checks for this code, since we don't want a recursive
+ begin
+ -- We make a temporary to hold the value of the converted value
+ -- (converted to the base type), and then do the test against this
+ -- temporary. The conversion itself is replaced by an occurrence of
+ -- Tnn and followed by the explicit range check. Note that checks
+ -- are suppressed for this code, since we don't want a recursive
-- range check popping up.
- begin
+ -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
+ -- [constraint_error when Tnn not in Target_Type]
+
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Actual : Node_Id;
Analyzed_Formal : Node_Id) return Node_Id
is
- Loc : Source_Ptr;
- Formal_Sub : constant Entity_Id :=
- Defining_Unit_Name (Specification (Formal));
Analyzed_S : constant Entity_Id :=
Defining_Unit_Name (Specification (Analyzed_Formal));
- Decl_Node : Node_Id;
- Nam : Node_Id;
- New_Spec : Node_Id;
+ Formal_Sub : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Formal));
function From_Parent_Scope (Subp : Entity_Id) return Boolean;
-- If the generic is a child unit, the parent has been installed on the
("expect subprogram or entry name in instantiation of&",
Instantiation_Node, Formal_Sub);
Abandon_Instantiation (Instantiation_Node);
-
end Valid_Actual_Subprogram;
+ -- Local variables
+
+ Decl_Node : Node_Id;
+ Loc : Source_Ptr;
+ Nam : Node_Id;
+ New_Spec : Node_Id;
+
-- Start of processing for Instantiate_Formal_Subprogram
begin
Set_Defining_Unit_Name
(New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub)));
- -- Create new entities for the each of the formals in the
- -- specification of the renaming declaration built for the actual.
+ -- Create new entities for the each of the formals in the specification
+ -- of the renaming declaration built for the actual.
if Present (Parameter_Specifications (New_Spec)) then
declare
- F : Node_Id;
+ F : Node_Id;
+ F_Id : Entity_Id;
+
begin
F := First (Parameter_Specifications (New_Spec));
while Present (F) loop
+ F_Id := Defining_Identifier (F);
+
Set_Defining_Identifier (F,
- Make_Defining_Identifier (Sloc (F),
- Chars => Chars (Defining_Identifier (F))));
+ Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id)));
Next (F);
end loop;
end;
-- identifier or operator with the same name as the formal.
if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then
- Nam := Make_Operator_Symbol (Loc,
- Chars => Chars (Formal_Sub),
- Strval => No_String);
+ Nam :=
+ Make_Operator_Symbol (Loc,
+ Chars => Chars (Formal_Sub),
+ Strval => No_String);
else
Nam := Make_Identifier (Loc, Chars (Formal_Sub));
end if;
-- instance. If overloaded, it will be resolved when analyzing the
-- renaming declaration.
- if Box_Present (Formal)
- and then No (Actual)
- then
+ if Box_Present (Formal) and then No (Actual) then
Analyze (Nam);
if Is_Child_Unit (Scope (Analyzed_S))
-- Emit a continuation error message suggesting subprogram Subp_Id as
-- a possible interpretation.
+ function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp_Id denotes the intrinsic "="
+ -- operator.
+
+ function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp_Id is a suitable candidate for
+ -- the role of a wrapped subprogram.
+
----------------
-- Build_Call --
----------------
procedure Interpretation_Error (Subp_Id : Entity_Id) is
begin
Error_Msg_Sloc := Sloc (Subp_Id);
- Error_Msg_NE
- ("\\possible interpretation: & defined #", Spec, Formal_Spec);
+
+ if Is_Internal (Subp_Id) then
+ Error_Msg_NE
+ ("\\possible interpretation: predefined & #",
+ Spec, Formal_Spec);
+ else
+ Error_Msg_NE
+ ("\\possible interpretation: & defined #", Spec, Formal_Spec);
+ end if;
end Interpretation_Error;
+ ---------------------------
+ -- Is_Intrinsic_Equality --
+ ---------------------------
+
+ function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean is
+ begin
+ return
+ Ekind (Subp_Id) = E_Operator
+ and then Chars (Subp_Id) = Name_Op_Eq
+ and then Is_Intrinsic_Subprogram (Subp_Id);
+ end Is_Intrinsic_Equality;
+
+ ---------------------------
+ -- Is_Suitable_Candidate --
+ ---------------------------
+
+ function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean is
+ begin
+ if No (Subp_Id) then
+ return False;
+
+ -- An intrinsic subprogram is never a good candidate. This is an
+ -- indication of a missing primitive, either defined directly or
+ -- inherited from a parent tagged type.
+
+ elsif Is_Intrinsic_Subprogram (Subp_Id) then
+ return False;
+
+ else
+ return True;
+ end if;
+ end Is_Suitable_Candidate;
+
-- Local variables
Actual_Typ : Entity_Id := Empty;
-- The actual class-wide type for Formal_Typ
+ CW_Prim_OK : Boolean;
CW_Prim_Op : Entity_Id;
- -- The class-wide primitive (if any) which corresponds to the renamed
- -- generic formal subprogram.
+ -- The class-wide subprogram (if available) which corresponds to the
+ -- renamed generic formal subprogram.
Formal_Typ : Entity_Id := Empty;
- -- The generic formal type (if any) with unknown discriminants
+ -- The generic formal type with unknown discriminants
+ Root_Prim_OK : Boolean;
Root_Prim_Op : Entity_Id;
- -- The root type primitive (if any) which corresponds to the renamed
- -- generic formal subprogram.
+ -- The root type primitive (if available) which corresponds to the
+ -- renamed generic formal subprogram.
+
+ Root_Typ : Entity_Id := Empty;
+ -- The root type of Actual_Typ
Body_Decl : Node_Id;
Formal : Node_Id;
end if;
-- Analyze the renamed name, but do not resolve it. The resolution is
- -- completed once a suitable primitive is found.
+ -- completed once a suitable subprogram is found.
Analyze (Nam);
+ -- When the renamed name denotes the intrinsic operator equals, the
+ -- name must be treated as overloaded. This allows for a potential
+ -- match against the root type's predefined equality function.
+
+ if Is_Intrinsic_Equality (Entity (Nam)) then
+ Set_Is_Overloaded (Nam);
+ Collect_Interps (Nam);
+ end if;
+
-- Step 1: Find the generic formal type with unknown discriminants
-- and its corresponding class-wide actual type from the renamed
-- generic formal subprogram.
then
Formal_Typ := Etype (Formal);
Actual_Typ := Get_Instance_Of (Formal_Typ);
+ Root_Typ := Etype (Actual_Typ);
exit;
end if;
pragma Assert (Present (Formal_Typ));
- -- Step 2: Find the proper primitive which corresponds to the renamed
- -- generic formal subprogram.
+ -- Step 2: Find the proper class-wide subprogram or primitive which
+ -- corresponds to the renamed generic formal subprogram.
CW_Prim_Op := Find_Primitive (Actual_Typ);
- Root_Prim_Op := Find_Primitive (Etype (Actual_Typ));
+ CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op);
+ Root_Prim_Op := Find_Primitive (Root_Typ);
+ Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op);
- -- The class-wide actual type has two primitives which correspond to
+ -- The class-wide actual type has two subprograms which correspond to
-- the renamed generic formal subprogram:
-- with procedure Prim_Op (Param : Formal_Typ);
-- procedure Prim_Op (Param : Actual_Typ); -- may be inherited
-- procedure Prim_Op (Param : Actual_Typ'Class);
- -- Even though the declaration of the two primitives is legal, a call
- -- to either one is ambiguous and therefore illegal.
+ -- Even though the declaration of the two subprograms is legal, a
+ -- call to either one is ambiguous and therefore illegal.
- if Present (CW_Prim_Op) and then Present (Root_Prim_Op) then
+ if CW_Prim_OK and Root_Prim_OK then
- -- Deal with abstract primitives
+ -- A user-defined primitive has precedence over a predefined one
- if Is_Abstract_Subprogram (CW_Prim_Op)
- or else Is_Abstract_Subprogram (Root_Prim_Op)
+ if Is_Internal (CW_Prim_Op)
+ and then not Is_Internal (Root_Prim_Op)
then
- -- An abstract subprogram cannot act as a generic actual, but
- -- the partial parameterization of the instance may hide the
- -- true nature of the actual. Emit an error when both options
- -- are abstract.
-
- if Is_Abstract_Subprogram (CW_Prim_Op)
- and then Is_Abstract_Subprogram (Root_Prim_Op)
- then
- Error_Msg_NE
- ("abstract subprogram not allowed as generic actual",
- Spec, Formal_Spec);
- Interpretation_Error (CW_Prim_Op);
- Interpretation_Error (Root_Prim_Op);
- return;
-
- -- Otherwise choose the non-abstract version
-
- elsif Is_Abstract_Subprogram (Root_Prim_Op) then
- Prim_Op := CW_Prim_Op;
-
- else pragma Assert (Is_Abstract_Subprogram (CW_Prim_Op));
- Prim_Op := Root_Prim_Op;
- end if;
-
- -- If one of the candidate primitives is intrinsic, choose the
- -- other (which may also be intrinsic). Preference is given to
- -- the primitive of the root type.
-
- elsif Is_Intrinsic_Subprogram (CW_Prim_Op) then
Prim_Op := Root_Prim_Op;
- elsif Is_Intrinsic_Subprogram (Root_Prim_Op) then
+ elsif Is_Internal (Root_Prim_Op)
+ and then not Is_Internal (CW_Prim_Op)
+ then
Prim_Op := CW_Prim_Op;
elsif CW_Prim_Op = Root_Prim_Op then
Prim_Op := Root_Prim_Op;
- -- Otherwise there are two perfectly good candidates which satisfy
- -- the profile of the renamed generic formal subprogram.
+ -- Otherwise both candidate subprograms are user-defined and
+ -- ambiguous.
else
Error_Msg_NE
("ambiguous actual for generic subprogram &",
- Spec, Formal_Spec);
- Interpretation_Error (CW_Prim_Op);
+ Spec, Formal_Spec);
Interpretation_Error (Root_Prim_Op);
+ Interpretation_Error (CW_Prim_Op);
return;
end if;
- elsif Present (CW_Prim_Op) then
+ elsif CW_Prim_OK and not Root_Prim_OK then
Prim_Op := CW_Prim_Op;
- elsif Present (Root_Prim_Op) then
+ elsif not CW_Prim_OK and Root_Prim_OK then
+ Prim_Op := Root_Prim_Op;
+
+ -- An intrinsic equality may act as a suitable candidate in the case
+ -- of a null type extension where the parent's equality is hidden. A
+ -- call to an intrinsic equality is expanded as dispatching.
+
+ elsif Present (Root_Prim_Op)
+ and then Is_Intrinsic_Equality (Root_Prim_Op)
+ then
Prim_Op := Root_Prim_Op;
- -- Otherwise there are no candidate primitives. Let the caller
+ -- Otherwise there are no candidate subprograms. Let the caller
-- diagnose the error.
else
projects / thirdparty / gcc.git / commitdiff
