paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-11 18:08:15 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ added register keyword to Interlocked* definitions as suggested by Jonas, resolves #12255

Browse Source 
git-svn-id: trunk@12698 -
This commit is contained in:
florian 2009-02-07 16:09:05 +00:00
parent c4310a6f08
commit 0c65d53f45
3 changed files with 28 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -8719,6 +8719,7 @@ tests/webtbs/tw12233.pp svneol=native#text/plain
tests/webtbs/tw12237.pp svneol=native#text/plain
tests/webtbs/tw12242.pp svneol=native#text/plain
tests/webtbs/tw12249.pp svneol=native#text/plain
tests/webtbs/tw12255.pp svneol=native#text/plain
tests/webtbs/tw1228.pp svneol=native#text/plain
tests/webtbs/tw1229.pp svneol=native#text/plain
tests/webtbs/tw12318.pp svneol=native#text/plain

12
rtl/win/wininc/redef.inc
View File

@ -1004,18 +1004,18 @@ function SetKeyboardState(var KeyState:TKeyboardState):WINBOOL; external 'user32
function GetWindowThreadProcessId(hWnd:HWND;var lpdwProcessId:DWORD):DWORD; external 'user32' name 'GetWindowThreadProcessId';
function HwndMSWheel(var puiMsh_MsgMouseWheel, puiMsh_Msg3DSupport,puiMsh_MsgScrollLines: UINT;
var pf3DSupport: BOOL; var piScrollLines: Integer): HWND;
function CreateWaitableTimer(lpTimerAttributes :LPSECURITY_ATTRIBUTES; bManualReset:BOOl;lpTimerName:LPCTSTR):THandle;external 'kernel32' name 'CreateWaitableTimerA';
function CreateWaitableTimer(lpTimerAttributes :LPSECURITY_ATTRIBUTES; bManualReset:BOOl;lpTimerName:LPCTSTR):THandle;external 'kernel32' name 'CreateWaitableTimerA';
function OpenWaitableTimer(dwDesiredAccess:DWORD;bInheritHandle:BOOL;lpTimerName:LPCTSTR):THandle;external 'kernel32' name 'OpenWaitableTimerA';
//function PropertySheetA(p:TPROPSHEETHEADER):longint; external 'comctl32' name 'PropertySheetA';
// windows because of Delphi compat.
{$calling default}
function InterLockedIncrement (var Target: longint) : longint; external name 'FPC_INTERLOCKEDINCREMENT';
function InterLockedDecrement (var Target: longint) : longint; external name 'FPC_INTERLOCKEDDECREMENT';
function InterLockedExchange (var Target: longint;Source : longint) : longint; external name 'FPC_INTERLOCKEDEXCHANGE';
function InterLockedExchangeAdd (var Target: longint;Source : longint) : longint; external name 'FPC_INTERLOCKEDEXCHANGEADD';
function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE';
function InterLockedIncrement (var Target: longint) : longint; register; external name 'FPC_INTERLOCKEDINCREMENT';
function InterLockedDecrement (var Target: longint) : longint; register; external name 'FPC_INTERLOCKEDDECREMENT';
function InterLockedExchange (var Target: longint;Source : longint) : longint; register; external name 'FPC_INTERLOCKEDEXCHANGE';
function InterLockedExchangeAdd (var Target: longint;Source : longint) : longint; register; external name 'FPC_INTERLOCKEDEXCHANGEADD';
function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint; register; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE';
{$calling stdcall}
{$endif read_interface}

21
tests/webtbs/tw12255.pp Normal file
View File

@ -0,0 +1,21 @@
{ %target=win32 }
{$mode objfpc}
uses sysutils
, windows
;
var
SharedInt : PInteger;
target : integer;
savetarget : integer;
begin
target := 0;
savetarget := system.InterlockedCompareExchange(Target, 1, 0);
Writeln(format('%d = InterlockedCompareExchange(Target= %d , 1, 0)',[savetarget, target]));
SharedInt := AllocMem(SizeOf(Integer));
SharedInt^ := 0;
// here is runtime exception rised - access to invalid memory
savetarget := windows.InterlockedCompareExchange(SharedInt^, 1, 0);
Writeln(format('%d = InterlockedCompareExchange(SharedInt^= %d , 1, 0)',[savetarget, SharedInt^]));
FreeMem(SharedInt);
end.