* use domem() for heap checking

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
+  if DoMem(mem)<>0 then
-    begin
+    halt(1);
-      Writeln('Memory hole using pointers to ansi strings');
-      Halt(1);
-    end
-  else
-    Writeln('No memory hole with pointers to ansi strings');
 end.
 

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;
+  DoMem(mem);
-  writeln(memavail);
   dotest;
-  writeln(memavail);
+  if DoMem(mem)<>0 then
-  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');
 end.

tests/test/tobject1.pp

@@ -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('@self = ',ptrint(@self));
-      Writeln('typeof = ',longint(typeof(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)');
-     writeln('After successful new(pa1,init), memory used = ',hstatus.CurrHeapUsed);
      new(pa2,init(true));
-     getheapstatus(hstatus);
+     writeln('After unsuccessful new(pa2,init)');
-     writeln('After unsuccessful new(pa2,init), memory used = ',hstatus.CurrHeapUsed);
+     writeln('pa1 = ',ptrint(pa1),' pa2 = ',ptrint(pa2));
-     writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2));
      writeln('Call to pa1^.test after successful init');
      pa1^.test;
      dispose(pa1,done);
-     getheapstatus(hstatus);
+     writeln('After release of pa1');
-     writeln('After release of pa1, memory used = ',hstatus.CurrHeapUsed);
+     DoMem(mem);
      pa1:=new(pbigarrayobj,good_init);
-     getheapstatus(hstatus);
+     writeln('After successful pa1:=new(pbigarrayobj,good_init)');
-     writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',hstatus.CurrHeapUsed);
      pa2:=new(pbigarrayobj,wrong_init);
-     getheapstatus(hstatus);
+     writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init)');
-     writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',hstatus.CurrHeapUsed);
+     writeln('pa1 = ',ptrint(pa1),' pa2 = ',ptrint(pa2));
-     writeln('pa1 = ',longint(pa1),' pa2 = ',longint(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.

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
+  if StartMem=0 then
-    Writeln ('Used: ',hstatus.CUrrHeapUsed shr 10,'Kb, Lost ',hstatus.CurrHeapUsed-StartMem,' Bytes.');
+    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;
 

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);
+  mem:=0;
-        findFirst('c:\*.*',volumeid,sRec);
+  DoMem(mem);
-        findClose(sRec);
+  test_it;
-        writeln(sRec.name);
+  DoMem(mem);
-        writeln(memAvail);      { no memory waste ! }
+end.
-end. *)

tests/webtbs/tw0812.pp

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

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);
+  domem(mem);
-  MemBefore:=heapsize-MemAvail;
   Test;
-  writeln(heapsize-MemAvail);
+  if domem(mem)<>0 then
-  if MemBefore<>heapsize-MemAvail then
     begin
       Writeln('ReAllocMem creates emory leaks');
       Writeln('Bug 812 is not yet fixed');

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;
+  mem : sizeint;
-// Main routine
 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 DoMem(mem)<>0 then
-  If ExitMem<EntryMem then
     begin
       Writeln('Memory lost');
       Halt(1);

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');
+  domem(mem);
-  writeln('Largest block available is ',MaxAvail,' bytes');
   done := false;
   size := 40000000;
   repeat
@@ -40,5 +40,6 @@ begin
         freemem(l,storage);
       end;
   until (done);
+  domem(mem);
 end.
 

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);

tests/webtbs/tw3131.pp

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

tests/webtbs/tw3334.pp

@@ -6,6 +6,7 @@ program project1;
 {$mode objfpc}{$H+}
 
 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;
+  if domem(mem)<>0 then
-  writeln(mem1,' - ',mem2);
-  if mem1<>mem2 then
     halt(1);
 end.
 

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);