paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-02 08:30:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ ReturnNilIfGrowHeapFails used in objects unit

Browse Source 
to handle TMemoryStream out of memory properly
    as MaxAvail is not a good test anymore.
This commit is contained in:
pierre 2000-04-07 21:10:35 +00:00
parent 3fd094a0f0
commit e9f1439f5a
3 changed files with 45 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/inc/heap.inc
View File

@ -826,7 +826,10 @@ begin
NewPos:=Sbrk(size);
if NewPos=-1 then
begin
GrowHeap:=0;
if ReturnNilIfGrowHeapFails then
GrowHeap:=1
else
GrowHeap:=0;
Exit;
end;
end;
@ -881,7 +884,12 @@ end;
{
$Log$
Revision 1.36 2000-03-13 21:22:28 peter
Revision 1.37 2000-04-07 21:10:35 pierre
+ ReturnNilIfGrowHeapFails used in objects unit
to handle TMemoryStream out of memory properly
as MaxAvail is not a good test anymore.
Revision 1.36 2000/03/13 21:22:28 peter
* concat free blocks in main freelist
Revision 1.35 2000/03/10 12:41:21 pierre
@ -952,4 +960,4 @@ end;
Revision 1.16 1999/09/17 17:14:12 peter
+ new heap manager supporting delphi freemem(pointer)
}
}

10
rtl/inc/heaph.inc
View File

@ -36,6 +36,7 @@ function IsMemoryManagerSet: Boolean;
const
growheapsize1 : longint=256*1024; { < 256k will grow with 256k }
growheapsize2 : longint=1024*1024; { > 256k will grow with 1m }
ReturnNilIfGrowHeapFails : boolean = false;
var
heaporg,heapptr,heapend,heaperror,freelist : pointer;
@ -77,7 +78,12 @@ Procedure release(var p : pointer);
{
$Log$
Revision 1.17 2000-02-09 16:59:30 peter
Revision 1.18 2000-04-07 21:10:35 pierre
+ ReturnNilIfGrowHeapFails used in objects unit
to handle TMemoryStream out of memory properly
as MaxAvail is not a good test anymore.
Revision 1.17 2000/02/09 16:59:30 peter
* truncated log
Revision 1.16 2000/01/31 23:41:30 peter
@ -101,4 +107,4 @@ Procedure release(var p : pointer);
Revision 1.10 1999/09/17 17:14:12 peter
+ new heap manager supporting delphi freemem(pointer)
}
}

33
rtl/inc/objects.pp
View File

@ -1639,6 +1639,7 @@ END;
{---------------------------------------------------------------------------}
FUNCTION TMemoryStream.ChangeListSize (ALimit: Sw_Word): Boolean;
VAR I, W: Word; Li: LongInt; P: PPointerArray;
OldVal : Boolean;
BEGIN
If (ALimit <> BlkCount) Then Begin { Change is needed }
ChangeListSize := False; { Preset failure }
@ -1648,7 +1649,14 @@ BEGIN
If (MaxAvail > Li) Then Begin
GetMem(P, Li); { Allocate memory }
FillChar(P^, Li, #0); { Clear the memory }
End Else Exit; { Insufficient memory }
End Else Begin
OldVal:=ReturnNilIfGrowHeapFails;
ReturnNilIfGrowHeapFails:=true;
GetMem(P,Li);
ReturnNilIfGrowHeapFails:=OldVal;
If P = Nil Then Exit;
FillChar(P^, Li, #0); { Clear the memory }
End; { Insufficient memory }
If (BlkCount <> 0) AND (BlkList <> Nil) Then { Current list valid }
If (BlkCount <= ALimit) Then Move(BlkList^,
P^, BlkCount * SizeOf(Pointer)) Else { Move whole old list }
@ -1660,10 +1668,16 @@ BEGIN
If (P <> Nil) AND (ALimit > BlkCount) Then Begin { Expand stream size }
For W := BlkCount To ALimit-1 Do Begin
If (MaxAvail < BlkSize) Then Begin { Check enough memory }
For I := BlkCount To W-1 Do
FreeMem(P^[I], BlkSize); { Free mem allocated }
FreeMem(P, Li); { Release memory }
Exit; { Now exit }
OldVal:=ReturnNilIfGrowHeapFails;
ReturnNilIfGrowHeapFails:=true;
GetMem(P^[W],BlkSize);
ReturnNilIfGrowHeapFails:=OldVal;
If P = Nil Then Begin
For I := BlkCount To W-1 Do
FreeMem(P^[I], BlkSize); { Free mem allocated }
FreeMem(P, Li); { Release memory }
Exit;
End { Now exit }
End Else GetMem(P^[W], BlkSize); { Allocate memory }
End;
End;
@ -2786,7 +2800,12 @@ END;
END.
{
$Log$
Revision 1.36 2000-03-06 20:15:32 daniel
Revision 1.37 2000-04-07 21:10:35 pierre
+ ReturnNilIfGrowHeapFails used in objects unit
to handle TMemoryStream out of memory properly
as MaxAvail is not a good test anymore.
Revision 1.36 2000/03/06 20:15:32 daniel
+ Added is_object method to Tobject. It is similar to the is operator.
Revision 1.35 2000/02/09 16:59:30 peter
@ -2807,4 +2826,4 @@ END.
Revision 1.30 1999/09/10 17:15:13 peter
* fixed freeall
}
}