paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-29 19:20:38 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from LacaK2, implementing an initial BCDToStrF

Browse Source 
git-svn-id: trunk@17145 -
This commit is contained in:
marco 2011-03-19 13:04:00 +00:00
parent 3d3a42b911
commit 0e6e2ba589
1 changed files with 145 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

155
rtl/objpas/fmtbcd.pp
View File

@ -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;