Comments
Patch
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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);
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 <schonberg@adacore.com> * sem_res.adb (Resolve_Call): implement rule in RM 12.5.1 (23.3/2).