blob: 24eedfed1ae0dab59e0166524c0225ead89caadf (
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
|
{$mode objfpc}{$H+}
{$define second_test}
type
TTestClass = class of TTestBase;
TTestBase = class(TObject)
public
class function ClassMetadataStr: string;
class function InternalMetadataStr: string; virtual;
end;
TTestImpl = class(TTestBase)
public
class function InternalMetadataStr: string; override;
end;
class function TTestBase.ClassMetadataStr: string;
var
VMetadataMethod, VParentMetadataMethod: function: string of object;
{$ifdef second_test}
VClass: TTestClass;
{$endif}
begin
if Self <> TTestBase then
begin
writeln('pass 1');
VMetadataMethod := @InternalMetadataStr;
writeln('pass 2');
{$ifndef second_test}
VParentMetadataMethod := @TTestClass(ClassParent).InternalMetadataStr;
{$else}
VClass := TTestClass(ClassParent);
writeln('pass 2.1');
VParentMetadataMethod := @VClass.InternalMetadataStr;
{$endif}
writeln('pass 3');
if TMethod(VMetadataMethod).Code <> TMethod(VParentMetadataMethod).Code then
begin
Result := VParentMetadataMethod();
writeln('result: ',result);
if Result<>'parent meth' then
halt(1);
end
else
halt(2);
writeln('pass 4');
end else
Result := 'base result';
end;
class function TTestBase.InternalMetadataStr: string;
begin
Result := 'parent meth';
end;
class function TTestImpl.InternalMetadataStr: string;
begin
Result := 'some stuff';
end;
var
VTestClass: TTestClass;
begin
VTestClass := TTestBase;
writeln('TTestBase result:');
writeln(VTestClass.ClassMetadataStr);
writeln;
VTestClass := TTestImpl;
writeln('TTestImpl result:');
writeln(VTestClass.ClassMetadataStr);
end.
|
