When the type of the controlling formal of a dispatching call is an interface subtype the compiler can generate code that dispatch to the wrong operation or crash the program.
After this patch the following test compiles and executes well. package Small_Types is type I_Dummy is limited interface; procedure Dummy (Obj : I_Dummy) is abstract; type I_Writable is limited interface; procedure Write (Obj : I_Writable) is abstract; type I_Whole is limited interface and I_Dummy and I_Writable; end; with Small_Types; use Small_Types; package Small_Tests is type T_Whole is new Small_Types.I_Whole with null record; procedure Dummy (Stream : T_Whole); procedure Write (Stream : T_Whole); procedure Run; end; with Ada.Text_IO; use Ada.Text_IO; package body Small_Tests is procedure Write (Stream : T_Whole) is begin Put_Line ("OK"); end; procedure Dummy (Stream : T_Whole) is begin Put_Line ("Wrong"); raise Program_Error; end; procedure Test_1 (Obj : I_Writable'Class) is begin Obj.Write; -- OK end; subtype T_Writable_Class is I_Writable'Class; procedure Test_2 (Obj : T_Writable_Class) is begin Obj.Write; -- Wrong end; procedure Run is Obj : T_Whole; begin Put ("Test 1 .... "); Test_1 (Obj); Put ("Test 2 .... "); Test_2 (Obj); end; end; with Small_Tests; procedure Small_Main is begin Small_Tests.Run; end; Command: gnatmake small_main.adb; ./small_main Output: Test 1 .... OK Test 2 .... OK Tested on x86_64-pc-linux-gnu, committed on trunk 2017-01-23 Javier Miranda <mira...@adacore.com> * exp_ch6.adb (Expand_Call): Improve the code that checks if some formal of the called subprogram is a class-wide interface, to handle subtypes of class-wide interfaces.
Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 244789) +++ exp_ch6.adb (working copy) @@ -2832,10 +2832,12 @@ CW_Interface_Formals_Present := CW_Interface_Formals_Present or else - (Ekind (Etype (Formal)) = E_Class_Wide_Type + (Is_Class_Wide_Type (Etype (Formal)) and then Is_Interface (Etype (Etype (Formal)))) or else (Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Is_Class_Wide_Type (Directly_Designated_Type + (Etype (Etype (Formal)))) and then Is_Interface (Directly_Designated_Type (Etype (Etype (Formal)))));