blob: d7ae1c260b72577b5d3175a2cd12a888555acf67 (
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
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
{ Source provided for Free Pascal Bug Report 3456 }
{ Submitted by "Ales Katona (Almindor)" on 2004-12-18 }
{ e-mail: ales@chello.sk }
program objtest;
{$ifdef fpc}
{$mode objfpc}
{$endif}
{$ifdef win32}
{$apptype console}
{$endif}
uses
SysUtils;
const
{$if defined(cpusparc) or defined(cpuarm) or defined(go32v2)}
loopcnt = 10000;
{$else}
loopcnt = 1000000;
{$endif}
type TClassRoot = class
public
function Make: TClassRoot; virtual; abstract;
end;
TClassB = class;
TClassA = class(TClassRoot)
private
x: longint;
public
constructor Create;
destructor Destroy; override;
function Make: TClassRoot; override;
end;
TClassB = class(TClassRoot)
private
x: longint;
public
constructor Create;
destructor Destroy; override;
function Make: TClassRoot; override;
end;
constructor TClassA.Create;
begin
x:=1;
end;
destructor TClassA.Destroy;
begin
x:=0;
end;
function TClassA.Make: TClassRoot;
begin
result:=TClassB.Create;
end;
constructor TClassB.Create;
begin
x:=2;
end;
destructor TClassB.Destroy;
begin
x:=0;
end;
function TClassB.Make: TClassRoot;
begin
result:=TClassA.Create;
end;
procedure procb;
var i: longint;
ar: array of TClassRoot;
time: double;
begin
writeln('Array test');
time:=now;
setlength(ar, loopcnt+1);
ar[0]:=TClassA.Create;
for i:=1 to loopcnt do
ar[i]:=ar[i-1].Make;
for i:=0 to loopcnt do
ar[i].free;
time:=now-time;
writeln(time);
end;
var
p : pointer;
begin
{ Add a big memory block to the free osblocks list }
getmem(p,1024*1024);
freemem(p);
{ The small fixed size blocks shall not reuse the big memory block }
procb;
end.
|
