mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-13 08:39:33 +02:00
07bf44517c
the IInterface implementation to be XPCom-compatible --- Merging r15997 through r16179 into '.': U rtl/inc/variants.pp U rtl/inc/objpash.inc U rtl/inc/objpas.inc U rtl/objpas/classes/persist.inc U rtl/objpas/classes/compon.inc U rtl/objpas/classes/classesh.inc A tests/test/tconstref1.pp A tests/test/tconstref2.pp A tests/test/tconstref3.pp U tests/test/tinterface4.pp A tests/test/tconstref4.pp U tests/webtbs/tw10897.pp U tests/webtbs/tw4086.pp U tests/webtbs/tw15363.pp U tests/webtbs/tw2177.pp U tests/webtbs/tw16592.pp U tests/tbs/tb0546.pp U compiler/sparc/cpupara.pas U compiler/i386/cpupara.pas U compiler/pdecsub.pas U compiler/symdef.pas U compiler/powerpc/cpupara.pas U compiler/avr/cpupara.pas U compiler/browcol.pas U compiler/defcmp.pas U compiler/powerpc64/cpupara.pas U compiler/ncgrtti.pas U compiler/x86_64/cpupara.pas U compiler/opttail.pas U compiler/htypechk.pas U compiler/tokens.pas U compiler/objcutil.pas U compiler/ncal.pas U compiler/symtable.pas U compiler/symsym.pas U compiler/m68k/cpupara.pas U compiler/regvars.pas U compiler/arm/cpupara.pas U compiler/symconst.pas U compiler/mips/cpupara.pas U compiler/paramgr.pas U compiler/psub.pas U compiler/pdecvar.pas U compiler/dbgstabs.pas U compiler/options.pas U packages/fcl-fpcunit/src/testutils.pp git-svn-id: trunk@16180 -
84 lines
1.6 KiB
ObjectPascal
84 lines
1.6 KiB
ObjectPascal
{ Source provided for Free Pascal Bug Report 4086 }
|
|
{ Submitted by "Martin Schreiber" on 2005-06-14 }
|
|
{ e-mail: }
|
|
program project1;
|
|
{$ifdef FPC}
|
|
{$mode objfpc}{$H+}
|
|
{$else}
|
|
{$apptype console}
|
|
{$endif}
|
|
|
|
uses
|
|
Classes,SysUtils;
|
|
|
|
type
|
|
|
|
itest = interface
|
|
procedure testproc;
|
|
end;
|
|
|
|
ttestclass1 = class(tobject,itest)
|
|
public
|
|
function queryinterface(constref guid: tguid; out obj): hresult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
function _addref: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
function _release: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
procedure testproc;
|
|
end;
|
|
|
|
ttestclass2 = class
|
|
public
|
|
intf: pointer;
|
|
end;
|
|
|
|
{ ttestclass1 }
|
|
|
|
function ttestclass1.queryinterface(constref guid: tguid; out obj): hresult; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
begin
|
|
result:= integer(e_nointerface);
|
|
end;
|
|
|
|
function ttestclass1._addref: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
begin
|
|
writeln('addref called');
|
|
// result:= inherited _addref;
|
|
result:= -1;
|
|
end;
|
|
|
|
function ttestclass1._release: integer; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};
|
|
begin
|
|
writeln('release called');
|
|
// result:= inherited _release;
|
|
result:= -1;
|
|
end;
|
|
|
|
procedure ttestclass1.testproc;
|
|
begin
|
|
writeln('testproc called');
|
|
end;
|
|
|
|
var
|
|
po1: pointer;
|
|
test1: ttestclass1;
|
|
test2: ttestclass2;
|
|
|
|
procedure test;
|
|
begin
|
|
writeln('*** global variable');
|
|
po1:= pointer(itest(test1));
|
|
itest(po1).testproc;
|
|
writeln('*** object field');
|
|
test2.intf:= pointer(itest(test1));
|
|
itest(test2.intf).testproc;
|
|
|
|
end;
|
|
|
|
begin
|
|
test1:= ttestclass1.create;
|
|
test2:= ttestclass2.create;
|
|
test;
|
|
test1.free;
|
|
test2.free;
|
|
end.
|
|
|
|
|