+ correct parsing interface delegation through classes

git-svn-id: trunk@10466 -

compiler/msg/errore.msg

@@ -353,7 +353,7 @@ scan_w_frameworks_darwin_only=02084_W_Framework-related options are only support
 % Frameworks are not a known concept, or at least not supported by FPC, on operating systems other than Darwin/Mac OS X.
 scan_e_illegal_minfpconstprec=02085_E_Illegal minimal floating point constant precision "$1"
 % Valid minimal precisions for floating point constants are default, 32 and 64, which mean respectively minimal (usually 32 bit), 32 bit and 64 bit precision.
-scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure multiple times, was previously set to "$1" 
+scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure multiple times, was previously set to "$1"
 % \end{description}
 #
 # Parser
@@ -1135,7 +1135,7 @@ parser_e_no_generics_as_types=03236_E_Generics without specialization can not be
 % Generics must be always specialized before being used as variable type
 parser_w_register_list_ignored=03237_W_Register list is ignored for pure assembler routines
 % When using pure assembler routines, the list with modified registers is ignored.
-parser_e_implements_must_be_class_or_interface=03238_E_Implements property must have interface type
+parser_e_implements_must_be_class_or_interface=03238_E_Implements property must have class or interface type
 parser_e_implements_must_have_correct_type=03239_E_Implements-property must implement interface of correct type, found "$1" expected "$2"
 parser_e_implements_must_read_specifier=03240_E_Implements-property must have read specifier
 parser_e_implements_must_not_have_write_specifier=03241_E_Implements-property must not have write-specifier
@@ -1143,6 +1143,9 @@ parser_e_implements_must_not_have_stored_specifier=03242_E_Implements-property m
 parser_e_implements_uses_non_implemented_interface=03243_E_Implements-property used on unimplemented interface: "$1"
 parser_e_unsupported_real=03244_E_Floating point not supported for this target
 % The compiler parsed a floating point expression, but it is not supported.
+parser_e_class_doesnt_implement_interface=03245_E_Class "$1" does not implement interface "$2"
+% The delegated interface is not implemented by the class given in the implements clause
+parser_e_class_implements_must_be_interface=03246_E_Type used by implements must be an interface
 % \end{description}
 #
 # Type Checking

compiler/msgidx.inc

@@ -332,6 +332,8 @@ const
   parser_e_implements_must_not_have_stored_specifier=03242;
   parser_e_implements_uses_non_implemented_interface=03243;
   parser_e_unsupported_real=03244;
+  parser_e_class_doesnt_implement_interface=03245;
+  parser_e_class_implements_must_be_interface=03246;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -743,9 +745,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 46137;
+  MsgTxtSize = 46251;
 
   MsgIdxMax : array[1..20] of longint=(
-    24,87,245,84,64,50,108,22,135,60,
+    24,87,247,84,64,50,108,22,135,60,
     42,1,1,1,1,1,1,1,1,1
   );

compiler/pdecvar.pas

@@ -627,16 +627,41 @@ implementation
            begin
              single_type(def,false);
 
-             if compare_defs(def,p.propdef,nothingn)<te_equal then
+             if not(is_interface(def)) then
+               message(parser_e_class_implements_must_be_interface);
+
+             if is_interface(p.propdef) then
                begin
-                 message2(parser_e_implements_must_have_correct_type,def.GetTypeName,p.propdef.GetTypeName);
-                 exit;
-               end;
-             if not is_class_or_interface(def) then
+                 if compare_defs(def,p.propdef,nothingn)<te_equal then
+                   begin
+                     message2(parser_e_implements_must_have_correct_type,def.GetTypeName,p.propdef.GetTypeName);
+                     exit;
+                   end;
+               end
+             else if is_class(p.propdef) then
+               begin
+                 ImplIntf:=tobjectdef(p.propdef).find_implemented_interface(tobjectdef(def));
+                 if assigned(ImplIntf) then
+                   begin
+                     if compare_defs(ImplIntf.IntfDef,def,nothingn)<te_equal then
+                       begin
+                         message2(parser_e_implements_must_have_correct_type,ImplIntf.IntfDef.GetTypeName,def.GetTypeName);
+                         exit;
+                       end;
+                   end
+                 else
+                   begin
+                     message2(parser_e_class_doesnt_implement_interface,p.propdef.GetTypeName,def.GetTypeName);
+                     exit;
+                   end;
+               end
+             else
                begin
                  message(parser_e_implements_must_be_class_or_interface);
                  exit;
                end;
+
+
              if not assigned(p.propaccesslist[palt_read].firstsym) then
                begin
                  message(parser_e_implements_must_read_specifier);
@@ -658,10 +683,10 @@ implementation
                  ImplIntf:=TImplementedInterface(aclass.ImplementedInterfaces[i]);
 
                  if compare_defs(def,ImplIntf.IntfDef,nothingn)>=te_equal then
-                 begin
-                   found:=true;
-                   break;
-                 end;
+                   begin
+                     found:=true;
+                     break;
+                   end;
                end;
              if found then
                begin