paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 10:40:13 +02:00
Code Issues Packages Projects Releases Wiki Activity

* implemented LeftPromotion to fmtbcd to fix mantis 38496 but unfortunately FPC doesn't call it.

Browse Source 
git-svn-id: trunk@49413 -
This commit is contained in:
marco 2021-05-30 13:00:00 +00:00
parent 0ed69fc662
commit 9bc8f17f16
1 changed files with 12 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
packages/rtl-objpas/src/inc/fmtbcd.pp
View File

@ -815,7 +815,7 @@ INTERFACE
__hi_bh = ( MaxFmtBCDFractionSize + 1 );
type
tBCD_helper = Maybe_Packed record
tBCD_helper = Maybe_Packed record
Prec : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif};
Plac : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif};
FDig,
@ -866,6 +866,7 @@ IMPLEMENTATION
PROTECTED
function GetInstance(const v : TVarData): tObject; OVERRIDE;
PUBLIC
function LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean; override;
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;
@ -4162,6 +4163,16 @@ function TFMTBcdFactory.GetInstance(const v : TVarData): tObject;
end;
function TFMTBcdFactory.LeftPromotion(const V: TVarData; const Operation: TVarOp; out RequiredVarType: TVarType): Boolean;
// mantis 38496
begin
if v.vtype in FloatVarTypes then // floats can accept full result of a mixed float-bcd operation
RequiredVarType := v.vtype
else
RequiredVarType := VarType;
result:=true;
end;
procedure TFMTBcdFactory.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp);
var l, r: TBCD;
begin