paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 14:47:55 +02:00
Code Issues Packages Projects Releases Wiki Activity

* memavail fixes

Browse Source
This commit is contained in:
peter 2004-11-22 22:29:26 +00:00
parent c38daf68eb
commit bbb08436c5
8 changed files with 94 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
tests/test/tclass5.pp
View File

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

9
tests/test/texception3.pp
View File

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

21
tests/test/theap.pp
View File

@ -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

19
tests/test/tobject1.pp
View File

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

3
tests/test/tobject2.pp
View File

@ -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.

40
tests/test/tstring4.pp
View File

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

33
tests/test/tstring6.pp
View File

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

45
tests/units/erroru.pp
View File

@ -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