diff --git a/rtl/objpas/fmtbcd.pp b/rtl/objpas/fmtbcd.pp index 2cec6943a5..452578556e 100644 --- a/rtl/objpas/fmtbcd.pp +++ b/rtl/objpas/fmtbcd.pp @@ -142,7 +142,6 @@ INTERFACE USES SysUtils, -{ dateutils,} Variants; const @@ -2426,26 +2425,23 @@ writeln ( '> ', i4, ' ', bh.Singles[i4], ' ', Add ); { TBCD variant creation utils } procedure VarFmtBCDCreate ( var aDest : Variant; const aBCD : tBCD ); - begin VarClear(aDest); TVarData(aDest).Vtype:=FMTBcdFactory.Vartype; TVarData(aDest).VPointer:=TFMTBcdVarData.create(aBCD); - end; + end; function VarFmtBCDCreate : Variant; - begin VarFmtBCDCreate ( result, NullBCD ); - end; + end; function VarFmtBCDCreate ( const aValue : FmtBCDStringtype; Precision, Scale : Word ) : Variant; - begin VarFmtBCDCreate ( result, StrToBCD ( aValue ) ); - end; + end; {$ifndef FPUNONE} function VarFmtBCDCreate ( const aValue : myRealtype; @@ -2471,7 +2467,6 @@ writeln ( '> ', i4, ' ', bh.Singles[i4], ' ', Add ); function VarFmtBCD : TVartype; - begin Result:=FMTBcdFactory.VarType; end; @@ -2482,9 +2477,149 @@ writeln ( '> ', i4, ' ', bh.Singles[i4], ' ', Add ); Format : TFloatFormat; const Precision, Digits : Integer ) : FmtBCDStringtype; + var P, E: integer; + Negative: boolean; + DS, TS: char; + + procedure RoundDecimalDigits(const D: integer); + var i,j: integer; begin - not_implemented; - result:=''; + j:=P+D; + if (Length(Result) > j) and (Result[j+1] >= '5') then + for i:=j downto 1+ord(Negative) do + begin + if Result[i] = '9' then + begin + Result[i] := '0'; + if i = 1+ord(Negative) then + begin + Insert('1', Result, i); + inc(P); + inc(j); + end; + end + else if Result[i] <> DS then + begin + inc(Result[i]); + break; + end; + end; + Result := copy(Result, 1, j); + end; + + procedure AddDecimalDigits; + var n,d: integer; + begin + if Digits < 0 then d := 2 else d := Digits; + + n := d + P - Length(Result); + + if n > 0 then + Result := Result + StringOfChar('0', n) + else if n < 0 then + RoundDecimalDigits(d); + end; + + procedure AddThousandSeparators; + begin + Dec(P, 3); + While (P > 1) Do + Begin + If (Result[P - 1] <> '-') And (TS <> #0) Then + Insert(TS, Result, P); + Dec(P, 3); + End; + end; + + begin + Result := BCDToStr(BCD); + if Format = ffGeneral then Exit; + + SetDecimals(DS, TS); + + Negative := Result[1] = '-'; + P := Pos(DS, Result); + if P = 0 then + begin + P := Length(Result) + 1; + if Digits <> 0 then + Result := Result + DS; + end; + + Case Format Of + ffExponent: + Begin + E := P - 2 - ord(Negative); + + if (E = 0) and (Result[P-1] = '0') then + repeat + dec(E); + until (Length(Result) <= P-E) or (Result[P-E] <> '0'); + + if E <> 0 then + begin + System.Delete(Result, P, 1); + dec(P, E); + Insert(DS, Result, P); + end; + + RoundDecimalDigits(Precision-1); + + if E < 0 then + begin + System.Delete(Result, P+E-1, -E); + Result := Result + SysUtils.Format('E%.*d' , [Digits,E]) + end + else + Result := Result + SysUtils.Format('E+%.*d', [Digits,E]); + End; + + ffFixed: + Begin + AddDecimalDigits; + End; + + ffNumber: + Begin + AddDecimalDigits; + AddThousandSeparators; + End; + + ffCurrency: + Begin + //implementation based on FloatToStrFIntl() + if Negative then System.Delete(Result, 1, 1); + + AddDecimalDigits; + AddThousandSeparators; + + If Not Negative Then + Begin + Case CurrencyFormat Of + 0: Result := CurrencyString + Result; + 1: Result := Result + CurrencyString; + 2: Result := CurrencyString + ' ' + Result; + 3: Result := Result + ' ' + CurrencyString; + End + End + Else + Begin + Case NegCurrFormat Of + 0: Result := '(' + CurrencyString + Result + ')'; + 1: Result := '-' + CurrencyString + Result; + 2: Result := CurrencyString + '-' + Result; + 3: Result := CurrencyString + Result + '-'; + 4: Result := '(' + Result + CurrencyString + ')'; + 5: Result := '-' + Result + CurrencyString; + 6: Result := Result + '-' + CurrencyString; + 7: Result := Result + CurrencyString + '-'; + 8: Result := '-' + Result + ' ' + CurrencyString; + 9: Result := '-' + CurrencyString + ' ' + Result; + 10: Result := CurrencyString + ' ' + Result + '-'; + End; + End; + End; + End; end;