fpc/rtl/inc/variants.pp

{
    This include file contains the variants
    support for FPC

    This file is part of the Free Pascal run time library.
    Copyright (c) 2001-2005 by the Free Pascal development team

    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.

 **********************************************************************}

{$IFDEF fpc}
{$mode objfpc}
{$ENDIF}
{$h+}

{ Using inlining for small system functions/wrappers }
{$inline on}
{$define VARIANTINLINE}

unit variants;

interface

  uses
    sysutils,sysconst,rtlconsts,typinfo;

type
  EVariantParamNotFoundError = class(EVariantError);
  EVariantInvalidOpError = class(EVariantError);
  EVariantTypeCastError = class(EVariantError);
  EVariantOverflowError = class(EVariantError);
  EVariantInvalidArgError = class(EVariantError);
  EVariantBadVarTypeError = class(EVariantError);
  EVariantBadIndexError = class(EVariantError);
  EVariantArrayLockedError = class(EVariantError);
  EVariantNotAnArrayError = class(EVariantError);
  EVariantArrayCreateError = class(EVariantError);
  EVariantNotImplError = class(EVariantError);
  EVariantOutOfMemoryError = class(EVariantError);
  EVariantUnexpectedError = class(EVariantError);
  EVariantDispatchError = class(EVariantError);
  EVariantRangeCheckError = class(EVariantOverflowError);
  EVariantInvalidNullOpError = class(EVariantInvalidOpError);

  TVariantRelationship = (vrEqual, vrLessThan, vrGreaterThan, vrNotEqual);
  TNullCompareRule = (ncrError, ncrStrict, ncrLoose);
  TBooleanToStringRule = (bsrAsIs, bsrLower, bsrUpper);

Const
  OrdinalVarTypes = [varSmallInt, varInteger, varBoolean, varShortInt,
                     varByte, varWord,varLongWord,varInt64];
  FloatVarTypes = [
{$ifndef FPUNONE}
    varSingle, varDouble,
{$endif}
    varCurrency];

{ Variant support procedures and functions }

function VarType(const V: Variant): TVarType; inline;
function VarTypeDeRef(const V: Variant): TVarType; overload;
function VarTypeDeRef(const V: TVarData): TVarType; overload; inline;
function VarAsType(const V: Variant; aVarType: TVarType): Variant;
function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload; inline;
function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;
function VarIsByRef(const V: Variant): Boolean; inline;

function VarIsEmpty(const V: Variant): Boolean; inline;
procedure VarCheckEmpty(const V: Variant); inline;
function VarIsNull(const V: Variant): Boolean; inline;
function VarIsClear(const V: Variant): Boolean; inline;

function VarIsCustom(const V: Variant): Boolean; inline;
function VarIsOrdinal(const V: Variant): Boolean; inline;
function VarIsFloat(const V: Variant): Boolean; inline;
function VarIsNumeric(const V: Variant): Boolean; inline;
function VarIsStr(const V: Variant): Boolean;

function VarToStr(const V: Variant): string;
function VarToStrDef(const V: Variant; const ADefault: string): string;
function VarToWideStr(const V: Variant): WideString;
function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
function VarToUnicodeStr(const V: Variant): UnicodeString;
function VarToUnicodeStrDef(const V: Variant; const ADefault: UnicodeString): UnicodeString;

{$ifndef FPUNONE}
function VarToDateTime(const V: Variant): TDateTime;
function VarFromDateTime(const DateTime: TDateTime): Variant;
{$endif}

function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;

function VarSameValue(const A, B: Variant): Boolean;
function VarCompareValue(const A, B: Variant): TVariantRelationship;

function VarIsEmptyParam(const V: Variant): Boolean; inline;

procedure VarClear(var V: Variant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
procedure VarClear(var V: OleVariant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}

procedure SetClearVarToEmptyParam(var V: TVarData);

function VarIsError(const V: Variant; out AResult: HRESULT): Boolean;
function VarIsError(const V: Variant): Boolean; inline;
function VarAsError(AResult: HRESULT): Variant;

function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
function VarSupports(const V: Variant; const IID: TGUID): Boolean;

{ Variant copy support }
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);

{ Variant array support procedures and functions }

function VarArrayCreate(const Bounds: array of SizeInt; aVarType: TVarType): Variant;
function VarArrayCreate(const Bounds: PVarArrayBoundArray; Dims : SizeInt; aVarType: TVarType): Variant;
function VarArrayOf(const Values: array of Variant): Variant;

function VarArrayAsPSafeArray(const A: Variant): PVarArray;

function VarArrayDimCount(const A: Variant) : LongInt;
function VarArrayLowBound(const A: Variant; Dim : LongInt) : LongInt;
function VarArrayHighBound(const A: Variant; Dim : LongInt) : LongInt;

function VarArrayLock(const A: Variant): Pointer;
procedure VarArrayUnlock(const A: Variant);

function VarArrayRef(const A: Variant): Variant;

function VarIsArray(const A: Variant): Boolean; inline;
function VarIsArray(const A: Variant; AResolveByRef: Boolean): Boolean;

function VarTypeIsValidArrayType(const aVarType: TVarType): Boolean;
function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;

{ Variant <--> Dynamic Arrays }

procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);

{ Global constants }

function Unassigned: Variant; // Unassigned standard constant
function Null: Variant;       // Null standard constant

var
  EmptyParam: OleVariant;

{ Custom Variant base class }

type
  TVarCompareResult = (crLessThan, crEqual, crGreaterThan);
  TCustomVariantType = class(TObject, IInterface)
  private
    FVarType: TVarType;
  protected
    function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    procedure SimplisticClear(var V: TVarData);
    procedure SimplisticCopy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean = False);
    procedure RaiseInvalidOp;
    procedure RaiseCastError;
    procedure RaiseDispError;
    function LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; virtual;
    function RightPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; virtual;
    function OlePromotion(const V: TVarData; out RequiredVarType: TVarType): Boolean; virtual;
    procedure DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer); virtual;
    procedure VarDataInit(var Dest: TVarData);
    procedure VarDataClear(var Dest: TVarData);
    procedure VarDataCopy(var Dest: TVarData; const Source: TVarData);
    procedure VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData);
    procedure VarDataCast(var Dest: TVarData; const Source: TVarData);
    procedure VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); overload;
    procedure VarDataCastTo(var Dest: TVarData; const aVarType: TVarType); overload;
    procedure VarDataCastToOleStr(var Dest: TVarData);
    procedure VarDataFromStr(var V: TVarData; const Value: string);
    procedure VarDataFromOleStr(var V: TVarData; const Value: WideString);
    function VarDataToStr(const V: TVarData): string;
    function VarDataIsEmptyParam(const V: TVarData): Boolean;
    function VarDataIsByRef(const V: TVarData): Boolean;
    function VarDataIsArray(const V: TVarData): Boolean;
    function VarDataIsOrdinal(const V: TVarData): Boolean;
    function VarDataIsFloat(const V: TVarData): Boolean;
    function VarDataIsNumeric(const V: TVarData): Boolean;
    function VarDataIsStr(const V: TVarData): Boolean;
  public
    constructor Create; overload;
    constructor Create(RequestedVarType: TVarType); overload;
    destructor Destroy; override;
    function IsClear(const V: TVarData): Boolean; virtual;
    procedure Cast(var Dest: TVarData; const Source: TVarData); virtual;
    procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); virtual;
    procedure CastToOle(var Dest: TVarData; const Source: TVarData); virtual;
    procedure Clear(var V: TVarData); virtual; abstract;
    procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); virtual; abstract;
    procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); virtual;
    procedure UnaryOp(var Right: TVarData; const Operation: TVarOp); virtual;
    function CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean; virtual;
    procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); virtual;
    property VarType: TVarType read FVarType;
  end;
  TCustomVariantTypeClass = class of TCustomVariantType;

  TVarDataArray = array of TVarData;
  IVarInvokeable = interface
    ['{1CB65C52-BBCB-41A6-9E58-7FB916BEEB2D}']
    function DoFunction(var Dest: TVarData; const V: TVarData;
      const Name: string; const Arguments: TVarDataArray): Boolean;
    function DoProcedure(const V: TVarData; const Name: string;
      const Arguments: TVarDataArray): Boolean;
    function GetProperty(var Dest: TVarData; const V: TVarData;
      const Name: string): Boolean;
    function SetProperty(const V: TVarData; const Name: string;
      const Value: TVarData): Boolean;
  end;

  TInvokeableVariantType = class(TCustomVariantType, IVarInvokeable)
  protected
    procedure DispInvoke(Dest: PVarData; const Source: TVarData;
      CallDesc: PCallDesc; Params: Pointer); override;
  public
    { IVarInvokeable }
    function DoFunction(var Dest: TVarData; const V: TVarData;
      const Name: string; const Arguments: TVarDataArray): Boolean; virtual;
    function DoProcedure(const V: TVarData; const Name: string;
      const Arguments: TVarDataArray): Boolean; virtual;
    function GetProperty(var Dest: TVarData; const V: TVarData;
      const Name: string): Boolean; virtual;
    function SetProperty(const V: TVarData; const Name: string;
      const Value: TVarData): Boolean; virtual;
  end;

  IVarInstanceReference = interface
    ['{5C176802-3F89-428D-850E-9F54F50C2293}']
    function GetInstance(const V: TVarData): TObject;
  end;

  TPublishableVariantType = class(TInvokeableVariantType, IVarInstanceReference)
  protected
    { IVarInstanceReference }
    function GetInstance(const V: TVarData): TObject; virtual; abstract;
  public
    function GetProperty(var Dest: TVarData; const V: TVarData;
      const Name: string): Boolean; override;
    function SetProperty(const V: TVarData; const Name: string;
      const Value: TVarData): Boolean; override;
  end;

  function FindCustomVariantType(const aVarType: TVarType;
    out CustomVariantType: TCustomVariantType): Boolean; overload;
  function FindCustomVariantType(const TypeName: string;
    out CustomVariantType: TCustomVariantType): Boolean; overload;

type
  TAnyProc = procedure (var V: TVarData);
  TVarDispProc = procedure (Dest: PVariant; const Source: Variant;
      CallDesc: PCallDesc; Params: Pointer); cdecl;

Const
  CMaxNumberOfCustomVarTypes = $0EFF;
  CMinVarType = $0100;
  CMaxVarType = CMinVarType + CMaxNumberOfCustomVarTypes;
  CIncVarType = $000F;
  CFirstUserType = CMinVarType + CIncVarType;

var
  NullEqualityRule: TNullCompareRule = ncrLoose;
  NullMagnitudeRule: TNullCompareRule = ncrLoose;
  NullStrictConvert: Boolean = true;
  NullAsStringValue: string = '';
  PackVarCreation: Boolean = True;
{$ifndef FPUNONE}
  OleVariantInt64AsDouble: Boolean = False;
{$endif}


  VarDispProc: TVarDispProc;
  ClearAnyProc: TAnyProc;  { Handler clearing a varAny }
  ChangeAnyProc: TAnyProc; { Handler to change any to Variant }
  RefAnyProc: TAnyProc;    { Handler to add a reference to an varAny }
  InvalidCustomVariantType : TCustomVariantType;

procedure VarCastError;
procedure VarCastError(const ASourceType, ADestType: TVarType);
procedure VarCastErrorOle(const ASourceType: TVarType);
procedure VarInvalidOp;
procedure VarInvalidOp(const aLeft, aRight: TVarType; aOpCode: TVarOp);
procedure VarInvalidOp(const aRight: TVarType; aOpCode: TVarOp);
procedure VarInvalidNullOp;
procedure VarBadTypeError;
procedure VarOverflowError;
procedure VarOverflowError(const ASourceType, ADestType: TVarType);
procedure VarBadIndexError;
procedure VarArrayLockedError;
procedure VarNotImplError;
procedure VarOutOfMemoryError;
procedure VarInvalidArgError;
procedure VarInvalidArgError(AType: TVarType);
procedure VarUnexpectedError;
procedure VarRangeCheckError(const AType: TVarType);
procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
procedure VarArrayCreateError;
procedure VarResultCheck(AResult: HRESULT);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
procedure VarResultCheck(AResult: HRESULT; ASourceType, ADestType: TVarType);
procedure HandleConversionException(const ASourceType, ADestType: TVarType);
function VarTypeAsText(const AType: TVarType): string;
function FindVarData(const V: Variant): PVarData;

const
  VarOpAsText : array[TVarOp] of string = (
    '+',   {opAdd}
    '-',   {opSubtract}
    '*',   {opMultiply}
    '/',   {opDivide}
    'div', {opIntDivide}
    'mod', {opModulus}
    'shl', {opShiftLeft}
    'shr', {opShiftRight}
    'and', {opAnd}
    'or',  {opOr}
    'xor', {opXor}
    '',    {opCompare}
    '-',   {opNegate}
    'not', {opNot}
    '=',   {opCmpEq}
    '<>',  {opCmpNe}
    '<',   {opCmpLt}
    '<=',  {opCmpLe}
    '>',   {opCmpGt}
    '>=',  {opCmpGe}
    '**'   {opPower}
  );

{ Typinfo unit Variant routines have been moved here, so as not to make TypInfo dependent on variants }

Function GetPropValue(Instance: TObject; const PropName: string): Variant;
Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);
Function  GetVariantProp(Instance: TObject; PropInfo : PPropInfo): Variant;
Function  GetVariantProp(Instance: TObject; const PropName: string): Variant;
Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);


{$IFDEF DEBUG_VARIANTS}
var
  __DEBUG_VARIANTS: Boolean = False;
{$ENDIF}

implementation

uses
  Math,
  VarUtils;

{$IFOPT R-} {$DEFINE RANGECHECKINGOFF} {$ENDIF}
{$IFOPT Q-} {$DEFINE OVERFLOWCHECKINGOFF} {$ENDIF}

var
  customvarianttypes    : array of TCustomVariantType;
  customvarianttypelock : trtlcriticalsection;
  customvariantcurrtype : LongInt;

const
  { all variants for which vType and varComplexType = 0 do not require
    finalization. }
  varComplexType = $BFE8;

procedure DoVarClearComplex(var v : TVarData); forward;
procedure DoVarCopy(var Dest : TVarData; const Source : TVarData); forward;
procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt); forward;

procedure DoVarClear(var v : TVarData); inline;
begin
  if v.vType and varComplexType <> 0 then
    DoVarClearComplex(v)
  else
    v.vType := varEmpty;
end;

procedure DoVarClearIfComplex(var v : TVarData); inline;
begin
  if v.vType and varComplexType <> 0 then
    DoVarClearComplex(v);
end;

function AlignToPtr(p : Pointer) : Pointer;inline;
begin
  {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT}
  Result:=align(p,SizeOf(p));
  {$ELSE FPC_REQUIRES_PROPER_ALIGNMENT}
  Result:=p;
  {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
end;


{ ---------------------------------------------------------------------
    String Messages
  ---------------------------------------------------------------------}

ResourceString
  SErrVarIsEmpty = 'Variant is empty';
  SErrInvalidIntegerRange = 'Invalid Integer range: %d';

{ ---------------------------------------------------------------------
    Auxiliary routines
  ---------------------------------------------------------------------}

Procedure VariantError (Const Msg : String); inline;
begin
  Raise EVariantError.Create(Msg);
end;

Procedure NotSupported(Meth: String);
begin
  Raise EVariantError.CreateFmt('Method %s not yet supported.',[Meth]);
end;

type
  TVariantArrayIterator = object
    Bounds : PVarArrayBoundArray;
    Coords : PVarArrayCoorArray;
    Dims   : SizeInt;
    constructor Init(aDims: SizeInt; aBounds : PVarArrayBoundArray);
    destructor Done;

    function Next : Boolean;
    { returns true if the iterator reached the end of the variant array }
    function AtEnd: Boolean;
  end;


{$r-}

constructor TVariantArrayIterator.Init(aDims: SizeInt; aBounds : PVarArrayBoundArray);
var
  i : sizeint;
begin
  Dims := aDims;
  Bounds := aBounds;

  GetMem(Coords, SizeOf(SizeInt) * Dims);
  { initialize coordinate counter }
  for i:= 0 to Pred(Dims) do
    Coords^[i] := Bounds^[i].LowBound;
end;


function TVariantArrayIterator.Next: Boolean;
var
  Finished : Boolean;

  procedure IncDim(Dim : SizeInt);
  begin
    if Finished then
      Exit;

    Inc(Coords^[Dim]);
    if Coords^[Dim] >= Bounds^[Dim].LowBound + Bounds^[Dim].ElementCount then begin
      Coords^[Dim]:=Bounds^[Dim].LowBound;
      if Dim > 0 then
        IncDim(Pred(Dim))
      else
        Finished := True;
    end;
  end;


begin
  Finished := False;
  IncDim(Pred(Dims));
  Result := not Finished;
end;


function TVariantArrayIterator.AtEnd: Boolean;
var
  i : sizeint;
begin
  result:=true;
  for i:=0 to Pred(Dims) do
    if Coords^[i] < Bounds^[i].LowBound + Bounds^[i].ElementCount then
      begin
        result:=false;
        exit;
      end;
end;

{$ifndef RANGECHECKINGOFF}
{$r+}
{$endif}

destructor TVariantArrayIterator.done;
  begin
    FreeMem(Coords);
  end;


type
  tdynarraybounds = array of SizeInt;
  tdynarraycoords = tdynarraybounds;
  tdynarrayelesize = tdynarraybounds;
  tdynarraypositions = array of Pointer;
  tdynarrayiter = object
    Bounds : tdynarraybounds;
    Coords : tdynarraycoords;
    elesize : tdynarrayelesize;
    positions : tdynarraypositions;
    Dims : SizeInt;
    data : Pointer;
    constructor init(d : Pointer;p : pdynarraytypeinfo;_dims: SizeInt;b : tdynarraybounds);
    function next : Boolean;
    destructor done;
  end;


constructor tdynarrayiter.init(d : Pointer;p : pdynarraytypeinfo;_dims: SizeInt;b : tdynarraybounds);
  var
    i : sizeint;
  begin
    Bounds:=b;
    Dims:=_dims;
    SetLength(Coords,Dims);
    SetLength(elesize,Dims);
    SetLength(positions,Dims);
    positions[0]:=d;
    { initialize coordinate counter and elesize }
    for i:=0 to Dims-1 do
      begin
        Coords[i]:=0;
        if i>0 then
          positions[i]:=Pointer(positions[i-1]^);
        { skip kind and name }
        inc(Pointer(p),ord(pdynarraytypeinfo(p)^.namelen)+2);

        p:=AlignToPtr(p);

        elesize[i]:=psizeint(p)^;

        { skip elesize }
        inc(Pointer(p),SizeOf(sizeint));

        p:=pdynarraytypeinfo(ppointer(p)^);
      end;
    data:=positions[Dims-1];
  end;


function tdynarrayiter.next : Boolean;
  var
    Finished : Boolean;

  procedure incdim(d : SizeInt);
    begin
      if Finished then
        exit;
      inc(Coords[d]);
      inc(Pointer(positions[d]),elesize[d]);

      if Coords[d]>=Bounds[d] then
        begin
          Coords[d]:=0;
          if d>0 then
            begin
              incdim(d-1);
              positions[d]:=Pointer(positions[d-1]^);
            end
          else
            Finished:=true;
        end;
    end;

  begin
    Finished:=False;
    incdim(Dims-1);
    data:=positions[Dims-1];
    Result:=not(Finished);
  end;


destructor tdynarrayiter.done;
  begin
    Bounds:=nil;
    Coords:=nil;
    elesize:=nil;
    positions:=nil;
  end;

{ ---------------------------------------------------------------------
    VariantManager support
  ---------------------------------------------------------------------}

procedure sysvarinit(var v : Variant);
begin
  TVarData(V).vType := varEmpty;
end;


procedure sysvarclear(var v : Variant);
begin
  if TVarData(v).vType and varComplexType <> 0 then
    VarClearProc(TVarData(V))
  else
    TVarData(v).vType := varEmpty;
end;


function Sysvartoint (const v : Variant) : Integer;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varInt64)
    else
      Result := 0
  else
    Result := VariantToLongInt(TVarData(V));
end;

function Sysvartoint64 (const v : Variant) : Int64;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varInt64)
    else
      Result := 0
  else
    Result := VariantToInt64(TVarData(V));
end;


function sysvartoword64 (const v : Variant) : QWord;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varQWord)
    else
      Result := 0
  else
    Result := VariantToQWord (TVarData(V));
end;


function sysvartobool (const v : Variant) : Boolean;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varBoolean)
    else
      Result := False
  else
    Result := VariantToBoolean(TVarData(V));
end;


{$ifndef FPUNONE}
function sysvartoreal (const v : Variant) : Extended;
var Handler: TCustomVariantType;
    dest: TVarData;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varDouble)
    else
      Result := 0
  { TODO: performance: custom variants must be handled after standard ones }
  else if FindCustomVariantType(TVarData(v).vType, Handler) then
  begin
    VariantInit(dest);
    Handler.CastTo(dest, TVarData(v), varDouble);
    Result := dest.vDouble;
  end
  else
    Result := VariantToDouble(TVarData(V));
end;
{$endif}


function sysvartocurr (const v : Variant) : Currency;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varCurrency)
    else
      Result := 0
  else
    Result := VariantToCurrency(TVarData(V));
end;

function CustomVarToLStr(const v: TVarData; out s: AnsiString): Boolean;
var
  handler: TCustomVariantType;
  temp: TVarData;
begin
  result := FindCustomVariantType(v.vType, handler);
  if result then
  begin
    VariantInit(temp);
    handler.CastTo(temp, v, varString);
    { out-semantic ensures that s is finalized,
      so just copy the pointer and don't finalize the temp }
    Pointer(s) := temp.vString;
  end;
end;

procedure sysvartolstr (var s : AnsiString; const v : Variant);
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varString)
    else
      s := NullAsStringValue
  { TODO: performance: custom variants must be handled after standard ones }
  else if not CustomVarToLStr(TVarData(v), s) then
    S := VariantToAnsiString(TVarData(V));
end;


procedure sysvartopstr (var s; const v : Variant);
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varString)
    else
      ShortString(s) := NullAsStringValue
  else
    ShortString(s) := VariantToShortString(TVarData(V));
end;


procedure sysvartowstr (var s : WideString; const v : Variant);
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varOleStr)
    else
      s := NullAsStringValue
  else
    S := VariantToWideString(TVarData(V));
end;


procedure sysvartointf (var Intf : IInterface; const v : Variant);
begin
  case TVarData(v).vType of
    varEmpty:
      Intf := nil;
    varNull:
      if NullStrictConvert then
        VarCastError(varNull, varUnknown)
      else
        Intf := nil;
    varUnknown:
      Intf := IInterface(TVarData(v).vUnknown);
    varUnknown or varByRef:
      Intf := IInterface(TVarData(v).vPointer^);
    varDispatch:
      Intf := IInterface(TVarData(v).vDispatch);
    varDispatch or varByRef:
      Intf := IInterface(TVarData(v).vPointer^);
    varVariant, varVariant or varByRef: begin
      if not Assigned(TVarData(v).vPointer) then
        VarBadTypeError;
      sysvartointf(Intf, Variant(PVarData(TVarData(v).vPointer)^) );
    end;
  else
    VarCastError(TVarData(v).vType, varUnknown);
  end;
end;


procedure sysvartodisp (var Disp : IDispatch; const v : Variant);
begin
  case TVarData(v).vType of
    varEmpty:
      Disp := nil;
    varNull:
      if NullStrictConvert then
        VarCastError(varNull, varDispatch)
      else
        Disp := nil;
    varUnknown:
      if IInterface(TVarData(v).vUnknown).QueryInterface(IDispatch, Disp) <> S_OK then
        VarCastError(varUnknown, varDispatch);
    varUnknown or varByRef:
      if IInterface(TVarData(v).vPointer^).QueryInterface(IDispatch, Disp) <> S_OK then
        VarCastError(varUnknown or varByRef, varDispatch);
    varDispatch:
      Disp := IDispatch(TVarData(v).vDispatch);
    varDispatch or varByRef:
      Disp := IDispatch(TVarData(v).vPointer^);
    varVariant, varVariant or varByRef: begin
      if not Assigned(TVarData(v).vPointer) then
        VarBadTypeError;
      sysvartodisp(Disp, Variant(PVarData(TVarData(v).vPointer)^) );
    end;
  else
    VarCastError(TVarData(v).vType, varDispatch);
  end;
end;

{$ifndef FPUNONE}
function sysvartotdatetime (const v : Variant) : TDateTime;
begin
  if VarType(v) = varNull then
    if NullStrictConvert then
      VarCastError(varNull, varDate)
    else
      Result := 0
  else
    Result:=VariantToDate(TVarData(v));
end;
{$endif}

function DynamicArrayIsRectangular(p : Pointer;TypeInfo : Pointer) : Boolean;
var
  arraysize,i : sizeint;
begin
  Result := False;

  { get TypeInfo of second level }
  { skip kind and name }
  inc(Pointer(TypeInfo),ord(pdynarraytypeinfo(TypeInfo)^.namelen)+2);
  TypeInfo:=AlignToPtr(TypeInfo);
  TypeInfo:=ppointer(TypeInfo+SizeOf(sizeint))^;

  { check recursively? }
  if assigned(pdynarraytypeinfo(TypeInfo)) and (pdynarraytypeinfo(TypeInfo)^.kind=byte(tkDynArray)) then
    begin
      { set to dimension of first element }
      arraysize:=psizeint(ppointer(p)^-SizeOf(sizeint))^;
      { walk through all elements }
      for i:=1 to psizeint(p-SizeOf(sizeint))^ do
        begin
          { ... and check dimension }
          if psizeint(ppointer(p)^-SizeOf(sizeint))^<>arraysize then
            exit;
          if not(DynamicArrayIsRectangular(ppointer(p)^,TypeInfo)) then
            exit;
          inc(p,SizeOf(Pointer));
        end;
    end;
    Result:=true;
end;

procedure sysvartodynarray (var dynarr : Pointer; const v : Variant; TypeInfo : Pointer);
begin
  DynArrayFromVariant(dynarr, v, TypeInfo);
end;

procedure sysvarfrombool (var Dest : Variant; const Source : Boolean);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varBoolean;
    vBoolean := Source;
  end;
end;

procedure VariantErrorInvalidIntegerRange(Range: LongInt);
begin
  VariantError(Format(SErrInvalidIntegerRange,[Range]));
end;

procedure sysvarfromint (var Dest : Variant; const Source, Range : LongInt);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do
    if PackVarCreation then
      case Range of
        -4 : begin
          vType := varInteger;
          vInteger := Source;
        end;
        -2 : begin
          vType := varSmallInt;
          vSmallInt := Source;
        end;
        -1 : Begin
          vType := varShortInt;
          vshortint := Source;
        end;
        1 : begin
          vType := varByte;
          vByte := Source;
        end;
        2 : begin
          vType := varWord;
          vWord := Source;
        end;
        4 : Begin
          vType := varLongWord;
          {use vInteger, not vLongWord as the value came passed in as an Integer }
          vInteger := Source;
        end;
      else
        VariantErrorInvalidIntegerRange(Range);
      end
    else begin
      vType := varInteger;
      vInteger := Source;
    end;
end;

procedure sysvarfromint64 (var Dest : Variant; const Source : Int64);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varInt64;
    vInt64 := Source;
  end;
end;

procedure sysvarfromword64 (var Dest : Variant; const Source : QWord);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varQWord;
    vQWord := Source;
  end;
end;

{$ifndef FPUNONE}
procedure sysvarfromreal (var Dest : Variant; const Source : Extended);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varDouble;
    vDouble := Source;
  end;
end;

procedure sysvarfromsingle (var Dest : Variant; const Source : single);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varSingle;
    vSingle := Source;
  end;
end;

procedure sysvarfromdouble (var Dest : Variant; const Source : double);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varDouble;
    vDouble := Source;
  end;
end;
{$endif}

procedure sysvarfromcurr (var Dest : Variant; const Source : Currency);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varCurrency;
    vCurrency := Source;
  end;
end;


{$ifndef FPUNONE}
procedure sysvarfromtdatetime (var Dest : Variant; const Source : TDateTime);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varDate;
    vDate := Source;
  end;
end;
{$endif}


procedure sysvarfrompstr (var Dest : Variant; const Source : ShortString);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varString;
    vString := nil;
    AnsiString(vString) := Source;
  end;
end;

procedure sysvarfromlstr (var Dest : Variant; const Source : AnsiString);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varString;
    vString := nil;
    AnsiString(vString) := Source;
  end;
end;


procedure sysvarfromwstr (var Dest : Variant; const Source : WideString);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vType := varOleStr;
    vOleStr := nil;
    WideString(Pointer(vOleStr)) := Source;
  end;
end;

procedure sysvarfromintf(var Dest : Variant; const Source : IInterface);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vUnknown := nil;
    IInterface(vUnknown) := Source;
    vType := varUnknown;
  end;
end;


procedure sysvarfromdisp(var Dest : Variant; const Source : IDispatch);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vUnknown := nil;
    IDispatch(vDispatch) := Source;
    vType := varDispatch;
  end;
end;

type
  TCommonType = (ctEmpty,ctAny,ctError,ctLongInt,ctBoolean,
{$ifndef FPUNONE}
    ctFloat,ctDate,ctCurrency,
{$endif}
    ctInt64,ctNull,ctWideStr,ctString);

  TCommonVarType = varEmpty..varQWord;

const
{$ifdef FPUNONE}
  ctFloat = ctError;
  ctDate = ctError;
  ctCurrency = ctError;
{$endif}

  { get the basic type for a Variant type }
  VarTypeToCommonType : array[TCommonVarType] of TCommonType =
    (ctEmpty,           // varEmpty = 0;
     ctNull,            // varNull = 1;
     ctLongInt,         // varSmallInt = 2;
     ctLongInt,         // varInteger = 3;
     ctFloat,           // varSingle = 4;
     ctFloat,           // varDouble = 5;
     ctCurrency,        // varCurrency = 6;
     ctDate,            // varDate = 7;
     ctWideStr,         // varOleStr = 8;
     ctError,           // varDispatch = 9;
     ctError,           // varError = 10;
     ctBoolean,         // varBoolean = 11;
     ctError,           // varVariant = 12;
     ctError,           // varUnknown = 13;
     ctError,           // ??? 15
     ctError,           // varDecimal = 14;
     ctLongInt,         // varShortInt = 16;
     ctLongInt,         // varByte = 17;
     ctLongInt,         // varWord = 18;
     ctInt64,           // varLongWord = 19;
     ctInt64,           // varInt64 = 20;
     ctInt64            // varQWord = 21;
    );

  { map a basic type back to a Variant type }
{ Not used yet
  CommonTypeToVarType : array[TCommonType] of TVarType =
    (
      varEmpty,
      varany,
      varError,
      varInteger,
      varDouble,
      varBoolean,
      varInt64,
      varNull,
      varOleStr,
      varDate,
      varCurrency,
      varString
    );
}
function MapToCommonType(const vType : TVarType) : TCommonType;
begin
  case vType of
    Low(TCommonVarType)..High(TCommonVarType):
      Result := VarTypeToCommonType[vType];
    varString:
      Result:=ctString;
    varAny:
      Result:=ctAny;
  else
    Result:=ctError;
  end;
end;

const
  FindCmpCommonType : array[TCommonType, TCommonType] of TCommonType = (
     {              ctEmpty    ctAny    ctError  ctLongInt   ctBoolean                         ctFloat    ctDate   ctCurrency           ctInt64     ctNull   ctWideStr   ctString  }
    ({ ctEmpty }    ctEmpty,   ctEmpty, ctError, ctEmpty,    ctEmpty,    {$ifndef FPUNONE}ctEmpty,   ctEmpty, ctEmpty,    {$endif}ctEmpty,    ctEmpty, ctEmpty,    ctEmpty   ),
    ({ ctAny }      ctEmpty,   ctAny,   ctError, ctAny,      ctAny,      {$ifndef FPUNONE}ctAny,     ctAny,   ctAny,      {$endif}ctAny,      ctAny,   ctAny,      ctAny      ),
    ({ ctError }    ctError,   ctError, ctError, ctError,    ctError,    {$ifndef FPUNONE}ctError,   ctError, ctError,    {$endif}ctError,    ctError, ctError,    ctError    ),
    ({ ctLongInt }  ctEmpty,   ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,  ctFloat,    ctFloat    ),
    ({ ctBoolean }  ctEmpty,   ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,  ctWideStr,  ctString   ),
{$ifndef FPUNONE}
    ({ ctFloat }    ctEmpty,   ctAny,   ctError, ctFloat,    ctFloat,    ctFloat,   ctDate,  ctCurrency, ctFloat,    ctNull,  ctFloat,    ctFloat    ),
    ({ ctDate }     ctEmpty,   ctAny,   ctError, ctDate,     ctDate,     ctDate,    ctDate,  ctDate,     ctDate,     ctNull,  ctDate,     ctDate     ),
    ({ ctCurrency } ctEmpty,   ctAny,   ctError, ctCurrency, ctCurrency, ctCurrency,ctDate,  ctCurrency, ctCurrency, ctNull,  ctCurrency, ctCurrency ),
{$endif}
    ({ ctInt64 }    ctEmpty,   ctAny,   ctError, ctInt64,    ctInt64,    {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,  ctFloat,    ctFloat    ),
    ({ ctNull }     ctEmpty,   ctAny,   ctError, ctNull,     ctNull,     {$ifndef FPUNONE}ctNull,    ctNull,  ctNull,     {$endif}ctNull,     ctNull,  ctNull,     ctNull     ),
    ({ ctWideStr }  ctEmpty,   ctAny,   ctError, ctFloat,    ctWideStr,  {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,  ctWideStr,  ctWideStr  ),
    ({ ctString }   ctEmpty,   ctAny,   ctError, ctFloat,    ctString,   {$ifndef FPUNONE}ctFloat,   ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,  ctWideStr,  ctString   )
    );

function DoVarCmpSimple (const Left, Right, Common: TCommonType) : ShortInt; inline;
begin
  if Left = Common then
    if Right = Common then
      Result := 0
    else
      Result := -1
  else
    Result := 1;
end;

function DoVarCmpAny(const Left, Right: TVarData; const OpCode: TVarOp) : ShortInt;
begin
  VarInvalidOp(Left.vType, Right.vType, OpCode);
  Result:=0;
end;

function DoVarCmpLongInt(const Left, Right: LongInt): ShortInt; inline;
begin
  if Left < Right then
    Result := -1
  else if Left > Right then
    Result := 1
  else
    Result := 0;
end;

{$ifndef FPUNONE}
function DoVarCmpFloat(const Left, Right: Double; const OpCode: TVarOp): ShortInt;
begin
  if Left = Right then
    Result := 0
  else if (OpCode in [opCmpEq, opCmpNe]) or (Left < Right) then
    Result := -1
  else
    Result := 1;
end;
{$endif}

function DoVarCmpInt64(const Left, Right: Int64): ShortInt;
begin
  if Left < Right then
    Result := -1
  else if Left > Right then
    Result := 1
  else
    Result := 0;
end;

function DoVarCmpNull(const Left, Right: TCommonType; const OpCode: TVarOp) : ShortInt;
const
  ResultMap: array [Boolean, opCmpEq..opCmpGe] of ShortInt =
    ( ( -1, 0, 0, 1, 0, -1 ), ( 0, -1, -1, -1, 1, 1 ) );
begin
  if OpCode in [opCmpEq, opCmpNe] then
    case NullEqualityRule of
      ncrError:  VarInvalidNullOp;
      ncrStrict: Result := ResultMap[False, OpCode];
      ncrLoose:  Result := ResultMap[(Left = Right) xor (OpCode = opCmpNe), OpCode];
    end
  else
    case NullMagnitudeRule of
      ncrError:  VarInvalidNullOp;
      ncrStrict: Result := ResultMap[False, OpCode];
      ncrLoose:  Result := DoVarCmpSimple(Left, Right, ctNull);
    end;
end;

function DoVarCmpCurr(const Left, Right: Currency): ShortInt;
begin
  if Left < Right then
    Result := -1
  else if Left > Right then
    Result := 1
  else
    Result := 0;
end;

function DoVarCmpWStrDirect(const Left, Right: Pointer; const OpCode: TVarOp): ShortInt; inline;
begin
  { we can do this without ever copying the string }
  if OpCode in [opCmpEq, opCmpNe] then
    if Length(WideString(Left)) <> Length(WideString(Right)) then
      Exit(-1);
  Result := WideCompareStr(
    WideString(Left),
    WideString(Right)
  );
end;


function DoVarCmpWStr(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
begin
  { keep the temps away from the main proc }
  Result := DoVarCmpWStrDirect(Pointer(VariantToWideString(Left)),
    Pointer(VariantToWideString(Right)), OpCode);
end;


function DoVarCmpLStrDirect(const Left, Right: Pointer; const OpCode: TVarOp): ShortInt; inline;
begin
  { we can do this without ever copying the string }
  if OpCode in [opCmpEq, opCmpNe] then
    if Length(AnsiString(Left)) <> Length(AnsiString(Right)) then
      Exit(-1);
  Result := CompareStr(
    AnsiString(Left),
    AnsiString(Right)
  );
end;


function DoVarCmpLStr(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
begin
  { keep the temps away from the main proc }
  Result := DoVarCmpLStrDirect(Pointer(VariantToAnsiString(Left)),
    Pointer(VariantToAnsiString(Right)), OpCode);
end;

function DoVarCmpComplex(const Left, Right: TVarData; const OpCode: TVarOp): ShortInt;
var Handler: TCustomVariantType;
    CmpRes: boolean;
begin
  if FindCustomVariantType(Left.vType, Handler) then
    CmpRes := Handler.CompareOp(Left, Right, OpCode)
  else if FindCustomVariantType(Right.vType, Handler) then
    CmpRes := Handler.CompareOp(Left, Right, OpCode)
  else
  VarInvalidOp(Left.vType, Right.vType, OpCode);

  case OpCode of
    opCmpEq:
      if CmpRes then
        Result:=0
      else
        Result:=1;
    opCmpNe:
      if CmpRes then
        Result:=1
      else
        Result:=0;
    opCmpLt,
    opCmpLe:
      if CmpRes then
        Result:=-1
      else
        Result:=1;
    opCmpGt,
    opCmpGe:
      if CmpRes then
        Result:=1
      else
        Result:=-1;
  end;
end;


function DoVarCmp(const vl, vr : TVarData; const OpCode : TVarOp) : ShortInt;
var
  lct: TCommonType;
  rct: TCommonType;
begin
  { as the function in cvarutil.inc can handle varByRef correctly we simply
    resolve the final type }
  lct := MapToCommonType(VarTypeDeRef(vl));
  rct := MapToCommonType(VarTypeDeRef(vr));

  {$IFDEF DEBUG_VARIANTS}
  if __DEBUG_VARIANTS then begin
    WriteLn('DoVarCmp $', IntToHex(Cardinal(@vl),8), ' ', GetEnumName(TypeInfo(TVarOp), Ord(OpCode)) ,' $', IntToHex(Cardinal(@vr),8));
    DumpVariant('DoVarCmp/vl', vl);
    WriteLn('lct ', GetEnumName(TypeInfo(TCommonType), Ord(lct)));

    DumpVariant('DoVarCmp/vr', vr);
    WriteLn('rct ', GetEnumName(TypeInfo(TCommonType), Ord(rct)));

    WriteLn('common ', GetEnumName(TypeInfo(TCommonType), Ord(FindCmpCommonType[lct, rct])));
  end;
  {$ENDIF}

  case FindCmpCommonType[lct, rct] of
    ctEmpty:    Result := DoVarCmpSimple(lct, rct, ctEmpty);
    ctAny:      Result := DoVarCmpAny(vl, vr, OpCode);
    ctLongInt:  Result := DoVarCmpLongInt(VariantToLongInt(vl), VariantToLongInt(vr));
{$ifndef FPUNONE}
    ctFloat:    Result := DoVarCmpFloat(VariantToDouble(vl), VariantToDouble(vr), OpCode);
{$endif}
    ctBoolean:  Result := DoVarCmpLongInt(LongInt(VariantToBoolean(vl)), LongInt(VariantToBoolean(vr)));
    ctInt64:    Result := DoVarCmpInt64(VariantToInt64(vl), VariantToInt64(vr));
    ctNull:     Result := DoVarCmpNull(lct, rct, OpCode);
    ctWideStr:
      if (vl.vType = varOleStr) and (vr.vType = varOleStr) then
        Result := DoVarCmpWStrDirect(Pointer(vl.vOleStr), Pointer(vr.vOleStr), OpCode)
      else
        Result := DoVarCmpWStr(vl, vr, OpCode);
{$ifndef FPUNONE}
    ctDate:     Result := DoVarCmpFloat(VariantToDate(vl), VariantToDate(vr), OpCode);
    ctCurrency: Result := DoVarCmpCurr(VariantToCurrency(vl), VariantToCurrency(vr));
{$endif}
    ctString:
      if (vl.vType = varString) and (vr.vType = varString) then
        Result := DoVarCmpLStrDirect(Pointer(vl.vString), Pointer(vr.vString), OpCode)
      else
        Result := DoVarCmpLStr(vl, vr, OpCode);
  else
    Result := DoVarCmpComplex(vl, vr, OpCode);
  end;
end;

function syscmpop (const Left, Right : Variant; const OpCode : TVarOp) : Boolean;
var
  CmpRes : ShortInt;
begin
  CmpRes:=DoVarCmp(TVarData(Left),TVarData(Right),OpCode);
  case OpCode of
    opCmpEq:
      Result:=CmpRes=0;
    opCmpNe:
      Result:=CmpRes<>0;
    opCmpLt:
      Result:=CmpRes<0;
    opCmpLe:
      Result:=CmpRes<=0;
    opCmpGt:
      Result:=CmpRes>0;
    opCmpGe:
      Result:=CmpRes>=0;
   else
     VarInvalidOp;
  end;
end;


const
  FindOpCommonType : array[TCommonType,TCommonType] of TCommonType = (
     {              ctEmpty  ctAny    ctError  ctLongInt   ctBoolean   ctFloat     ctDate   ctCurrency  ctInt64     ctNull    ctWideStr   ctString  }
    ({ ctEmpty }    ctEmpty, ctAny,   ctError, ctEmpty,    ctEmpty,    {$ifndef FPUNONE}ctEmpty,    ctEmpty, ctEmpty,    {$endif}ctEmpty,    ctEmpty,  ctEmpty,    ctEmpty    ),
    ({ ctAny }      ctAny,   ctAny,   ctError, ctAny,      ctAny,      {$ifndef FPUNONE}ctAny,      ctAny,   ctAny,      {$endif}ctAny,      ctAny,    ctAny,      ctAny      ),
    ({ ctError }    ctError, ctError, ctError, ctError,    ctError,    {$ifndef FPUNONE}ctError,    ctError, ctError,    {$endif}ctError,    ctError,  ctError,    ctError    ),
    ({ ctLongInt }  ctEmpty, ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,   ctFloat,    ctFloat    ),
    ({ ctBoolean }  ctEmpty, ctAny,   ctError, ctLongInt,  ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,   ctBoolean,  ctBoolean  ),
{$ifndef FPUNONE}
    ({ ctFloat }    ctEmpty, ctAny,   ctError, ctFloat,    ctFloat,    ctFloat,    ctDate,  ctCurrency, ctFloat,    ctNull,   ctFloat,    ctFloat    ),
    ({ ctDate }     ctEmpty, ctAny,   ctError, ctDate,     ctDate,     ctDate,     ctDate,  ctDate,     ctDate,     ctNull,   ctDate,     ctDate     ),
    ({ ctCurrency } ctEmpty, ctAny,   ctError, ctCurrency, ctCurrency, ctCurrency, ctDate,  ctCurrency, ctCurrency, ctNull,   ctCurrency, ctCurrency ),
{$endif}
    ({ ctInt64 }    ctEmpty, ctAny,   ctError, ctInt64,    ctInt64,    {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctInt64,    ctNull,   ctFloat,    ctFloat    ),
    ({ ctNull }     ctEmpty, ctAny,   ctError, ctNull,     ctNull,     {$ifndef FPUNONE}ctNull,     ctNull,  ctNull,     {$endif}ctNull,     ctNull,   ctNull,     ctNull     ),
    ({ ctWideStr }  ctEmpty, ctAny,   ctError, ctFloat,    ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,   ctWideStr,  ctWideStr  ),
    ({ ctString }   ctEmpty, ctAny,   ctError, ctFloat,    ctBoolean,  {$ifndef FPUNONE}ctFloat,    ctDate,  ctCurrency, {$endif}ctFloat,    ctNull,   ctWideStr,  ctString   )
    );

procedure DoVarOpFloat(var vl :TVarData; const vr : TVarData; const OpCode : TVarOp);
{$ifndef FPUNONE}
var
  l, r : Double;
begin
  l := VariantToDouble(vl);
  r := VariantToDouble(vr);
  case OpCode of
    opAdd      :  l := l  + r;
    opSubtract :  l := l  - r;
    opMultiply :  l := l  * r;
    opDivide   :  l := l  / r;
    opPower    :  l := l ** r;
  else
    VarInvalidOp(vl.vType, vr.vType, OpCode);
  end;
  DoVarClearIfComplex(vl);
  vl.vType := varDouble;
  vl.vDouble := l;
{$else}
begin
   VarInvalidOp(vl.vType, vr.vType, OpCode);
{$endif}
end;

procedure DoVarOpAny(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
begin
  VarInvalidOp(vl.vType, vr.vType, OpCode);
end;

procedure DoVarOpLongInt(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
var
  l, r: LongInt;
begin
  l := VariantToLongint(vl);
  r := VariantToLongint(vr);
  case OpCode of
    opIntDivide  : l := l div r;
    opModulus    : l := l mod r;
    opShiftLeft  : l := l shl r;
    opShiftRight : l := l shr r;
    opAnd        : l := l and r;
    opOr         : l := l  or r;
    opXor        : l := l xor r;
  else
    VarInvalidOp(vl.vType, vr.vType, OpCode);
  end;
  DoVarClearIfComplex(vl);
  vl.vType := varInteger;
  vl.vInteger := l;
end;

procedure DoVarOpInt64(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
var
  l, r     : Int64;
  Overflow : Boolean;
begin
  l := VariantToInt64(vl);
  r := VariantToInt64(vr);
  Overflow := False;
  case OpCode of
    {$R+}{$Q+}
    opAdd..opMultiply,opPower: try
      case OpCode of
        opAdd      :  l := l  + r;
        opSubtract :  l := l  - r;
        opMultiply :  l := l  * r;
{$ifndef FPUNONE}
        opPower    :  l := l ** r;
{$endif}
      end;
    except
      on E: SysUtils.ERangeError do
        Overflow := True;
      on E: SysUtils.EIntOverflow do
        Overflow := True;
    end;
    {$IFDEF RANGECHECKINGOFF} {$R-} {$ENDIF} {$IFDEF OVERFLOWCHECKINGOFF} {$Q+} {$ENDIF}
    opIntDivide  : l := l div r;
    opModulus    : l := l mod r;
    opShiftLeft  : l := l shl r;
    opShiftRight : l := l shr r;
    opAnd        : l := l and r;
    opOr         : l := l  or r;
    opXor        : l := l xor r;
  else
    VarInvalidOp(vl.vType, vr.vType, OpCode);
  end;
  if Overflow then
    DoVarOpFloat(vl,vr,OpCode)
  else begin
    DoVarClearIfComplex(vl);
    vl.vType := varInt64;
    vl.vInt64 := l;
  end;
end;

procedure DoVarOpInt64to32(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
begin
  { can't do this well without an efficent way to check for overflows,
    let the Int64 version handle it and check the Result if we can downgrade it
    to integer }
  DoVarOpInt64(vl, vr, OpCode);
  with vl do
    if (vType = varInt64) and (vInt64 >= Low(LongInt)) and (vInt64 <= High(LongInt)) then begin
      vInteger := vInt64;
      vType := varInteger;
    end;
end;


procedure DoVarOpBool(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
var
  l,r: Boolean;
begin
  l := VariantToBoolean(vl);
  r := VariantToBoolean(vr);
  case OpCode of
    opAnd : l := l and r;
    opOr  : l := l  or r;
    opXor : l := l xor r;
  else
    VarInvalidOp(vl.vType, vr.vType, OpCode);
  end;
  DoVarClearIfComplex(vl);
  vl.vType := varBoolean;
  vl.vBoolean := l;
end;

procedure DoVarOpNull(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
begin
  if (OpCode = opAnd) or (OpCode = opOr) then
    if vl.vType = varNull then begin
      if vr.vType = varNull then begin
        {both null, do nothing }
      end else begin
        {Left null, Right not}
        if OpCode = opAnd then begin
          if not VariantToBoolean(vr) then
            VarCopyProc(vl, vr);
        end else {OpCode = opOr} begin
          if VariantToBoolean(vr) then
            VarCopyProc(vl, vr);
        end;
      end;
    end else begin
      if vr.vType = varNull then begin
        {Right null, Left not}
        if OpCode = opAnd then begin
          if VariantToBoolean(vl) then begin
            DoVarClearIfComplex(vl);
            vl.vType := varNull;
          end;
        end else {OpCode = opOr} begin
          if not VariantToBoolean(vl) then begin
            DoVarClearIfComplex(vl);
            vl.vType := varNull;
          end;
        end;
      end else begin
        { both not null, shouldn't happen }
        VarInvalidOp(vl.vType, vr.vType, OpCode);
      end;
    end
  else begin
    DoVarClearIfComplex(vl);
    vl.vType := varNull;
  end;
end;

procedure DoVarOpWStrCat(var vl : TVarData; const vr : TVarData);
var
  ws: WideString;
begin
  ws := VariantToWideString(vl) + VariantToWideString(vr);
  DoVarClearIfComplex(vl);
  vl.vType := varOleStr;
  { transfer the WideString without making a copy }
  Pointer(vl.vOleStr) := Pointer(ws);
  { prevent the WideString from being freed, the reference has been transfered
    from the local to the variant and will be correctly finalized when the
    variant is finalized. }
  Pointer(ws) := nil;
end;

procedure DoVarOpLStrCat(var vl: TVarData; const vr : TVarData);
var
  s: AnsiString;
begin
  s := VariantToAnsiString(vl) + VariantToAnsiString(vr);
  DoVarClearIfComplex(vl);
  vl.vType := varString;
  { transfer the AnsiString without making a copy }
  Pointer(vl.vString) := Pointer(s);
  { prevent the AnsiString from being freed, the reference has been transfered
    from the local to the variant and will be correctly finalized when the
    variant is finalized. }
  Pointer(s) := nil;
end;

procedure DoVarOpDate(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
{$ifndef FPUNONE}
var
  l, r : TDateTime;
begin
  l := VariantToDate(vl);
  r := VariantToDate(vr);
  case OpCode of
    opAdd      : l := l + r;
    opSubtract : l := l - r;
  else
    VarInvalidOp(vl.vType, vr.vType, OpCode);
  end;
  DoVarClearIfComplex(vl);
  vl.vType := varDate;
  vl.vDate := l;
{$else}
begin
   VarInvalidOp(vl.vType, vr.vType, OpCode);
{$endif}
end;

procedure DoVarOpCurr(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp; const lct, rct : TCommonType);
{$ifndef FPUNONE}
var
  c  : Currency;
  d  : Double;
begin
  case OpCode of
    opAdd:
      c := VariantToCurrency(vl) + VariantToCurrency(vr);
    opSubtract:
      c := VariantToCurrency(vl) - VariantToCurrency(vr);
    opMultiply:
      if lct = ctCurrency then
        if rct = ctCurrency then {both Currency}
          c := VariantToCurrency(vl) * VariantToCurrency(vr)
        else {Left Currency}
          c := VariantToCurrency(vl) * VariantToDouble(vr)
      else
        if rct = ctCurrency then {rigth Currency}
          c := VariantToDouble(vl) * VariantToCurrency(vr)
        else {non Currency, error}
          VarInvalidOp(vl.vType, vr.vType, OpCode);
    opDivide:
      if lct = ctCurrency then
        if rct = ctCurrency then {both Currency}
          c := VariantToCurrency(vl) / VariantToCurrency(vr)
        else {Left Currency}
          c := VariantToCurrency(vl) / VariantToDouble(vr)
      else
        if rct = ctCurrency then begin {rigth Currency}
          d := VariantToCurrency(vl) / VariantToCurrency(vr);
          DoVarClearIfComplex(vl);
          vl.vType := varDouble;
          vl.vDouble := d;
          Exit;
        end else {non Currency, error}
          VarInvalidOp(vl.vType, vr.vType, OpCode);
    opPower:
      if lct = ctCurrency then
        if rct = ctCurrency then {both Currency}
          c := VariantToCurrency(vl) ** VariantToCurrency(vr)
        else {Left Currency}
          c := VariantToCurrency(vl) ** VariantToDouble(vr)
      else
        if rct = ctCurrency then {rigth Currency}
          c := VariantToDouble(vl) ** VariantToCurrency(vr)
        else {non Currency, error}
          VarInvalidOp(vl.vType, vr.vType, OpCode);
  else
    VarInvalidOp(vl.vType, vr.vType, OpCode);
  end;
  DoVarClearIfComplex(vl);
  vl.vType := varCurrency;
  vl.vCurrency := c;
{$else}
begin
   VarInvalidOp(vl.vType, vr.vType, OpCode);
{$endif}
end;

procedure DoVarOpComplex(var vl : TVarData; const vr : TVarData; const OpCode : TVarOp);
var Handler: TCustomVariantType;
begin
  if FindCustomVariantType(vl.vType, Handler) then
    Handler.BinaryOp(vl, vr, OpCode)
  else if FindCustomVariantType(vr.vType, Handler) then
    Handler.BinaryOp(vl, vr, OpCode)
  else
   VarInvalidOp(vl.vType, vr.vType, OpCode);
end;

procedure SysVarOp(var Left : Variant; const Right : Variant; OpCode : TVarOp);
var
  lct: TCommonType;
  rct: TCommonType;
  {$IFDEF DEBUG_VARIANTS}
  i: Integer;
  {$ENDIF}
begin
  { as the function in cvarutil.inc can handle varByRef correctly we simply
    resolve the final type }
  lct := MapToCommonType(VarTypeDeRef(Left));
  rct := MapToCommonType(VarTypeDeRef(Right));

  {$IFDEF DEBUG_VARIANTS}
  if __DEBUG_VARIANTS then begin
    WriteLn('SysVarOp $', IntToHex(Cardinal(@TVarData(Left)),8), ' ', GetEnumName(TypeInfo(TVarOp), Ord(OpCode)) ,' $', IntToHex(Cardinal(@TVarData(Right)),8));
    DumpVariant('SysVarOp/TVarData(Left)', TVarData(Left));
    WriteLn('lct ', GetEnumName(TypeInfo(TCommonType), Ord(lct)));

    DumpVariant('SysVarOp/TVarData(Right)', TVarData(Right));
    WriteLn('rct ', GetEnumName(TypeInfo(TCommonType), Ord(rct)));

    WriteLn('common ', GetEnumName(TypeInfo(TCommonType), Ord(FindOpCommonType[lct, rct])));
  end;
  {$ENDIF}

  case FindOpCommonType[lct, rct] of
    ctEmpty:
      case OpCode of
        opDivide:
          Error(reZeroDivide);
        opIntDivide, opModulus:
          Error(reDivByZero);
      else
        DoVarClear(TVarData(Left));
      end;
    ctAny:
      DoVarOpAny(TVarData(Left),TVarData(Right),OpCode);
    ctLongInt:
      case OpCode of
        opAdd..opMultiply,opPower:
          DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
        opDivide:
          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
      else
        DoVarOpLongInt(TVarData(Left),TVarData(Right),OpCode);
      end;
{$ifndef FPUNONE}
    ctFloat:
      if OpCode in [opAdd,opSubtract,opMultiply,opDivide] then
        DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode)
      else
        DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
{$endif}
    ctBoolean:
      case OpCode of
        opAdd..opMultiply, opPower:
          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
        opIntDivide..opShiftRight:
          DoVarOpLongInt(TVarData(Left),TVarData(Right),OpCode);
        opAnd..opXor:
          DoVarOpBool(TVarData(Left),TVarData(Right),OpCode);
      else
        VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
      end;
    ctInt64:
      if OpCode <> opDivide then
        DoVarOpInt64(TVarData(Left),TVarData(Right),OpCode)
      else
        DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
    ctNull:
      DoVarOpNull(TVarData(Left),TVarData(Right),OpCode);
    ctWideStr:
      case OpCode of
        opAdd:
          DoVarOpWStrCat(TVarData(Left),TVarData(Right));
        opSubtract..opDivide,opPower:
          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
        opIntDivide..opXor:
          DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
      else
        VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
      end;
{$ifndef FPUNONE}
    ctDate:
      case OpCode of
        opAdd:
          DoVarOpDate(TVarData(Left),TVarData(Right),OpCode);
        opSubtract: begin
          DoVarOpDate(TVarData(Left),TVarData(Right),OpCode);
            if lct = rct then {both are date}
              TVarData(Left).vType := varDouble;
        end;
        opMultiply, opDivide:
          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
      else
        DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
      end;
    ctCurrency:
      if OpCode in [opAdd..opDivide, opPower] then
        DoVarOpCurr(TVarData(Left),TVarData(Right),OpCode, lct, rct)
      else
        DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
{$endif}
    ctString:
      case OpCode of
        opAdd:
          DoVarOpLStrCat(TVarData(Left),TVarData(Right));
        opSubtract..opDivide,opPower:
          DoVarOpFloat(TVarData(Left),TVarData(Right),OpCode);
        opIntDivide..opXor:
          DoVarOpInt64to32(TVarData(Left),TVarData(Right),OpCode);
      else
        VarInvalidOp(TVarData(Left).vType, TVarData(Right).vType, OpCode);
      end;
  else
    { more complex case }
    DoVarOpComplex(TVarData(Left),TVarData(Right),OpCode);
  end;
end;

procedure DoVarNegAny(var v: TVarData);
begin
  VarInvalidOp(v.vType, opNegate);
end;

procedure DoVarNegComplex(var v: TVarData);
begin
  { custom variants? }
  VarInvalidOp(v.vType, opNegate);
end;

procedure sysvarneg(var v: Variant);
const
  BoolMap: array [Boolean] of SmallInt = (0, -1);
begin
  with TVarData(v) do case vType of
    varEmpty: begin
      vSmallInt := 0;
      vType := varSmallInt;
    end;
    varNull:;
    varSmallint: vSmallInt := -vSmallInt;
    varInteger:  vInteger  := -vInteger;
{$ifndef FPUNONE}
    varSingle:   vSingle   := -vSingle;
    varDouble:   vDouble   := -vDouble;
    varCurrency: vCurrency := -vCurrency;
    varDate:     vDate     := -vDate;
    varOleStr:   sysvarfromreal(v, -VariantToDouble(TVarData(v)));
{$else}
    varOleStr:   sysvarfromint64(v, -VariantToInt64(TVarData(v)));
{$endif}
    varBoolean: begin
      vSmallInt := BoolMap[vBoolean];
      vType := varSmallInt;
    end;
    varShortInt: vShortInt := -vShortInt;
    varByte: begin
      vSmallInt := -vByte;
      vType := varSmallInt;
    end;
    varWord: begin
      vInteger := -vWord;
      vType := varInteger;
    end;
    varLongWord:
      if vLongWord and $80000000 <> 0 then begin
        vInt64 := -vLongWord;
        vType := varInt64;
      end else begin
        vInteger := -vLongWord;
        vType := varInteger;
      end;
    varInt64:    vInt64    := -vInt64;
    varQWord: begin
      if vQWord and $8000000000000000 <> 0 then
        VarRangeCheckError(varQWord, varInt64);
      vInt64 := -vQWord;
      vType := varInt64;
    end;
    varVariant:  v         := -Variant(PVarData(vPointer)^);
  else {with TVarData(v) do case vType of}
    case vType of
{$ifndef FPUNONE}
      varString:   sysvarfromreal(v, -VariantToDouble(TVarData(v)));
{$else}
      varString:   sysvarfromint64(v, -VariantToInt64(TVarData(v)));
{$endif}
      varAny:      DoVarNegAny(TVarData(v));
    else {case vType of}
      if (vType and not varTypeMask) = varByRef then
        case vType and varTypeMask of
          varSmallInt: begin
            vSmallInt := -PSmallInt(vPointer)^;
            vType := varSmallInt;
          end;
          varInteger: begin
            vInteger := -PInteger(vPointer)^;
            vType := varInteger;
          end;
{$ifndef FPUNONE}
          varSingle: begin
            vSingle := -PSingle(vPointer)^;
            vType := varSingle;
          end;
          varDouble: begin
            vDouble := -PDouble(vPointer)^;
            vType := varDouble;
          end;
          varCurrency: begin
            vCurrency := -PCurrency(vPointer)^;
            vType := varCurrency;
          end;
          varDate: begin
            vDate := -PDate(vPointer)^;
            vType := varDate;
          end;
          varOleStr: sysvarfromreal(v, -VariantToDouble(TVarData(v)));
{$else}
          varOleStr: sysvarfromint64(v, -VariantToInt64(TVarData(v)));
{$endif}
          varBoolean: begin
            vSmallInt := BoolMap[PWordBool(vPointer)^];
            vType := varSmallInt;
          end;
          varShortInt: begin
            vShortInt := -PShortInt(vPointer)^;
            vType := varShortInt;
          end;
          varByte: begin
            vSmallInt := -PByte(vPointer)^;
            vType := varSmallInt;
          end;
          varWord: begin
            vInteger := -PWord(vPointer)^;
            vType := varInteger;
          end;
          varLongWord:
            if PLongWord(vPointer)^ and $80000000 <> 0 then begin
              vInt64 := -PLongWord(vPointer)^;
              vType := varInt64;
            end else begin
              vInteger := -PLongWord(vPointer)^;
              vType := varInteger;
            end;
          varInt64: begin
            vInt64 := -PInt64(vPointer)^;
            vType := varInt64;
          end;
          varQWord: begin
            if PQWord(vPointer)^ and $8000000000000000 <> 0 then
              VarRangeCheckError(varQWord, varInt64);
            vInt64 := -PQWord(vPointer)^;
            vType := varInt64;
          end;
          varVariant:
            v := -Variant(PVarData(vPointer)^);
        else {case vType and varTypeMask of}
          DoVarNegComplex(TVarData(v));
        end {case vType and varTypeMask of}
      else {if (vType and not varTypeMask) = varByRef}
        DoVarNegComplex(TVarData(v));
    end; {case vType of}
  end; {with TVarData(v) do case vType of}
end;

procedure DoVarNotAny(var v: TVarData);
begin
  VarInvalidOp(v.vType, opNot);
end;

procedure DoVarNotOrdinal(var v: TVarData);
var
  i: Int64;
begin
  { only called for types that do no require finalization }
  i := VariantToInt64(v);
  with v do
    if (i < Low(Integer)) or (i > High(Integer)) then begin
      vInt64 := not i;
      vType := varInt64;
    end else begin
      vInteger := not Integer(i);
      vType := varInteger;
    end
end;

procedure DoVarNotWStr(var v: TVarData; const p: Pointer);
var
  i: Int64;
  e: Word;
  b: Boolean;
begin
  Val(WideString(p), i, e);
  with v do
    if e = 0 then begin
      DoVarClearIfComplex(v);
      if (i < Low(Integer)) or (i > High(Integer)) then begin
        vInt64 := not i;
        vType := varInt64;
      end else begin
        vInteger := not Integer(i);
        vType := varInteger;
      end
    end else begin
      if not TryStrToBool(WideString(p), b) then
        VarInvalidOp(vType, opNot);
      DoVarClearIfComplex(v);
      vBoolean := not b;
      vType := varBoolean;
    end;
end;

procedure DoVarNotLStr(var v: TVarData; const p: Pointer);
var
  i: Int64;
  e: Word;
  b: Boolean;
begin
  Val(AnsiString(p), i, e);
  with v do
    if e = 0 then begin
      DoVarClearIfComplex(v);
      if (i < Low(Integer)) or (i > High(Integer)) then begin
        vInt64 := not i;
        vType := varInt64;
      end else begin
        vInteger := not Integer(i);
        vType := varInteger;
      end
    end else begin
      if not TryStrToBool(AnsiString(p), b) then
        VarInvalidOp(v.vType, opNot);
      DoVarClearIfComplex(v);
      vBoolean := not b;
      vType := varBoolean;
    end;
end;

procedure DoVarNotComplex(var v: TVarData);
begin
  { custom variant support ?}
  VarInvalidOp(v.vType, opNot);
end;

procedure sysvarnot(var v: Variant);
begin
  with TVarData(v) do case vType of
    varEmpty:    v := -1;
    varNull:;
    varSmallint: vSmallInt := not vSmallInt;
    varInteger:  vInteger  := not vInteger;
{$ifndef FPUNONE}
    varSingle,
    varDouble,
    varCurrency,
    varDate:     DoVarNotOrdinal(TVarData(v));
{$endif}
    varOleStr:   DoVarNotWStr(TVarData(v), Pointer(vOleStr));
    varBoolean:  vBoolean := not vBoolean;
    varShortInt: vShortInt := not vShortInt;
    varByte:     vByte := not vByte;
    varWord:     vWord := not vWord;
    varLongWord: vLongWord := not vLongWord;
    varInt64:    vInt64    := not vInt64;
    varQWord:    vQWord    := not vQWord;
    varVariant:  v         := not Variant(PVarData(vPointer)^);
  else {with TVarData(v) do case vType of}
    case vType of
      varString:   DoVarNotLStr(TVarData(v), Pointer(vString));
      varAny:      DoVarNotAny(TVarData(v));
    else {case vType of}
      if (vType and not varTypeMask) = varByRef then
        case vType and varTypeMask of
          varSmallInt: begin
            vSmallInt := not PSmallInt(vPointer)^;
            vType := varSmallInt;
          end;
          varInteger: begin
            vInteger := not PInteger(vPointer)^;
            vType := varInteger;
          end;
{$ifndef FPUNONE}
          varSingle,
          varDouble,
          varCurrency,
          varDate: DoVarNotOrdinal(TVarData(v));
{$endif}
          varOleStr: DoVarNotWStr(TVarData(v), PPointer(vPointer)^);
          varBoolean: begin
            vBoolean := not PWordBool(vPointer)^;
            vType := varBoolean;
          end;
          varShortInt: begin
            vShortInt := not PShortInt(vPointer)^;
            vType := varShortInt;
          end;
          varByte: begin
            vByte := not PByte(vPointer)^;
            vType := varByte;
          end;
          varWord: begin
            vWord := not PWord(vPointer)^;
            vType := varWord;
          end;
          varLongWord: begin
            vLongWord := not PLongWord(vPointer)^;
            vType := varLongWord;
          end;
          varInt64: begin
            vInt64 := not PInt64(vPointer)^;
            vType := varInt64;
          end;
          varQWord: begin
            vQWord := not PQWord(vPointer)^;
            vType := varQWord;
          end;
          varVariant:
            v := not Variant(PVarData(vPointer)^);
        else {case vType and varTypeMask of}
          DoVarNotComplex(TVarData(v));
        end {case vType and varTypeMask of}
      else {if (vType and not varTypeMask) = varByRef}
        DoVarNotComplex(TVarData(v));
    end; {case vType of}
  end; {with TVarData(v) do case vType of}
end;

{
  This procedure is needed to destroy and clear non-standard variant type array elements,
  which can not be handled by SafeArrayDestroy.
  If array element type is varVariant, then clear each element individually before
  calling VariantClear for array. VariantClear just calls SafeArrayDestroy.
}
procedure DoVarClearArray(var VArray: TVarData);
var
  arr: pvararray;
  i, cnt: cardinal;
  data: pvardata;
begin
  if VArray.vtype and varTypeMask = varVariant then begin
    if WordBool(VArray.vType and varByRef) then
      arr:=PVarArray(VArray.vPointer^)
    else
      arr:=VArray.vArray;
    VarResultCheck(SafeArrayAccessData(arr, data));
    try
      { Calculation total number of elements in the array }
      cnt:=1;
{$ifopt r+}
{ arr^.bounds[] is an array[0..0] }
{$define rangeon}
{$r-}
{$endif}
      for i:=0 to arr^.dimcount - 1 do
        cnt:=cnt*cardinal(arr^.Bounds[i].ElementCount);
{$ifdef rangeon}
{$undef rangeon}
{$r+}
{$endif}

      { Clearing each element }
      for i:=1 to cnt do begin
        DoVarClear(data^);
        Inc(pointer(data), arr^.ElementSize);
      end;
    finally
      VarResultCheck(SafeArrayUnaccessData(arr));
    end;
  end;
  VariantClear(VArray);
end;

procedure DoVarClearComplex(var v : TVarData);
var
  Handler : TCustomVariantType;
begin
  with v do
    if vType < varInt64 then
      VarResultCheck(VariantClear(v))
    else if vType = varString then begin
      AnsiString(vString) := '';
      vType := varEmpty
    end else if vType = varAny then
      ClearAnyProc(v)
    else if vType and varArray <> 0 then
      DoVarClearArray(v)
    else if FindCustomVariantType(vType, Handler) then
      Handler.Clear(v)
    else begin
      { ignore errors, if the OS doesn't know how to free it, we don't either }
      VariantClear(v);
      vType := varEmpty;
    end;
end;

type
  TVarArrayCopyCallback = procedure(var aDest: TVarData; const aSource: TVarData);

procedure DoVarCopyArray(var aDest: TVarData; const aSource: TVarData; aCallback: TVarArrayCopyCallback);
var
  SourceArray : PVarArray;
  SourcePtr   : Pointer;
  DestArray   : PVarArray;
  DestPtr     : Pointer;

  Bounds      : array[0..63] of TVarArrayBound;
  Iterator    : TVariantArrayIterator;

  Dims        : Integer;
  HighBound   : Integer;
  i           : Integer;
begin
  with aSource do begin
    if vType and varArray = 0 then
      VarResultCheck(VAR_INVALIDARG);

    if (vType and varTypeMask) = varVariant then begin

      if (vType and varByRef) <> 0 then
        SourceArray := PVarArray(vPointer^)
      else
        SourceArray := vArray;

      Dims := SourceArray^.DimCount;
      for i := 0 to Pred(Dims) do
        with Bounds[i] do begin
          VarResultCheck(SafeArrayGetLBound(SourceArray, Succ(i), LowBound));
          VarResultCheck(SafeArrayGetUBound(SourceArray, Succ(i), HighBound));
          ElementCount := HighBound - LowBound + 1;
        end;

      DestArray := SafeArrayCreate(varVariant, Dims, PVarArrayBoundArray(@Bounds)^);
      if not Assigned(DestArray) then
        VarArrayCreateError;

      DoVarClearIfComplex(aDest);
      with aDest do begin
        vType := varVariant or varArray;
        vArray := DestArray;
      end;

      Iterator.Init(Dims, @Bounds);
      try
        if not(Iterator.AtEnd) then
          repeat
            VarResultCheck(SafeArrayPtrOfIndex(SourceArray, Iterator.Coords, SourcePtr));
            VarResultCheck(SafeArrayPtrOfIndex(DestArray, Iterator.Coords, DestPtr));
            aCallback(PVarData(DestPtr)^, PVarData(SourcePtr)^);
          until not Iterator.Next;
      finally
        Iterator.Done;
      end;

    end else
      VarResultCheck(VariantCopy(aDest, aSource));
  end;
end;

procedure DoVarCopyComplex(var Dest: TVarData; const Source: TVarData);
var
  Handler: TCustomVariantType;
begin
  DoVarClearIfComplex(Dest);

  with Source do
    if vType < varInt64 then
      VarResultCheck(VariantCopy(Dest, Source))
    else if vType = varString then begin
      Dest.vType := varString;
      Dest.vString := nil;
      AnsiString(Dest.vString) := AnsiString(vString);
    end else if vType = varAny then begin
      Dest := Source;
      RefAnyProc(Dest);
    end else if vType and varArray <> 0 then
      DoVarCopyArray(Dest, Source, @DoVarCopy)
    else if (vType and varByRef <> 0) and (vType xor varByRef = varString) then
      Dest := Source
    else if FindCustomVariantType(vType, Handler) then
      Handler.Copy(Dest, Source, False)
    else
      VarResultCheck(VariantCopy(Dest, Source));
end;

procedure DoVarCopy(var Dest : TVarData; const Source : TVarData);
begin
  if @Dest <> @Source then
    if (Source.vType and varComplexType) = 0 then begin
      DoVarClearIfComplex(Dest);
      Dest := Source;
    end else
      DoVarCopyComplex(Dest, Source);
end;

procedure sysvarcopy (var Dest : Variant; const Source : Variant);
begin
  DoVarCopy(TVarData(Dest),TVarData(Source));
end;

procedure DoVarAddRef(var v : TVarData); inline;
var
  Dummy : TVarData;
begin
  Dummy := v;
  v.vType := varEmpty;
  DoVarCopy(v, Dummy);
end;

procedure sysvaraddref(var v : Variant);
begin
  DoVarAddRef(TVarData(v));
end;

procedure DoVarCastWStr(var aDest : TVarData; const aSource : TVarData);
begin
  SysVarFromWStr(Variant(aDest), VariantToWideString(aSource));
end;

procedure DoVarCastLStr(var aDest : TVarData; const aSource : TVarData);
begin
  SysVarFromLStr(Variant(aDest), VariantToAnsiString(aSource));
end;

procedure DoVarCastDispatch(var aDest : TVarData; const aSource : TVarData);
var
  Disp: IDispatch;
begin
  SysVarToDisp(Disp, Variant(aSource));
  SysVarFromDisp(Variant(aDest), Disp);
end;

procedure DoVarCastInterface(var aDest : TVarData; const aSource : TVarData);
var
  Intf: IInterface;
begin
  SysVarToIntf(Intf, Variant(aSource));
  SysVarFromIntf(Variant(aDest), Intf);
end;

procedure DoVarCastAny(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
begin
  VarCastError(aSource.vType, aVarType)
end;

procedure DoVarCastFallback(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
begin
  if aSource.vType and varTypeMask >= varInt64 then begin
    DoVarCast(aDest, aSource, varOleStr);
    VarResultCheck(VariantChangeTypeEx(aDest, aDest, VAR_LOCALE_USER_DEFAULT,
      0, aVarType), aSource.vType, aVarType);
  end else if aVarType and varTypeMask < varInt64 then
    VarResultCheck(VariantChangeTypeEx(aDest, aSource, VAR_LOCALE_USER_DEFAULT,
      0, aVarType), aSource.vType, aVarType)
  else
    VarCastError(aSource.vType, aVarType);
end;

procedure DoVarCastComplex(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
var
  Handler: TCustomVariantType;
begin
  if aSource.vType = varAny then
    DoVarCastAny(aDest, aSource, aVarType)
  else if FindCustomVariantType(aSource.vType, Handler) then
    Handler.CastTo(aDest, aSource, aVarType)
  else if FindCustomVariantType(aVarType, Handler) then
    Handler.Cast(aDest, aSource)
  else
    DoVarCastFallback(aDest, aSource, aVarType);
end;

procedure DoVarCast(var aDest : TVarData; const aSource : TVarData; aVarType : LongInt);
begin
  with aSource do
    if vType = aVarType then
      DoVarCopy(aDest, aSource)
    else begin
      if (vType = varNull) and NullStrictConvert then
        VarCastError(varNull, aVarType);

      case aVarType of
        varEmpty, varNull: begin
          DoVarClearIfComplex(aDest);
          aDest.vType := aVarType;
        end;
        varSmallInt: SysVarFromInt(Variant(aDest), VariantToSmallInt(aSource), -2);
        varInteger:  SysVarFromInt(Variant(aDest), VariantToLongInt(aSource), -4);
{$ifndef FPUNONE}
        varSingle:   SysVarFromSingle(Variant(aDest), VariantToSingle(aSource));
        varDouble:   SysVarFromDouble(Variant(aDest), VariantToDouble(aSource));
        varCurrency: SysVarFromCurr(Variant(aDest), VariantToCurrency(aSource));
        varDate:     SysVarFromTDateTime(Variant(aDest), VariantToDate(aSource));
{$endif}
        varOleStr:   DoVarCastWStr(aDest, aSource);
        varBoolean:  SysVarFromBool(Variant(aDest), VariantToBoolean(aSource));
        varShortInt: SysVarFromInt(Variant(aDest), VariantToShortInt(aSource), -1);
        varByte:     SysVarFromInt(Variant(aDest), VariantToByte(aSource), 1);
        varWord:     SysVarFromInt(Variant(aDest), VariantToLongInt(aSource), 2);
        varLongWord: SysVarFromInt(Variant(aDest), Integer(VariantToCardinal(aSource)), 4);
        varInt64:    SysVarFromInt64(Variant(aDest), VariantToInt64(aSource));
        varQWord:    SysVarFromWord64(Variant(aDest), VariantToQWord(aSource));

        varDispatch: DoVarCastDispatch(aDest, aSource);
        varUnknown:  DoVarCastInterface(aDest, aSource);
      else
        case aVarType of
          varString: DoVarCastLStr(aDest, aSource);
          varAny:    VarCastError(vType, varAny);
        else
          DoVarCastComplex(aDest, aSource, aVarType);
        end;
      end;
    end;

end;

procedure sysvarcast (var aDest : Variant; const aSource : Variant; aVarType : LongInt);
begin
  DoVarCast(TVarData(aDest), TVarData(aSource), aVarType);
end;


procedure sysvarfromdynarray(var Dest : Variant; const Source : Pointer; TypeInfo: Pointer);
begin
  DynArrayToVariant(Dest,Source,TypeInfo);
  if VarIsEmpty(Dest) then
    VarCastError;
end;


procedure sysolevarfrompstr(var Dest : olevariant; const Source : ShortString);
begin
  sysvarfromwstr(Variant(TVarData(Dest)), Source);
end;


procedure sysolevarfromlstr(var Dest : olevariant; const Source : AnsiString);
begin
  sysvarfromwstr(Variant(TVarData(Dest)), Source);
end;

procedure DoOleVarFromAny(var aDest : TVarData; const aSource : TVarData);
begin
  VarCastErrorOle(aSource.vType);
end;

procedure DoOleVarFromVar(var aDest : TVarData; const aSource : TVarData);
var
  Handler: TCustomVariantType;
begin
  with aSource do
    if vType = varByRef or varVariant then
      DoOleVarFromVar(aDest, PVarData(vPointer)^)
    else begin
      case vType of
        varShortInt, varByte, varWord:
          DoVarCast(aDest, aSource, varInteger);
        varLongWord:
          if vLongWord and $80000000 = 0 then
            DoVarCast(aDest, aSource, varInteger)
          else
{$ifndef FPUNONE}
            if OleVariantInt64AsDouble then
              DoVarCast(aDest, aSource, varDouble)
            else
{$endif}
              DoVarCast(aDest, aSource, varInt64);
        varInt64:
          if (vInt64 < Low(Integer)) or (vInt64 > High(Integer)) then
{$ifndef FPUNONE}
            if OleVariantInt64AsDouble then
              DoVarCast(aDest, aSource, varDouble)
            else
{$endif}
              DoVarCast(aDest, aSource, varInt64)
          else
            DoVarCast(aDest, aSource, varInteger);
        varQWord:
          if vQWord > High(Integer) then
{$ifndef FPUNONE}
            if OleVariantInt64AsDouble or (vQWord and $8000000000000000 <> 0) then
              DoVarCast(aDest, aSource, varDouble)
            else
{$endif}
              DoVarCast(aDest, aSource, varInt64)
          else
            DoVarCast(aDest, aSource, varInteger);
        varString:
          DoVarCast(aDest, aSource, varOleStr);
        varAny:
          DoOleVarFromAny(aDest, aSource);
      else
        if (vType and varArray) <> 0 then
          DoVarCopyArray(aDest, aSource, @DoOleVarFromVar)
        else if (vType and varTypeMask) < CFirstUserType then
          DoVarCopy(aDest, aSource)
        else if FindCustomVariantType(vType, Handler) then
          Handler.CastToOle(aDest, aSource)
        else
          VarCastErrorOle(vType);
      end;
    end;
end;

procedure sysolevarfromvar(var aDest : OleVariant; const aSource : Variant);
begin
  DoOleVarFromVar(TVarData(aDest), TVarData(aSource));
end;

procedure sysolevarfromint(var Dest : olevariant; const Source : LongInt; const range : ShortInt);
begin
  DoVarClearIfComplex(TVarData(Dest));
  with TVarData(Dest) do begin
    vInteger := Source;
    vType := varInteger;
  end;
end;

procedure DoVarCastOle(var aDest: TVarData; const aSource: TVarData; aVarType: LongInt);
var
  Handler: TCustomVariantType;
begin
  with aSource do
  if vType = varByRef or varVariant then
    DoVarCastOle(aDest, PVarData(VPointer)^, aVarType)
  else
    if (aVarType = varString) or (aVarType = varAny) then
      VarCastError(vType, aVarType)
    else if FindCustomVariantType(vType, Handler) then
      Handler.CastTo(aDest, aSource, aVarType)
    else
      DoVarCast(aDest, aSource, aVarType);
end;

procedure sysvarcastole(var Dest : Variant; const Source : Variant; aVarType : LongInt);
begin
  DoVarCastOle(TVarData(Dest), TVarData(Source), aVarType);
end;


procedure sysdispinvoke(Dest : PVarData; const Source : TVarData;calldesc : pcalldesc;params : Pointer);cdecl;
var
  temp  : TVarData;
  tempp : ^TVarData;
  customvarianttype : TCustomVariantType;
begin
  if Source.vType=(varByRef or varVariant) then
    sysdispinvoke(Dest,PVarData(Source.vPointer)^,calldesc,params)
  else
    begin
      try
        { get a defined Result }
        if not(assigned(Dest)) then
          tempp:=nil
        else
          begin
            fillchar(temp,SizeOf(temp),0);
            tempp:=@temp;
          end;
        case Source.vType of
          varDispatch,
          varAny,
          varUnknown,
          varDispatch or varByRef,
          varAny or varByRef,
          varUnknown or varByRef:
            VarDispProc(pvariant(tempp),Variant(Source),calldesc,params);
          else
            begin
              if FindCustomVariantType(Source.vType,customvarianttype) then
                customvarianttype.DispInvoke(tempp,Source,calldesc,params)
              else
                VarInvalidOp;
            end;
        end;
      finally
        if assigned(tempp) then
          begin
            DoVarCopy(Dest^,tempp^);
            DoVarClear(temp);
          end;
      end;
    end;
end;


procedure sysvararrayredim(var a : Variant;highbound : SizeInt);
var
  src : TVarData;
  p : pvararray;
  newbounds : tvararraybound;
begin
  src:=TVarData(a);
  { get final Variant }
  while src.vType=varByRef or varVariant do
    src:=TVarData(src.vPointer^);

  if (src.vType and varArray)<>0 then
    begin
      { get Pointer to the array }
      if (src.vType and varByRef)<>0 then
        p:=pvararray(src.vPointer^)
      else
        p:=src.vArray;

{$ifopt r+}
{$define rangeon}
{$r-}
{$endif}
      if highbound<p^.Bounds[p^.dimcount-1].LowBound-1 then
        VarInvalidArgError;

      newbounds.LowBound:=p^.Bounds[p^.dimcount-1].LowBound;
{$ifdef rangon}
{$undef rangeon}
{$r+}
{$endif}
      newbounds.ElementCount:=highbound-newbounds.LowBound+1;

      VarResultCheck(SafeArrayRedim(p,newbounds));
    end
  else
    VarInvalidArgError(src.vType);
end;


function getfinalvartype(const v : TVarData) : TVarType;{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
var
  p: PVarData;
begin
  p := @v;
  while p^.vType = varByRef or varVariant do
    p := PVarData(p^.vPointer);
  Result := p^.vType;
end;


function sysvararrayget(const a : Variant;indexcount : SizeInt;indices : plongint) : Variant;cdecl;
var
  src : TVarData;
  p : pvararray;
  arraysrc : pvariant;
  arrayelementtype : TVarType;
begin
  src:=TVarData(a);
  { get final Variant }
  while src.vType=varByRef or varVariant do
    src:=TVarData(src.vPointer^);

  if (src.vType and varArray)<>0 then
    begin
      { get Pointer to the array }
      if (src.vType and varByRef)<>0 then
        p:=pvararray(src.vPointer^)
      else
        p:=src.vArray;

      { number of indices ok? }
      if p^.DimCount<>indexcount then
        VarInvalidArgError;

      arrayelementtype:=src.vType and varTypeMask;
      if arrayelementtype=varVariant then
        begin
          VarResultCheck(SafeArrayPtrOfIndex(p,PVarArrayCoorArray(indices),arraysrc));
          Result:=arraysrc^;
        end
      else
        begin
          TVarData(Result).vType:=arrayelementtype;
          VarResultCheck(SafeArrayGetElement(p,PVarArrayCoorArray(indices),@TVarData(Result).vPointer));
        end;
    end
  else
    VarInvalidArgError(src.vType);
end;


procedure sysvararrayput(var a : Variant; const value : Variant;indexcount : SizeInt;indices : plongint);cdecl;
var
  Dest : TVarData;
  p : pvararray;
  arraydest : pvariant;
  valuevtype,
  arrayelementtype : TVarType;
  tempvar : Variant;
begin
  Dest:=TVarData(a);
  { get final Variant }
  while Dest.vType=varByRef or varVariant do
    Dest:=TVarData(Dest.vPointer^);

  valuevtype:=getfinalvartype(TVarData(value));

  if not(VarTypeIsValidElementType(valuevtype)) and
    { varString isn't a valid varArray type but it is converted
      later }
    (valuevtype<>varString) then
    VarCastError(valuevtype,Dest.vType);

  if (Dest.vType and varArray)<>0 then
    begin
      { get Pointer to the array }
      if (Dest.vType and varByRef)<>0 then
        p:=pvararray(Dest.vPointer^)
      else
        p:=Dest.vArray;

      { number of indices ok? }
      if p^.DimCount<>indexcount then
        VarInvalidArgError;

      arrayelementtype:=Dest.vType and varTypeMask;
      if arrayelementtype=varVariant then
        begin
          VarResultCheck(SafeArrayPtrOfIndex(p,PVarArrayCoorArray(indices),arraydest));
          { we can't store ansistrings in Variant arrays so we convert the string to
            an olestring }
          if valuevtype=varString then
            begin
              tempvar:=VarToWideStr(value);
              arraydest^:=tempvar;
            end
          else
            arraydest^:=value;
        end
      else
        begin
          VarCast(tempvar,value,arrayelementtype);
          if arrayelementtype in [varOleStr,varDispatch,varUnknown] then
            VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),TVarData(tempvar).vPointer))
          else
            VarResultCheck(SafeArrayPutElement(p,PVarArrayCoorArray(indices),@TVarData(tempvar).vPointer));
        end;
    end
  else
    VarInvalidArgError(Dest.vType);
end;


{ import from system unit }
Procedure fpc_Write_Text_AnsiStr (Len : LongInt; Var f : Text; S : AnsiString); external name 'FPC_WRITE_TEXT_ANSISTR';


function syswritevariant(var t : text; const v : Variant;width : LongInt) : Pointer;
var
  s : AnsiString;
  variantmanager : tvariantmanager;
begin
  GetVariantManager(variantmanager);
  variantmanager.vartolstr(s,v);
  fpc_write_text_ansistr(width,t,s);
  Result:=nil; // Pointer to what should be returned?
end;


function syswrite0Variant(var t : text; const v : Variant) : Pointer;
var
  s : AnsiString;
  variantmanager : tvariantmanager;
begin
  getVariantManager(variantmanager);
  variantmanager.vartolstr(s,v);
  fpc_write_text_ansistr(-1,t,s);
  Result:=nil; // Pointer to what should be returned?
end;

Const
  SysVariantManager : TVariantManager = (
    vartoint      : @sysvartoint;
    vartoint64    : @sysvartoint64;
    vartoword64   : @sysvartoword64;
    vartobool     : @sysvartobool;
{$ifndef FPUNONE}
    vartoreal     : @sysvartoreal;
    vartotdatetime: @sysvartotdatetime;
{$endif}
    vartocurr     : @sysvartocurr;
    vartopstr     : @sysvartopstr;
    vartolstr     : @sysvartolstr;
    vartowstr     : @sysvartowstr;
    vartointf     : @sysvartointf;
    vartodisp     : @sysvartodisp;
    vartodynarray : @sysvartodynarray;
    varfrombool   : @sysvarfromBool;
    varfromint    : @sysvarfromint;
    varfromint64  : @sysvarfromint64;
    varfromword64 : @sysvarfromword64;
{$ifndef FPUNONE}
    varfromreal   : @sysvarfromreal;
    varfromtdatetime: @sysvarfromtdatetime;
{$endif}
    varfromcurr   : @sysvarfromcurr;
    varfrompstr   : @sysvarfrompstr;
    varfromlstr   : @sysvarfromlstr;
    varfromwstr   : @sysvarfromwstr;
    varfromintf   : @sysvarfromintf;
    varfromdisp   : @sysvarfromdisp;
    varfromdynarray: @sysvarfromdynarray;
    olevarfrompstr: @sysolevarfrompstr;
    olevarfromlstr: @sysolevarfromlstr;
    olevarfromvar : @sysolevarfromvar;
    olevarfromint : @sysolevarfromint;
    varop         : @SysVarOp;
    cmpop         : @syscmpop;
    varneg        : @sysvarneg;
    varnot        : @sysvarnot;
    varinit       : @sysvarinit;
    varclear      : @sysvarclear;
    varaddref     : @sysvaraddref;
    varcopy       : @sysvarcopy;
    varcast       : @sysvarcast;
    varcastole    : @sysvarcastole;
    dispinvoke    : @sysdispinvoke;
    vararrayredim : @sysvararrayredim;
    vararrayget   : @sysvararrayget;
    vararrayput   : @sysvararrayput;
    writevariant  : @syswritevariant;
    write0Variant : @syswrite0variant;
  );

Var
  PrevVariantManager : TVariantManager;

Procedure SetSysVariantManager;

begin
  GetVariantManager(PrevVariantManager);
  SetVariantManager(SysVariantManager);
end;

Procedure UnsetSysVariantManager;

begin
  SetVariantManager(PrevVariantManager);
end;


{ ---------------------------------------------------------------------
   Variant support procedures and functions
  ---------------------------------------------------------------------}


function VarType(const V: Variant): TVarType;

begin
  Result:=TVarData(V).vType;
end;


function VarTypeDeRef(const V: Variant): TVarType;
var
  p: PVarData;
begin
  p := @TVarData(V);
  Result := p^.vType and not varByRef;
  while Result = varVariant do begin
    p := p^.vPointer;
    if not Assigned(p) then
      VarBadTypeError;
    Result := p^.vType and not varByRef;
  end;
end;

function VarTypeDeRef(const V: TVarData): TVarType;
begin
  Result := VarTypeDeRef(Variant(v));
end;

function VarAsType(const V: Variant; aVarType: TVarType): Variant;

begin
  sysvarcast(Result,V,aVarType);
end;



function VarIsType(const V: Variant; aVarType: TVarType): Boolean; overload;

begin
  Result:=((TVarData(V).vType and varTypeMask)=aVarType);
end;


function VarIsType(const V: Variant; const AVarTypes: array of TVarType): Boolean; overload;

Var
  I : Integer;

begin
  I:=Low(AVarTypes);
  Result:=False;
  While Not Result and (I<=High(AVarTypes)) do
    begin
      Result:=((TVarData(V).vType and varTypeMask)=AVarTypes[I]);
      inc(i);
    end;
end;


function VarIsByRef(const V: Variant): Boolean;
begin
  Result:=(TVarData(V).vType and varByRef)<>0;
end;


function VarIsEmpty(const V: Variant): Boolean;
begin
  Result:=TVarData(V).vType=varEmpty;
end;


procedure VarCheckEmpty(const V: Variant);
begin
  If VarIsEmpty(V) Then
    VariantError(SErrVarIsEmpty);
end;


procedure VarClear(var V: Variant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
begin
  sysvarclear(v);
end;


procedure VarClear(var V: OleVariant);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
begin
  { strange casting using TVarData to avoid call of helper olevariant->Variant }
  sysvarclear(Variant(TVarData(v)));
end;


function VarIsNull(const V: Variant): Boolean;
begin
  Result:=TVarData(V).vType=varNull;
end;


function VarIsClear(const V: Variant): Boolean;

Var
  VT : TVarType;
  CustomType: TCustomVariantType;
begin
  VT:=TVarData(V).vType and varTypeMask;
  if VT<CFirstUserType then
    Result:=(VT=varEmpty) or
            (((VT=varDispatch) or (VT=varUnknown))
             and (TVarData(V).vDispatch=Nil))
   else
     Result:=FindCustomVariantType(VT,CustomType) and CustomType.IsClear(TVarData(V));
end;


function VarIsCustom(const V: Variant): Boolean;

begin
  Result:=TVarData(V).vType>=CFirstUserType;
end;


function VarIsOrdinal(const V: Variant): Boolean;
begin
  Result:=(TVarData(V).vType and varTypeMask) in OrdinalVarTypes;
end;



function VarIsFloat(const V: Variant): Boolean;

begin
  Result:=(TVarData(V).vType and varTypeMask) in FloatVarTypes;
end;


function VarIsNumeric(const V: Variant): Boolean;
begin
  Result:=(TVarData(V).vType and varTypeMask) in (OrdinalVarTypes + FloatVarTypes);
end;



function VarIsStr(const V: Variant): Boolean;

begin
  case (TVarData(V).vType and varTypeMask) of
    varOleStr,
    varString :
      Result:=True;
    else
      Result:=False;
  end;
end;


function VarToStr(const V: Variant): string;

begin
  Result:=VarToStrDef(V,'');
end;


function VarToStrDef(const V: Variant; const ADefault: string): string;

begin
  If TVarData(V).vType<>varNull then
    Result:=V
  else
    Result:=ADefault;
end;


function VarToWideStr(const V: Variant): WideString;

begin
  Result:=VarToWideStrDef(V,'');
end;


function VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;

begin
  If TVarData(V).vType<>varNull then
    Result:=V
  else
    Result:=ADefault;
end;


function VarToUnicodeStr(const V: Variant): UnicodeString;

begin
  Result:=VarToUnicodeStrDef(V,'');
end;


function VarToUnicodeStrDef(const V: Variant; const ADefault: UnicodeString): UnicodeString;

begin
  If TVarData(V).vType<>varNull then
    Result:=V
  else
    Result:=ADefault;
end;


{$ifndef FPUNONE}

function VarToDateTime(const V: Variant): TDateTime;
begin
  Result:=VariantToDate(TVarData(V));
end;


function VarFromDateTime(const DateTime: TDateTime): Variant;

begin
  SysVarClear(Result);
  with TVarData(Result) do
    begin
      vType:=varDate;
      vdate:=DateTime;
    end;
end;

{$endif}


function VarInRange(const AValue, AMin, AMax: Variant): Boolean;
begin
  Result:=(AValue>=AMin) and (AValue<=AMax);
end;


function VarEnsureRange(const AValue, AMin, AMax: Variant): Variant;
begin
  If Result>AMAx then
    Result:=AMax
  else If Result<AMin Then
    Result:=AMin
  else
    Result:=AValue;
end;


function VarSameValue(const A, B: Variant): Boolean;
  var
    v1,v2 : TVarData;
  begin
    v1:=FindVarData(a)^;
    v2:=FindVarData(b)^;
    if v1.vType in [varEmpty,varNull] then
      Result:=v1.vType=v2.vType
    else if v2.vType in [varEmpty,varNull] then
      Result:=False
    else
      Result:=A=B;
  end;


function VarCompareValue(const A, B: Variant): TVariantRelationship;
  var
    v1,v2 : TVarData;
  begin
    Result:=vrNotEqual;
    v1:=FindVarData(a)^;
    v2:=FindVarData(b)^;
    if (v1.vType in [varEmpty,varNull]) and (v1.vType=v2.vType) then
      Result:=vrEqual
    else if not(v2.vType in [varEmpty,varNull]) and
            not(v1.vType in [varEmpty,varNull]) then
      begin
        if a=b then
          Result:=vrEqual
        else if a>b then
          Result:=vrGreaterThan
        else
          Result:=vrLessThan;
      end;
  end;


function VarIsEmptyParam(const V: Variant): Boolean;
begin
  Result:=(TVarData(V).vType = varError) and
          (TVarData(V).vError=VAR_PARAMNOTFOUND);
end;


procedure SetClearVarToEmptyParam(var V: TVarData);
begin
  VariantClear(V);
  V.vType := varError;
  V.vError := VAR_PARAMNOTFOUND;
end;


function VarIsError(const V: Variant; out aResult: HRESULT): Boolean;
begin
  Result := TVarData(V).vType = varError;
  if Result then
    aResult := TVarData(v).vError;
end;


function VarIsError(const V: Variant): Boolean;
begin
  Result := TVarData(V).vType = varError;
end;


function VarAsError(AResult: HRESULT): Variant;
  begin
    TVarData(Result).vType:=varError;
    TVarData(Result).vError:=AResult;
  end;


function VarSupports(const V: Variant; const IID: TGUID; out Intf): Boolean;
begin
  case TVarData(v).vType of
    varUnknown:
      Result := Assigned(TVarData(v).vUnknown) and (IInterface(TVarData(v).vUnknown).QueryInterface(IID, Intf) = S_OK);
    varUnknown or varByRef:
      Result := Assigned(TVarData(v).vPointer) and Assigned(pointer(TVarData(v).vPointer^)) and (IInterface(TVarData(v).vPointer^).QueryInterface(IID, Intf) = S_OK);
    varDispatch:
      Result := Assigned(TVarData(v).vDispatch) and (IInterface(TVarData(v).vDispatch).QueryInterface(IID, Intf) = S_OK);
    varDispatch or varByRef:
      Result := Assigned(TVarData(v).vPointer) and Assigned(pointer(TVarData(v).vPointer^)) and (IInterface(TVarData(v).vPointer^).QueryInterface(IID, Intf) = S_OK);
    varVariant, varVariant or varByRef:
      Result := Assigned(TVarData(v).vPointer) and VarSupports(Variant(PVarData(TVarData(v).vPointer)^), IID, Intf);
    else
      Result := False;
  end;
end;


function VarSupports(const V: Variant; const IID: TGUID): Boolean;
var
  Dummy: IInterface;
begin
  Result := VarSupports(V, IID, Dummy);
end;


{ Variant copy support }
{$warnings off}
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);

begin
  NotSupported('VarCopyNoInd');
end;
{$warnings on}

{****************************************************************************
              Variant array support procedures and functions
 ****************************************************************************}

{$r-}

function VarArrayCreate(const Bounds: array of SizeInt; aVarType: TVarType): Variant;
  var
    hp : PVarArrayBoundArray;
    p : pvararray;
    i,lengthb : SizeInt;
  begin
    if not(VarTypeIsValidArrayType(aVarType)) or odd(length(Bounds)) then
      VarArrayCreateError;
    lengthb:=length(Bounds) div 2;
    try
      GetMem(hp,lengthb*SizeOf(TVarArrayBound));
      for i:=0 to lengthb-1 do
        begin
          hp^[i].LowBound:=Bounds[i*2];
          hp^[i].ElementCount:=Bounds[i*2+1]-Bounds[i*2]+1;
        end;
      SysVarClear(Result);

      p:=SafeArrayCreate(aVarType,lengthb,hp^);

      if not(assigned(p)) then
        VarArrayCreateError;

      TVarData(Result).vType:=aVarType or varArray;
      TVarData(Result).vArray:=p;
    finally
      FreeMem(hp);
    end;
  end;

{$ifndef RANGECHECKINGOFF}
{$r+}
{$endif}

function VarArrayCreate(const Bounds: PVarArrayBoundArray; Dims : SizeInt; aVarType: TVarType): Variant;
  var
    p : pvararray;
  begin
    if not(VarTypeIsValidArrayType(aVarType)) then
      VarArrayCreateError;
    SysVarClear(Result);

    p:=SafeArrayCreate(aVarType,Dims,Bounds^);

    if not(assigned(p)) then
      VarArrayCreateError;

    TVarData(Result).vType:=aVarType or varArray;
    TVarData(Result).vArray:=p;
  end;

function VarArrayOf(const Values: array of Variant): Variant;
  var
    i : SizeInt;
  begin
    Result:=VarArrayCreate([0,high(Values)],varVariant);
    for i:=0 to high(Values) do
      Result[i]:=Values[i];
  end;


function VarArrayAsPSafeArray(const A: Variant): PVarArray;
  var
    v : TVarData;
  begin
    v:=TVarData(a);
    while v.vType=varByRef or varVariant do
      v:=TVarData(v.vPointer^);

    if (v.vType and varArray)=varArray then
      begin
        if (v.vType and varByRef)<>0 then
          Result:=pvararray(v.vPointer^)
        else
          Result:=v.vArray;
      end
    else
      VarResultCheck(VAR_INVALIDARG);
  end;


function VarArrayDimCount(const A: Variant) : LongInt;
  var
    hv : TVarData;
  begin
    hv:=TVarData(a);

    { get final Variant }
    while hv.vType=varByRef or varVariant do
      hv:=TVarData(hv.vPointer^);

    if (hv.vType and varArray)<>0 then
      Result:=hv.vArray^.DimCount
    else
      Result:=0;
  end;


function VarArrayLowBound(const A: Variant; Dim: LongInt) : LongInt;
  begin
    VarResultCheck(SafeArrayGetLBound(VarArrayAsPSafeArray(A),Dim,Result));
  end;


function VarArrayHighBound(const A: Variant; Dim: LongInt) : LongInt;
  begin
    VarResultCheck(SafeArrayGetUBound(VarArrayAsPSafeArray(A),Dim,Result));
  end;


function VarArrayLock(const A: Variant): Pointer;
  begin
    VarResultCheck(SafeArrayAccessData(VarArrayAsPSafeArray(A),Result));
  end;


procedure VarArrayUnlock(const A: Variant);
  begin
    VarResultCheck(SafeArrayUnaccessData(VarArrayAsPSafeArray(A)));
  end;


function VarArrayRef(const A: Variant): Variant;
  begin
    if (TVarData(a).vType and varArray)=0 then
      VarInvalidArgError(TVarData(a).vType);
    TVarData(Result).vType:=TVarData(a).vType or varByRef;
    if (TVarData(a).vType and varByRef)=0 then
      TVarData(Result).vPointer:=@TVarData(a).vArray
    else
      TVarData(Result).vPointer:=@TVarData(a).vPointer;
  end;


function VarIsArray(const A: Variant; AResolveByRef: Boolean): Boolean;
  var
    v : TVarData;
  begin
    v:=TVarData(a);
    if AResolveByRef then
      while v.vType=varByRef or varVariant do
        v:=TVarData(v.vPointer^);

    Result:=(v.vType and varArray)=varArray;
  end;


function VarIsArray(const A: Variant): Boolean;
  begin
    VarIsArray:=VarIsArray(A,true);
  end;


function VarTypeIsValidArrayType(const aVarType: TVarType): Boolean;
  begin
    Result:=aVarType in [varSmallInt,varInteger,
{$ifndef FPUNONE}
      varSingle,varDouble,varDate,
{$endif}
      varCurrency,varOleStr,varDispatch,varError,varBoolean,
      varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord];
  end;


function VarTypeIsValidElementType(const aVarType: TVarType): Boolean;
  var
    customvarianttype : TCustomVariantType;
  begin
    Result:=((aVarType and not(varByRef) and not(varArray)) in [varEmpty,varNull,varSmallInt,varInteger,
{$ifndef FPUNONE}
      varSingle,varDouble,varDate,
{$endif}
      varCurrency,varOleStr,varDispatch,varError,varBoolean,
      varVariant,varUnknown,varShortInt,varByte,varWord,varLongWord,varInt64]) or
    FindCustomVariantType(aVarType,customvarianttype);
  end;


{ ---------------------------------------------------------------------
    Variant <-> Dynamic arrays support
  ---------------------------------------------------------------------}

function DynArrayGetVariantInfo(p : Pointer; var Dims : sizeint) : sizeint;
  begin
    Result:=varNull;
    { skip kind and name }
    inc(Pointer(p),ord(pdynarraytypeinfo(p)^.namelen)+2);

    p:=AlignToPtr(p);

    { skip elesize }
    inc(p,SizeOf(sizeint));

    { search recursive? }
    if pdynarraytypeinfo(ppointer(p)^)^.kind=21{tkDynArr} then
      Result:=DynArrayGetVariantInfo(ppointer(p)^,Dims)
    else
      begin
        { skip dynarraytypeinfo }
        inc(p,SizeOf(pdynarraytypeinfo));
        Result:=plongint(p)^;
      end;
    inc(Dims);
  end;


{$r-}

procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
  var
    i,
    Dims           : sizeint;
    vararrtype,
    dynarrvartype  : LongInt;
    vararraybounds : PVarArrayBoundArray;
    iter : TVariantArrayIterator;
    dynarriter : tdynarrayiter;
    p : Pointer;
    temp : Variant;
    dynarraybounds : tdynarraybounds;
  type
    TDynArray = array of Pointer;
  begin
    DoVarClear(TVarData(v));

    Dims:=0;
    dynarrvartype:=DynArrayGetVariantInfo(TypeInfo,Dims);

    vararrtype:=dynarrvartype;

    if (Dims>1) and not(DynamicArrayIsRectangular(DynArray,TypeInfo)) then
      exit;

    { retrieve Bounds array }
    Setlength(dynarraybounds,Dims);
    GetMem(vararraybounds,Dims*SizeOf(TVarArrayBound));
    try
      p:=DynArray;
      for i:=0 to Dims-1 do
        begin
          vararraybounds^[i].LowBound:=0;
          vararraybounds^[i].ElementCount:=length(TDynArray(p));
          dynarraybounds[i]:=length(TDynArray(p));
          if dynarraybounds[i]>0 then
            { we checked that the array is rectangular }
            p:=TDynArray(p)[0];
        end;
      { .. create Variant array }
      V:=VarArrayCreate(vararraybounds,Dims,vararrtype);

      VarArrayLock(V);
      try
        iter.init(Dims,PVarArrayBoundArray(vararraybounds));
        dynarriter.init(DynArray,TypeInfo,Dims,dynarraybounds);
        if not iter.AtEnd then
        repeat
          case vararrtype of
            varSmallInt:
              temp:=PSmallInt(dynarriter.data)^;
            varInteger:
              temp:=PInteger(dynarriter.data)^;
{$ifndef FPUNONE}
            varSingle:
              temp:=PSingle(dynarriter.data)^;
            varDouble:
              temp:=PDouble(dynarriter.data)^;
            varDate:
              temp:=PDouble(dynarriter.data)^;
{$endif}
            varCurrency:
              temp:=PCurrency(dynarriter.data)^;
            varOleStr:
              temp:=PWideString(dynarriter.data)^;
            varDispatch:
              temp:=PDispatch(dynarriter.data)^;
            varError:
              temp:=PError(dynarriter.data)^;
            varBoolean:
              temp:=PBoolean(dynarriter.data)^;
            varVariant:
              temp:=PVariant(dynarriter.data)^;
            varUnknown:
              temp:=PUnknown(dynarriter.data)^;
            varShortInt:
              temp:=PShortInt(dynarriter.data)^;
            varByte:
              temp:=PByte(dynarriter.data)^;
            varWord:
              temp:=PWord(dynarriter.data)^;
            varLongWord:
              temp:=PLongWord(dynarriter.data)^;
            varInt64:
              temp:=PInt64(dynarriter.data)^;
            varQWord:
              temp:=PQWord(dynarriter.data)^;
            else
              VarClear(temp);
          end;
          dynarriter.next;
          VarArrayPut(V,temp,Slice(iter.Coords^,Dims));
        until not(iter.next);
      finally
        iter.done;
        dynarriter.done;
        VarArrayUnlock(V);
      end;
    finally
      FreeMem(vararraybounds);
    end;
  end;


procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
  var
    DynArrayDims,
    VarArrayDims : SizeInt;
    iter : TVariantArrayIterator;
    dynarriter : tdynarrayiter;
    temp : Variant;
    dynarrvartype : LongInt;
    vararraybounds : PVarArrayBoundArray;
    dynarraybounds : tdynarraybounds;
    i : SizeInt;
  type
    TDynArray = array of Pointer;
  begin
    VarArrayDims:=VarArrayDimCount(V);

    DynArrayDims:=0;
    dynarrvartype:=DynArrayGetVariantInfo(TypeInfo,DynArrayDims);

    if (VarArrayDims=0) or (VarArrayDims<>DynArrayDims) then
      VarResultCheck(VAR_INVALIDARG);

    { retrieve Bounds array }
    Setlength(dynarraybounds,VarArrayDims);
    GetMem(vararraybounds,VarArrayDims*SizeOf(TVarArrayBound));
    try
      for i:=0 to VarArrayDims-1 do
        begin
          vararraybounds^[i].LowBound:=VarArrayLowBound(V,i+1);
          vararraybounds^[i].ElementCount:=VarArrayHighBound(V,i+1)-vararraybounds^[i].LowBound+1;
          dynarraybounds[i]:=vararraybounds^[i].ElementCount;
        end;
      DynArraySetLength(DynArray,TypeInfo,VarArrayDims,PSizeInt(dynarraybounds));
      VarArrayLock(V);
      try
        iter.init(VarArrayDims,PVarArrayBoundArray(vararraybounds));
        dynarriter.init(DynArray,TypeInfo,VarArrayDims,dynarraybounds);
        if not iter.AtEnd then
        repeat
          temp:=VarArrayGet(V,Slice(iter.Coords^,VarArrayDims));
          case dynarrvartype of
            varSmallInt:
              PSmallInt(dynarriter.data)^:=temp;
            varInteger:
              PInteger(dynarriter.data)^:=temp;
{$ifndef FPUNONE}
            varSingle:
              PSingle(dynarriter.data)^:=temp;
            varDouble:
              PDouble(dynarriter.data)^:=temp;
            varDate:
              PDouble(dynarriter.data)^:=temp;
{$endif}
            varCurrency:
              PCurrency(dynarriter.data)^:=temp;
            varOleStr:
              PWideString(dynarriter.data)^:=temp;
            varDispatch:
              PDispatch(dynarriter.data)^:=temp;
            varError:
              PError(dynarriter.data)^:=temp;
            varBoolean:
              PBoolean(dynarriter.data)^:=temp;
            varVariant:
              PVariant(dynarriter.data)^:=temp;
            varUnknown:
              PUnknown(dynarriter.data)^:=temp;
            varShortInt:
              PShortInt(dynarriter.data)^:=temp;
            varByte:
              PByte(dynarriter.data)^:=temp;
            varWord:
              PWord(dynarriter.data)^:=temp;
            varLongWord:
              PLongWord(dynarriter.data)^:=temp;
            varInt64:
              PInt64(dynarriter.data)^:=temp;
            varQWord:
              PQWord(dynarriter.data)^:=temp;
            else
              VarCastError;
          end;
          dynarriter.next;
        until not(iter.next);
      finally
        iter.done;
        dynarriter.done;
        VarArrayUnlock(V);
      end;
    finally
      FreeMem(vararraybounds);
    end;
  end;
{$ifndef RANGECHECKINGOFF}
{$r+}
{$endif}


function FindCustomVariantType(const aVarType: TVarType; out CustomVariantType: TCustomVariantType): Boolean; overload;
  begin
    Result:=(aVarType>=CMinVarType);
    if Result then
      begin
        EnterCriticalSection(customvarianttypelock);
        try
          Result:=(aVarType-CMinVarType)<=high(customvarianttypes);
          if Result then
            begin
              CustomVariantType:=customvarianttypes[aVarType-CMinVarType];
              Result:=assigned(CustomVariantType) and
               (CustomVariantType<>InvalidCustomVariantType);
            end;
        finally
          LeaveCriticalSection(customvarianttypelock);
        end;
      end;
  end;


function FindCustomVariantType(const TypeName: string;  out CustomVariantType: TCustomVariantType): Boolean; overload;
  var
    i: Integer;
    tmp: TCustomVariantType;
    ShortTypeName: shortstring;
  begin
    ShortTypeName:=TypeName;  // avoid conversion in the loop
    result:=False;
    EnterCriticalSection(customvarianttypelock);
    try
      for i:=low(customvarianttypes) to high(customvarianttypes) do
        begin
          tmp:=customvarianttypes[i];
          result:=Assigned(tmp) and (tmp<>InvalidCustomVariantType) and
            tmp.ClassNameIs(ShortTypeName);
          if result then
            begin
              CustomVariantType:=tmp;
              Exit;
            end;
        end;
    finally
      LeaveCriticalSection(customvarianttypelock);
    end;
  end;

function Unassigned: Variant; // Unassigned standard constant
begin
  SysVarClear(Result);
  TVarData(Result).vType := varEmpty;
end;


function Null: Variant;       // Null standard constant
  begin
    SysVarClear(Result);
    TVarData(Result).vType := varNull;
  end;

procedure VarDispInvokeError;
  begin
    raise EVariantDispatchError.Create(SDispatchError);
  end;

{ ---------------------------------------------------------------------
    TCustomVariantType Class.
  ---------------------------------------------------------------------}

{ All TCustomVariantType descendants are singletons, they ignore automatic refcounting. }
function TCustomVariantType.QueryInterface(const IID: TGUID; out Obj): HResult;  stdcall;
  begin
    if GetInterface(IID, obj) then
      result := S_OK
    else
      result := E_NOINTERFACE;
  end;


function TCustomVariantType._AddRef: Integer; stdcall;
  begin
    result := -1;
  end;


function TCustomVariantType._Release: Integer; stdcall;
  begin
    result := -1;
  end;

{$warnings off}
procedure TCustomVariantType.SimplisticClear(var V: TVarData);
  begin
    NotSupported('TCustomVariantType.SimplisticClear');
  end;


procedure TCustomVariantType.SimplisticCopy(var Dest: TVarData; const Source: TVarData;  const Indirect: Boolean = False);
begin
  NotSupported('TCustomVariantType.SimplisticCopy');
end;


procedure TCustomVariantType.RaiseInvalidOp;
begin
  VarInvalidOp;
end;


procedure TCustomVariantType.RaiseCastError;
begin
  VarCastError;
end;


procedure TCustomVariantType.RaiseDispError;
begin
  VarDispInvokeError;
end;



function TCustomVariantType.LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean;

begin
  NotSupported('TCustomVariantType.LeftPromotion');
end;


function TCustomVariantType.RightPromotion(const V: TVarData; const Operation: TVarOp;  out RequiredVarType: TVarType): Boolean;

begin
  NotSupported('TCustomVariantType.RightPromotion');
end;


function TCustomVariantType.OlePromotion(const V: TVarData;  out RequiredVarType: TVarType): Boolean;

begin
  NotSupported('TCustomVariantType.OlePromotion');
end;


procedure TCustomVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);

begin
  RaiseDispError;
end;



procedure TCustomVariantType.VarDataInit(var Dest: TVarData);

begin
  FillChar(Dest,SizeOf(Dest),0);
end;


procedure TCustomVariantType.VarDataClear(var Dest: TVarData);

begin
  VarClearProc(Dest);
end;



procedure TCustomVariantType.VarDataCopy(var Dest: TVarData; const Source: TVarData);

begin
  DoVarCopy(Dest,Source)
end;


procedure TCustomVariantType.VarDataCopyNoInd(var Dest: TVarData; const Source: TVarData);

begin
  // This is probably not correct, but there is no DoVarCopyInd
  DoVarCopy(Dest,Source);
end;



procedure TCustomVariantType.VarDataCast(var Dest: TVarData; const Source: TVarData);

begin
  DoVarCast(Dest, Source, VarType);
end;


procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);

begin
  DoVarCast(Dest, Source, AVarType);
end;


procedure TCustomVariantType.VarDataCastTo(var Dest: TVarData; const aVarType: TVarType);

begin
  DoVarCast(Dest,Dest,AVarType);
end;


procedure TCustomVariantType.VarDataCastToOleStr(var Dest: TVarData);

begin
  VarDataCastTo(Dest, Dest, varOleStr);
end;



procedure TCustomVariantType.VarDataFromStr(var V: TVarData; const Value: string);

begin
  sysvarfromlstr(Variant(V),Value);
end;


procedure TCustomVariantType.VarDataFromOleStr(var V: TVarData; const Value: WideString);

begin
  sysvarfromwstr(variant(V),Value);
end;


function TCustomVariantType.VarDataToStr(const V: TVarData): string;

begin
  sysvartolstr(Result,Variant(V));
end;



function TCustomVariantType.VarDataIsEmptyParam(const V: TVarData): Boolean;

begin
  VarIsEmptyParam(Variant(V));
end;


function TCustomVariantType.VarDataIsByRef(const V: TVarData): Boolean;

begin
  Result:=(V.vType and varByRef)=varByRef;
end;


function TCustomVariantType.VarDataIsArray(const V: TVarData): Boolean;

begin
  Result:=(V.vType and varArray)=varArray;
end;



function TCustomVariantType.VarDataIsOrdinal(const V: TVarData): Boolean;

begin
  Result:=(V.vType and varTypeMask) in OrdinalVarTypes;
end;


function TCustomVariantType.VarDataIsFloat(const V: TVarData): Boolean;

begin
  Result:=(V.vType and varTypeMask) in FloatVarTypes;
end;


function TCustomVariantType.VarDataIsNumeric(const V: TVarData): Boolean;

begin
  Result:=(V.vType and varTypeMask) in (OrdinalVarTypes + FloatVarTypes);
end;


function TCustomVariantType.VarDataIsStr(const V: TVarData): Boolean;

begin
   Result:=
     ((V.vType and varTypeMask) = varOleStr) or
     ((V.vType and varTypeMask) = varString);
end;


procedure RegisterCustomVariantType(obj: TCustomVariantType; RequestedVarType: TVarType;
  UseFirstAvailable: Boolean);
var
  index,L: Integer;
begin
  EnterCriticalSection(customvarianttypelock);
  try
    L:=Length(customvarianttypes);
    if UseFirstAvailable then
    begin
      repeat
        inc(customvariantcurrtype);
        if customvariantcurrtype>=CMaxVarType then
          raise EVariantError.Create(SVarTypeTooManyCustom);
      until ((customvariantcurrtype-CMinVarType)>=L) or
        (customvarianttypes[customvariantcurrtype-CMinVarType]=nil);
      RequestedVarType:=customvariantcurrtype;
    end
    else if (RequestedVarType<CFirstUserType) or (RequestedVarType>CMaxVarType) then
      raise EVariantError.CreateFmt(SVarTypeOutOfRangeWithPrefix, ['$', RequestedVarType]);

    index:=RequestedVarType-CMinVarType;
    if index>=L then
      SetLength(customvarianttypes,L+1);
    if Assigned(customvarianttypes[index]) then
    begin
      if customvarianttypes[index]=InvalidCustomVariantType then
        raise EVariantError.CreateFmt(SVarTypeNotUsableWithPrefix, ['$', RequestedVarType])
      else
        raise EVariantError.CreateFmt(SVarTypeAlreadyUsedWithPrefix,
          ['$', RequestedVarType, customvarianttypes[index].ClassName]);
    end;
    customvarianttypes[index]:=obj;
    obj.FVarType:=RequestedVarType;
  finally
    LeaveCriticalSection(customvarianttypelock);
  end;
end;

constructor TCustomVariantType.Create;
begin
  RegisterCustomVariantType(Self,0,True);
end;

constructor TCustomVariantType.Create(RequestedVarType: TVarType);
begin
  RegisterCustomVariantType(Self,RequestedVarType,False);
end;


destructor TCustomVariantType.Destroy;
begin
  EnterCriticalSection(customvarianttypelock);
  try
    if FVarType<>0 then
      customvarianttypes[FVarType-CMinVarType]:=InvalidCustomVariantType;
  finally
    LeaveCriticalSection(customvarianttypelock);
  end;
  inherited Destroy;
end;



function TCustomVariantType.IsClear(const V: TVarData): Boolean;
begin
  result:=False;
end;


procedure TCustomVariantType.Cast(var Dest: TVarData; const Source: TVarData);

begin
  DoVarCast(Dest,Source,VarType);
end;


procedure TCustomVariantType.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);

begin
  DoVarCast(Dest,Source,AVarType);
end;


procedure TCustomVariantType.CastToOle(var Dest: TVarData; const Source: TVarData);

begin
  NotSupported('TCustomVariantType.CastToOle');
end;



procedure TCustomVariantType.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp);

begin
  NotSupported('TCustomVariantType.BinaryOp');
end;


procedure TCustomVariantType.UnaryOp(var Right: TVarData; const Operation: TVarOp);

begin
  NotSupported('TCustomVariantType.UnaryOp');
end;


function TCustomVariantType.CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean;

begin
  NotSupported('TCustomVariantType.CompareOp');
end;


procedure TCustomVariantType.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);

begin
  NotSupported('TCustomVariantType.Compare');
end;
{$warnings on}

{ ---------------------------------------------------------------------
    TInvokeableVariantType implementation
  ---------------------------------------------------------------------}

procedure TInvokeableVariantType.DispInvoke(Dest: PVarData; const Source: TVarData; CallDesc: PCallDesc; Params: Pointer);

begin
  NotSupported('TInvokeableVariantType.DispInvoke');
end;

function TInvokeableVariantType.DoFunction(var Dest: TVarData; const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;

begin
  result := False;
end;

function TInvokeableVariantType.DoProcedure(const V: TVarData; const Name: string; const Arguments: TVarDataArray): Boolean;
begin
  result := False
end;


function TInvokeableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
  begin
    result := False;
  end;


function TInvokeableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
  begin
    result := False;
  end;


{ ---------------------------------------------------------------------
    TPublishableVariantType implementation
  ---------------------------------------------------------------------}

function TPublishableVariantType.GetProperty(var Dest: TVarData; const V: TVarData; const Name: string): Boolean;
  begin
    Result:=true;
    Variant(Dest):=GetPropValue(getinstance(v),name);
  end;


function TPublishableVariantType.SetProperty(const V: TVarData; const Name: string; const Value: TVarData): Boolean;
  begin
    Result:=true;
    SetPropValue(getinstance(v),name,Variant(value));
  end;


procedure VarCastError;
  begin
    raise EVariantTypeCastError.Create(SInvalidVarCast);
  end;


procedure VarCastError(const ASourceType, ADestType: TVarType);
  begin
    raise EVariantTypeCastError.CreateFmt(SVarTypeCouldNotConvert,
      [VarTypeAsText(ASourceType),VarTypeAsText(ADestType)]);
  end;


procedure VarCastErrorOle(const ASourceType: TVarType);
  begin
    raise EVariantTypeCastError.CreateFmt(SVarTypeCouldNotConvert,
      [VarTypeAsText(ASourceType),'(OleVariant)']);
  end;


procedure VarInvalidOp;
  begin
    raise EVariantInvalidOpError.Create(SInvalidVarOp);
  end;

procedure VarInvalidOp(const aLeft, aRight: TVarType; aOpCode: TVarOp);
  begin
    raise EVariantInvalidOpError.CreateFmt(SInvalidBinaryVarOp,
      [VarTypeAsText(aLeft),VarOpAsText[aOpCode],VarTypeAsText(aRight)]);
  end;


procedure VarInvalidOp(const aRight: TVarType; aOpCode: TVarOp);
  begin
    raise EVariantInvalidOpError.CreateFmt(SInvalidUnaryVarOp,
      [VarOpAsText[aOpCode],VarTypeAsText(aRight)]);
  end;


procedure VarInvalidNullOp;
  begin
    raise EVariantInvalidOpError.Create(SInvalidvarNullOp);
  end;


procedure VarParamNotFoundError;
  begin
    raise EVariantParamNotFoundError.Create(SVarParamNotFound);
  end;


procedure VarBadTypeError;
  begin
    raise EVariantBadVarTypeError.Create(SVarBadType);
  end;


procedure VarOverflowError;
  begin
    raise EVariantOverflowError.Create(SVarOverflow);
  end;


procedure VarOverflowError(const ASourceType, ADestType: TVarType);
  begin
    raise EVariantOverflowError.CreateFmt(SVarTypeConvertOverflow,
      [VarTypeAsText(ASourceType),VarTypeAsText(ADestType)]);
  end;


procedure VarRangeCheckError(const AType: TVarType);
  begin
    raise EVariantOverflowError.CreateFmt(SVarTypeRangeCheck1,
      [VarTypeAsText(AType)])
  end;


procedure VarRangeCheckError(const ASourceType, ADestType: TVarType);
  begin
    if ASourceType<>ADestType then
      raise EVariantOverflowError.CreateFmt(SVarTypeRangeCheck2,
        [VarTypeAsText(ASourceType),VarTypeAsText(ADestType)])
    else
      VarRangeCheckError(ASourceType);
  end;


procedure VarBadIndexError;
  begin
    raise EVariantBadIndexError.Create(SVarArrayBounds);
  end;


procedure VarArrayLockedError;
  begin
    raise EVariantArrayLockedError.Create(SVarArrayLocked);
  end;


procedure VarNotImplError;
  begin
    raise EVariantNotImplError.Create(SVarNotImplemented);
  end;


procedure VarOutOfMemoryError;
  begin
    raise EVariantOutOfMemoryError.Create(SOutOfMemory);
  end;


procedure VarInvalidArgError;
  begin
    raise EVariantInvalidArgError.Create(SVarInvalid);
  end;


procedure VarInvalidArgError(AType: TVarType);
  begin
    raise EVariantInvalidArgError.CreateFmt(SVarInvalid1,
      [VarTypeAsText(AType)])
  end;


procedure VarUnexpectedError;
  begin
    raise EVariantUnexpectedError.Create(SVarUnexpected);
  end;


procedure VarArrayCreateError;
  begin
    raise EVariantArrayCreateError.Create(SVarArrayCreate);
  end;


procedure RaiseVarException(res : HRESULT);
  begin
    case res of
      VAR_PARAMNOTFOUND:
        VarParamNotFoundError;
      VAR_TYPEMISMATCH:
        VarCastError;
      VAR_BADVARTYPE:
        VarBadTypeError;
      VAR_EXCEPTION:
        VarInvalidOp;
      VAR_OVERFLOW:
        VarOverflowError;
      VAR_BADINDEX:
        VarBadIndexError;
      VAR_ARRAYISLOCKED:
        VarArrayLockedError;
      VAR_NOTIMPL:
        VarNotImplError;
      VAR_OUTOFMEMORY:
        VarOutOfMemoryError;
      VAR_INVALIDARG:
        VarInvalidArgError;
      VAR_UNEXPECTED:
        VarUnexpectedError;
      else
        raise EVariantError.CreateFmt(SInvalidVarOpWithHResultWithPrefix,
          ['$',res,'']);
    end;
  end;


procedure VarResultCheck(AResult: HRESULT);{$IFDEF VARIANTINLINE}inline;{$ENDIF VARIANTINLINE}
  begin
    if AResult<>VAR_OK then
      RaiseVarException(AResult);
  end;


procedure VarResultCheck(AResult: HRESULT; ASourceType, ADestType: TVarType);
  begin
    case AResult of
      VAR_OK:
        ;
      VAR_OVERFLOW:
        VarOverflowError(ASourceType,ADestType);
      VAR_TYPEMISMATCH:
        VarCastError(ASourceType,ADestType);
    else
      RaiseVarException(AResult);
    end;
  end;


procedure HandleConversionException(const ASourceType, ADestType: TVarType);
  begin
    if exceptobject is econverterror then
      VarCastError(asourcetype,adesttype)
    else if (exceptobject is eoverflow) or
      (exceptobject is erangeerror) then
      varoverflowerror(asourcetype,adesttype)
    else
      raise exception(acquireexceptionobject);
  end;


function VarTypeAsText(const AType: TVarType): string;
  var
    customvarianttype : TCustomVariantType;
  const
    names : array[varEmpty..varQWord] of string[8] = (
    'Empty','Null','Smallint','Integer','Single','Double','Currency','Date','OleStr','Dispatch','Error','Boolean','Variant',
    'Unknown','Decimal','???','ShortInt','Byte','Word','DWord','Int64','QWord');
  begin
    if ((AType and varTypeMask)>=low(names)) and ((AType and varTypeMask)<=high(names)) then
      Result:=names[AType and varTypeMask]
    else
      case AType and varTypeMask of
        varString:
          Result:='String';
        varAny:
          Result:='Any';
        else
          begin
            if FindCustomVariantType(AType and varTypeMask,customvarianttype) then
              Result:=customvarianttype.classname
            else
              Result:='$'+IntToHex(AType and varTypeMask,4)
          end;
      end;
    if (AType and vararray)<>0 then
      Result:='Array of '+Result;
    if (AType and varByRef)<>0 then
      Result:='Ref to '+Result;
  end;


function FindVarData(const V: Variant): PVarData;
  begin
    Result:=PVarData(@V);
    while Result^.vType=varVariant or varByRef do
      Result:=PVarData(Result^.vPointer);
  end;

{ ---------------------------------------------------------------------
    Variant properties from typinfo
  ---------------------------------------------------------------------}

function GetVariantProp(Instance : TObject;PropInfo : PPropInfo) : Variant;
type
  TGetVariantProc = function:Variant of object;
  TGetVariantProcIndex = function(Index: integer): Variant of object;
var
  AMethod : TMethod;
begin
  Result:=Null;
  case PropInfo^.PropProcs and 3 of
    ptField:
      Result:=PVariant(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
    ptStatic,
    ptVirtual:
      begin
        if (PropInfo^.PropProcs and 3)=ptStatic then
          AMethod.Code:=PropInfo^.GetProc
        else
          AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
        AMethod.Data:=Instance;

        if ((PropInfo^.PropProcs shr 6) and 1)=0 then
          Result:=TGetVariantProc(AMethod)()
        else
          Result:=TGetVariantProcIndex(AMethod)(PropInfo^.Index);
      end;
  end;
end;


Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; const Value : Variant);
type
  TSetVariantProc = procedure(const AValue: Variant) of object;
  TSetVariantProcIndex = procedure(Index: integer; AValue: Variant) of object;
Var
  AMethod : TMethod;
begin
  case (PropInfo^.PropProcs shr 2) and 3 of
    ptfield:
      PVariant(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;	
    ptVirtual,ptStatic:
      begin
        if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
          AMethod.Code:=PropInfo^.SetProc
        else
          AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
        AMethod.Data:=Instance;

	      if ((PropInfo^.PropProcs shr 6) and 1)=0 then
          TSetVariantProc(AMethod)(Value)
        else
          TSetVariantProcIndex(AMethod)(PropInfo^.Index,Value);
      end;
  end;
end;


Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
begin
  Result:=GetVariantProp(Instance,FindPropInfo(Instance,PropName));
end;


Procedure SetVariantProp(Instance: TObject; const PropName: string;  const Value: Variant);
begin
  SetVariantprop(instance,FindpropInfo(Instance,PropName),Value);
end;

{ ---------------------------------------------------------------------
  All properties through Variant.
  ---------------------------------------------------------------------}

Function GetPropValue(Instance: TObject; const PropName: string): Variant;
begin
  Result:=GetPropValue(Instance,PropName,True);
end;


Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;

var
  PropInfo: PPropInfo;

begin
  // find the property
  PropInfo := GetPropInfo(Instance, PropName);
  if PropInfo = nil then
    raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName])
 else
   begin
   Result := Null; //at worst
   // call the Right GetxxxProp
   case PropInfo^.PropType^.Kind of
     tkInteger, tkChar, tkWChar, tkClass, tkBool:
        Result := GetOrdProp(Instance, PropInfo);
     tkEnumeration:
       if PreferStrings then
         Result := GetEnumProp(Instance, PropInfo)
       else
         Result := GetOrdProp(Instance, PropInfo);
     tkSet:
       if PreferStrings then
         Result := GetSetProp(Instance, PropInfo, False)
       else
         Result := GetOrdProp(Instance, PropInfo);
{$ifndef FPUNONE}
     tkFloat:
       Result := GetFloatProp(Instance, PropInfo);
{$endif}
     tkMethod:
       Result := PropInfo^.PropType^.Name;
     tkString, tkLString, tkAString:
       Result := GetStrProp(Instance, PropInfo);
     tkWString:
       Result := GetWideStrProp(Instance, PropInfo);
     tkUString:
       Result := GetUnicodeStrProp(Instance, PropInfo);
     tkVariant:
       Result := GetVariantProp(Instance, PropInfo);
     tkInt64:
       Result := GetInt64Prop(Instance, PropInfo);
     tkQWord:
       Result := QWord(GetInt64Prop(Instance, PropInfo));
   else
     raise EPropertyConvertError.CreateFmt('Invalid Property Type: %s',[PropInfo^.PropType^.Name]);
   end;
   end;
end;

Procedure SetPropValue(Instance: TObject; const PropName: string;  const Value: Variant);

var
 PropInfo: PPropInfo;
 TypeData: PTypeData;
 O: Integer;
 I64: Int64;
 Qw: QWord;
 S: String;
 B: Boolean;

begin
   // find the property
   PropInfo := GetPropInfo(Instance, PropName);
   if PropInfo = nil then
     raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName])
   else
     begin
     TypeData := GetTypeData(PropInfo^.PropType);
     // call Right SetxxxProp
     case PropInfo^.PropType^.Kind of
       tkBool:
         begin
         { to support the strings 'true' and 'false' }
         if (VarType(Value)=varOleStr) or
            (VarType(Value)=varString) or
            (VarType(Value)=varBoolean) then
           begin
             B:=Value;
             SetOrdProp(Instance, PropInfo, ord(B));
           end
         else
           begin
             I64:=Value;
             if (I64<TypeData^.MinValue) or (I64>TypeData^.MaxValue) then
               raise ERangeError.Create(SRangeError);
             SetOrdProp(Instance, PropInfo, I64);
           end;
         end;
       tkInteger, tkChar, tkWChar:
         begin
         I64:=Value;
         if (TypeData^.OrdType=otULong) then
           if (I64<LongWord(TypeData^.MinValue)) or (I64>LongWord(TypeData^.MaxValue)) then
             raise ERangeError.Create(SRangeError)
           else
         else
         if (I64<TypeData^.MinValue) or (I64>TypeData^.MaxValue) then
           raise ERangeError.Create(SRangeError);
         SetOrdProp(Instance, PropInfo, I64);
         end;
       tkEnumeration :
         begin
         if (VarType(Value)=varOleStr) or (VarType(Value)=varString) then
           begin
           S:=Value;
           SetEnumProp(Instance,PropInfo,S);
           end
         else
           begin
           I64:=Value;
           if (I64<TypeData^.MinValue) or (I64>TypeData^.MaxValue) then
             raise ERangeError.Create(SRangeError);
           SetOrdProp(Instance, PropInfo, I64);
           end;
         end;
       tkSet :
         begin
         if (VarType(Value)=varOleStr) or (VarType(Value)=varString) then
           begin
           S:=Value;
           SetSetProp(Instance,PropInfo,S);
           end
         else
           begin
           O:=Value;
           SetOrdProp(Instance, PropInfo, O);
           end;
         end;
{$ifndef FPUNONE}
       tkFloat:
         SetFloatProp(Instance, PropInfo, Value);
{$endif}
       tkString, tkLString, tkAString:
         SetStrProp(Instance, PropInfo, VarToStr(Value));
       tkWString:
         SetWideStrProp(Instance, PropInfo, VarToWideStr(Value));
       tkUString:
         SetUnicodeStrProp(Instance, PropInfo, VarToUnicodeStr(Value));
       tkVariant:
         SetVariantProp(Instance, PropInfo, Value);
       tkInt64:
         begin
           I64:=Value;
           if (I64<TypeData^.MinInt64Value) or (I64>TypeData^.MaxInt64Value) then
             raise ERangeError.Create(SRangeError);
           SetInt64Prop(Instance, PropInfo, I64);
         end;
       tkQWord:
         begin
           Qw:=Value;
           if (Qw<TypeData^.MinQWordValue) or (Qw>TypeData^.MaxQWordValue) then
             raise ERangeError.Create(SRangeError);
           SetInt64Prop(Instance, PropInfo,Qw);
         end
     else
       raise EPropertyConvertError.CreateFmt('SetPropValue: Invalid Property Type %s',
                                      [PropInfo^.PropType^.Name]);
     end;
   end;
end;

var
  i : LongInt;

Initialization
  InitCriticalSection(customvarianttypelock);
  // start with one-less value, so first increment yields CFirstUserType
  customvariantcurrtype:=CFirstUserType-1;
  SetSysVariantManager;
  SetClearVarToEmptyParam(TVarData(EmptyParam));
  VarClearProc:=@DoVarClear;
  VarAddRefProc:=@DoVarAddRef;
  VarCopyProc:=@DoVarCopy;
  // Typinfo Variant support
  OnGetVariantProp:=@GetVariantprop;
  OnSetVariantProp:=@SetVariantprop;
  OnSetPropValue:=@SetPropValue;
  OnGetPropValue:=@GetPropValue;
  InvalidCustomVariantType:=TCustomVariantType(-1);
  SetLength(customvarianttypes,CFirstUserType);
Finalization
  EnterCriticalSection(customvarianttypelock);
  try
    for i:=0 to high(customvarianttypes) do
      if customvarianttypes[i]<>InvalidCustomVariantType then
        customvarianttypes[i].Free;
  finally
    LeaveCriticalSection(customvarianttypelock);
  end;
  UnSetSysVariantManager;
  DoneCriticalSection(customvarianttypelock);
end.