Delphi -- Compiler helper for initializing/finalizing variable

 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;