paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-30 01:19:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

* more tcustomvariant conversion helpers from Lacak2. Mantis 16853

Browse Source 
git-svn-id: trunk@16504 -
This commit is contained in:
marco 2010-12-04 20:21:03 +00:00
parent b1f1c026f8
commit 69c89d4579
2 changed files with 141 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
rtl/inc/variants.pp
View File

@ -662,12 +662,20 @@ 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
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;

138
rtl/objpas/fmtbcd.pp
View File

@ -863,6 +863,10 @@ IMPLEMENTATION
procedure BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); override;
procedure Clear(var V: TVarData); override;
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;
function CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean; override;
procedure Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult); override;
procedure Cast(var Dest: TVarData; const Source: TVarData); override;
procedure CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
end;
TFMTBcdVarData = CLASS(TPersistent)
@ -3704,6 +3708,58 @@ writeln;
{$endif}
Function VariantToBCD(const VargSrc : TVarData) : TBCD;
begin
with VargSrc do
case vType and not varTypeMask of
0: case vType of
varEmpty : Result := 0;
varSmallInt : Result := vSmallInt;
varShortInt : Result := vShortInt;
varInteger : Result := vInteger;
varSingle : Result := vSingle;
varDouble : Result := vDouble;
varCurrency : Result := vCurrency;
varDate : Result := vDate;
varBoolean : Result := Integer(vBoolean);
varVariant : Result := VariantToBCD(PVarData(vPointer)^);
varByte : Result := vByte;
varWord : Result := vWord;
varLongWord : Result := vLongWord;
varInt64 : Result := vInt64;
varQword : Result := vQWord;
varString : Result := AnsiString(vString);
else
if vType=VarFmtBCD then
Result := TFMTBcdVarData(vPointer).BCD
else
not_implemented;
end;
varByRef: if Assigned(vPointer) then case vType and varTypeMask of
varSmallInt : Result := PSmallInt(vPointer)^;
varShortInt : Result := PShortInt(vPointer)^;
varInteger : Result := PInteger(vPointer)^;
varSingle : Result := PSingle(vPointer)^;
varDouble : Result := PDouble(vPointer)^;
varCurrency : Result := PCurrency(vPointer)^;
varDate : Result := PDate(vPointer)^;
varBoolean : Result := SmallInt(PWordBool(vPointer)^);
varVariant : Result := VariantToBCD(PVarData(vPointer)^);
varByte : Result := PByte(vPointer)^;
varWord : Result := PWord(vPointer)^;
varLongWord : Result := PLongWord(vPointer)^;
varInt64 : Result := PInt64(vPointer)^;
varQword : Result := PQWord(vPointer)^;
else { other vtype }
not_implemented;
end else { pointer is nil }
not_implemented;
else { array or something like that }
not_implemented;
end;
end;
constructor TFMTBcdVarData.create;
begin
inherited create;
@ -3723,16 +3779,65 @@ function TFMTBcdFactory.GetInstance(const v : TVarData): tObject;
procedure TFMTBcdFactory.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp);
var l, r: TBCD;
begin
l:=VariantToBCD(Left);
r:=VariantToBCD(Right);
case Operation of
opAdd:
TFMTBcdVarData(Left.VPointer).BCD:=TFMTBcdVarData(Left.VPointer).BCD+TFMTBcdVarData(Right.VPointer).BCD;
l:=l+r;
opSubtract:
TFMTBcdVarData(Left.VPointer).BCD:=TFMTBcdVarData(Left.VPointer).BCD-TFMTBcdVarData(Right.VPointer).BCD;
l:=l-r;
opMultiply:
TFMTBcdVarData(Left.VPointer).BCD:=TFMTBcdVarData(Left.VPointer).BCD*TFMTBcdVarData(Right.VPointer).BCD;
l:=l*r;
opDivide:
TFMTBcdVarData(Left.VPointer).BCD:=TFMTBcdVarData(Left.VPointer).BCD/TFMTBcdVarData(Right.VPointer).BCD;
l:=l/r;
else
RaiseInvalidOp;
end;
if Left.vType=VarType then
TFMTBcdVarData(Left.VPointer).BCD := l
else
RaiseInvalidOp;
end;
procedure TFMTBcdFactory.Compare(const Left, Right: TVarData; var Relationship: TVarCompareResult);
var l, r: TBCD;
CmpRes: integer;
begin
l:=VariantToBCD(Left);
r:=VariantToBCD(Right);
CmpRes := BCDCompare(l,r);
if CmpRes=0 then
Relationship := crEqual
else if CmpRes<0 then
Relationship := crLessThan
else
Relationship := crGreaterThan;
end;
function TFMTBcdFactory.CompareOp(const Left, Right: TVarData; const Operation: TVarOp): Boolean;
var l, r: TBCD;
begin
l:=VariantToBCD(Left);
r:=VariantToBCD(Right);
case Operation of
opCmpEq:
Result := l=r;
opCmpNe:
Result := l<>r;
opCmpLt:
Result := l<r;
opCmpLe:
Result := l<=r;
opCmpGt:
Result := l>r;
opCmpGe:
Result := l>=r;
else
RaiseInvalidOp;
end;
@ -3750,9 +3855,32 @@ procedure TFMTBcdFactory.Copy(var Dest: TVarData; const Source: TVarData; const
Dest.VPointer:=Source.VPointer
else
Dest.VPointer:=TFMTBcdVarData.Create(TFMTBcdVarData(Source.VPointer).BCD);
Dest.VType:=Vartype;
Dest.VType:=VarType;
end;
procedure TFMTBcdFactory.Cast(var Dest: TVarData; const Source: TVarData);
begin
not_implemented;
end;
procedure TFMTBcdFactory.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
var v: TVarData;
begin
if Source.vType=VarType then
begin
VarDataInit(v);
try
v.vType:=varDouble;
v.vDouble:=TFMTBcdVarData(Source.vPointer).BCD;
VarDataCastTo(Dest, v, aVarType); //now cast Double to any requested type
finally
VarDataClear(v);
end;
end
else
inherited;
end;
{$if declared ( myMinIntBCD ) }
(*
{$if sizeof ( integer ) = 2 }