* Patch from LacaK2, implementing an initial BCDToStrF

git-svn-id: trunk@17145 -

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;