it CompilerhelperForInitializingFinalizingVariable;
interface
{ Compiler helper for initializing/finalizing variable }
procedure _Initialize(p : Pointer; typeInfo : Pointer);
procedure _InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
procedure _InitializeRecord(p : Pointer; typeInfo : Pointer);
{$IF not defined(X86ASMRTL)}
// dcc64 generated code expects P to remain in RAX on exit from this function.
function _Finalize(P : Pointer; TypeInfo : Pointer): Pointer;
function _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt): Pointer;
function _FinalizeRecord(P : Pointer; TypeInfo : Pointer): Pointer;
{$ELSE}
procedure _Finalize(p : Pointer; typeInfo : Pointer);
procedure _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
procedure _FinalizeRecord(P : Pointer; TypeInfo : Pointer);
{$ENDIF}
procedure _CopyRecord(Dest, Source, TypeInfo : Pointer);
procedure _CopyObject(Dest, Source : Pointer; vmtPtrOffs : NativeInt; TypeInfo : Pointer);
procedure _CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeUInt);
procedure _AddRef(P : Pointer; TypeInfo : Pointer);
procedure _AddRefArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
procedure _AddRefRecord(P : Pointer; TypeInfo : Pointer);
function _New(Size : NativeInt; TypeInfo : Pointer): Pointer;
procedure _Dispose(P : Pointer; TypeInfo : Pointer);
procedure InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
procedure CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeInt);
procedure FinalizeArray(P : Pointer; TypeInfo : Pointer; Count : NativeUInt);
implementation
{ ===========================================================================
InitializeRecord, InitializeArray, and Initialize are PIC safe even though
they alter EBX because they only call each other. They never call out to
other functions and they don t access global data.
FinalizeRecord, Finalize, and FinalizeArray are PIC safe because they call
Pascal routines which will have EBX fixup prologs.
===========================================================================}
procedure _VarClr(var v : TVarData);
begin
if Assigned(VarClearProc) then
VarClearProc(v)
else
Error(reVarInvalidOp);
end;
procedure _VarCopy(var Dest : TVarData; const Src : TVarData);
begin
if Assigned(VarCopyProc) then
VarCopyProc(Dest, Src)
else
Error(reVarInvalidOp);
end;
procedure _VarAddRef(var v : TVarData);
begin
if Assigned(VarAddRefProc) then
VarAddRefProc(v)
else
Error(reVarInvalidOp);
end;
{ ===========================================================================
InitializeRecord, InitializeArray, and Initialize are PIC safe even though
they alter EBX because they only call each other. They never call out to
other functions and they don t access global data.
FinalizeRecord, Finalize, and FinalizeArray are PIC safe because they call
Pascal routines which will have EBX fixup prologs.
===========================================================================}
procedure _InitializeRecord(p : Pointer; typeInfo : Pointer);
var
FT : PFieldTable;
I : Cardinal;
begin
FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[]));
if FT.Count > then
begin
for I := FT.Count - downto do
{$IFDEF WEAKREF}
if FT.Fields[I].TypeInfo <> nil then
{$ENDIF}
_InitializeArray(Pointer(PByte(P) + UIntPtr(FT.Fields[I].Offset)),
FT.Fields[I].TypeInfo^, );
end;
end;
function _FinalizeRecord(P : Pointer; TypeInfo : Pointer): Pointer;
var
FT : PFieldTable;
I : Cardinal;
{$IFDEF WEAKREF}
Weak : Boolean;
{$ENDIF}
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
if FT.Count > then
begin
{$IFDEF WEAKREF}
Weak := false;
{$ENDIF}
for I := to FT.Count - do
begin
{$IFDEF WEAKREF}
if FT.Fields[I].TypeInfo = nil then
begin
Weak := true;
Continue;
end;
if not Weak then
begin
{$ENDIF}
_FinalizeArray(Pointer(PByte(P) + IntPtr(FT.Fields[I].Offset)),
FT.Fields[I].TypeInfo^, );
{$IFDEF WEAKREF}
end
else
begin
case FT.Fields[I].TypeInfo^.Kind of
{$IFDEF WEAKINTFREF}
tkInterface:
_IntfWeakClear(IInterface(Pointer(PByte(P) +
IntPtr(FT.Fields[I].Offset))^));
{$ENDIF}
{$IFDEF WEAKINSTREF}
tkClass:
_InstWeakClear(TObject(Pointer(PByte(P) + IntPtr(FT.Fields[I].Offset))^));
{$ENDIF}
{$IFDEF WEAKREF}
tkMethod:
_ClosureRemoveWeakRef(TMethod(Pointer(PByte(P) +
IntPtr(FT.Fields[I].Offset))^));
{$ENDIF}
else
Error(reInvalidPtr);
end;
end;
{$ENDIF}
end;
end;
Result := P;
end;
procedure _InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
var
FT : PFieldTable;
I : Cardinal;
begin
if elemCount = then
Exit;
case PTypeInfo(typeInfo).Kind of
{$IFDEF WEAKREF}
tkMethod:
while elemCount > do
begin
TMethod(P^).Data := nil;
TMethod(P^).Code := nil;
Inc(PByte(P), SizeOf(TMethod));
Dec(elemCount);
end;
{$ENDIF}
{$IFDEF AUTOREFCOUNT}
tkClass,
{$ENDIF}
tkLString, tkWString, tkInterface, tkDynArray, tkUString:
while elemCount > do
begin
PPointer(P)^ := nil;
Inc(PByte(P), SizeOf(Pointer));
Dec(elemCount);
end;
tkVariant:
while elemCount > do
begin
with PVarData(P)^ do
for I := Low(RawData) to High(RawData) do
RawData[I] := ;
Inc(PByte(P), SizeOf(TVarData));
Dec(elemCount);
end;
tkArray:
begin
FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[]));
while elemCount > do
begin
_InitializeArray(P, FT.Fields[].TypeInfo^, FT.Count);
Inc(PByte(P), FT.Size);
Dec(elemCount);
end;
end;
tkRecord:
begin
FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[]));
while elemCount > do
begin
_InitializeRecord(P, typeInfo);
Inc(PByte(P), FT.Size);
Dec(elemCount);
end;
end;
else
Error(reInvalidPtr);
end;
end;
function _FinalizeArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt): Pointer;
var
FT : PFieldTable;
begin
Result := P;
if ElemCount = then
Exit;
case PTypeInfo(TypeInfo).Kind of
{$IFDEF WEAKREF}
tkMethod:
while ElemCount > do
begin
_ClosureRemoveWeakRef(TMethod(P^));
Inc(PByte(P), SizeOf(TMethod));
Dec(ElemCount);
end;
{$ENDIF}
{$IFDEF AUTOREFCOUNT}
tkClass:
while ElemCount > do
begin
_InstClear(TObject(P^));
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
{$ENDIF}
tkLString:
_LStrArrayClr(P^, ElemCount);
tkWString:
_WStrArrayClr(P^, ElemCount);
tkUString:
_UStrArrayClr(P^, ElemCount);
tkVariant:
while ElemCount > do
begin
_VarClr(PVarData(P)^);
Inc(PByte(P), SizeOf(TVarData));
Dec(ElemCount);
end;
tkArray:
begin
FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[]));
while ElemCount > do
begin
_FinalizeArray(P, FT.Fields[].TypeInfo^, FT.Count);
Inc(PByte(P), FT.Size);
Dec(ElemCount);
end;
end;
tkRecord:
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
while ElemCount > do
begin
_FinalizeRecord(P, TypeInfo);
Inc(PByte(P), FT.Size);
Dec(ElemCount);
end;
end;
tkInterface:
while ElemCount > do
begin
_IntfClear(IInterface(P^));
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
tkDynArray:
while ElemCount > do
begin
{ The cast and dereference of P here is to fake out the call to
_DynArrayClear. That function expects a var parameter. Our
declaration says we got a non-var parameter, but because of
the data type that got passed to us (tkDynArray), this isn t
strictly true. The compiler will have passed us a reference. }
_DynArrayClear(PPointer(P)^, typeInfo);
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
else
Error(reInvalidPtr);
end;
end;
procedure _AddRefRecord(P : Pointer; TypeInfo : Pointer);
var
FT : PFieldTable;
I : Cardinal;
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
if FT.Count > then
begin
for I := to FT.Count - do
begin
{$IFDEF WEAKREF}
// Check for the sentinal indicating the following fields are weak references
// which don t need to be reference counted
if FT.Fields[I].TypeInfo = nil then
Break;
{$ENDIF}
_AddRefArray(Pointer(PByte(P) + UIntPtr(FT.Fields[I].Offset)),
FT.Fields[I].TypeInfo^, );
end;
end;
end;
procedure _AddRefArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
var
FT : PFieldTable;
begin
if ElemCount = then
Exit;
case PTypeInfo(TypeInfo).Kind of
{$IFDEF WEAKREF}
tkMethod:
while ElemCount > do
begin
_ClosureAddWeakRef(TMethod(P^));
Inc(PByte(P), SizeOf(TMethod));
Dec(ElemCount);
end;
{$ENDIF}
{$IFDEF AUTOREFCOUNT}
tkClass:
while ElemCount > do
begin
_InstAddRef(TObject(P^));
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
{$ENDIF}
tkLString:
while ElemCount > do
begin
_LStrAddRef(PPointer(P)^);
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
tkWString:
while ElemCount > do
begin
{$IFDEF MSWINDOWS}
_WStrAddRef(PWideString(P)^);
{$ELSE}
_WStrAddRef(PPointer(P)^);
{$ENDIF}
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
tkUString:
while ElemCount > do
begin
_UStrAddRef(PPointer(P)^);
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
tkVariant:
while ElemCount > do
begin
_VarAddRef(PVarData(P)^);
Inc(PByte(P), SizeOf(TVarData));
Dec(ElemCount);
end;
tkArray:
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
while ElemCount > do
begin
_AddRefArray(P, FT.Fields[].TypeInfo^, FT.Count);
Inc(PByte(P), FT.Size);
Dec(ElemCount);
end;
end;
tkRecord:
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
while ElemCount > do
begin
_AddRefRecord(P, TypeInfo);
Inc(PByte(P), FT.Size);
Dec(ElemCount);
end;
end;
tkInterface:
while ElemCount > do
begin
_IntfAddRef(IInterface(P^));
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
tkDynArray:
while ElemCount > do
begin
_DynArrayAddRef(PPointer(P)^);
Inc(PByte(P), SizeOf(Pointer));
Dec(ElemCount);
end;
else
Error(reInvalidPtr);
end;
end;
procedure _AddRef(P : Pointer; TypeInfo : Pointer);
begin
_AddRefArray(P, TypeInfo, );
end;
procedure _CopyRecord(Dest, Source, TypeInfo : Pointer);
var
FT, EFT : PFieldTable;
I, Count, L : Cardinal;
{$IFDEF WEAKREF}
J, K : Cardinal;
{$ENDIF}
Offset : UIntPtr;
FTypeInfo : PTypeInfo;
DestOff, SrcOff : Pointer;
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
Offset := ;
if FT.Count > then
begin
Count := FT.Count;
{$IFDEF WEAKREF}
J := ;
K := Count;
for I := Count - downto do
if FT.Fields[I].TypeInfo = nil then
begin
K := I + ; // found the weak sentinal
Dec(Count); // remove the sentinal from consideration
Break;
end;
{$ENDIF}
for L := to Count - do
begin
{$IFDEF WEAKREF}
if (FT.Fields[J].TypeInfo <> nil) and
((K = FT.Count) or (FT.Fields[J].Offset < FT.Fields[K].Offset)) then
begin
I := J;
Inc(J);
end
else
begin
I := K;
Inc(K);
end;
{$ELSE}
I := L;
{$ENDIF}
if FT.Fields[I].Offset > Offset then
Move(Pointer(PByte(Source) + Offset)^,
Pointer(PByte(Dest) + Offset)^,
FT.Fields[I].Offset - Offset);
Offset := FT.Fields[I].Offset;
FTypeInfo := FT.Fields[I].TypeInfo^;
DestOff := Pointer(PByte(Dest) + Offset);
SrcOff := Pointer(PByte(Source) + Offset);
case FTypeInfo.Kind of
{$IFDEF WEAKREF}
tkMethod:
begin
_CopyClosure(PMethod(DestOff)^, PMethod(SrcOff)^);
Inc(Offset, SizeOf(TMethod));
end;
{$ENDIF}
{$IFDEF AUTOREFCOUNT}
tkClass:
begin
{$IFDEF WEAKINSTREF}
if I > J then
_InstWeakCopy(TObject(PPointer(DestOff)^),
TObject(PPointer(SrcOff)^))
else
{$ENDIF}
_InstCopy(TObject(PPointer(DestOff)^), TObject(PPointer(SrcOff)^));
Inc(Offset, SizeOf(Pointer));
end;
{$ENDIF}
tkLString:
begin
_LStrAsg(_PAnsiStr(DestOff)^, _PAnsiStr(SrcOff)^);
Inc(Offset, SizeOf(Pointer));
end;
tkWString:
begin
_WStrAsg(_PWideStr(DestOff)^, _PWideStr(SrcOff)^);
Inc(Offset, SizeOf(Pointer));
end;
tkUString:
begin
_UStrAsg(PUnicodeString(DestOff)^, PUnicodeString(SrcOff)^);
Inc(Offset, SizeOf(Pointer));
end;
tkVariant:
begin
_VarCopy(PVarData(DestOff)^, PVarData(SrcOff)^);
Inc(Offset, SizeOf(TVarData));
end;
tkArray:
begin
EFT :=
PFieldTable(PByte(FTypeInfo) + Byte(PTypeInfo(FTypeInfo).Name[]));
_CopyArray(DestOff, SrcOff, EFT.Fields[].TypeInfo^, EFT.Count);
Inc(Offset, EFT.Size);
end;
tkRecord:
begin
EFT :=
PFieldTable(PByte(FTypeInfo) + Byte(PTypeInfo(FTypeInfo).Name[]));
_CopyRecord(DestOff, SrcOff, FTypeInfo);
Inc(Offset, EFT.Size);
end;
tkInterface:
begin
{$IFDEF WEAKINTFREF}
if I > J then
_IntfWeakCopy(IInterface(PPointer(DestOff)^),
IInterface(PPointer(SrcOff)^))
else
{$ENDIF}
_IntfCopy(IInterface(PPointer(DestOff)^),
IInterface(PPointer(SrcOff)^));
Inc(Offset, SizeOf(Pointer));
end;
tkDynArray:
begin
_DynArrayAsg(PPointer(DestOff)^, PPointer(SrcOff)^, FTypeInfo);
Inc(Offset, SizeOf(Pointer));
end;
else
Error(reInvalidPtr);
end;
end;
end;
if FT.Size > Offset then
Move(Pointer(PByte(Source) + Offset)^,
Pointer(PByte(Dest) + Offset)^,
FT.Size - Offset);
end;
procedure _CopyObject(Dest, Source : Pointer; vmtPtrOffs : NativeInt; TypeInfo : Pointer);
var
SavedVmtPtr : Pointer;
begin
SavedVmtPtr := PPointer(PByte(Dest) + vmtPtrOffs)^;
_CopyRecord(Dest, Source, TypeInfo);
PPointer(PByte(Dest) + vmtPtrOffs)^ := SavedVmtPtr;
end;
procedure _CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeUInt);
var
FT : PFieldTable;
begin
if Count = then
Exit;
case PTypeInfo(TypeInfo).Kind of
{$IFDEF WEAKREF}
tkMethod:
while Count > do
begin
_CopyClosure(PMethod(Dest)^, PMethod(Source)^);
Inc(PByte(Dest), SizeOf(TMethod));
Inc(PByte(Source), SizeOf(TMethod));
Dec(Count);
end;
{$ENDIF}
{$IFDEF AUTOREFCOUNT}
tkClass:
while Count > do
begin
_InstCopy(TObject(PPointer(Dest)^), TObject(PPointer(Source)^));
Inc(PByte(Dest), SizeOf(Pointer));
Inc(PByte(Source), SizeOf(Pointer));
Dec(Count);
end;
{$ENDIF}
tkLString:
while Count > do
begin
_LStrAsg(_PAnsiStr(Dest)^, _PAnsiStr(Source)^);
Inc(PByte(Dest), SizeOf(Pointer));
Inc(PByte(Source), SizeOf(Pointer));
Dec(Count);
end;
tkWString:
while Count > do
begin
_WStrAsg(_PWideStr(Dest)^, _PWideStr(Source)^);
Inc(PByte(Dest), SizeOf(Pointer));
Inc(PByte(Source), SizeOf(Pointer));
Dec(Count);
end;
tkUString:
while Count > do
begin
_UStrAsg(PUnicodeString(Dest)^, PUnicodeString(Source)^);
Inc(PByte(Dest), SizeOf(Pointer));
Inc(PByte(Source), SizeOf(Pointer));
Dec(Count);
end;
tkVariant:
while Count > do
begin
_VarCopy(PVarData(Dest)^, PVarData(Source)^);
Inc(PByte(Dest), SizeOf(TVarData));
Inc(PByte(Source), SizeOf(TVarData));
Dec(Count);
end;
tkArray:
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
while Count > do
begin
_CopyArray(Pointer(Dest), Pointer(Source),
FT.Fields[].TypeInfo^, FT.Count);
Inc(PByte(Dest), FT.Size);
Inc(PByte(Source), FT.Size);
Dec(Count);
end;
end;
tkRecord:
begin
FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[]));
while Count > do
begin
_CopyRecord(Dest, Source, TypeInfo);
Inc(PByte(Dest), FT.Size);
Inc(PByte(Source), FT.Size);
Dec(Count);
end;
end;
tkInterface:
while Count > do
begin
_IntfCopy(IInterface(PPointer(Dest)^), IInterface(PPointer(Source)^));
Inc(PByte(Dest), SizeOf(Pointer));
Inc(PByte(Source), SizeOf(Pointer));
Dec(Count);
end;
tkDynArray:
while Count > do
begin
_DynArrayAsg(PPointer(Dest)^, PPointer(Source)^, TypeInfo);
Inc(PByte(Dest), SizeOf(Pointer));
Inc(PByte(Source), SizeOf(Pointer));
Dec(Count);
end;
else
Error(reInvalidPtr);
end;
end;
procedure CopyArray(Dest, Source, TypeInfo : Pointer; Count : NativeInt);
begin
if Count > then
_CopyArray(Dest, Source, TypeInfo, Count);
end;
procedure InitializeArray(p : Pointer; typeInfo : Pointer; elemCount : NativeUInt);
begin
_InitializeArray(p, typeInfo, elemCount);
end;
procedure FinalizeArray(P, TypeInfo : Pointer; Count : NativeUInt);
begin
_FinalizeArray(P, TypeInfo, Count);
end;
procedure _Initialize(p : Pointer; typeInfo : Pointer);
begin
_InitializeArray(p, typeInfo, );
end;
function _Finalize(p : Pointer; typeInfo : Pointer): Pointer;
begin
Result := _FinalizeArray(p, typeInfo, );
end;
function _New(Size : NativeInt; TypeInfo : Pointer): Pointer;
begin
GetMem(Result, Size);
if Result <> nil then
_Initialize(Result, TypeInfo);
end;
procedure _Dispose(P : Pointer; TypeInfo : Pointer);
begin
_Finalize(P, TypeInfo);
FreeMem(P);
end;