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[0]));
  if FT.Count > 0 then
  begin
    for I := FT.Count - 1 downto 0 do
      {$IFDEF WEAKREF}
      if FT.Fields[I].TypeInfo <> nil then
        {$ENDIF}
        _InitializeArray(Pointer(PByte(P) + UIntPtr(FT.Fields[I].Offset)),
          FT.Fields[I].TypeInfo^, 1);
  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[0]));
  if FT.Count > 0 then
  begin
    {$IFDEF WEAKREF}
    Weak := false;
    {$ENDIF}
    for I := 0 to FT.Count - 1 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^, 1);
        {$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 = 0 then 
    Exit;
  case PTypeInfo(typeInfo).Kind of
    {$IFDEF WEAKREF}
    tkMethod:
      while elemCount > 0 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 > 0 do
      begin
        PPointer(P)^ := nil;
        Inc(PByte(P), SizeOf(Pointer));
        Dec(elemCount);
      end;
    tkVariant:
      while elemCount > 0 do
      begin
        with PVarData(P)^ do
          for I := Low(RawData) to High(RawData) do 
            RawData[I] := 0;
        Inc(PByte(P), SizeOf(TVarData));
        Dec(elemCount);
      end;
    tkArray:
      begin
        FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
        while elemCount > 0 do
        begin
          _InitializeArray(P, FT.Fields[0].TypeInfo^, FT.Count);
          Inc(PByte(P), FT.Size);
          Dec(elemCount);
        end;
      end;
    tkRecord:
      begin
        FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
        while elemCount > 0 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 = 0 then 
    Exit;
  case PTypeInfo(TypeInfo).Kind of
    {$IFDEF WEAKREF}
    tkMethod:
      while ElemCount > 0 do
      begin
        _ClosureRemoveWeakRef(TMethod(P^));
        Inc(PByte(P), SizeOf(TMethod));
        Dec(ElemCount);
      end;
    {$ENDIF}
    {$IFDEF AUTOREFCOUNT}
    tkClass:
      while ElemCount > 0 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 > 0 do
      begin
        _VarClr(PVarData(P)^);
        Inc(PByte(P), SizeOf(TVarData));
        Dec(ElemCount);
      end;
    tkArray:
      begin
        FT := PFieldTable(PByte(typeInfo) + Byte(PTypeInfo(typeInfo).Name[0]));
        while ElemCount > 0 do
        begin
          _FinalizeArray(P, FT.Fields[0].TypeInfo^, FT.Count);
          Inc(PByte(P), FT.Size);
          Dec(ElemCount);
        end;
      end;
    tkRecord:
      begin
        FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
        while ElemCount > 0 do
        begin
          _FinalizeRecord(P, TypeInfo);
          Inc(PByte(P), FT.Size);
          Dec(ElemCount);
        end;
      end;
    tkInterface:
      while ElemCount > 0 do
      begin
        _IntfClear(IInterface(P^));
        Inc(PByte(P), SizeOf(Pointer));
        Dec(ElemCount);
      end;
    tkDynArray:
      while ElemCount > 0 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[0]));
  if FT.Count > 0 then
  begin
    for I := 0 to FT.Count - 1 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^, 1);
    end;
  end;
end;

procedure _AddRefArray(P : Pointer; TypeInfo : Pointer; ElemCount : NativeUInt);
var
  FT : PFieldTable;
begin
  if ElemCount = 0 then 
    Exit;
  case PTypeInfo(TypeInfo).Kind of
    {$IFDEF WEAKREF}
    tkMethod:
      while ElemCount > 0 do
      begin
        _ClosureAddWeakRef(TMethod(P^));
        Inc(PByte(P), SizeOf(TMethod));
        Dec(ElemCount);
      end;
    {$ENDIF}
    {$IFDEF AUTOREFCOUNT}
    tkClass:
      while ElemCount > 0 do
      begin
        _InstAddRef(TObject(P^));
        Inc(PByte(P), SizeOf(Pointer));
        Dec(ElemCount);
      end;
    {$ENDIF}
    tkLString:
      while ElemCount > 0 do
      begin
        _LStrAddRef(PPointer(P)^);
        Inc(PByte(P), SizeOf(Pointer));
        Dec(ElemCount);
      end;
    tkWString:
      while ElemCount > 0 do
      begin
        {$IFDEF MSWINDOWS}
        _WStrAddRef(PWideString(P)^);
        {$ELSE}
        _WStrAddRef(PPointer(P)^);
        {$ENDIF}
        Inc(PByte(P), SizeOf(Pointer));
        Dec(ElemCount);
      end;
    tkUString:
      while ElemCount > 0 do
      begin
        _UStrAddRef(PPointer(P)^);
        Inc(PByte(P), SizeOf(Pointer));
        Dec(ElemCount);
      end;
    tkVariant:
      while ElemCount > 0 do
      begin
        _VarAddRef(PVarData(P)^);
        Inc(PByte(P), SizeOf(TVarData));
        Dec(ElemCount);
      end;
    tkArray:
      begin
        FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
        while ElemCount > 0 do
        begin
          _AddRefArray(P, FT.Fields[0].TypeInfo^, FT.Count);
          Inc(PByte(P), FT.Size);
          Dec(ElemCount);
        end;
      end;
    tkRecord:
      begin
        FT := PFieldTable(PByte(TypeInfo) + Byte(PTypeInfo(TypeInfo).Name[0]));
        while ElemCount > 0 do
        begin
          _AddRefRecord(P, TypeInfo);
          Inc(PByte(P), FT.Size);
          Dec(ElemCount);
        end;
      end;
    tkInterface:
      while ElemCount > 0 do
      begin
        _IntfAddRef(IInterface(P^));
        Inc(PByte(P), SizeOf(Pointer));
        Dec(ElemCount);
      end;
    tkDynArray:
      while ElemCount > 0 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, 1);
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[0]));
  Offset := 0;
  if FT.Count > 0 then
  begin
    Count := FT.Count;
    {$IFDEF WEAKREF}
    J := 0;
    K := Count;
    for I := Count - 1 downto 0 do
      if FT.Fields[I].TypeInfo = nil then
      begin
        K := I + 1; // found the weak sentinal
        Dec(Count); // remove the sentinal from consideration
        Break;
      end;
    {$ENDIF}
    for L := 0 to Count - 1 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[0]));
            _CopyArray(DestOff, SrcOff, EFT.Fields[0].TypeInfo^, EFT.Count);
            Inc(Offset, EFT.Size);
          end;
        tkRecord:
          begin
            EFT :=
              PFieldTable(PByte(FTypeInfo) + Byte(PTypeInfo(FTypeInfo).Name[0]));
            _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 = 0 then 
    Exit;
  case PTypeInfo(TypeInfo).Kind of
    {$IFDEF WEAKREF}
    tkMethod:
      while Count > 0 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 > 0 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 > 0 do
      begin
        _LStrAsg(_PAnsiStr(Dest)^, _PAnsiStr(Source)^);
        Inc(PByte(Dest), SizeOf(Pointer));
        Inc(PByte(Source), SizeOf(Pointer));
        Dec(Count);
      end;
    tkWString:
      while Count > 0 do
      begin
        _WStrAsg(_PWideStr(Dest)^, _PWideStr(Source)^);
        Inc(PByte(Dest), SizeOf(Pointer));
        Inc(PByte(Source), SizeOf(Pointer));
        Dec(Count);
      end;
    tkUString:
      while Count > 0 do
      begin
        _UStrAsg(PUnicodeString(Dest)^, PUnicodeString(Source)^);
        Inc(PByte(Dest), SizeOf(Pointer));
        Inc(PByte(Source), SizeOf(Pointer));
        Dec(Count);
      end;
    tkVariant:
      while Count > 0 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[0]));
        while Count > 0 do
        begin
          _CopyArray(Pointer(Dest), Pointer(Source),
            FT.Fields[0].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[0]));
        while Count > 0 do
        begin
          _CopyRecord(Dest, Source, TypeInfo);
          Inc(PByte(Dest), FT.Size);
          Inc(PByte(Source), FT.Size);
          Dec(Count);
        end;
      end;
    tkInterface:
      while Count > 0 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 > 0 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 > 0 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, 1);
end;

function _Finalize(p : Pointer; typeInfo : Pointer): Pointer;
begin
  Result := _FinalizeArray(p, typeInfo, 1);
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;