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
|
{%skiptarget=$nothread }
{ %target=darwin,linux,freebsd,solaris,haiku,aix }
{$mode objfpc}
uses
cthreads, pthreads, classes, unixtype;
type
tc = class(tthread)
procedure execute;override;
end;
procedure tc.execute;
begin
end;
function threadproc(arg: pointer): pointer; cdecl;
var
p: pointer;
a: ansistring;
begin
setlength(a,4000000);
getmem(p,5);
writeln('hi from thread ',ptruint(arg));
freemem(p);
result:=pointer(ptruint(arg)+10);
end;
var
t1, t2, t3: pthread_t;
res: pointer;
begin
{ initialise threading system }
with tc.create(false) do
begin
waitfor;
free;
end;
if pthread_create(@t1,nil,@threadproc,pointer(1))<>0 then
begin
writeln('error creating 1');
halt(1);
end;
if pthread_create(@t2,nil,@threadproc,pointer(2))<>0 then
begin
writeln('error creating 2');
halt(1);
end;
if pthread_create(@t3,nil,@threadproc,pointer(3))<>0 then
begin
writeln('error creating 3');
halt(1);
end;
if pthread_join(t1,@res)<>0 then
begin
writeln('error joining 1');
halt(1);
end;
if res<>pointer(11) then
begin
writeln('error 1: ',ptruint(res));
halt(1);
end;
if pthread_join(t2,@res)<>0 then
begin
writeln('error joining 1');
halt(1);
end;
if res<>pointer(12) then
begin
writeln('error 2: ',ptruint(res));
halt(2);
end;
if pthread_join(t3,@res)<>0 then
begin
writeln('error joining 1');
halt(1);
end;
if res<>pointer(13) then
begin
writeln('error 3: ',ptruint(res));
halt(3);
end;
end.
|
