[Ada] Missing check on interface primitives

[Ada] Missing check on interface primitives

[Arnaud Charlet]

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

The compiler does not not verify always that all the primitives of an
interface type are abstract or null procedures. After this patch the
following test is compiled with errors:

package Pkg is
   --  Test 1
   type IA is tagged;
   function Get_myB (Self : IA) return natural;

   type IA is interface;

   --  Test 2
   type Iface is interface;
   function f1 (Obj : Iface) return Natural is (0);
end;

Command: gcc -c pkg.ads
Output:
pkg.ads:4:04: interface function "Get_Myb" must be abstract
pkg.ads:10:04: interface function "F1" must be abstract

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

2014-10-31  Javier Miranda  <miranda@adacore.com>

	* freeze.adb (Freeze_Record_Type): Add missing
	check to verify that all the primitives of an interface type
	are abstract or null procedures.


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

Index: freeze.adb
===================================================================
--- freeze.adb	(revision 216963)
+++ freeze.adb	(working copy)
@@ -4004,6 +4004,47 @@
             --  call to the Analyze_Freeze_Entity for the record type.
 
          end Check_Variant_Part;
+
+         --  Check that all the primitives of an interface type are abstract
+         --  or null procedures.
+
+         if Is_Interface (Rec)
+           and then not Error_Posted (Parent (Rec))
+         then
+            declare
+               Elmt : Elmt_Id;
+               Subp : Entity_Id;
+
+            begin
+               Elmt := First_Elmt (Primitive_Operations (Rec));
+               while Present (Elmt) loop
+                  Subp := Node (Elmt);
+
+                  if not Is_Abstract_Subprogram (Subp)
+
+                     --  Avoid reporting the error on inherited primitives
+
+                    and then Comes_From_Source (Subp)
+                  then
+                     Error_Msg_Name_1 := Chars (Subp);
+
+                     if Ekind (Subp) = E_Procedure then
+                        if not Null_Present (Parent (Subp)) then
+                           Error_Msg_N
+                             ("interface procedure % must be abstract or null",
+                              Parent (Subp));
+                        end if;
+                     else
+                        Error_Msg_N
+                          ("interface function % must be abstract",
+                           Parent (Subp));
+                     end if;
+                  end if;
+
+                  Next_Elmt (Elmt);
+               end loop;
+            end;
+         end if;
       end Freeze_Record_Type;
 
       -------------------------------