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

* fixed several bugs, most related to handling multi-dimensional

Browse Source 
dynamical arrays
This commit is contained in:
Jonas Maebe 2001-09-26 14:07:25 +00:00
parent 249311757a
commit da09ad93c7
1 changed files with 55 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
rtl/inc/dynarr.inc
View File

@ -59,7 +59,7 @@ procedure dynarray_clear(var p : pdynarray;ti : pdynarraytypeinfo);
inc(pointer(ti),ord(ti^.namelen)); inc(pointer(ti),ord(ti^.namelen));
{ finalize all data } { finalize all data }
int_finalizearray(p,ti^.eletype,p^.high+1,ti^.elesize); int_finalizearray(pointer(p)+sizeof(tdynarray),ti^.eletype,p^.high+1,ti^.elesize);
{ release the data } { release the data }
freemem(p,sizeof(tdynarray)+(p^.high+1)*ti^.elesize); freemem(p,sizeof(tdynarray)+(p^.high+1)*ti^.elesize);
@ -81,8 +81,10 @@ procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer);[Public,Alias:'FPC
{ decr. ref. count } { decr. ref. count }
{ should we remove the array? } { should we remove the array? }
if declocked(realp^.refcount) then if declocked(realp^.refcount) then
dynarray_clear(realp,pdynarraytypeinfo(ti)); begin
p:=nil; dynarray_clear(realp,pdynarraytypeinfo(ti));
p := nil;
end;
end; end;
{$ifdef hascompilerproc} {$ifdef hascompilerproc}
@ -106,7 +108,7 @@ procedure fpc_dynarray_incr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_INC
{$ifdef hascompilerproc} {$ifdef hascompilerproc}
{ provide local access to dynarr_decr_ref for dynarr_setlength } { provide local access to dynarr_decr_ref for dynarr_setlength }
procedure fpc_dynarray_incr_ref(var p : pointer;ti : pointer); [external name 'FPC_DYNARRAY_INCR_REF']; procedure fpc_dynarray_incr_ref(var p : pointer); [external name 'FPC_DYNARRAY_INCR_REF'];
{$endif} {$endif}
{ provide local access to dynarr_setlength } { provide local access to dynarr_setlength }
@ -117,12 +119,14 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif} dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
var var
movelen: cardinal;
i : tdynarrayindex; i : tdynarrayindex;
size : t_size; size : t_size;
{ contains the "fixed" pointers where the refcount } { contains the "fixed" pointers where the refcount }
{ and high are at positive offsets } { and high are at positive offsets }
realp,newp : pdynarray; realp,newp : pdynarray;
ti : pdynarraytypeinfo; ti : pdynarraytypeinfo;
updatep: boolean;
begin begin
ti:=pdynarraytypeinfo(pti); ti:=pdynarraytypeinfo(pti);
@ -130,23 +134,26 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
inc(pointer(ti),ord(ti^.namelen)); inc(pointer(ti),ord(ti^.namelen));
{ determine new memory size } { determine new memory size }
size:=ti^.elesize*dims[0]+sizeof(tdynarray); { dims[dimcount-1] because the dimensions are in reverse order! (JM) }
size:=ti^.elesize*dims[dimcount-1]+sizeof(tdynarray);
updatep := false;
{ not assigned yet? } { not assigned yet? }
if not(assigned(p)) then if not(assigned(p)) then
begin begin
getmem(newp,size); getmem(newp,size);
fillchar(newp^,size,0); fillchar(newp^,size,0);
updatep := true;
end end
else else
begin begin
realp:=pdynarray(p-sizeof(tdynarray)); realp:=pdynarray(p-sizeof(tdynarray));
if dims[0]<0 then if dims[dimcount-1]<0 then
HandleErrorFrame(201,get_frame); HandleErrorFrame(201,get_frame);
{ if the new dimension is 0, we've to release all data } { if the new dimension is 0, we've to release all data }
if dims[0]=0 then if dims[dimcount-1]=0 then
begin begin
dynarray_clear(realp,pdynarraytypeinfo(pti)); dynarray_clear(realp,pdynarraytypeinfo(pti));
p:=nil; p:=nil;
@ -155,12 +162,18 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
if realp^.refcount<>1 then if realp^.refcount<>1 then
begin begin
updatep := true;
{ make an unique copy } { make an unique copy }
getmem(newp,size); getmem(newp,size);
move(p^,(pointer(newp)+sizeof(tdynarray))^,ti^.elesize*dims[0]); fillchar(newp^,size,0);
if realp^.high < dims[dimcount-1] then
movelen := realp^.high+1
else
movelen := dims[dimcount-1];
move(p^,(pointer(newp)+sizeof(tdynarray))^,ti^.elesize*movelen);
{ increment ref. count of members } { increment ref. count of members }
for i:=0 to dims[0]-1 do for i:= 0 to movelen-1 do
int_addref(pointer(newp)+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype); int_addref(pointer(newp)+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype);
{ a declock(ref. count) isn't enough here } { a declock(ref. count) isn't enough here }
@ -170,9 +183,11 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
{ it is, because it doesn't really matter } { it is, because it doesn't really matter }
{ if the array is now removed } { if the array is now removed }
fpc_dynarray_decr_ref(p,ti); { fpc_dynarray_decr_ref(p,ti); }
if declocked(realp^.refcount) then
dynarray_clear(realp,pdynarraytypeinfo(ti));
end end
else if dims[0]<>realp^.high+1 then else if dims[dimcount-1]<>realp^.high+1 then
begin begin
{ range checking is quite difficult ... } { range checking is quite difficult ... }
@ -183,37 +198,43 @@ procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
HandleErrorFrame(201,get_frame); HandleErrorFrame(201,get_frame);
{ resize? } { resize? }
{ here, realp^.refcount has to be one, otherwise the previous }
{ if-statement would have been taken. Or is this also for MT }
{ code? (JM) }
if realp^.refcount=1 then if realp^.refcount=1 then
begin begin
{ shrink the array? } { shrink the array? }
if dims[0]<realp^.high+1 then if dims[dimcount-1]<realp^.high+1 then
begin begin
int_finalizearray(pointer(realp)+sizeof(tdynarray)+ti^.elesize*dims[0], int_finalizearray(pointer(realp)+sizeof(tdynarray)+
ti^.eletype,realp^.high-dims[0]+1,ti^.elesize); ti^.elesize*dims[dimcount-1],
ti^.eletype,realp^.high-dims[dimcount-1]+1,ti^.elesize);
reallocmem(realp,size); reallocmem(realp,size);
end end
else if dims[0]>realp^.high+1 then else if dims[dimcount-1]>realp^.high+1 then
begin begin
reallocmem(realp,size); reallocmem(realp,size);
fillchar((pointer(realp)+sizeof(tdynarray)+ti^.elesize*(realp^.high+1))^, fillchar((pointer(realp)+sizeof(tdynarray)+ti^.elesize*(realp^.high+1))^,
(dims[0]-realp^.high-1)*ti^.elesize,0); (dims[dimcount-1]-realp^.high-1)*ti^.elesize,0);
end; end;
newp := realp;
updatep := true;
end; end;
end
else
newp:=realp;
{ handle nested arrays }
if dimcount>1 then
begin
for i:=0 to dims[0]-1 do
int_dynarray_setlength(pointer(plongint(pointer(newp)+sizeof(tdynarray))[i*ti^.elesize]),
ti^.eletype,dimcount-1,@dims[1]);
end; end;
end; end;
p:=pointer(newp)+sizeof(tdynarray); { handle nested arrays }
newp^.refcount:=1; if dimcount>1 then
newp^.high:=dims[0]-1; begin
for i:=0 to dims[dimcount-1]-1 do
int_dynarray_setlength(pointer((pointer(newp)+sizeof(tdynarray)+i*ti^.elesize)^),
ti^.eletype,dimcount-1,dims);
end;
if updatep then
begin
p:=pointer(newp)+sizeof(tdynarray);
newp^.refcount:=1;
newp^.high:=dims[dimcount-1]-1;
end;
end; end;
@ -230,7 +251,11 @@ function fpc_dynarray_copy(var p : pointer;ti : pointer;
{ {
$Log$ $Log$
Revision 1.9 2001-08-19 21:02:01 florian Revision 1.10 2001-09-26 14:07:25 jonas
* fixed several bugs, most related to handling multi-dimensional
dynamical arrays
Revision 1.9 2001/08/19 21:02:01 florian
* fixed and added a lot of stuff to get the Jedi DX( headers * fixed and added a lot of stuff to get the Jedi DX( headers
compiled compiled