paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 20:09:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* first tthread.synchronize support (merged neli's patches)

Browse Source
This commit is contained in:
marco 2004-12-23 09:42:42 +00:00
parent 8bcd529bca
commit 8019924d4f
6 changed files with 181 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/freebsd/classes.pp
View File

@ -43,18 +43,26 @@ uses
initialization
CommonInit;
{$ifndef ver1_0}
InitCriticalSection(SynchronizeCritSect);
ExecuteEvent := RtlEventCreate;
SynchronizeMethod := nil;
{$endif}
finalization
CommonCleanup;
{$ifndef ver1_0}
if ThreadsInited then
DoneThreads;
DoneCriticalSection(SynchronizeCritSect);
RtlEventDestroy(ExecuteEvent);
{$endif}
end.
{
$Log$
Revision 1.7 2004-01-22 17:11:23 peter
Revision 1.8 2004-12-23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.7 2004/01/22 17:11:23 peter
* classes uses types to import TPoint and TRect
Revision 1.6 2004/01/10 20:13:40 michael

48
rtl/freebsd/tthread.inc
View File

@ -346,6 +346,31 @@ end;
change them completely.
}
var
{ event that happens when gui thread is done executing the method}
ExecuteEvent: PRtlEvent;
{ guard for synchronization variables }
SynchronizeCritSect: TRtlCriticalSection;
{ method to execute }
SynchronizeMethod: TThreadMethod;
{ caught exception in gui thread, to be raised in calling thread }
SynchronizeException: Exception;
procedure CheckSynchronize;
{ assumes being called from GUI thread }
begin
if SynchronizeMethod = nil then
exit;
try
SynchronizeMethod;
except
SynchronizeException := Exception(AcquireExceptionObject);
end;
RtlEventSetEvent(ExecuteEvent);
end;
function SemaphoreInit: Pointer;
begin
SemaphoreInit := GetMem(SizeOf(TFilDes));
@ -594,8 +619,24 @@ begin
end;
procedure TThread.Synchronize(Method: TThreadMethod);
var
LocalSyncException: Exception;
begin
{$TODO someone with more clue of the GUI stuff will have to do this}
if SynchronizeMethodProc = nil then
{ raise some error? }
exit;
EnterCriticalSection(SynchronizeCritSect);
SynchronizeMethod := Method;
SynchronizeException := nil;
SynchronizeMethodProc;
// wait infinitely
RtlEventWaitFor(ExecuteEvent);
SynchronizeMethod := nil;
LocalSyncException := SynchronizeException;
LeaveCriticalSection(SynchronizeCritSect);
if LocalSyncException <> nil then
raise LocalSyncException;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
@ -606,7 +647,10 @@ end;
{
$Log$
Revision 1.9 2004-03-06 01:27:40 marco
Revision 1.10 2004-12-23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.9 2004/03/06 01:27:40 marco
* Somebody forgot to adapt bsd again
Revision 1.8 2004/01/03 12:18:29 marco

14
rtl/linux/classes.pp
View File

@ -48,19 +48,27 @@ uses
initialization
CommonInit;
{$ifndef VER1_0}
InitCriticalSection(SynchronizeCritSect);
ExecuteEvent := RtlEventCreate;
SynchronizeMethod := nil;
{$endif}
finalization
CommonCleanup;
{$ifndef VER1_0}
if ThreadsInited then
DoneThreads;
DoneCriticalSection(SynchronizeCritSect);
RtlEventDestroy(ExecuteEvent);
{$endif}
end.
{
$Log$
Revision 1.5 2004-01-22 17:11:23 peter
Revision 1.6 2004-12-23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.5 2004/01/22 17:11:23 peter
* classes uses types to import TPoint and TRect
Revision 1.4 2004/01/10 19:35:52 michael

51
rtl/linux/tthread.inc
View File

@ -66,6 +66,20 @@
change them completely.
}
var
{ event that happens when gui thread is done executing the method
}
ExecuteEvent: PRtlEvent;
{ guard for synchronization variables }
SynchronizeCritSect: TRtlCriticalSection;
{ method to execute }
SynchronizeMethod: TThreadMethod;
{ caught exception in gui thread, to be raised in calling thread }
SynchronizeException: Exception;
function SemaphoreInit: Pointer;
begin
SemaphoreInit := GetMem(SizeOf(TFilDes));
@ -314,8 +328,38 @@ begin
end;
procedure TThread.Synchronize(Method: TThreadMethod);
var
LocalSyncException: Exception;
begin
{$TODO someone with more clue of the GUI stuff will have to do this}
if SynchronizeMethodProc = nil then
{ raise some error? }
exit;
EnterCriticalSection(SynchronizeCritSect);
SynchronizeMethod := Method;
SynchronizeException := nil;
SynchronizeMethodProc;
// wait infinitely
RtlEventWaitFor(ExecuteEvent);
SynchronizeMethod := nil;
LocalSyncException := SynchronizeException;
LeaveCriticalSection(SynchronizeCritSect);
if LocalSyncException <> nil then
raise LocalSyncException;
end;
procedure CheckSynchronize;
{ assumes being called from GUI thread }
begin
if SynchronizeMethod = nil then
exit;
try
SynchronizeMethod;
except
SynchronizeException := Exception(AcquireExceptionObject);
end;
RtlEventSetEvent(ExecuteEvent);
end;
procedure TThread.SetPriority(Value: TThreadPriority);
@ -325,7 +369,10 @@ end;
{
$Log$
Revision 1.8 2004-12-12 14:30:27 peter
Revision 1.9 2004-12-23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.8 2004/12/12 14:30:27 peter
* x86_64 updates
Revision 1.7 2004/03/03 22:00:37 peter

16
rtl/win32/classes.pp
View File

@ -47,14 +47,24 @@ uses
initialization
CommonInit;
{$ifndef ver1_0}
systhrds.InitCriticalSection(SynchronizeCritSect);
ExecuteEvent := RtlEventCreate;
SynchronizeMethod := nil;
{$endif}
finalization
CommonCleanup;
{$ifndef ver1_0}
systhrds.DoneCriticalSection(SynchronizeCritSect);
RtlEventDestroy(ExecuteEvent);
{$endif}
end.
{
$Log$
Revision 1.5 2004-01-22 17:11:23 peter
Revision 1.6 2004-12-23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.5 2004/01/22 17:11:23 peter
* classes uses types to import TPoint and TRect
Revision 1.4 2004/01/13 18:04:25 florian

52
rtl/win32/tthread.inc
View File

@ -16,6 +16,16 @@ type
var
ThreadWindow: HWND;
ThreadCount: Integer;
{ event that happens when gui thread is done executing the method
}
ExecuteEvent: PRtlEvent;
{ guard for synchronization variables }
SynchronizeCritSect: systhrds.TRtlCriticalSection;
{ method to execute }
SynchronizeMethod: TThreadMethod;
{ caught exception in gui thread, to be raised in calling thread }
SynchronizeException: Exception;
function ThreadWndProc(Window: HWnd; AMessage:UInt; WParam : WParam; LParam: LParam): Longint; stdcall;
@ -174,6 +184,7 @@ begin
SetThreadPriority(FHandle, Priorities[Value]);
end;
{ old implementation? :
procedure TThread.Synchronize(Method: TThreadMethod);
begin
FSynchronizeException := nil;
@ -181,6 +192,42 @@ begin
SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self));
if Assigned(FSynchronizeException) then raise FSynchronizeException;
end;
}
procedure TThread.Synchronize(Method: TThreadMethod);
var
LocalSyncException: Exception;
begin
if SynchronizeMethodProc = nil then
{ raise some error? }
exit;
systhrds.EnterCriticalSection(SynchronizeCritSect);
SynchronizeMethod := Method;
SynchronizeException := nil;
SynchronizeMethodProc;
// wait infinitely
RtlEventWaitFor(ExecuteEvent);
SynchronizeMethod := nil;
LocalSyncException := SynchronizeException;
systhrds.LeaveCriticalSection(SynchronizeCritSect);
if LocalSyncException <> nil then
raise LocalSyncException;
end;
procedure CheckSynchronize;
{ assumes being called from GUI thread }
begin
if SynchronizeMethod = nil then
exit;
try
SynchronizeMethod;
except
SynchronizeException := Exception(AcquireExceptionObject);
end;
RtlEventSetEvent(ExecuteEvent);
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
@ -219,7 +266,10 @@ begin
end;
{
$Log$
Revision 1.2 2004-01-29 16:58:28 marco
Revision 1.3 2004-12-23 09:42:42 marco
* first tthread.synchronize support (merged neli's patches)
Revision 1.2 2004/01/29 16:58:28 marco
* threadproc is passed to OS and must be stdcall;
Revision 1.1 2003/10/06 21:01:07 peter