* throw an error if the forward interface type and the actual interface type do not match, resolves #36720

git-svn-id: trunk@44230 -

.gitattributes

@@ -16234,6 +16234,7 @@ tests/webtbf/tw3662.pp svneol=native#text/plain
 tests/webtbf/tw36631a.pp svneol=native#text/pascal
 tests/webtbf/tw36631b.pp svneol=native#text/pascal
 tests/webtbf/tw36652.pp svneol=native#text/pascal
+tests/webtbf/tw36720.pp svneol=native#text/pascal
 tests/webtbf/tw3680.pp svneol=native#text/plain
 tests/webtbf/tw3716.pp svneol=native#text/plain
 tests/webtbf/tw3738.pp svneol=native#text/plain
@@ -16371,6 +16372,8 @@ tests/webtbf/uw27378a.pp svneol=native#text/pascal
 tests/webtbf/uw27378b.pp svneol=native#text/pascal
 tests/webtbf/uw3450.pp svneol=native#text/plain
 tests/webtbf/uw36652.pp svneol=native#text/pascal
+tests/webtbf/uw36720a.pp svneol=native#text/pascal
+tests/webtbf/uw36720b.pp svneol=native#text/pascal
 tests/webtbf/uw3969.pp svneol=native#text/plain
 tests/webtbf/uw4103.pp svneol=native#text/plain
 tests/webtbf/uw4541.pp svneol=native#text/pascal

compiler/msg/errore.msg

@@ -1617,7 +1617,7 @@ parser_e_generic_constraints_not_allowed_here=03355_E_Generic constraint not all
 %
 # Type Checking
 #
-# 04126 is the last used one
+# 04127 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -2057,6 +2057,10 @@ type_e_cblock_callconv=04126_E_C block reference must use CDECL or MWPASCAL call
 % When declaring a C block reference ensure that it uses either the \var{cdecl} or \var{mwpascal}
 % calling convention either by adding the corresponding function directive or by using the
 % \var{\{\$Calling\}} compiler directive.
+type_e_forward_interface_type_does_not_match=04127_E_The interface type of the forward declaration and the declared interface type do not match for interface $1
+% When declaring an interface forward, the interface type must be the same as at the actual declaration of the interface.
+% This is in particular important with regard to the parent interface which implicitly sets the interface type for the
+% child interface.
 % \end{description}
 #
 # Symtable

compiler/msgidx.inc

@@ -583,6 +583,7 @@ const
   type_e_seg_procvardef_wrong_memory_model=04124;
   type_w_empty_constant_range_set=04125;
   type_e_cblock_callconv=04126;
+  type_e_forward_interface_type_does_not_match=04127;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -1123,9 +1124,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 84666;
+  MsgTxtSize = 84782;
 
   MsgIdxMax : array[1..20] of longint=(
-    28,106,356,127,99,63,143,35,223,68,
+    28,106,356,128,99,63,143,35,223,68,
     62,20,30,1,1,1,1,1,1,1
   );

compiler/pdecl.pas

@@ -658,7 +658,8 @@ implementation
          first,
          isgeneric,
          isunique,
-         istyperenaming : boolean;
+         istyperenaming,
+         wasforward: boolean;
          generictypelist : tfphashobjectlist;
          localgenerictokenbuf : tdynamicarray;
          p:tnode;
@@ -764,6 +765,7 @@ implementation
                    (sp_generic_dummy in sym.symoptions)
                  ) then
                begin
+                 wasforward:=false;
                  if ((token=_CLASS) or
                      (token=_INTERFACE) or
                      (token=_DISPINTERFACE) or
@@ -774,6 +776,7 @@ implementation
                     is_implicit_pointer_object_type(ttypesym(sym).typedef) and
                     (oo_is_forward in tobjectdef(ttypesym(sym).typedef).objectoptions) then
                   begin
+                    wasforward:=true;
                     case token of
                       _CLASS :
                         objecttype:=default_class_type;
@@ -802,6 +805,9 @@ implementation
                     gendef:=determine_generic_def(gentypename);
                     { we can ignore the result, the definition is modified }
                     object_dec(objecttype,genorgtypename,newtype,gendef,generictypelist,tobjectdef(ttypesym(sym).typedef),ht_none);
+                    if wasforward and
+                      (tobjectdef(ttypesym(sym).typedef).objecttype<>objecttype) then
+                      Message1(type_e_forward_interface_type_does_not_match,tobjectdef(ttypesym(sym).typedef).GetTypeName);
                     newtype:=ttypesym(sym);
                     hdef:=newtype.typedef;
                   end

tests/webtbf/tw36720.pp

@@ -0,0 +1,12 @@
+{ %fail }
+program project1;
+{$mode objfpc}{$H+}
+
+uses uw36720a, uw36720b;
+
+var
+  a: TObject;
+begin
+  ( a as IInterface2 ).DoSomethingElse;
+end.
+

tests/webtbf/uw36720a.pp

@@ -0,0 +1,24 @@
+{ %norun }
+unit uw36720a;
+
+{$mode objfpc}{$H+}
+{$interfaces CORBA}
+
+interface
+
+uses
+  Classes, SysUtils;
+
+type
+  IInterface = interface
+    ['{BD11C7E5-5EF3-4F2A-B047-54FFA8ED43A9}']
+
+    procedure DoSomething;
+  end;
+
+
+implementation
+
+end.
+
+

tests/webtbf/uw36720b.pp

@@ -0,0 +1,30 @@
+{ %norun }
+unit uw36720b;
+
+{$mode objfpc}{$H+}
+{$interfaces COM}
+
+interface
+
+uses
+  Classes, SysUtils,
+  uw36720a;
+
+type
+  IInterface3 = interface;
+  IInterface2 = interface ( IInterface )
+    ['{EB2E9267-C542-4784-81AE-A4C6ED044748}']
+
+    function DoSomethingElse: IInterface3;
+  end;
+
+  IInterface3 = interface( IInterface2 )
+    ['{EB2E9267-C542-4784-81AE-A4C6ED044748}']
+    function DoSomethingCompletelyDifferent: Integer;
+  end;
+
+
+implementation
+
+end.
+