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

* use domem() for heap checking

Browse Source
This commit is contained in:
peter 2004-11-26 21:59:49 +00:00
parent e92f1a2d0b
commit d30f99c17e
13 changed files with 100 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
tests/tbs/tb0239.pp
View File

@ -3,9 +3,14 @@
{$H+}
Program AnsiTest;
uses
erroru;
Type
PS=^String;
var
mem : ptrint;
procedure test;
var
@ -26,18 +31,10 @@ Begin
Dispose(P);
end;
var
membefore : longint;
begin
membefore:=memavail;
DoMem(mem);
test;
if membefore<>memavail then
begin
Writeln('Memory hole using pointers to ansi strings');
Halt(1);
end
else
Writeln('No memory hole with pointers to ansi strings');
if DoMem(mem)<>0 then
halt(1);
end.

19
tests/tbs/tb0240.pp
View File

@ -1,10 +1,10 @@
{ Old file: tbs0280.pp }
{ problem with object finalization. OK 0.99.13 (FK) }
{$mode objfpc}
{$H+}
program memhole;
uses
Erroru;
type
TMyClass = class
@ -29,17 +29,10 @@ begin
end;
var
membefore : sizeint;
mem : sizeint;
begin
membefore:=memavail;
writeln(memavail);
DoMem(mem);
dotest;
writeln(memavail);
if membefore<>memavail then
begin
Writeln('Memory hole using ansi strings in classes');
Halt(1);
end
else
Writeln('No memory hole unsing ansi strings in classes');
if DoMem(mem)<>0 then
Halt(1);
end.

33
tests/test/tobject1.pp
View File

@ -5,7 +5,7 @@ program test_fail;
uses
erroru;
type
parrayobj = ^tarrayobj;
tarrayobj = object
@ -24,7 +24,6 @@ program test_fail;
var
pa1, pa2 : parrayobj;
ta1, ta2 : tarrayobj;
availmem : longint;
constructor tarrayobj.init(do_fail : boolean);
begin
@ -40,8 +39,8 @@ program test_fail;
procedure tarrayobj.test;
begin
Writeln('@self = ',longint(@self));
Writeln('typeof = ',longint(typeof(self)));
Writeln('@self = ',ptrint(@self));
Writeln('typeof = ',ptrint(typeof(self)));
if ar[1]=1 then
Writeln('Init called');
if ar[2]=2 then
@ -66,33 +65,33 @@ program test_fail;
Inherited test;
end;
var
mem : sizeint;
begin
mem:=0;
DoMem(mem);
new(pa1,init(false));
getheapstatus(hstatus);
writeln('After successful new(pa1,init), memory used = ',hstatus.CurrHeapUsed);
writeln('After successful new(pa1,init)');
new(pa2,init(true));
getheapstatus(hstatus);
writeln('After unsuccessful new(pa2,init), memory used = ',hstatus.CurrHeapUsed);
writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2));
writeln('After unsuccessful new(pa2,init)');
writeln('pa1 = ',ptrint(pa1),' pa2 = ',ptrint(pa2));
writeln('Call to pa1^.test after successful init');
pa1^.test;
dispose(pa1,done);
getheapstatus(hstatus);
writeln('After release of pa1, memory used = ',hstatus.CurrHeapUsed);
writeln('After release of pa1');
DoMem(mem);
pa1:=new(pbigarrayobj,good_init);
getheapstatus(hstatus);
writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',hstatus.CurrHeapUsed);
writeln('After successful pa1:=new(pbigarrayobj,good_init)');
pa2:=new(pbigarrayobj,wrong_init);
getheapstatus(hstatus);
writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',hstatus.CurrHeapUsed);
writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2));
writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init)');
writeln('pa1 = ',ptrint(pa1),' pa2 = ',ptrint(pa2));
writeln('Call to pa1^.test after successful init');
pa1^.test;
ta1.init(false);
writeln('Call to ta1.test after successful init');
ta1.test;
ta2.init(true);
writeln('typeof(ta2) = ',longint(typeof(ta2)),' after unsuccessful init');
writeln('typeof(ta2) = ',ptrint(typeof(ta2)),' after unsuccessful init');
Writeln('Trying to call ta2.test (should generate a Run Time Error)');
ta2.test;
end.

32
tests/units/erroru.pp
View File

@ -30,7 +30,7 @@ type
procedure getheapstatus(var status:THeapStatus);
{$endif HASGETHEAPSTATUS}
Procedure DoMem (Var StartMem : sizeint);
function DoMem (Var StartMem : sizeint): sizeint;
implementation
@ -115,13 +115,37 @@ end;
{$endif HASGETHEAPSTATUS}
Procedure DoMem (Var StartMem : sizeint);
function DoMem (Var StartMem : sizeint): sizeint;
function getsize(l:sizeint):string;
begin
if l<16*1024 then
begin
str(l,getsize);
getsize:=getsize+' bytes';
end
else
begin
str(l shr 10,getsize);
getsize:=getsize+' Kb';
end;
end;
var
hstatus : THeapstatus;
begin
GetHeapStatus(hstatus);
if StartMem<>0 then
Writeln ('Used: ',hstatus.CUrrHeapUsed shr 10,'Kb, Lost ',hstatus.CurrHeapUsed-StartMem,' Bytes.');
if StartMem=0 then
begin
Writeln ('[HEAP] Size: ',getsize(hstatus.CurrHeapSize),', Used: ',getsize(hstatus.CurrHeapUsed));
DoMem:=0;
end
else
begin
Writeln ('[HEAP] Size: ',getsize(hstatus.CurrHeapSize),', Used: ',getsize(hstatus.CurrHeapUsed),
', Lost: ',getsize(hstatus.CurrHeapUsed-StartMem));
DoMem:=hstatus.CurrHeapUsed-StartMem;
end;
StartMem:=hstatus.CurrHeapUsed;
end;

26
tests/webtbs/tw0630.pp
View File

@ -1,34 +1,22 @@
{ Program 1 : memory waste
dummy test }
USES SysUtils;
USES SysUtils,erroru;
procedure test_it;
var
sRec : TSearchRec;
begin
writeln(memAvail);
findFirst('c:\*.*',faVolumeId,sRec);
findClose(sRec);
writeln(sRec.name);
writeln(memAvail); { 288 bytes waste ! }
end;
begin
Writeln('Before call ',MemAvail);
test_it;
Writeln('After call : ',MemAvail);
end.
(*{ Program 2 : correct }
USES Dos;
var
sRec : searchRec;
mem : sizeint;
begin
writeln(memAvail);
findFirst('c:\*.*',volumeid,sRec);
findClose(sRec);
writeln(sRec.name);
writeln(memAvail); { no memory waste ! }
end. *)
mem:=0;
DoMem(mem);
test_it;
DoMem(mem);
end.

13
tests/webtbs/tw0812.pp
View File

@ -1,5 +1,6 @@
program TestVm2;
uses
erroru;
procedure Test;
var
P: Pointer;
@ -9,13 +10,11 @@ begin
ReAllocMem(P, 0);
end;
var MemBefore : longint;
var Mem : sizeint;
begin
writeln(MemAvail);
MemBefore:=MemAvail;
domem(mem);
Test;
writeln(MemAvail);
if MemBefore<>MemAvail then
if domem(mem)<>0 then
begin
Writeln('ReAllocMem creates emory leaks');
Writeln('Bug 812 is not yet fixed');

10
tests/webtbs/tw0813.pp
View File

@ -1,4 +1,4 @@
program TestVm2;
uses erroru;
procedure Test;
var
@ -15,13 +15,11 @@ begin
end;
end;
var MemBefore : longint;
var Mem : sizeint;
begin
writeln(heapsize-MemAvail);
MemBefore:=heapsize-MemAvail;
domem(mem);
Test;
writeln(heapsize-MemAvail);
if MemBefore<>heapsize-MemAvail then
if domem(mem)<>0 then
begin
Writeln('ReAllocMem creates emory leaks');
Writeln('Bug 812 is not yet fixed');

10
tests/webtbs/tw1658.pp
View File

@ -4,7 +4,7 @@
program Buggy;
uses
erroru,
Objects, Strings;
type
@ -31,10 +31,9 @@ end;
// Global vars
var
pTempStream: PMyStream;
EntryMem,ExitMem : Cardinal;
// Main routine
mem : sizeint;
begin
EntryMem:=heapsize-MemAvail;
DoMem(mem);
pTempStream := nil;
pTempStream := New(PMyStream, Init('tw1658.tmp', stCreate));
if not Assigned(pTempStream) then
@ -42,8 +41,7 @@ begin
pTempStream^.m_fAutoDelete := False;
Dispose(pTempStream, Done);
pTempStream := nil;
ExitMem:=heapsize-MemAvail;
If ExitMem<EntryMem then
if DoMem(mem)<>0 then
begin
Writeln('Memory lost');
Halt(1);

9
tests/webtbs/tw2494.pp
View File

@ -1,7 +1,8 @@
{ Source provided for Free Pascal Bug Report 2494 }
{ Submitted by "Alan Mead" on 2003-05-17 }
{ e-mail: cubrewer@yahoo.com }
program dummy;
uses
erroru;
type
matrix_element = array[1..1] of byte;
@ -17,11 +18,10 @@ var p:pointer;
size, storage : longint;
i,j:longint;
done:boolean;
mem : sizeint;
begin
ReturnNilIfGrowHeapFails:=true;
writeln('Total heap available is ',MemAvail,' bytes');
writeln('Largest block available is ',MaxAvail,' bytes');
domem(mem);
done := false;
size := 40000000;
repeat
@ -40,5 +40,6 @@ begin
freemem(l,storage);
end;
until (done);
domem(mem);
end.

7
tests/webtbs/tw3004.pp
View File

@ -5,7 +5,7 @@
{$H+}
{ $mode DELPHI}
uses SysUtils;
uses erroru,SysUtils;
procedure P;
var s:string;
@ -18,12 +18,13 @@ procedure p1;
var
i : sizeint;
begin
i:=heapsize-memavail;
i:=0;
domem(i);
try
P;
except
end;
if i<>heapsize-memavail then
if domem(i)<>0 then
begin
writeln('Memleak');
halt(1);

1
tests/webtbs/tw3131.pp
View File

@ -5,6 +5,7 @@
{ e-mail: Arnstein.Prytz@jcu.edu.au }
program tmp;
{$goto on}
{$asmmode intel}
procedure l;

11
tests/webtbs/tw3334.pp
View File

@ -5,7 +5,8 @@ program project1;
{$mode objfpc}{$H+}
uses
uses
erroru,
Classes;
procedure p1;
@ -19,13 +20,11 @@ begin
end;
var
mem1,mem2 : longint;
mem : sizeint;
begin
mem1:=heapsize-memavail;
domem(mem);
p1;
mem2:=heapsize-memavail;
writeln(mem1,' - ',mem2);
if mem1<>mem2 then
if domem(mem)<>0 then
halt(1);
end.

9
tests/webtbs/uw0701d.pp
View File

@ -4,13 +4,16 @@ unit uw0701d;
implementation
uses erroru;
var
startmem : longint;
startmem : sizeint;
initialization
startmem:=heapsize-memavail;
startmem:=0;
DoMem(startmem);
finalization
if startmem<>heapsize-memavail then
if DoMem(startmem)<>0 then
begin
writeln('Problem with ansistrings in units');
halt(1);