blob: 995f0f776f0ba4c9a6323765d72ab997d2a4f48a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
{ 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.
|
