From d30f99c17e3ddbb4a36d71d60a34a36861c583e3 Mon Sep 17 00:00:00 2001 From: peter Date: Fri, 26 Nov 2004 21:59:49 +0000 Subject: [PATCH] * use domem() for heap checking --- tests/tbs/tb0239.pp | 19 ++++++++----------- tests/tbs/tb0240.pp | 19 ++++++------------- tests/test/tobject1.pp | 33 ++++++++++++++++----------------- tests/units/erroru.pp | 32 ++++++++++++++++++++++++++++---- tests/webtbs/tw0630.pp | 26 +++++++------------------- tests/webtbs/tw0812.pp | 13 ++++++------- tests/webtbs/tw0813.pp | 10 ++++------ tests/webtbs/tw1658.pp | 10 ++++------ tests/webtbs/tw2494.pp | 9 +++++---- tests/webtbs/tw3004.pp | 7 ++++--- tests/webtbs/tw3131.pp | 1 + tests/webtbs/tw3334.pp | 11 +++++------ tests/webtbs/uw0701d.pp | 9 ++++++--- 13 files changed, 100 insertions(+), 99 deletions(-) diff --git a/tests/tbs/tb0239.pp b/tests/tbs/tb0239.pp index dcd748d385..62a4cbd69a 100644 --- a/tests/tbs/tb0239.pp +++ b/tests/tbs/tb0239.pp @@ -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. diff --git a/tests/tbs/tb0240.pp b/tests/tbs/tb0240.pp index 0fb93acec1..beaf247861 100644 --- a/tests/tbs/tb0240.pp +++ b/tests/tbs/tb0240.pp @@ -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. diff --git a/tests/test/tobject1.pp b/tests/test/tobject1.pp index d90e29bd4a..76a4adc3bd 100644 --- a/tests/test/tobject1.pp +++ b/tests/test/tobject1.pp @@ -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. diff --git a/tests/units/erroru.pp b/tests/units/erroru.pp index 20068fdc69..b4d03b5d85 100644 --- a/tests/units/erroru.pp +++ b/tests/units/erroru.pp @@ -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; diff --git a/tests/webtbs/tw0630.pp b/tests/webtbs/tw0630.pp index 3c9438fc04..5edbe418e6 100644 --- a/tests/webtbs/tw0630.pp +++ b/tests/webtbs/tw0630.pp @@ -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. \ No newline at end of file diff --git a/tests/webtbs/tw0812.pp b/tests/webtbs/tw0812.pp index 24a0359ff9..836dc62bff 100644 --- a/tests/webtbs/tw0812.pp +++ b/tests/webtbs/tw0812.pp @@ -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'); diff --git a/tests/webtbs/tw0813.pp b/tests/webtbs/tw0813.pp index f47420c1b8..b2c4fa6b79 100644 --- a/tests/webtbs/tw0813.pp +++ b/tests/webtbs/tw0813.pp @@ -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'); diff --git a/tests/webtbs/tw1658.pp b/tests/webtbs/tw1658.pp index db551d3840..123c3a35b6 100644 --- a/tests/webtbs/tw1658.pp +++ b/tests/webtbs/tw1658.pp @@ -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 ExitMem0 then begin Writeln('Memory lost'); Halt(1); diff --git a/tests/webtbs/tw2494.pp b/tests/webtbs/tw2494.pp index cebc233ea3..80680aee2e 100644 --- a/tests/webtbs/tw2494.pp +++ b/tests/webtbs/tw2494.pp @@ -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. diff --git a/tests/webtbs/tw3004.pp b/tests/webtbs/tw3004.pp index 5030ba4401..522be98ae0 100644 --- a/tests/webtbs/tw3004.pp +++ b/tests/webtbs/tw3004.pp @@ -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); diff --git a/tests/webtbs/tw3131.pp b/tests/webtbs/tw3131.pp index 862278b8cc..07c62ac2d5 100644 --- a/tests/webtbs/tw3131.pp +++ b/tests/webtbs/tw3131.pp @@ -5,6 +5,7 @@ { e-mail: Arnstein.Prytz@jcu.edu.au } program tmp; +{$goto on} {$asmmode intel} procedure l; diff --git a/tests/webtbs/tw3334.pp b/tests/webtbs/tw3334.pp index 84c398b0a2..60a25557f8 100644 --- a/tests/webtbs/tw3334.pp +++ b/tests/webtbs/tw3334.pp @@ -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. diff --git a/tests/webtbs/uw0701d.pp b/tests/webtbs/uw0701d.pp index a391305aeb..a193d2268f 100644 --- a/tests/webtbs/uw0701d.pp +++ b/tests/webtbs/uw0701d.pp @@ -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);