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

fix(codegen): WriteLn(Double/Single) crashed QBE with type mismatch

Browse source 
EmitWrite had no tyDouble/tySingle case; floats fell through to
_SysWriteInt with a d-typed temp, which QBE rejected as an invalid
argument type.

Add _SysWriteDouble and _SysWriteSingle RTL stubs in rtl.platform.pas
and rtl.platform.posix.pas (using the existing _DoubleToStr/_SingleToStr
functions from blaise_float.pas).  EmitWrite now dispatches to these
stubs so WriteLn(someDouble) and WriteLn(someSingle) compile and run
correctly without requiring DoubleToStr at the call site.

Two new e2e tests (TestRun_WriteLn_Double_Direct, TestRun_WriteLn_Single_Direct)
verify direct float output; 2375 tests pass.
This commit is contained in:
Graeme Geldenhuys 2026-06-03 13:22:10 +01:00
parent 613f326fa1
commit f4baabb9ce
4 changed files with 94 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -6711,6 +6711,12 @@ begin
ArgTemp := EmitExpr(ArgExpr);
if IsString then
EmitLine(Format(' call $_SysWriteStr(w %s, l %s)', [FdLit, ArgTemp]))
else if (ArgExpr.ResolvedType <> nil) and
(ArgExpr.ResolvedType.Kind = tyDouble) then
EmitLine(Format(' call $_SysWriteDouble(w %s, d %s)', [FdLit, ArgTemp]))
else if (ArgExpr.ResolvedType <> nil) and
(ArgExpr.ResolvedType.Kind = tySingle) then
EmitLine(Format(' call $_SysWriteSingle(w %s, s %s)', [FdLit, ArgTemp]))
else if (ArgExpr.ResolvedType <> nil) and
(ArgExpr.ResolvedType.Kind = tyUInt64) then
EmitLine(Format(' call $_SysWriteUInt64(w %s, l %s)', [FdLit, ArgTemp]))

42
compiler/src/test/pascal/cp.test.e2e.math.pas
View file

@ -148,6 +148,10 @@ type
{ Real division `/` with Integer operands yields a float }
procedure TestRun_RealDiv_IntegerOperands_RoundTrunc;
procedure TestRun_RealDiv_TenOverFour_Half;
{ WriteLn(Double) / WriteLn(Single) — direct float output without DoubleToStr }
procedure TestRun_WriteLn_Double_Direct;
procedure TestRun_WriteLn_Single_Direct;
end;
implementation
@ -1441,6 +1445,44 @@ begin
AssertEquals('10/4', '2.5', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ WriteLn(Double) / WriteLn(Single) direct float output }
{ ------------------------------------------------------------------ }
procedure TE2EMathTests.TestRun_WriteLn_Double_Direct;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(
'''
program P;
var D: Double;
begin
D := 3.14;
WriteLn(D)
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('WriteLn(Double)', '3.14', Trim(Output));
end;
procedure TE2EMathTests.TestRun_WriteLn_Single_Direct;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(
'''
program P;
var S: Single;
begin
S := 1.5;
WriteLn(S)
end.
''', Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('WriteLn(Single)', '1.5', Trim(Output));
end;
initialization
RegisterTest(TE2EMathTests);

2
runtime/src/main/pascal/rtl.platform.pas
View file

@ -58,6 +58,8 @@ type
procedure SysWriteInt(Fd: Integer; N: Integer); virtual; abstract;
procedure SysWriteInt64(Fd: Integer; N: Int64); virtual; abstract;
procedure SysWriteUInt64(Fd: Integer; N: UInt64); virtual; abstract;
procedure SysWriteDouble(Fd: Integer; V: Double); virtual; abstract;
procedure SysWriteSingle(Fd: Integer; V: Single); virtual; abstract;
procedure SysWriteNewline(Fd: Integer); virtual; abstract;
{ File-descriptor primitives — used by streams }

44
runtime/src/main/pascal/rtl.platform.posix.pas
View file

@ -66,6 +66,8 @@ type
procedure SysWriteInt(Fd: Integer; N: Integer); override;
procedure SysWriteInt64(Fd: Integer; N: Int64); override;
procedure SysWriteUInt64(Fd: Integer; N: UInt64); override;
procedure SysWriteDouble(Fd: Integer; V: Double); override;
procedure SysWriteSingle(Fd: Integer; V: Single); override;
procedure SysWriteNewline(Fd: Integer); override;
{ File-descriptor primitives }
@ -157,6 +159,8 @@ procedure _BlaiseFreeMem(Ptr: Pointer); external name '_BlaiseFreeMem';
function _IntToStr(N: Integer): Pointer; external name '_IntToStr';
function _Int64ToStr(N: Int64): Pointer; external name '_Int64ToStr';
function _UInt64ToStr(N: UInt64): Pointer; external name '_UInt64ToStr';
function _DoubleToStr(V: Double): Pointer; external name '_DoubleToStr';
function _SingleToStr(V: Single): Pointer; external name '_SingleToStr';
procedure _StringAddRef(Ptr: Pointer); external name '_StringAddRef';
procedure _StringRelease(Ptr: Pointer); external name '_StringRelease';
@ -237,6 +241,8 @@ procedure _SysWriteStr(Fd: Integer; S: Pointer);
procedure _SysWriteInt(Fd: Integer; N: Integer);
procedure _SysWriteInt64(Fd: Integer; N: Int64);
procedure _SysWriteUInt64(Fd: Integer; N: UInt64);
procedure _SysWriteDouble(Fd: Integer; V: Double);
procedure _SysWriteSingle(Fd: Integer; V: Single);
procedure _SysWriteNewline(Fd: Integer);
{ File-descriptor primitives }
@ -768,6 +774,34 @@ begin
_StringRelease(S);
end;
procedure TRtlPlatformPosix.SysWriteDouble(Fd: Integer; V: Double);
var
S: Pointer;
LPtr: ^Integer;
Len: Integer;
begin
S := _DoubleToStr(V);
_StringAddRef(S);
LPtr := S - 8;
Len := LPtr^;
WriteAllToFd(Fd, PChar(S), Len);
_StringRelease(S);
end;
procedure TRtlPlatformPosix.SysWriteSingle(Fd: Integer; V: Single);
var
S: Pointer;
LPtr: ^Integer;
Len: Integer;
begin
S := _SingleToStr(V);
_StringAddRef(S);
LPtr := S - 8;
Len := LPtr^;
WriteAllToFd(Fd, PChar(S), Len);
_StringRelease(S);
end;
{ ================================================================== }
{ TRtlPlatformPosix — File-descriptor primitives }
{ ================================================================== }
@ -1233,6 +1267,16 @@ begin
GRtlPlatform.SysWriteUInt64(Fd, N);
end;
procedure _SysWriteDouble(Fd: Integer; V: Double);
begin
GRtlPlatform.SysWriteDouble(Fd, V);
end;
procedure _SysWriteSingle(Fd: Integer; V: Single);
begin
GRtlPlatform.SysWriteSingle(Fd, V);
end;
procedure _SysWriteNewline(Fd: Integer);
begin
GRtlPlatform.SysWriteNewline(Fd);