paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 22:49:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix crash under win32 with previous reallocmem fix

Browse Source
This commit is contained in:
peter 2005-03-21 16:31:33 +00:00
parent 239beee554
commit ccf36c0afd
2 changed files with 24 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/inc/heap.inc
View File

@ -734,6 +734,9 @@ var
mc_tmp : pmemchunk_var; mc_tmp : pmemchunk_var;
size_right : ptrint; size_right : ptrint;
begin begin
// mc_right can't be a fixed size block
if mc_right^.size and fixedsizeflag<>0 then
HandleError(204);
// left block free, concat with right-block // left block free, concat with right-block
size_right := mc_right^.size and sizemask; size_right := mc_right^.size and sizemask;
inc(mc_left^.size, size_right); inc(mc_left^.size, size_right);
@ -1106,6 +1109,7 @@ begin
{$endif TestFreeLists} {$endif TestFreeLists}
end; end;
function SysFreeMem(p: pointer): ptrint; function SysFreeMem(p: pointer): ptrint;
var var
pcurrsize: ptrint; pcurrsize: ptrint;
@ -1214,9 +1218,9 @@ begin
currsize := pcurrsize and fixedsizemask; currsize := pcurrsize and fixedsizemask;
size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask; size := (size+sizeof(tmemchunk_fixed_hdr)+(blocksize-1)) and fixedsizemask;
end; end;
oldsize := currsize;
{ is the allocated block still correct? } { is the allocated block still correct? }
if (currsize>=size) and (size>(currsize-16)) then if (currsize>=size) and (size>(currsize-blocksize)) then
begin begin
SysTryResizeMem := true; SysTryResizeMem := true;
{$ifdef TestFreeLists} {$ifdef TestFreeLists}
@ -1235,6 +1239,7 @@ begin
{ get pointer to block } { get pointer to block }
pcurr := pmemchunk_var(pointer(p)-sizeof(tmemchunk_var_hdr)); pcurr := pmemchunk_var(pointer(p)-sizeof(tmemchunk_var_hdr));
oldsize := currsize;
{ do we need to allocate more memory ? } { do we need to allocate more memory ? }
if size>currsize then if size>currsize then
@ -1349,7 +1354,10 @@ end;
{ {
$Log$ $Log$
Revision 1.48 2005-03-20 18:57:29 peter Revision 1.49 2005-03-21 16:31:33 peter
* fix crash under win32 with previous reallocmem fix
Revision 1.48 2005/03/20 18:57:29 peter
* fixed tryresizemem * fixed tryresizemem
Revision 1.47 2005/03/04 16:49:34 peter Revision 1.47 2005/03/04 16:49:34 peter

19
rtl/win32/system.pp
View File

@ -143,11 +143,15 @@ var
argvlen : longint; argvlen : longint;
procedure allocarg(idx,len:longint); procedure allocarg(idx,len:longint);
var
oldargvlen : longint;
begin begin
if idx>=argvlen then if idx>=argvlen then
begin begin
oldargvlen:=argvlen;
argvlen:=(idx+8) and (not 7); argvlen:=(idx+8) and (not 7);
sysreallocmem(argv,argvlen*sizeof(pointer)); sysreallocmem(argv,argvlen*sizeof(pointer));
fillchar(argv[oldargvlen],(argvlen-oldargvlen)*sizeof(pointer),0);
end; end;
{ use realloc to reuse already existing memory } { use realloc to reuse already existing memory }
{ always allocate, even if length is zero, since } { always allocate, even if length is zero, since }
@ -715,7 +719,7 @@ var
{$ifdef SYSTEMEXCEPTIONDEBUG} {$ifdef SYSTEMEXCEPTIONDEBUG}
procedure DebugHandleErrorAddrFrame(error, addr, frame : longint); procedure DebugHandleErrorAddrFrame(error, addr, frame : longint);
begin begin
if IsConsole then if IsConsole then
begin begin
write(stderr,'HandleErrorAddrFrame(error=',error); write(stderr,'HandleErrorAddrFrame(error=',error);
write(stderr,',addr=',hexstr(addr,8)); write(stderr,',addr=',hexstr(addr,8));
@ -918,13 +922,13 @@ end;
function CharUpperBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD; stdcall; external 'user32' name 'CharUpperBuffW'; function CharUpperBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD; stdcall; external 'user32' name 'CharUpperBuffW';
function CharLowerBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD; stdcall; external 'user32' name 'CharLowerBuffW'; function CharLowerBuff(lpsz:LPWSTR; cchLength:DWORD):DWORD; stdcall; external 'user32' name 'CharLowerBuffW';
function Win32WideUpper(const s : WideString) : WideString; function Win32WideUpper(const s : WideString) : WideString;
begin begin
result:=s; result:=s;
UniqueString(result); UniqueString(result);
if length(result)>0 then if length(result)>0 then
CharUpperBuff(LPWSTR(result),length(result)); CharUpperBuff(LPWSTR(result),length(result));
end; end;
@ -936,7 +940,7 @@ function Win32WideLower(const s : WideString) : WideString;
if length(result)>0 then if length(result)>0 then
CharLowerBuff(LPWSTR(result),length(result)); CharLowerBuff(LPWSTR(result),length(result));
end; end;
{ there is a similiar procedure in sysutils which inits the fields which { there is a similiar procedure in sysutils which inits the fields which
are only relevant for the sysutils units } are only relevant for the sysutils units }
@ -945,7 +949,7 @@ procedure InitWin32Widestrings;
widestringmanager.UpperWideStringProc:=@Win32WideUpper; widestringmanager.UpperWideStringProc:=@Win32WideUpper;
widestringmanager.LowerWideStringProc:=@Win32WideLower; widestringmanager.LowerWideStringProc:=@Win32WideLower;
end; end;
{$endif HASWIDESTRING} {$endif HASWIDESTRING}
@ -1106,7 +1110,10 @@ end.
{ {
$Log$ $Log$
Revision 1.71 2005-03-02 19:18:42 florian Revision 1.72 2005-03-21 16:31:33 peter
* fix crash under win32 with previous reallocmem fix
Revision 1.71 2005/03/02 19:18:42 florian
* fixed compilation with 1.0.10 * fixed compilation with 1.0.10
Revision 1.70 2005/02/26 20:43:52 florian Revision 1.70 2005/02/26 20:43:52 florian