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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
{
This program tries to test any aspect of procedure variables and related
stuff in FPC mode
}
{$ifdef go32v2}
uses
dpmiexcp;
{$endif go32v2}
Type
TMyRecord = Record
MyProc1,MyProc2 : Procedure(l : longint);
MyVar : longint;
end;
procedure do_error(i : longint);
begin
writeln('Error near: ',i);
halt(1);
end;
var
globalvar : longint;
type
tpoo_rec = record
procpointer : pointer;
s : pointer;
end;
procedure callmethodparam(s : pointer;addr : pointer;param : longint);
var
p : procedure(param : longint) of object;
begin
tpoo_rec(p).procpointer:=addr;
tpoo_rec(p).s:=s;
p(param);
end;
type
to1 = object
constructor init;
procedure test1;
procedure test2(l : longint);
procedure test3(l : longint);virtual;abstract;
end;
to2 = object(to1)
procedure test3(l : longint);virtual;
end;
constructor to1.init;
begin
end;
procedure to1.test1;
var
p:pointer;
begin
// useless only a semantic test
p:=@to1.test1;
// this do we use to do some testing
p:=@to1.test2;
globalvar:=0;
callmethodparam(@self,p,1234);
if globalvar<>1234 then
do_error(1000);
end;
procedure to1.test2(l : longint);
begin
globalvar:=l;
end;
procedure to2.test3(l : longint);
begin
globalvar:=l;
end;
procedure testproc(l : longint);
begin
globalvar:=l;
end;
const
constmethodaddr : pointer = @to1.test2;
MyRecord : TMyRecord = (
MyProc1 : @TestProc;
MyProc2 : @TestProc;
MyVar : 0;
);
var
o1 : to1;
o2 : to2;
p : procedure(l : longint) of object;
begin
{ Simple procedure variables }
writeln('Procedure variables');
globalvar:=0;
MyRecord.MyProc1(1234);
if globalvar<>1234 then
do_error(2000);
globalvar:=0;
MyRecord.MyProc2(4321);
if globalvar<>4321 then
do_error(2001);
writeln('Ok');
{ }
{ Procedures of objects }
{ }
o1.init;
o2.init;
writeln('Procedures of objects');
p:=@o1.test2;
globalvar:=0;
p(12);
if globalvar<>12 then
do_error(1002);
writeln('Ok');
p:=@o2.test3;
globalvar:=0;
p(12);
if globalvar<>12 then
do_error(1004);
writeln('Ok');
{ }
{ Pointers and addresses of procedures }
{ }
writeln('Getting an address of a method as pointer');
o1.test1;
globalvar:=0;
callmethodparam(@o1,constmethodaddr,34);
if globalvar<>34 then
do_error(1001);
writeln('Ok');
end.
|
