452 lines
15 KiB
ObjectPascal
452 lines
15 KiB
ObjectPascal
{
|
|
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.decimal;
|
|
|
|
{ IR-level tests for the Numerics.Decimal stdlib unit (TDecimal).
|
|
|
|
These resolve Numerics.Decimal via TUnitLoader, run the semantic pass, and
|
|
inspect the generated QBE IR. They cover the parser / semantic / codegen path
|
|
for TDecimal usage. They CANNOT see RTL-contract or runtime-behaviour issues —
|
|
those are covered by cp.test.e2e.numerics.decimal.pas.
|
|
|
|
Phase 0 surface: construction (DecFromInt / DecFromInt64 / DecFromStr),
|
|
ToString / ToPlainString, Scale, IsZero, Sign. }
|
|
|
|
interface
|
|
|
|
uses
|
|
blaise.testing, strutils,
|
|
uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe, uUnitLoader;
|
|
|
|
type
|
|
TDecimalIRTests = 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_FromInt64_OK;
|
|
procedure TestSemantic_ToString_OK;
|
|
procedure TestSemantic_ToPlainString_OK;
|
|
procedure TestSemantic_Scale_ReturnsInteger_OK;
|
|
procedure TestSemantic_IsZero_ReturnsBoolean_OK;
|
|
procedure TestSemantic_Sign_ReturnsInteger_OK;
|
|
|
|
{ --- Comparison / equality / hash --- }
|
|
procedure TestSemantic_Compare_ReturnsInteger_OK;
|
|
procedure TestSemantic_Equals_ReturnsBoolean_OK;
|
|
procedure TestSemantic_GetHashCode_ReturnsInteger_OK;
|
|
|
|
{ --- Arithmetic (add/subtract/negate/abs) --- }
|
|
procedure TestSemantic_Add_ReturnsDecimal_OK;
|
|
procedure TestSemantic_Subtract_ReturnsDecimal_OK;
|
|
procedure TestSemantic_Negate_ReturnsDecimal_OK;
|
|
procedure TestSemantic_Abs_ReturnsDecimal_OK;
|
|
procedure TestSemantic_Multiply_ReturnsDecimal_OK;
|
|
procedure TestSemantic_FromStr_LargeValue_OK;
|
|
|
|
{ --- Division / rounding --- }
|
|
procedure TestSemantic_Divide_EnumMode_OK;
|
|
procedure TestSemantic_Divide_Strategy_OK;
|
|
procedure TestSemantic_RoundTo_EnumMode_OK;
|
|
procedure TestSemantic_SetScale_OK;
|
|
procedure TestSemantic_StandardRounding_ReturnsStrategy_OK;
|
|
procedure TestSemantic_CustomStrategy_OK;
|
|
|
|
{ --- Float conversion / strip / out-conversions --- }
|
|
procedure TestSemantic_DecFromFloat_OK;
|
|
procedure TestSemantic_DecFromFloatExact_OK;
|
|
procedure TestSemantic_StripTrailingZeros_OK;
|
|
procedure TestSemantic_ToDouble_ReturnsDouble_OK;
|
|
procedure TestSemantic_ToInt64_ReturnsInt64_OK;
|
|
|
|
{ --- Type errors --- }
|
|
procedure TestSemantic_FromInt_WrongArgType_Error;
|
|
procedure TestSemantic_AssignDecimalToInt_Error;
|
|
|
|
{ --- IR shape --- }
|
|
procedure TestIR_FromStr_EmitsCall;
|
|
procedure TestIR_MethodCall_EmitsCall;
|
|
end;
|
|
|
|
implementation
|
|
|
|
procedure TDecimalIRTests.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 TDecimalIRTests.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 TDecimalIRTests.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 TDecimalIRTests.AnalyseExpectError(const ASrc: string);
|
|
begin
|
|
try
|
|
SemanticOK(ASrc);
|
|
Fail('Expected ESemanticError');
|
|
except
|
|
on E: ESemanticError do ; { expected }
|
|
end;
|
|
end;
|
|
|
|
function TDecimalIRTests.IRContains(const AIR, AFragment: string): Boolean;
|
|
begin
|
|
Result := Pos(AFragment, AIR) >= 0;
|
|
end;
|
|
|
|
{ ------------------------------------------------------------------ }
|
|
{ Semantic resolution }
|
|
{ ------------------------------------------------------------------ }
|
|
|
|
procedure TDecimalIRTests.TestSemantic_FromStr_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; ' +
|
|
'begin A := DecFromStr(''1.50'') end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_FromInt_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; ' +
|
|
'begin A := DecFromInt(5) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_FromInt64_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; ' +
|
|
'begin A := DecFromInt64(5) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_ToString_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; S: string; ' +
|
|
'begin A := DecFromInt(5); S := A.ToString() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_ToPlainString_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; S: string; ' +
|
|
'begin A := DecFromInt(5); S := A.ToPlainString() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Scale_ReturnsInteger_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; N: Integer; ' +
|
|
'begin A := DecFromStr(''1.50''); N := A.Scale() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_IsZero_ReturnsBoolean_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; B: Boolean; ' +
|
|
'begin A := DecFromInt(0); B := A.IsZero() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Sign_ReturnsInteger_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; N: Integer; ' +
|
|
'begin A := DecFromInt(-3); N := A.Sign() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Compare_ReturnsInteger_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B: TDecimal; N: Integer; ' +
|
|
'begin A := DecFromStr(''2.0''); B := DecFromStr(''2.00''); ' +
|
|
'N := A.Compare(B) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Equals_ReturnsBoolean_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B: TDecimal; E: Boolean; ' +
|
|
'begin A := DecFromStr(''2.0''); B := DecFromStr(''2.00''); ' +
|
|
'E := A.Equals(B) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_GetHashCode_ReturnsInteger_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; H: Integer; ' +
|
|
'begin A := DecFromStr(''2.0''); H := A.GetHashCode() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Add_ReturnsDecimal_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''1.5''); B := DecFromStr(''2.25''); ' +
|
|
'C := A.Add(B) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Subtract_ReturnsDecimal_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''1.5''); B := DecFromStr(''2.25''); ' +
|
|
'C := A.Subtract(B) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Negate_ReturnsDecimal_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''5.00''); C := A.Negate() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Abs_ReturnsDecimal_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''-7.25''); C := A.Abs() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Multiply_ReturnsDecimal_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''19.99''); B := DecFromStr(''0.20''); ' +
|
|
'C := A.Multiply(B) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_FromStr_LargeValue_OK;
|
|
begin
|
|
{ A 20+ digit literal exceeds Int64 and must still parse (inflated path). }
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; S: string; ' +
|
|
'begin A := DecFromStr(''99999999999999999999''); S := A.ToString() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Divide_EnumMode_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''10''); B := DecFromStr(''4''); ' +
|
|
'C := A.Divide(B, 2, rmHalfEven) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_Divide_Strategy_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, B, C: TDecimal; S: IRoundingStrategy; ' +
|
|
'begin A := DecFromStr(''1''); B := DecFromStr(''3''); ' +
|
|
'S := StandardRounding(rmHalfUp); C := A.Divide(B, 4, S) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_RoundTo_EnumMode_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''3.14159''); C := A.RoundTo(2, rmHalfEven) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_SetScale_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''1.5''); C := A.SetScale(4, rmHalfEven) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_StandardRounding_ReturnsStrategy_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var S: IRoundingStrategy; ' +
|
|
'begin S := StandardRounding(rmHalfEven) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_CustomStrategy_OK;
|
|
begin
|
|
{ A user class implementing IRoundingStrategy must satisfy the interface. }
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal;' +
|
|
'type TMy = class(TObject, IRoundingStrategy)' +
|
|
' function RoundIncrement(Negative: Boolean; LastKeptDigit: Integer;' +
|
|
' DiscardedCompareHalf: Integer; AnyDiscarded: Boolean): Boolean;' +
|
|
'end;' +
|
|
'function TMy.RoundIncrement(Negative: Boolean; LastKeptDigit: Integer;' +
|
|
' DiscardedCompareHalf: Integer; AnyDiscarded: Boolean): Boolean;' +
|
|
'begin Result := False end;' +
|
|
'var A, B, C: TDecimal; S: IRoundingStrategy;' +
|
|
'begin S := TMy.Create(); A := DecFromStr(''1''); B := DecFromStr(''3'');' +
|
|
'C := A.Divide(B, 4, S) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_DecFromFloat_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; D: Double; ' +
|
|
'begin D := 0.1; A := DecFromFloat(D) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_DecFromFloatExact_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; D: Double; ' +
|
|
'begin D := 0.1; A := DecFromFloatExact(D) end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_StripTrailingZeros_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A, C: TDecimal; ' +
|
|
'begin A := DecFromStr(''4.0000''); C := A.StripTrailingZeros() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_ToDouble_ReturnsDouble_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; D: Double; ' +
|
|
'begin A := DecFromStr(''3.14''); D := A.ToDouble() end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_ToInt64_ReturnsInt64_OK;
|
|
begin
|
|
SemanticOK(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; N: Int64; ' +
|
|
'begin A := DecFromStr(''42.99''); N := A.ToInt64() end.');
|
|
end;
|
|
|
|
{ ------------------------------------------------------------------ }
|
|
{ Type errors }
|
|
{ ------------------------------------------------------------------ }
|
|
|
|
procedure TDecimalIRTests.TestSemantic_FromInt_WrongArgType_Error;
|
|
begin
|
|
{ DecFromInt expects an integer, not a string. }
|
|
AnalyseExpectError(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; ' +
|
|
'begin A := DecFromInt(''x'') end.');
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestSemantic_AssignDecimalToInt_Error;
|
|
begin
|
|
{ A TDecimal value is not assignable to an Integer. }
|
|
AnalyseExpectError(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; N: Integer; ' +
|
|
'begin A := DecFromInt(5); N := A end.');
|
|
end;
|
|
|
|
{ ------------------------------------------------------------------ }
|
|
{ IR shape }
|
|
{ ------------------------------------------------------------------ }
|
|
|
|
procedure TDecimalIRTests.TestIR_FromStr_EmitsCall;
|
|
var IR: string;
|
|
begin
|
|
IR := GenIR(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; ' +
|
|
'begin A := DecFromStr(''1.50'') end.');
|
|
AssertTrue('emits DecFromStr call',
|
|
IRContains(IR, 'DecFromStr'));
|
|
end;
|
|
|
|
procedure TDecimalIRTests.TestIR_MethodCall_EmitsCall;
|
|
var IR: string;
|
|
begin
|
|
IR := GenIR(
|
|
'program P; uses Numerics.Decimal; var A: TDecimal; N: Integer; ' +
|
|
'begin A := DecFromInt(7); N := A.Sign() end.');
|
|
AssertTrue('emits TDecimal_Sign call',
|
|
IRContains(IR, 'Sign'));
|
|
end;
|
|
|
|
initialization
|
|
RegisterTest(TDecimalIRTests);
|
|
|
|
end.
|