mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-21 15:29:25 +02:00
* interfaces basically running
This commit is contained in:
florian
parent
8f79c2cadd
commit
5da658c6db
@ -1117,7 +1117,6 @@ end;
|
||||
{$ifdef SYSTEMDEBUG}
|
||||
end;
|
||||
{$endif def SYSTEMDEBUG}
|
||||
{$ifdef HASINTF}
|
||||
{ do a thread save inc/dec }
|
||||
|
||||
procedure declocked(var l : longint);assembler;
|
||||
@ -1158,11 +1157,12 @@ procedure inclocked(var l : longint);assembler;
|
||||
.Linclockedend:
|
||||
end ['EDI'];
|
||||
|
||||
{$endif HASINTF}
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.4 2000-11-07 23:42:21 florian
|
||||
Revision 1.5 2000-11-12 23:23:34 florian
|
||||
* interfaces basically running
|
||||
|
||||
Revision 1.4 2000/11/07 23:42:21 florian
|
||||
+ AfterConstruction and BeforeDestruction implemented
|
||||
+ TInterfacedObject implemented
|
||||
|
||||
|
||||
@ -16,6 +16,10 @@
|
||||
**********************************************************************
|
||||
}
|
||||
|
||||
procedure FinalizeArray(data,typeinfo : pointer;count,size : longint);forward;
|
||||
Procedure Addref (Data,TypeInfo : Pointer);forward;
|
||||
Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
|
||||
type
|
||||
tdynarrayindex = longint;
|
||||
pdynarrayindex = ^tdynarrayindex;
|
||||
@ -23,39 +27,73 @@ type
|
||||
|
||||
{ don't add new fields, the size is used }
|
||||
{ to calculate memory requirements }
|
||||
tdynarray = record
|
||||
pdynarray = ^tdynarray;
|
||||
tdynarray = packed record
|
||||
refcount : dword;
|
||||
high : tdynarrayindex;
|
||||
end;
|
||||
|
||||
pdynarray = ^tdynarray;
|
||||
pdynarraytypeinfo = packed record
|
||||
pdynarraytypeinfo = ^tdynarraytypeinfo;
|
||||
tdynarraytypeinfo = packed record
|
||||
kind : byte;
|
||||
namelen : byte;
|
||||
// here the chars follow, we've to skip them
|
||||
{ here the chars follow, we've to skip them }
|
||||
elesize : t_size;
|
||||
eletype : pdynarraytypeinfo;
|
||||
end;
|
||||
|
||||
function dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH'];
|
||||
|
||||
function dynarray_length(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_LENGTH'];
|
||||
begin
|
||||
dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high+1;
|
||||
end;
|
||||
|
||||
|
||||
function dynarray_high(p : pointer) : tdynarrayindex;[Public,Alias:'FPC_DYNARRAY_HIGH'];
|
||||
|
||||
begin
|
||||
//!!!!!!! dynarray_length:=pdynarray(p-sizeof(tdynarray))^.high;
|
||||
dynarray_high:=pdynarray(p-sizeof(tdynarray))^.high;
|
||||
end;
|
||||
|
||||
procedure dynarray_decr_ref(var p : pointer);[Public,Alias:'FPC_DYNARRAY_DECR_REF'];
|
||||
|
||||
{ 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 }
|
||||
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 dynarray_setlength(var p : pointer;ti : pdynarraytypeinfo;
|
||||
dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARRAY_SETLENGTH'];
|
||||
|
||||
procedure dynarray_decr_ref(var p : pointer;ti : pdynarraytypeinfo);[Public,Alias:'FPC_DYNARRAY_DECR_REF'];
|
||||
var
|
||||
realp : pdynarray;
|
||||
begin
|
||||
if p=nil then
|
||||
exit;
|
||||
|
||||
realp:=pdynarray(p-sizeof(tdynarray));
|
||||
if realp^.refcount=0 then
|
||||
HandleErrorFrame(204,get_frame);
|
||||
|
||||
{ this isn't MT safe! }
|
||||
{ decr. ref. count }
|
||||
declocked(realp^.refcount);
|
||||
|
||||
{ should we remove the array? }
|
||||
if realp^.refcount=0 then
|
||||
dynarray_clear(realp,ti);
|
||||
p:=nil;
|
||||
end;
|
||||
|
||||
|
||||
procedure dynarray_setlength(var p : pointer;pti : pdynarraytypeinfo;
|
||||
dimcount : dword;dims : pdynarrayindex);[Public,Alias:'FPC_DYNARR_SETLENGTH'];
|
||||
|
||||
var
|
||||
i : tdynarrayindex;
|
||||
@ -63,76 +101,111 @@ procedure dynarray_setlength(var p : pointer;ti : pdynarraytypeinfo;
|
||||
{ contains the "fixed" pointers where the refcount }
|
||||
{ and high are at positive offsets }
|
||||
realp,newp : pdynarray;
|
||||
ti : pdynarraytypeinfo;
|
||||
|
||||
begin
|
||||
(* !!!!!!
|
||||
realp:=pdynarray(p-sizeof(tdynarray));
|
||||
if dims[0]<0 then
|
||||
HandleErrorFrame(201,get_frame);
|
||||
if dims[0]=0 then
|
||||
begin
|
||||
{ release all data }
|
||||
!!!!!
|
||||
p:=nil;
|
||||
exit;
|
||||
end;
|
||||
if dims[0]<>realp^.high+1 then
|
||||
begin
|
||||
{ determine new memory size }
|
||||
size:=ti.elesize*dims[0]+sizeof(tdynarray);
|
||||
ti:=pti;
|
||||
{ skip kind and name }
|
||||
inc(pointer(ti),ord(ti^.namelen));
|
||||
|
||||
{ range checking is quite difficult ... }
|
||||
if (size<sizeof(tdynarray)) or
|
||||
((ti.elesize>0) and (size<ti.elesize)) then
|
||||
{ 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);
|
||||
|
||||
{ skip kind and name }
|
||||
inc(pointer(ti),ord(ti.namelen));
|
||||
|
||||
{ resize? }
|
||||
if realp.refcount=1 then
|
||||
{ if the new dimension is 0, we've to release all data }
|
||||
if dims[0]=0 then
|
||||
begin
|
||||
{ shrink the array? }
|
||||
if dims[0]<realp^.high+1 then
|
||||
dynarray_clear(realp,pti);
|
||||
p:=nil;
|
||||
exit;
|
||||
end;
|
||||
|
||||
if realp^.refcount<>1 then
|
||||
begin
|
||||
{ make an unique copy }
|
||||
getmem(newp,size);
|
||||
move(p^,(newp+sizeof(tdynarray))^,ti^.elesize*dims[0]);
|
||||
|
||||
{ increment ref. count of members }
|
||||
for i:=0 to dims[0]-1 do
|
||||
addref(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 }
|
||||
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
|
||||
for i:=dims[0]-1 to realp^.high do
|
||||
finalize(,ti^.eletype);
|
||||
reallocmem(realp,size);
|
||||
end
|
||||
else
|
||||
begin
|
||||
reallocmem(realp,size);
|
||||
!!!!!! fillchar
|
||||
{ shrink the array? }
|
||||
if dims[0]<realp^.high+1 then
|
||||
begin
|
||||
finalizearray(realp+sizeof(realp)+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((realp+sizeof(realp)+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
|
||||
{ no, copy }
|
||||
!!!!!!!
|
||||
for i:=0 to dims[0]-1 do
|
||||
dynarray_setlength(pointer(plongint(newp+sizeof(tdynarray))[i*ti^.elesize]),
|
||||
ti^.eletype,dimcount-1,@dims[1]);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ handle nested arrays }
|
||||
if dimcount>1 then
|
||||
begin
|
||||
for i:=0 to dims[0]-1 do
|
||||
dynarray_setlength(newp+sizeof(tdynarray)+i*elesize,
|
||||
ti.eletype,dimcount-1,@dims[1]);
|
||||
end;
|
||||
p:=newp+sizeof(tdynarray);
|
||||
!!!!!! *)
|
||||
newp^.refcount:=1;
|
||||
newp^.high:=dims[0]-1;
|
||||
end;
|
||||
|
||||
function dynarray_copy(var p : pointer;ti : pdynarraytypeinfo;
|
||||
dimcount : dword;dims : pdynarrayindex) : pointer;[Public,Alias:'FPC_DYNARRAY_COPY'];
|
||||
|
||||
begin
|
||||
{!!!!!!!!!!}
|
||||
end;
|
||||
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2000-11-07 23:42:21 florian
|
||||
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
|
||||
|
||||
@ -141,4 +214,4 @@ function dynarray_copy(var p : pointer;ti : pdynarraytypeinfo;
|
||||
|
||||
Revision 1.1 2000/11/04 17:52:46 florian
|
||||
* fixed linker errors
|
||||
}
|
||||
}
|
||||
|
||||
@ -14,8 +14,6 @@
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
|
||||
{****************************************************************************
|
||||
Internal Routines called from the Compiler
|
||||
****************************************************************************}
|
||||
@ -128,6 +126,24 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
InstanceSize:=plongint(self)^;
|
||||
end;
|
||||
|
||||
procedure InitInterfacePointers(objclass: tclass;instance : pointer);
|
||||
|
||||
var
|
||||
intftable : pinterfacetable;
|
||||
i : longint;
|
||||
|
||||
begin
|
||||
{$ifdef HASINTF}
|
||||
if assigned(objclass.classparent) then
|
||||
InitInterfacePointers(objclass.classparent,instance);
|
||||
intftable:=objclass.getinterfacetable;
|
||||
if assigned(intftable) then
|
||||
for i:=0 to intftable^.EntryCount-1 do
|
||||
ppointer(@(PChar(instance)[intftable^.Entries[i].IOffset]))^:=
|
||||
pointer(intftable^.Entries[i].VTable);
|
||||
{$endif HASINTF}
|
||||
end;
|
||||
|
||||
class function TObject.InitInstance(instance : pointer) : tobject;
|
||||
|
||||
begin
|
||||
@ -135,6 +151,9 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
{ insert VMT pointer into the new created memory area }
|
||||
{ (in class methods self contains the VMT!) }
|
||||
ppointer(instance)^:=pointer(self);
|
||||
{$ifdef HASINTF}
|
||||
InitInterfacePointers(self,instance);
|
||||
{$endif HASINTF}
|
||||
InitInstance:=TObject(Instance);
|
||||
end;
|
||||
|
||||
@ -217,13 +236,12 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
MethodAddress:=nil;
|
||||
end;
|
||||
|
||||
class function TObject.MethodName(address : pointer) : shortstring;
|
||||
|
||||
class function TObject.MethodName(address : pointer) : shortstring;
|
||||
var
|
||||
methodtable : pmethodnametable;
|
||||
i : dword;
|
||||
c : tclass;
|
||||
|
||||
begin
|
||||
c:=self;
|
||||
while assigned(c) do
|
||||
@ -244,10 +262,7 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
|
||||
function TObject.FieldAddress(const name : shortstring) : pointer;
|
||||
|
||||
type
|
||||
PFieldInfo = ^TFieldInfo;
|
||||
TFieldInfo = packed record
|
||||
@ -595,6 +610,7 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
begin
|
||||
getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
|
||||
end;
|
||||
|
||||
{****************************************************************************
|
||||
TINTERFACEDOBJECT
|
||||
****************************************************************************}
|
||||
@ -661,7 +677,10 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.11 2000-11-09 17:50:12 florian
|
||||
Revision 1.12 2000-11-12 23:23:34 florian
|
||||
* interfaces basically running
|
||||
|
||||
Revision 1.11 2000/11/09 17:50:12 florian
|
||||
* Finalize to int_finalize renamed
|
||||
|
||||
Revision 1.10 2000/11/07 23:42:21 florian
|
||||
@ -691,4 +710,4 @@ Procedure int_finalize (Data,TypeInfo: Pointer);forward;
|
||||
|
||||
Revision 1.1.2.1 2000/07/22 14:46:57 sg
|
||||
* Made TObject.MethodAddress case independent
|
||||
}
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user