@@ -540,8 +540,10 @@ package body Sem_Disp is
Control : Node_Id := Empty;
Func : Entity_Id;
Subp_Entity : Entity_Id;
- Indeterm_Ancestor_Call : Boolean := False;
- Indeterm_Ctrl_Type : Entity_Id := Empty; -- init to avoid warning
+
+ Indeterm_Ctrl_Type : Entity_Id := Empty;
+ -- Type of a controlling formal whose actual is a tag-indeterminate call
+ -- whose result type is different from, but is an ancestor of, the type.
Static_Tag : Node_Id := Empty;
-- If a controlling formal has a statically tagged actual, the tag of
@@ -935,8 +937,7 @@ package body Sem_Disp is
and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal))
and then Is_Ancestor (Etype (Actual), Etype (Formal))
then
- Indeterm_Ancestor_Call := True;
- Indeterm_Ctrl_Type := Etype (Formal);
+ Indeterm_Ctrl_Type := Etype (Formal);
-- If the formal is controlling but the actual is not, the type
-- of the actual is statically known, and may be used as the
@@ -946,39 +947,13 @@ package body Sem_Disp is
and then Is_Entity_Name (Actual)
and then Is_Tagged_Type (Etype (Actual))
then
- Static_Tag := Actual;
+ Static_Tag := Etype (Actual);
end if;
Next_Actual (Actual);
Next_Formal (Formal);
end loop;
- -- If the call doesn't have a controlling actual but does have an
- -- indeterminate actual that requires dispatching treatment, then an
- -- object is needed that will serve as the controlling argument for
- -- a dispatching call on the indeterminate actual. This can occur
- -- in the unusual situation of a default actual given by a tag-
- -- indeterminate call and where the type of the call is an ancestor
- -- of the type associated with a containing call to an inherited
- -- operation (see AI-239).
-
- -- Rather than create an object of the tagged type, which would
- -- be problematic for various reasons (default initialization,
- -- discriminants), the tag of the containing call's associated
- -- tagged type is directly used to control the dispatching.
-
- if No (Control)
- and then Indeterm_Ancestor_Call
- and then No (Static_Tag)
- then
- Control :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
- Attribute_Name => Name_Tag);
-
- Analyze (Control);
- end if;
-
if Present (Control) then
-- Verify that no controlling arguments are statically tagged
@@ -1030,17 +1005,35 @@ package body Sem_Disp is
Check_Direct_Call;
- -- If there is a statically tagged actual and a tag-indeterminate
- -- call to a function of the ancestor (such as that provided by a
- -- default), then treat this as a dispatching call and propagate
- -- the tag to the tag-indeterminate call(s).
-
- elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then
- Control :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Etype (Static_Tag), Loc),
- Attribute_Name => Name_Tag);
+ -- If the call doesn't have a controlling actual but does have an
+ -- indeterminate actual that requires dispatching treatment, then an
+ -- object is needed that will serve as the controlling argument for
+ -- a dispatching call on the indeterminate actual. This can occur
+ -- in the unusual situation of a default actual given by a tag-
+ -- indeterminate call and where the type of the call is an ancestor
+ -- of the type associated with a containing call to an inherited
+ -- operation (see AI-239).
+
+ -- Rather than create an object of the tagged type, which would
+ -- be problematic for various reasons (default initialization,
+ -- discriminants), the tag of the containing call's associated
+ -- tagged type is directly used to control the dispatching.
+
+ elsif Present (Indeterm_Ctrl_Type) then
+ if Present (Static_Tag) then
+ Control :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Static_Tag, Loc),
+ Attribute_Name => Name_Tag);
+
+ else
+ Control :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Indeterm_Ctrl_Type, Loc),
+ Attribute_Name => Name_Tag);
+ end if;
Analyze (Control);