paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-10-18 00:11:30 +02:00
Code Issues Packages Projects Releases Wiki Activity
ed449defca
fpc/rtl/inc/dynarr.inc
florian 6476fbf2fe * fixed and added a lot of stuff to get the Jedi DX( headers 
compiled
2001-08-19 21:02:01 +00:00

270 lines
8.7 KiB
PHP
Raw Blame History

{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2000 by Florian Klaempfl
member of the Free Pascal development team.
This file implements the helper routines for dyn. Arrays in FPC
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
}
type
{ don't add new fields, the size is used }
{ to calculate memory requirements }
pdynarray = ^tdynarray;
tdynarray = packed record
refcount : longint;
high : tdynarrayindex;
end;
pdynarraytypeinfo = ^tdynarraytypeinfo;
tdynarraytypeinfo = packed record
kind : byte;
namelen : byte;
{ here the chars follow, we've to skip them }
elesize : t_size;
eletype : pdynarraytypeinfo;
end;
function fpc_dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(p) then
fpc_dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high+1
else
fpc_dynarray_length:=0;
end;
function fpc_dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_HIGH']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
if assigned(p) then
fpc_dynarray_high:=pdynarray(p-sizeof(tdynarray))^.high
else
fpc_dynarray_high:=-1;
end;
{ releases and finalizes the data of a dyn. array and sets p to nil }
procedure dynarray_clear(var p : pdynarray;ti : pdynarraytypeinfo);
begin
{ skip kind and name }
inc(pointer(ti),ord(ti^.namelen));
{ finalize all data }
int_finalizearray(p,ti^.eletype,p^.high+1,ti^.elesize);
{ release the data }
freemem(p,sizeof(tdynarray)+(p^.high+1)*ti^.elesize);
p:=nil;
end;
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer);[Public,Alias:'FPC_DYNARRAY_DECR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
realp : pdynarray;
begin
if p=nil then
exit;
realp:=pdynarray(p-sizeof(tdynarray));
if realp^.refcount=0 then
HandleErrorFrame(204,get_frame);
{ decr. ref. count }
{ should we remove the array? }
if declocked(realp^.refcount) then
dynarray_clear(realp,pdynarraytypeinfo(ti));
p:=nil;
end;
{$ifdef hascompilerproc}
{ provide local access to dynarr_decr_ref for dynarr_setlength }
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer); [external name 'FPC_DYNARRAY_DECR_REF'];
{$endif}
procedure fpc_dynarray_incr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_INCR_REF']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
realp : pdynarray;
begin
if p=nil then
exit;
realp:=pdynarray(p-sizeof(tdynarray));
if realp^.refcount=0 then
HandleErrorFrame(204,get_frame);
inclocked(realp^.refcount);
end;
{$ifdef hascompilerproc}
{ 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'];
{$endif}
{ provide local access to dynarr_setlength }
procedure int_dynarray_setlength(var p : pointer;pti : pointer;
dimcount : dword;dims : pdynarrayindex);[external name 'FPC_DYNARR_SETLENGTH'];
procedure fpc_dynarray_setlength(var p : pointer;pti : pointer;
dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH']; {$ifdef hascompilerproc} compilerproc; {$endif}
var
i : tdynarrayindex;
size : t_size;
{ contains the "fixed" pointers where the refcount }
{ and high are at positive offsets }
realp,newp : pdynarray;
ti : pdynarraytypeinfo;
begin
ti:=pdynarraytypeinfo(pti);
{ skip kind and name }
inc(pointer(ti),ord(ti^.namelen));
{ determine new memory size }
size:=ti^.elesize*dims[0]+sizeof(tdynarray);
{ not assigned yet? }
if not(assigned(p)) then
begin
getmem(newp,size);
fillchar(newp^,size,0);
end
else
begin
realp:=pdynarray(p-sizeof(tdynarray));
if dims[0]<0 then
HandleErrorFrame(201,get_frame);
{ if the new dimension is 0, we've to release all data }
if dims[0]=0 then
begin
dynarray_clear(realp,pdynarraytypeinfo(pti));
p:=nil;
exit;
end;
if realp^.refcount<>1 then
begin
{ make an unique copy }
getmem(newp,size);
move(p^,(pointer(newp)+sizeof(tdynarray))^,ti^.elesize*dims[0]);
{ increment ref. count of members }
for i:=0 to dims[0]-1 do
int_addref(pointer(newp)+sizeof(tdynarray)+ti^.elesize*i,ti^.eletype);
{ a declock(ref. count) isn't enough here }
{ it could be that the in MT enviroments }
{ in the mean time the refcount was }
{ decremented }
{ it is, because it doesn't really matter }
{ if the array is now removed }
fpc_dynarray_decr_ref(p,ti);
end
else if dims[0]<>realp^.high+1 then
begin
{ range checking is quite difficult ... }
{ if size overflows then it is less than }
{ the values it was calculated from }
if (size<sizeof(tdynarray)) or
((ti^.elesize>0) and (size<ti^.elesize)) then
HandleErrorFrame(201,get_frame);
{ resize? }
if realp^.refcount=1 then
begin
{ shrink the array? }
if dims[0]<realp^.high+1 then
begin
int_finalizearray(pointer(realp)+sizeof(tdynarray)+ti^.elesize*dims[0],
ti^.eletype,realp^.high-dims[0]+1,ti^.elesize);
reallocmem(realp,size);
end
else if dims[0]>realp^.high+1 then
begin
reallocmem(realp,size);
fillchar((pointer(realp)+sizeof(tdynarray)+ti^.elesize*(realp^.high+1))^,
(dims[0]-realp^.high-1)*ti^.elesize,0);
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;
p:=pointer(newp)+sizeof(tdynarray);
newp^.refcount:=1;
newp^.high:=dims[0]-1;
end;
function fpc_dynarray_copy(var p : pointer;ti : pointer;
dimcount : dword;dims : pdynarrayindex) : pointer;[Public,Alias:'FPC_DYNARRAY_COPY']; {$ifdef hascompilerproc} compilerproc; {$endif}
begin
{ note: ti is of type pdynarrayinfo, but it can't be declared }
{ that way because this procedure is also declared in the interface }
{ (as compilerproc) and the pdynarraytypeinfo isn't available there }
{!!!!!!!!!!}
end;
{
$Log$
Revision 1.9 2001-08-19 21:02:01 florian
* fixed and added a lot of stuff to get the Jedi DX( headers
compiled
Revision 1.8 2001/08/01 15:00:10 jonas
+ "compproc" helpers
* renamed several helpers so that their name is the same as their
"public alias", which should facilitate the conversion of processor
specific code in the code generator to processor independent code
* some small fixes to the val_ansistring and val_widestring helpers
(always immediately exit if the source string is longer than 255
chars)
* fixed fpc_dynarray_high and fpc_dynarray_length if the dynarray is
still nil (used to crash, now return resp -1 and 0)
Revision 1.7 2001/05/27 14:28:44 florian
+ made the ref. couting MT safe
Revision 1.6 2001/04/13 23:49:48 peter
* fixes for the stricter compiler
Revision 1.5 2000/12/01 23:30:00 florian
* fixed some bugs in setlength
Revision 1.4 2000/11/12 23:23:34 florian
* interfaces basically running
Revision 1.3 2000/11/07 23:42:21 florian
+ AfterConstruction and BeforeDestruction implemented
+ TInterfacedObject implemented
Revision 1.2 2000/11/06 21:35:59 peter
* removed some warnings
Revision 1.1 2000/11/04 17:52:46 florian
* fixed linker errors
}
Reference in New Issue View Git Blame Copy Permalink