[Ada] Interface type conversions are not dynamically tagged

[Ada] Interface type conversions are not dynamically tagged

[Arnaud Charlet]

[-- Attachment #1: Type: text/plain, Size: 910 bytes --]

A view conversion to an interface type is expanded into a dereference of a
temporary that involves the class-wide interface type. Nevertheless such an
expression is not dynamically tagged, and is not a controlling argument in 
a call.

Compiling main.adb must be rejected with:

   main.adb:8:10: call to abstract procedure must be dispatching

---
with Types; use Types;
procedure Main is
    V : R;
begin
    I (V).P1;
    I'Class (V).P1;
    I (V).P2;
    I'Class (V).P2;
end Main;
---
package Types  is
  type I is interface;

   procedure P1 (V : I)  is null;
   procedure P2 (V : I) is abstract;

   type R is new I with null record;

   procedure P2 (V : R) is null;
end Types;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-09-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_disp.adb (Find_Controlling_Arg): Add checks for
	interface type conversions, that are expanded into dereferences.


[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 1188 bytes --]

Index: sem_disp.adb
===================================================================
--- sem_disp.adb	(revision 178381)
+++ sem_disp.adb	(working copy)
@@ -1616,6 +1616,32 @@
       then
          return Controlling_Argument (Orig_Node);
 
+      --  Type conversions are dynamically tagged if the target type, or its
+      --  designated type, are classwide. An interface conversion expands into
+      --  a dereference, so test must be performed on the original node.
+
+      elsif Nkind (Orig_Node) = N_Type_Conversion
+        and then Nkind (N) = N_Explicit_Dereference
+        and then Is_Controlling_Actual (N)
+      then
+         declare
+            Target_Type : constant Entity_Id :=
+                             Entity (Subtype_Mark (Orig_Node));
+
+         begin
+            if Is_Class_Wide_Type (Target_Type) then
+               return N;
+
+            elsif Is_Access_Type (Target_Type)
+              and then Is_Class_Wide_Type (Designated_Type (Target_Type))
+            then
+               return N;
+
+            else
+               return Empty;
+            end if;
+         end;
+
       --  Normal case
 
       elsif Is_Controlling_Actual (N)