* memavail fixes

tests/test/tclass5.pp

@@ -22,7 +22,6 @@ program test_fail;
        end;
   var
     ta1, ta2 : tarraycla;
-    availmem : longint;
 
   constructor tarraycla.create(do_fail : boolean);
     begin
@@ -63,7 +62,6 @@ program test_fail;
     end;
 
   begin
-     availmem:=memavail;
      ta1:=tarraycla.create(false);
      writeln('Call to ta1.test after successful init');
      ta1.test;

tests/test/texception3.pp

@@ -600,11 +600,11 @@ procedure test119;
   end;
 
 var
-   startmemavail : longint;
-
+  hstatusstart,
+  hstatusend : theapstatus;
 begin
    writeln('Testing exception handling');
-   startmemavail:=memavail;
+   getheapstatus(hstatusstart);
    i:=-1;
    try
      test1;
@@ -769,7 +769,8 @@ begin
    if i<>2 then
      do_error(1119);
 
-   if memavail<startmemavail then
+   getheapstatus(hstatusend);
+   if hstatusstart.Currheapused<>hstatusend.Currheapused then
      begin
        writeln('exception generates memory holes');
        do_error(99999);

tests/test/theap.pp

@@ -5,6 +5,8 @@
 }
 PROGRAM TestHeap;
 
+uses
+  erroru;
 
 const
 {$ifdef cpusparc}
@@ -27,8 +29,10 @@ end;
 
 
 procedure ShowHeap;
+var
+  hstatus : THeapstatus;
 begin
-   WriteLn ('MaxAvail: ', MaxAvail, '   MemAvail: ', MemAvail,'   Heapsize: ',Heapsize);
+   WriteLn ('Used: ', hstatus.CurrHeapUsed, '   Free: ', hstatus.CurrHeapFree,'   Size: ',hstatus.CurrHeapSize);
 end;
 
 
@@ -143,21 +147,6 @@ BEGIN
    Inc (TotalTime, Delta);
    WriteLn (Delta:5, ' ms');
    ShowHeap;
-   Start := MSTimer;
-   FOR L := 1 TO Blocks DO BEGIN
-      MaxAvail;
-   END;
-   Delta := MSTimer-Start;
-   Inc (TotalTime, (Delta + 5) DIV 10);
-   WriteLn (Blocks,' calls to MaxAvail:                        ', Delta:5, ' ms');
-   Start := MSTimer;
-   FOR L := 1 TO Blocks DO BEGIN
-      MemAvail;
-   END;
-   Delta := MSTimer - Start;
-   Inc (TotalTime, (Delta + 5) DIV 10);
-   WriteLn (Blocks,' calls to MemAvail:                        ', Delta:5, ' ms');
-   ShowHeap;
    Write ('Reallocating deallocated ',(Blocks div 2 + 1),' blocks at random: ');
    Start := MSTimer;
    FOR L := (Blocks div 2+1) TO Blocks DO BEGIN

tests/test/tobject1.pp

@@ -3,6 +3,9 @@
 
 program test_fail;
 
+  uses
+    erroru;
+    
   type
      parrayobj = ^tarrayobj;
      tarrayobj = object
@@ -64,20 +67,24 @@ program test_fail;
     end;
 
   begin
-     availmem:=memavail;
      new(pa1,init(false));
-     writeln('After successful new(pa1,init), memory used = ',availmem - memavail);
+     getheapstatus(hstatus);
+     writeln('After successful new(pa1,init), memory used = ',hstatus.CurrHeapUsed);
      new(pa2,init(true));
-     writeln('After unsuccessful new(pa2,init), memory used = ',availmem - memavail);
+     getheapstatus(hstatus);
+     writeln('After unsuccessful new(pa2,init), memory used = ',hstatus.CurrHeapUsed);
      writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2));
      writeln('Call to pa1^.test after successful init');
      pa1^.test;
      dispose(pa1,done);
-     writeln('After release of pa1, memory used = ',availmem - memavail);
+     getheapstatus(hstatus);
+     writeln('After release of pa1, memory used = ',hstatus.CurrHeapUsed);
      pa1:=new(pbigarrayobj,good_init);
-     writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',availmem - memavail);
+     getheapstatus(hstatus);
+     writeln('After successful pa1:=new(pbigarrayobj,good_init), memory used = ',hstatus.CurrHeapUsed);
      pa2:=new(pbigarrayobj,wrong_init);
-     writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',availmem - memavail);
+     getheapstatus(hstatus);
+     writeln('After unsuccessful pa2:=new(pbigarrayobj,wrong_init), memory used = ',hstatus.CurrHeapUsed);
      writeln('pa1 = ',longint(pa1),' pa2 = ',longint(pa2));
      writeln('Call to pa1^.test after successful init');
      pa1^.test;

tests/test/tobject2.pp

@@ -94,10 +94,7 @@ var
  obj: pbase;
  devobj: tderived;
 Begin
- WriteLn(MemAvail);
  obj:=new(pbase,init(10));
  obj^.showit;
- WriteLn(MemAvail);
  dispose(obj,done);
- WriteLn(MemAvail);
 end.

tests/test/tstring4.pp

@@ -1,5 +1,8 @@
 Program ansitest;
 
+uses
+  erroru;
+  
 {$ifdef cpu68k}
   {$define COMP_IS_INT64}
 {$endif cpu68k}
@@ -10,33 +13,11 @@ Program ansitest;
   {$define COMP_IS_INT64}
 {$endif FPC_COMP_IS_INT64}
 
-{$ifdef ver1_0}
-type
-  ptrint=longint;
-  sizeint=longint;
-{$endif}
-
-{$ifndef fpc}
-type
-  ptrint=longint;
-  sizeint=longint;
-Function Memavail : ptrint;
-begin
- Result:=0;
-end;
-{$endif}
 
 { -------------------------------------------------------------------
     General stuff
   ------------------------------------------------------------------- }
 
-Procedure DoMem (Var StartMem : sizeint);
-
-begin
-  Writeln ('Lost ',StartMem-Memavail,' Bytes.');
-  StartMem:=MemAvail;
-end;
-
 Procedure DoRef (P : Pointer);
 
 Type Psizeint = ^sizeint;
@@ -142,7 +123,8 @@ Var S : AnsiString;
     Mem : sizeint;
 
 begin
-  Mem:=MemAvail;
+  Mem:=0;
+  DoMem(Mem);
   S :='This is another ansistring';
   Writeln ('Calling testvalparam with "',s,'"');
   testvalparam (s);
@@ -338,7 +320,8 @@ Var I : Integer;
     mem : sizeint;
 
 begin
- mem:=memavail;
+ mem:=0;
+ DoMem(mem);
  S3 := 'ABCDEF';
  Write ('S1+S2=S3 :');
  If S1+S2=S3 then writeln (ok) else writeln (nok);
@@ -381,7 +364,8 @@ Var S,T : AnsiString;
     Co : Comp;
     TempMem:sizeint;
 begin
-  TempMem:=Memavail;
+  TempMem:=0;
+  DoMem(TempMem);
   S:='ABCDEF';
   Write ('S = "',S,'"');Doref(Pointer(S));
   T:=Copy(S,1,3);
@@ -468,8 +452,10 @@ end;
 Var GlobalStartMem,StartMem : PtrInt;
 
 begin
-  GlobalStartMem:=MemAvail;
-  StartMem:=MemAvail;
+  GlobalStartMem:=0;
+  StartMem:=0;
+  DoMem(GlobalStartMem);
+  DoMem(StartMem);
   Writeln ('Testing Initialize/Finalize.');
   TestInitFinal;
   Write ('End of Initialize/finalize test : ');DoMem(StartMem);

tests/test/tstring6.pp

@@ -1,25 +1,13 @@
 { %VERSION=1.1 }
 Program widetest;
 
-Function MemUsed : Longint;
-begin
-{$ifdef fpc}
- MemUsed:=Heapsize-Memavail;
-{$else}
- MemUsed:=0;
-{$endif}
-end;
-
+uses
+  erroru;
+  
 { -------------------------------------------------------------------
     General stuff
   ------------------------------------------------------------------- }
 
-Procedure DoMem (Var StartMem : Longint);
-
-begin
-  Writeln ('Lost ',StartMem-MemUsed,' Bytes.');
-  StartMem:=MemUsed;
-end;
 
 Procedure DoRef (P : Pointer);
 
@@ -132,7 +120,8 @@ Var S : WideString;
     Mem : Longint;
 
 begin
-  Mem:=MemUsed;
+  Mem:=0;
+  DoMem(Mem);
   S :='This is another WideString';
   Writeln ('Calling testvalparam with "',s,'"');
   testvalparam (s);
@@ -329,7 +318,8 @@ Var I : Integer;
     mem : Longint;
 
 begin
- mem:=MemUsed;
+ mem:=0;
+ DoMem(Mem);
  S3 := 'ABCDEF';
  Write ('S1+S2=S3 :');
  If S1+S2=S3 then writeln (ok) else writeln (nok);
@@ -372,7 +362,8 @@ Var S,T : WideString;
     Co : Comp;
     TempMem:Longint;
 begin
-  TempMem:=MemUsed;
+  TempMem:=0;
+  DoMem(TempMem);
   S:='ABCDEF';
   Write ('S = "',S,'"');Doref(Pointer(S));
   T:=Copy(S,1,3);
@@ -459,8 +450,10 @@ end;
 Var GlobalStartMem,StartMem : Longint;
 
 begin
-  GlobalStartMem:=MemUsed;
-  StartMem:=MemUsed;
+  GlobalStartMem:=0;
+  StartMem:=0;
+  DoMem(GlobalStartMem);
+  DoMem(StartMem);
   Writeln ('Testing Initialize/Finalize.');
   TestInitFinal;
   Write ('End of Initialize/finalize test : ');DoMem(StartMem);

tests/units/erroru.pp

@@ -2,6 +2,13 @@
 unit erroru;
 interface
 
+{$ifdef ver1_0}
+type
+  ptrint=longint;
+  sizeint=longint;
+{$endif}
+
+
   procedure do_error(l : longint);
 
   procedure error;
@@ -10,6 +17,21 @@ interface
 
   procedure require_error(num : longint);
 
+{$ifndef HASGETHEAPSTATUS}
+type
+  THeapStatus = record
+    MaxHeapSize,
+    MaxHeapUsed,
+    CurrHeapSize,
+    CurrHeapUsed,
+    CurrHeapFree  : ptrint;
+  end;
+
+  procedure getheapstatus(var status:THeapStatus);
+{$endif HASGETHEAPSTATUS}
+
+Procedure DoMem (Var StartMem : sizeint);
+
 
 implementation
 
@@ -80,6 +102,29 @@ begin
      end;
 end;
 
+{$ifndef HASGETHEAPSTATUS}
+  procedure getheapstatus(var status:THeapStatus);
+  begin
+    fillchar(status,sizeof(status),0);
+    status.MaxHeapSize:=HeapSize;
+    status.MaxHeapUsed:=HeapSize-MemAvail;
+    status.CurrHeapSize:=HeapSize;
+    status.CurrHeapUsed:=HeapSize-MemAvail;
+    status.CurrHeapFree:=MemAvail;
+  end;
+{$endif HASGETHEAPSTATUS}
+
+
+Procedure DoMem (Var StartMem : sizeint);
+var
+  hstatus : THeapstatus;
+begin
+  GetHeapStatus(hstatus);
+  if StartMem<>0 then
+    Writeln ('Used: ',hstatus.CUrrHeapUsed shr 10,'Kb, Lost ',hstatus.CurrHeapUsed-StartMem,' Bytes.');
+  StartMem:=hstatus.CurrHeapUsed;
+end;
+
 
 initialization
 finalization