Merge branch source:main into main

compiler/ncgrtti.pas

@@ -1741,6 +1741,9 @@ implementation
             { write GUID }
             tcb.emit_guid_const(def.iidguid^);
 
+            { write hidden class reference - if it is nil, write_rtti_reference writes nil }
+            write_rtti_reference(tcb,def.hiddenclassdef,fullrtti);
+
             { write unit name }
             tcb.emit_shortstring_const(current_module.realmodulename^);
 

compiler/pdecobj.pas

@@ -1569,7 +1569,7 @@ implementation
         { set published flag in $M+ mode, it can also be inherited and will
           be added when the parent class set with tobjectdef.set_parent (PFV) }
         if (cs_generate_rtti in current_settings.localswitches) and
-           (current_objectdef.objecttype in [odt_interfacecom,odt_class,odt_helper]) then
+           (current_objectdef.objecttype in [odt_interfacecom,odt_interfacecorba,odt_class,odt_helper]) then
           include(current_structdef.objectoptions,oo_can_have_published);
 
         { Objective-C/Java objectdefs can be "formal definitions", in which case

compiler/pmodules.pas

@@ -1233,6 +1233,13 @@ type
          { Generate specializations of objectdefs methods }
          generate_specialization_procs;
 
+         // This needs to be done before we generate the VMTs
+         if (target_cpu=tsystemcpu.cpu_wasm32) then
+           begin
+           add_synthetic_interface_classes_for_st(current_module.globalsymtable);
+           add_synthetic_interface_classes_for_st(current_module.localsymtable);
+           end;
+
          { Generate VMTs }
          if Errorcount=0 then
            begin
@@ -2260,6 +2267,10 @@ type
          { Generate specializations of objectdefs methods }
          generate_specialization_procs;
 
+         // This needs to be done before we generate the VMTs
+         if (target_cpu=tsystemcpu.cpu_wasm32) then
+           add_synthetic_interface_classes_for_st(current_module.localsymtable);
+
          { Generate VMTs }
          if Errorcount=0 then
            write_vmts(current_module.localsymtable,false);

compiler/symcreat.pas

@@ -126,6 +126,10 @@ interface
   function generate_pkg_stub(pd:tprocdef):tnode;
   procedure generate_attr_constrs(attrs:tfpobjectlist);
 
+  { Generate the hidden thunk class for interfaces,
+    so we can use them in TVirtualInterface on platforms that do not allow
+    generating executable code in memory at runtime.}
+  procedure add_synthetic_interface_classes_for_st(st : tsymtable);
 
 
 implementation
@@ -133,7 +137,7 @@ implementation
   uses
     cutils,globals,verbose,systems,comphook,fmodule,constexp,
     symtable,defutil,symutil,procinfo,
-    pbase,pdecobj,pdecsub,psub,ptconst,pparautl,
+    pbase,pdecl, pdecobj,pdecsub,psub,ptconst,pparautl,
 {$ifdef jvm}
     pjvm,jvmdef,
 {$endif jvm}
@@ -309,6 +313,34 @@ implementation
       current_scanner.tempopeninputfile;
     end;
 
+    function str_parse_objecttypedef(typename : shortstring;str: ansistring): tobjectdef;
+     var
+       b,oldparse_only: boolean;
+       tmpstr: ansistring;
+       flags : tread_proc_flags;
+
+     begin
+      result:=nil;
+      Message1(parser_d_internal_parser_string,str);
+      oldparse_only:=parse_only;
+      parse_only:=true;
+      { "const" starts a new kind of block and hence makes the scanner return }
+      str:=str+'const;';
+      block_type:=bt_type;
+      { inject the string in the scanner }
+      current_scanner.substitutemacro('hidden_interface_class_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index,true);
+      current_scanner.readtoken(false);
+      type_dec(b);
+      if (current_module.DefList.Last is tobjectdef) and
+         (tobjectdef(current_module.DefList.Last).GetTypeName=typename) then
+           result:=tobjectdef(current_module.DefList.Last);
+      parse_only:=oldparse_only;
+      { remove the temporary macro input file again }
+      current_scanner.closeinputfile;
+      current_scanner.nextfile;
+      current_scanner.tempopeninputfile;
+     end;
+
 
   function def_unit_name_prefix_if_toplevel(def: tdef): TSymStr;
     begin
@@ -1290,6 +1322,351 @@ implementation
         end;
     end;
 
+  function get_method_paramtype(vardef  : Tdef) : ansistring;
+
+  var
+    p : integer;
+    arrdef : tarraydef absolute vardef;
+
+  begin
+    {
+      None of the existing routines fulltypename,OwnerHierarchyName,FullOwnerHierarchyName,typename
+      results in a workable definition for open array parameters.
+    }
+    if not (vardef is tarraydef) then
+      result:=vardef.fulltypename
+    else
+      begin
+      if (ado_isarrayofconst in arrdef.arrayoptions) then
+        result:='Array Of Const'
+      else if (ado_OpenArray in arrdef.arrayoptions) then
+        result:='Array of '+arrdef.elementdef.fulltypename
+      else
+        result:=vardef.fulltypename;
+      end;
+    // ansistring(0) -> ansistring
+    p:=pos('(',result);
+    if p=0 then
+      p:=pos('[',result);
+    if p>0 then
+      result:=copy(result,1,p-1);
+  end;
+
+  function create_intf_method_args(p : tprocdef; out argcount: integer) : ansistring;
+
+  const
+    varspezprefixes : array[tvarspez] of shortstring =
+      ('','const','var','out','constref','final');
+  var
+    i : integer;
+    s : string;
+    para : tparavarsym;
+
+
+  begin
+    result:='';
+    argCount:=0;
+    for i:=0 to p.paras.Count-1 do
+      begin
+      para:=tparavarsym(p.paras[i]);
+      if vo_is_hidden_para in para.varoptions then
+        continue;
+      if Result<>'' then
+        Result:=Result+';';
+      inc(argCount);
+      result:=result+varspezprefixes[para.varspez]+' p'+tostr(argcount);
+      if Assigned(para.vardef) and not (para.vardef is tformaldef) then
+        result:=Result+' : '+get_method_paramtype(para.vardef);
+      end;
+    if Result<>'' then
+      Result:='('+Result+')';
+  end;
+
+  function generate_thunkclass_name(acount: Integer; objdef : tobjectdef) : shortstring;
+
+  var
+    cn : shortstring;
+    i : integer;
+
+  begin
+    cn:=ObjDef.GetTypeName;
+    for i:=0 to Length(cn) do
+      if cn[i]='.' then
+        cn[i]:='_';
+    result:='_t_hidden'+tostr(acount)+cn;
+  end;
+
+  function get_thunkclass_interface_vmtoffset(objdef : tobjectdef) : integer;
+
+  var
+    i,j,offs : integer;
+    sym : tsym;
+    proc : tprocsym absolute sym;
+    pd : tprocdef;
+
+  begin
+    offs:=maxint;
+    for I:=0 to objdef.symtable.symList.Count-1 do
+      begin
+      sym:=tsym(objdef.symtable.symList[i]);
+      if Not assigned(sym) then
+        continue;
+      if (Sym.typ<>procsym) then
+        continue;
+      for j:=0 to proc.ProcdefList.Count-1 do
+        begin
+        pd:=tprocdef(proc.ProcdefList[j]);
+        if pd.extnumber<offs then
+          offs:=pd.extnumber;
+        end;
+      end;
+      if offs=maxint then
+        offs:=0;
+      result:=offs;
+    end;
+
+  procedure implement_interface_thunkclass_decl(cn : shortstring; objdef : tobjectdef);
+
+  var
+    str : ansistring;
+    sym : tsym;
+    proc : tprocsym absolute sym;
+    pd : tprocdef;
+    def : tobjectdef;
+    offs,argcount,i,j : integer;
+
+  begin
+    str:='type '#10;
+    str:=str+cn+' = class(TInterfaceThunk,'+objdef.GetTypeName+')'#10;
+    str:=str+' protected '#10;
+    for I:=0 to objdef.symtable.symList.Count-1 do
+      begin
+      sym:=tsym(objdef.symtable.symList[i]);
+      if Not assigned(sym) then
+        continue;
+      if (Sym.typ<>procsym) then
+        continue;
+      for j:=0 to proc.ProcdefList.Count-1 do
+        begin
+        pd:=tprocdef(proc.ProcdefList[j]);
+        if pd.returndef<>voidtype then
+          str:=str+'function '
+        else
+          str:=str+'procedure ';
+        str:=str+proc.RealName;
+        str:=str+create_intf_method_args(pd,argcount);
+        if pd.returndef<>voidtype then
+          str:=str+' : '+get_method_paramtype(pd.returndef);
+        str:=str+';'#10;
+        end;
+      end;
+    offs:=get_thunkclass_interface_vmtoffset(objdef);
+    if offs>0 then
+      begin
+      str:=str+'public '#10;
+      str:=str+'  function InterfaceVMTOffset : word; override;'#10;
+      end;
+    str:=str+' end;'#10;
+    def:=str_parse_objecttypedef(cn,str);
+    if assigned(def) then
+      begin
+      def.created_in_current_module:=true;
+      include(def.objectoptions,oo_can_have_published);
+      end;
+    objdef.hiddenclassdef:=def;
+  end;
+
+  function str_parse_method(str: ansistring): tprocdef;
+   var
+     oldparse_only: boolean;
+     tmpstr: ansistring;
+     flags : tread_proc_flags;
+
+   begin
+    Message1(parser_d_internal_parser_string,str);
+    oldparse_only:=parse_only;
+    parse_only:=false;
+    { "const" starts a new kind of block and hence makes the scanner return }
+    str:=str+'const;';
+    block_type:=bt_none;
+    { inject the string in the scanner }
+    current_scanner.substitutemacro('hidden_interface_method',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index,true);
+    current_scanner.readtoken(false);
+    Result:=read_proc([],Nil);
+    parse_only:=oldparse_only;
+    { remove the temporary macro input file again }
+    current_scanner.closeinputfile;
+    current_scanner.nextfile;
+    current_scanner.tempopeninputfile;
+   end;
+
+
+  procedure implement_interface_thunkclass_impl_method(cn : shortstring; objdef : tobjectdef; proc : tprocsym; pd : tprocdef);
+
+  var
+    rest,str : ansistring;
+    pn,d : shortstring;
+    sym : tsym;
+    aArg,argcount,i : integer;
+    haveresult : boolean;
+    para : tparavarsym;
+    hasopenarray, washigh: Boolean;
+
+  begin
+    rest:='';
+    str:='';
+    if pd.returndef<>voidtype then
+      str:=str+'function '
+    else
+      str:=str+'procedure ';
+    pn:=proc.RealName;
+    str:=str+cn+'.'+pn;
+    str:=str+create_intf_method_args(pd,argcount);
+    haveresult:=pd.returndef<>voidtype;
+    if haveresult then
+      begin
+      rest:=get_method_paramtype(pd.returndef);
+      str:=str+' : '+rest;
+      end;
+    str:=str+';'#10;
+    str:=str+'var '#10;
+    str:=str+'  data : array[0..'+tostr(argcount)+'] of System.TInterfaceThunk.TArgData;'#10;
+    if haveresult then
+      str:=str+'  res : '+rest+';'#10;
+    str:=str+'begin'#10;
+    // initialize result.
+    if HaveResult then
+      begin
+      str:=Str+'  data[0].addr:=@Res;'#10;
+      str:=Str+'  data[0].info:=TypeInfo(Res);'#10;
+      end
+    else
+      begin
+      str:=Str+'  data[0].addr:=nil;'#10;
+      str:=Str+'  data[0].idx:=-1;'#10;
+      end;
+    str:=Str+'  data[0].idx:=-1;'#10;
+    str:=Str+'  data[0].ahigh:=-1;'#10;
+    // Fill rest of data
+    aArg:=0;
+    washigh:=false;
+    d:='0';
+    for i:=0 to pd.paras.Count-1 do
+      begin
+      para:=tparavarsym(pd.paras[i]);
+      // previous was open array. Record high
+      if (i>1) then
+        begin
+        WasHigh:=(vo_is_high_para in para.varoptions);
+        if Washigh then
+          // D is still value of previous (real) parameter
+          str:=str+'  data['+d+'].ahigh:=High(p'+d+');'#10
+        else
+          str:=str+'  data['+d+'].ahigh:=-1;'#10;
+        end;
+      if vo_is_hidden_para in para.varoptions then
+        continue;
+      inc(aArg);
+      d:=tostr(aArg);
+      Str:=Str+'  data['+d+'].addr:=@p'+d+';'#10;
+      Str:=Str+'  data['+d+'].idx:='+tostr(i)+';'#10;
+      if Assigned(para.vardef) and not (para.vardef is tformaldef) then
+        Str:=Str+'  data['+d+'].info:=TypeInfo(p'+d+');'#10
+      else
+        Str:=Str+'  data['+d+'].info:=Nil;'#10
+      end;
+    // if last was not high, set to sentinel.
+    if not WasHigh then
+      str:=str+'  data['+d+'].ahigh:=-1;'#10;
+    str:=str+'  Thunk('+tostr(pd.extnumber)+','+tostr(argcount)+',@Data);'#10;
+    if HaveResult then
+      str:=str+'  Result:=res;'#10;
+    str:=str+'end;'#10;
+    pd:=str_parse_method(str);
+  end;
+
+  procedure implement_thunkclass_interfacevmtoffset(cn : shortstring; objdef : tobjectdef; offs : integer);
+
+  var
+    str : ansistring;
+  begin
+    str:='function '+cn+'.InterfaceVMTOffset : word;'#10;
+    str:=str+'begin'#10;
+    str:=str+'  result:='+toStr(offs)+';'#10;
+    str:=str+'end;'#10;
+    str_parse_method(str);
+  end;
+
+
+  procedure implement_interface_thunkclass_impl(cn: shortstring; objdef : tobjectdef);
+
+  var
+    str : ansistring;
+    sym : tsym;
+    proc : tprocsym absolute sym;
+    pd : tprocdef;
+    offs,i,j : integer;
+
+  begin
+    offs:=get_thunkclass_interface_vmtoffset(objdef);
+    if offs>0 then
+      implement_thunkclass_interfacevmtoffset(cn,objdef,offs);
+    for I:=0 to objdef.symtable.symList.Count-1 do
+      begin
+      sym:=tsym(objdef.symtable.symList[i]);
+      if Not assigned(sym) then
+        continue;
+      if (Sym.typ<>procsym) then
+        continue;
+      for j:=0 to proc.ProcdefList.Count-1 do
+        begin
+        pd:=tprocdef(proc.ProcdefList[j]);
+        implement_interface_thunkclass_impl_method(cn,objdef,proc,pd);
+        end;
+      end;
+  end;
+
+  procedure add_synthetic_interface_classes_for_st(st : tsymtable);
+
+  var
+    i   : longint;
+    def : tdef;
+    objdef : tobjectdef absolute def;
+    recdef : trecorddef absolute def;
+    sstate: tscannerstate;
+    cn : shortstring;
+
+  begin
+    { skip if any errors have occurred, since then this can only cause more
+      errors }
+    if ErrorCount<>0 then
+      exit;
+    replace_scanner('hiddenclass_impl',sstate);
+    for i:=0 to st.deflist.count-1 do
+      begin
+      def:=tdef(st.deflist[i]);
+      if (def.typ<>objectdef) then
+        continue;
+      if not (objdef.objecttype in [odt_interfacecorba,odt_interfacecom]) then
+        continue;
+      if not (oo_can_have_published in objdef.objectoptions) then
+        continue;
+      // need to add here extended rtti check when it is available
+      cn:=generate_thunkclass_name(i,objdef);
+      implement_interface_thunkclass_decl(cn,objdef);
+      implement_interface_thunkclass_impl(cn,objdef);
+      end;
+    restore_scanner(sstate);
+    // Recurse for interfaces defined in a type section of a class/record.
+    for i:=0 to st.deflist.count-1 do
+      begin
+      def:=tdef(st.deflist[i]);
+      if (def.typ=objectdef) and (objdef.objecttype=odt_class) then
+        add_synthetic_interface_classes_for_st(objdef.symtable)
+      else if (def.typ=recorddef) and (m_advanced_records in current_settings.modeswitches) then
+        add_synthetic_interface_classes_for_st(recdef.symtable);
+      end;
+  end;
 
   procedure add_synthetic_method_implementations(st: tsymtable);
     var

compiler/symdef.pas

@@ -506,6 +506,12 @@ interface
           }
           classref_created_in_current_module : boolean;
           objecttype     : tobjecttyp;
+          { for interfaces that can be invoked using Invoke(),
+            this is the definition of the hidden class that is generated by the compiler.
+            we need this definition to reference it in the RTTI, only during compilation of unit. 
+            so no need to write it to the .ppu file.
+          }
+          hiddenclassdef : tobjectdef;
           constructor create(ot:tobjecttyp;const n:string;c:tobjectdef;doregister:boolean);virtual;
           constructor ppuload(ppufile:tcompilerppufile);
           destructor  destroy;override;

packages/rtl-generics/fpmake.pp

@@ -23,7 +23,7 @@ begin
     P.Email := '';
     P.Description := 'Generic collection library.';
     P.NeedLibC:= false;
-    P.OSes := AllOSes-[embedded,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc,watcom,sinclairql,wasi];
+    P.OSes := AllOSes-[embedded,win16,macosclassic,palmos,zxspectrum,msxdos,amstradcpc,watcom,sinclairql];
     if Defaults.CPU=jvm then
       P.OSes := P.OSes - [java,android];
 

packages/rtl-generics/src/generics.hashes.pas

@@ -33,6 +33,10 @@ unit Generics.Hashes;
 {$OVERFLOWCHECKS OFF}
 {$RANGECHECKS OFF}
 
+{$IFDEF CPUWASM}
+{$DEFINE NOGOTO}
+{$ENDIF}
+
 interface
 
 uses
@@ -195,8 +199,10 @@ function HashWord(
   AInitVal: UInt32): UInt32;         //* the previous hash, or an arbitrary value */
 var
   a,b,c: UInt32;
+{$IFNDEF NOGOTO}
 label
   Case0, Case1, Case2, Case3;
+{$ENDIF}
 begin
   //* Set up the internal state */
   a := $DEADBEEF + (UInt32(ALength) shl 2) + AInitVal;
@@ -215,6 +221,16 @@ begin
   end;
 
   //*------------------------------------------- handle the last 3 uint32_t's */
+{$IFDEF NOGOTO}
+  if aLength=3 then
+    c+=AKey[2];
+  if aLength>=2 then
+    b+=AKey[1];
+  if aLength>=1 then
+    a+=AKey[0];
+  if aLength>0 then
+    final_abc;
+{$ELSE}
   case ALength of //* all the case statements fall through */
     3: goto Case3;
     2: goto Case2;
@@ -226,6 +242,7 @@ begin
   Case1: a+=AKey[0];
     final_abc;
   Case0:     //* case 0: nothing left to add */
+{$ENDIF}
   //*------------------------------------------------------ report the result */
   Result := c;
 end;
@@ -237,8 +254,10 @@ var APrimaryHashAndInitVal: UInt32;                      //* IN: seed OUT: prima
 var ASecondaryHashAndInitVal: UInt32);               //* IN: more seed OUT: secondary hash value */
 var
   a,b,c: UInt32;
+{$IFNDEF NOGOTO}
 label
   Case0, Case1, Case2, Case3;
+{$ENDIF}
 begin
   //* Set up the internal state */
   a := $deadbeef + (UInt32(ALength shl 2)) + APrimaryHashAndInitVal;
@@ -258,6 +277,16 @@ begin
   end;
 
   //*------------------------------------------- handle the last 3 uint32_t's */
+{$IFDEF NOGOTO}
+  if aLength=3 then
+     c+=AKey[2];
+  if aLength>=2 then
+     b+=AKey[1];
+  if aLength>=1 then
+     a+=AKey[0];
+  if aLength>0 then
+    final_abc;
+{$ELSE}
   case ALength of                     //* all the case statements fall through */
     3: goto Case3;
     2: goto Case2;
@@ -269,6 +298,7 @@ begin
   Case1: a+=AKey[0];
     final_abc;
   Case0:     //* case 0: nothing left to add */
+{$ENDIF}
   //*------------------------------------------------------ report the result */
   APrimaryHashAndInitVal := c;
   ASecondaryHashAndInitVal := b;
@@ -286,8 +316,45 @@ var
   k16: ^UInt16 absolute AKey;
   k8: ^UInt8 absolute AKey;
 
+{$IFNDEF NOGOTO}
 label _10, _8, _6, _4, _2;
 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
+{$endif}
+
+{$IFDEF NOGOTO}
+  procedure Do10; inline;
+
+  begin
+    c+=k16[4];
+    b+=k16[2]+((UInt32(k16[3])) shl 16);
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do8; inline;
+
+  begin
+    b+=k16[2]+((UInt32(k16[3])) shl 16);
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do6; inline;
+
+  begin
+    b+=k16[2];
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do4; inline;
+
+  begin
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do2; inline;
+  begin
+    a+=k16[0];
+  end;
+{$ENDIF}
 
 begin
   a := $DEADBEEF + UInt32(ALength) + AInitVal;
@@ -346,51 +413,96 @@ begin
       11:
         begin
           c+=(UInt32(k8[10])) shl 16;     //* fall through */
+{$IFDEF NOGOTO}
+          do10;
+{$ELSE}
           goto _10;
+{$ENDIF}
         end;
       10:
-        begin _10:
+        begin
+{$IFDEF NOGOTO}
+          do10;
+{$ELSE}
+          _10:
           c+=k16[4];
           b+=k16[2]+((UInt32(k16[3])) shl 16);
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       9 :
         begin
           c+=k8[8];                      //* fall through */
+{$IFDEF NOGOTO}
+          do8;
+{$ELSE}
           goto _8;
+{$ENDIF}
         end;
       8 :
-        begin _8:
+        begin
+{$IFDEF NOGOTO}
+          do8;
+{$ELSE}
+          _8:
           b+=k16[2]+((UInt32(k16[3])) shl 16);
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       7 :
         begin
           b+=(UInt32(k8[6])) shl 16;      //* fall through */
+{$IFDEF NOGOTO}
+          Do6 ;
+{$ELSE}
           goto _6;
+{$ENDIF}
         end;
       6 :
-        begin _6:
+        begin
+{$IFDEF NOGOTO}
+          Do6 ;
+{$ELSE}
+          _6:
           b+=k16[2];
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       5 :
         begin
           b+=k8[4];                      //* fall through */
+{$IFDEF NOGOTO}
+          Do4;
+{$ELSE}
           goto _4;
+{$ENDIF}
         end;
       4 :
-        begin _4:
+        begin
+{$IFDEF NOGOTO}
+          Do4;
+{$ELSE}
+          _4:
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       3 :
         begin
           a+=(UInt32(k8[2])) shl 16;      //* fall through */
+{$IFDEF NOGOTO}
+          do2;
+{$ELSE}
           goto _2;
+{$ENDIF}
         end;
       2 :
-        begin _2:
+        begin
+{$IFDEF NOGOTO}
+          do2;
+{$ELSE}
+         _2:
           a+=k16[0];
+{$ENDIF}
         end;
       1 :
         begin
@@ -420,7 +532,34 @@ begin
       ALength -= 12;
       k8 += 12;
     end;
-
+{$IFDEF NOGOTO}
+  if Alength=0 then
+    Exit(c);
+  if ALength=12 then
+    c+=(UInt32(k8[11])) shl 24;
+  if aLength>=11 then
+    c+=(UInt32(k8[10])) shl 16;
+  if aLength>=10 then
+    c+=(UInt32(k8[9])) shl 8;
+  if aLength>=9 then
+    c+=k8[8];
+  if aLength>=8 then
+    b+=(UInt32(k8[7])) shl 24;
+  if aLength>=7 then
+    b+=(UInt32(k8[6])) shl 16;
+  if aLength>=6 then
+    b+=(UInt32(k8[5])) shl 8;
+  if aLength>=5 then
+    b+=k8[4];
+  if aLength>=4 then
+    a+=(UInt32(k8[3])) shl 24;
+  if aLength>=3 then
+    a+=(UInt32(k8[2])) shl 16;
+  if aLength>=2 then
+    a+=(UInt32(k8[1])) shl 8;
+  // case aLength=0 was handled first, so we know aLength>=1.
+  a+=k8[0];
+{$ELSE}
     case ALength of
       12: goto Case12;
       11: goto Case11;
@@ -449,6 +588,7 @@ begin
     Case3: a+=(UInt32(k8[2])) shl 16;
     Case2: a+=(UInt32(k8[1])) shl 8;
     Case1: a+=k8[0];
+{$ENDIF}
   end;
 
   final_abc;
@@ -481,8 +621,45 @@ var
   k16: ^UInt16 absolute AKey;
   k8: ^UInt8 absolute AKey;
 
+{$IFNDEF NOGOTO}
 label _10, _8, _6, _4, _2;
 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
+{$ENDIF}
+
+{$IFDEF NOGOTO}
+  procedure Do10; inline;
+
+  begin
+    c+=k16[4];
+    b+=k16[2]+((UInt32(k16[3])) shl 16);
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do8; inline;
+
+  begin
+    b+=k16[2]+((UInt32(k16[3])) shl 16);
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do6; inline;
+
+  begin
+    b+=k16[2];
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do4; inline;
+
+  begin
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do2; inline;
+  begin
+    a+=k16[0];
+  end;
+{$ENDIF}
 
 begin
   //* Set up the internal state */
@@ -548,51 +725,96 @@ begin
       11:
         begin
           c+=(UInt32(k8[10])) shl 16;     //* fall through */
-          goto _10;
+{$IFDEF NOGOTO}
+          Do10;
+{$ELSE}
+          goto _10
+{$ENDIF}
         end;
       10:
-        begin _10:
+        begin
+{$IFDEF NOGOTO}
+         Do10;
+{$ELSE}
+        _10:
           c+=k16[4];
           b+=k16[2]+((UInt32(k16[3])) shl 16);
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       9 :
         begin
           c+=k8[8];                      //* fall through */
+{$IFDEF NOGOTO}
+          Do8;
+{$ELSE}
           goto _8;
+{$ENDIF}
         end;
       8 :
-        begin _8:
+        begin
+{$IFDEF NOGOTO}
+          Do8;
+{$ELSE}
+        _8:
           b+=k16[2]+((UInt32(k16[3])) shl 16);
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       7 :
         begin
           b+=(UInt32(k8[6])) shl 16;      //* fall through */
+{$IFDEF NOGOTO}
+          Do6 ;
+{$ELSE}
           goto _6;
+{$ENDIF}
         end;
       6 :
-        begin _6:
+        begin
+{$IFDEF NOGOTO}
+          Do6 ;
+{$ELSE}
+        _6:
           b+=k16[2];
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       5 :
         begin
           b+=k8[4];                      //* fall through */
+{$IFDEF NOGOTO}
+          Do4 ;
+{$ELSE}
           goto _4;
+{$ENDIF}
         end;
       4 :
-        begin _4:
+        begin
+{$IFDEF NOGOTO}
+          Do4 ;
+{$ELSE}
+        _4:
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       3 :
         begin
           a+=(UInt32(k8[2])) shl 16;      //* fall through */
+{$IFDEF NOGOTO}
+          Do2 ;
+{$ELSE}
           goto _2;
+{$ENDIF}
         end;
       2 :
-        begin _2:
+        begin
+{$IFDEF NOGOTO}
+          Do2;
+{$ELSE}
+        _2:
           a+=k16[0];
+{$ENDIF}
         end;
       1 :
         begin
@@ -627,7 +849,37 @@ begin
       ALength -= 12;
       k8 += 12;
     end;
-
+{$IFDEF NOGOTO}
+  if aLength=0 then
+    begin
+    APrimaryHashAndInitVal := c;
+    ASecondaryHashAndInitVal := b;
+    Exit;              // zero length strings require no mixing
+    end;
+  if aLength=12 then
+    c+=(UInt32(k8[11])) shl 24;
+  if aLength>=11 then
+    c+=(UInt32(k8[10])) shl 16;
+  if aLength>=10 then
+    c+=(UInt32(k8[9])) shl 8;
+  if aLength>=9 then
+    c+=k8[8];
+  if aLength>=8 then
+    b+=(UInt32(k8[7])) shl 24;
+  if aLength>=7 then
+    b+=(UInt32(k8[6])) shl 16;
+  if aLength>=6 then
+    b+=(UInt32(k8[5])) shl 8;
+  if aLength>=5 then
+    b+=k8[4];
+  if aLength>=4 then
+    a+=(UInt32(k8[3])) shl 24;
+  if aLength>=3 then
+    a+=(UInt32(k8[2])) shl 16;
+  if aLength>=2 then
+    a+=(UInt32(k8[1])) shl 8;
+  a+=k8[0];
+{$ELSE}
     case ALength of
       12: goto Case12;
       11: goto Case11;
@@ -661,6 +913,7 @@ begin
     Case3: a+=(UInt32(k8[2])) shl 16;
     Case2: a+=(UInt32(k8[1])) shl 8;
     Case1: a+=k8[0];
+{$ENDIF}
   end;
 
   final_abc;
@@ -680,8 +933,45 @@ var
   k16: ^UInt16 absolute AKey;
   k8: ^UInt8 absolute AKey;
 
+{$IFNDEF NOGOTO}
 label _10, _8, _6, _4, _2;
 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
+{$ENDIF}
+
+{$IFDEF NOGOTO}
+  procedure Do10; inline;
+
+  begin
+    c+=k16[4];
+    b+=k16[2]+((UInt32(k16[3])) shl 16);
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do8; inline;
+
+  begin
+    b+=k16[2]+((UInt32(k16[3])) shl 16);
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do6; inline;
+
+  begin
+    b+=k16[2];
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do4; inline;
+
+  begin
+    a+=k16[0]+((UInt32(k16[1])) shl 16);
+  end;
+
+  procedure Do2; inline;
+  begin
+    a+=k16[0];
+  end;
+{$ENDIF}
 
 begin
   //* Set up the internal state */
@@ -747,51 +1037,96 @@ begin
       11:
         begin
           c+=(UInt32(k8[10])) shl 16;     //* fall through */
+{$IFDEF NOGOTO}
+          Do10;
+{$ELSE}
           goto _10;
+{$ENDIF}
         end;
       10:
-        begin _10:
+        begin
+{$IFDEF NOGOTO}
+          Do10;
+{$ELSE}
+        _10:
           c+=k16[4];
           b+=k16[2]+((UInt32(k16[3])) shl 16);
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       9 :
         begin
           c+=k8[8];                      //* fall through */
+{$IFDEF NOGOTO}
+          Do8;
+{$ELSE}
           goto _8;
+{$ENDIF}
         end;
       8 :
-        begin _8:
+        begin
+{$IFDEF NOGOTO}
+          Do8;
+{$ELSE}
+        _8:
           b+=k16[2]+((UInt32(k16[3])) shl 16);
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       7 :
         begin
           b+=(UInt32(k8[6])) shl 16;      //* fall through */
+{$IFDEF NOGOTO}
+          Do6;
+{$ELSE}
           goto _6;
+{$ENDIF}
         end;
       6 :
-        begin _6:
+        begin
+{$IFDEF NOGOTO}
+          Do6;
+{$ELSE}
+        _6:
           b+=k16[2];
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       5 :
         begin
           b+=k8[4];                      //* fall through */
+{$IFDEF NOGOTO}
+          Do4;
+{$ELSE}
           goto _4;
+{$ENDIF}
         end;
       4 :
-        begin _4:
+        begin
+{$IFDEF NOGOTO}
+          Do4;
+{$ELSE}
+        _4:
           a+=k16[0]+((UInt32(k16[1])) shl 16);
+{$ENDIF}
         end;
       3 :
         begin
           a+=(UInt32(k8[2])) shl 16;      //* fall through */
+{$IFDEF NOGOTO}
+          Do2;
+{$ELSE}
           goto _2;
+{$ENDIF}
         end;
       2 :
-        begin _2:
+        begin
+{$IFDEF NOGOTO}
+          Do2;
+{$ELSE}
+        _2:
           a+=k16[0];
+{$ENDIF}
         end;
       1 :
         begin
@@ -826,7 +1161,38 @@ begin
       ALength -= 12;
       k8 += 12;
     end;
-
+{$IFDEF NOGOTO}
+    if aLength=0 then
+      begin
+      APrimaryHashAndInitVal := c;
+      ASecondaryHashAndInitVal := b;
+      Exit;              // zero length strings require no mixing
+      end;
+    if aLength=12 then
+      c+=(UInt32(k8[11])) shl 24;
+    if aLength>=11 then
+      c+=(UInt32(k8[10])) shl 16;
+    if aLength>=10 then
+      c+=(UInt32(k8[9])) shl 8;
+    if aLength>=9 then
+      c+=k8[8];
+    if aLength>=8 then
+      b+=(UInt32(k8[7])) shl 24;
+    if aLength>=7 then
+      b+=(UInt32(k8[6])) shl 16;
+    if aLength>=6 then
+      b+=(UInt32(k8[5])) shl 8;
+    if aLength>=5 then
+      b+=k8[4];
+    if aLength>=4 then
+      a+=(UInt32(k8[3])) shl 24;
+    if aLength>=3 then
+      a+=(UInt32(k8[2])) shl 16;
+    if aLength>=2 then
+      a+=(UInt32(k8[1])) shl 8;
+    a+=k8[0];
+
+{$ELSE}
     case ALength of
       12: goto Case12;
       11: goto Case11;
@@ -860,6 +1226,7 @@ begin
     Case3: a+=(UInt32(k8[2])) shl 16;
     Case2: a+=(UInt32(k8[1])) shl 8;
     Case1: a+=k8[0];
+{$ENDIF}
   end;
 
   final_abc;
@@ -879,7 +1246,9 @@ var
   //k16: ^UInt16 absolute AKey;
   k8: ^UInt8 absolute AKey;
 
+{$IFNDEF NOGOTO}
 label Case12, Case11, Case10, Case9, Case8, Case7, Case6, Case5, Case4, Case3, Case2, Case1;
+{$ENDIF NOGOTO}
 
 begin
   a := $DEADBEEF + UInt32(ALength shl 2) + AInitVal; // delphi version bug? original version don't have "shl 2"
@@ -936,7 +1305,34 @@ begin
       ALength -= 12;
       k8 += 12;
     end;
-
+{$IFDEF NOGOTO}
+  if aLength=0 then
+    exit(c);
+  if aLength=12 then
+    c+=(UInt32(k8[11])) shl 24;
+  if aLength>=11 then
+    c+=(UInt32(k8[10])) shl 16;
+  if aLength>=10 then
+    c+=(UInt32(k8[9])) shl 8;
+  if aLength>=9 then
+    c+=k8[8];
+  if aLength>=8 then
+    b+=(UInt32(k8[7])) shl 24;
+  if aLength>=7 then
+    b+=(UInt32(k8[6])) shl 16;
+  if aLength>=6 then
+    b+=(UInt32(k8[5])) shl 8;
+  if aLength>=5 then
+    b+=k8[4];
+  if aLength>=4 then
+    a+=(UInt32(k8[3])) shl 24;
+  if aLength>=3 then
+    a+=(UInt32(k8[2])) shl 16;
+  if aLength>=2 then
+    a+=(UInt32(k8[1])) shl 8;
+  a+=k8[0];
+
+{$ELSE}
     case ALength of
       12: goto Case12;
       11: goto Case11;
@@ -965,6 +1361,7 @@ begin
     Case3: a+=(UInt32(k8[2])) shl 16;
     Case2: a+=(UInt32(k8[1])) shl 8;
     Case1: a+=k8[0];
+{$ENDIF}
   end;
 
   final_abc;

packages/rtl-generics/tests/testrunner.rtlgenerics.pp

@@ -22,6 +22,8 @@ var
   Application: TTestRunner;
 
 begin
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
   Application := TTestRunner.Create(nil);
   Application.Initialize;
   Application.Title := 'RTL-Generics unit tests';

packages/rtl-generics/tests/tests.generics.dictionary.pas

@@ -175,7 +175,7 @@ end;
 
 procedure TTestSimpleDictionary.DoKeyNotify(ASender: TObject; const AItem: Integer; AAction: TCollectionNotification);
 begin
-  Writeln(FnotifyMessage+' Notification',FCurrentKeyNotify);
+  Writeln(FnotifyMessage+' Notification ',FCurrentKeyNotify);
   AssertSame(FnotifyMessage+' Correct sender', FDict,aSender);
   if (FCurrentKeyNotify>=Length(FExpectKeys)) then
     Fail(FnotifyMessage+' Too many notificiations');
@@ -185,7 +185,7 @@ end;
 
 procedure TTestSimpleDictionary.DoValueNotify(ASender: TObject; const AItem: String; AAction: TCollectionNotification);
 begin
-  Writeln(FnotifyMessage+' value Notification',FCurrentValueNotify);
+  Writeln(FnotifyMessage+' value Notification ',FCurrentValueNotify);
   AssertSame(FnotifyMessage+' value Correct sender', FDict,aSender);
   if (FCurrentValueNotify>=Length(FExpectValues)) then
     Fail(FnotifyMessage+' Too many value notificiations');
@@ -449,12 +449,24 @@ begin
   DoneExpectKeys;
 end;
 
+Const
+{$IFDEF FPC}
+  {$IFNDEF CPUWASM}
+    ReverseDeleteNotification = True;
+  {$ElSE}
+    ReverseDeleteNotification = False;
+  {$ENDIF}
+{$ELSE}
+   ReverseDeleteNotification = False;
+{$ENDIF}
+
 procedure TTestSimpleDictionary.TestNotificationDelete;
 
+
 begin
   DoAdd(3);
   Dict.OnKeyNotify:=@DoKeyNotify;
-  SetExpectKeys('Clear',[1,2,3],[cnRemoved,cnRemoved,cnRemoved],{$IFDEF FPC}true{$ELSE}False{$endif});
+  SetExpectKeys('Clear',[1,2,3],[cnRemoved,cnRemoved,cnRemoved],ReverseDeleteNotification);
   Dict.Clear;
   DoneExpectKeys;
 end;
@@ -471,7 +483,7 @@ procedure TTestSimpleDictionary.TestValueNotificationDelete;
 begin
   DoAdd(3);
   Dict.OnValueNotify:=@DoValueNotify;
-  SetExpectValues('Clear',['1','2','3'],[cnRemoved,cnRemoved,cnRemoved],{$IFDEF FPC}true{$ELSE}False{$endif});
+  SetExpectValues('Clear',['1','2','3'],[cnRemoved,cnRemoved,cnRemoved],ReverseDeleteNotification);
   Dict.Clear;
   DoneExpectValues;
 end;

rtl/inc/objpas.inc

@@ -1224,6 +1224,28 @@
       FName:=aName;
     end;
 
+{****************************************************************************
+                             TInterfaceThunk
+****************************************************************************}
+
+Constructor TInterfaceThunk.Create(aCallback : TThunkCallback);
+
+begin
+  FCallBack:=aCallBack;
+end;
+
+Procedure TInterfaceThunk.Thunk(aMethod: Longint; aCount : Longint; aData : PArgData);
+
+begin
+  if Assigned(FCallBack) then
+    FCallBack(Self,aMethod,aCount,aData); 
+end;
+
+function TInterfaceThunk.InterfaceVMTOffset : word;
+
+begin
+  Result:=0;
+end;
 
 {****************************************************************************
                              Exception Support

rtl/inc/objpash.inc

@@ -340,7 +340,28 @@
            function _AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
            function _Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
        end;
-                   
+
+       
+       TInterfaceThunk = Class(TInterfacedObject)
+       Public
+         Type
+           TArgData = record
+             addr : pointer;   // Location
+             info : pointer;   // type info (if available: nil for untyped args)
+             idx  : smallint;  // param index in rtti
+             ahigh : sizeint;  // For open arrays, high()
+           end;
+           PArgData = ^TargData;
+         TThunkCallBack = Procedure(aInstance: Pointer; aMethod,aCount : Longint; aData : PArgData) of object;
+       Private  
+         FCallback : TThunkCallback;
+       Protected  
+         Procedure Thunk(aMethod: Longint; aCount : Longint; aData : PArgData); virtual;
+       Public  
+         constructor create(aCallBack : TThunkCallback);
+         function InterfaceVMTOffset : word; virtual;
+       end;  
+       TInterfaceThunkClass = class of TInterfaceThunk;
 
        { some pointer definitions }
        PUnknown = ^IUnknown;

rtl/objpas/typinfo.pp

@@ -515,6 +515,7 @@ unit TypInfo;
           Parent: PPTypeInfo;
           Flags: TIntfFlagsBase;
           GUID: TGUID;
+          ThunkClass : PPTypeInfo;
           UnitNameField: ShortString;
           { PropertyTable: TPropData }
           { MethodTable: TIntfMethodTable }
@@ -555,6 +556,7 @@ unit TypInfo;
             Parent: PPTypeInfo;
             Flags : TIntfFlagsBase;
             IID: TGUID;
+            ThunkClass : PPTypeInfo;
             UnitNameField: ShortString;
             { IIDStr: ShortString; }
             { PropertyTable: TPropData }
@@ -756,6 +758,7 @@ unit TypInfo;
                IntfParentRef: TypeInfoPtr;
                IntfFlags : TIntfFlagsBase;
                GUID: TGUID;
+               ThunkClass : PPTypeInfo;
                IntfUnit: ShortString;
                { PropertyTable: TPropData }
                { MethodTable: TIntfMethodTable }
@@ -765,6 +768,7 @@ unit TypInfo;
                RawIntfParentRef: TypeInfoPtr;
                RawIntfFlags : TIntfFlagsBase;
                IID: TGUID;
+               RawThunkClass : PPTypeInfo;
                RawIntfUnit: ShortString;
                { IIDStr: ShortString; }
                { PropertyTable: TPropData }

tests/test/trtti15.pp

@@ -183,8 +183,10 @@ const
 begin
   Writeln('Testing interface ITestRaw');
   { raw interfaces don't support $M+ currently }
-  TestInterface(GetTypeData(TypeInfo(ITestRaw)), True, 'Test', 0{1}, [
-      MakeMethod('Test', ccReg, mkFunction, TypeInfo(LongInt), [])
+  TestInterface(GetTypeData(TypeInfo(ITestRaw)), True, 'Test',1, [
+      MakeMethod('Test', ccReg, mkFunction, TypeInfo(LongInt), [
+      MakeParam('$self', [pfHidden, pfSelf, pfAddress], TypeInfo(ITestRaw))
+      ])
     ]);
 
   Writeln('Testing interface ITest');

tests/test/tthunkcl1.pp

@@ -0,0 +1,137 @@
+{ %CPU=wasm32 }
+program tthunkcl1;
+
+{$mode objfpc}
+{$h+}
+
+uses sysutils, typinfo, uthintf;
+
+Type
+
+  { TTestThunk }
+
+  TTestThunk = class(TObject)
+  private
+    FOffset : integer;
+    FExpectMethod,
+    FExpectArgInt : Integer;
+    FExpectCount : Integer;
+    FExpectResult : Boolean;
+    FReturnResultInt : Integer;
+    FExpectArgTypeInfo : TTypeKind;
+    FExpectResultTypeInfo : TTypeKind;
+    FTest : String;
+    Procedure AssertEquals(Msg : string; aExpect,aActual : Integer);
+    Procedure AssertTrue(Msg : string; aValue : Boolean);
+    Procedure AssertNotNull(Msg : string; aValue : Pointer);
+    procedure ThunkCallBack(aInstance: Pointer; aMethod, aCount: Longint; aData : TInterfaceThunk.PArgData);
+  Public
+    Procedure DoTest;
+  end;
+
+procedure TTestThunk.AssertEquals(Msg: string; aExpect, aActual: Integer);
+begin
+  AssertTrue(Msg+': '+IntToStr(aExpect)+'<>'+IntToStr(aActual),aExpect=aActual);
+end;
+
+procedure TTestThunk.AssertTrue(Msg: string; aValue: Boolean);
+begin
+  if not aValue then
+    begin
+    Writeln(FTest+' failed: ',Msg);
+    Halt(1);
+    end;
+end;
+
+procedure TTestThunk.AssertNotNull(Msg: string; aValue: Pointer);
+begin
+  AssertTrue(Msg+': not null',Assigned(aValue));
+end;
+
+procedure TTestThunk.ThunkCallBack(aInstance: Pointer; aMethod,
+  aCount: Longint; aData : TInterfaceThunk.PargData);
+
+begin
+  AssertEquals('Correct method called',FOffset+FExpectMethod,aMethod);
+  AssertEquals('Correct argument count',FExpectCount,aCount);
+  AssertTrue('Have result',Assigned(aData[0].addr)=FExpectResult);
+  if ACount>0 then
+    begin
+    AssertTrue('Have arg 0 type info',Assigned(aData[1].info));
+    AssertTrue('Have arg 0 correct type info',PTypeInfo(aData[1].Info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectArgTypeInfo of
+      tkInteger: AssertEquals('Correct arg 0 integer argument value ',FExpectArgInt,PInteger(aData[1].addr)^);
+    end;
+    end;
+ if FExpectResult then
+    begin
+    AssertTrue('Have correct result type info',PTypeInfo(aData[0].info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectResultTypeInfo of
+      tkInteger: PInteger(aData[0].addr)^:=FReturnResultInt;
+    end;
+    end;
+end;
+
+procedure TTestThunk.DoTest;
+
+var
+  PI,PC : PTypeInfo;
+  PT : PTypeData;
+  I : TMyInterface;
+  TT : TInterfaceThunk;
+  TC : TInterfaceThunkClass;
+  R : Integer;
+
+begin
+  PI:=TypeInfo(TMyInterface);
+  AssertNotNull('Type info',PI);
+  PT:=GetTypeData(PI);
+  AssertNotNull('Type data ',PT);
+  AssertNotNull('Thunk class',PInterfaceData(PT)^.ThunkClass);
+  PC:=PInterfaceData(PT)^.ThunkClass^;
+  TC:=TInterfaceThunkClass(GetTypeData(PC)^.ClassType);
+  TT:=TC.create(@ThunkCallBack);
+  FOffset:=TT.InterfaceVMTOffset;
+  I:=TT as TMyInterface;
+  FTest:='DoA1';
+  FExpectMethod:=0; 
+  FExpectCount:=1;
+  FExpectResult:=False;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=12;
+  I.DoA(12);
+  FTest:='DoA2';
+  FExpectMethod:=1;
+  FExpectCount:=0;
+  FExpectResult:=False;
+  I.DoA;
+  FTest:='DoB';
+  FExpectMethod:=2;
+  FExpectCount:=0;
+  FExpectResult:=True;
+  FReturnResultint:=42;
+  FExpectResultTypeInfo:=tkInteger;
+  R:=I.DoB;
+  AssertEquals('Result',FReturnResultint,R);
+  FTest:='DoC';
+  FExpectMethod:=3;
+  FExpectCount:=1;
+  FExpectResult:=True;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=41;
+  FExpectResultTypeInfo:=tkInteger;
+  FReturnResultInt:=43;
+  R:=I.DoC(41);
+  AssertEquals('Result',FReturnResultint,R);
+  Writeln('All OK');
+end;
+
+begin
+  With TTestThunk.Create do
+   try
+     DoTest;
+   finally
+     Free;
+   end;
+end.
+

tests/test/tthunkcl2.pp

@@ -0,0 +1,133 @@
+{ %CPU=wasm32 }
+program tthunkcl2;
+
+{$mode objfpc}
+{$h+}
+
+uses sysutils, typinfo, uthintfn;
+
+Type
+
+  { TTestThunk }
+
+  TTestThunk = class(TObject)
+  private
+    FExpectMethod,
+    FExpectArgInt : Integer;
+    FExpectCount : Integer;
+    FExpectResult : Boolean;
+    FReturnResultInt : Integer;
+    FExpectArgTypeInfo : TTypeKind;
+    FExpectResultTypeInfo : TTypeKind;
+    FTest : String;
+    Procedure AssertEquals(Msg : string; aExpect,aActual : Integer);
+    Procedure AssertTrue(Msg : string; aValue : Boolean);
+    Procedure AssertNotNull(Msg : string; aValue : Pointer);
+    procedure ThunkCallBack(aInstance: Pointer; aMethod, aCount: Longint; aData : TInterfaceThunk.PargData);
+  Public
+    Procedure DoTest;
+  end;
+
+procedure TTestThunk.AssertEquals(Msg: string; aExpect, aActual: Integer);
+begin
+  AssertTrue(Msg+': '+IntToStr(aExpect)+'<>'+IntToStr(aActual),aExpect=aActual);
+end;
+
+procedure TTestThunk.AssertTrue(Msg: string; aValue: Boolean);
+begin
+  if not aValue then
+    begin
+    Writeln(FTest+' failed: ',Msg);
+    Halt(1);
+    end;
+end;
+
+procedure TTestThunk.AssertNotNull(Msg: string; aValue: Pointer);
+begin
+  AssertTrue(Msg+': not null',Assigned(aValue));
+end;
+
+procedure TTestThunk.ThunkCallBack(aInstance: Pointer; aMethod,
+  aCount: Longint; aData : TInterfaceThunk.PArgData);
+
+begin
+  AssertEquals('Correct method called',FExpectMethod,aMethod);
+  AssertEquals('Correct argument count',FExpectMethod,aMethod);
+  AssertTrue('Have result',Assigned(aData[0].Addr)=FExpectResult);
+  if ACount>0 then
+    begin
+    AssertTrue('Have arg 0 type info',Assigned(adata[1].info));
+    AssertTrue('Have arg 0 correct type info',PTypeInfo(aData[1].Info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectArgTypeInfo of
+      tkInteger: AssertEquals('Correct arg 0 integer argument value ',FExpectArgInt,PInteger(aData[1].addr)^);
+    end;
+    end;
+ if FExpectResult then
+    begin
+    AssertTrue('Have correct result type info',PTypeInfo(aData[0].info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectResultTypeInfo of
+      tkInteger: PInteger(aData[0].addr)^:=FReturnResultInt;
+    end;
+    end;
+end;
+
+procedure TTestThunk.DoTest;
+
+var
+  PI,PC : PTypeInfo;
+  PT : PTypeData;
+  I : TNested.TMyInterface;
+  TC : TInterfaceThunkClass;
+  R : Integer;
+
+begin
+  PI:=TypeInfo(TNested.TMyInterface);
+  AssertNotNull('Type info',PI);
+  PT:=GetTypeData(PI);
+  AssertNotNull('Type data ',PT);
+  AssertNotNull('Thunk class',PInterfaceData(PT)^.ThunkClass);
+  PC:=PInterfaceData(PT)^.ThunkClass^;
+  TC:=TInterfaceThunkClass(GetTypeData(PC)^.ClassType);
+  I:=TC.create(@ThunkCallBack) as TNested.TMyInterface;
+  FTest:='DoA1';
+  FExpectMethod:=3; // Skip 0..2, part of IInterface.
+  FExpectCount:=1;
+  FExpectResult:=False;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=12;
+  I.DoA(12);
+  FTest:='DoA2';
+  FExpectMethod:=4;
+  FExpectCount:=0;
+  FExpectResult:=False;
+  I.DoA;
+  FTest:='DoB';
+  FExpectMethod:=5;
+  FExpectCount:=0;
+  FExpectResult:=True;
+  FReturnResultint:=42;
+  FExpectResultTypeInfo:=tkInteger;
+  R:=I.DoB;
+  AssertEquals('Result',FReturnResultint,R);
+  FTest:='DoC';
+  FExpectMethod:=6;
+  FExpectCount:=1;
+  FExpectResult:=True;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=41;
+  FExpectResultTypeInfo:=tkInteger;
+  FReturnResultInt:=43;
+  R:=I.DoC(41);
+  AssertEquals('Result',FReturnResultint,R);
+  Writeln('All OK');
+end;
+
+begin
+  With TTestThunk.Create do
+   try
+     DoTest;
+   finally
+     Free;
+   end;
+end.
+

tests/test/tthunkcl3.pp

@@ -0,0 +1,140 @@
+{ %CPU=wasm32 }
+program tthunkcl3;
+
+{$mode objfpc}
+{$h+}
+
+uses sysutils, typinfo;
+
+Type
+  {$M+}
+  TMyInterface = Interface ['{76DC0D03-376C-45AA-9E0C-B3546B0C7208}']
+    Procedure DoA(a : Integer);
+    Procedure DoA;
+    function doB : Integer;
+    function doc(a : integer) : integer;
+  end;
+
+  { TTestThunk }
+
+  TTestThunk = class(TObject)
+  private
+    FExpectMethod,
+    FExpectArgInt : Integer;
+    FExpectCount : Integer;
+    FExpectResult : Boolean;
+    FReturnResultInt : Integer;
+    FExpectArgTypeInfo : TTypeKind;
+    FExpectResultTypeInfo : TTypeKind;
+    FTest : String;
+    Procedure AssertEquals(Msg : string; aExpect,aActual : Integer);
+    Procedure AssertTrue(Msg : string; aValue : Boolean);
+    Procedure AssertNotNull(Msg : string; aValue : Pointer);
+    procedure ThunkCallBack(aInstance: Pointer; aMethod, aCount: Longint; aData : TInterfaceThunk.PargData);
+  Public
+    Procedure DoTest;
+  end;
+
+procedure TTestThunk.AssertEquals(Msg: string; aExpect, aActual: Integer);
+begin
+  AssertTrue(Msg+': '+IntToStr(aExpect)+'<>'+IntToStr(aActual),aExpect=aActual);
+end;
+
+procedure TTestThunk.AssertTrue(Msg: string; aValue: Boolean);
+begin
+  if not aValue then
+    begin
+    Writeln(FTest+' failed: ',Msg);
+    Halt(1);
+    end;
+end;
+
+procedure TTestThunk.AssertNotNull(Msg: string; aValue: Pointer);
+begin
+  AssertTrue(Msg+': not null',Assigned(aValue));
+end;
+
+procedure TTestThunk.ThunkCallBack(aInstance: Pointer; aMethod,
+  aCount: Longint; aData : TInterfaceThunk.PargData);
+
+begin
+  AssertEquals('Correct method called',FExpectMethod,aMethod);
+  AssertEquals('Correct argument count',FExpectMethod,aMethod);
+  AssertTrue('Have result',Assigned(aData[0].Addr)=FExpectResult);
+  if ACount>0 then
+    begin
+    AssertTrue('Have arg 0 type info',Assigned(aData[1].info));
+    AssertTrue('Have arg 0 correct type info',PTypeInfo(aData[1].info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectArgTypeInfo of
+      tkInteger: AssertEquals('Correct arg 0 integer argument value ',FExpectArgInt,PInteger(aData[1].Addr)^);
+    end;
+    end;
+ if FExpectResult then
+    begin
+    AssertTrue('Have correct result type info',PTypeInfo(aData[0].info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectResultTypeInfo of
+      tkInteger: PInteger(aData[0].addr)^:=FReturnResultInt;
+    end;
+    end;
+end;
+
+procedure TTestThunk.DoTest;
+
+var
+  PI,PC : PTypeInfo;
+  PT : PTypeData;
+  I : TMyInterface;
+  TC : TInterfaceThunkClass;
+  R : Integer;
+
+begin
+  PI:=TypeInfo(TMyInterface);
+  AssertNotNull('Type info',PI);
+  PT:=GetTypeData(PI);
+  AssertNotNull('Type data ',PT);
+  AssertNotNull('Thunk class',PInterfaceData(PT)^.ThunkClass);
+  PC:=PInterfaceData(PT)^.ThunkClass^;
+  TC:=TInterfaceThunkClass(GetTypeData(PC)^.ClassType);
+  I:=TC.create(@ThunkCallBack) as TMyInterface;
+  FTest:='DoA1';
+  FExpectMethod:=3; // Skip 0..2, part of IInterface.
+  FExpectCount:=1;
+  FExpectResult:=False;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=12;
+  I.DoA(12);
+  FTest:='DoA2';
+  FExpectMethod:=4;
+  FExpectCount:=0;
+  FExpectResult:=False;
+  I.DoA;
+  FTest:='DoB';
+  FExpectMethod:=5;
+  FExpectCount:=0;
+  FExpectResult:=True;
+  FReturnResultint:=42;
+  FExpectResultTypeInfo:=tkInteger;
+  R:=I.DoB;
+  AssertEquals('Result',FReturnResultint,R);
+  FTest:='DoC';
+  FExpectMethod:=6;
+  FExpectCount:=1;
+  FExpectResult:=True;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=41;
+  FExpectResultTypeInfo:=tkInteger;
+  FReturnResultInt:=43;
+  R:=I.DoC(41);
+  AssertEquals('Result',FReturnResultint,R);
+  Writeln('All OK');
+end;
+
+begin
+  With TTestThunk.Create do
+   try
+     DoTest;
+   finally
+     Free;
+   end;
+end.
+

tests/test/tthunkcl4.pp

@@ -0,0 +1,133 @@
+{ %CPU=wasm32 }
+program tthunkcl4;
+
+{$mode objfpc}
+{$h+}
+
+uses sysutils, typinfo, uthintfr;
+
+Type
+
+  { TTestThunk }
+
+  TTestThunk = class(TObject)
+  private
+    FExpectMethod,
+    FExpectArgInt : Integer;
+    FExpectCount : Integer;
+    FExpectResult : Boolean;
+    FReturnResultInt : Integer;
+    FExpectArgTypeInfo : TTypeKind;
+    FExpectResultTypeInfo : TTypeKind;
+    FTest : String;
+    Procedure AssertEquals(Msg : string; aExpect,aActual : Integer);
+    Procedure AssertTrue(Msg : string; aValue : Boolean);
+    Procedure AssertNotNull(Msg : string; aValue : Pointer);
+    procedure ThunkCallBack(aInstance: Pointer; aMethod, aCount: Longint; aData : TInterfaceThunk.PargData);
+  Public
+    Procedure DoTest;
+  end;
+
+procedure TTestThunk.AssertEquals(Msg: string; aExpect, aActual: Integer);
+begin
+  AssertTrue(Msg+': '+IntToStr(aExpect)+'<>'+IntToStr(aActual),aExpect=aActual);
+end;
+
+procedure TTestThunk.AssertTrue(Msg: string; aValue: Boolean);
+begin
+  if not aValue then
+    begin
+    Writeln(FTest+' failed: ',Msg);
+    Halt(1);
+    end;
+end;
+
+procedure TTestThunk.AssertNotNull(Msg: string; aValue: Pointer);
+begin
+  AssertTrue(Msg+': not null',Assigned(aValue));
+end;
+
+procedure TTestThunk.ThunkCallBack(aInstance: Pointer; aMethod,
+  aCount: Longint; aData  : TInterfaceThunk.PargData);
+
+begin
+  AssertEquals('Correct method called',FExpectMethod,aMethod);
+  AssertEquals('Correct argument count',FExpectMethod,aMethod);
+  AssertTrue('Have result',Assigned(aData[0].addr)=FExpectResult);
+  if ACount>0 then
+    begin
+    AssertTrue('Have arg 0 type info',Assigned(adata[1].info));
+    AssertTrue('Have arg 0 correct type info',PTypeInfo(adata[1].info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectArgTypeInfo of
+      tkInteger: AssertEquals('Correct arg 0 integer argument value ',FExpectArgInt,PInteger(aData[1].addr)^);
+    end;
+    end;
+ if FExpectResult then
+    begin
+    AssertTrue('Have correct result type info',PTypeInfo(aData[0].info)^.Kind=FExpectArgTypeInfo);
+    Case FExpectResultTypeInfo of
+      tkInteger: PInteger(aData[0].Addr)^:=FReturnResultInt;
+    end;
+    end;
+end;
+
+procedure TTestThunk.DoTest;
+
+var
+  PI,PC : PTypeInfo;
+  PT : PTypeData;
+  I : TMyInterface;
+  TC : TInterfaceThunkClass;
+  R : Integer;
+
+begin
+  PI:=TypeInfo(TMyInterface);
+  AssertNotNull('Type info',PI);
+  PT:=GetTypeData(PI);
+  AssertNotNull('Type data ',PT);
+  AssertNotNull('Thunk class',PInterfaceData(PT)^.ThunkClass);
+  PC:=PInterfaceData(PT)^.ThunkClass^;
+  TC:=TInterfaceThunkClass(GetTypeData(PC)^.ClassType);
+  I:=TC.create(@ThunkCallBack) as TMyInterface;
+  FTest:='DoA1';
+  FExpectMethod:=0; // no IInterface, so start at 0.
+  FExpectCount:=1;
+  FExpectResult:=False;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=12;
+  I.DoA(12);
+  FTest:='DoA2';
+  FExpectMethod:=1;
+  FExpectCount:=0;
+  FExpectResult:=False;
+  I.DoA;
+  FTest:='DoB';
+  FExpectMethod:=2;
+  FExpectCount:=0;
+  FExpectResult:=True;
+  FReturnResultint:=42;
+  FExpectResultTypeInfo:=tkInteger;
+  R:=I.DoB;
+  AssertEquals('Result',FReturnResultint,R);
+  FTest:='DoC';
+  FExpectMethod:=3;
+  FExpectCount:=1;
+  FExpectResult:=True;
+  FExpectArgTypeInfo:=tkInteger;
+  FExpectArgInt:=41;
+  FExpectResultTypeInfo:=tkInteger;
+  FReturnResultInt:=43;
+  R:=I.DoC(41);
+  AssertEquals('Result',FReturnResultint,R);
+  Writeln('All OK');
+end;
+
+begin
+  With TTestThunk.Create do
+   try
+     DoTest;
+   finally
+     Free;
+   end;
+end.
+

tests/test/uthintf.pp

@@ -0,0 +1,63 @@
+{ %CPU=wasm32 }
+Unit uthintf;
+
+{$mode objfpc}
+{$h+}
+
+interface
+
+
+type
+  TArgdata = record
+    toto : string;
+  end;
+  
+  {$M+}
+  TMyInterface = Interface ['{76DC0D03-376C-45AA-9E0C-B3546B0C7208}']
+    Procedure DoA(a : Integer);
+    Procedure DoA;
+    function doB : Integer;
+    function doc(a : integer) : integer;
+    procedure DoD(var p);
+    procedure DoE(data : TargData);
+  end;
+
+  ITestInterface = interface
+    ['{1DE799BB-BEE9-405F-9AF3-D55DE978C793}']
+    procedure TestMethod1;
+    function  TestMethod2(aArg1: SizeInt): SizeInt;
+    procedure TestMethod3(aArg1: AnsiString);
+    procedure TestMethod4(aArg1: ShortString);
+    function  TestMethod5: AnsiString;
+    function  TestMethod6: ShortString;
+    procedure TestMethod7(aArg1: SizeInt; var aArg2: SizeInt; out aArg3: SizeInt; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: SizeInt);
+    procedure TestMethod8(aArg1: AnsiString; var aArg2: AnsiString; out aArg3: AnsiString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: AnsiString);
+    procedure TestMethod9(aArg1: ShortString; var aArg2: ShortString; out aArg3: ShortString; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: ShortString);
+    procedure TestMethod10(aArg1: Single; var aArg2: Single; out aArg3: Single; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Single);
+    procedure TestMethod11(aArg1: Double; var aArg2: Double; out aArg3: Double; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Double);
+    procedure TestMethod12(aArg1: Extended; var aArg2: Extended; out aArg3: Extended; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Extended);
+    procedure TestMethod13(aArg1: Comp; var aArg2: Comp; out aArg3: Comp; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Comp);
+    procedure TestMethod14(aArg1: Currency; var aArg2: Currency; out aArg3: Currency; {$ifdef fpc}constref{$else}const [ref]{$endif}aArg4: Currency);
+    function  TestMethod15(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: SizeInt): SizeInt;
+    function  TestMethod16(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Single): Single;
+    function  TestMethod17(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Double): Double;
+    function  TestMethod18(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Extended): Extended;
+    function  TestMethod19(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Comp): Comp;
+    function  TestMethod20(aArg1, aArg2, aArg3, aArg4, aArg5, aArg6, aArg7, aArg8, aArg9, aArg10: Currency): Currency;
+    procedure TestMethod21(var aArg1; out aArg2; const aArg3; {$ifdef fpc}constref{$else}const [ref]{$endif} aArg4);
+  end;
+
+ ITestInterface2 = interface
+    procedure Test;
+    function Test2: LongInt;
+    procedure Test3(aArg1: LongInt; const aArg2: AnsiString; var aArg3: Boolean; out aArg4: Word);
+    function Test4(aArg1: array of LongInt; aArg2: array of const): AnsiString;
+  end;
+
+  
+implementation
+
+end.  
+  
+  
+  

tests/test/uthintfn.pp

@@ -0,0 +1,28 @@
+{ %CPU=wasm32 }
+Unit uthintfn;
+
+{$mode objfpc}
+{$h+}
+
+interface
+
+
+type
+  {$M+}
+  TNested = class
+    Type
+      TMyInterface = Interface ['{76DC0D03-376C-45AA-9E0C-B3546B0C7208}']
+        Procedure DoA(a : Integer);
+        Procedure DoA;
+        function doB : Integer;
+        function doc(a : integer) : integer;
+      end;
+  end;
+ 
+  
+implementation
+
+end.  
+  
+  
+  

tests/test/uthintfr.pp

@@ -0,0 +1,26 @@
+{ %CPU=wasm32 }
+Unit uthintfr;
+
+{$mode objfpc}
+{$h+}
+{$interfaces corba}
+
+interface
+
+
+type
+  {$M+}
+  TMyInterface = Interface ['{76DC0D03-376C-45AA-9E0C-B3546B0C7208}']
+    Procedure DoA(a : Integer);
+    Procedure DoA;
+    function doB : Integer;
+    function doc(a : integer) : integer;
+  end;
+
+ 
+implementation
+
+end.  
+  
+  
+