|
|
@@ -1,5 +1,5 @@
|
|
|
{
|
|
|
- $Id$
|
|
|
+ $Id$
|
|
|
This file is part of the Free Pascal run time library.
|
|
|
Copyright (c) 1993,97 by the Free Pascal development team.
|
|
|
|
|
|
@@ -43,9 +43,9 @@
|
|
|
const last_assigned : pheap_mem_info = nil;
|
|
|
const growheapstop : boolean = false;
|
|
|
|
|
|
- const free_nothing : boolean = false;
|
|
|
+ const free_nothing : boolean = false;
|
|
|
const trace : boolean = true;
|
|
|
- const getmem_nb : longint = 0;
|
|
|
+ const getmem_nb : longint = 0;
|
|
|
const freemem_nb : longint = 0;
|
|
|
{$EndIf CHECKHEAP}
|
|
|
|
|
|
@@ -61,7 +61,7 @@
|
|
|
|
|
|
type
|
|
|
tblocks = array[1..maxblock] of pointer;
|
|
|
- pblocks = ^tblocks;
|
|
|
+ pblocks = ^tblocks;
|
|
|
tnblocks = array[1..maxblock] of longint;
|
|
|
pnblocks = ^tnblocks;
|
|
|
pheapinfo = ^theapinfo;
|
|
|
@@ -87,7 +87,7 @@
|
|
|
baseheap : theapinfo;
|
|
|
curheap : pheapinfo;
|
|
|
{$ifdef TEMPHEAP}
|
|
|
- tempheap : theapinfo;
|
|
|
+ tempheap : theapinfo;
|
|
|
otherheap : pheapinfo;
|
|
|
{$endif TEMPHEAP}
|
|
|
|
|
|
@@ -130,8 +130,8 @@
|
|
|
|
|
|
function heapsize : longint;
|
|
|
|
|
|
- begin
|
|
|
- heapsize:=_heapsize;
|
|
|
+ begin
|
|
|
+ heapsize:=_heapsize;
|
|
|
end;
|
|
|
|
|
|
{$IfDef CHECKHEAP}
|
|
|
@@ -149,7 +149,7 @@
|
|
|
begin
|
|
|
writeln(i,' 0x',hexstr(pp^.calls[i],8));
|
|
|
end;
|
|
|
- end
|
|
|
+ end
|
|
|
else
|
|
|
writeln('tracing not enabled, sorry !!');
|
|
|
end;
|
|
|
@@ -174,34 +174,34 @@
|
|
|
call_stack(p+sizeof(heap_mem_info));
|
|
|
asm
|
|
|
movl (%ebp),%eax
|
|
|
- movl (%eax),%eax
|
|
|
- movl %eax,ebp
|
|
|
- end;
|
|
|
- dump_stack(ebp);
|
|
|
- end;
|
|
|
-
|
|
|
- function is_in_getmem_list (p : pointer) : boolean;
|
|
|
- var pp : pheap_mem_info;
|
|
|
- i : longint;
|
|
|
- begin
|
|
|
- is_in_getmem_list:=false;
|
|
|
- pp:=last_assigned;
|
|
|
- i:=0;
|
|
|
- while pp<>nil do
|
|
|
- begin
|
|
|
- if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
|
|
|
+ movl (%eax),%eax
|
|
|
+ movl %eax,ebp
|
|
|
+ end;
|
|
|
+ dump_stack(ebp);
|
|
|
+ end;
|
|
|
+
|
|
|
+ function is_in_getmem_list (p : pointer) : boolean;
|
|
|
+ var pp : pheap_mem_info;
|
|
|
+ i : longint;
|
|
|
+ begin
|
|
|
+ is_in_getmem_list:=false;
|
|
|
+ pp:=last_assigned;
|
|
|
+ i:=0;
|
|
|
+ while pp<>nil do
|
|
|
+ begin
|
|
|
+ if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
|
|
|
+ begin
|
|
|
+ writeln('error in linked list of heap_mem_info');
|
|
|
+ runerror(204);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if pp=p then
|
|
|
begin
|
|
|
- writeln('error in linked list of heap_mem_info');
|
|
|
- runerror(204);
|
|
|
- end;
|
|
|
-
|
|
|
- if pp=p then
|
|
|
- begin
|
|
|
- is_in_getmem_list:=true;
|
|
|
+ is_in_getmem_list:=true;
|
|
|
end;
|
|
|
pp:=pp^.previous;
|
|
|
inc(i);
|
|
|
- if i > getmem_nb - freemem_nb then
|
|
|
+ if i > getmem_nb - freemem_nb then
|
|
|
writeln('error in linked list of heap_mem_info');
|
|
|
end;
|
|
|
end;
|
|
|
@@ -218,8 +218,8 @@
|
|
|
exit;
|
|
|
end
|
|
|
else
|
|
|
- begin
|
|
|
- hp:=freelist;
|
|
|
+ begin
|
|
|
+ hp:=freelist;
|
|
|
while assigned(hp) do
|
|
|
begin
|
|
|
if (p>=hp) and (p<hp+hp^.size) then
|
|
|
@@ -237,32 +237,32 @@
|
|
|
function cal_memavail : longint;
|
|
|
|
|
|
var
|
|
|
- hp : pfreerecord;
|
|
|
+ hp : pfreerecord;
|
|
|
ma : longint;
|
|
|
- i : longint;
|
|
|
-
|
|
|
- begin
|
|
|
- ma:=heapend-heapptr;
|
|
|
- if heapblocks then
|
|
|
- for i:=1 to maxblock do
|
|
|
- ma:=ma+i*8*nblocks^[i];
|
|
|
- hp:=freelist;
|
|
|
- while assigned(hp) do
|
|
|
- begin
|
|
|
- ma:=ma+hp^.size;
|
|
|
+ i : longint;
|
|
|
+
|
|
|
+ begin
|
|
|
+ ma:=heapend-heapptr;
|
|
|
+ if heapblocks then
|
|
|
+ for i:=1 to maxblock do
|
|
|
+ ma:=ma+i*8*nblocks^[i];
|
|
|
+ hp:=freelist;
|
|
|
+ while assigned(hp) do
|
|
|
+ begin
|
|
|
+ ma:=ma+hp^.size;
|
|
|
{$IfDef CHECKHEAP}
|
|
|
- if (longint(hp^.next)=0) then
|
|
|
- begin
|
|
|
- if ((longint(hp)+hp^.size)>longint(heapptr)) then
|
|
|
- writeln('freerecordlist bad at end ')
|
|
|
- end
|
|
|
- else
|
|
|
- if ((longint(hp^.next)<=(longint(hp)+hp^.size)) or
|
|
|
+ if (longint(hp^.next)=0) then
|
|
|
+ begin
|
|
|
+ if ((longint(hp)+hp^.size)>longint(heapptr)) then
|
|
|
+ writeln('freerecordlist bad at end ')
|
|
|
+ end
|
|
|
+ else
|
|
|
+ if ((longint(hp^.next)<=(longint(hp)+hp^.size)) or
|
|
|
((hp^.size and 7) <> 0)) then
|
|
|
writeln('error in freerecord list ');
|
|
|
{$EndIf CHECKHEAP}
|
|
|
hp:=hp^.next;
|
|
|
- end;
|
|
|
+ end;
|
|
|
cal_memavail:=ma;
|
|
|
end;
|
|
|
|
|
|
@@ -289,8 +289,8 @@
|
|
|
tempheap.heapend:=heapend;
|
|
|
tempheap.memavail:=longint(tempheap.heapend) - longint(tempheap.heaporg);
|
|
|
tempheap.heapsize:=tempheap.memavail;
|
|
|
- getmem(tempheap.block,sizeof(tblocks));
|
|
|
- getmem(tempheap.nblock,sizeof(tnblocks));
|
|
|
+ getmem(tempheap.block,sizeof(tblocks));
|
|
|
+ getmem(tempheap.nblock,sizeof(tnblocks));
|
|
|
for i:=1 to maxblock do
|
|
|
begin
|
|
|
tempheap.block^[i]:=nil;
|
|
|
@@ -301,12 +301,12 @@
|
|
|
baseheap.memavail:=_memavail;
|
|
|
baseheap.heapsize:=longint(baseheap.heapend)-longint(baseheap.heaporg);
|
|
|
curheap:=@baseheap;
|
|
|
- otherheap:=@tempheap;
|
|
|
+ otherheap:=@tempheap;
|
|
|
heap_split:=true;
|
|
|
end;
|
|
|
end;
|
|
|
|
|
|
- procedure switch_to_temp_heap;
|
|
|
+ procedure switch_to_temp_heap;
|
|
|
begin
|
|
|
if curheap = @baseheap then
|
|
|
begin
|
|
|
@@ -320,12 +320,12 @@
|
|
|
{$IfDef CHECKHEAP}
|
|
|
baseheap.last_mem:=last_assigned;
|
|
|
last_assigned:=tempheap.last_mem;
|
|
|
- baseheap.nb_get:=getmem_nb;
|
|
|
+ baseheap.nb_get:=getmem_nb;
|
|
|
baseheap.nb_free:=freemem_nb;
|
|
|
- getmem_nb:=tempheap.nb_get;
|
|
|
+ getmem_nb:=tempheap.nb_get;
|
|
|
freemem_nb:=tempheap.nb_free;
|
|
|
{$EndIf CHECKHEAP}
|
|
|
- heaporg:=tempheap.heaporg;
|
|
|
+ heaporg:=tempheap.heaporg;
|
|
|
heapptr:=tempheap.heapptr;
|
|
|
freelist:=tempheap.freelist;
|
|
|
heapend:=tempheap.heapend;
|
|
|
@@ -345,13 +345,13 @@
|
|
|
tempheap.heapend:=heapend;
|
|
|
tempheap.heapptr:=heapptr;
|
|
|
tempheap.freelist:=freelist;
|
|
|
- tempheap.memavail:=_memavail;
|
|
|
+ tempheap.memavail:=_memavail;
|
|
|
{$IfDef CHECKHEAP}
|
|
|
tempheap.last_mem:=last_assigned;
|
|
|
last_assigned:=baseheap.last_mem;
|
|
|
- tempheap.nb_get:=getmem_nb;
|
|
|
- tempheap.nb_free:=freemem_nb;
|
|
|
- getmem_nb:=baseheap.nb_get;
|
|
|
+ tempheap.nb_get:=getmem_nb;
|
|
|
+ tempheap.nb_free:=freemem_nb;
|
|
|
+ getmem_nb:=baseheap.nb_get;
|
|
|
freemem_nb:=baseheap.nb_free;
|
|
|
{$EndIf CHECKHEAP}
|
|
|
heaporg:=baseheap.heaporg;
|
|
|
@@ -369,7 +369,7 @@
|
|
|
procedure switch_heap;
|
|
|
begin
|
|
|
if not heap_split then split_heap;
|
|
|
- if curheap = @tempheap then
|
|
|
+ if curheap = @tempheap then
|
|
|
switch_to_base_heap
|
|
|
else
|
|
|
switch_to_temp_heap;
|
|
|
@@ -381,7 +381,7 @@
|
|
|
split_heap;
|
|
|
switch_to_temp_heap;
|
|
|
allow_special:=true;
|
|
|
- getmem(p,size);
|
|
|
+ getmem(p,size);
|
|
|
allow_special:=false;
|
|
|
end;
|
|
|
{$endif TEMPHEAP}
|
|
|
@@ -389,12 +389,12 @@
|
|
|
function memavail : longint;
|
|
|
|
|
|
begin
|
|
|
- memavail:=_memavail;
|
|
|
+ memavail:=_memavail;
|
|
|
end;
|
|
|
|
|
|
{$ifdef TEMPHEAP}
|
|
|
procedure unsplit_heap;
|
|
|
- var hp,hp2,thp : pfreerecord;
|
|
|
+ var hp,hp2,thp : pfreerecord;
|
|
|
begin
|
|
|
{heapend can be modified by HeapError }
|
|
|
if not heap_split then exit;
|
|
|
@@ -413,7 +413,7 @@
|
|
|
hp^.next:=tempheap.freelist;
|
|
|
heapptr:=tempheap.heapptr;
|
|
|
end;
|
|
|
- heapend:=tempheap.heapend;
|
|
|
+ heapend:=tempheap.heapend;
|
|
|
_memavail:=cal_memavail;
|
|
|
heap_split:=false;
|
|
|
end else
|
|
|
@@ -433,12 +433,12 @@
|
|
|
hp:=hp^.next;
|
|
|
if assigned(hp^.next) then
|
|
|
begin
|
|
|
- thp:=hp^.next;
|
|
|
+ thp:=hp^.next;
|
|
|
hp^.next:=hp2;
|
|
|
hp:=thp;
|
|
|
end else
|
|
|
begin
|
|
|
- hp^.next:=hp2;
|
|
|
+ hp^.next:=hp2;
|
|
|
hp:=nil;
|
|
|
end;
|
|
|
end ;
|
|
|
@@ -457,7 +457,7 @@
|
|
|
begin
|
|
|
switch_to_temp_heap;
|
|
|
{$ifdef CHECKHEAP}
|
|
|
- if heapptr<>heaporg then
|
|
|
+ if heapptr<>heaporg then
|
|
|
writeln('Warning in releasetempheap : ',longint(tempheap.heapsize)-longint(tempheap.memavail),' bytes used !');
|
|
|
dump_heap(true);
|
|
|
{ release(heaporg);
|
|
|
@@ -477,25 +477,25 @@
|
|
|
maxavail:=heapend-heapptr;
|
|
|
hp:=freelist;
|
|
|
while assigned(hp) do
|
|
|
- begin
|
|
|
- if hp^.size>maxavail then
|
|
|
- maxavail:=hp^.size;
|
|
|
- hp:=hp^.next;
|
|
|
- end;
|
|
|
- end;
|
|
|
+ begin
|
|
|
+ if hp^.size>maxavail then
|
|
|
+ maxavail:=hp^.size;
|
|
|
+ hp:=hp^.next;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
|
|
|
{$ifdef CHECKHEAP}
|
|
|
- procedure test_memavail;
|
|
|
-
|
|
|
- begin
|
|
|
- if check and (_memavail<>cal_memavail) then
|
|
|
- begin
|
|
|
- writeln('Memavail error in getmem/freemem');
|
|
|
- end;
|
|
|
- end;
|
|
|
+ procedure test_memavail;
|
|
|
+
|
|
|
+ begin
|
|
|
+ if check and (_memavail<>cal_memavail) then
|
|
|
+ begin
|
|
|
+ writeln('Memavail error in getmem/freemem');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
{$endif CHECKHEAP}
|
|
|
|
|
|
- procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM'];
|
|
|
+ procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM'];
|
|
|
|
|
|
{$IfDef CHECKHEAP}
|
|
|
var i,bp,orsize : longint;
|
|
|
@@ -539,15 +539,15 @@
|
|
|
{$ifdef TEMPHEAP}
|
|
|
if heap_split and not allow_special then
|
|
|
begin
|
|
|
- if (@p < otherheap^.heapend) and
|
|
|
- (@p > otherheap^.heaporg) then
|
|
|
- { useful line for the debugger }
|
|
|
+ if (@p < otherheap^.heapend) and
|
|
|
+ (@p > otherheap^.heaporg) then
|
|
|
+ { useful line for the debugger }
|
|
|
writeln('warning : p and @p are in different heaps !');
|
|
|
end;
|
|
|
{$endif TEMPHEAP}
|
|
|
- { calc to multiply of 8 }
|
|
|
+ { calc to multiply of 8 }
|
|
|
size:=(size+7) and not 7;
|
|
|
- dec(_memavail,size);
|
|
|
+ _memavail:=_memavail-size;
|
|
|
if heapblocks then
|
|
|
begin
|
|
|
{ search cache }
|
|
|
@@ -570,7 +570,7 @@
|
|
|
repeat
|
|
|
nochmal:=false;
|
|
|
{ search the freelist }
|
|
|
- if assigned(freelist) then
|
|
|
+ if assigned(freelist) then
|
|
|
begin
|
|
|
last:=nil;
|
|
|
hp:=freelist;
|
|
|
@@ -583,57 +583,57 @@
|
|
|
{ need we the whole block ? }
|
|
|
if (hp^.size>size) and heapblocks then
|
|
|
begin
|
|
|
- { we must check if we are still below the limit !! }
|
|
|
- if hp^.size-size<=max_size then
|
|
|
- begin
|
|
|
- { adjust the list }
|
|
|
- if assigned(last) then
|
|
|
- last^.next:=hp^.next
|
|
|
- else
|
|
|
- freelist:=hp^.next;
|
|
|
- { insert in chain }
|
|
|
- s:=(hp^.size-size) div 8;
|
|
|
- ppointer(hp+size)^:=blocks^[s];
|
|
|
- blocks^[s]:=hp+size;
|
|
|
- inc(nblocks^[s]);
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- (hp+size)^.size:=hp^.size-size;
|
|
|
- (hp+size)^.next:=hp^.next;
|
|
|
- if assigned(last) then
|
|
|
- last^.next:=hp+size
|
|
|
- else
|
|
|
- freelist:=hp+size;
|
|
|
- end;
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
+ { we must check if we are still below the limit !! }
|
|
|
+ if hp^.size-size<=max_size then
|
|
|
+ begin
|
|
|
+ { adjust the list }
|
|
|
+ if assigned(last) then
|
|
|
+ last^.next:=hp^.next
|
|
|
+ else
|
|
|
+ freelist:=hp^.next;
|
|
|
+ { insert in chain }
|
|
|
+ s:=(hp^.size-size) div 8;
|
|
|
+ ppointer(hp+size)^:=blocks^[s];
|
|
|
+ blocks^[s]:=hp+size;
|
|
|
+ inc(nblocks^[s]);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ (hp+size)^.size:=hp^.size-size;
|
|
|
+ (hp+size)^.next:=hp^.next;
|
|
|
+ if assigned(last) then
|
|
|
+ last^.next:=hp+size
|
|
|
+ else
|
|
|
+ freelist:=hp+size;
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
{$IfDef CHECKHEAP}
|
|
|
- dec(freerecord_list_length);
|
|
|
+ dec(freerecord_list_length);
|
|
|
{$endif CHECKHEAP}
|
|
|
- if assigned(last) then
|
|
|
- last^.next:=hp^.next
|
|
|
- else
|
|
|
- {this was wrong !!}
|
|
|
- {freelist:=nil;}
|
|
|
- freelist:=hp^.next;
|
|
|
- end;
|
|
|
+ if assigned(last) then
|
|
|
+ last^.next:=hp^.next
|
|
|
+ else
|
|
|
+ {this was wrong !!}
|
|
|
+ {freelist:=nil;}
|
|
|
+ freelist:=hp^.next;
|
|
|
+ end;
|
|
|
{$ifdef CHECKHEAP}
|
|
|
goto check_new;
|
|
|
{$else CHECKHEAP}
|
|
|
exit;
|
|
|
{$endif CHECKHEAP}
|
|
|
- end;
|
|
|
+ end;
|
|
|
last:=hp;
|
|
|
hp:=hp^.next;
|
|
|
end;
|
|
|
end;
|
|
|
- { Latly, the top of the heap is checked, to see if there is }
|
|
|
+ { Latly, the top of the heap is checked, to see if there is }
|
|
|
{ still memory available. }
|
|
|
if heapend-heapptr<size then
|
|
|
begin
|
|
|
- if assigned(heaperror) then
|
|
|
+ if assigned(heaperror) then
|
|
|
begin
|
|
|
case call_heaperror(heaperror,size) of
|
|
|
0 : runerror(203);
|
|
|
@@ -658,11 +658,11 @@ check_new:
|
|
|
begin
|
|
|
asm
|
|
|
movl (%ebp),%eax
|
|
|
- movl %eax,bp
|
|
|
+ movl %eax,bp
|
|
|
end;
|
|
|
pheap_mem_info(p)^.sig:=$DEADBEEF;
|
|
|
pheap_mem_info(p)^.previous:=last_assigned;
|
|
|
- if last_assigned<>nil then
|
|
|
+ if last_assigned<>nil then
|
|
|
last_assigned^.next:=pheap_mem_info(p);
|
|
|
last_assigned:=p;
|
|
|
pheap_mem_info(p)^.next:=nil;
|
|
|
@@ -673,11 +673,11 @@ check_new:
|
|
|
bp:=get_next_frame(bp);
|
|
|
end;
|
|
|
p:=p+sizeof(heap_mem_info);
|
|
|
- end;
|
|
|
+ end;
|
|
|
{$endif CHECKHEAP}
|
|
|
end;
|
|
|
|
|
|
- procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM'];
|
|
|
+ procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM'];
|
|
|
|
|
|
var
|
|
|
hp : pfreerecord;
|
|
|
@@ -700,73 +700,73 @@ check_new:
|
|
|
p:=p-sizeof(heap_mem_info);
|
|
|
{ made after heap_switch
|
|
|
if not (is_in_getmem_list(p)) then
|
|
|
- runerror(204); }
|
|
|
+ runerror(204); }
|
|
|
end;
|
|
|
{$endif CHECKHEAP}
|
|
|
if size=0 then
|
|
|
begin
|
|
|
p:=nil;
|
|
|
- exit;
|
|
|
+ exit;
|
|
|
end;
|
|
|
- if p=nil then RunError (204);
|
|
|
+ if p=nil then RunError (204);
|
|
|
{$ifdef TEMPHEAP}
|
|
|
- heap_switched:=false;
|
|
|
- if heap_split and not allow_special then
|
|
|
- begin
|
|
|
- if (p <= heapptr) and
|
|
|
- ( p >= heaporg) and
|
|
|
- (@p <= otherheap^.heapend) and
|
|
|
- (@p >= otherheap^.heaporg) then
|
|
|
- begin
|
|
|
- writeln('warning : p and @p are in different heaps !');
|
|
|
- end;
|
|
|
- end;
|
|
|
- if (p<heaporg) or (p>heapptr) then
|
|
|
- begin
|
|
|
- if heap_split and (p<otherheap^.heapend) and
|
|
|
- (p>otherheap^.heaporg) then
|
|
|
- begin
|
|
|
- if (@p >= heaporg) and
|
|
|
- (@p <= heapptr) and
|
|
|
- not allow_special then
|
|
|
- writeln('warning : p and @p are in different heaps !');
|
|
|
- switch_heap;
|
|
|
- heap_switched:=true;
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- writeln('pointer ',hexstr(longint(@p),8),' at ',
|
|
|
- hexstr(longint(p),8),' doesn''t points to the heap');
|
|
|
- runerror(204);
|
|
|
- end;
|
|
|
- end;
|
|
|
+ heap_switched:=false;
|
|
|
+ if heap_split and not allow_special then
|
|
|
+ begin
|
|
|
+ if (p <= heapptr) and
|
|
|
+ ( p >= heaporg) and
|
|
|
+ (@p <= otherheap^.heapend) and
|
|
|
+ (@p >= otherheap^.heaporg) then
|
|
|
+ begin
|
|
|
+ writeln('warning : p and @p are in different heaps !');
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ if (p<heaporg) or (p>heapptr) then
|
|
|
+ begin
|
|
|
+ if heap_split and (p<otherheap^.heapend) and
|
|
|
+ (p>otherheap^.heaporg) then
|
|
|
+ begin
|
|
|
+ if (@p >= heaporg) and
|
|
|
+ (@p <= heapptr) and
|
|
|
+ not allow_special then
|
|
|
+ writeln('warning : p and @p are in different heaps !');
|
|
|
+ switch_heap;
|
|
|
+ heap_switched:=true;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ writeln('pointer ',hexstr(longint(@p),8),' at ',
|
|
|
+ hexstr(longint(p),8),' doesn''t points to the heap');
|
|
|
+ runerror(204);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
{$endif TEMPHEAP}
|
|
|
{$ifdef CHECKHEAP}
|
|
|
- if trace then
|
|
|
- begin
|
|
|
- if not (is_in_getmem_list(p)) then
|
|
|
- runerror(204);
|
|
|
- if pheap_mem_info(p)^.sig=$AAAAAAAA then
|
|
|
- dump_free(p);
|
|
|
- if pheap_mem_info(p)^.next<>nil then
|
|
|
- pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous;
|
|
|
- if pheap_mem_info(p)^.previous<>nil then
|
|
|
- pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next;
|
|
|
- if pheap_mem_info(p)=last_assigned then
|
|
|
- last_assigned:=last_assigned^.previous;
|
|
|
- end;
|
|
|
+ if trace then
|
|
|
+ begin
|
|
|
+ if not (is_in_getmem_list(p)) then
|
|
|
+ runerror(204);
|
|
|
+ if pheap_mem_info(p)^.sig=$AAAAAAAA then
|
|
|
+ dump_free(p);
|
|
|
+ if pheap_mem_info(p)^.next<>nil then
|
|
|
+ pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous;
|
|
|
+ if pheap_mem_info(p)^.previous<>nil then
|
|
|
+ pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next;
|
|
|
+ if pheap_mem_info(p)=last_assigned then
|
|
|
+ last_assigned:=last_assigned^.previous;
|
|
|
+ end;
|
|
|
{$endif CHECKHEAP}
|
|
|
- { calc to multiple of 8 }
|
|
|
- size:=(size+7) and not 7;
|
|
|
- inc(_memavail,size);
|
|
|
- if p+size>=heapptr then
|
|
|
- heapptr:=p
|
|
|
- { insert into cache }
|
|
|
- else
|
|
|
- if heapblocks and (size<=max_size) then
|
|
|
- begin
|
|
|
- s:=size div 8;
|
|
|
- ppointer(p)^:=blocks^[s];
|
|
|
+ { calc to multiple of 8 }
|
|
|
+ size:=(size+7) and not 7;
|
|
|
+ _memavail:=_memavail+size;
|
|
|
+ if p+size>=heapptr then
|
|
|
+ heapptr:=p
|
|
|
+ { insert into cache }
|
|
|
+ else
|
|
|
+ if heapblocks and (size<=max_size) then
|
|
|
+ begin
|
|
|
+ s:=size div 8;
|
|
|
+ ppointer(p)^:=blocks^[s];
|
|
|
blocks^[s]:=p;
|
|
|
inc(nblocks^[s]);
|
|
|
end
|
|
|
@@ -785,7 +785,7 @@ check_new:
|
|
|
inc(freerecord_list_length);
|
|
|
{$endif CHECKHEAP}
|
|
|
goto freemem_exit;
|
|
|
- end;
|
|
|
+ end;
|
|
|
if p+size<freelist then
|
|
|
begin
|
|
|
pfreerecord(p)^.next:=freelist;
|
|
|
@@ -794,22 +794,22 @@ check_new:
|
|
|
inc(freerecord_list_length);
|
|
|
{$endif CHECKHEAP}
|
|
|
goto freemem_exit;
|
|
|
- end
|
|
|
+ end
|
|
|
else
|
|
|
- if p+size=freelist then
|
|
|
- begin
|
|
|
- inc(pfreerecord(p)^.size,pfreerecord(freelist)^.size);
|
|
|
- pfreerecord(p)^.next:=pfreerecord(freelist)^.next;
|
|
|
- freelist:=p;
|
|
|
- { but now it can also connect the next block !!}
|
|
|
- if p+pfreerecord(p)^.size=pfreerecord(p)^.next then
|
|
|
- begin
|
|
|
- inc(pfreerecord(p)^.size,pfreerecord(p)^.next^.size);
|
|
|
+ if p+size=freelist then
|
|
|
+ begin
|
|
|
+ pfreerecord(p)^.size:=Pfreerecord(p)^.size+pfreerecord(freelist)^.size;
|
|
|
+ pfreerecord(p)^.next:=pfreerecord(freelist)^.next;
|
|
|
+ freelist:=p;
|
|
|
+ { but now it can also connect the next block !!}
|
|
|
+ if p+pfreerecord(p)^.size=pfreerecord(p)^.next then
|
|
|
+ begin
|
|
|
+ pfreerecord(p)^.size:=pfreerecord(p)^.size+pfreerecord(p)^.next^.size;
|
|
|
{$ifdef CHECKHEAP}
|
|
|
dec(freerecord_list_length);
|
|
|
{$endif CHECKHEAP}
|
|
|
pfreerecord(p)^.next:=pfreerecord(freelist)^.next^.next;
|
|
|
- end;
|
|
|
+ end;
|
|
|
goto freemem_exit;
|
|
|
end;
|
|
|
{ search the insert position }
|
|
|
@@ -817,68 +817,72 @@ check_new:
|
|
|
while assigned(hp) do
|
|
|
begin
|
|
|
if p<hp+hp^.size then
|
|
|
- begin
|
|
|
- writeln('pointer to dispose at ',hexstr(longint(p),8),
|
|
|
- ' has already been disposed');
|
|
|
- runerror(204);
|
|
|
- end;
|
|
|
- { connecting two blocks ? }
|
|
|
- if hp+hp^.size=p then
|
|
|
- begin
|
|
|
- inc(hp^.size,size);
|
|
|
- { connecting also to next block ? }
|
|
|
- if hp+hp^.size=hp^.next then
|
|
|
- begin
|
|
|
- inc(hp^.size,hp^.next^.size);
|
|
|
+ begin
|
|
|
{$ifdef CHECKHEAP}
|
|
|
- dec(freerecord_list_length);
|
|
|
+ writeln('pointer to dispose at ',hexstr(longint(p),8),
|
|
|
+ ' has already been disposed');
|
|
|
{$endif CHECKHEAP}
|
|
|
- hp^.next:=hp^.next^.next;
|
|
|
- end
|
|
|
- else
|
|
|
- if (hp^.next<>nil) and (hp+hp^.size>hp^.next) then
|
|
|
- begin
|
|
|
- writeln('pointer to dispose at ',hexstr(longint(p),8),
|
|
|
- ' is too big !!');
|
|
|
- runerror(204);
|
|
|
- end;
|
|
|
- break;
|
|
|
- end
|
|
|
- { if the end is reached, then concat }
|
|
|
- else if hp^.next=nil then
|
|
|
- begin
|
|
|
- hp^.next:=p;
|
|
|
+ runerror(204);
|
|
|
+ end;
|
|
|
+ { connecting two blocks ? }
|
|
|
+ if hp+hp^.size=p then
|
|
|
+ begin
|
|
|
+ hp^.size:=hp^.size+size;
|
|
|
+ { connecting also to next block ? }
|
|
|
+ if hp+hp^.size=hp^.next then
|
|
|
+ begin
|
|
|
+ hp^.size:=hp^.size+hp^.next^.size;
|
|
|
{$ifdef CHECKHEAP}
|
|
|
- inc(freerecord_list_length);
|
|
|
+ dec(freerecord_list_length);
|
|
|
{$endif CHECKHEAP}
|
|
|
- pfreerecord(p)^.next:=nil;
|
|
|
- break;
|
|
|
- end
|
|
|
- { falls der n„chste Zeiger gr”áer ist, dann }
|
|
|
- { Einh„ngen }
|
|
|
- else if hp^.next>p then
|
|
|
- begin
|
|
|
- { connect to blocks }
|
|
|
- if p+size=hp^.next then
|
|
|
- begin
|
|
|
- pfreerecord(p)^.next:=hp^.next^.next;
|
|
|
- inc(pfreerecord(p)^.size,hp^.next^.size);
|
|
|
- { we have to reset the right position }
|
|
|
- hp^.next:=pfreerecord(p);
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
+ hp^.next:=hp^.next^.next;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ if (hp^.next<>nil) and (hp+hp^.size>hp^.next) then
|
|
|
+ begin
|
|
|
+{$ifdef CHECKHEAP}
|
|
|
+ writeln('pointer to dispose at ',hexstr(longint(p),8),
|
|
|
+ ' is too big !!');
|
|
|
+{$endif CHECKHEAP}
|
|
|
+ runerror(204);
|
|
|
+ end;
|
|
|
+ break;
|
|
|
+ end
|
|
|
+ { if the end is reached, then concat }
|
|
|
+ else if hp^.next=nil then
|
|
|
+ begin
|
|
|
+ hp^.next:=p;
|
|
|
+{$ifdef CHECKHEAP}
|
|
|
+ inc(freerecord_list_length);
|
|
|
+{$endif CHECKHEAP}
|
|
|
+ pfreerecord(p)^.next:=nil;
|
|
|
+ break;
|
|
|
+ end
|
|
|
+ { falls der n„chste Zeiger gr”áer ist, dann }
|
|
|
+ { Einh„ngen }
|
|
|
+ else if hp^.next>p then
|
|
|
+ begin
|
|
|
+ { connect to blocks }
|
|
|
+ if p+size=hp^.next then
|
|
|
+ begin
|
|
|
+ pfreerecord(p)^.next:=hp^.next^.next;
|
|
|
+ pfreerecord(p)^.size:=pfreerecord(p)^.size+hp^.next^.size;
|
|
|
+ { we have to reset the right position }
|
|
|
+ hp^.next:=pfreerecord(p);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
pfreerecord(p)^.next:=hp^.next;
|
|
|
- hp^.next:=p;
|
|
|
+ hp^.next:=p;
|
|
|
{$ifdef CHECKHEAP}
|
|
|
inc(freerecord_list_length);
|
|
|
{$endif CHECKHEAP}
|
|
|
end;
|
|
|
- break;
|
|
|
+ break;
|
|
|
end;
|
|
|
hp:=hp^.next;
|
|
|
end;
|
|
|
- end;
|
|
|
+ end;
|
|
|
freemem_exit:
|
|
|
{$ifdef CHECKHEAP}
|
|
|
inc(freemem_nb);
|
|
|
@@ -893,7 +897,7 @@ check_new:
|
|
|
procedure release(var p : pointer);
|
|
|
|
|
|
begin
|
|
|
- heapptr:=p;
|
|
|
+ heapptr:=p;
|
|
|
freelist:=nil;
|
|
|
_memavail:=cal_memavail;
|
|
|
end;
|
|
|
@@ -904,7 +908,7 @@ check_new:
|
|
|
p:=heapptr;
|
|
|
end;
|
|
|
|
|
|
- procedure markheap(var oldfreelist,oldheapptr : pointer);
|
|
|
+ procedure markheap(var oldfreelist,oldheapptr : pointer);
|
|
|
|
|
|
begin
|
|
|
oldheapptr:=heapptr;
|
|
|
@@ -913,16 +917,16 @@ check_new:
|
|
|
_memavail:=cal_memavail;
|
|
|
end;
|
|
|
|
|
|
- procedure releaseheap(oldfreelist,oldheapptr : pointer);
|
|
|
+ procedure releaseheap(oldfreelist,oldheapptr : pointer);
|
|
|
|
|
|
begin
|
|
|
heapptr:=oldheapptr;
|
|
|
if longint(freelist) < longint(heapptr) then
|
|
|
- begin
|
|
|
+ begin
|
|
|
{here we should reget the freed blocks}
|
|
|
end;
|
|
|
freelist:=oldfreelist;
|
|
|
- _memavail:=cal_memavail;
|
|
|
+ _memavail:=cal_memavail;
|
|
|
end;
|
|
|
|
|
|
{ the sbrk function is moved to the system.pp }
|
|
|
@@ -948,40 +952,40 @@ begin
|
|
|
begin
|
|
|
GrowHeap:=0;
|
|
|
{$IfDef CHECKHEAP}
|
|
|
- writeln('Call to GrowHeap failed');
|
|
|
- readln;
|
|
|
- {$EndIf CHECKHEAP}
|
|
|
- Exit;
|
|
|
- end
|
|
|
+ writeln('Call to GrowHeap failed');
|
|
|
+ readln;
|
|
|
+ {$EndIf CHECKHEAP}
|
|
|
+ Exit;
|
|
|
+ end
|
|
|
else
|
|
|
- begin
|
|
|
- { make the room clean }
|
|
|
+ begin
|
|
|
+ { make the room clean }
|
|
|
{$ifdef CHECKHEAP}
|
|
|
- Fillword(pointer(NewPos)^,size div 2,$ABCD);
|
|
|
- Newlimit:= (newpos+size) or $3fff;
|
|
|
+ Fillword(pointer(NewPos)^,size div 2,$ABCD);
|
|
|
+ Newlimit:= (newpos+size) or $3fff;
|
|
|
{$else }
|
|
|
- Fillchar(pointer(NewPos)^,size,#0);
|
|
|
+ Fillchar(pointer(NewPos)^,size,#0);
|
|
|
{$endif }
|
|
|
- hp:=pfreerecord(freelist);
|
|
|
- if not assigned(hp) then
|
|
|
- begin
|
|
|
- if pointer(newpos) = heapend then
|
|
|
- heapend:=pointer(newpos+size)
|
|
|
- else
|
|
|
- begin
|
|
|
- if heapend - heapptr > 0 then
|
|
|
- begin
|
|
|
- freelist:=heapptr;
|
|
|
- hp:=pfreerecord(freelist);
|
|
|
- hp^.size:=heapend-heapptr;
|
|
|
- hp^.next:=nil;
|
|
|
- end;
|
|
|
- heapptr:=pointer(newpos);
|
|
|
- heapend:=pointer(newpos+size);
|
|
|
- end;
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
+ hp:=pfreerecord(freelist);
|
|
|
+ if not assigned(hp) then
|
|
|
+ begin
|
|
|
+ if pointer(newpos) = heapend then
|
|
|
+ heapend:=pointer(newpos+size)
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ if heapend - heapptr > 0 then
|
|
|
+ begin
|
|
|
+ freelist:=heapptr;
|
|
|
+ hp:=pfreerecord(freelist);
|
|
|
+ hp^.size:=heapend-heapptr;
|
|
|
+ hp^.next:=nil;
|
|
|
+ end;
|
|
|
+ heapptr:=pointer(newpos);
|
|
|
+ heapend:=pointer(newpos+size);
|
|
|
+ end;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
if pointer(newpos) = heapend then
|
|
|
heapend:=pointer(newpos+size)
|
|
|
else
|
|
|
@@ -1001,16 +1005,16 @@ begin
|
|
|
begin
|
|
|
pfreerecord(NewPos)^.Size:=Size;
|
|
|
pfreerecord(NewPos)^.Next:=hp^.next;
|
|
|
- hp^.next:=pfreerecord(NewPos);
|
|
|
+ hp^.next:=pfreerecord(NewPos);
|
|
|
end;
|
|
|
end;
|
|
|
end;
|
|
|
{ the wanted size has to be substracted }
|
|
|
- _memavail:=cal_memavail-wantedsize;
|
|
|
+ _memavail:=cal_memavail-wantedsize;
|
|
|
{ set the total new heap size }
|
|
|
asm
|
|
|
movl Size,%ebx
|
|
|
- movl HEAPSIZE,%eax
|
|
|
+ movl HEAPSIZE,%eax
|
|
|
addl %ebx,%eax
|
|
|
movl %eax,HEAPSIZE
|
|
|
end;
|
|
|
@@ -1057,7 +1061,13 @@ end;
|
|
|
|
|
|
{
|
|
|
$Log$
|
|
|
- Revision 1.7 1998-05-30 15:01:28 peter
|
|
|
+ Revision 1.8 1998-06-15 15:15:13 daniel
|
|
|
+
|
|
|
+
|
|
|
+ * Brought my policy into practive that the RTL should output only runtime
|
|
|
+ errors and no other texts when things go wrong.
|
|
|
+
|
|
|
+ Revision 1.7 1998/05/30 15:01:28 peter
|
|
|
* this needs also direct mode :(
|
|
|
|
|
|
Revision 1.6 1998/05/25 10:40:48 peter
|
daniel