* tests fixed

tests/test/theap.inc

@@ -1,10 +1,161 @@
-{
+const
+{$if defined (cpusparc) or defined(cpui8086)}
+  Blocks = 1000;
+{$else}
+  Blocks = 10000;
+{$endif}
 
-  Program to test heap functions, timing doesn't work
-}
-PROGRAM TestHeap;
+Procedure InitMSTimer;
+begin
+end;
 
-uses
-  erroru;
 
-{$i theap.inc}
+
+{Get MS Timer}
+Function MSTimer:longint;
+begin
+  MSTimer:=0;
+end;
+
+
+procedure ShowHeap;
+var
+  hstatus : TFPCHeapstatus;
+begin
+   hstatus:=GetFPCHeapStatus;
+   WriteLn ('Used: ', hstatus.CurrHeapUsed, '   Free: ', hstatus.CurrHeapFree,'   Size: ',hstatus.CurrHeapSize);
+end;
+
+
+VAR Start, LoopTime,LoopTime2: LONGINT;
+    Delta, TotalTime: LONGINT;
+    L,Choice,K,T: WORD;
+    BlkPtr:  ARRAY [1..Blocks] OF POINTER;
+    BlkSize: ARRAY [1..Blocks] OF WORD;
+    Permutation: ARRAY [1..Blocks] OF WORD;
+
+BEGIN
+  INitMSTimer;
+   WriteLn ('Test of TP heap functions');
+   WriteLn;
+   TotalTime := 0;
+   RandSeed := 997;
+   ShowHeap;
+   Start :=MSTimer;
+   FOR L := 1 TO Blocks DO BEGIN
+   END;
+   LoopTime := MSTimer-Start;
+   FOR L := 1 TO Blocks DO BEGIN
+      BlkSize [L] := Random (512) + 1;
+   END;
+   Write ('Allocating ',Blocks,' blocks at the end of the heap: ');
+   Start := MSTImer;
+   FOR L := 1 TO Blocks DO BEGIN
+      GetMem (BlkPtr [L], BlkSize [L]);
+   END;
+   Delta := MSTimer-Start-LoopTime;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   Write ('Deallocating same ',Blocks,' blocks in reverse order:');
+   Start := MSTimer;
+   FOR L := 1 TO Blocks DO BEGIN
+      FreeMem (BlkPtr [L], BlkSize [L]);
+   END;
+   Delta := MSTimer-Start-LoopTime;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   Write ('Allocating ',Blocks,' blocks at the end of the heap: ');
+   Start := MSTimer;
+   FOR L := 1 TO Blocks DO BEGIN
+      GetMem (BlkPtr [L], BlkSize [L]);
+   END;
+   Delta := MSTimer-Start-LoopTime;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   FOR L := 1 TO Blocks DO BEGIN
+      Permutation [L] := L;
+   END;
+   Start := MSTimer;
+   FOR L := Blocks DOWNTO 1 DO BEGIN
+      Choice := Random (L)+1;
+      K := Permutation [Choice];
+      Permutation [Choice] := Permutation [L];
+   END;
+   LoopTime2 := MSTimer - Start;
+   FOR L := 1 TO Blocks DO BEGIN
+      Permutation [L] := L;
+   END;
+   Write ('Deallocating same ',Blocks,' blocks at random:       ');
+   Start := MSTimer;
+   FOR L := Blocks DOWNTO 1 DO BEGIN
+      Choice := Random (L)+1;
+      K := Permutation [Choice];
+      Permutation [Choice] := Permutation [L];
+      FreeMem (BlkPtr [K], BlkSize [K]);
+   END;
+   Delta := MSTimer - Start - LoopTime2;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   Write ('Allocating ',Blocks,' blocks at the end of the heap: ');
+   Start := MSTimer;
+   FOR L := 1 TO Blocks DO BEGIN
+      GetMem (BlkPtr [L], BlkSize [L]);
+   END;
+   Delta := MSTimer-Start-LoopTime;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   FOR L := 1 TO Blocks DO BEGIN
+      Permutation [L] := L;
+   END;
+   Start := MSTimer;
+   FOR L := Blocks DOWNTO 1 DO BEGIN
+      Choice := Random (L)+1;
+      K := Permutation [Choice];
+      T:= Permutation [L];
+      Permutation [L] := Permutation [Choice];
+      Permutation [Choice] := T;
+   END;
+   LoopTime2 := MSTimer - Start;
+   FOR L := 1 TO Blocks DO BEGIN
+      Permutation [L] := L;
+   END;
+   Write ('Deallocating ',(Blocks div 2 + 1),' blocks at random:             ');
+   Start := MSTimer;
+   FOR L := Blocks DOWNTO (Blocks div 2 + 1) DO BEGIN
+      Choice := Random (L)+1;
+      K := Permutation [Choice];
+      T:= Permutation [L];
+      Permutation [L] := Permutation [Choice];
+      Permutation [Choice] := T;
+      SYSTEM.FreeMem (BlkPtr [K], BlkSize [K]);
+   END;
+   Delta := MSTimer-Start-LoopTime2;
+   Inc (TotalTime, Delta);
+   WriteLn (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
+      GetMem (BlkPtr [Permutation [L]], BlkSize [Permutation [L]]);
+   END;
+   Delta := MSTimer-Start-LoopTime;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   Write ('Deallocating all ',Blocks,' blocks at random:        ');
+   Start := MSTimer;
+   FOR L := Blocks DOWNTO 1 DO BEGIN
+      FreeMem (BlkPtr [L], BlkSize [L]);
+   END;
+   Delta := MSTimer-Start-LoopTime;
+   Inc (TotalTime, Delta);
+   WriteLn (Delta:5, ' ms');
+   ShowHeap;
+   WriteLn;
+   WriteLn ('Total time for benchmark: ', TotalTime, ' ms');
+END.

tests/test/theap.pp

@@ -7,4 +7,4 @@ PROGRAM TestHeap;
 uses
   erroru;
 
-{$I heap.inc}
+{$I theap.inc}