paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 14:29:14 +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 ); __hi_bh = ( MaxFmtBCDFractionSize + 1 );
type type
tBCD_helper = Maybe_Packed record tBCD_helper = Maybe_Packed record
Prec : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif}; Prec : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif};
Plac : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif}; Plac : {$ifopt r+} 0..( __hi_bh - __lo_bh + 1 ) {$else} Integer {$endif};
FDig, FDig,
@ -866,6 +866,7 @@ IMPLEMENTATION
PROTECTED PROTECTED
function GetInstance(const v : TVarData): tObject; OVERRIDE; function GetInstance(const v : TVarData): tObject; OVERRIDE;
PUBLIC 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 BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp); override;
procedure Clear(var V: TVarData); override; procedure Clear(var V: TVarData); override;
procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); 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; 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); procedure TFMTBcdFactory.BinaryOp(var Left: TVarData; const Right: TVarData; const Operation: TVarOp);
var l, r: TBCD; var l, r: TBCD;
begin begin