[Ada] Primitive operations of formals when actual is class-wide

Message ID 20110802144646.GA9868@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Aug. 2, 2011, 2:46 p.m.
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

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;
       I.Test (Obj);
       when Program_Error => Put_Line ("Raised on T1");
with P1; use P1;
   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
      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));
          YY : NT := Empty;
                   -- If actual is class-wide, this raises Program_Error
                   -- as there is no tag provided by context.
          XX := YY;  -- We never get this far.
   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;
      return Result;
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);
package body P2 is
   --  type T1 is new T with null record;
   function Empty return T1 is
      Result : T1;
      return Result;

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).


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);