MG: fixed memcheck

git-svn-id: trunk@3329 -
This commit is contained in:
lazarus 2002-09-13 07:01:20 +00:00
parent 11279dd04b
commit 1b2e55a1f2
2 changed files with 371 additions and 98 deletions

View File

@ -3,27 +3,29 @@
* * * *
* This unit is an altered heaptrc.pp from the fpc sources * * This unit is an altered heaptrc.pp from the fpc sources *
* * * *
* The only change are the 2 procs CheckHeap *
* *
*************************************************************************** ***************************************************************************
} }
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team.
Heap tracer
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
unit MemCheck; unit MemCheck;
{$mode objfpc}{$H+} {$goto on}
{off $DEFINE UseHeapTrc}
{$DEFINE EXTRA}
interface interface
{ $IFDEF UseHeapTrc}
uses HeapTrc;
{ $ENDIF}
procedure CheckHeap;
procedure CheckHeap(const txt: string);
{$IFNDEF UseHeapTrc}
Procedure DumpHeap; Procedure DumpHeap;
Procedure MarkHeap; Procedure MarkHeap;
@ -57,50 +59,33 @@ const
{ set this to true if you suspect that memory { set this to true if you suspect that memory
is freed several times } is freed several times }
{$ifdef EXTRA} {$ifdef EXTRA}
keepreleased : boolean=false; keepreleased : boolean=true;
add_tail : boolean = true; add_tail : boolean = true;
{$else EXTRA} {$else EXTRA}
keepreleased : boolean=false; keepreleased : boolean=false;
add_tail : boolean = true; // MG changed to true add_tail : boolean = false;
{$endif EXTRA} {$endif EXTRA}
{ put crc in sig { put crc in sig
this allows to test for writing into that part } this allows to test for writing into that part }
usecrc : boolean = true; usecrc : boolean = true;
MaxDumpCnt : integer = 10; // StartAddition for CodeTools
procedure CheckHeap;
procedure CheckHeap(const txt: ansistring);
procedure CheckHeapWrtMemCnt(const txt: ansistring);
var function MemCheck_getmem_cnt: longint;
getmem_cnt, function MemCheck_freemem_cnt: longint;
freemem_cnt : longint; function MemCheck_getmem_size: longint;
getmem_size, function MemCheck_freemem_size: longint;
freemem_size : longint; function MemCheck_getmem8_size: longint;
getmem8_size, function MemCheck_freemem8_size: longint;
freemem8_size : longint;
// Addition for CodeTools
{$ENDIF}
implementation implementation
procedure CheckHeap;
var p: pointer;
begin
writeln('>>> memcheck.pp - CheckHeap');
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
end;
procedure CheckHeap(const txt: string);
var p: pointer;
begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'"');
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
end;
{$IFNDEF UseHeapTrc}
type type
plongint = ^longint; plongint = ^longint;
@ -145,7 +130,111 @@ var
heap_valid_last : pheap_mem_info; heap_valid_last : pheap_mem_info;
{$endif EXTRA} {$endif EXTRA}
heap_mem_root : pheap_mem_info; heap_mem_root : pheap_mem_info;
getmem_cnt,
freemem_cnt : longint;
getmem_size,
freemem_size : longint;
getmem8_size,
freemem8_size : longint;
// StartAddition for CodeTools
procedure CheckHeap;
var p: pointer;
begin
writeln('>>> memcheck.pp - CheckHeap');
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
end;
procedure CheckHeap(const txt: ansistring);
var p: pointer;
begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'"');
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
end;
function IntToStr(i: longint): string;
var
NewLen, p: integer;
Negated: boolean;
j: integer;
begin
if i<>0 then begin
NewLen:=0;
if i<0 then begin
Negated:=true;
i:=-i;
inc(NewLen);
end else begin
Negated:=false;
end;
j:=i;
while (j>0) do begin
j:=j div 10;
inc(NewLen);
end;
SetLength(IntToStr,NewLen);
p:=1;
if Negated then begin
IntToStr[p]:='-';
inc(p);
end;
j:=i;
while (j>0) do begin
IntToStr[p]:=chr(ord('0')+(j mod 10));
j:=j div 10;
inc(p);
end;
end else begin
IntToStr:='0';
end;
end;
procedure CheckHeapWrtMemCnt(const txt: ansistring);
var p: pointer;
begin
writeln('>>> memcheck.pp - CheckHeap "',txt,'" ',IntToStr(MemCheck_getmem_cnt));
QuickTrace:=false;
GetMem(p,4);
FreeMem(p);
QuickTrace:=true;
end;
function MemCheck_getmem_cnt: longint;
begin
MemCheck_getmem_cnt:=getmem_cnt;
end;
function MemCheck_freemem_cnt: longint;
begin
MemCheck_freemem_cnt:=freemem_cnt;
end;
function MemCheck_getmem_size: longint;
begin
MemCheck_getmem_size:=getmem_size;
end;
function MemCheck_freemem_size: longint;
begin
MemCheck_freemem_size:=freemem_size;
end;
function MemCheck_getmem8_size: longint;
begin
MemCheck_getmem8_size:=getmem8_size;
end;
function MemCheck_freemem8_size: longint;
begin
MemCheck_freemem8_size:=freemem8_size;
end;
// Addition for CodeTools
{***************************************************************************** {*****************************************************************************
Crc 32 Crc 32
@ -172,7 +261,7 @@ begin
crc:=i; crc:=i;
for n:=1 to 8 do for n:=1 to 8 do
if odd(crc) then if odd(crc) then
crc:=(crc shr 1) xor integer($edb88320) crc:=(crc shr 1) xor $edb88320
else else
crc:=crc shr 1; crc:=crc shr 1;
Crc32Tbl[i]:=crc; Crc32Tbl[i]:=crc;
@ -205,7 +294,7 @@ var
crc : longint; crc : longint;
pl : plongint; pl : plongint;
begin begin
crc:=integer($ffffffff); crc:=$ffffffff;
crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); crc:=UpdateCrc32(crc,p^.size,sizeof(longint));
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint));
if extra_info_size>0 then if extra_info_size>0 then
@ -225,7 +314,7 @@ var
crc : longint; crc : longint;
pl : plongint; pl : plongint;
begin begin
crc:=integer($ffffffff); crc:=$ffffffff;
crc:=UpdateCrc32(crc,p^.size,sizeof(longint)); crc:=UpdateCrc32(crc,p^.size,sizeof(longint));
crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint)); crc:=UpdateCrc32(crc,p^.calls,tracesize*sizeof(longint));
if extra_info_size>0 then if extra_info_size>0 then
@ -339,9 +428,9 @@ begin
i:=0; i:=0;
while pp<>nil do while pp<>nil do
begin begin
if ((pp^.sig<>integer($DEADBEEF)) or usecrc) and if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) and ((pp^.sig<>calculate_sig(pp)) or not usecrc) and
(pp^.sig <> integer($AAAAAAAA)) then (pp^.sig <> $AAAAAAAA) then
begin begin
writeln(ptext^,'error in linked list of heap_mem_info'); writeln(ptext^,'error in linked list of heap_mem_info');
RunError(204); RunError(204);
@ -374,12 +463,12 @@ begin
inc(bp,sizeof(longint)); inc(bp,sizeof(longint));
p:=SysGetMem(bp); p:=SysGetMem(bp);
{ Create the info block } { Create the info block }
pheap_mem_info(p)^.sig:=integer($DEADBEEF); pheap_mem_info(p)^.sig:=$DEADBEEF;
pheap_mem_info(p)^.size:=size; pheap_mem_info(p)^.size:=size;
if add_tail then if add_tail then
begin begin
pl:=pointer(p)+bp-sizeof(longint); pl:=pointer(p)+bp-sizeof(longint);
pl^:=integer($DEADBEEF); pl^:=$DEADBEEF;
end; end;
bp:=get_caller_frame(get_frame); bp:=get_caller_frame(get_frame);
for i:=1 to tracesize do for i:=1 to tracesize do
@ -438,13 +527,13 @@ begin
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
if not quicktrace and not(is_in_getmem_list(pp)) then if not quicktrace and not(is_in_getmem_list(pp)) then
RunError(204); RunError(204);
if (pp^.sig=integer($AAAAAAAA)) and not usecrc then if (pp^.sig=$AAAAAAAA) and not usecrc then
begin begin
error_in_heap:=true; error_in_heap:=true;
dump_already_free(pp,ptext^); dump_already_free(pp,ptext^);
if haltonerror then halt(1); if haltonerror then halt(1);
end end
else if ((pp^.sig<>integer($DEADBEEF)) or usecrc) and else if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin begin
error_in_heap:=true; error_in_heap:=true;
@ -468,7 +557,7 @@ begin
exit; exit;
end; end;
{ now it is released !! } { now it is released !! }
pp^.sig:=integer($AAAAAAAA); pp^.sig:=$AAAAAAAA;
if not keepreleased then if not keepreleased then
begin begin
if pp^.next<>nil then if pp^.next<>nil then
@ -593,7 +682,7 @@ begin
dec(p,sizeof(theap_mem_info)+extra_info_size); dec(p,sizeof(theap_mem_info)+extra_info_size);
pp:=pheap_mem_info(p); pp:=pheap_mem_info(p);
{ test block } { test block }
if ((pp^.sig<>integer($DEADBEEF)) or usecrc) and if ((pp^.sig<>$DEADBEEF) or usecrc) and
((pp^.sig<>calculate_sig(pp)) or not usecrc) then ((pp^.sig<>calculate_sig(pp)) or not usecrc) then
begin begin
error_in_heap:=true; error_in_heap:=true;
@ -634,12 +723,12 @@ begin
inc(getmem_size,size); inc(getmem_size,size);
inc(getmem8_size,((size+7) div 8)*8); inc(getmem8_size,((size+7) div 8)*8);
{ Create the info block } { Create the info block }
pp^.sig:=integer($DEADBEEF); pp^.sig:=$DEADBEEF;
pp^.size:=size; pp^.size:=size;
if add_tail then if add_tail then
begin begin
pl:=pointer(p)+bp-sizeof(longint); pl:=pointer(p)+bp-sizeof(longint);
pl^:=integer($DEADBEEF); pl^:=$DEADBEEF;
end; end;
bp:=get_caller_frame(get_frame); bp:=get_caller_frame(get_frame);
for i:=1 to tracesize do for i:=1 to tracesize do
@ -657,12 +746,8 @@ begin
end; end;
{***************************************************************************** Check pointer *****************************************************************************}
{***************************************************************************** {$ifndef unix}
Check pointer
*****************************************************************************}
{$ifndef linux}
{$S-} {$S-}
{$endif} {$endif}
@ -684,17 +769,24 @@ var
data_end : cardinal;external name '__data_end__'; data_end : cardinal;external name '__data_end__';
{$endif} {$endif}
{$ifdef unix}
const
global_stack_top : cardinal = 0;
procedure _start; cdecl; external;
{$endif unix}
procedure CheckPointer(p : pointer);[saveregisters,public, alias : 'FPC_CHECKPOINTER']; procedure CheckPointer(p : pointer);[saveregisters,public, alias : 'FPC_CHECKPOINTER'];
var var
i : longint; i : longint;
pp : pheap_mem_info; pp : pheap_mem_info;
{$ifdef win32}get_ebp: cardinal;{$endif} get_ebp,stack_top : cardinal;
{$ifdef go32v2}
stack_top : cardinal;
data_end : cardinal; data_end : cardinal;
{$endif} label
_exit;
begin begin
if p=nil then exit; if p=nil then
goto _exit;
i:=0; i:=0;
@ -708,23 +800,86 @@ begin
end; end;
stack_top:=__stkbottom+__stklen; stack_top:=__stkbottom+__stklen;
{ allow all between start of code and end of data } { allow all between start of code and end of data }
if cardinal(p)<=data_end then exit; if cardinal(p)<=data_end then
goto _exit;
{ .bss section } { .bss section }
if cardinal(p)<=cardinal(heap_at_init) then exit; if cardinal(p)<=cardinal(heap_at_init) then
goto _exit;
{ stack can be above heap !! } { stack can be above heap !! }
if (cardinal(p)>=get_ebp) and (cardinal(p)<=stack_top) then exit; if (cardinal(p)>=get_ebp) and (cardinal(p)<=stack_top) then
goto _exit;
{$endif go32v2} {$endif go32v2}
{$ifdef unix}
if (cardinal(p)>=cardinal(@_start)) and
(cardinal(p)<=cardinal(heaporg)) then exit;
{$ifdef cpui386}
asm
movl %ebp, get_ebp
end;
{$endif cpui386}
{$ifdef cpu68k}
asm
move.l a6, get_ebp
end;
{$endif cpu86}
if cardinal (p) > cardinal (get_ebp) then
begin
if (global_stack_top = 0) then
begin
{$ifdef cpui386}
asm
movl %ebp,%eax
movl %eax,%ebx
.Lnext:
orl %eax,%eax
je .Ltopfound
movl (%eax),%eax
cmpl %eax,%ebx
jae .Ltopfound
movl %eax,%ebx
jmp .Lnext
.Ltopfound:
movl %ebx,global_stack_top
end;
{$endif cpui386}
{$ifdef cpu68k}
asm
move.l a6,d0
move.l d0,d1
@Lnext:
or.l d0,d0
beq @Ltopfound
move.l d0,a0
move.l (a0),d0
cmp.l a0,a1
bgt @Ltopfound
move.l a0,a1
bra @Lnext
@Ltopfound:
move.l a1,global_stack_top
end;
{$endif cpu86}
{ argv and argc are above this value :( }
global_stack_top := global_stack_top or $fffff;
end;
if cardinal(p) <= global_stack_top then
exit;
end;
{$endif unix}
{ I don't know where the stack is in other OS !! } { I don't know where the stack is in other OS !! }
{$ifdef win32} {$ifdef win32}
if (cardinal(p)>=$40000) and (p<=HeapOrg) then exit; if (cardinal(p)>=$40000) and (p<=HeapOrg) then
goto _exit;
{ inside stack ? } { inside stack ? }
asm asm
movl %ebp,get_ebp movl %ebp,get_ebp
end; end;
if (cardinal(p)>get_ebp) and if (cardinal(p)>get_ebp) and
(cardinal(p)<Win32StackTop) then exit; (cardinal(p)<Win32StackTop) then
goto _exit;
{$endif win32} {$endif win32}
if p>=heapptr then if p>=heapptr then
@ -738,15 +893,15 @@ begin
{ inside this valid block ! } { inside this valid block ! }
{ we can be changing the extrainfo !! } { we can be changing the extrainfo !! }
if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info){+extra_info_size}) and if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info){+extra_info_size}) and
(cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info) (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+extra_info_size+pp^.size) then
+Cardinal(extra_info_size)+Cardinal(pp^.size)) then
begin begin
{ check allocated block } { check allocated block }
if ((pp^.sig=integer($DEADBEEF)) and not usecrc) or if ((pp^.sig=$DEADBEEF) and not usecrc) or
((pp^.sig=calculate_sig(pp)) and usecrc) or ((pp^.sig=calculate_sig(pp)) and usecrc) or
{ special case of the fill_extra_info call } { special case of the fill_extra_info call }
((pp=heap_valid_last) and usecrc and (pp^.sig=integer($DEADBEEF)) ((pp=heap_valid_last) and usecrc and (pp^.sig=$DEADBEEF)
and inside_trace_getmem) then exit and inside_trace_getmem) then
goto _exit
else else
begin begin
writeln(ptext^,'corrupted heap_mem_info'); writeln(ptext^,'corrupted heap_mem_info');
@ -772,9 +927,9 @@ begin
if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)) and if (cardinal(p)>=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)) and
(cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)+cardinal(pp^.size)) then (cardinal(p)<=cardinal(pp)+sizeof(theap_mem_info)+cardinal(extra_info_size)+cardinal(pp^.size)) then
{ allocated block } { allocated block }
if ((pp^.sig=integer($DEADBEEF)) and not usecrc) or if ((pp^.sig=$DEADBEEF) and not usecrc) or
((pp^.sig=calculate_sig(pp)) and usecrc) then ((pp^.sig=calculate_sig(pp)) and usecrc) then
exit goto _exit
else else
begin begin
writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' points into invalid memory block');
@ -791,6 +946,7 @@ begin
end; end;
writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block'); writeln(ptext^,'pointer $',hexstr(longint(p),8),' does not point to valid memory block');
runerror(204); runerror(204);
_exit:
end; end;
{***************************************************************************** {*****************************************************************************
@ -800,11 +956,14 @@ end;
procedure dumpheap; procedure dumpheap;
var var
pp : pheap_mem_info; pp : pheap_mem_info;
i, WrittenCnt : longint; i : longint;
ExpectedMemAvail : longint; ExpectedMemAvail : longint;
begin begin
pp:=heap_mem_root; pp:=heap_mem_root;
Writeln(ptext^,'Heap dump by memcheck unit'); Writeln(ptext^,'Heap dump by heaptrc unit');
{$ifdef EXTRA}
Writeln(ptext^,'compiled with EXTRA features');
{$endif EXTRA}
Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size); Writeln(ptext^,getmem_cnt, ' memory blocks allocated : ',getmem_size,'/',getmem8_size);
Writeln(ptext^,freemem_cnt,' memory blocks freed : ',freemem_size,'/',freemem8_size); Writeln(ptext^,freemem_cnt,' memory blocks freed : ',freemem_size,'/',freemem8_size);
Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size); Writeln(ptext^,getmem_cnt-freemem_cnt,' unfreed memory blocks : ',getmem_size-freemem_size);
@ -819,7 +978,6 @@ begin
If ExpectedMemAvail<>MemAvail then If ExpectedMemAvail<>MemAvail then
Writeln(ptext^,'Should be : ',ExpectedMemAvail); Writeln(ptext^,'Should be : ',ExpectedMemAvail);
i:=getmem_cnt-freemem_cnt; i:=getmem_cnt-freemem_cnt;
WrittenCnt:=0;
while pp<>nil do while pp<>nil do
begin begin
if i<0 then if i<0 then
@ -828,7 +986,7 @@ begin
Writeln(ptext^,'More memory blocks than expected'); Writeln(ptext^,'More memory blocks than expected');
exit; exit;
end; end;
if ((pp^.sig=integer($DEADBEEF)) and not usecrc) or if ((pp^.sig=$DEADBEEF) and not usecrc) or
((pp^.sig=calculate_sig(pp)) and usecrc) then ((pp^.sig=calculate_sig(pp)) and usecrc) then
begin begin
{ this one was not released !! } { this one was not released !! }
@ -836,7 +994,7 @@ begin
call_stack(pp,ptext^); call_stack(pp,ptext^);
dec(i); dec(i);
end end
else if pp^.sig<>integer($AAAAAAAA) then else if pp^.sig<>$AAAAAAAA then
begin begin
dump_error(pp,ptext^); dump_error(pp,ptext^);
{$ifdef EXTRA} {$ifdef EXTRA}
@ -850,10 +1008,9 @@ begin
dump_change_after(pp,ptext^); dump_change_after(pp,ptext^);
dump_change_after(pp,error_file); dump_change_after(pp,error_file);
error_in_heap:=true; error_in_heap:=true;
end; end
{$endif EXTRA} {$endif EXTRA}
inc(WrittenCnt); ;
if WrittenCnt>=MaxDumpCnt then break;
pp:=pp^.previous; pp:=pp^.previous;
end; end;
end; end;
@ -866,7 +1023,7 @@ begin
pp:=heap_mem_root; pp:=heap_mem_root;
while pp<>nil do while pp<>nil do
begin begin
pp^.sig:=integer($AAAAAAAA); pp^.sig:=$AAAAAAAA;
pp:=pp^.previous; pp:=pp^.previous;
end; end;
end; end;
@ -927,7 +1084,7 @@ begin
ioresult; ioresult;
if (exitcode<>0) and (erroraddr<>nil) then if (exitcode<>0) and (erroraddr<>nil) then
begin begin
Writeln(ptext^,'No heap dump by memcheck unit'); Writeln(ptext^,'No heap dump by heaptrc unit');
Writeln(ptext^,'Exitcode = ',exitcode); Writeln(ptext^,'Exitcode = ',exitcode);
if ptext<>@stderr then if ptext<>@stderr then
begin begin
@ -1005,6 +1162,122 @@ Initialization
{$endif} {$endif}
finalization finalization
TraceExit; TraceExit;
{$ENDIF}
end. end.
{
$Log$
Revision 1.8 2002/09/13 07:01:20 lazarus
MG: fixed memcheck
Revision 1.1.2.10 2002/07/16 13:52:59 pierre
* fix compilation for m68k linux
Revision 1.1.2.9 2002/06/19 13:56:09 pierre
* try to fix handling for unix
Revision 1.1.2.8 2002/05/31 11:18:20 marco
* Rename fest for 1.0.x step one. Compiler and RTL
Revision 1.1.2.7 2001/09/22 04:48:42 carl
- remove unused define
Revision 1.1.2.6 2001/07/24 09:11:38 pierre
* added goto on to avoid need of -Sg option
Revision 1.1.2.5 2001/06/06 14:27:14 jonas
* fixed wrong typed constant procvars in preparation of my fix which will
disallow them in FPC mode
Revision 1.1.2.4 2001/04/22 00:38:47 carl
+ make it portable
Revision 1.1.2.3 2001/04/16 20:31:31 carl
* 386DX bugfix with popal
Revision 1.1.2.2 2000/12/15 13:02:30 jonas
* added some typecasts so some expressiosn aren't evaluated anymore in
64bit when rangechecking is on
Revision 1.1.2.1 2000/08/24 08:59:35 jonas
* clear inoutres in traceexit before writing anything (to avoid an RTE
when writing the heaptrc output when a program didn't handle ioresult)
Revision 1.1 2000/07/13 06:30:47 michael
+ Initial import
Revision 1.43 2000/05/18 17:03:27 peter
* fixed reallocmem with double removing from heap_mem_root list
* fixed reallocmem getmem/freemem count, now both are increased and
the _size8 counts are also increased
Revision 1.42 2000/04/27 15:35:50 pierre
* fix for bug report 929
Revision 1.41 2000/02/10 13:59:35 peter
* fixed bug with reallocmem to use the wrong size when copying the
data to the new allocated pointer
Revision 1.40 2000/02/09 16:59:30 peter
* truncated log
Revision 1.39 2000/02/07 10:42:44 peter
* use backtracestrfunc()
Revision 1.38 2000/02/02 11:13:15 peter
* fixed tracereallocmem which supplied the wrong size for tryresize
Revision 1.37 2000/01/31 23:41:30 peter
* reallocmem fixed for freemem() call when size=0
Revision 1.36 2000/01/20 14:25:51 jonas
* finally fixed tracereallocmem completely
Revision 1.35 2000/01/20 13:17:11 jonas
* another problme with realloc fixed (one left)
Revision 1.34 2000/01/20 12:35:35 jonas
* fixed problem with reallocmem and heaptrc
Revision 1.33 2000/01/07 16:41:34 daniel
* copyright 2000
Revision 1.32 2000/01/07 16:32:24 daniel
* copyright 2000 added
Revision 1.31 2000/01/05 13:56:55 jonas
* fixed traceReallocMem with nil pointer (simply calls traceGetMem now in
such a case)
Revision 1.30 2000/01/03 19:37:52 peter
* fixed reallocmem with p=nil
Revision 1.29 1999/11/14 21:35:04 peter
* removed warnings
Revision 1.28 1999/11/09 22:32:23 pierre
* several extra_size_info fixes
Revision 1.27 1999/11/06 14:35:38 peter
* truncated log
Revision 1.26 1999/11/01 13:56:50 peter
* freemem,reallocmem now get var argument
Revision 1.25 1999/10/30 17:39:05 peter
* memorymanager expanded with allocmem/reallocmem
Revision 1.24 1999/09/17 17:14:12 peter
+ new heap manager supporting delphi freemem(pointer)
Revision 1.23 1999/09/10 17:13:41 peter
* fixed missing var
Revision 1.22 1999/09/08 16:14:41 peter
* pointer fixes
Revision 1.21 1999/08/18 12:03:16 peter
* objfpc mode for 0.99.12
Revision 1.20 1999/08/17 14:56:03 michael
Removed the mode for objpas
}

View File

@ -702,7 +702,7 @@ Var
ParentComponent: TComponent; ParentComponent: TComponent;
Begin Begin
writeln('[TCustomFormEditor.CreateComponent] Class='''+TypeClass.ClassName+''''); writeln('[TCustomFormEditor.CreateComponent] Class='''+TypeClass.ClassName+'''');
{$IFDEF IDE_MEM_CHECK}CheckHeap('TCustomFormEditor.CreateComponent A '+IntToStr(GetMem_Cnt));{$ENDIF} {$IFDEF IDE_MEM_CHECK}CheckHeapWrtMemCnt('TCustomFormEditor.CreateComponent A');{$ENDIF}
Temp := TComponentInterface.Create; Temp := TComponentInterface.Create;
OwnerComponent:=nil; OwnerComponent:=nil;
@ -724,7 +724,7 @@ Begin
exit; exit;
end; end;
end; end;
{$IFDEF IDE_MEM_CHECK}CheckHeap('TCustomFormEditor.CreateComponent C '+IntToStr(GetMem_Cnt));{$ENDIF} {$IFDEF IDE_MEM_CHECK}CheckHeapWrtMemCnt('TCustomFormEditor.CreateComponent C ');{$ENDIF}
if Assigned(ParentCI) and (Temp.Component is TControl) then if Assigned(ParentCI) and (Temp.Component is TControl) then
Begin Begin
@ -743,7 +743,7 @@ Begin
end; end;
end; end;
{$IFDEF IDE_MEM_CHECK}CheckHeap('TCustomFormEditor.CreateComponent D '+IntToStr(GetMem_Cnt));{$ENDIF} {$IFDEF IDE_MEM_CHECK}CheckHeapWrtMemCnt('TCustomFormEditor.CreateComponent D ');{$ENDIF}
Temp.Component.Name := CreateUniqueComponentName(Temp.Component); Temp.Component.Name := CreateUniqueComponentName(Temp.Component);
if (Temp.Component is TControl) then if (Temp.Component is TControl) then
@ -766,7 +766,7 @@ Begin
end; end;
end; end;
{$IFDEF IDE_MEM_CHECK}CheckHeap('TCustomFormEditor.CreateComponent F '+IntToStr(GetMem_Cnt));{$ENDIF} {$IFDEF IDE_MEM_CHECK}CheckHeapWrtMemCnt('TCustomFormEditor.CreateComponent F ');{$ENDIF}
FComponentInterfaceList.Add(Temp); FComponentInterfaceList.Add(Temp);
Result := Temp; Result := Temp;