If the actual for a formal type with unknown discriminants is class-wide, then
a call to a primitive operation of the formal that dispatches on result raises
program_error in the instance if the context cannot provide a tag for the call.
This is the case for a declaration of an object of the formal type. This rule
was not previously enforced by GNAT.
The following commands:
gnatmake -q test_class
test_class
must yield:
Tag of XX is P2.T1
Raised on T1
---
with P1; use P1;
with P2; use P2;
with Text_IO; use Text_IO;
procedure Test_Class is
Obj : T1;
begin
begin
I.Test (Obj);
exception
when Program_Error => Put_Line ("Raised on T1");
end;
end;
---
with P1; use P1;
generic
type NT(<>) is new T with private;
-- T has operation "function Empty return T;"
package G is
procedure Test(XX : in out NT);
end G;
---
with Ada.Tags; use Ada.Tags;
with Text_IO; use Text_IO;
package body G is
procedure Test(XX : in out NT) is
begin
XX := Empty; -- Dispatching based on X'Tag takes
-- place if actual is class-wide.
Put_Line ("Tag of XX is " & External_Tag (NT'class (XX)'Tag));
declare
YY : NT := Empty;
-- If actual is class-wide, this raises Program_Error
-- as there is no tag provided by context.
begin
XX := YY; -- We never get this far.
end;
end Test;
end G;
---
package P1 is
type T is tagged null record;
function Empty return T;
end P1;
---
package body P1 is
-- type T is tagged null record;
function Empty return T is
result : T;
begin
return Result;
end;
end P1;
---
with G;
with P1; use P1;
package P2 is
type T1 is new T with null record;
function Empty return T1;
package I is new G (T1'Class);
end;
---
package body P2 is
-- type T1 is new T with null record;
function Empty return T1 is
Result : T1;
begin
return Result;
end;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-02 Ed Schonberg <schonb...@adacore.com>
* sem_res.adb (Resolve_Call): implement rule in RM 12.5.1 (23.3/2).
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 177153)
+++ sem_res.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- --
@@ -5751,6 +5751,44 @@
-- Check_Formal_Restriction ("function not inherited", N);
-- end if;
+ -- Implement rule in 12.5.1 (23.3/2) : in an instance, if the actual
+ -- is class-wide and the call dispatches on result in a context that
+ -- does not provide a tag, the call raises Program_Error.
+
+ if Nkind (N) = N_Function_Call
+ and then In_Instance
+ and then Is_Generic_Actual_Type (Typ)
+ and then Is_Class_Wide_Type (Typ)
+ and then Has_Controlling_Result (Nam)
+ and then Nkind (Parent (N)) = N_Object_Declaration
+ then
+
+ -- verify that none of the formals are controlling.
+
+ declare
+ Call_OK : Boolean := False;
+ F : Entity_Id;
+
+ begin
+ F := First_Formal (Nam);
+ while Present (F) loop
+ if Is_Controlling_Formal (F) then
+ Call_OK := True;
+ exit;
+ end if;
+ Next_Formal (F);
+ end loop;
+
+ if not Call_OK then
+ Error_Msg_N ("!? cannot determine tag of result", N);
+ Error_Msg_N ("!? Program_Error will be raised", N);
+ Insert_Action (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Explicit_Raise));
+ end if;
+ end;
+ end if;
+
-- All done, evaluate call and deal with elaboration issues
Eval_Call (N);
