administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

feat(stdlib): add Numerics.Money — currency-aware TMoney

Browse source 
TMoney is a thin value-type wrapper layering an ISO-4217 currency tag onto
an exact TDecimal amount.  The numeric core (TDecimal) stays currency- and
locale-agnostic; currency policy lives entirely in this wrapper, matching
Moneta / money-gem / rusty-money.

Design:
- Currency is an upper-cased ISO-4217 string code; the set is open (unknown
  codes are accepted at the fallback minor-unit scale of 2).
- A built-in registry gives each currency its default scale (JPY 0, USD 2,
  KWD 3, fallback 2); every TMoney is normalised to its currency's scale on
  construction and after every operation, using banker's rounding.
- Cross-currency Add/Subtract/Compare raise EMoneyMismatch (no implicit
  conversion); Equals is total (False, not raise, across currencies).
- Immutable value semantics, mirroring TDecimal.

API: free-function constructors (MoneyFromStr / MoneyFromDecimal /
MoneyFromInt / MoneyZero), record methods (Amount, CurrencyCode, IsZero,
Sign, Add, Subtract, Negate, Multiply, MultiplyInt, Compare, Equals,
AmountString, ToString), and the CurrencyScale registry function.

Tests:
- cp.test.numerics.money.pas: 22 IR/semantic tests (resolution, IR shape,
  type errors) via TUnitLoader.
- cp.test.e2e.numerics.money.pas: 24 dual-backend e2e tests
  (CompileAndRunWithRTL) covering construction + per-currency normalisation,
  banker's rounding, case-folding, arithmetic, mismatch raising,
  Compare/Equals/IsZero/Sign, the registry, and a realistic invoice flow.

Docs: language-rationale.adoc gains "Currency Amounts — TMoney Wraps
TDecimal, Currency Is a String Tag" (decision + alternatives);
future-improvements.adoc marks Numerics.Money as implemented.

Verified: FIXPOINT_OK, NATIVE_FIXPOINT_OK, NATIVE_INTERNAL_OK; full suite
green on both the QBE-built and native-built runners (3671 tests).
This commit is contained in:
Graeme Geldenhuys 2026-06-20 10:33:35 +01:00
parent 62331de986
commit 36cad37423
6 changed files with 1288 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
compiler/src/test/pascal/TestRunner.pas
View file

@ -135,6 +135,8 @@ uses
cp.test.e2e.math,
cp.test.numerics.decimal,
cp.test.e2e.numerics.decimal,
cp.test.numerics.money,
cp.test.e2e.numerics.money,
cp.test.streams,
cp.test.e2e.streams,
cp.test.e2e.dateutils,

514
compiler/src/test/pascal/cp.test.e2e.numerics.money.pas Normal file
View file

@ -0,0 +1,514 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit cp.test.e2e.numerics.money;
{ E2E tests for the Numerics.Money stdlib unit (TMoney).
These compile -> assemble -> link -> run real programs that use TMoney and
assert on stdout/exit code, on BOTH backends (CompileAndRunWithRTL runs QBE
and native and requires parity). TMoney wraps TDecimal, so these also serve
as end-to-end coverage of the nested-managed-record return + interface-param
+ record-copy paths that TDecimal exercises.
Coverage: construction + currency normalisation (per-currency scale, banker's
rounding), case-insensitive currency codes, ToString, arithmetic
(Add/Subtract/Negate/Multiply/MultiplyInt), currency-mismatch raising,
Compare/Equals, IsZero/Sign, and the CurrencyScale registry. }
interface
uses
blaise.testing, cp.test.e2e.base;
type
[Threaded]
TE2EMoneyTests = class(TE2ETestCase)
protected
procedure SetUp; override;
published
{ --- Construction + normalisation --- }
procedure TestRun_FromStr_TwoDp;
procedure TestRun_FromStr_BankersRoundsHalfToEven;
procedure TestRun_FromStr_CurrencyCodeUppercased;
procedure TestRun_FromStr_JPY_ZeroScale;
procedure TestRun_FromStr_KWD_ThreeScale;
procedure TestRun_FromStr_UnknownCurrency_DefaultScale;
procedure TestRun_FromInt;
procedure TestRun_Zero;
{ --- ToString / AmountString --- }
procedure TestRun_ToString_WithCode;
procedure TestRun_AmountString_NoCode;
{ --- Arithmetic (same currency) --- }
procedure TestRun_Add_SameCurrency;
procedure TestRun_Subtract_SameCurrency;
procedure TestRun_Negate;
procedure TestRun_MultiplyInt_Quantity;
procedure TestRun_Multiply_TaxRate_BankersRound;
{ --- Currency mismatch raises --- }
procedure TestRun_Add_MismatchRaises;
procedure TestRun_Subtract_MismatchRaises;
procedure TestRun_Compare_MismatchRaises;
{ --- Compare / Equals / IsZero / Sign --- }
procedure TestRun_Compare_OrdersByAmount;
procedure TestRun_Equals_DifferentScaleSameValue;
procedure TestRun_Equals_DifferentCurrency_False;
procedure TestRun_IsZero_And_Sign;
{ --- Registry --- }
procedure TestRun_CurrencyScale_Registry;
{ --- A small realistic flow --- }
procedure TestRun_Invoice_LineItemsAndTax;
end;
implementation
procedure TE2EMoneyTests.SetUp;
begin
inherited SetUp();
SetUpScratch('compiler/target/test-e2e-numerics-money');
end;
{ ------------------------------------------------------------------ }
{ Construction + normalisation }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_FromStr_TwoDp;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromStr('19.99', 'USD'); WriteLn(M.ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('19.99 USD', '19.99 USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_FromStr_BankersRoundsHalfToEven;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 1.005 at 2dp, banker's: ties to even -> 1.00 (not 1.01). }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromStr('1.005', 'USD'); WriteLn(M.AmountString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('1.005 -> 1.00', '1.00', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_FromStr_CurrencyCodeUppercased;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromStr('5.00', 'usd'); WriteLn(M.CurrencyCode()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('lowercase -> USD', 'USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_FromStr_JPY_ZeroScale;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ JPY has scale 0 — a fractional input rounds to a whole number. }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromStr('199.6', 'JPY'); WriteLn(M.ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('200 JPY', '200 JPY', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_FromStr_KWD_ThreeScale;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ KWD has scale 3 — banker's at the 4th digit: 1.2345 -> 1.234. }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromStr('1.2345', 'KWD'); WriteLn(M.ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('1.234 KWD', '1.234 KWD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_FromStr_UnknownCurrency_DefaultScale;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ An unknown code is accepted at the fallback scale of 2. }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromStr('3.456', 'ZZZ'); WriteLn(M.ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('3.46 ZZZ', '3.46 ZZZ', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_FromInt;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyFromInt(5, 'EUR'); WriteLn(M.ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('5.00 EUR', '5.00 EUR', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Zero;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var M: TMoney;
begin M := MoneyZero('GBP'); WriteLn(M.ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('0.00 GBP', '0.00 GBP', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ ToString / AmountString }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_ToString_WithCode;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin WriteLn(MoneyFromStr('-0.5', 'USD').ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('-0.50 USD', '-0.50 USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_AmountString_NoCode;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin WriteLn(MoneyFromStr('42', 'USD').AmountString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('42.00', '42.00', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ Arithmetic (same currency) }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_Add_SameCurrency;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var A, B, C: TMoney;
begin
A := MoneyFromStr('19.99', 'USD');
B := MoneyFromStr('0.01', 'USD');
C := A.Add(B);
WriteLn(C.ToString())
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('20.00 USD', '20.00 USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Subtract_SameCurrency;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var A, B, C: TMoney;
begin
A := MoneyFromStr('5.00', 'USD');
B := MoneyFromStr('7.25', 'USD');
C := A.Subtract(B);
WriteLn(C.ToString())
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('-2.25 USD', '-2.25 USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Negate;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin WriteLn(MoneyFromStr('3.50', 'USD').Negate().ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('-3.50 USD', '-3.50 USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_MultiplyInt_Quantity;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Unit price * quantity. }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin WriteLn(MoneyFromStr('19.99', 'USD').MultiplyInt(3).ToString()) end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('59.97 USD', '59.97 USD', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Multiply_TaxRate_BankersRound;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 19.99 * 1.08 = 21.5892 -> 21.59 at 2dp (banker's). }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money, Numerics.Decimal;
var M: TMoney;
begin
M := MoneyFromStr('19.99', 'USD').Multiply(DecFromStr('1.08'));
WriteLn(M.ToString())
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('21.59 USD', '21.59 USD', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ Currency mismatch raises }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_Add_MismatchRaises;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var A, B, C: TMoney;
begin
A := MoneyFromStr('1.00', 'USD');
B := MoneyFromStr('100', 'JPY');
try
C := A.Add(B);
WriteLn('no-raise')
except
on E: EMoneyMismatch do WriteLn('mismatch')
end
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('raises', 'mismatch', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Subtract_MismatchRaises;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var A, B, C: TMoney;
begin
A := MoneyFromStr('5.00', 'EUR');
B := MoneyFromStr('1.00', 'USD');
try
C := A.Subtract(B);
WriteLn('no-raise')
except
on E: EMoneyMismatch do WriteLn('mismatch')
end
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('raises', 'mismatch', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Compare_MismatchRaises;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var A, B: TMoney; R: Integer;
begin
A := MoneyFromStr('5.00', 'EUR');
B := MoneyFromStr('5.00', 'USD');
try
R := A.Compare(B);
WriteLn('no-raise ', R)
except
on E: EMoneyMismatch do WriteLn('mismatch')
end
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('raises', 'mismatch', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ Compare / Equals / IsZero / Sign }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_Compare_OrdersByAmount;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
var A, B: TMoney;
begin
A := MoneyFromStr('19.99', 'USD');
B := MoneyFromStr('20.00', 'USD');
WriteLn(A.Compare(B), ' ', B.Compare(A), ' ', A.Compare(A))
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('-1 1 0', '-1 1 0', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Equals_DifferentScaleSameValue;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 2 and 2.00 in the same currency are equal (value-based, like TDecimal). }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin
WriteLn(MoneyFromStr('2', 'USD').Equals(MoneyFromStr('2.00', 'USD')))
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('equal', 'True', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_Equals_DifferentCurrency_False;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Same amount, different currency -> not equal (and does NOT raise). }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin
WriteLn(MoneyFromStr('2.00', 'USD').Equals(MoneyFromStr('2.00', 'EUR')))
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('not equal', 'False', Trim(Output));
end;
procedure TE2EMoneyTests.TestRun_IsZero_And_Sign;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin
WriteLn(MoneyZero('USD').IsZero(), ' ',
MoneyFromStr('-1.00', 'USD').Sign(), ' ',
MoneyFromStr('1.00', 'USD').Sign())
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('True -1 1', 'True -1 1', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ Registry }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_CurrencyScale_Registry;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money;
begin
WriteLn(CurrencyScale('JPY'), ' ', CurrencyScale('USD'), ' ',
CurrencyScale('KWD'), ' ', CurrencyScale('zzz'))
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('0 2 3 2', '0 2 3 2', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ A small realistic flow }
{ ------------------------------------------------------------------ }
procedure TE2EMoneyTests.TestRun_Invoice_LineItemsAndTax;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 2 x 9.99 + 1 x 4.50 = 24.48; +8% tax = 26.4384 -> 26.44.
Note: each step writes a DISTINCT variable — never `M := M.Method(...)` —
because self-assigning a record-method result aliases Self (see bugs.txt). }
AssertTrue('compile+run', CompileAndRunWithRTL(
'''
program P; uses Numerics.Money, Numerics.Decimal;
var LineA, Subtotal, Total: TMoney;
begin
LineA := MoneyFromStr('9.99', 'USD').MultiplyInt(2);
Subtotal := LineA.Add(MoneyFromStr('4.50', 'USD'));
WriteLn('subtotal ', Subtotal.ToString());
Total := Subtotal.Multiply(DecFromStr('1.08'));
WriteLn('total ', Total.ToString())
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('invoice',
'subtotal 24.48 USD' + #10 + 'total 26.44 USD', Trim(Output));
end;
initialization
RegisterTest(TE2EMoneyTests);
end.

352
compiler/src/test/pascal/cp.test.numerics.money.pas Normal file
View file

@ -0,0 +1,352 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit cp.test.numerics.money;
{ IR-level tests for the Numerics.Money stdlib unit (TMoney).
These resolve Numerics.Money (and its Numerics.Decimal dependency) via
TUnitLoader, run the semantic pass, and inspect the generated QBE IR. They
cover the parser / semantic / codegen path for TMoney usage. RTL-contract and
runtime-behaviour issues are covered by cp.test.e2e.numerics.money.pas. }
interface
uses
blaise.testing, strutils,
uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe, uUnitLoader;
type
TMoneyIRTests = class(TTestCase)
private
FRTLUnitPath: string;
FStdlibUnitPath: string;
function GenIR(const ASrc: string): string;
procedure SemanticOK(const ASrc: string);
procedure AnalyseExpectError(const ASrc: string);
function IRContains(const AIR, AFragment: string): Boolean;
protected
procedure SetUp; override;
published
{ --- Semantic resolution through the unit loader --- }
procedure TestSemantic_FromStr_OK;
procedure TestSemantic_FromInt_OK;
procedure TestSemantic_FromDecimal_OK;
procedure TestSemantic_Zero_OK;
procedure TestSemantic_ToString_OK;
procedure TestSemantic_AmountString_OK;
procedure TestSemantic_CurrencyCode_ReturnsString_OK;
procedure TestSemantic_Amount_ReturnsDecimal_OK;
procedure TestSemantic_CurrencyScale_ReturnsInteger_OK;
{ --- Arithmetic / queries --- }
procedure TestSemantic_Add_ReturnsMoney_OK;
procedure TestSemantic_Subtract_ReturnsMoney_OK;
procedure TestSemantic_Negate_ReturnsMoney_OK;
procedure TestSemantic_Multiply_ReturnsMoney_OK;
procedure TestSemantic_MultiplyInt_ReturnsMoney_OK;
procedure TestSemantic_Compare_ReturnsInteger_OK;
procedure TestSemantic_Equals_ReturnsBoolean_OK;
procedure TestSemantic_IsZero_ReturnsBoolean_OK;
procedure TestSemantic_Sign_ReturnsInteger_OK;
{ --- Type errors --- }
procedure TestSemantic_FromStr_WrongArgType_Error;
procedure TestSemantic_AssignMoneyToInt_Error;
{ --- IR shape --- }
procedure TestIR_FromStr_EmitsCall;
procedure TestIR_Add_EmitsCall;
end;
implementation
procedure TMoneyIRTests.SetUp;
var
ExeDir: string;
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;
function TMoneyIRTests.GenIR(const ASrc: string): string;
var
Lexer: TLexer;
Parser: TParser;
Prog: TProgram;
Semantic: TSemanticAnalyser;
CG: TCodeGenQBE;
Loader: TUnitLoader;
Units: TObjectList;
SearchPaths: TStringList;
I: Integer;
begin
Lexer := nil; Parser := nil; Prog := nil; Semantic := nil; CG := nil;
Loader := nil; Units := nil; SearchPaths := nil;
try
Lexer := TLexer.Create(ASrc);
Parser := TParser.Create(Lexer);
Prog := Parser.Parse();
Semantic := TSemanticAnalyser.Create();
SearchPaths := TStringList.Create();
SearchPaths.Add(FRTLUnitPath);
SearchPaths.Add(FStdlibUnitPath);
Loader := TUnitLoader.Create(SearchPaths);
Units := Loader.LoadAll(Prog.UsedUnits);
for I := 0 to Units.Count - 1 do
Semantic.AnalyseUnitForExport(TUnit(Units.Items[I]));
Semantic.Analyse(Prog);
CG := TCodeGenQBE.Create();
CG.SetSymbolTable(Prog.SymbolTable);
for I := 0 to Units.Count - 1 do
CG.AppendUnit(TUnit(Units.Items[I]));
CG.AppendProgram(Prog);
Result := CG.GetOutput();
finally
CG.Free(); Semantic.Free();
Units.Free(); Loader.Free(); SearchPaths.Free();
Prog.Free(); Parser.Free(); Lexer.Free();
end;
end;
procedure TMoneyIRTests.SemanticOK(const ASrc: string);
var
Lexer: TLexer;
Parser: TParser;
Prog: TProgram;
Semantic: TSemanticAnalyser;
Loader: TUnitLoader;
Units: TObjectList;
SearchPaths: TStringList;
I: Integer;
begin
Lexer := nil; Parser := nil; Prog := nil; Semantic := nil;
Loader := nil; Units := nil; SearchPaths := nil;
try
Lexer := TLexer.Create(ASrc);
Parser := TParser.Create(Lexer);
Prog := Parser.Parse();
Semantic := TSemanticAnalyser.Create();
SearchPaths := TStringList.Create();
SearchPaths.Add(FRTLUnitPath);
SearchPaths.Add(FStdlibUnitPath);
Loader := TUnitLoader.Create(SearchPaths);
Units := Loader.LoadAll(Prog.UsedUnits);
for I := 0 to Units.Count - 1 do
Semantic.AnalyseUnitForExport(TUnit(Units.Items[I]));
Semantic.Analyse(Prog);
finally
Semantic.Free();
Units.Free(); Loader.Free(); SearchPaths.Free();
Prog.Free(); Parser.Free(); Lexer.Free();
end;
end;
procedure TMoneyIRTests.AnalyseExpectError(const ASrc: string);
begin
try
SemanticOK(ASrc);
Fail('Expected ESemanticError');
except
on E: ESemanticError do ; { expected }
end;
end;
function TMoneyIRTests.IRContains(const AIR, AFragment: string): Boolean;
begin
Result := Pos(AFragment, AIR) >= 0;
end;
{ ------------------------------------------------------------------ }
{ Semantic resolution }
{ ------------------------------------------------------------------ }
procedure TMoneyIRTests.TestSemantic_FromStr_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var M: TMoney; ' +
'begin M := MoneyFromStr(''1.50'', ''USD'') end.');
end;
procedure TMoneyIRTests.TestSemantic_FromInt_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var M: TMoney; ' +
'begin M := MoneyFromInt(5, ''USD'') end.');
end;
procedure TMoneyIRTests.TestSemantic_FromDecimal_OK;
begin
SemanticOK(
'program P; uses Numerics.Money, Numerics.Decimal; var M: TMoney; ' +
'begin M := MoneyFromDecimal(DecFromStr(''1.50''), ''USD'') end.');
end;
procedure TMoneyIRTests.TestSemantic_Zero_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var M: TMoney; ' +
'begin M := MoneyZero(''USD'') end.');
end;
procedure TMoneyIRTests.TestSemantic_ToString_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var M: TMoney; S: string; ' +
'begin M := MoneyFromInt(5, ''USD''); S := M.ToString() end.');
end;
procedure TMoneyIRTests.TestSemantic_AmountString_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var M: TMoney; S: string; ' +
'begin M := MoneyFromInt(5, ''USD''); S := M.AmountString() end.');
end;
procedure TMoneyIRTests.TestSemantic_CurrencyCode_ReturnsString_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var M: TMoney; S: string; ' +
'begin M := MoneyFromInt(5, ''USD''); S := M.CurrencyCode() end.');
end;
procedure TMoneyIRTests.TestSemantic_Amount_ReturnsDecimal_OK;
begin
SemanticOK(
'program P; uses Numerics.Money, Numerics.Decimal; var M: TMoney; D: TDecimal; ' +
'begin M := MoneyFromInt(5, ''USD''); D := M.Amount() end.');
end;
procedure TMoneyIRTests.TestSemantic_CurrencyScale_ReturnsInteger_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var I: Integer; ' +
'begin I := CurrencyScale(''KWD'') end.');
end;
{ ------------------------------------------------------------------ }
{ Arithmetic / queries }
{ ------------------------------------------------------------------ }
procedure TMoneyIRTests.TestSemantic_Add_ReturnsMoney_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A, B, C: TMoney; ' +
'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' +
'C := A.Add(B) end.');
end;
procedure TMoneyIRTests.TestSemantic_Subtract_ReturnsMoney_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A, B, C: TMoney; ' +
'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' +
'C := A.Subtract(B) end.');
end;
procedure TMoneyIRTests.TestSemantic_Negate_ReturnsMoney_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A, C: TMoney; ' +
'begin A := MoneyFromInt(1, ''USD''); C := A.Negate() end.');
end;
procedure TMoneyIRTests.TestSemantic_Multiply_ReturnsMoney_OK;
begin
SemanticOK(
'program P; uses Numerics.Money, Numerics.Decimal; var A, C: TMoney; ' +
'begin A := MoneyFromInt(1, ''USD''); C := A.Multiply(DecFromStr(''1.08'')) end.');
end;
procedure TMoneyIRTests.TestSemantic_MultiplyInt_ReturnsMoney_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A, C: TMoney; ' +
'begin A := MoneyFromInt(1, ''USD''); C := A.MultiplyInt(3) end.');
end;
procedure TMoneyIRTests.TestSemantic_Compare_ReturnsInteger_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A, B: TMoney; I: Integer; ' +
'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' +
'I := A.Compare(B) end.');
end;
procedure TMoneyIRTests.TestSemantic_Equals_ReturnsBoolean_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A, B: TMoney; X: Boolean; ' +
'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' +
'X := A.Equals(B) end.');
end;
procedure TMoneyIRTests.TestSemantic_IsZero_ReturnsBoolean_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A: TMoney; X: Boolean; ' +
'begin A := MoneyFromInt(0, ''USD''); X := A.IsZero() end.');
end;
procedure TMoneyIRTests.TestSemantic_Sign_ReturnsInteger_OK;
begin
SemanticOK(
'program P; uses Numerics.Money; var A: TMoney; I: Integer; ' +
'begin A := MoneyFromInt(1, ''USD''); I := A.Sign() end.');
end;
{ ------------------------------------------------------------------ }
{ Type errors }
{ ------------------------------------------------------------------ }
procedure TMoneyIRTests.TestSemantic_FromStr_WrongArgType_Error;
begin
{ Second argument must be a string currency code, not an integer. }
AnalyseExpectError(
'program P; uses Numerics.Money; var M: TMoney; ' +
'begin M := MoneyFromStr(''1.50'', 5) end.');
end;
procedure TMoneyIRTests.TestSemantic_AssignMoneyToInt_Error;
begin
AnalyseExpectError(
'program P; uses Numerics.Money; var M: TMoney; I: Integer; ' +
'begin M := MoneyFromInt(1, ''USD''); I := M end.');
end;
{ ------------------------------------------------------------------ }
{ IR shape }
{ ------------------------------------------------------------------ }
procedure TMoneyIRTests.TestIR_FromStr_EmitsCall;
var IR: string;
begin
IR := GenIR(
'program P; uses Numerics.Money; var M: TMoney; ' +
'begin M := MoneyFromStr(''1.50'', ''USD'') end.');
AssertTrue('emits MoneyFromStr call',
IRContains(IR, '$Numerics_Money_MoneyFromStr'));
end;
procedure TMoneyIRTests.TestIR_Add_EmitsCall;
var IR: string;
begin
IR := GenIR(
'program P; uses Numerics.Money; var A, B, C: TMoney; ' +
'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' +
'C := A.Add(B) end.');
AssertTrue('emits TMoney.Add call',
IRContains(IR, '$Numerics_Money_TMoney_Add'));
end;
initialization
RegisterTest(TMoneyIRTests);
end.

20
docs/future-improvements.adoc
View file

@ -180,20 +180,12 @@ local record variables at scope exit.
== StdLib Packages — Numeric Types
The exact-decimal type itself (`TDecimal` in `Numerics.Decimal`) is implemented;
the design decision — one `TDecimal`, no separate `Currency`/`BigDecimal` — is
recorded in `docs/language-rationale.adoc` ("Decimal Arithmetic — One `TDecimal`,
No `Currency` Primitive"). The following numeric items remain genuinely future
work.
=== `Numerics.Money` — currency-aware wrapper
A thin type layering currency onto `TDecimal`: a `TMoney` carrying an amount plus
an ISO-4217 currency tag, with mismatched-currency arithmetic raising and a
per-currency default scale (JPY 0, USD 2, KWD 3). This is the universal pattern —
Moneta (Java), the `money` gem (Ruby) and `rusty-money` (Rust) all wrap a decimal
rather than baking currency into the numeric core. Deferred so currency/locale
policy stays out of `TDecimal`.
The exact-decimal type (`TDecimal` in `Numerics.Decimal`) and the currency-aware
wrapper (`TMoney` in `Numerics.Money`) are both implemented; the design
decisions are recorded in `docs/language-rationale.adoc` ("Decimal Arithmetic —
One `TDecimal`, No `Currency` Primitive" and "Currency Amounts — `TMoney` Wraps
`TDecimal`, Currency Is a String Tag"). The following numeric items remain
genuinely future work.
=== Operator overloading for `TDecimal`

80
docs/language-rationale.adoc
View file

@ -5024,7 +5024,79 @@ rounding) need no change to the library.
where exact decimal representation is impossible and pointless. `Double` +
`Math` already serve this; `TDecimal` ships no such functions.
* *Baking currency (ISO-4217) into the numeric core.* Deferred to a future
`Numerics.Money` wrapper. Currency is a policy layer (which currencies, how to
format, per-jurisdiction rounding) that should not be frozen into the numeric
type — matching Moneta / money-gem / rusty-money, which all wrap a decimal.
* *Baking currency (ISO-4217) into the numeric core.* Deferred to the
`Numerics.Money` wrapper (see the next section). Currency is a policy layer
(which currencies, how to format, per-jurisdiction rounding) that should not be
frozen into the numeric type — matching Moneta / money-gem / rusty-money, which
all wrap a decimal.
== Currency Amounts — `TMoney` Wraps `TDecimal`, Currency Is a String Tag
=== Decision
Currency-aware monetary amounts are provided by `TMoney` (`Numerics.Money`), a
thin value-type wrapper that pairs an exact `TDecimal` amount with an ISO-4217
currency tag. The numeric core (`TDecimal`) stays currency- and locale-agnostic;
currency policy lives entirely in this wrapper. Three rules define `TMoney`:
* The currency tag is an ISO-4217 alphabetic *string* code ('USD', 'JPY',
'KWD'), upper-cased on construction. The set of currencies is open: a code the
built-in registry does not list is still accepted and uses the fallback minor-
unit scale of two.
* Each currency has a default minor-unit scale (JPY 0, USD 2, KWD 3, fallback 2).
Every `TMoney` is normalised to its currency's scale on construction and after
every arithmetic operation, using banker's rounding (`rmHalfEven`).
* Arithmetic across different currencies (`Add`, `Subtract`, `Compare`) raises
`EMoneyMismatch`. There is no implicit conversion — exchange rates are a
higher policy layer, not a property of the type. (`Equals` is the one
exception: it returns `False` for different currencies rather than raising, so
it is total and safe in containers.)
`TMoney` has immutable value semantics: every operation returns a fresh value and
never mutates `Self`, exactly as `TDecimal` does.
=== Rationale
This is the universal industry pattern. Moneta (Java), the money gem (Ruby) and
rusty-money (Rust) each wrap a decimal with a currency tag rather than baking
currency into the numeric type. Keeping currency out of `TDecimal` preserves the
"one exact-decimal type" decision (see the previous section) and keeps locale and
jurisdiction policy — formatting, which currencies exist, per-currency rounding —
in a layer that can evolve without touching the numeric core.
A *string* currency code (rather than a closed `enum`) keeps the type open: new
or non-standard codes (crypto, historical, regional) work without a library
edit, matching money gem and rusty-money. The small loss of compile-time
checking is the right trade for an inventory that changes outside the compiler's
release cycle; an unknown code degrades gracefully to the fallback scale instead
of failing to compile.
Per-currency scale normalisation with banker's rounding on every operation makes
`TMoney` behave like real money: a JPY amount never carries a fraction, a USD
amount is always two places, and ties round without the upward bias of
round-half-up. Doing it on *every* operation (not just on display) keeps stored
values canonical, so equality and hashing are well-defined.
=== Alternatives considered
* *A `TCurrency` enum instead of a string code.* Rejected. It is type-safe but
closes the currency set: every new or non-standard code would require editing
and re-releasing the library. The open string code matches the dominant money
libraries and lets unknown codes degrade to the fallback scale.
* *Preserving full `TDecimal` scale and rounding only on display.* Rejected as
the default. Lazy rounding lets non-canonical values (e.g. an un-rounded
division result) leak into stored amounts and breaks value equality between
amounts that should be equal. Normalising eagerly keeps every `TMoney` at its
currency scale.
* *Baking exchange-rate conversion into `TMoney`.* Rejected. Rates are
time-varying external data, not a property of an amount; mixing them in would
make arithmetic depend on hidden state. Cross-currency arithmetic raises
instead, leaving conversion to an explicit higher layer.
* *A fixed-point money type (Int64 scaled).* Already rejected for `TDecimal`
(see the previous section); `TMoney` inherits `TDecimal`'s compact `Int64`
fast path for the common case, so it needs no separate fixed-point design.

338
stdlib/src/main/pascal/numerics.money.pas Normal file
View file

@ -0,0 +1,338 @@
{
Blaise - An Object Pascal Compiler
Copyright (c) 2026 Graeme Geldenhuys
SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
Licensed under the Apache License v2.0 with Runtime Library Exception.
See LICENSE file in the project root for full license terms.
}
unit Numerics.Money;
{ Blaise StdLib — currency-aware monetary amounts.
TMoney is a thin VALUE-TYPE wrapper that layers an ISO-4217 currency tag onto
an exact TDecimal amount (see Numerics.Decimal). It is the money type; the
numeric core (TDecimal) stays currency- and locale-agnostic, matching the
universal pattern of Moneta (Java), the money gem (Ruby) and rusty-money
(Rust), each of which wraps a decimal rather than baking currency into the
numeric type. See docs/language-rationale.adoc.
Design:
- Currency is an ISO-4217 alphabetic code held as a string ('USD', 'JPY',
'KWD'). This is open-ended: a code the built-in registry does not know is
still accepted and uses the fallback scale (2). The code is upper-cased
on construction so 'usd' and 'USD' are the same currency.
- Each currency has a default minor-unit scale: JPY 0, USD 2, KWD 3, and a
fallback of 2 for unknown codes. Every TMoney is NORMALISED to its
currency's scale on construction and after every arithmetic operation,
using banker's rounding (rmHalfEven) — the recommended money default.
So MoneyFromStr('1.005', 'USD') stores 1.00, and a JPY amount never
carries a fraction.
- Mismatched-currency arithmetic RAISES EMoneyMismatch. Add, Subtract and
Compare across different currencies are programming errors, not silent
conversions (there is no exchange-rate concept here — that is a higher
policy layer).
- Immutable value semantics: every operation returns a fresh TMoney and
never mutates Self. Scaling by a quantity (Multiply) keeps the same
currency and re-normalises to its scale.
Construction uses free functions (MoneyFromStr / MoneyFromDecimal /
MoneyFromInt / MoneyZero), following the Numerics.Decimal and DateUtils
house style. Queries and arithmetic are record methods. }
interface
uses
SysUtils, Numerics.Decimal;
type
{ Base class for all errors raised by this unit. }
EMoneyError = class(Exception);
{ Raised when an operation combines two TMoney values of different
currencies (e.g. USD + JPY). }
EMoneyMismatch = class(EMoneyError);
{ ------------------------------------------------------------------ }
{ TMoney — a decimal amount tagged with an ISO-4217 currency }
{ ------------------------------------------------------------------ }
{ A monetary amount in a single currency. See the unit header for the
design rationale. The amount is always held at the currency's default
scale (banker's-rounded on every operation). }
TMoney = record
{ The exact amount, normalised to the currency's default scale. }
FAmount: TDecimal;
{ ISO-4217 alphabetic currency code, upper-case (e.g. 'USD'). }
FCurrency: string;
{ The amount as an exact TDecimal (at the currency scale).
@returns the monetary amount. }
function Amount: TDecimal;
{ The ISO-4217 currency code (upper-case).
@returns the currency code string. }
function CurrencyCode: string;
{ Tests whether the amount is exactly zero.
@returns True iff the amount is zero. }
function IsZero: Boolean;
{ Sign of the amount.
@returns -1 if negative, 0 if zero, +1 if positive. }
function Sign: Integer;
{ Sum of Self and B. Both must be the same currency; the result is in that
currency, normalised to its scale.
@param B the amount to add.
@returns Self + B.
@raises EMoneyMismatch if the currencies differ. }
function Add(const B: TMoney): TMoney;
{ Difference Self - B. Both must be the same currency.
@param B the amount to subtract.
@returns Self - B.
@raises EMoneyMismatch if the currencies differ. }
function Subtract(const B: TMoney): TMoney;
{ Arithmetic negation (-Self), same currency and scale.
@returns the amount with opposite sign. }
function Negate: TMoney;
{ Scales the amount by a dimensionless TDecimal factor (e.g. unit price *
quantity, or amount * tax-rate), re-normalising to the currency scale with
banker's rounding. The currency is preserved.
@param Factor the multiplier.
@returns Self * Factor at the currency scale. }
function Multiply(const Factor: TDecimal): TMoney;
{ Scales the amount by an integer quantity. Exact (no rounding needed
beyond the existing scale). The currency is preserved.
@param Quantity the integer multiplier.
@returns Self * Quantity. }
function MultiplyInt(Quantity: Integer): TMoney;
{ Three-way comparison by amount. Both must be the same currency.
@param B the amount to compare against.
@returns -1 if Self < B, 0 if equal, +1 if Self > B.
@raises EMoneyMismatch if the currencies differ. }
function Compare(const B: TMoney): Integer;
{ Value equality: same currency AND equal amount. Unlike Compare, this does
NOT raise on a currency mismatch — two amounts in different currencies are
simply not equal.
@param B the amount to compare against.
@returns True iff same currency and equal amount. }
function Equals(const B: TMoney): Boolean;
{ The bare amount as a plain decimal string at the currency scale, with no
currency code (e.g. '19.99'). Never scientific notation.
@returns the amount string. }
function AmountString: string;
{ Amount followed by a space and the currency code (e.g. '19.99 USD').
@returns the formatted monetary string. }
function ToString: string;
end;
{ ------------------------------------------------------------------ }
{ Construction (free functions, house style) }
{ ------------------------------------------------------------------ }
{ Builds a TMoney from a decimal literal string and a currency code. The
amount is parsed exactly (see DecFromStr) then normalised to the currency's
default scale with banker's rounding.
@param AAmount the decimal literal (e.g. '19.99', '-0.005').
@param ACurrency the ISO-4217 code (case-insensitive; stored upper-case).
@returns the money value.
@raises EDecimalParse if AAmount is malformed. }
function MoneyFromStr(const AAmount, ACurrency: string): TMoney;
{ Builds a TMoney from an existing TDecimal amount and a currency code. The
amount is normalised to the currency's default scale (banker's rounding).
@param AAmount the decimal amount.
@param ACurrency the ISO-4217 code (case-insensitive; stored upper-case).
@returns the money value. }
function MoneyFromDecimal(const AAmount: TDecimal; const ACurrency: string): TMoney;
{ Builds a TMoney from a whole-unit integer amount and a currency code
(e.g. MoneyFromInt(5, 'USD') = 5.00 USD).
@param AAmount the whole-unit integer amount.
@param ACurrency the ISO-4217 code (case-insensitive; stored upper-case).
@returns the money value. }
function MoneyFromInt(AAmount: Integer; const ACurrency: string): TMoney;
{ A zero amount in the given currency, at the currency scale.
@param ACurrency the ISO-4217 code (case-insensitive; stored upper-case).
@returns zero money in that currency. }
function MoneyZero(const ACurrency: string): TMoney;
{ ------------------------------------------------------------------ }
{ Currency registry }
{ ------------------------------------------------------------------ }
{ The default minor-unit scale (number of fraction digits) for a currency code.
Known: JPY 0, USD/EUR/GBP/AUD/CAD/CHF/CNY 2, KWD/BHD/OMR 3. Unknown codes
return the fallback scale 2. The lookup is case-insensitive.
@param ACurrency the ISO-4217 code.
@returns the default fraction-digit count for that currency. }
function CurrencyScale(const ACurrency: string): Integer;
implementation
const
{ Fallback minor-unit scale for currencies the registry does not list. }
cDefaultScale = 2;
function CurrencyScale(const ACurrency: string): Integer;
var
C: string;
begin
C := UpperCase(ACurrency);
{ Zero-decimal currencies. }
if (C = 'JPY') or (C = 'KRW') or (C = 'CLP') or (C = 'ISK') or
(C = 'VND') or (C = 'XAF') or (C = 'XOF') or (C = 'PYG') then
Result := 0
{ Three-decimal currencies. }
else if (C = 'KWD') or (C = 'BHD') or (C = 'OMR') or (C = 'TND') or
(C = 'JOD') or (C = 'IQD') or (C = 'LYD') then
Result := 3
{ Everything else (USD, EUR, GBP, ...) uses two. }
else
Result := cDefaultScale;
end;
{ Normalises ADec to ACurrency's scale with banker's rounding and pairs it with
the upper-cased code. Central constructor used by every public builder so the
invariant "FAmount is always at the currency scale" holds in one place. }
function MakeMoney(const ADec: TDecimal; const ACurrency: string): TMoney;
var
Code: string;
Norm: TDecimal;
begin
Code := UpperCase(ACurrency);
Norm := ADec.RoundTo(CurrencyScale(Code), rmHalfEven);
Result.FAmount := Norm;
Result.FCurrency := Code;
end;
function MoneyFromStr(const AAmount, ACurrency: string): TMoney;
begin
Result := MakeMoney(DecFromStr(AAmount), ACurrency);
end;
function MoneyFromDecimal(const AAmount: TDecimal; const ACurrency: string): TMoney;
begin
Result := MakeMoney(AAmount, ACurrency);
end;
function MoneyFromInt(AAmount: Integer; const ACurrency: string): TMoney;
begin
Result := MakeMoney(DecFromInt(AAmount), ACurrency);
end;
function MoneyZero(const ACurrency: string): TMoney;
begin
Result := MakeMoney(DecFromInt(0), ACurrency);
end;
{ Raises EMoneyMismatch when A and B are different currencies. AOp names the
operation for the message. }
procedure RequireSameCurrency(const A, B: TMoney; const AOp: string);
begin
if A.FCurrency <> B.FCurrency then
raise EMoneyMismatch.Create('Numerics.Money: cannot ' + AOp +
' different currencies (' + A.FCurrency + ' and ' + B.FCurrency + ')');
end;
function TMoney.Amount: TDecimal;
begin
Result := Self.FAmount;
end;
function TMoney.CurrencyCode: string;
begin
Result := Self.FCurrency;
end;
function TMoney.IsZero: Boolean;
begin
Result := Self.FAmount.IsZero();
end;
function TMoney.Sign: Integer;
begin
Result := Self.FAmount.Sign();
end;
function TMoney.Add(const B: TMoney): TMoney;
var
Sum: TDecimal;
begin
RequireSameCurrency(Self, B, 'add');
Sum := Self.FAmount.Add(B.FAmount);
Result := MakeMoney(Sum, Self.FCurrency);
end;
function TMoney.Subtract(const B: TMoney): TMoney;
var
Diff: TDecimal;
begin
RequireSameCurrency(Self, B, 'subtract');
Diff := Self.FAmount.Subtract(B.FAmount);
Result := MakeMoney(Diff, Self.FCurrency);
end;
function TMoney.Negate: TMoney;
var
Neg: TDecimal;
begin
Neg := Self.FAmount.Negate();
Result := MakeMoney(Neg, Self.FCurrency);
end;
function TMoney.Multiply(const Factor: TDecimal): TMoney;
var
Prod: TDecimal;
begin
Prod := Self.FAmount.Multiply(Factor);
Result := MakeMoney(Prod, Self.FCurrency);
end;
function TMoney.MultiplyInt(Quantity: Integer): TMoney;
var
Prod: TDecimal;
begin
Prod := Self.FAmount.Multiply(DecFromInt(Quantity));
Result := MakeMoney(Prod, Self.FCurrency);
end;
function TMoney.Compare(const B: TMoney): Integer;
begin
RequireSameCurrency(Self, B, 'compare');
Result := Self.FAmount.Compare(B.FAmount);
end;
function TMoney.Equals(const B: TMoney): Boolean;
begin
if Self.FCurrency <> B.FCurrency then
Result := False
else
Result := Self.FAmount.Equals(B.FAmount);
end;
function TMoney.AmountString: string;
begin
Result := Self.FAmount.ToString();
end;
function TMoney.ToString: string;
begin
Result := Self.FAmount.ToString() + ' ' + Self.FCurrency;
end;
end.