>From the text of AI05-0071:
If a generic unit has a subprogram_default specified by a box, and
the corresponding actual parameter is omitted, then it is equivalent
to an explicit actual parameter that is a usage name identical to the
defining name of the formal. {If a subtype_mark in the profile of the
formal_subprogram_declaration denotes a formal private or formal derived
type and the actual type for this formal type is a class-wide type
T'Class, then for the purposes of resolving this default_name at the
point of the instantiation, for each primitive subprogram of T that has
a matching defining name, that is directly visible at the point of the
instantiation, and that has at least one controlling formal parameter,
a corresponding subprogram with the same defining name is directly
visible, but with T systematically replaced by T'Class in the types
of its profile. The body of such a subprogram is as defined in
12.5.1 for primitive subprograms of a formal type when the actual
type is class-wide.}
This patch implements this resolution rule by creating the class-wide operation
and its body within an instance that has such a defaulted formal subprogram.
The following commands:
gnatmake -q class_wide_default
class_wide_default
must yield:
Mangle T
Mangle T1
---
with P1, P2; use P1, P2;
procedure Class_Wide_Default is
Thing : T;
Thing1 : T1;
begin
I.Test (Thing);
I.Test (Thing1);
end;
---
package P1 is
type T is tagged null record;
function Empty return T;
procedure Mangle (X : T);
end P1;
---
with P1; use P1;
generic
type NT(<>) is new T with private;
with procedure Mangle (X : NT) is <>;
package Gen_Pack is
procedure Test(XX : in out NT);
end Gen_Pack;
---
with Gen_Pack;
with P1; use P1;
package P2 is
type T1 is new T with null record;
function Empty return T1;
procedure Mangle (X : T1);
package I is new Gen_Pack (T'Class);
end;
---
with Ada.Tags; use Ada.Tags;
with Text_IO; use Text_IO;
package body Gen_Pack is
procedure Test(XX : in out NT) is
begin
Mangle (XX);
end Test;
end Gen_Pack;
---
with Text_IO; use Text_IO;
package body P1 is
function Empty return T is
result : T;
begin
return Result;
end;
procedure Mangle (X : T) is
begin
Put_Line ("Mangle T");
end;
end P1;
---
with Text_IO; use Text_IO;
package body P2 is
function Empty return T1 is
Result : T1;
begin
return Result;
end;
procedure Mangle (X : T1) is
begin
Put_Line ("Mangle T1");
end;
procedure Huh (Y : T1'class) is
begin
Mangle (Y);
end;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Ed Schonberg <schonb...@adacore.com>
* sem_ch8.adb (Analyze_Subprogram_Renaming): new procedure
Check_Class_Wide_Actual, to implement AI05-0071, on defaulted
primitive operations of class-wide actuals.
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 177152)
+++ sem_ch8.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- 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- --
@@ -1614,6 +1614,179 @@
-- before the subprogram it completes is frozen, and renaming indirectly
-- renames the subprogram itself.(Defect Report 8652/0027).
+ function Check_Class_Wide_Actual return Entity_Id;
+ -- AI05-0071: In an instance, if the actual for a formal type FT with
+ -- unknown discriminants is a class-wide type CT, and the generic has
+ -- a formal subprogram with a box for a primitive operation of FT,
+ -- then the corresponding actual subprogram denoted by the default is a
+ -- class-wide operation whose body is a dispatching call. We replace the
+ -- generated renaming declaration:
+ --
+ -- procedure P (X : CT) renames P;
+ --
+ -- by a different renaming and a class-wide operation:
+ --
+ -- procedure Pr (X : T) renames P; -- renames primitive operation
+ -- procedure P (X : CT); -- class-wide operation
+ -- ...
+ -- procedure P (X : CT) is begin Pr (X); end; -- dispatching call
+
+ -- This rule only applies if there is no explicit visible class-wide
+ -- operation at the point of the instantiation.
+
+ -----------------------------
+ -- Check_Class_Wide_Actual --
+ -----------------------------
+
+ function Check_Class_Wide_Actual return Entity_Id is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ F : Entity_Id;
+ Formal_Type : Entity_Id;
+ Actual_Type : Entity_Id;
+ New_Body : Node_Id;
+ New_Decl : Node_Id;
+ Result : Entity_Id;
+
+ function Make_Call (Prim_Op : Entity_Id) return Node_Id;
+ -- Build dispatching call for body of class-wide operation
+
+ function Make_Spec return Node_Id;
+ -- Create subprogram specification for declaration and body of
+ -- class-wide operation, using signature of renaming declaration.
+
+ ---------------
+ -- Make_Call --
+ ---------------
+
+ function Make_Call (Prim_Op : Entity_Id) return Node_Id is
+ Actuals : List_Id;
+ F : Node_Id;
+
+ begin
+ Actuals := New_List;
+ F := First (Parameter_Specifications (Specification (New_Decl)));
+ while Present (F) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (F))));
+ Next (F);
+ end loop;
+
+ if Ekind (Prim_Op) = E_Function then
+ return Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Prim_Op, Loc),
+ Parameter_Associations => Actuals));
+ else
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Prim_Op, Loc),
+ Parameter_Associations => Actuals);
+ end if;
+ end Make_Call;
+
+ ---------------
+ -- Make_Spec --
+ ---------------
+
+ function Make_Spec return Node_Id is
+ Param_Specs : constant List_Id := Copy_Parameter_List (New_S);
+
+ begin
+ if Ekind (New_S) = E_Procedure then
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Unit_Name (Spec))),
+ Parameter_Specifications => Param_Specs);
+ else
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Defining_Unit_Name (Spec))),
+ Parameter_Specifications => Param_Specs,
+ Result_Definition =>
+ New_Copy_Tree (Result_Definition (Spec)));
+ end if;
+ end Make_Spec;
+
+ -- Start of processing for Check_Class_Wide_Actual
+
+ begin
+ Result := Any_Id;
+ Formal_Type := Empty;
+ Actual_Type := Empty;
+
+ F := First_Formal (Formal_Spec);
+ while Present (F) loop
+ if Has_Unknown_Discriminants (Etype (F))
+ and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F)))
+ then
+ Formal_Type := Etype (F);
+ Actual_Type := Etype (Get_Instance_Of (Formal_Type));
+ exit;
+ end if;
+
+ Next_Formal (F);
+ end loop;
+
+ if Present (Formal_Type) then
+
+ -- Create declaration and body for class-wide operation
+
+ New_Decl :=
+ Make_Subprogram_Declaration (Loc, Specification => Make_Spec);
+
+ New_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification => Make_Spec,
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, New_List));
+
+ -- Modify Spec and create internal name for renaming of primitive
+ -- operation.
+
+ Set_Defining_Unit_Name (Spec, Make_Temporary (Loc, 'R'));
+ F := First (Parameter_Specifications (Spec));
+ while Present (F) loop
+ if Nkind (Parameter_Type (F)) = N_Identifier
+ and then Is_Class_Wide_Type (Entity (Parameter_Type (F)))
+ then
+ Set_Parameter_Type (F, New_Occurrence_Of (Actual_Type, Loc));
+ end if;
+ Next (F);
+ end loop;
+
+ New_S := Analyze_Subprogram_Specification (Spec);
+ Result := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+ end if;
+
+ if Result /= Any_Id then
+ Insert_Before (N, New_Decl);
+ Analyze (New_Decl);
+
+ -- Add dispatching call to body of class-wide operation
+
+ Append (Make_Call (Result),
+ Statements (Handled_Statement_Sequence (New_Body)));
+
+ -- The generated body does not freeze. It is analyzed when the
+ -- generated operation is frozen.
+
+ Append_Freeze_Action (Defining_Entity (New_Decl), New_Body);
+
+ Result := Defining_Entity (New_Decl);
+ end if;
+
+ -- Return the class-wide operation if one was created.
+
+ return Result;
+ end Check_Class_Wide_Actual;
+
--------------------------
-- Check_Null_Exclusion --
--------------------------
@@ -2190,6 +2363,16 @@
end if;
end if;
+ -- If no renamed entity was found, check whether the renaming is for
+ -- a defaulted actual subprogram with a class-wide actual.
+
+ if Old_S = Any_Id
+ and then Is_Actual
+ and then From_Default (N)
+ then
+ Old_S := Check_Class_Wide_Actual;
+ end if;
+
if Old_S /= Any_Id then
if Is_Actual
and then From_Default (N)
@@ -2246,8 +2429,21 @@
end if;
elsif Ekind (Old_S) /= E_Operator then
- Check_Mode_Conformant (New_S, Old_S);
+ -- If this is a default subprogram, it may be for a class-wide
+ -- actual, in which case there is no check for mode conformance,
+ -- given that the signatures do not match (the source mentions T,
+ -- but the actual mentions T'Class).
+
+ if Is_Actual
+ and then From_Default (N)
+ then
+ null;
+
+ else
+ Check_Mode_Conformant (New_S, Old_S);
+ end if;
+
if Is_Actual
and then Error_Posted (New_S)
then
@@ -5319,7 +5515,10 @@
end loop;
Set_Entity (Nam, Old_S);
- Set_Is_Overloaded (Nam, False);
+
+ if Old_S /= Any_Id then
+ Set_Is_Overloaded (Nam, False);
+ end if;
end if;
return Old_S;
