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

Рабочие синонимы

Browse source
This commit is contained in:
mzhoot 2026-07-04 21:44:54 +03:00
parent 8b50bc0c9f
commit 94ae8c354c
166 changed files with 2995 additions and 27804 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
compiler/project.xml
View file

@ -7,8 +7,7 @@
<mainSource>Blaise.pas</mainSource>
<executableName>blaise</executableName>
<unitPaths>
<!-- RTL units (runtime.*) now live in this module's own source dir;
only stdlib remains a separate unit-path. -->
<path>../runtime/src/main/pascal</path>
<path>../stdlib/src/main/pascal</path>
</unitPaths>
</build>
@ -16,6 +15,7 @@
<test>
<testSource>TestRunner.pas</testSource>
<unitPaths>
<path>../runtime/src/main/pascal</path>
<path>../stdlib/src/main/pascal</path>
</unitPaths>
</test>

29
compiler/src/it/freebsd/fileio.pas
View file

@ -1,29 +0,0 @@
{ FreeBSD cross-compile emulation smoke test (docs/freebsd-x86_64-backend-design
Step 8). Exercises the file path that STATIC ELF checks cannot catch: a wrong
struct-stat offset or syscall number only shows up when the binary actually
runs on FreeBSD. Write a file, read it back, and stat it (FileExists), then
print the results. Expected output under FreeBSD:
file-io-ok
exists-ok
done
A wrong FreeBSD st_size / st_mode offset (they differ from Linux — see
rtl.platform.layout.freebsd) would make ReadFile or FileExists misbehave.
This also guards the memory manager's mmap path: WriteFile/ReadFile allocate,
and runtime.mem passes the Linux MAP_ANONYMOUS bit which the FreeBSD mmap leaf
must translate to MAP_ANON — without the translation the first allocation
fails with EBADF and the program SIGSEGVs (regression caught here). }
program fileio;
uses sysutils;
var
S: string;
begin
WriteFile('blaise_fbsd_it.txt', 'file-io-ok');
S := ReadFile('blaise_fbsd_it.txt');
WriteLn(S);
if FileExists('blaise_fbsd_it.txt') then
WriteLn('exists-ok');
DeleteFile('blaise_fbsd_it.txt');
WriteLn('done');
end.

9
compiler/src/it/freebsd/hello.pas
View file

@ -1,9 +0,0 @@
{ FreeBSD cross-compile emulation smoke test (docs/freebsd-x86_64-backend-design
Step 8). Cross-compiled with --target freebsd-x86_64 on the Linux CI runner,
then executed inside a FreeBSD VM. A raw-syscall static ET_EXEC: printing
Hello and exiting 0 proves _start, argv capture, write(2) and _exit(2) work
under the real FreeBSD kernel. }
program hello;
begin
WriteLn('Hello');
end.

165
compiler/src/main/pascal/Blaise.pas
View file

@ -31,7 +31,7 @@ uses
blaise.codegen.native.driver,
uUnitLoader, uDebugOPDF, uDebugFacts, uUnitInterface, uSemanticExport, uSemanticImport,
uUnitInterfaceIO, uIfaceObject, uASTDump,
blaise.frontend.opts, uConfig, uToolchain;
blaise.frontend.opts, uConfig;
type
{ Alias so existing signatures (ParseArgs out param, locals) read
@ -40,7 +40,7 @@ type
TBackend = TBackendKind;
const
Version = '0.13.0-SNAPSHOT';
Version = '0.12.0';
CompilerName = 'Blaise';
{ Build the --backend usage fragment from the registered drivers, with
@ -93,17 +93,12 @@ begin
WriteLn(FormatFlagLine('--output <path>', 'Output binary path'));
WriteLn(FormatFlagLine('--unit-path <dir>',
'Add directory to unit search path (repeatable)'));
WriteLn(FormatFlagLine('--rtl-src <dir>',
'RTL source directory (default: beside the binary; or $BLAISE_RTL_SRC).'));
WriteLn(FormatFlagLine('',
'Needed when the binary is moved away from its source tree.'));
WriteLn(FormatFlagLine('--define <sym> | -d <sym>',
'Define a conditional-compilation symbol (repeatable)'));
WriteLn(FormatFlagLine('--backend <id>', BackendUsageLine()));
WriteLn(FormatFlagLine('--target <os>-<cpu>',
'Cross-compile target (default: ' + TargetName(HostTarget()) + ', the host).'));
WriteLn(FormatFlagLine('', 'linux-x86_64, linux-i386, linux-arm64, freebsd-x86_64,'));
WriteLn(FormatFlagLine('', 'windows-x86_64, macos-arm64'));
'linux-x86_64 (default), linux-i386, linux-arm64,'));
WriteLn(FormatFlagLine('', 'freebsd-x86_64, windows-x86_64, macos-arm64'));
WriteLn(FormatFlagLine('--emit-ir', 'Print QBE IR to stdout and exit'));
WriteLn(FormatFlagLine('--emit-asm',
'Print native assembly to stdout (requires --backend native)'));
@ -139,10 +134,8 @@ begin
'Emit OPDF debug info (.opdf.s companion file)'));
WriteLn('');
WriteLn('Configuration:');
WriteLn(' blaise.cfg (next to the binary, then ~/.blaise.cfg) can set, one');
WriteLn(' per line: unit-path=<dir> (repeatable) and rtl-src=<dir>. A relative');
WriteLn(' path is resolved against the config file''s directory; --rtl-src on');
WriteLn(' the command line overrides rtl-src= in the config.');
WriteLn(' Unit search paths can also be set in blaise.cfg (one unit-path=<dir>');
WriteLn(' per line). Searched next to the binary, then ~/.blaise.cfg.');
end;
{ Populate the two caller-constructed opts objects from the command line.
@ -154,29 +147,11 @@ end;
bad flag; the caller owns and frees both objects regardless. }
{ Apply each -d/--define symbol in ADefines to ALexer's conditional-compilation
table. No-op when ADefines is nil/empty. }
{ True if ASym is one of the OS conditional-compilation symbols. }
function IsOSDefine(const ASym: string): Boolean;
var U: string;
begin
U := UpperCase(ASym);
Result := (U = 'LINUX') or (U = 'FREEBSD') or (U = 'WINDOWS')
or (U = 'DARWIN') or (U = 'UNIX');
end;
procedure AddDefinesTo(ALexer: TLexer; ADefines: TStringList);
var
I: Integer;
HasOS: Boolean;
begin
if ADefines = nil then Exit;
{ If the caller supplies an OS symbol (a cross --target injects the target's),
it REPLACES the host OS symbols the lexer seeded in SeedPredefines: drop
those first so an IFDEF LINUX etc. reflects the target, not the host. }
HasOS := False;
for I := 0 to ADefines.Count - 1 do
if IsOSDefine(ADefines.Strings[I]) then HasOS := True;
if HasOS then
ALexer.ClearOSDefines();
for I := 0 to ADefines.Count - 1 do
ALexer.AddDefine(ADefines.Strings[I]);
end;
@ -256,13 +231,6 @@ begin
Inc(I);
AFront.UnitCacheDir := ParamStr(I);
end
else if (Arg = '--rtl-src') and (I < ParamCount()) then
begin
Inc(I);
AOpts.RTLSrcDir := ParamStr(I);
end
else if Arg = '--static' then
AOpts.Static := True
else if Arg = '--emit-ir' then
AFront.EmitIR := True
else if Arg = '--emit-asm' then
@ -469,7 +437,6 @@ var
SourceFile, OutputFile: string;
SearchPaths: TStringList;
ConfigPaths: TStringList;
CfgRtlSrc: string;
EmitIR: Boolean;
EmitAsm: Boolean;
DumpAST: Boolean;
@ -508,7 +475,6 @@ var
Front: TFrontEndOpts; { front-end-only flag bag, populated by ParseArgs }
ToolErr: string; { CheckToolchain result ('' on success) }
ValidErr: string; { Driver.ValidateOptions result ('' on success) }
RTLSrc: string; { RTL source dir added to the loader search path }
PendingFlags: TStringList; { deferred unknown flags (driver-private) }
PendingArgs: TStringList; { lookahead token per pending flag ('' if none) }
PendIdx: Integer; { drain cursor over the pending lists }
@ -528,12 +494,10 @@ var
any ExportUnitInterface bugs against real
codebases. }
I: Integer;
J: Integer;
IR: string;
IRFile: string;
LinkErr: string; { Driver.LinkProgram result ('' on success) }
UnitOPath: string; { per-dep .o output path in incremental mode }
UnitODir: string; { directory the per-dep .o/.bif files are written to }
Workers: TObjectList; { TCompileWorker threads for parallel incremental }
Worker: TCompileWorker;
@ -557,23 +521,6 @@ begin
Halt(1);
end;
{ The OS conditional-compilation symbols follow the resolved --target (which
defaults to the host). Inject them into Front.Defines; AddDefinesTo then
replaces the lexer's host-seeded OS symbols with these on every lexer (top
program and, via the unit loader, each dependency unit). So an IFDEF
FREEBSD in compiled source reflects the TARGET, not this compiler's host,
which is what makes cross-compiling blaise itself for FreeBSD bake
HostTarget=FreeBSD into the result. }
case Opts.Target.OS of
osFreeBSD: Front.Defines.Add('FREEBSD');
osWindows: Front.Defines.Add('WINDOWS');
osMacOS: Front.Defines.Add('DARWIN');
else
Front.Defines.Add('LINUX');
end;
if Opts.Target.OS <> osWindows then
Front.Defines.Add('UNIX');
{ Seed the working locals from the opts objects. Keeping the locals lets
the (large) main body read them unchanged; the parser owns the objects.
SearchPaths is the object's owned list (not copied) so config-path
@ -599,14 +546,7 @@ begin
ConfigPaths := TStringList.Create();
try
{ blaise.cfg supplies extra unit-paths and, optionally, rtl-src. A CLI
--rtl-src (already in Opts.RTLSrcDir) takes precedence: only let the config
set it when the CLI did not. Seed CfgRtlSrc with the CLI value so the
config only overrides an EMPTY one. }
CfgRtlSrc := Opts.RTLSrcDir;
LoadConfigPaths(ConfigPaths, CfgRtlSrc);
if Opts.RTLSrcDir = '' then
Opts.RTLSrcDir := CfgRtlSrc;
LoadConfigPaths(ConfigPaths);
for I := ConfigPaths.Count - 1 downto 0 do
SearchPaths.Insert(0, ConfigPaths.Strings[I]);
finally
@ -616,24 +556,6 @@ begin
if (UnitCacheDir <> '') and (SearchPaths.IndexOf(UnitCacheDir) < 0) then
SearchPaths.Add(UnitCacheDir);
{ Always make the RTL source directory discoverable to the unit loader. The
RTL units (runtime.*, rtl.platform.*, system) live in the compiler's own
source tree after the RTL-unification move; stdlib units such as `classes`
explicitly `uses runtime.arc`, so a program that uses them needs the RTL
source on the search path — without this the loader fails with
"Unit 'runtime.arc' not found". The driver already source-builds the RTL
from this same directory at link time; here we add it for the front-end
loader too. Resolution mirrors EnsureRTLObjects: --rtl-src, then
$BLAISE_RTL_SRC, then the binary/CWD-relative default. }
RTLSrc := Opts.RTLSrcDir;
if RTLSrc = '' then
RTLSrc := GetEnvironmentVariable('BLAISE_RTL_SRC');
if RTLSrc = '' then
RTLSrc := RTLSourceDir();
if (RTLSrc <> '') and DirectoryExists(RTLSrc)
and (SearchPaths.IndexOf(RTLSrc) < 0) then
SearchPaths.Add(RTLSrc);
{ Emit-mode / backend compatibility. --emit-ir prints QBE IR and
--emit-asm prints native assembly; PickTopDriver routes each to the
backend that produces it, ignoring --backend. That silent override is
@ -754,17 +676,7 @@ begin
Parser := TParser.Create(Lexer);
IsUnitMode := Parser.IsUnitTopLevel();
if IsUnitMode then
begin
TopUnit := Parser.ParseUnit();
{ The loader sets SourceFile on dependency units (uUnitLoader), but a
unit compiled standalone via --source never had it set. Without it
the exported iface carries an empty SourceHash, so a later compile
that depends on this unit cannot validate the cached .o and falls
back to recompiling from source — which re-inlines the dependency
body and causes duplicate-symbol link errors. Set it from the
--source path. }
TopUnit.SourceFile := ExpandFileName(SourceFile);
end
TopUnit := Parser.ParseUnit()
else
Prog := Parser.Parse();
except
@ -913,24 +825,17 @@ begin
WorkerDriver := GetDriver(bkQBE);
Workers := TObjectList.Create(True);
try
{ Resolve the directory the per-unit .o/.bif artefacts go in.
Priority: an explicit --unit-cache, else the --output file's own
directory. When neither yields a directory (e.g. --output is a
bare filename with no path component, or omitted entirely) the
artefacts are written to the current directory — never to the
filesystem root. ExtractFilePath returns '' for a path with no
directory part; IncludeTrailingPathDelimiter('') would turn that
into '/', anchoring the unit objects at root, so only prepend a
delimiter when the directory is non-empty. }
if UnitCacheDir <> '' then
UnitODir := IncludeTrailingPathDelimiter(UnitCacheDir)
else if ExtractFilePath(OutputFile) <> '' then
UnitODir := IncludeTrailingPathDelimiter(ExtractFilePath(OutputFile))
else
UnitODir := '';
for I := 0 to Units.Count - 1 do
begin
UnitOPath := UnitODir + LowerCase(TUnit(Units.Items[I]).Name) + '.o';
UnitOPath := UnitCacheDir;
if UnitOPath <> '' then
UnitOPath := IncludeTrailingPathDelimiter(UnitOPath) +
LowerCase(TUnit(Units.Items[I]).Name) + '.o'
else if OutputFile <> '' then
UnitOPath := IncludeTrailingPathDelimiter(ExtractFilePath(OutputFile)) +
LowerCase(TUnit(Units.Items[I]).Name) + '.o'
else
UnitOPath := LowerCase(TUnit(Units.Items[I]).Name) + '.o';
Worker := TCompileWorker.Create(True);
Worker.WorkUnit := TUnit(Units.Items[I]);
@ -980,27 +885,9 @@ begin
begin
{ Unit-as-top-level: emit just the unit's bodies, no program wrapping, no @main. }
CG.SetSymbolTable(Semantic.GetSymbolTable());
{ Note every dependency whose body is NOT emitted into this object so the
backend references its globals externally instead of re-defining them.
Cached (prebuilt-iface) deps are always external; source deps are
external only when SkipDepCodegen compiled them to their own objects.
Without this, a standalone unit compile re-defines an imported unit's
globals (e.g. GPlatformLayout), and linking the per-unit objects
directly — rather than via an archive whose member selection hides the
clash — fails with multiple-definition errors. }
if Loader <> nil then
for I := 0 to Loader.PrebuiltIfaces.Count - 1 do
CG.NoteDepInitUnit(
TUnitInterface(Loader.PrebuiltIfaces.Items[I]).Name,
TUnitInterface(Loader.PrebuiltIfaces.Items[I]).HasInitialization);
if (Units <> nil) and not SkipDepCodegen then
for I := 0 to Units.Count - 1 do
CG.AppendUnit(TUnit(Units.Items[I]))
else if Units <> nil then
for I := 0 to Units.Count - 1 do
CG.NoteDepInitUnit(TUnit(Units.Items[I]).Name,
(TUnit(Units.Items[I]).InitStmts <> nil) and
(TUnit(Units.Items[I]).InitStmts.Count > 0));
CG.AppendUnit(TUnit(Units.Items[I]));
CG.AppendUnit(TopUnit);
end
else if ((Units <> nil) and (Units.Count > 0)) or
@ -1106,22 +993,6 @@ begin
if PrebuiltObjPaths.IndexOf(Loader.LinkOnlyObjects.Strings[I]) < 0 then
PrebuiltObjPaths.Add(Loader.LinkOnlyObjects.Strings[I]);
end;
{ Capture link-library deps (-l<name>) off the program AST and every used
unit's interface before Prog/Loader are freed below — the link step runs
after this finally block. Unioned into Opts.LinkLibs; the driver emits one
-l<name> each, additive to the RTL's -lm/-lpthread. }
if Opts.LinkLibs = nil then Opts.LinkLibs := TStringList.Create();
if (Prog <> nil) and (Prog.LinkLibs <> nil) then
for I := 0 to Prog.LinkLibs.Count - 1 do
if Opts.LinkLibs.IndexOf(TLinkLibDecl(Prog.LinkLibs.Items[I]).LibName) < 0 then
Opts.LinkLibs.Add(TLinkLibDecl(Prog.LinkLibs.Items[I]).LibName);
if Loader <> nil then
for I := 0 to Loader.PrebuiltIfaces.Count - 1 do
for J := 0 to TUnitInterface(Loader.PrebuiltIfaces.Items[I]).LinkLibs.Count - 1 do
if Opts.LinkLibs.IndexOf(
TUnitInterface(Loader.PrebuiltIfaces.Items[I]).LinkLibs.Strings[J]) < 0 then
Opts.LinkLibs.Add(
TUnitInterface(Loader.PrebuiltIfaces.Items[I]).LinkLibs.Strings[J]);
Units.Free();
Loader.Free();
SearchPaths.Free();

642
compiler/src/main/pascal/blaise.assembler.x86_64.pas
View file

@ -88,7 +88,7 @@ end;
const
REG_COUNT = 66;
RegNames: array[0..89] of string = (
RegNames: array[0..65] of string = (
'rax', 'rcx', 'rdx', 'rbx', 'rsp', 'rbp', 'rsi', 'rdi',
'r8', 'r9', 'r10', 'r11', 'r12', 'r13', 'r14', 'r15',
'eax', 'ecx', 'edx', 'ebx', 'esp', 'ebp', 'esi', 'edi',
@ -97,13 +97,10 @@ const
'al', 'cl', 'dl', 'bl', 'spl', 'bpl', 'sil', 'dil',
'r8b', 'r9b', 'r10b', 'r11b',
'xmm0', 'xmm1', 'xmm2', 'xmm3', 'xmm4', 'xmm5', 'xmm6', 'xmm7',
'ah', 'ch', 'dh', 'bh',
'xmm8', 'xmm9', 'xmm10', 'xmm11', 'xmm12', 'xmm13', 'xmm14', 'xmm15',
'ymm0', 'ymm1', 'ymm2', 'ymm3', 'ymm4', 'ymm5', 'ymm6', 'ymm7',
'ymm8', 'ymm9', 'ymm10', 'ymm11', 'ymm12', 'ymm13', 'ymm14', 'ymm15'
'ah', 'ch', 'dh', 'bh'
);
RegCodes: array[0..89] of Integer = (
RegCodes: array[0..65] of Integer = (
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15,
0, 1, 2, 3, 4, 5, 6, 7,
@ -112,13 +109,10 @@ const
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11,
0, 1, 2, 3, 4, 5, 6, 7,
4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15,
0, 1, 2, 3, 4, 5, 6, 7,
8, 9, 10, 11, 12, 13, 14, 15
4, 5, 6, 7
);
RegWidths: array[0..89] of Integer = (
RegWidths: array[0..65] of Integer = (
64, 64, 64, 64, 64, 64, 64, 64,
64, 64, 64, 64, 64, 64, 64, 64,
32, 32, 32, 32, 32, 32, 32, 32,
@ -127,13 +121,10 @@ const
8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8,
128, 128, 128, 128, 128, 128, 128, 128,
8, 8, 8, 8,
128, 128, 128, 128, 128, 128, 128, 128,
256, 256, 256, 256, 256, 256, 256, 256,
256, 256, 256, 256, 256, 256, 256, 256
8, 8, 8, 8
);
RegIsXmm: array[0..89] of Integer = (
RegIsXmm: array[0..65] of Integer = (
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0,
@ -142,10 +133,7 @@ const
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0,
1, 1, 1, 1, 1, 1, 1, 1,
0, 0, 0, 0,
1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1,
1, 1, 1, 1, 1, 1, 1, 1
0, 0, 0, 0
);
type
@ -175,7 +163,6 @@ type
Sym: string; { symbol name (for RIP-rel, labels, TLS) }
SymDisp: Int64; { addend to symbol (sym + N) }
TpOff: Boolean; { sym@tpoff — emit R_X86_64_TPOFF32 relocation }
Indirect: Boolean; { memory operand reached via *mem (call/jmp *disp(%reg)) }
end;
{ Parsed line types }
@ -189,11 +176,10 @@ type
TParsedLine = record
Kind: TLineKind;
Mnemonic: string; { instruction mnemonic or directive name }
Op1, Op2, Op3: TOperand; { up to three operands (Op3 for VEX/imm forms) }
Op1, Op2: TOperand; { up to two operands }
NumOps: Integer;
RawLine: string; { original line text }
LineNum: Integer;
HasLock: Boolean; { a `lock` prefix preceded the mnemonic }
end;
{ Internal assembler state for a single section }
@ -317,7 +303,7 @@ var
I: Integer;
begin
I := 0;
while I <= High(RegNames) do
while I < 66 do
begin
if RegNames[I] = AName then
begin
@ -355,7 +341,6 @@ begin
Result.Scale := 1;
Result.Sym := '';
Result.SymDisp := 0;
Result.Indirect := False;
P := APos;
while (P < Length(S)) and ((S[P]= Ord(' ')) or (S[P]= 9)) do
@ -367,8 +352,7 @@ begin
Exit;
end;
{ Indirect operand: *%reg (register-indirect) or *disp(%reg) (memory-
indirect), used by `call`/`jmp` through a pointer. }
{ Indirect register: *%reg }
if S[P]= Ord('*') then
begin
P := P + 1;
@ -386,11 +370,6 @@ begin
AEnd := P;
Exit;
end;
{ *disp(%reg): parse the remainder as an ordinary memory operand and flag
it indirect so the branch encoder uses FF /4 with that memory ModRM. }
Result := ParseOperand(S, P, AEnd);
Result.Indirect := True;
Exit;
end;
{ Immediate: $N }
@ -495,12 +474,10 @@ begin
end
else
Result.Kind := opMem;
{ Check for index,scale. GNU as allows whitespace after the commas,
e.g. `(%rdi, %rdx)` and `(%rdi, %rdx, 4)`. }
{ Check for index,scale }
if (P < Length(S)) and (S[P]= Ord(',')) then
begin
P := P + 1;
while (P < Length(S)) and ((S[P]= Ord(' ')) or (S[P]= 9)) do P := P + 1;
if (P < Length(S)) and (S[P]= Ord('%')) then
begin
P := P + 1;
@ -512,11 +489,9 @@ begin
end;
LookupReg(RegName, Result.Index, IdxW, IdxXmm);
end;
while (P < Length(S)) and ((S[P]= Ord(' ')) or (S[P]= 9)) do P := P + 1;
if (P < Length(S)) and (S[P]= Ord(',')) then
begin
P := P + 1;
while (P < Length(S)) and ((S[P]= Ord(' ')) or (S[P]= 9)) do P := P + 1;
Result.Scale := Integer(ParseInt(S, P));
end;
end;
@ -559,14 +534,12 @@ begin
end
else
begin
{ Any other @SUFFIX (e.g. @PLT, @GOTPCREL) is a relocation qualifier,
NOT part of the symbol name — consume and discard it. @PLT just
selects the PLT32 relocation, which call/jmp already emit by default.
Appending it to the name would create a bogus symbol like
`__libc_start_main@PLT` that no loader resolves. }
P := P + 1;
while (P < Length(S)) and (IsAlnum(S[P]) or (S[P]= Ord('_'))) do
while (P < Length(S)) and (IsAlnum(S[P]) or (S[P]= Ord('.'))
or (S[P]= Ord('_')) or (S[P]= Ord('$')) or (S[P]= Ord('@'))) do
begin
SymName := SymName + Chr(S[P]);
P := P + 1;
end;
end;
end;
@ -650,7 +623,7 @@ end;
function ParseLine(const ALine: string; ALineNum: Integer): TParsedLine;
var
S: string;
P, Q, OpEnd: Integer;
P, OpEnd: Integer;
Mnemonic: string;
TmpOp: TOperand;
begin
@ -659,58 +632,12 @@ begin
Result.NumOps := 0;
Result.RawLine := ALine;
Result.LineNum := ALineNum;
Result.HasLock := False;
Result.Op1.Kind := opNone;
Result.Op2.Kind := opNone;
Result.Op3.Kind := opNone;
S := TrimStr(ALine);
if (Length(S) = 0) or (S[0]= Ord('#')) then Exit;
{ Strip a brace comment (open/close = ASCII 123/125) that survived the lexer:
a whole-line or trailing comment inside an asm block. Single line only;
remove the span from the open brace to the matching close brace, or to end
of line when unterminated. Skip over quoted strings so that a brace INSIDE
a .ascii string literal (the string-const data the native backend emits) is
left intact rather than mistaken for a comment. }
P := 0;
while P < Length(S) do
begin
if S[P] = Ord('"') then
begin
{ Skip the whole quoted string, honouring \" escapes. }
P := P + 1;
while P < Length(S) do
begin
if S[P] = Ord('\') then
P := P + 2
else if S[P] = Ord('"') then
begin
P := P + 1;
Break;
end
else
P := P + 1;
end;
end
else if S[P] = 123 then
begin
Q := P + 1;
while (Q < Length(S)) and (S[Q] <> 125) do
Q := Q + 1;
{ Splice out [P..Q] WITHOUT trimming mid-scan (a left-trim would shift the
string under P); resume from P so a following brace is still found. }
if Q < Length(S) then
S := Copy(S, 0, P) + ' ' + Copy(S, Q + 1, Length(S))
else
S := Copy(S, 0, P);
end
else
P := P + 1;
end;
S := TrimStr(S);
if Length(S) = 0 then Exit;
{ Strip trailing comment, but skip over quoted strings so that '#'
inside .ascii "..." is not mistaken for a comment start. }
P := 0;
@ -779,21 +706,6 @@ begin
Mnemonic := Mnemonic + Chr(S[P]);
P := P + 1;
end;
{ `lock` prefix: record it and read the real mnemonic that follows. }
if Mnemonic = 'lock' then
begin
Result.HasLock := True;
while (P < Length(S)) and ((S[P] = Ord(' ')) or (S[P] = 9)) do
P := P + 1;
Mnemonic := '';
while (P < Length(S)) and (IsAlnum(S[P])) do
begin
Mnemonic := Mnemonic + Chr(S[P]);
P := P + 1;
end;
end;
Result.Mnemonic := Mnemonic;
{ Skip whitespace }
@ -821,22 +733,6 @@ begin
Result.Op2 := TmpOp;
if Result.Op2.Kind <> opNone then
Result.NumOps := 2;
P := OpEnd;
{ Third operand (VEX 3-operand forms, e.g. vpaddb %ymm2,%ymm3,%ymm3, and
imm-prefixed forms like pshufd $0x0E,%xmm3,%xmm3). }
while (P < Length(S)) and ((S[P]= Ord(' ')) or (S[P]= 9)) do
P := P + 1;
if (P < Length(S)) and (S[P]= Ord(',')) then
begin
P := P + 1;
while (P < Length(S)) and ((S[P]= Ord(' ')) or (S[P]= 9)) do
P := P + 1;
TmpOp := ParseOperand(S, P, OpEnd);
Result.Op3 := TmpOp;
if Result.Op3.Kind <> opNone then
Result.NumOps := 3;
end;
end;
end;
@ -1059,9 +955,6 @@ function EncodeALU(var ACB: TCodeBuf; var ACtx: TEncodeContext;
function EncodeIMul(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const ASrc, ADst: TOperand): string; forward;
function EncodeXchg(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const ASrc, ADst: TOperand): string; forward;
function EncodeShift(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const ASrc, ADst: TOperand): string; forward;
@ -1072,10 +965,6 @@ function EncodeSSE(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const ASrc, ADst: TOperand): string; forward;
function EncodeMovqXmm(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const ASrc, ADst: TOperand): string; forward;
{ VEX/AVX encoder. AOp1/AOp2/AOp3 are the parsed operands in AT&T order
(AOp1 = first / source-or-immediate ... AOp3 = destination). }
function EncodeVEX(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const AOp1, AOp2, AOp3: TOperand): string; forward;
{ Returns True if the mnemonic is a conditional or unconditional branch }
function IsBranch(const AMnem: string): Boolean;
@ -1339,45 +1228,6 @@ begin
Result := (AWidth = 8) and (ARegCode >= 4) and (ARegCode <= 7);
end;
{ Map an unsuffixed AT&T mnemonic (mov/lea/xor/…) to its size-suffixed form,
inferring the operand size from a register operand's width (GNU as does the
same). Mnemonics that already carry a suffix, and ones that are size-fixed in
long mode (push/pop/call/jmp are 64-bit), pass through. 64-bit is the default
when no register operand pins the width. }
function NormalizeMnemonic(const AMnem: string;
const AOp1, AOp2: TOperand): string;
var
W: Integer;
Suffix: string;
begin
Result := AMnem;
{ Width from whichever operand is a register (Op2 first — it is the
destination in AT&T two-operand forms). }
W := 0;
if AOp2.Kind = opReg then W := AOp2.RegW
else if AOp1.Kind = opReg then W := AOp1.RegW;
if W = 64 then Suffix := 'q'
else if W = 32 then Suffix := 'l'
else if W = 16 then Suffix := 'w'
else if W = 8 then Suffix := 'b'
else Suffix := 'q'; { default 64-bit when no register pins the size }
{ Size-inferred integer ALU/data mnemonics. }
if (AMnem = 'mov') or (AMnem = 'xor') or (AMnem = 'and') or (AMnem = 'or') or
(AMnem = 'add') or (AMnem = 'sub') or (AMnem = 'cmp') or (AMnem = 'test') or
(AMnem = 'inc') or (AMnem = 'dec') or (AMnem = 'neg') or (AMnem = 'not') or
(AMnem = 'imul') or (AMnem = 'shl') or (AMnem = 'shr') then
Result := AMnem + Suffix
{ lea's size is the destination pointer width — always 64-bit here. }
else if AMnem = 'lea' then
Result := 'leaq'
{ Stack/branch ops are 64-bit-only in long mode. }
else if AMnem = 'push' then Result := 'pushq'
else if AMnem = 'pop' then Result := 'popq'
else if AMnem = 'call' then Result := 'callq';
{ 'jmp' keeps its name (the encoder already handles jmp incl. indirect). }
end;
{ ---- Main instruction encoder ----------------------------------------- }
function EncodeInstruction(var ACtx: TEncodeContext;
@ -1385,7 +1235,7 @@ function EncodeInstruction(var ACtx: TEncodeContext;
var
CB: TCodeBuf;
Mnem: string;
Op1, Op2, Op3: TOperand;
Op1, Op2: TOperand;
DispOff: Integer;
Dummy: Boolean;
TargetOff: Integer;
@ -1395,15 +1245,9 @@ var
begin
CBInit(CB);
ACtx.ImmTail := 0;
Mnem := AParsed.Mnemonic;
Op1 := AParsed.Op1;
Op2 := AParsed.Op2;
Op3 := AParsed.Op3;
{ Accept unsuffixed AT&T mnemonics (mov/lea/xor/…) by inferring the size. }
Mnem := NormalizeMnemonic(AParsed.Mnemonic, Op1, Op2);
{ ---- lock prefix (F0) — emitted ahead of the instruction it guards ---- }
if AParsed.HasLock then
CBEmit(CB, $F0);
{ ---- ret ---- }
if Mnem = 'ret' then
@ -1413,38 +1257,6 @@ begin
Exit;
end;
{ ---- endbr64 (CET) ---- F3 0F 1E FA }
if Mnem = 'endbr64' then
begin
CBEmit(CB, $F3); CBEmit(CB, $0F); CBEmit(CB, $1E); CBEmit(CB, $FA);
Result := CB.Data;
Exit;
end;
{ ---- hlt ---- F4 }
if Mnem = 'hlt' then
begin
CBEmit(CB, $F4);
Result := CB.Data;
Exit;
end;
{ ---- syscall ---- 0F 05 }
if Mnem = 'syscall' then
begin
CBEmit(CB, $0F); CBEmit(CB, $05);
Result := CB.Data;
Exit;
end;
{ ---- cpuid ---- 0F A2 }
if Mnem = 'cpuid' then
begin
CBEmit(CB, $0F); CBEmit(CB, $A2);
Result := CB.Data;
Exit;
end;
{ ---- leave ---- }
if Mnem = 'leave' then
begin
@ -1601,25 +1413,10 @@ begin
end
else if (Op1.Kind = opIndirect) then
begin
{ Register-indirect: jmp *%reg / call *%reg. FF /4 (jmp) or /2 (call). }
if Op1.Reg >= 8 then
CBEmit(CB, MakeRex(False, False, False, True));
CBEmit(CB, $FF);
if Mnem = 'jmp' then
CBEmit(CB, MakeModRM(3, 4, Op1.Reg))
else
CBEmit(CB, MakeModRM(3, 2, Op1.Reg));
end
else if IsMemLike(Op1) and Op1.Indirect then
begin
{ Memory-indirect: jmp *disp(%reg) / call *disp(%reg). FF /4 or /2 with
the memory ModRM. }
EmitRexForMem(CB, False, 0, Op1, False);
CBEmit(CB, $FF);
if Mnem = 'jmp' then
EncodeMemOperand(CB, ACtx, Op1, 4)
else
EncodeMemOperand(CB, ACtx, Op1, 2);
CBEmit(CB, MakeModRM(3, 4, Op1.Reg));
end
else
raise EAssembler.Create(Mnem + ': unsupported operand');
@ -1703,17 +1500,6 @@ begin
Exit;
end;
{ ---- xchg / cmpxchg (atomic primitives) ----
AT&T order is `reg, r/m`. xchg has an implicit lock when r/m is memory;
cmpxchg compares r/m against %eax/%rax and conditionally swaps in reg.
Both take the `reg, mem` and `reg, reg` forms the futex mutex needs. }
if (Mnem = 'xchgl') or (Mnem = 'xchgq')
or (Mnem = 'cmpxchgl') or (Mnem = 'cmpxchgq') then
begin
Result := EncodeXchg(CB, ACtx, Mnem, Op1, Op2);
Exit;
end;
{ ---- imulq ---- }
if Mnem = 'imulq' then
begin
@ -1740,24 +1526,22 @@ begin
end;
{ ---- incq / decq ---- }
if (Mnem = 'incq') or (Mnem = 'decq') or
(Mnem = 'incl') or (Mnem = 'decl') then
if (Mnem = 'incq') or (Mnem = 'decq') then
begin
{ FF /0 = inc, /1 = dec; REX.W only for the 'q' (64-bit) forms. }
if Op1.Kind = opReg then
begin
EmitRexIfNeeded(CB, (Mnem = 'incq') or (Mnem = 'decq'), 0, Op1.Reg, False);
EmitRexIfNeeded(CB, True, 0, Op1.Reg, False);
CBEmit(CB, $FF);
if (Mnem = 'incq') or (Mnem = 'incl') then
if Mnem = 'incq' then
CBEmit(CB, MakeModRM(3, 0, Op1.Reg))
else
CBEmit(CB, MakeModRM(3, 1, Op1.Reg));
end
else if IsMemLike(Op1) then
begin
EmitRexForMem(CB, (Mnem = 'incq') or (Mnem = 'decq'), 0, Op1, False);
EmitRexForMem(CB, True, 0, Op1, False);
CBEmit(CB, $FF);
if (Mnem = 'incq') or (Mnem = 'incl') then
if Mnem = 'incq' then
EncodeMemOperand(CB, ACtx, Op1, 0)
else
EncodeMemOperand(CB, ACtx, Op1, 1);
@ -1783,45 +1567,6 @@ begin
Exit;
end;
{ ---- negl / negq ---- (F7 /3, same group as notl/notq) }
if (Mnem = 'negl') or (Mnem = 'negq') then
begin
if Op1.Kind = opReg then
begin
EmitRexIfNeeded(CB, Mnem = 'negq', 0, Op1.Reg, False);
CBEmit(CB, $F7);
CBEmit(CB, MakeModRM(3, 3, Op1.Reg));
end
else
raise EAssembler.Create(Mnem + ': unsupported operand');
Result := CB.Data;
Exit;
end;
{ ---- xaddl / xaddq ---- (0F C1 /r: xadd src-reg, r/m). Atomic with the
lock prefix (emitted above). src register is in the ModRM reg field. }
if (Mnem = 'xaddl') or (Mnem = 'xaddq') then
begin
if (Op1.Kind = opReg) and IsMemLike(Op2) then
begin
EmitRexForMem(CB, Mnem = 'xaddq', Op1.Reg, Op2, False);
CBEmit(CB, $0F);
CBEmit(CB, $C1);
EncodeMemOperand(CB, ACtx, Op2, Op1.Reg and 7);
end
else if (Op1.Kind = opReg) and (Op2.Kind = opReg) then
begin
EmitRexIfNeeded(CB, Mnem = 'xaddq', Op1.Reg, Op2.Reg, False);
CBEmit(CB, $0F);
CBEmit(CB, $C1);
CBEmit(CB, MakeModRM(3, Op1.Reg, Op2.Reg));
end
else
raise EAssembler.Create(Mnem + ': unsupported operand combination');
Result := CB.Data;
Exit;
end;
{ ---- shll/shlq/shrl/shrq ---- }
if (Mnem = 'shll') or (Mnem = 'shlq') or (Mnem = 'shrl') or (Mnem = 'shrq') then
begin
@ -1848,42 +1593,12 @@ begin
or (Mnem = 'cvtsd2ss') or (Mnem = 'cvtss2sd')
or (Mnem = 'cvtsi2sdq') or (Mnem = 'cvtsi2ssq')
or (Mnem = 'cvtsd2si') or (Mnem = 'cvtss2si')
or (Mnem = 'cvttsd2si') or (Mnem = 'cvttss2si')
or (Mnem = 'pxor') or (Mnem = 'movdqa') or (Mnem = 'movdqu')
or (Mnem = 'paddb') or (Mnem = 'pcmpgtb') or (Mnem = 'pcmpeqb')
or (Mnem = 'psadbw') or (Mnem = 'pabsb') then
or (Mnem = 'cvttsd2si') or (Mnem = 'cvttss2si') then
begin
Result := EncodeSSE(CB, ACtx, Mnem, Op1, Op2);
Exit;
end;
{ ---- pshufd $imm8, xmm/m, xmm (66 0F 70 /r ib) ---- }
if Mnem = 'pshufd' then
begin
if (Op1.Kind = opImm) and (Op2.Kind = opReg) and (Op3.Kind = opReg) then
begin
EmitSSERegReg(CB, $66, False, $70, -1, Op2.Reg, Op3.Reg);
CBEmit(CB, Integer(Op1.Imm) and $FF);
end
else
raise EAssembler.Create('pshufd: unsupported operands');
Result := CB.Data;
Exit;
end;
{ ---- AVX/AVX2 (VEX-encoded) ---- }
if (Mnem = 'vzeroupper')
or (Mnem = 'vpxor') or (Mnem = 'vpaddb') or (Mnem = 'vpaddw')
or (Mnem = 'vpaddq') or (Mnem = 'vpcmpeqb') or (Mnem = 'vpcmpgtb')
or (Mnem = 'vpsadbw') or (Mnem = 'vpabsb')
or (Mnem = 'vmovdqa') or (Mnem = 'vmovdqu') or (Mnem = 'vmovd')
or (Mnem = 'vpsllw') or (Mnem = 'vpsrlw') or (Mnem = 'vpshufd')
or (Mnem = 'vextracti128') then
begin
Result := EncodeVEX(CB, ACtx, Mnem, Op1, Op2, Op3);
Exit;
end;
raise EAssembler.Create('unhandled mnemonic: ' + Mnem);
end;
@ -2148,59 +1863,6 @@ begin
raise EAssembler.Create(AMnem + ': unsupported operand combination');
end;
{ ---- XCHG / CMPXCHG encoder ------------------------------------------- }
{ Atomic exchange and compare-exchange. AT&T operand order is `reg, r/m`
(ASrc = the register, ADst = the register or memory target):
xchg %reg, r/m -> 87 /r (mem form is implicitly atomic)
cmpxchg %reg, r/m -> 0F B1 /r
Only the forms the futex mutex needs (reg->reg, reg->mem) are encoded. }
function EncodeXchg(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const ASrc, ADst: TOperand): string;
var
W64, IsCmpxchg: Boolean;
begin
W64 := AMnem[Length(AMnem)] = Ord('q');
IsCmpxchg := (AMnem = 'cmpxchgl') or (AMnem = 'cmpxchgq');
if ASrc.Kind <> opReg then
raise EAssembler.Create(AMnem + ': source must be a register');
{ reg, reg }
if ADst.Kind = opReg then
begin
EmitRexIfNeeded(ACB, W64, ASrc.Reg, ADst.Reg, False);
if IsCmpxchg then
begin
CBEmit(ACB, $0F);
CBEmit(ACB, $B1);
end
else
CBEmit(ACB, $87);
CBEmit(ACB, MakeModRM(3, ASrc.Reg, ADst.Reg));
Result := ACB.Data;
Exit;
end;
{ reg, mem/rip }
if IsMemLike(ADst) then
begin
EmitRexForMem(ACB, W64, ASrc.Reg, ADst, False);
if IsCmpxchg then
begin
CBEmit(ACB, $0F);
CBEmit(ACB, $B1);
end
else
CBEmit(ACB, $87);
EncodeMemOperand(ACB, ACtx, ADst, ASrc.Reg and 7);
Result := ACB.Data;
Exit;
end;
raise EAssembler.Create(AMnem + ': unsupported operand combination');
end;
{ ---- IMUL encoder ----------------------------------------------------- }
function EncodeIMul(var ACB: TCodeBuf; var ACtx: TEncodeContext;
@ -2462,92 +2124,6 @@ begin
raise EAssembler.Create(AMnem + ': not implemented');
end;
{ ---- VEX (AVX/AVX2) helpers ----------------------------------------- }
{ pp (mandatory-prefix) field: 0=none, 1=66, 2=F3, 3=F2. }
function VexPP(APrefix: Integer): Integer;
begin
case APrefix of
$66: Result := 1;
$F3: Result := 2;
$F2: Result := 3;
else
Result := 0;
end;
end;
{ Emit a VEX-encoded instruction. AMap is the opcode map (1 = 0F, 2 = 0F38,
3 = 0F3A). ADstReg goes in ModRM.reg, ARmReg/ARmMem in ModRM.r/m, AVvvv is
the non-destructive source register (the VEX.vvvv field; pass 15 / unused for
two-operand forms). AL256 selects the 256-bit (ymm) form (VEX.L). AW is
VEX.W. The 2-byte form (C5) is used when X=B=0, map=1 and W=0; otherwise the
3-byte form (C4) is required. }
procedure EmitVexRR(var ACB: TCodeBuf; APrefix, AMap: Integer;
AW, AL256: Boolean; AOpcode, ADstReg, AVvvv, ARmReg: Integer);
var
R, X, B, PP, Byte2, Byte3: Integer;
begin
R := Ord(ADstReg >= 8); { ModRM.reg extension }
X := 0;
B := Ord(ARmReg >= 8); { ModRM.r/m extension }
PP := VexPP(APrefix);
if (AMap = 1) and (not AW) and (X = 0) and (B = 0) then
begin
{ 2-byte VEX (C5). Byte2 = ~R<<7 | ~vvvv<<3 | L<<2 | pp }
Byte2 := ((1 - R) shl 7) or (((not AVvvv) and $0F) shl 3)
or (Ord(AL256) shl 2) or PP;
CBEmit(ACB, $C5);
CBEmit(ACB, Byte2 and $FF);
end
else
begin
{ 3-byte VEX (C4). Byte2 = ~R<<7|~X<<6|~B<<5|map ; Byte3 = W<<7|~vvvv<<3|L<<2|pp }
Byte2 := ((1 - R) shl 7) or ((1 - X) shl 6) or ((1 - B) shl 5) or (AMap and $1F);
Byte3 := (Ord(AW) shl 7) or (((not AVvvv) and $0F) shl 3)
or (Ord(AL256) shl 2) or PP;
CBEmit(ACB, $C4);
CBEmit(ACB, Byte2 and $FF);
CBEmit(ACB, Byte3 and $FF);
end;
CBEmit(ACB, AOpcode);
CBEmit(ACB, MakeModRM(3, ADstReg, ARmReg));
end;
{ As EmitVexRR but the r/m operand is memory. }
procedure EmitVexRM(var ACB: TCodeBuf; var ACtx: TEncodeContext;
APrefix, AMap: Integer; AW, AL256: Boolean;
AOpcode, ADstReg, AVvvv: Integer; const AMem: TOperand);
var
R, X, B, PP, Byte2, Byte3, BaseReg: Integer;
begin
BaseReg := AMem.Base;
if BaseReg < 0 then BaseReg := 0;
R := Ord(ADstReg >= 8);
X := Ord(AMem.Index >= 8);
B := Ord(BaseReg >= 8);
PP := VexPP(APrefix);
if (AMap = 1) and (not AW) and (X = 0) and (B = 0) then
begin
Byte2 := ((1 - R) shl 7) or (((not AVvvv) and $0F) shl 3)
or (Ord(AL256) shl 2) or PP;
CBEmit(ACB, $C5);
CBEmit(ACB, Byte2 and $FF);
end
else
begin
Byte2 := ((1 - R) shl 7) or ((1 - X) shl 6) or ((1 - B) shl 5) or (AMap and $1F);
Byte3 := (Ord(AW) shl 7) or (((not AVvvv) and $0F) shl 3)
or (Ord(AL256) shl 2) or PP;
CBEmit(ACB, $C4);
CBEmit(ACB, Byte2 and $FF);
CBEmit(ACB, Byte3 and $FF);
end;
CBEmit(ACB, AOpcode);
EncodeMemOperand(ACB, ACtx, AMem, ADstReg and 7);
end;
{ ---- SSE/FP helpers -------------------------------------------------- }
procedure EmitSSERegReg(var ACB: TCodeBuf; APrefix: Integer;
@ -2624,16 +2200,6 @@ begin
else if AMnem = 'cvtss2si' then begin Prefix := $F3; Opcode1 := $2D; NeedRexW := True; end
else if AMnem = 'cvttsd2si' then begin Prefix := $F2; Opcode1 := $2C; NeedRexW := True; end
else if AMnem = 'cvttss2si' then begin Prefix := $F3; Opcode1 := $2C; NeedRexW := True; end
{ ---- SSE2 packed-integer (128-bit xmm) ---- }
else if AMnem = 'pxor' then begin Prefix := $66; Opcode1 := $EF; end
else if AMnem = 'movdqa' then begin Prefix := $66; Opcode1 := $6F; end
else if AMnem = 'movdqu' then begin Prefix := $F3; Opcode1 := $6F; end
else if AMnem = 'paddb' then begin Prefix := $66; Opcode1 := $FC; end
else if AMnem = 'pcmpgtb' then begin Prefix := $66; Opcode1 := $64; end
else if AMnem = 'pcmpeqb' then begin Prefix := $66; Opcode1 := $74; end
else if AMnem = 'psadbw' then begin Prefix := $66; Opcode1 := $F6; end
{ 3-byte 0F 38 map. }
else if AMnem = 'pabsb' then begin Prefix := $66; Opcode1 := $38; Opcode2 := $1C; end
else
raise EAssembler.Create('SSE: unhandled mnemonic: ' + AMnem);
@ -2685,129 +2251,6 @@ begin
raise EAssembler.Create(AMnem + ': unsupported operand combination');
end;
{ ---- VEX/AVX2 instruction encoder ----------------------------------- }
function EncodeVEX(var ACB: TCodeBuf; var ACtx: TEncodeContext;
const AMnem: string; const AOp1, AOp2, AOp3: TOperand): string;
var
Prefix, Map, Opc: Integer;
W, L: Boolean;
ShiftSub: Integer; { /n in ModRM.reg for the imm-shift forms, else -1 }
begin
{ vzeroupper: C5 F8 77, no operands (vvvv=1111, L=0, pp=0). }
if AMnem = 'vzeroupper' then
begin
CBEmit(ACB, $C5); CBEmit(ACB, $F8); CBEmit(ACB, $77);
Result := ACB.Data;
Exit;
end;
{ VEX.L: 256-bit (ymm) vs 128-bit (xmm), taken from a vector register
operand's width (ymm = 256). Prefer the destination (last operand); fall
back to an earlier vector operand. }
if (AOp3.Kind = opReg) and (AOp3.RegW = 256) then L := True
else if (AOp3.Kind = opReg) and (AOp3.RegW = 128) then L := False
else if (AOp2.Kind = opReg) and (AOp2.RegW = 256) then L := True
else if (AOp1.Kind = opReg) and (AOp1.RegW = 256) then L := True
else L := False;
Prefix := 0; Map := 1; W := False; ShiftSub := -1; Opc := 0;
if AMnem = 'vpxor' then begin Prefix := $66; Opc := $EF; end
else if AMnem = 'vpaddb' then begin Prefix := $66; Opc := $FC; end
else if AMnem = 'vpaddw' then begin Prefix := $66; Opc := $FD; end
else if AMnem = 'vpaddq' then begin Prefix := $66; Opc := $D4; end
else if AMnem = 'vpcmpeqb' then begin Prefix := $66; Opc := $74; end
else if AMnem = 'vpcmpgtb' then begin Prefix := $66; Opc := $64; end
else if AMnem = 'vpsadbw' then begin Prefix := $66; Opc := $F6; end
else if AMnem = 'vpabsb' then begin Prefix := $66; Map := 2; Opc := $1C; end
else if AMnem = 'vmovdqa' then begin Prefix := $66; Opc := $6F; end
else if AMnem = 'vmovdqu' then begin Prefix := $F3; Opc := $6F; end
else if AMnem = 'vpsllw' then begin Prefix := $66; Opc := $71; ShiftSub := 6; end
else if AMnem = 'vpsrlw' then begin Prefix := $66; Opc := $71; ShiftSub := 2; end
else if AMnem = 'vpshufd' then begin Prefix := $66; Opc := $70; end
else if AMnem = 'vextracti128' then begin Prefix := $66; Map := 3; Opc := $39; end
else if AMnem = 'vmovd' then
begin
{ vmovd %xmm, %r32 : 66 VEX.128.0F.W0 7E /r — gp reg in r/m, xmm in reg. }
EmitVexRR(ACB, $66, 1, False, False, $7E, AOp1.Reg, 0, AOp2.Reg);
Result := ACB.Data;
Exit;
end
else
raise EAssembler.Create('VEX: unhandled mnemonic: ' + AMnem);
{ Imm-shift forms: vpsllw $imm, src, dst. ModRM.reg = /ShiftSub, r/m = src,
vvvv = dst; imm8 trails. }
if ShiftSub >= 0 then
begin
if (AOp1.Kind = opImm) and (AOp2.Kind = opReg) and (AOp3.Kind = opReg) then
begin
EmitVexRR(ACB, Prefix, Map, W, L, Opc, ShiftSub, AOp3.Reg, AOp2.Reg);
CBEmit(ACB, Integer(AOp1.Imm) and $FF);
end
else
raise EAssembler.Create(AMnem + ': bad shift operands');
Result := ACB.Data;
Exit;
end;
{ Imm + 2 regs (no vvvv): vpshufd $imm,%src,%dst ; vextracti128 $imm,%src,%dst.
ModRM.reg = src(reg field holds the operand being read), r/m = dst, imm8
trails, vvvv unused (1111). Note for vextracti128 the ENCODING reg/rm
direction is reversed vs vpshufd (it stores ymm-src in reg, xmm-dst in rm),
and VEX.L=1 always (it operates on a 256-bit source despite the xmm dst). }
if AMnem = 'vpshufd' then
begin
if (AOp1.Kind = opImm) and (AOp2.Kind = opReg) and (AOp3.Kind = opReg) then
begin
EmitVexRR(ACB, Prefix, Map, W, L, Opc, AOp3.Reg, 0, AOp2.Reg);
CBEmit(ACB, Integer(AOp1.Imm) and $FF);
end
else
raise EAssembler.Create(AMnem + ': bad operands');
Result := ACB.Data;
Exit;
end;
if AMnem = 'vextracti128' then
begin
if (AOp1.Kind = opImm) and (AOp2.Kind = opReg) and (AOp3.Kind = opReg) then
begin
{ ymm src is in ModRM.reg, xmm dst in r/m; L=1 (256-bit source). }
EmitVexRR(ACB, Prefix, Map, W, True, Opc, AOp2.Reg, 0, AOp3.Reg);
CBEmit(ACB, Integer(AOp1.Imm) and $FF);
end
else
raise EAssembler.Create(AMnem + ': bad operands');
Result := ACB.Data;
Exit;
end;
{ Two-operand (no vvvv): vpabsb %src,%dst ; vmovdqa/vmovdqu %src/mem,%dst. }
if AOp3.Kind = opNone then
begin
if (AOp1.Kind = opReg) and (AOp2.Kind = opReg) then
EmitVexRR(ACB, Prefix, Map, W, L, Opc, AOp2.Reg, 0, AOp1.Reg)
else if IsMemLike(AOp1) and (AOp2.Kind = opReg) then
EmitVexRM(ACB, ACtx, Prefix, Map, W, L, Opc, AOp2.Reg, 0, AOp1)
else
raise EAssembler.Create(AMnem + ': bad 2-operand form');
Result := ACB.Data;
Exit;
end;
{ Three-operand: vpaddb %src2,%src1,%dst. ModRM.reg = dst, vvvv = src1,
r/m = src2 (reg or mem). }
if (AOp1.Kind = opReg) and (AOp2.Kind = opReg) and (AOp3.Kind = opReg) then
EmitVexRR(ACB, Prefix, Map, W, L, Opc, AOp3.Reg, AOp2.Reg, AOp1.Reg)
else if IsMemLike(AOp1) and (AOp2.Kind = opReg) and (AOp3.Kind = opReg) then
EmitVexRM(ACB, ACtx, Prefix, Map, W, L, Opc, AOp3.Reg, AOp2.Reg, AOp1)
else
raise EAssembler.Create(AMnem + ': bad 3-operand form');
Result := ACB.Data;
end;
{ Encode `movq`/`movd` moving between an XMM register and a GP register or
memory. The XMM operand is always the ModRM.reg field:
xmm <- gp/mem : 66 [REX.W] 0F 6E /r (load into xmm)
@ -2866,7 +2309,6 @@ var
FVal: Single;
DataOp: TOperand;
OpEnd: Integer;
Count, Size, FillVal, J: Integer;
begin
Dir := AParsed.Mnemonic;
Args := TrimStr(AParsed.RawLine);
@ -2891,8 +2333,6 @@ begin
ASection := eskTbss
else if StartsWithStr(Args, '.note.GNU-stack') then
Exit
else if StartsWithStr(Args, '.data') then
ASection := eskData
else if StartsWithStr(Args, '.bss') then
ASection := eskBss
else if StartsWithStr(Args, '.opdf') then
@ -2990,34 +2430,6 @@ begin
Exit;
end;
{ .fill <count>, <size>, <value> — emit <count> copies of a <size>-byte
little-endian <value>. Used for SIMD threshold constant blocks
(e.g. `.fill 32, 1, 0xBF`). size/value default to 1/0 if omitted (GNU as),
but the RTL always supplies all three. }
if Dir = '.fill' then
begin
P := 0;
Len := Length(Args);
while (P < Len) and ((Args[P] = Ord(' ')) or (Args[P] = Ord(#9))) do P := P + 1;
Val := ParseInt(Args, P); { count }
Count := Integer(Val);
Size := 1; FillVal := 0;
while (P < Len) and ((Args[P] = Ord(' ')) or (Args[P] = Ord(#9)) or
(Args[P] = Ord(','))) do P := P + 1;
if P < Len then
begin
Size := Integer(ParseInt(Args, P)); { size }
while (P < Len) and ((Args[P] = Ord(' ')) or (Args[P] = Ord(#9)) or
(Args[P] = Ord(','))) do P := P + 1;
if P < Len then
FillVal := Integer(ParseInt(Args, P)); { value }
end;
for I := 0 to Count - 1 do
for J := 0 to Size - 1 do
AWriter.AppendByte(ASection, (FillVal shr (J * 8)) and $FF);
Exit;
end;
{ .int is an alias for .long: GNU as treats both as a 32-bit value on
x86-64. The OPDF debug emitter uses .int, so accept it here. }
if (Dir = '.long') or (Dir = '.int') then

349
compiler/src/main/pascal/blaise.codegen.driver.pas
View file

@ -88,21 +88,6 @@ type
UseInternalLinker: Boolean; { --linker internal (native backend) }
LinkerExplicit: Boolean; { True when user passed --linker }
LinkerChoiceBad: Boolean; { --linker value not 'internal' or 'external' }
RTLSrcDir: string; { --rtl-src DIR: explicit RTL source directory.
Overrides the binary/CWD-relative lookup, for
a relocated/release binary whose RTL source
lives elsewhere (empty = use default lookup) }
Static: Boolean; { --static: link a freestanding, libc-free ELF
(native internal linker only). The kernel
leaf (runtime.syscall.<os> + runtime.cstub +
runtime.start.static.<os>) replaces libc; the
linker emits a non-PIE ET_EXEC with no
PT_INTERP. docs/linux-syscall-migration.adoc }
LinkLibs: TStringList; { extra libraries to link (-l<name>), unioned by
the frontend from the program's and its used
units' 'external ''lib''' declarations
(TUnitInterface.LinkLibs). nil = none. Owned;
ARC-released with the opts object. }
end;
TBackendDriver = class
@ -204,41 +189,10 @@ type
{ Shared link line: cc-driver resolved via uToolchain (env overrides
and target awareness apply), input file, OPDF sidecar, extra
objects, the RTL objects, -lm, -lpthread. Used by every driver's
objects, RTL archive, -lm, -lpthread. Used by every driver's
LinkProgram. }
function LinkViaToolchain(const AInputFile, AOutputFile: string;
AOpts: TBackendOpts; AExtraObjects: TStringList): string;
{ Compile the implicit RTL units (runtime.* + rtl.platform.*) from source
into a per-compiler object cache and return their .o paths in AObjPaths
(link order). A unit is (re)compiled only when its cached .o is missing
or older than the source. Replaces the pre-built blaise_rtl.a — the RTL
is built from source by the compiler itself (docs/rtl-unification-plan.adoc).
Both the cc link line and the native internal linker call this.
RTL units carry inline asm, so they are always built with the native
backend + internal assembler. Building goes through a --unit-cache so a
unit that uses another RTL unit references its globals externally instead
of re-defining them — without that, the per-unit objects clash on
duplicate global definitions when linked directly (the archive's member
selection used to hide this). The cache also auto-builds intermediate
deps (e.g. rtl.platform), which are collected too.
AIncludeStartup controls whether runtime.start.o (which defines the bare
`_start` entry) is included. The native internal linker needs it (Blaise
owns the entry point); the cc/QBE link line must omit it (libc's startup
provides `_start` and calls `main`), or the two `_start`s collide.
AAlreadyProvided lists object paths the caller already puts on the link
line (the program's own prebuilt/incremental deps). A program that uses
an RTL unit (e.g. `uses classes` pulls runtime.arc) compiles that unit
into its own object cache, so supplying our copy too would double-define
it. Any RTL unit whose <name>.o basename matches an entry here is skipped.
Pass nil when the caller adds no objects of its own.
Returns '' on success, else an error message. }
function EnsureRTLObjects(AOpts: TBackendOpts; AIncludeStartup: Boolean;
AAlreadyProvided, AObjPaths: TStringList): string;
end;
{ Run an external tool, capturing combined output. Shared by the
@ -247,22 +201,6 @@ type
function RunProcess(const AExe: string; AArgs: TStringList;
out AOutput: string): Integer;
{ Build the leaf-first RTL unit list for a target. The base list is shared;
the OS-specific bits are selected from AOS:
* the platform-layout adapter (rtl.platform.layout.<os>), and
* for a --static (freestanding, no-libc) link, the kernel leaf that
replaces libc — the freestanding runtime.start.static.<os> in place of
the libc runtime.start, plus runtime.syscall.<os> / runtime.libc.<os> /
runtime.libc2.<os> / runtime.thread.static.<os> and the OS-invariant
runtime.cstub.
A dynamic (libc) link keeps the plain list with only the layout adapter
swapped. Exposed for unit testing; EnsureRTLObjects drives it off
AOpts.Static and AOpts.Target.OS. Caller owns and frees the result. }
function BuildRTLUnitList(AStatic: Boolean;
AOS: TTargetOS): TStringList;
{ Format one --help flag line with the shared 2-space indent and flag
column. Single source of truth for the column width so the common
usage block (Blaise.pas PrintUsage) and each driver's DescribeOptions
@ -300,48 +238,8 @@ implementation
uses
SysUtils,
Process,
blaise.elfreader,
uToolchain;
{ Process id + directory removal, for the per-process private RTL build
directory. Declared directly rather than via GRtlPlatform to avoid a
unit-initialisation-order dependency (this unit may run before the platform
layer assigns GRtlPlatform). }
function _driver_getpid: Integer; external name 'getpid';
function _driver_rmdir(APath: PChar): Integer; external name 'rmdir';
{ Collect the names of all symbols an ELF object DEFINES with global or weak
binding (STB_GLOBAL/STB_WEAK and Shndx not SHN_UNDEF) into ADest.
Used by EnsureRTLObjects to decide, by symbol rather than by filename,
whether an RTL unit is already supplied by the program's own objects. Any
read/parse failure (non-ELF target, truncated file) leaves ADest unchanged —
the caller then falls back to supplying its copy, which is always safe. }
procedure CollectDefinedSymbols(const AObjPath: string; ADest: TStringList);
var
Obj: TElfObjectFile;
I: Integer;
Sym: TRdSymbol;
begin
Obj := nil;
try
try
Obj := ReadElfObjectFile(AObjPath);
except
Exit; { not a readable ELF object — be conservative }
end;
for I := 0 to Obj.Symbols.Count - 1 do
begin
Sym := Obj.Symbols.Get(I);
if (Sym.Name <> '') and (Sym.Shndx <> SHN_UNDEF) and
((Sym.Bind = STB_GLOBAL) or (Sym.Bind = STB_WEAK)) then
if ADest.IndexOf(Sym.Name) < 0 then
ADest.Add(Sym.Name);
end;
finally
Obj.Free();
end;
end;
{ Indexed by Ord(TBackendKind). The bound is a literal because the
parser only accepts integer literals on array decls; keep the upper
bound in sync with the enum's highest ordinal (bkNative = 1). }
@ -434,238 +332,28 @@ begin
' backend does not support per-unit object lowering';
end;
{ The implicit RTL units, in dependency/link order (leaf-first). The compiler
emits calls to their symbols (_SetArgs, _BlaiseGetMem, _start, ARC helpers, …)
in every program, so every program links them. Names are the dotted-flat
unit names; the source files are <name>.pas in the RTL source directory.
rtl.platform is the base abstraction layout.linux + posix both use; it owns
the shared globals (GPlatformLayout, GRtlPlatform) so it must be built first
and linked once. }
const
RTL_UNITS: array[0..14] of string = (
'rtl.platform',
'runtime.start', 'runtime.atomic', 'runtime.setjmp', 'runtime.utf8',
'runtime.mem', 'runtime.str', 'runtime.set', 'runtime.arc',
'runtime.weak', 'runtime.float', 'runtime.thread', 'runtime.exc',
'rtl.platform.layout.linux', 'rtl.platform.posix');
{ Lower-case OS suffix used in the OS-specific RTL unit names
(rtl.platform.layout.<os>, runtime.syscall.<os>, …). }
function RTLOSSuffix(AOS: TTargetOS): string;
begin
case AOS of
osFreeBSD: Result := 'freebsd';
else
{ Linux is the default host leaf; other OSes gain their own suffix as
their adapter set lands. }
Result := 'linux';
end;
end;
function BuildRTLUnitList(AStatic: Boolean; AOS: TTargetOS): TStringList;
var
I: Integer;
OS: string;
begin
OS := RTLOSSuffix(AOS);
Result := TStringList.Create();
{ The base list, in leaf-first order. Two OS-specific substitutions:
the platform-layout adapter always follows the target, and for a --static
link the libc entry point (runtime.start) is replaced by the freestanding
per-OS start. A dynamic link keeps runtime.start. }
for I := 0 to High(RTL_UNITS) do
if SameText(RTL_UNITS[I], 'rtl.platform.layout.linux') then
Result.Add('rtl.platform.layout.' + OS)
else if AStatic and SameText(RTL_UNITS[I], 'runtime.start') then
Result.Add('runtime.start.static.' + OS)
else
Result.Add(RTL_UNITS[I]);
{ The freestanding kernel leaf that replaces libc under --static: the raw
syscall stubs, the OS-invariant freestanding C functions (runtime.cstub),
the libc-shim layers, and the static-TLS thread leaf. }
if AStatic then
begin
Result.Add('runtime.syscall.' + OS);
Result.Add('runtime.cstub');
Result.Add('runtime.libc.' + OS);
Result.Add('runtime.libc2.' + OS);
Result.Add('runtime.thread.static.' + OS);
end;
end;
function TBackendDriver.EnsureRTLObjects(AOpts: TBackendOpts;
AIncludeStartup: Boolean; AAlreadyProvided, AObjPaths: TStringList): string;
var
SrcDir, CacheDir, BuildDir, BlaiseBin: string;
SrcFile, ObjFile, TmpObj: string;
I, J, ExitCode: Integer;
Args: TStringList;
Msg: string;
ProvidedSyms, MySyms, Units: TStringList;
Redundant: Boolean;
begin
Result := '';
{ Collect every symbol the caller's own objects already DEFINE (the program's
prebuilt/incremental deps). An RTL unit the program compiled itself (e.g.
`uses classes` pulls runtime.arc) is already on the link line; supplying our
copy too would double-define it. Match by symbol rather than by filename so
a same-named-but-different object (e.g. a stale mangled cache entry) does NOT
suppress the real provider — this mirrors the old archive's member
selection. }
ProvidedSyms := TStringList.Create();
ProvidedSyms.CaseSensitive := True;
ProvidedSyms.Sorted := True;
ProvidedSyms.Duplicates := dupIgnore;
MySyms := TStringList.Create();
if AAlreadyProvided <> nil then
for J := 0 to AAlreadyProvided.Count - 1 do
CollectDefinedSymbols(AAlreadyProvided.Strings[J], ProvidedSyms);
try
{ RTL source lives in the compiler's own source tree. Resolution order:
1. --rtl-src DIR (AOpts.RTLSrcDir) — explicit, for a relocated binary;
2. $BLAISE_RTL_SRC;
3. binary/CWD-relative default (RTLSourceDir). }
if AOpts.RTLSrcDir <> '' then
SrcDir := ExpandFileName(AOpts.RTLSrcDir)
else
begin
SrcDir := GetEnvironmentVariable('BLAISE_RTL_SRC');
if SrcDir = '' then
SrcDir := ExpandFileName(RTLSourceDir());
end;
if not DirectoryExists(SrcDir) then
Exit('RTL source directory not found (' + SrcDir +
'); pass --rtl-src DIR or set $BLAISE_RTL_SRC to compiler/src/main/pascal');
{ Object cache lives beside the compiler binary so repeated program builds
reuse it (compiler/target/rtl/). The shared cache is read for reuse and is
the link source, but the actual build happens in a per-process private
sub-directory (rtl/build-<pid>/) and finished objects are atomically renamed
into the shared cache. This keeps cross-build reuse while making concurrent
builders (e.g. parallel e2e suites all warming a cold cache) race-free: a
reader never sees a half-written object, and two builders just publish
identical results, last-writer-wins. }
CacheDir := IncludeTrailingPathDelimiter(CompilerBinDir()) + 'rtl';
ForceDirectories(CacheDir);
BuildDir := IncludeTrailingPathDelimiter(CacheDir) + 'build-' +
IntToStr(_driver_getpid());
ForceDirectories(BuildDir);
BlaiseBin := ParamStr(0);
{ The unit list to build/link, in leaf-first order. Selection is driven off
the target (AOpts.Target.OS) and link mode: the platform layout adapter
follows the target, and a static link swaps in the freestanding per-OS
kernel leaf (start / syscall / libc shims / thread) in place of libc. A
freestanding target (FreeBSD, Strategy B) has no libc, so it is static
regardless of the --static flag. See BuildRTLUnitList. }
Units := BuildRTLUnitList(
AOpts.Static or TargetIsFreestanding(AOpts.Target), AOpts.Target.OS);
for I := 0 to Units.Count - 1 do
begin
SrcFile := IncludeTrailingPathDelimiter(SrcDir) + Units.Strings[I] + '.pas';
ObjFile := IncludeTrailingPathDelimiter(CacheDir) + Units.Strings[I] + '.o';
if not FileExists(SrcFile) then
Exit('RTL unit source missing: ' + SrcFile);
{ Recompile only when the shared cached object is missing or stale. Build
into the private BuildDir (its own --unit-cache so each unit's RTL deps
are referenced externally and intermediate deps are built leaf-first),
then atomically rename the result into the shared CacheDir. RTL units
carry inline asm, so the native backend + internal assembler is mandatory. }
if (not FileExists(ObjFile)) or (FileAge(ObjFile) < FileAge(SrcFile)) then
begin
TmpObj := IncludeTrailingPathDelimiter(BuildDir) + Units.Strings[I] + '.o';
Args := TStringList.Create();
try
Args.Add('--backend'); Args.Add('native');
Args.Add('--assembler'); Args.Add('internal');
Args.Add('--source'); Args.Add(SrcFile);
Args.Add('--unit-path'); Args.Add(SrcDir);
Args.Add('--unit-cache'); Args.Add(BuildDir);
Args.Add('--output'); Args.Add(TmpObj);
ExitCode := RunProcess(BlaiseBin, Args, Msg);
finally
Args.Free();
end;
if ExitCode <> 0 then
Exit('failed to build RTL unit ' + Units.Strings[I] +
' (exit ' + IntToStr(ExitCode) + '): ' + Msg);
{ Publish atomically. RenameFile within the same directory tree is an
atomic rename(2); a concurrent builder doing the same is harmless. }
if not RenameFile(TmpObj, ObjFile) then
Exit('failed to publish RTL object ' + ObjFile);
end;
{ runtime.start defines the bare _start entry — include it only for the
native internal linker (Blaise owns the entry); the cc link line gets
_start from libc and must omit it to avoid a multiple-definition. }
if SameText(Units.Strings[I], 'runtime.start') and (not AIncludeStartup) then
Continue;
{ Skip this RTL object if EVERY symbol it defines is already defined by the
caller's objects — i.e. the program compiled this RTL unit itself. A
partially-overlapping object is still supplied (its unique symbols are
needed); the linker resolves the shared ones to the first definition.
The unit is always built above so later RTL units that depend on it
resolve against our cache's iface. }
if ProvidedSyms.Count > 0 then
begin
MySyms.Clear();
CollectDefinedSymbols(ObjFile, MySyms);
Redundant := MySyms.Count > 0;
for J := 0 to MySyms.Count - 1 do
if ProvidedSyms.IndexOf(MySyms.Strings[J]) < 0 then
begin
Redundant := False;
Break;
end;
if Redundant then
Continue;
end;
AObjPaths.Add(ObjFile);
end;
{ Tidy the private build directory. The published .o files live in the shared
cache now; the build dir holds only intermediate .bif/.o stragglers. Remove
the known per-unit artefacts and the (now-empty) directory. Best-effort —
a leftover dir is harmless. }
for I := 0 to Units.Count - 1 do
begin
DeleteFile(IncludeTrailingPathDelimiter(BuildDir) + Units.Strings[I] + '.o');
DeleteFile(IncludeTrailingPathDelimiter(BuildDir) + Units.Strings[I] + '.bif');
end;
_driver_rmdir(PChar(ExcludeTrailingPathDelimiter(BuildDir)));
Units.Free();
finally
ProvidedSyms.Free();
MySyms.Free();
end;
end;
function TBackendDriver.LinkViaToolchain(const AInputFile, AOutputFile: string;
AOpts: TBackendOpts; AExtraObjects: TStringList): string;
var
TC: TToolchain;
Args: TStringList;
RTLObjs: TStringList;
Msg, RTLErr: string;
Msg: string;
ExitCode: Integer;
I: Integer;
begin
Result := '';
{ Every Blaise program links the implicit RTL units (runtime.* +
rtl.platform.*). They are no longer shipped as a pre-built blaise_rtl.a;
the compiler builds them from source into a per-compiler object cache
(EnsureRTLObjects) and links the resulting .o files directly. This is the
same RTL the native internal linker uses — one source of truth. }
TC := ResolveToolchain(AOpts.Target);
{ Every Blaise program needs blaise_rtl.a; an empty RTLPath means it was not
found beside the compiler binary or via $BLAISE_RTL. Linking without it
yields a flood of undefined-reference errors from the external linker (or,
on the internal linker, a silently broken binary) — fail with a clear
message instead. }
if TC.RTLPath = '' then
Exit('runtime archive blaise_rtl.a not found '
+ '(looked beside the compiler binary and in $BLAISE_RTL); '
+ 'cannot link a Blaise program without the RTL');
Args := TStringList.Create();
RTLObjs := TStringList.Create();
try
{ cc link line: libc supplies _start, so omit runtime.start. Pass the
program's prebuilt deps so an RTL unit it compiled itself (e.g. via
`uses classes`) is not supplied twice. }
RTLErr := Self.EnsureRTLObjects(AOpts, False, AExtraObjects, RTLObjs);
if RTLErr <> '' then
Exit(RTLErr);
Args.Add('-o');
Args.Add(AOutputFile);
Args.Add(AInputFile);
@ -680,20 +368,11 @@ begin
if AExtraObjects <> nil then
for I := 0 to AExtraObjects.Count - 1 do
Args.Add(AExtraObjects.Strings[I]);
{ RTL objects, in link order. }
for I := 0 to RTLObjs.Count - 1 do
Args.Add(RTLObjs.Strings[I]);
Args.Add(TC.RTLPath);
Args.Add('-lm'); { math functions (sqrt, sin, cos, etc.) }
Args.Add('-lpthread'); { POSIX threads (blaise_thread unit) }
{ Libraries declared via 'external ''lib''' in the program or any used unit
(unioned by the frontend into AOpts.LinkLibs). Emitted as -l<name> — ld
expands to lib<name>.so/.a. Additive to the always-needed -lm/-lpthread. }
if AOpts.LinkLibs <> nil then
for I := 0 to AOpts.LinkLibs.Count - 1 do
Args.Add('-l' + AOpts.LinkLibs.Strings[I]);
ExitCode := RunProcess(Self.ToolPath('linker', AOpts.Target), Args, Msg);
finally
RTLObjs.Free();
Args.Free();
end;
if ExitCode <> 0 then

146
compiler/src/main/pascal/blaise.codegen.native.backend.pas
View file

@ -160,41 +160,167 @@ end;
procedure TNativeBackend.EmitBlank;
begin
FAsm.AppendLine();
FAsm.AppendLine;
end;
{ The record-return ABI classifier and its leaf predicates now live as shared
free functions in blaise.codegen (byte-identical to the QBE backend's former
twin). These methods delegate so existing Self.X call sites are unchanged. }
function TNativeBackend.IsRecordManagedClean(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := RecretManagedClean(ARec);
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyString, tyClass, tyInterface, tyDynArray:
Exit;
tyRecord:
if not Self.IsRecordManagedClean(TRecordTypeDesc(F.TypeDesc)) then Exit;
end;
end;
Result := True;
end;
function TNativeBackend.IsRecordAllIntegerLeaves(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := RecretAllIntegerLeaves(ARec);
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyInteger, tyInt64, tyUInt32, tyUInt64,
tySmallInt, tyWord, tyByte, tyBoolean,
tyEnum, tyPointer, tyProcedural, tyMetaClass:
;
tyRecord:
if not Self.IsRecordAllIntegerLeaves(TRecordTypeDesc(F.TypeDesc)) then Exit;
else
Exit;
end;
end;
Result := True;
end;
function TNativeBackend.IsRecordAllFloatLeaves(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := RecretAllFloatLeaves(ARec);
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyDouble, tySingle: ;
tyRecord:
if not Self.IsRecordAllFloatLeaves(TRecordTypeDesc(F.TypeDesc)) then Exit;
else
Exit;
end;
end;
Result := True;
end;
function TNativeBackend.IsRecordAllIntOrFloatLeaves(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := RecretAllIntOrFloatLeaves(ARec);
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyInteger, tyInt64, tyUInt32, tyUInt64,
tySmallInt, tyWord, tyByte, tyBoolean,
tyEnum, tyPointer, tyProcedural, tyMetaClass,
tyDouble, tySingle: ;
tyRecord:
if not Self.IsRecordAllIntOrFloatLeaves(TRecordTypeDesc(F.TypeDesc)) then Exit;
else
Exit;
end;
end;
Result := True;
end;
function TNativeBackend.EightbyteIsSSE(ARec: TRecordTypeDesc;
AStartByte: Integer): Boolean;
var
I, Off: Integer;
F: TFieldInfo;
begin
Result := RecretEightbyteIsSSE(ARec, AStartByte);
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
Off := F.Offset;
if (Off < AStartByte) or (Off >= AStartByte + 8) then Continue;
case F.TypeDesc.Kind of
tyDouble, tySingle:
Exit(True);
tyRecord:
if Self.EightbyteIsSSE(TRecordTypeDesc(F.TypeDesc),
AStartByte - Off) then Exit(True);
end;
end;
end;
function TNativeBackend.ClassifyRecordReturn(ARec: TRecordTypeDesc): TRecReturnClass;
var
Sz: Integer;
Eb0SSE, Eb1SSE: Boolean;
begin
Result := RecretClassify(ARec, FTarget);
Result := rcSret;
if (ARec = nil) or (ARec.Kind <> tyRecord) then Exit;
if ARec.Fields.Count = 0 then Exit;
if not Self.IsRecordManagedClean(ARec) then Exit;
Sz := ARec.TotalSize();
if FTarget.OS = osWindows then
begin
if Self.IsRecordAllIntOrFloatLeaves(ARec) then
Result := rcWin64Agg;
Exit;
end;
if Self.IsRecordAllIntegerLeaves(ARec) then
begin
case Sz of
1, 2, 4, 8: Result := rcInt1;
9, 10, 11, 12, 13, 14, 15, 16: Result := rcInt2;
end;
Exit;
end;
if Self.IsRecordAllFloatLeaves(ARec) then
begin
case Sz of
4, 8: Result := rcSSE1;
9, 10, 11, 12, 13, 14, 15, 16: Result := rcSSE2;
end;
Exit;
end;
if not Self.IsRecordAllIntOrFloatLeaves(ARec) then Exit;
case Sz of
9, 10, 11, 12, 13, 14, 15, 16:
begin
Eb0SSE := Self.EightbyteIsSSE(ARec, 0);
Eb1SSE := Self.EightbyteIsSSE(ARec, 8);
if (not Eb0SSE) and Eb1SSE then Result := rcIntSSE
else if Eb0SSE and (not Eb1SSE) then Result := rcSSEInt;
end;
end;
end;
function TNativeBackend.GenerateProgram(AProg: TProgram): string;

108
compiler/src/main/pascal/blaise.codegen.native.driver.pas
View file

@ -69,8 +69,6 @@ type
private
function LinkViaInternalLinker(const AObjFile, AOutputFile: string;
AOpts: TBackendOpts; AExtraObjects: TStringList): string;
{ EnsureRTLObjects is inherited from TBackendDriver — both the native
internal linker and the cc link line build the RTL the same way. }
end;
implementation
@ -78,7 +76,6 @@ implementation
uses
SysUtils, Classes,
uToolchain,
blaise.codegen.toolkit,
blaise.assembler.x86_64,
blaise.elfreader,
blaise.linker.elf;
@ -190,91 +187,58 @@ function TNativeBackendDriver.LinkViaInternalLinker(
var
Lk: TLinker;
Obj: TElfObjectFile;
Toolkit: TTargetToolkit;
LinkTarget: TLinkTarget;
RTLObjs: TStringList;
TC: TToolchain;
Crt1, Crti, Crtn, CrtBeginS, CrtEndS: string;
I: Integer;
begin
Result := '';
if not FindCrtObjects(Crt1, Crti, Crtn, CrtBeginS, CrtEndS) then
Exit('internal linker: CRT startup objects not found');
{ The internal linker links only Blaise ELF objects (+ the source-built RTL);
it has no concept of -l<name> system libraries. A program that declares an
`external 'lib'` dependency therefore cannot be linked this way — fail loudly
rather than silently drop the library and emit a binary with unresolved
symbols. Use the external toolchain linker (the default) for such programs. }
if (AOpts.LinkLibs <> nil) and (AOpts.LinkLibs.Count > 0) then
Exit('internal linker cannot resolve external library ''' +
AOpts.LinkLibs.Strings[0] +
''' (from an ''external ''''lib'''''' declaration); use --linker external');
TC := ResolveToolchain(AOpts.Target);
{ Build the linker with the resolved target's TLinkTarget so the emitted ELF
carries the right EI_OSABI / machine / load base for AOpts.Target — without
this the internal linker always produced a Linux-shaped ELF regardless of
--target. The toolkit is the single source of per-target link facts
(docs/native-target-architecture.adoc). }
Toolkit := ResolveToolkit(AOpts.Target);
if Toolkit = nil then
Exit('internal linker: no toolkit registered for target ' +
TargetName(AOpts.Target));
{ Every Blaise program links blaise_rtl.a — the program entry emits
_SetArgs and the runtime supplies ARC, strings, exceptions, the platform
layer, etc. An empty RTLPath means FindRTLArchive could not locate
blaise_rtl.a beside the compiler binary (or via BLAISE_RTL). Linking
anyway is never correct: every RTL symbol becomes an undefined dynamic
import that silently links but dies at run time (e.g. `undefined symbol:
_SetArgs`). Fail loudly instead of emitting a broken executable. }
if TC.RTLPath = '' then
Exit('internal linker: runtime archive blaise_rtl.a not found '
+ '(looked beside the compiler binary and in $BLAISE_RTL); '
+ 'cannot link a Blaise program without the RTL');
{ Build the implicit RTL objects from source (cached beside the compiler).
Every Blaise program emits calls to RTL symbols (_SetArgs, _BlaiseGetMem,
_start, ARC/string/exception helpers, …) as undefined externals; these
objects supply them. Replaces the pre-built blaise_rtl.a — the RTL is now
compiled by the compiler itself. }
RTLObjs := TStringList.Create();
Lk := TLinker.Create();
try
{ Native internal linker: Blaise owns the entry point, so include
runtime.start (its bare _start). In --static mode EnsureRTLObjects swaps
runtime.start for the freestanding runtime.start.static.<os> and adds the
syscall + cstub leaves, so AIncludeStartup is irrelevant there. Pass the
program's prebuilt deps so an RTL unit it compiled itself is not supplied
twice. }
Result := Self.EnsureRTLObjects(AOpts, True, AExtraObjects, RTLObjs);
if Result <> '' then Exit;
{ TLinker.Create(ATarget) borrows the target — we own and free it here. }
LinkTarget := Toolkit.MakeLinkTarget();
Lk := TLinker.Create(LinkTarget);
try
try
{ --static: freestanding non-PIE ET_EXEC, no libc/PT_INTERP (the kernel
leaf supplies open/read/write/... + _start). Default: dynamic PIE
linked against libc. A freestanding target (FreeBSD, Strategy B) has
no libc to link against, so it is ALWAYS static regardless of the
--static flag — the kernel leaf is the only libc it gets. }
Lk.SetDynamic(not (AOpts.Static or TargetIsFreestanding(AOpts.Target)));
Lk.SetDynamic(True);
Lk.AddCrtObject(Crt1);
Lk.AddCrtObject(Crti);
Lk.AddCrtObject(CrtBeginS);
Obj := ReadElfObjectFile(AObjFile);
Lk.AddOwnedObject(Obj);
Obj := ReadElfObjectFile(AObjFile);
Lk.AddOwnedObject(Obj);
if AExtraObjects <> nil then
for I := 0 to AExtraObjects.Count - 1 do
begin
Obj := ReadElfObjectFile(AExtraObjects.Strings[I]);
Lk.AddOwnedObject(Obj);
end;
{ The RTL objects — including _start (runtime.start) and the implicit
runtime symbols — built from source above. }
for I := 0 to RTLObjs.Count - 1 do
if AExtraObjects <> nil then
for I := 0 to AExtraObjects.Count - 1 do
begin
Obj := ReadElfObjectFile(RTLObjs.Strings[I]);
Obj := ReadElfObjectFile(AExtraObjects.Strings[I]);
Lk.AddOwnedObject(Obj);
end;
Lk.Link('_start', AOutputFile);
except
on E: Exception do
Result := 'internal linker error [' + Exception(E).ClassName + ']: ' +
Exception(E).Message;
end;
finally
Lk.Free();
LinkTarget.Free();
Lk.AddArchive(TC.RTLPath);
Lk.AddCrtObject(CrtEndS);
Lk.AddCrtObject(Crtn);
Lk.Link('_start', AOutputFile);
except
on E: Exception do
Result := 'internal linker error [' + Exception(E).ClassName + ']: ' +
Exception(E).Message;
end;
finally
RTLObjs.Free();
Lk.Free();
end;
end;

13
compiler/src/main/pascal/blaise.codegen.native.pas
View file

@ -76,24 +76,19 @@ function CreateNativeBackend(const ATarget: TTargetDesc): TNativeBackend;
implementation
uses
blaise.codegen.toolkit;
blaise.codegen.native.x86_64;
{ ------------------------------------------------------------------ }
{ Backend factory }
{ ------------------------------------------------------------------ }
function CreateNativeBackend(const ATarget: TTargetDesc): TNativeBackend;
var
Toolkit: TTargetToolkit;
begin
{ Resolve the per-target adapter family from the registry (Abstract
Factory). Adding a target is a new toolkit + one registration — this
dispatch never changes. See docs/native-target-architecture.adoc. }
Toolkit := ResolveToolkit(ATarget);
if Toolkit = nil then
if (ATarget.OS = osLinux) and (ATarget.CPU = cpuX86_64) then
Result := TX86_64Backend.Create(ATarget)
else
raise ENativeCodeGenError.Create(
'native backend not yet implemented for target ' + TargetName(ATarget));
Result := Toolkit.MakeBackend();
end;
{ ------------------------------------------------------------------ }

2890
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

File diff suppressed because it is too large Load diff

312
compiler/src/main/pascal/blaise.codegen.pas
View file

@ -27,7 +27,7 @@ unit blaise.codegen;
interface
uses
uAST, uSymbolTable, uDebugFacts, blaise.codegen.target, uStrCompat;
uAST, uSymbolTable, uDebugFacts;
type
TRecReturnClass = (
@ -91,316 +91,6 @@ type
function GetOutput: string;
end;
{ ----------------------------------------------------------------------
Shared System V / Win64 record-return ABI classifier.
Both the QBE backend and the native x86-64 backend must agree, byte for
byte, on how a record-typed return value is passed (sret vs register, and
which register class). The decision is a pure walk over the record's field
layout plus the target OS — no backend state — so it lives here as free
functions that both backends call, instead of being carried as two
drift-prone twins. Only RecretClassify consults the target (the Win64
aggregate rule); the leaf predicates are target-independent type walks. }
{ True when ARec (and every nested record) contains no managed fields
(string / class / interface / dynamic array) — a precondition for any
register return. }
function RecretManagedClean(ARec: TRecordTypeDesc): Boolean;
{ True when every leaf field is an integer-class scalar (or a nested record
thereof). }
function RecretAllIntegerLeaves(ARec: TRecordTypeDesc): Boolean;
{ True when every leaf field is a float (Double/Single) or a nested record
thereof. }
function RecretAllFloatLeaves(ARec: TRecordTypeDesc): Boolean;
{ True when every leaf field is an integer- or float-class scalar. }
function RecretAllIntOrFloatLeaves(ARec: TRecordTypeDesc): Boolean;
{ True when the eightbyte starting at AStartByte holds any float leaf — i.e.
the eightbyte is SSE-classified under the SysV mixed-class rules. }
function RecretEightbyteIsSSE(ARec: TRecordTypeDesc; AStartByte: Integer): Boolean;
{ Classify ARec's return-passing for ATarget's OS. }
function RecretClassify(ARec: TRecordTypeDesc;
const ATarget: TTargetDesc): TRecReturnClass;
{ ----------------------------------------------------------------------
Shared ARC ownership-transfer predicate.
True when AExpr, used as an r-value, leaves an ARC-managed value at
refcount +1 that the consuming site must NOT AddRef again (it consumes the
transferred reference). Covers function/method calls and method-backed
property reads returning a class, string, or dynamic array. The decision is
a pure walk over the AST node + its resolved type — no backend state — so it
is single-sourced here and both backends call it (formerly the byte-identical
twins ExprOwnsRef / NativeExprOwnsRef). }
function ArcExprOwnsRef(AExpr: TASTExpr): Boolean;
{ Mangle a Blaise symbol name into an assembler-legal identifier, shared by
both backends (formerly QBEMangle / NativeMangle). Replaces the generic/
overload metacharacters '<' ',' ' ' -> '_', drops '>', and maps the type-code
sigils '$' '@' '^' to '_D_' '_V_' '_P_'. A clean name (no metacharacter) is
returned unchanged via a fast pre-scan that avoids per-character concat. }
function CodegenMangle(const AName: string): string;
implementation
function RecretManagedClean(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyString, tyClass, tyInterface, tyDynArray:
Exit;
tyRecord:
if not RecretManagedClean(TRecordTypeDesc(F.TypeDesc)) then Exit;
end;
end;
Result := True;
end;
function RecretAllIntegerLeaves(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyInteger, tyInt64, tyUInt32, tyUInt64,
tySmallInt, tyWord, tyByte, tyBoolean,
tyEnum, tyPointer, tyProcedural, tyMetaClass:
;
tyRecord:
if not RecretAllIntegerLeaves(TRecordTypeDesc(F.TypeDesc)) then Exit;
else
Exit;
end;
end;
Result := True;
end;
function RecretAllFloatLeaves(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyDouble, tySingle: ;
tyRecord:
if not RecretAllFloatLeaves(TRecordTypeDesc(F.TypeDesc)) then Exit;
else
Exit;
end;
end;
Result := True;
end;
function RecretAllIntOrFloatLeaves(ARec: TRecordTypeDesc): Boolean;
var
I: Integer;
F: TFieldInfo;
begin
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
case F.TypeDesc.Kind of
tyInteger, tyInt64, tyUInt32, tyUInt64,
tySmallInt, tyWord, tyByte, tyBoolean,
tyEnum, tyPointer, tyProcedural, tyMetaClass,
tyDouble, tySingle: ;
tyRecord:
if not RecretAllIntOrFloatLeaves(TRecordTypeDesc(F.TypeDesc)) then Exit;
else
Exit;
end;
end;
Result := True;
end;
function RecretEightbyteIsSSE(ARec: TRecordTypeDesc; AStartByte: Integer): Boolean;
var
I, Off: Integer;
F: TFieldInfo;
begin
Result := False;
if ARec = nil then Exit;
for I := 0 to ARec.Fields.Count - 1 do
begin
F := TFieldInfo(ARec.Fields.Items[I]);
Off := F.Offset;
if (Off < AStartByte) or (Off >= AStartByte + 8) then Continue;
case F.TypeDesc.Kind of
tyDouble, tySingle:
Exit(True);
tyRecord:
if RecretEightbyteIsSSE(TRecordTypeDesc(F.TypeDesc),
AStartByte - Off) then Exit(True);
end;
end;
end;
function RecretClassify(ARec: TRecordTypeDesc;
const ATarget: TTargetDesc): TRecReturnClass;
var
Sz: Integer;
Eb0SSE, Eb1SSE: Boolean;
begin
Result := rcSret;
if (ARec = nil) or (ARec.Kind <> tyRecord) then Exit;
if ARec.Fields.Count = 0 then Exit;
if not RecretManagedClean(ARec) then Exit;
Sz := ARec.TotalSize();
if ATarget.OS = osWindows then
begin
if RecretAllIntOrFloatLeaves(ARec) then
Result := rcWin64Agg;
Exit;
end;
if RecretAllIntegerLeaves(ARec) then
begin
case Sz of
1, 2, 4, 8: Result := rcInt1;
9, 10, 11, 12, 13, 14, 15, 16: Result := rcInt2;
end;
Exit;
end;
if RecretAllFloatLeaves(ARec) then
begin
case Sz of
4, 8: Result := rcSSE1;
9, 10, 11, 12, 13, 14, 15, 16: Result := rcSSE2;
end;
Exit;
end;
if not RecretAllIntOrFloatLeaves(ARec) then Exit;
case Sz of
9, 10, 11, 12, 13, 14, 15, 16:
begin
Eb0SSE := RecretEightbyteIsSSE(ARec, 0);
Eb1SSE := RecretEightbyteIsSSE(ARec, 8);
if (not Eb0SSE) and Eb1SSE then Result := rcIntSSE
else if Eb0SSE and (not Eb1SSE) then Result := rcSSEInt;
end;
end;
end;
function ArcExprOwnsRef(AExpr: TASTExpr): Boolean;
var
FA: TFieldAccessExpr;
MC: TMethodCallExpr;
IE: TIdentExpr;
begin
Result := False;
if AExpr = nil then Exit;
if AExpr.ResolvedType = nil then Exit;
{ Ownership transfer applies to every ARC-managed return value, not just
classes: a function/method returning a String or dynamic array leaves
its Result at refcount +1 (the callee AddRef'd on `Result := x` and did
not release Result at scope exit). The caller's assignment site must
therefore NOT AddRef again — it consumes that transferred reference.
Without covering tyString/tyDynArray here the assignment branches emit a
spurious _StringAddRef/_DynArrayAddRef on the call result, which is never
balanced and leaks one buffer per call. }
if not (AExpr.ResolvedType.Kind in [tyClass, tyDynArray])
and not AExpr.ResolvedType.IsString() then Exit;
if AExpr is TIdentExpr then
begin
IE := TIdentExpr(AExpr);
if IE.IsImplicitSelfMethod then
Exit(True);
end;
{ Constructor calls via TFieldAccessExpr (TFoo.Create) — do NOT own. }
if AExpr is TFieldAccessExpr then
begin
FA := TFieldAccessExpr(AExpr);
if FA.IsConstructorCall then Exit;
if FA.IsMethodCall then begin Result := True; Exit end;
{ Method-backed property read (read GetX): the getter returns +1.
Field-backed reads (read FX) emit a plain load and do NOT own. }
if (FA.PropRead <> nil) and (FA.PropRead.ReadMethod <> '') then
Exit(True);
end;
{ TMethodCallExpr: constructor calls do NOT own; all other method calls DO. }
if AExpr is TMethodCallExpr then
begin
MC := TMethodCallExpr(AExpr);
if not MC.IsConstructorCall then Result := True;
Exit;
end;
if AExpr is TFuncCallExpr then
begin
if (TFuncCallExpr(AExpr).ResolvedDecl <> nil) or
TFuncCallExpr(AExpr).IsIndirectCall then
Result := True;
Exit;
end;
{ Indexed property subscript: L[I] desugars to Subscript(FieldAccess(Items))
where Items has a ReadMethod. The subscript emitter delegates to the
getter — the result inherits the +1. }
if AExpr is TStringSubscriptExpr then
begin
if (TStringSubscriptExpr(AExpr).StrExpr is TFieldAccessExpr) and
(TFieldAccessExpr(TStringSubscriptExpr(AExpr).StrExpr).PropRead <> nil) and
(TFieldAccessExpr(TStringSubscriptExpr(AExpr).StrExpr).PropRead.ReadMethod <> '') then
Result := True;
end;
end;
function CodegenMangle(const AName: string): string;
var
I, C: Integer;
Clean: Boolean;
begin
{ Fast path: the overwhelming majority of names contain none of the mangled
characters — return the input unchanged instead of rebuilding it with one
concat (and its ARC churn) per character. }
Clean := True;
for I := 0 to Length(AName) - 1 do
begin
C := StrAt(AName, I);
if (C = 60) or (C = 62) or (C = 44) or (C = 36) or (C = 64) or
(C = 94) or (C = 32) then
begin
Clean := False;
break;
end;
end;
if Clean then
Exit(AName);
Result := '';
for I := 0 to Length(AName) - 1 do
begin
C := StrAt(AName, I);
case C of
60: Result := Result + '_'; { '<' }
62: ; { '>' — skip }
44: Result := Result + '_'; { ',' }
32: Result := Result + '_'; { ' ' — e.g. 'class of T' }
36: Result := Result + '_D_'; { '$' — overload delimiter }
64: Result := Result + '_V_'; { '@' — var-param prefix }
94: Result := Result + '_P_'; { '^' — pointer prefix }
else
Result := Result + Chr(C);
end;
end;
end;
end.

2344
compiler/src/main/pascal/blaise.codegen.qbe.pas
View file

File diff suppressed because it is too large Load diff

69
compiler/src/main/pascal/blaise.codegen.target.pas
View file

@ -61,26 +61,6 @@ function TargetName(const ATarget: TTargetDesc): string;
{ True when the native backend can actually generate code for this target. }
function TargetHasNativeBackend(const ATarget: TTargetDesc): Boolean;
{ True when the target is FREESTANDING — reached via direct syscalls with no
libc, so it is always linked as a static ET_EXEC with a self-supplied _start
and no PT_INTERP / libc NEEDED (Strategy B, see
docs/freebsd-x86_64-backend-design.adoc). FreeBSD is freestanding; Linux
links dynamic libc by default. Drives both the RTL unit-list selection
(the kernel leaf is always pulled in) and the internal linker's static mode. }
function TargetIsFreestanding(const ATarget: TTargetDesc): Boolean;
{ Lower-case OS token used in the OS-specific RTL unit names, e.g.
'linux' / 'freebsd' in rtl.platform.layout.<os>, runtime.syscall.<os>.
The single source of truth for the OS suffix, shared by the driver's RTL
unit-list selection and the codegen backends' platform-layout-init call. }
function TargetOSName(const ATarget: TTargetDesc): string;
{ Assembler symbol of the target's platform-layout unit initialiser
(rtl.platform.layout.<os>_init). The compiler emits a direct call to this
from main so the compile-time --target's layout assigns GPlatformLayout first,
regardless of the program's import graph. }
function PlatformLayoutInitSym(const ATarget: TTargetDesc): string;
{ Platform constants derived from the target OS. }
function TargetLineEnding(const ATarget: TTargetDesc): string;
function TargetDirectorySeparator(const ATarget: TTargetDesc): string;
@ -107,22 +87,14 @@ end;
function HostTarget: TTargetDesc;
begin
{ The host OS is a COMPILE-TIME property of this binary: a blaise built with
`--target freebsd-x86_64` runs on FreeBSD, so its HostTarget must report
FreeBSD. The OS conditional symbols are target-driven (injected by the
driver from the resolved --target; see Blaise.pas and uLexer.SeedPredefines),
the IFDEF FREEBSD below is true exactly when THIS compiler was built for
FreeBSD. This is what lets a FreeBSD-hosted blaise default (no --target) to
producing FreeBSD binaries — the basis of self-hosting on FreeBSD. }
{$IFDEF FREEBSD}
MakeTarget(osFreeBSD, cpuX86_64, Result);
{$ELSE}
{$IFDEF WINDOWS}
MakeTarget(osWindows, cpuX86_64, Result);
{$ELSE}
MakeTarget(osLinux, cpuX86_64, Result);
{$ENDIF}
{$ENDIF}
{ A '.exe' suffix on our own path means we are running on Windows (incl.
under wine). Unix hosts carry no extension; we can't cheaply tell
linux/macos/freebsd apart here, and only the Windows distinction matters
for tool extensions today, so default the unix case to linux. }
if LowerCase(ExtractFileExt(ParamStr(0))) = '.exe' then
MakeTarget(osWindows, cpuX86_64, Result)
else
MakeTarget(osLinux, cpuX86_64, Result);
end;
function PtrSize(const ATarget: TTargetDesc): Integer;
@ -185,31 +157,6 @@ begin
Result := (ATarget.OS = osLinux) and (ATarget.CPU = cpuX86_64);
end;
function TargetIsFreestanding(const ATarget: TTargetDesc): Boolean;
begin
{ FreeBSD uses Strategy B — direct syscalls, no libc — so it is always a
static, freestanding ET_EXEC. Other OSes link dynamic libc by default. }
Result := (ATarget.OS = osFreeBSD);
end;
function TargetOSName(const ATarget: TTargetDesc): string;
begin
case ATarget.OS of
osFreeBSD: Result := 'freebsd';
osWindows: Result := 'windows';
osMacOS: Result := 'macos';
else
Result := 'linux';
end;
end;
function PlatformLayoutInitSym(const ATarget: TTargetDesc): string;
begin
{ NativeMangle/QBE mangling of an rtl.* unit keeps the dotted name verbatim
and appends '_init'; the layout unit is rtl.platform.layout.<os>. }
Result := 'rtl.platform.layout.' + TargetOSName(ATarget) + '_init';
end;
function TargetLineEnding(const ATarget: TTargetDesc): string;
begin
case ATarget.OS of

234
compiler/src/main/pascal/blaise.codegen.toolkit.pas
View file

@ -1,234 +0,0 @@
{
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 blaise.codegen.toolkit;
{ Multi-target toolkit + registry (docs/native-target-architecture.adoc).
A TTargetToolkit is the Abstract Factory that produces the consistent
*family* of per-target compiler-side objects: the native backend and the
link target. Keeping them behind one factory guarantees the family is
coherent — a FreeBSD backend paired with a Linux link target is a bug a
registry-resolved toolkit cannot produce.
TTargetRegistry maps a TTargetDesc to its toolkit. Adding a target is a new
TTargetToolkit subclass plus one registration call — no existing dispatch is
edited (Open/Closed). --target resolution and "does this target have a
native backend?" both go through the registry, replacing the previous
hard-coded case statements in blaise.codegen.native and
blaise.codegen.target.
This is the compiler-side half of the architecture. The runtime-side ports
(TKernelABI / TPlatformLayout) live in the RTL and are introduced in later
steps; they are not part of this unit. }
interface
uses
SysUtils, Generics.Collections,
blaise.codegen.target, blaise.codegen.native.backend, blaise.linker.elf;
type
{ Abstract Factory for one target's compiler-side object family. }
TTargetToolkit = class
public
{ Canonical "<os>-<cpu>" name (matches blaise.codegen.target.TargetName). }
function Name: string; virtual; abstract;
{ Construct the native backend for this target. Caller owns the result. }
function MakeBackend: TNativeBackend; virtual; abstract;
{ Construct the link target (ELF header facts) for this target. Caller
owns the result. }
function MakeLinkTarget: TLinkTarget; virtual; abstract;
end;
{ Linux x86_64 — the original (and, before FreeBSD, only) target. }
TLinuxX86_64Toolkit = class(TTargetToolkit)
public
function Name: string; override;
function MakeBackend: TNativeBackend; override;
function MakeLinkTarget: TLinkTarget; override;
end;
{ FreeBSD x86_64 — shares the System V AMD64 ABI and the x86_64 instruction
selector with Linux, so MakeBackend reuses TX86_64Backend; only the link
target's OS/ABI byte differs. The runtime/syscall divergence is handled
in the RTL (TKernelABI / TPlatformLayout), not here. }
TFreeBSDX86_64Toolkit = class(TTargetToolkit)
public
function Name: string; override;
function MakeBackend: TNativeBackend; override;
function MakeLinkTarget: TLinkTarget; override;
end;
{ Toolkit registry. Owns the registered toolkit instances. A linear list
is correct here: the target count is tiny (one per supported OS/CPU), so a
name scan is cheaper than a hash map and avoids instantiating a generic
map over a class type. }
TTargetRegistry = class
private
FByName: TOrderedDictionary<string, TTargetToolkit>;
public
constructor Create;
destructor Destroy; override;
{ Register a toolkit. Registry takes ownership. }
procedure Register(AToolkit: TTargetToolkit);
{ Resolve the toolkit for ATarget, or nil if none is registered. }
function Resolve(const ATarget: TTargetDesc): TTargetToolkit;
end;
{ The process-wide registry, populated in this unit's initialization. }
function GTargetRegistry: TTargetRegistry;
{ Resolve the toolkit for ATarget via the global registry (nil if unknown). }
function ResolveToolkit(const ATarget: TTargetDesc): TTargetToolkit;
{ True when ATarget has a registered native backend toolkit. Replacement for
blaise.codegen.target.TargetHasNativeBackend, driven by the registry. }
function RegisteredHasNativeBackend(const ATarget: TTargetDesc): Boolean;
implementation
uses
blaise.codegen.native.x86_64;
{ ---- TLinuxX86_64Toolkit --------------------------------------------- }
function TLinuxX86_64Toolkit.Name: string;
begin
Result := 'linux-x86_64';
end;
function TLinuxX86_64Toolkit.MakeBackend: TNativeBackend;
var
T: TTargetDesc;
begin
MakeTarget(osLinux, cpuX86_64, T);
Result := TX86_64Backend.Create(T);
end;
function TLinuxX86_64Toolkit.MakeLinkTarget: TLinkTarget;
begin
Result := LinuxX86_64Target();
end;
{ ---- TFreeBSDX86_64Toolkit ------------------------------------------- }
function TFreeBSDX86_64Toolkit.Name: string;
begin
Result := 'freebsd-x86_64';
end;
function TFreeBSDX86_64Toolkit.MakeBackend: TNativeBackend;
var
T: TTargetDesc;
begin
MakeTarget(osFreeBSD, cpuX86_64, T);
Result := TX86_64Backend.Create(T);
end;
function TFreeBSDX86_64Toolkit.MakeLinkTarget: TLinkTarget;
begin
Result := FreeBSDX86_64Target();
end;
{ ---- TTargetRegistry ------------------------------------------------- }
constructor TTargetRegistry.Create;
begin
inherited Create();
FByName := TOrderedDictionary<string, TTargetToolkit>.Create();
end;
destructor TTargetRegistry.Destroy;
var
I: Integer;
Tk: TTargetToolkit;
begin
if FByName <> nil then
begin
for I := 0 to FByName.Count - 1 do
begin
Tk := FByName.Values[I];
Tk.Free();
end;
FByName.Free();
end;
inherited Destroy();
end;
procedure TTargetRegistry.Register(AToolkit: TTargetToolkit);
begin
FByName.Items[AToolkit.Name()] := AToolkit;
end;
function TTargetRegistry.Resolve(const ATarget: TTargetDesc): TTargetToolkit;
var
Key: string;
Tk: TTargetToolkit;
begin
Key := TargetName(ATarget);
if FByName.TryGetValue(Key, Tk) then
Result := Tk
else
Result := nil;
end;
{ ---- Global registry -------------------------------------------------- }
var
GRegistry: TTargetRegistry;
{ Build the registry on first use. This unit's initialization section calls
EnsureRegistry once at startup (single-threaded, before any worker thread is
spawned), so the common path is a no-op nil check. The lazy guard also
covers the case where a codegen unit's own initialization constructs a
backend before this unit's initialization runs (link-order independence).
Thread-safety note: the incremental compile worker pool is THREADS, not
processes. The registry must be FULLY built before it is published to the
global, or a second thread could observe a non-nil GRegistry whose toolkit
list is still empty and wrongly conclude a target has no backend. Build
into a local and assign the global last (publish-after-populate). }
procedure EnsureRegistry;
var
R: TTargetRegistry;
begin
if GRegistry = nil then
begin
R := TTargetRegistry.Create();
R.Register(TLinuxX86_64Toolkit.Create());
R.Register(TFreeBSDX86_64Toolkit.Create());
GRegistry := R;
end;
end;
function GTargetRegistry: TTargetRegistry;
begin
EnsureRegistry();
Result := GRegistry;
end;
function ResolveToolkit(const ATarget: TTargetDesc): TTargetToolkit;
begin
EnsureRegistry();
Result := GRegistry.Resolve(ATarget);
end;
function RegisteredHasNativeBackend(const ATarget: TTargetDesc): Boolean;
begin
EnsureRegistry();
Result := GRegistry.Resolve(ATarget) <> nil;
end;
initialization
EnsureRegistry();
finalization
GRegistry.Free();
end.

167
compiler/src/main/pascal/blaise.linker.elf.pas
View file

@ -37,14 +37,13 @@ unit blaise.linker.elf;
with Phase B alone.
Phase C — TLinker in dynamic mode (SetDynamic(True)) produces a
PIE (ET_DYN) executable linked against libc. It generates GOT/PLT
for undefined (libc) symbols, emits .dynamic/.dynsym/.dynstr/.hash
sections, resolves R_X86_64_64 as R_X86_64_RELATIVE in .rela.dyn,
handles R_X86_64_TPOFF32 for TLS, and merges any .init_array/
.fini_array a linked object contributes. The entry point is _start,
which the runtime archive supplies (blaise_start_x86_64.s) and which
calls __libc_start_main with main as the program's entry — no system
Scrt1.o / crtbegin / crtend / crti / crtn is needed (issue #142). }
PIE (ET_DYN) executable linked against libc. It reads CRT startup
objects, generates GOT/PLT for undefined (libc) symbols, emits
.dynamic/.dynsym/.dynstr/.hash sections, resolves R_X86_64_64 as
R_X86_64_RELATIVE in .rela.dyn, handles R_X86_64_TPOFF32 for TLS,
and merges .init_array/.fini_array from CRT objects. The entry
point is _start (from Scrt1.o), which calls __libc_start_main with
main as the program's entry. }
interface
@ -84,10 +83,6 @@ type
{ Linux x86-64 ELF, non-PIE ET_EXEC. Caller frees. }
function LinuxX86_64Target: TLinkTarget;
{ FreeBSD x86-64 ELF. Same System V AMD64 machine/arch as Linux; differs
only in EI_OSABI (9 = FreeBSD). Caller frees. }
function FreeBSDX86_64Target: TLinkTarget;
type
{ One output section accumulating contributions from input objects. }
TMergedSection = class
@ -615,13 +610,6 @@ begin
{ defaults already describe Linux x86-64 }
end;
function FreeBSDX86_64Target: TLinkTarget;
begin
Result := TLinkTarget.Create();
{ Identical to Linux x86-64 except the OS/ABI byte in the ELF header. }
Result.OSABI := ELFOSABI_FREEBSD;
end;
{ ---- TLinker ----------------------------------------------------------- }
constructor TLinker.Create;
@ -817,19 +805,12 @@ var
M: TMergedSection;
Addr: Int64;
HdrBytes: Int64;
IsAlloc, IsExec, IsWrite, HasTlsSec: Boolean;
IsAlloc, IsExec, IsWrite: Boolean;
begin
{ Program headers: PT_LOAD x2 (exec run, write run), plus PT_TLS when the
program has any TLS section (.tdata/.tbss). Reserve header space so the
first section's file offset (= addr - base) clears the headers; otherwise
the first section would overlap and overwrite the PT_TLS phdr. Phdr = 56. }
HasTlsSec := False;
for I := 0 to FMerger.Merged.Count - 1 do
if (FMerger.Merged.Get(I).Flags and SHF_TLS) <> 0 then HasTlsSec := True;
if HasTlsSec then
HdrBytes := ELF64_EHDR_SIZE + 3 * 56
else
HdrBytes := ELF64_EHDR_SIZE + 2 * 56;
{ Program-header count is known: PT_LOAD x2 (exec run, write run).
Reserve header space so the first section's file offset — which
equals (addr - base) — clears the headers. Elf64_Phdr = 56. }
HdrBytes := ELF64_EHDR_SIZE + 2 * 56;
{ Executable run: header bytes share its first page. }
Addr := FTarget.BaseAddr + HdrBytes;
@ -851,16 +832,14 @@ begin
Self.PlaceSection(M, Addr);
end;
{ Writable run starts on a fresh page. TLS sections (.tdata/.tbss, SHF_TLS)
are placed separately below and must be skipped here. }
{ Writable run starts on a fresh page. }
Addr := LkAlignUp(Addr, FTarget.PageSize);
for I := 0 to FMerger.Merged.Count - 1 do
begin
M := FMerger.Merged.Get(I);
IsAlloc := (M.Flags and SHF_ALLOC) <> 0;
IsWrite := (M.Flags and SHF_WRITE) <> 0;
if IsAlloc and IsWrite and (M.ShType <> SHT_NOBITS)
and ((M.Flags and SHF_TLS) = 0) then
if IsAlloc and IsWrite and (M.ShType <> SHT_NOBITS) then
Self.PlaceSection(M, Addr);
end;
for I := 0 to FMerger.Merged.Count - 1 do
@ -868,42 +847,9 @@ begin
M := FMerger.Merged.Get(I);
IsAlloc := (M.Flags and SHF_ALLOC) <> 0;
IsWrite := (M.Flags and SHF_WRITE) <> 0;
if IsAlloc and IsWrite and (M.ShType = SHT_NOBITS)
and ((M.Flags and SHF_TLS) = 0) then
if IsAlloc and IsWrite and (M.ShType = SHT_NOBITS) then
Self.PlaceSection(M, Addr);
end;
{ TLS sections (.tdata then .tbss). Mirror LayoutDynamic so a static ET_EXEC
also gets a correct TLS block + FTlsAddr/FTlsSize for TPOFF relocations and
the PT_TLS program header (which the freestanding _start reads to set up the
thread pointer). }
FTlsAddr := 0;
FTlsSize := 0;
FTlsAlign := 1;
FTlsFileSize := 0;
M := FMerger.FindMerged('.tdata');
if M <> nil then
begin
Self.PlaceSection(M, Addr);
FTlsAddr := Self.MergedAddr(M);
FTlsFileSize := M.Size;
FTlsSize := M.Size;
if M.Align > FTlsAlign then FTlsAlign := M.Align;
end;
M := FMerger.FindMerged('.tbss');
if M <> nil then
begin
Self.PlaceSection(M, Addr);
if FTlsAddr = 0 then FTlsAddr := Self.MergedAddr(M);
FTlsSize := FTlsSize + M.Size;
if M.Align > FTlsAlign then FTlsAlign := M.Align;
end;
{ Variant-II TLS: the thread pointer sits at the ALIGNED end of the block, and
TPOFF32 is computed as (sym - FTlsAddr - FTlsSize). The freestanding _start
places TP at AlignUp(memsz, align); align FTlsSize to match so both agree even
when the raw section sum is not a multiple of FTlsAlign (else every threadvar
read is off by the alignment padding). }
FTlsSize := LkAlignUp(FTlsSize, FTlsAlign);
end;
function TLinker.FindSymbol(const AName: string): TLinkSymbol;
@ -1571,9 +1517,6 @@ begin
FTlsSize := FTlsSize + M.Size;
if M.Align > FTlsAlign then FTlsAlign := M.Align;
end;
{ TP sits at the aligned end of the TLS block (variant II); align FTlsSize so
TPOFF32 (sym - FTlsAddr - FTlsSize) matches the aligned thread pointer. }
FTlsSize := LkAlignUp(FTlsSize, FTlsAlign);
{ Build .dynamic section. 'libc.so.6' is at offset 1 in .dynstr. }
FDynamicData := '';
@ -1669,10 +1612,9 @@ begin
raise ELinker.Create('undefined reference to `' + Sym.Name + '''');
end;
{ Patch the merged section bytes for every relocation. Static mode
(Phase B) supports PC-relative and absolute forms (every symbol has a
final link-time address in a non-PIE ET_EXEC); dynamic mode (Phase C)
additionally handles GOT-relative and emits RELATIVE fixups. }
{ Patch the merged section bytes for every relocation. In static
mode (Phase B) only PC-relative forms are supported; in dynamic mode
(Phase C) absolute, GOT-relative and TLS relocations are handled. }
procedure TLinker.ApplyRelocations;
var
Oi, Ri: Integer;
@ -1722,52 +1664,28 @@ begin
R_X86_64_64:
begin
if not FDynamic then
raise ELinker.Create(Ctx + ': R_X86_64_64 relocation against `'
+ Sym.Name + ''' needs dynamic linking');
S := Self.ResolveSymbolAddr(Obj, Rel.SymIndex, Ctx);
Val := S + Rel.Addend;
if M.ShType = SHT_NOBITS then
raise ELinker.Create(Ctx
+ ': relocation into a NOBITS section');
{ Patch the absolute 64-bit target address. In a non-PIE ET_EXEC
(static mode) every symbol has a fixed load address, so this value
is final and needs no run-time fixup. In PIE/dynamic mode the
image base is unknown until load, so the same slot also gets an
R_X86_64_RELATIVE entry in .rela.dyn for the loader to re-add the
base. }
LkPatch64(M.Data, PFileOff, Val);
if FDynamic then
begin
RE := TRelaDynEntry.Create();
RE.VAddr := PAddr;
RE.Addend := Val;
FRelaDyn.Add(RE);
end;
RE := TRelaDynEntry.Create();
RE.VAddr := PAddr;
RE.Addend := Val;
FRelaDyn.Add(RE);
end;
R_X86_64_32, R_X86_64_32S:
begin
if not FDynamic then
raise ELinker.Create(Ctx
+ ': absolute 32-bit relocation unsupported in static mode');
S := Self.ResolveSymbolAddr(Obj, Rel.SymIndex, Ctx);
Val := S + Rel.Addend;
if M.ShType = SHT_NOBITS then
raise ELinker.Create(Ctx
+ ': relocation into a NOBITS section');
{ Resolvable in BOTH modes: static ET_EXEC links at a fixed base
(0x400000) where every mapped address fits in 32 bits, and in
PIE mode the patched value is the unslid link-time address
(the OPDF reader applies the run-time slide itself; code never
uses abs32 in PIE objects). Range-check like GNU ld does:
R_X86_64_32 must fit zero-extended, R_X86_64_32S sign-extended. }
if Rel.RelocType = R_X86_64_32 then
begin
if (Val < 0) or (Val > $FFFFFFFF) then
raise ELinker.Create(Ctx
+ ': R_X86_64_32 overflow against ' + Sym.Name);
end
else
begin
if (Val < -2147483648) or (Val > 2147483647) then
raise ELinker.Create(Ctx
+ ': R_X86_64_32S overflow against ' + Sym.Name);
end;
LkPatch32(M.Data, PFileOff, Val and $FFFFFFFF);
end;
@ -1789,12 +1707,10 @@ begin
end;
R_X86_64_TPOFF32:
{ Local-Exec TLS: the offset from the thread pointer (which points at
the END of the static TLS block) down to this threadvar. This is the
STATIC TLS model — it is resolvable at link time in both static and
PIE/dynamic executables (the threadvar's position within the initial
TLS block is fixed at link), so it needs no dynamic relocation. }
begin
if not FDynamic then
raise ELinker.Create(Ctx
+ ': TLS relocation needs dynamic linking');
S := Self.ResolveSymbolAddr(Obj, Rel.SymIndex, Ctx);
Val := S - FTlsAddr + Rel.Addend - FTlsSize;
LkPatch32(M.Data, PFileOff, Val and $FFFFFFFF);
@ -1868,12 +1784,7 @@ begin
Buf := Buf + LkLE(0, 4); { e_flags }
Buf := Buf + LkLE(ELF64_EHDR_SIZE, 2); { e_ehsize }
Buf := Buf + LkLE(56, 2); { e_phentsize }
{ 2 PT_LOAD, plus PT_TLS when the program has threadvars (so the static
_start can set up the thread pointer from the PT_TLS init image). }
if FTlsSize > 0 then
Buf := Buf + LkLE(3, 2) { e_phnum }
else
Buf := Buf + LkLE(2, 2);
Buf := Buf + LkLE(2, 2); { e_phnum (2 PT_LOAD) }
Buf := Buf + LkLE(ELF64_SHDR_SIZE, 2); { e_shentsize }
Buf := Buf + LkLE(0, 2); { e_shnum (patched later) }
Buf := Buf + LkLE(0, 2); { e_shstrndx (patched later) }
@ -1896,20 +1807,6 @@ begin
Buf := Buf + LkLE(WriteMemHi - WriteLo, 8); { p_memsz }
Buf := Buf + LkLE(PageSz, 8); { p_align }
{ PT_TLS — the initial TLS image (.tdata file bytes + .tbss zero size). The
static _start reads this segment to build the per-thread block and set %fs.
Only emitted when the program has threadvars (e_phnum reflects this). }
if FTlsSize > 0 then
begin
Buf := Buf + LkLE(PT_TLS, 4) + LkLE(PF_R, 4);
Buf := Buf + LkLE(Self.FileOffset(FTlsAddr), 8); { p_offset }
Buf := Buf + LkLE(FTlsAddr, 8); { p_vaddr }
Buf := Buf + LkLE(FTlsAddr, 8); { p_paddr }
Buf := Buf + LkLE(FTlsFileSize, 8); { p_filesz (.tdata) }
Buf := Buf + LkLE(FTlsSize, 8); { p_memsz (.tdata + .tbss) }
Buf := Buf + LkLE(FTlsAlign, 8); { p_align }
end;
{ Pad headers out to the first section's file offset (the exec run's
first byte sits at Self.FileOffset(ExecLo)). }
if Length(Buf) < Self.FileOffset(ExecLo) then

143
compiler/src/main/pascal/rtl.platform.layout.freebsd.pas
View file

@ -1,143 +0,0 @@
{
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 rtl.platform.layout.freebsd;
// FreeBSD x86_64 struct layouts and OS constants — the concrete TPlatformLayout
// adapter for FreeBSD (docs/native-target-architecture.adoc, Step 0b;
// docs/freebsd-x86_64-backend-design.adoc, Step 2).
//
// This is the FreeBSD sibling of rtl.platform.layout.linux. The POSIX method
// bodies in rtl.platform.posix are shared between Linux and FreeBSD; the only
// per-target divergence is the struct stat layout and a handful of OS constant
// values, both of which live here. No conditional compilation: the FreeBSD RTL
// archive composes this unit in place of the Linux one.
//
// Layout pinned to FreeBSD 14.x amd64 (sys/sys/stat.h). It is identical on
// FreeBSD 13.x: the ino_t/dev_t widening that changed struct stat landed in
// FreeBSD 12 and has been stable since, so 13.x and 14.x share these offsets.
//
// struct stat offsets (FreeBSD amd64): st_mode at byte 24, st_size at byte 112,
// st_mtim.tv_sec at byte 64. The buffer is sized at 224 bytes
// (sizeof(struct stat)). These differ from Linux (48/88/144) — reusing the
// Linux offsets here would read garbage file sizes and dates, the single most
// error-prone item in the FreeBSD port.
//
// The O_CREAT / O_TRUNC / O_APPEND flag bits also differ from Linux; the rest
// (S_*, SEEK_*, CLOCK_REALTIME, WNOHANG) happen to share Linux's values.
interface
uses
rtl.platform;
type
TPlatformLayoutFreeBSDX86_64 = class(TPlatformLayout)
public
function O_RDONLY: Integer; override;
function O_WRONLY: Integer; override;
function O_RDWR: Integer; override;
function O_CREAT: Integer; override;
function O_TRUNC: Integer; override;
function O_APPEND: Integer; override;
function S_IFMT: Integer; override;
function S_IFDIR: Integer; override;
function SEEK_SET: Integer; override;
function SEEK_CUR: Integer; override;
function SEEK_END: Integer; override;
function CLOCK_REALTIME: Integer; override;
function WNOHANG: Integer; override;
function StatBufSize: Integer; override;
function StatSize(Buf: Pointer): Int64; override;
function StatMtime(Buf: Pointer): Int64; override;
function StatMode(Buf: Pointer): Integer; override;
end;
implementation
const
{ FreeBSD 14.x amd64 struct stat field offsets (bytes). }
STAT_OFF_MODE = 24; { st_mode (mode_t, u16) }
STAT_OFF_MTIME = 64; { st_mtim.tv_sec (Int64) }
STAT_OFF_SIZE = 112; { st_size (off_t, Int64) }
STAT_SIZE = 224; { sizeof(struct stat) }
function TPlatformLayoutFreeBSDX86_64.O_RDONLY: Integer; begin Result := 0; end;
function TPlatformLayoutFreeBSDX86_64.O_WRONLY: Integer; begin Result := 1; end;
function TPlatformLayoutFreeBSDX86_64.O_RDWR: Integer; begin Result := 2; end;
function TPlatformLayoutFreeBSDX86_64.O_CREAT: Integer; begin Result := $0200; end;
function TPlatformLayoutFreeBSDX86_64.O_TRUNC: Integer; begin Result := $0400; end;
function TPlatformLayoutFreeBSDX86_64.O_APPEND: Integer; begin Result := $0008; end;
function TPlatformLayoutFreeBSDX86_64.S_IFMT: Integer; begin Result := $F000; end;
function TPlatformLayoutFreeBSDX86_64.S_IFDIR: Integer; begin Result := $4000; end;
function TPlatformLayoutFreeBSDX86_64.SEEK_SET: Integer; begin Result := 0; end;
function TPlatformLayoutFreeBSDX86_64.SEEK_CUR: Integer; begin Result := 1; end;
function TPlatformLayoutFreeBSDX86_64.SEEK_END: Integer; begin Result := 2; end;
function TPlatformLayoutFreeBSDX86_64.CLOCK_REALTIME: Integer; begin Result := 0; end;
function TPlatformLayoutFreeBSDX86_64.WNOHANG: Integer; begin Result := 1; end;
function TPlatformLayoutFreeBSDX86_64.StatBufSize: Integer;
begin
Result := STAT_SIZE;
end;
function TPlatformLayoutFreeBSDX86_64.StatSize(Buf: Pointer): Int64;
var
P: ^Int64;
begin
P := Pointer(PChar(Buf) + STAT_OFF_SIZE);
Result := P^;
end;
function TPlatformLayoutFreeBSDX86_64.StatMtime(Buf: Pointer): Int64;
var
P: ^Int64;
begin
P := Pointer(PChar(Buf) + STAT_OFF_MTIME);
Result := P^;
end;
function TPlatformLayoutFreeBSDX86_64.StatMode(Buf: Pointer): Integer;
var
P: ^Integer;
begin
P := Pointer(PChar(Buf) + STAT_OFF_MODE);
Result := P^;
end;
{ Assign GPlatformLayout to the FreeBSD layout, once. Called from this unit's
initialization (rtl.platform.layout.freebsd_init, which main invokes by-name
for a FreeBSD --target) and from the weak _BlaisePlatformInit trampoline. The
nil-guard keeps it a no-op on a host build that merely imports this unit (e.g.
cp.test.platformlayout.freebsd), so it never clobbers the host layout. }
procedure AssignLayoutFreeBSD;
begin
if GPlatformLayout = nil then
GPlatformLayout := TPlatformLayoutFreeBSDX86_64.Create();
end;
{ Weak bootstrap-fallback trampoline — see the twin in rtl.platform.layout.linux
for the full rationale. Defined WEAK so the linker keeps the first-seen (host)
layout's copy when both units are linked. }
procedure _BlaisePlatformInit; assembler; nostackframe;
asm
.weak _BlaisePlatformInit
jmp AssignLayoutFreeBSD
end;
initialization
AssignLayoutFreeBSD();
end.

136
compiler/src/main/pascal/rtl.platform.layout.linux.pas
View file

@ -1,136 +0,0 @@
{
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 rtl.platform.layout.linux;
// Linux x86_64 struct layouts and OS constants — the concrete TPlatformLayout
// adapter for Linux (docs/native-target-architecture.adoc, Step 0b).
//
// These are the values that previously lived as `const` declarations and the
// TStatBuf record inside rtl.platform.posix.pas. Moving them behind the
// TPlatformLayout port keeps the POSIX method bodies (which are shared with
// FreeBSD) free of any Linux-specific layout assumption; the FreeBSD adapter
// supplies its own offsets and flag values without conditional compilation.
//
// struct stat offsets below match the Linux x86_64 `struct stat`
// (sys/stat.h): st_mode at byte 24, st_size at byte 48, st_mtime at byte 88.
// The buffer is sized at 144 bytes (sizeof(struct stat) on Linux x86_64).
interface
uses
rtl.platform;
type
TPlatformLayoutLinuxX86_64 = class(TPlatformLayout)
public
function O_RDONLY: Integer; override;
function O_WRONLY: Integer; override;
function O_RDWR: Integer; override;
function O_CREAT: Integer; override;
function O_TRUNC: Integer; override;
function O_APPEND: Integer; override;
function S_IFMT: Integer; override;
function S_IFDIR: Integer; override;
function SEEK_SET: Integer; override;
function SEEK_CUR: Integer; override;
function SEEK_END: Integer; override;
function CLOCK_REALTIME: Integer; override;
function WNOHANG: Integer; override;
function StatBufSize: Integer; override;
function StatSize(Buf: Pointer): Int64; override;
function StatMtime(Buf: Pointer): Int64; override;
function StatMode(Buf: Pointer): Integer; override;
end;
implementation
const
{ Linux x86_64 struct stat field offsets (bytes). }
STAT_OFF_MODE = 24; { st_mode (Integer) }
STAT_OFF_SIZE = 48; { st_size (Int64) }
STAT_OFF_MTIME = 88; { st_mtim.tv_sec (Int64) }
STAT_SIZE = 144; { sizeof(struct stat) }
function TPlatformLayoutLinuxX86_64.O_RDONLY: Integer; begin Result := 0; end;
function TPlatformLayoutLinuxX86_64.O_WRONLY: Integer; begin Result := 1; end;
function TPlatformLayoutLinuxX86_64.O_RDWR: Integer; begin Result := 2; end;
function TPlatformLayoutLinuxX86_64.O_CREAT: Integer; begin Result := $40; end;
function TPlatformLayoutLinuxX86_64.O_TRUNC: Integer; begin Result := $200; end;
function TPlatformLayoutLinuxX86_64.O_APPEND: Integer; begin Result := $400; end;
function TPlatformLayoutLinuxX86_64.S_IFMT: Integer; begin Result := $F000; end;
function TPlatformLayoutLinuxX86_64.S_IFDIR: Integer; begin Result := $4000; end;
function TPlatformLayoutLinuxX86_64.SEEK_SET: Integer; begin Result := 0; end;
function TPlatformLayoutLinuxX86_64.SEEK_CUR: Integer; begin Result := 1; end;
function TPlatformLayoutLinuxX86_64.SEEK_END: Integer; begin Result := 2; end;
function TPlatformLayoutLinuxX86_64.CLOCK_REALTIME: Integer; begin Result := 0; end;
function TPlatformLayoutLinuxX86_64.WNOHANG: Integer; begin Result := 1; end;
function TPlatformLayoutLinuxX86_64.StatBufSize: Integer;
begin
Result := STAT_SIZE;
end;
function TPlatformLayoutLinuxX86_64.StatSize(Buf: Pointer): Int64;
var
P: ^Int64;
begin
P := Pointer(PChar(Buf) + STAT_OFF_SIZE);
Result := P^;
end;
function TPlatformLayoutLinuxX86_64.StatMtime(Buf: Pointer): Int64;
var
P: ^Int64;
begin
P := Pointer(PChar(Buf) + STAT_OFF_MTIME);
Result := P^;
end;
function TPlatformLayoutLinuxX86_64.StatMode(Buf: Pointer): Integer;
var
P: ^Integer;
begin
P := Pointer(PChar(Buf) + STAT_OFF_MODE);
Result := P^;
end;
{ Assign GPlatformLayout to this target's layout, once. Called both from this
unit's initialization (rtl.platform.layout.linux_init, which main invokes
by-name for a Linux --target) and from the weak _BlaisePlatformInit trampoline
below. }
procedure AssignLayoutLinux;
begin
if GPlatformLayout = nil then
GPlatformLayout := TPlatformLayoutLinuxX86_64.Create();
end;
{ Bootstrap fallback: a binary built by a codegen that does not yet emit main's
direct, strong, by-name call to rtl.platform.layout.<os>_init reaches the
layout through _SetArgs -> _BlaisePlatformInit instead. Emitted WEAK so that
every concrete layout unit can define it without a duplicate-symbol link error
when more than one is linked (e.g. a test that imports a non-host layout): the
linker keeps the first-seen weak, which is the host layout BuildRTLUnitList
links first. A tiny asm trampoline that tail-calls AssignLayout. }
procedure _BlaisePlatformInit; assembler; nostackframe;
asm
.weak _BlaisePlatformInit
jmp AssignLayoutLinux
end;
initialization
AssignLayoutLinux();
end.

53
compiler/src/main/pascal/runtime.atomic.pas
View file

@ -1,53 +0,0 @@
{
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 runtime.atomic;
// Atomic 32-bit add/sub primitives used by ARC reference counting.
//
// Inline-assembler port of runtime/src/main/asm/blaise_atomic_x86_64.s — the
// bodies are now `asm … end` routines in this Pascal unit so the RTL builds
// with Blaise's own internal assembler and needs no hand-written .s file
// (docs/inline-asm-design.adoc, §"Migration of the .s files").
//
// Each returns the PREVIOUS value at Ptr (xadd semantics). System V AMD64:
// arg1 Ptr -> %rdi, arg2 Delta -> %esi; the 32-bit result is returned in %eax.
// `nostackframe` lets the asm body own the frame so the registers hold the
// raw incoming arguments.
interface
{ Ptr addresses a 32-bit integer. Typed as Pointer (not a `PInteger` alias) so
this unit does not export a type name that collides with the same alias in
other RTL units when they are compiled together (e.g. blaise_arc's PInteger).
The body reads/writes through %rdi regardless of the Pascal pointer type. }
function _AtomicAddInt32(Ptr: Pointer; Delta: Integer): Integer;
function _AtomicSubInt32(Ptr: Pointer; Delta: Integer): Integer;
implementation
{ return *Ptr (old); *Ptr += Delta — atomically. }
function _AtomicAddInt32(Ptr: Pointer; Delta: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax
lock xaddl %eax, (%rdi)
ret
end;
{ return *Ptr (old); *Ptr -= Delta — atomically (xadd of the negated delta). }
function _AtomicSubInt32(Ptr: Pointer; Delta: Integer): Integer;
assembler; nostackframe;
asm
negl %esi
movl %esi, %eax
lock xaddl %eax, (%rdi)
ret
end;
end.

105
compiler/src/main/pascal/runtime.cstub.pas
View file

@ -1,105 +0,0 @@
{
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 runtime.cstub;
// Freestanding C-library leaves the compiler and RTL emit calls to but which
// are not syscalls: memcpy / memset / memcmp / strlen. In a libc-backed build
// these come from libc; in a --static build this unit supplies them so no libc
// is needed (docs/linux-syscall-migration.adoc).
//
// Architecture-neutral byte-at-a-time implementations. Correctness over speed:
// these are the fallback for the freestanding build; if profiling shows the
// allocator/string paths need it, an SSE/AVX memcpy can replace the loop later
// (the inline-asm assembler already encodes the vector ops).
//
// Signatures match the C ABI the codegen assumes:
// void* memcpy(void* dst, const void* src, size_t n) - returns dst
// void* memset(void* dst, int c, size_t n) - returns dst
// int memcmp(const void* a, const void* b, size_t n)
// size_t strlen(const char* s)
interface
function memcpy(Dst, Src: Pointer; N: Int64): Pointer;
function memset(Dst: Pointer; C: Integer; N: Int64): Pointer;
function memcmp(A, B: Pointer; N: Int64): Integer;
function strlen(S: PChar): Int64;
implementation
{ PChar indexing reads/writes a single byte as an Integer (see runtime.str), so
these loops need no Char type (Blaise has none). }
function memcpy(Dst, Src: Pointer; N: Int64): Pointer;
var
D, S: PChar;
I: Int64;
begin
D := PChar(Dst);
S := PChar(Src);
I := 0;
while I < N do
begin
D[I] := S[I];
I := I + 1;
end;
Result := Dst;
end;
function memset(Dst: Pointer; C: Integer; N: Int64): Pointer;
var
D: PChar;
I: Int64;
B: Integer;
begin
D := PChar(Dst);
B := C and $FF;
I := 0;
while I < N do
begin
D[I] := B;
I := I + 1;
end;
Result := Dst;
end;
function memcmp(A, B: Pointer; N: Int64): Integer;
var
PA, PB: PChar;
I: Int64;
CA, CB: Integer;
begin
PA := PChar(A);
PB := PChar(B);
I := 0;
while I < N do
begin
CA := PA[I] and $FF;
CB := PB[I] and $FF;
if CA <> CB then
begin
Result := CA - CB;
Exit;
end;
I := I + 1;
end;
Result := 0;
end;
function strlen(S: PChar): Int64;
var
I: Int64;
begin
I := 0;
while (S[I] and $FF) <> 0 do
I := I + 1;
Result := I;
end;
end.

188
compiler/src/main/pascal/runtime.libc.freebsd.pas
View file

@ -1,188 +0,0 @@
{
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 runtime.libc.freebsd;
// libc-shaped leaves that are MORE than a raw syscall - they need logic the
// kernel does not provide: env lookup, the libc-style return shapes, the
// hw.ncpu sysctl. Built on the raw syscalls in runtime.syscall.freebsd.
// Linked only in a static (libc-free) FreeBSD build
// (docs/freebsd-x86_64-backend-design.adoc). The FreeBSD sibling of
// runtime.libc.linux.
//
// These DEFINE the bare POSIX names (getcwd, getenv, time, waitpid, execvp,
// sysconf) that rtl.platform.posix / runtime.thread import via `external name`,
// so they resolve here instead of FreeBSD's libc.
//
// Deltas from the Linux sibling:
// * time() has no SYS_time on FreeBSD; it reads CLOCK_REALTIME via
// clock_gettime and returns tv_sec.
// * sysconf(CPU count) uses sysctl(hw.ncpu) — FreeBSD has no
// sched_getaffinity.
// getcwd / getenv / waitpid / execvp are structurally identical (the syscall
// leaf provides sys_getcwd / wait4 / execve / environ on both targets).
interface
uses
runtime.syscall.freebsd; { provides `environ`, captured by _start }
{ libc-shaped getcwd: returns Buf on success, nil on error (the raw syscall
returns 0 / -errno). }
function getcwd(Buf: PChar; Size: Int64): PChar;
{ getenv: linear scan of `environ` for "Name=" returns a pointer to the value
(just past '='), or nil if not present. }
function getenv(Name: PChar): PChar;
{ time(2): FreeBSD has no SYS_time — read CLOCK_REALTIME and return tv_sec. If
T is non-nil the same value is written there (libc's optional out-param). }
function time(T: Pointer): Int64;
{ waitpid via wait4 with a NULL rusage. }
function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
{ execvp: execve the name with the current `environ` as envp. No $PATH search
yet (matches the Linux sibling — the RTL only execs explicit paths). }
function execvp(File_: PChar; Argv: Pointer): Integer;
{ sysconf for the few names the RTL queries - currently only the online CPU
count (_SC_NPROCESSORS_ONLN, passed as 84 by runtime.thread on every target),
via sysctl(hw.ncpu). }
function sysconf(Name: Integer): Int64;
implementation
type
PPointer = ^Pointer;
PInt64 = ^Int64;
const
{ The token runtime.thread passes for the CPU-count query. It is an internal
RTL contract value (runtime.thread hardcodes 84 on every target), NOT
FreeBSD's libc _SC_NPROCESSORS_ONLN (58) — we never reach FreeBSD's libc. }
_SC_NPROCESSORS_ONLN = 84;
CLOCK_REALTIME = 0;
{ sysctl MIB for hw.ncpu (FreeBSD sys/sysctl.h): CTL_HW=6, HW_NCPU=3. }
CTL_HW = 6;
HW_NCPU = 3;
{ --- small freestanding string helpers (no dependency on runtime.str) --- }
function CStrLen(S: PChar): Int64;
var I: Int64;
begin
I := 0;
while (S[I] and $FF) <> 0 do I := I + 1;
Result := I;
end;
{ Compare the "KEY=" prefix of an environ entry against Name (length NLen).
Returns True when Entry starts with Name immediately followed by '='. }
function EnvKeyMatches(Entry, Name: PChar; NLen: Int64): Boolean;
var I: Int64;
begin
I := 0;
while I < NLen do
begin
if (Entry[I] and $FF) <> (Name[I] and $FF) then Exit(False);
if (Entry[I] and $FF) = 0 then Exit(False);
I := I + 1;
end;
Result := (Entry[NLen] and $FF) = Ord('=');
end;
function getcwd(Buf: PChar; Size: Int64): PChar;
var Rc: Int64;
begin
Rc := sys_getcwd(Buf, Size);
if Rc < 0 then
Result := nil
else
Result := Buf;
end;
function getenv(Name: PChar): PChar;
var
Entry: PChar;
NLen, Off: Int64;
begin
Result := nil;
if environ = nil then Exit;
NLen := CStrLen(Name);
{ environ is a NULL-terminated array of PChar; read the I-th slot as a
Pointer at environ + I*8 (PPointer deref, the RTL idiom - no [] on a typed
pointer). }
Off := 0;
Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
while Entry <> nil do
begin
if EnvKeyMatches(Entry, Name, NLen) then
begin
Result := PChar(Pointer(PChar(Entry) + NLen + 1)); { just past '=' }
Exit;
end;
Off := Off + 8;
Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
end;
end;
function time(T: Pointer): Int64;
var
Ts: array[0..1] of Int64; { struct timespec: tv_sec (Int64), tv_nsec (long) }
Rc: Integer;
Out_: PInt64;
begin
Rc := clock_gettime(CLOCK_REALTIME, @Ts[0]);
if Rc <> 0 then
Result := -1
else
Result := Ts[0]; { tv_sec }
if (T <> nil) and (Result >= 0) then
begin
Out_ := PInt64(T);
Out_^ := Result; { libc's optional out-param: *T = tv_sec }
end;
end;
function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
begin
Result := wait4(Pid, Status, Options, nil);
end;
function execvp(File_: PChar; Argv: Pointer): Integer;
begin
{ No PATH search yet: execve the name directly (matches runtime.libc.linux —
the RTL only execs explicit paths, e.g. system() builds "/bin/sh"). }
Result := execve(File_, Argv, environ);
end;
function sysconf(Name: Integer): Int64;
var
Mib: array[0..1] of Integer; { the two-element MIB: CTL_HW, HW_NCPU }
NCpu: Integer;
OldLen: Int64; { size_t }
Rc: Integer;
begin
if Name = _SC_NPROCESSORS_ONLN then
begin
Mib[0] := CTL_HW;
Mib[1] := HW_NCPU;
NCpu := 0;
OldLen := SizeOf(NCpu); { 4 }
Rc := sysctl(@Mib[0], 2, @NCpu, @OldLen, nil, 0);
if (Rc <> 0) or (NCpu < 1) then
Result := 1 { fall back to single CPU on error }
else
Result := NCpu;
end
else
Result := -1;
end;
end.

175
compiler/src/main/pascal/runtime.libc.linux.pas
View file

@ -1,175 +0,0 @@
{
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 runtime.libc.linux;
// libc-shaped leaves that are MORE than a raw syscall - they need logic the
// kernel does not provide: PATH/env lookup, the libc-style return shapes, etc.
// Built on the raw syscalls in runtime.syscall.linux. Linked only in a
// --static (libc-free) build (docs/linux-syscall-migration.adoc).
//
// These DEFINE the bare POSIX names (getcwd, getenv, ) that rtl.platform.posix
// imports via `external name`, so they resolve here instead of libc.so.6.
interface
uses
runtime.syscall.linux; { provides `environ`, captured by _start }
{ libc-shaped getcwd: returns Buf on success, nil on error (the raw syscall
returns a length / -errno). }
function getcwd(Buf: PChar; Size: Int64): PChar;
{ getenv: linear scan of `environ` for "Name=" returns a pointer to the value
(just past '='), or nil if not present. }
function getenv(Name: PChar): PChar;
{ time(2) wrapper matching libc's signature (the raw syscall already supports the
optional out-param, so this just forwards). }
function time(T: Pointer): Int64;
{ waitpid via wait4 with a NULL rusage. }
function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
{ execvp: search $PATH for File when it has no '/', then execve. Argv is the
NULL-terminated argument vector; the current `environ` is passed as envp. }
function execvp(File_: PChar; Argv: Pointer): Integer;
{ sysconf for the few names the RTL queries - currently only the online CPU
count (_SC_NPROCESSORS_ONLN = 84), via sched_getaffinity + popcount. }
function sysconf(Name: Integer): Int64;
implementation
type
PPointer = ^Pointer;
const
_SC_NPROCESSORS_ONLN = 84;
{ --- small freestanding string helpers (no dependency on runtime.str) --- }
function CStrLen(S: PChar): Int64;
var I: Int64;
begin
I := 0;
while (S[I] and $FF) <> 0 do I := I + 1;
Result := I;
end;
{ Compare the "KEY=" prefix of an environ entry against Name (length NLen).
Returns True when Entry starts with Name immediately followed by '='. }
function EnvKeyMatches(Entry, Name: PChar; NLen: Int64): Boolean;
var I: Int64;
begin
I := 0;
while I < NLen do
begin
if (Entry[I] and $FF) <> (Name[I] and $FF) then Exit(False);
if (Entry[I] and $FF) = 0 then Exit(False);
I := I + 1;
end;
Result := (Entry[NLen] and $FF) = Ord('=');
end;
function getcwd(Buf: PChar; Size: Int64): PChar;
var Rc: Int64;
begin
Rc := sys_getcwd(Buf, Size);
if Rc < 0 then
Result := nil
else
Result := Buf;
end;
function getenv(Name: PChar): PChar;
var
Entry: PChar;
NLen, Off: Int64;
begin
Result := nil;
if environ = nil then Exit;
NLen := CStrLen(Name);
{ environ is a NULL-terminated array of PChar; read the I-th slot as a
Pointer at environ + I*8 (PPointer deref, the RTL idiom - no [] on a typed
pointer). }
Off := 0;
Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
while Entry <> nil do
begin
if EnvKeyMatches(Entry, Name, NLen) then
begin
Result := PChar(Pointer(PChar(Entry) + NLen + 1)); { just past '=' }
Exit;
end;
Off := Off + 8;
Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
end;
end;
function time(T: Pointer): Int64;
begin
Result := sys_time(T);
end;
function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
begin
Result := wait4(Pid, Status, Options, nil);
end;
function execvp(File_: PChar; Argv: Pointer): Integer;
begin
{ No PATH search yet: execve the name directly. The RTL only execs
absolute/relative program paths (system() builds "/bin/sh"), so this covers
the present call sites. A bare program name resolves only relative to the
CWD and otherwise fails with the kernel's ENOENT (never a silent wrong
result); add a $PATH scan here if a bare-name exec call site appears. }
Result := execve(File_, Argv, environ);
end;
{ Population count of a 1024-bit affinity mask (128 bytes), counting set CPUs. }
function PopCountMask(Mask: PChar; NBytes: Int64): Int64;
var
I, J, Cnt: Int64;
B: Integer;
begin
Cnt := 0;
I := 0;
while I < NBytes do
begin
B := Mask[I] and $FF;
J := 0;
while J < 8 do
begin
if (B and (1 shl J)) <> 0 then Cnt := Cnt + 1;
J := J + 1;
end;
I := I + 1;
end;
Result := Cnt;
end;
function sysconf(Name: Integer): Int64;
var
Mask: array[0..127] of Byte; { 1024 CPUs worth of affinity bits }
Rc: Integer;
begin
if Name = _SC_NPROCESSORS_ONLN then
begin
Rc := sched_getaffinity(0, 128, @Mask[0]);
if Rc <= 0 then
Result := 1 { fall back to single CPU on error }
else
Result := PopCountMask(PChar(@Mask[0]), Rc);
if Result < 1 then Result := 1;
end
else
Result := -1;
end;
end.

296
compiler/src/main/pascal/runtime.libc2.freebsd.pas
View file

@ -1,296 +0,0 @@
{
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 runtime.libc2.freebsd;
// FreeBSD sibling of runtime.libc2.linux — the Tier 2 libc leaves that need real
// logic, not a raw syscall:
// * the atexit registry + `exit` (runs handlers then _exit)
// * __cxa_atexit (register a handler)
// * abort (raise SIGABRT, then _exit 134)
// * gmtime_r / localtime_r / timegm (freestanding civil-calendar math, UTC)
// * mkstemp (random-named O_CREAT|O_EXCL file)
// * system (fork + execve /bin/sh -c + wait4)
//
// The civil-calendar math, the atexit registry, and the tm layout are all
// target-invariant (struct tm is identical on Linux/FreeBSD amd64), so the only
// differences from the Linux unit are the syscall leaf it builds on
// (runtime.syscall.freebsd) and the FreeBSD O_* flag values. Linked only in a
// --static (libc-free) FreeBSD build (docs/freebsd-x86_64-backend-design.adoc,
// Step 4b).
interface
uses
runtime.syscall.freebsd;
{ __cxa_atexit(func, arg, dso_handle): register func(arg) to run at exit, LIFO.
Returns 0 on success. dso_handle is ignored (single program, no DSO unload). }
function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
{ exit(code): run the registered handlers (LIFO), then _exit(code). This is the
bare `exit` main's epilogue calls; it is a reserved word in Pascal, so the
Pascal proc is _libc2_exit and the asm body publishes `exit`. }
procedure _RunAtExitAndExit(Code: Integer);
{ abort(): raise SIGABRT to self; if the signal is caught/ignored, force-exit
with status 134 (128 + SIGABRT). }
procedure abort;
{ struct tm split/join (UTC). T points at a time_t (Int64 epoch seconds). }
function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
function localtime_r(T: Pointer; Tm: Pointer): Pointer;
function timegm(Tm: Pointer): Int64;
{ mkstemp(template): template ends with "XXXXXX"; replace with random chars and
open O_CREAT|O_EXCL|O_RDWR mode 0600. Returns the fd or -1. }
function mkstemp(Template: PChar): Integer;
{ system(cmd): fork, child execve "/bin/sh -c <cmd>", parent wait4; returns the
child's raw wait status (the RTL extracts the exit code). }
function system(Cmd: PChar): Integer;
implementation
type
PInt64 = ^Int64;
PInteger = ^Integer;
const
SIGABRT = 6;
O_RDWR = 2;
{ FreeBSD open(2) flag bits — differ from Linux ($40 / $80). See
rtl.platform.layout.freebsd (O_CREAT=$0200, O_TRUNC=$0400, O_APPEND=$0008);
O_EXCL is $0800 (sys/fcntl.h). }
O_CREAT = $0200;
O_EXCL = $0800;
MAX_ATEXIT = 64;
{ struct tm field byte offsets (SysV layout — identical on Linux and FreeBSD
amd64; the RTL's TTm mirrors it):
Sec@0 Min@4 Hour@8 MDay@12 Mon@16 Year@20 WDay@24 YDay@28 IsDST@32 (all int). }
const
TM_SEC=0; TM_MIN=4; TM_HOUR=8; TM_MDAY=12; TM_MON=16; TM_YEAR=20;
TM_WDAY=24; TM_YDAY=28; TM_ISDST=32;
{ --- atexit registry --- }
var
GAtExitFns: array[0..MAX_ATEXIT - 1] of Pointer;
GAtExitArgs: array[0..MAX_ATEXIT - 1] of Pointer;
GAtExitCount: Integer;
function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
begin
if GAtExitCount >= MAX_ATEXIT then
begin
Result := -1;
Exit;
end;
GAtExitFns[GAtExitCount] := Func;
GAtExitArgs[GAtExitCount] := Arg;
GAtExitCount := GAtExitCount + 1;
Result := 0;
end;
{ Call a registered handler: void (*func)(void* arg). The handler is invoked
with its arg in %rdi (a 0-arg Pascal handler simply ignores it). }
procedure CallHandler(Func, Arg: Pointer); assembler; nostackframe;
asm
movq %rsi, %rax { Arg -> scratch; Func is in %rdi }
movq %rdi, %r11 { Func }
movq %rax, %rdi { Arg -> first C arg }
jmp *%r11
end;
procedure _RunAtExitAndExit(Code: Integer);
var
I: Integer;
begin
{ LIFO. }
I := GAtExitCount - 1;
while I >= 0 do
begin
if GAtExitFns[I] <> nil then
CallHandler(GAtExitFns[I], GAtExitArgs[I]);
I := I - 1;
end;
_exit(Code);
end;
{ Publish the bare `exit` symbol as a tail-call into _RunAtExitAndExit (Code is
already in %edi). }
procedure _libc2_exit(Code: Integer); assembler; nostackframe;
asm
.globl exit
exit:
jmp _RunAtExitAndExit
end;
procedure abort;
begin
kill(getpid(), SIGABRT);
_exit(134);
end;
{ --- civil calendar (UTC), based on Howard Hinnant's days_from_civil --- }
{ Days since 1970-01-01 for a y/m/d (proleptic Gregorian). }
function DaysFromCivil(Y, M, D: Int64): Int64;
var
Era, Yoe, Doy, Doe: Int64;
YY: Int64;
begin
if M <= 2 then YY := Y - 1 else YY := Y;
if YY >= 0 then Era := YY div 400 else Era := (YY - 399) div 400;
Yoe := YY - Era * 400;
if M > 2 then Doy := (153 * (M - 3) + 2) div 5 + D - 1
else Doy := (153 * (M + 9) + 2) div 5 + D - 1;
Doe := Yoe * 365 + Yoe div 4 - Yoe div 100 + Doy;
Result := Era * 146097 + Doe - 719468;
end;
{ Inverse: y/m/d from days-since-epoch. }
procedure CivilFromDays(Z: Int64; var Y, M, D: Int64);
var
Era, Doe, Yoe, Doy, Mp: Int64;
begin
Z := Z + 719468;
if Z >= 0 then Era := Z div 146097 else Era := (Z - 146096) div 146097;
Doe := Z - Era * 146097;
Yoe := (Doe - Doe div 1460 + Doe div 36524 - Doe div 146096) div 365;
Y := Yoe + Era * 400;
Doy := Doe - (365 * Yoe + Yoe div 4 - Yoe div 100);
Mp := (5 * Doy + 2) div 153;
D := Doy - (153 * Mp + 2) div 5 + 1;
if Mp < 10 then M := Mp + 3 else M := Mp - 9;
if M <= 2 then Y := Y + 1;
end;
procedure FillTm(T: Int64; Tm: Pointer);
var
Days, Secs, Y, M, D: Int64;
P: PInteger;
begin
Days := T div 86400;
Secs := T - Days * 86400;
if Secs < 0 then
begin
Secs := Secs + 86400;
Days := Days - 1;
end;
CivilFromDays(Days, Y, M, D);
P := PInteger(Pointer(PChar(Tm) + TM_SEC)); P^ := Integer(Secs mod 60);
P := PInteger(Pointer(PChar(Tm) + TM_MIN)); P^ := Integer((Secs div 60) mod 60);
P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); P^ := Integer(Secs div 3600);
P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); P^ := Integer(D);
P := PInteger(Pointer(PChar(Tm) + TM_MON)); P^ := Integer(M - 1); { 0-based }
P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); P^ := Integer(Y - 1900); { years since 1900 }
{ WDay: 1970-01-01 was a Thursday (4). }
P := PInteger(Pointer(PChar(Tm) + TM_WDAY));
P^ := Integer(((Days mod 7) + 4 + 7) mod 7);
P := PInteger(Pointer(PChar(Tm) + TM_YDAY));
P^ := Integer(Days - DaysFromCivil(Y, 1, 1));
P := PInteger(Pointer(PChar(Tm) + TM_ISDST)); P^ := 0;
end;
function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
begin
FillTm(PInt64(T)^, Tm);
Result := Tm;
end;
function localtime_r(T: Pointer; Tm: Pointer): Pointer;
begin
{ No timezone database in the freestanding RTL - treat local as UTC. }
Result := gmtime_r(T, Tm);
end;
function timegm(Tm: Pointer): Int64;
var
Y, M, D, Hh, Mm, Ss: Int64;
P: PInteger;
begin
P := PInteger(Pointer(PChar(Tm) + TM_SEC)); Ss := P^;
P := PInteger(Pointer(PChar(Tm) + TM_MIN)); Mm := P^;
P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); Hh := P^;
P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); D := P^;
P := PInteger(Pointer(PChar(Tm) + TM_MON)); M := P^ + 1;
P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); Y := P^ + 1900;
Result := DaysFromCivil(Y, M, D) * 86400 + Hh * 3600 + Mm * 60 + Ss;
end;
{ --- mkstemp --- }
function mkstemp(Template: PChar): Integer;
const
ALPHABET = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
var
Len, I, Tries, Got: Integer;
N: Int64;
RandBuf: array[0..5] of Byte;
Fd: Integer;
begin
Len := 0;
while (Template[Len] and $FF) <> 0 do Len := Len + 1;
if Len < 6 then Exit(-1);
Tries := 0;
while Tries < 256 do
begin
{ Fill all 6 bytes; getrandom may short-read, so loop until satisfied rather
than leave stale/zero bytes that would weaken the random suffix. }
Got := 0;
while Got < 6 do
begin
N := getrandom(@RandBuf[Got], 6 - Got, 0);
if N <= 0 then Continue; { EINTR / transient: retry }
Got := Got + Integer(N);
end;
for I := 0 to 5 do
Template[Len - 6 + I] := Ord(ALPHABET[(RandBuf[I] mod 62)]);
Fd := open(Template, O_RDWR or O_CREAT or O_EXCL, 384); { 0600 }
if Fd >= 0 then Exit(Fd);
Tries := Tries + 1;
end;
Result := -1;
end;
{ --- system --- }
function system(Cmd: PChar): Integer;
var
Pid, Status: Integer;
Argv: array[0..3] of Pointer;
ShPath, DashC: array[0..15] of Byte;
begin
{ Build argv = /bin/sh, -c, cmd, NULL. The /bin/sh path and -c flag are short
literals copied into local byte buffers so they have stable addresses. }
ShPath[0]:=Ord('/'); ShPath[1]:=Ord('b'); ShPath[2]:=Ord('i'); ShPath[3]:=Ord('n');
ShPath[4]:=Ord('/'); ShPath[5]:=Ord('s'); ShPath[6]:=Ord('h'); ShPath[7]:=0;
DashC[0]:=Ord('-'); DashC[1]:=Ord('c'); DashC[2]:=0;
Argv[0] := @ShPath[0];
Argv[1] := @DashC[0];
Argv[2] := Pointer(Cmd);
Argv[3] := nil;
Pid := fork();
if Pid = 0 then
begin
{ Child: replace image; on failure exit 127 like the shell. Forward the
process environment so the spawned shell sees PATH/HOME/etc. }
execve(PChar(@ShPath[0]), @Argv[0], environ);
_exit(127);
end;
if Pid < 0 then Exit(-1);
Status := 0;
wait4(Pid, @Status, 0, nil);
Result := Status;
end;
end.

287
compiler/src/main/pascal/runtime.libc2.linux.pas
View file

@ -1,287 +0,0 @@
{
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 runtime.libc2.linux;
// Tier 2 libc leaves that need real logic, not a raw syscall:
// * the atexit registry + `exit` (runs handlers then exit_group)
// * __cxa_atexit (register a handler)
// * abort (raise SIGABRT, then exit_group 134)
// * gmtime_r / localtime_r / timegm (freestanding civil-calendar math, UTC)
// * mkstemp (random-named O_CREAT|O_EXCL file)
// * system (fork + execve /bin/sh -c + wait4)
//
// Linked only in a --static (libc-free) build (docs/linux-syscall-migration.adoc).
// Built on runtime.syscall.linux's raw syscalls.
interface
uses
runtime.syscall.linux;
{ __cxa_atexit(func, arg, dso_handle): register func(arg) to run at exit, LIFO.
Returns 0 on success. dso_handle is ignored (single program, no DSO unload). }
function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
{ exit(code): run the registered handlers (LIFO), then exit_group(code). This
is the bare `exit` main's epilogue calls; it is a reserved word in Pascal, so
the Pascal proc is _libc2_exit and the asm/Pascal body publishes `exit`. }
procedure _RunAtExitAndExit(Code: Integer);
{ abort(): raise SIGABRT to self; if the signal is caught/ignored, force-exit
with status 134 (128 + SIGABRT). }
procedure abort;
{ struct tm split/join (UTC). T points at a time_t (Int64 epoch seconds). }
function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
function localtime_r(T: Pointer; Tm: Pointer): Pointer;
function timegm(Tm: Pointer): Int64;
{ mkstemp(template): template ends with "XXXXXX"; replace with random chars and
open O_CREAT|O_EXCL|O_RDWR mode 0600. Returns the fd or -1. }
function mkstemp(Template: PChar): Integer;
{ system(cmd): fork, child execve "/bin/sh -c <cmd>", parent wait4; returns the
child's raw wait status (the RTL extracts the exit code). }
function system(Cmd: PChar): Integer;
implementation
type
PInt64 = ^Int64;
PInteger = ^Integer;
const
SIGABRT = 6;
O_RDWR = 2;
O_CREAT = $40;
O_EXCL = $80;
MAX_ATEXIT = 64;
{ struct tm field byte offsets (Linux/SysV layout the RTL's TTm mirrors):
Sec@0 Min@4 Hour@8 MDay@12 Mon@16 Year@20 WDay@24 YDay@28 IsDST@32 (all int). }
const
TM_SEC=0; TM_MIN=4; TM_HOUR=8; TM_MDAY=12; TM_MON=16; TM_YEAR=20;
TM_WDAY=24; TM_YDAY=28; TM_ISDST=32;
{ --- atexit registry --- }
var
GAtExitFns: array[0..MAX_ATEXIT - 1] of Pointer;
GAtExitArgs: array[0..MAX_ATEXIT - 1] of Pointer;
GAtExitCount: Integer;
function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
begin
if GAtExitCount >= MAX_ATEXIT then
begin
Result := -1;
Exit;
end;
GAtExitFns[GAtExitCount] := Func;
GAtExitArgs[GAtExitCount] := Arg;
GAtExitCount := GAtExitCount + 1;
Result := 0;
end;
{ Call a registered handler: void (*func)(void* arg). The handler is invoked
with its arg in %rdi (a 0-arg Pascal handler simply ignores it). }
procedure CallHandler(Func, Arg: Pointer); assembler; nostackframe;
asm
movq %rsi, %rax { Arg -> scratch; Func is in %rdi }
movq %rdi, %r11 { Func }
movq %rax, %rdi { Arg -> first C arg }
jmp *%r11
end;
procedure _RunAtExitAndExit(Code: Integer);
var
I: Integer;
begin
{ LIFO. }
I := GAtExitCount - 1;
while I >= 0 do
begin
if GAtExitFns[I] <> nil then
CallHandler(GAtExitFns[I], GAtExitArgs[I]);
I := I - 1;
end;
_exit(Code);
end;
{ Publish the bare `exit` symbol as a tail-call into _RunAtExitAndExit (Code is
already in %edi). }
procedure _libc2_exit(Code: Integer); assembler; nostackframe;
asm
.globl exit
exit:
jmp _RunAtExitAndExit
end;
procedure abort;
begin
kill(getpid(), SIGABRT);
_exit(134);
end;
{ --- civil calendar (UTC), based on Howard Hinnant's days_from_civil --- }
{ Days since 1970-01-01 for a y/m/d (proleptic Gregorian). }
function DaysFromCivil(Y, M, D: Int64): Int64;
var
Era, Yoe, Doy, Doe: Int64;
YY: Int64;
begin
if M <= 2 then YY := Y - 1 else YY := Y;
if YY >= 0 then Era := YY div 400 else Era := (YY - 399) div 400;
Yoe := YY - Era * 400;
if M > 2 then Doy := (153 * (M - 3) + 2) div 5 + D - 1
else Doy := (153 * (M + 9) + 2) div 5 + D - 1;
Doe := Yoe * 365 + Yoe div 4 - Yoe div 100 + Doy;
Result := Era * 146097 + Doe - 719468;
end;
{ Inverse: y/m/d from days-since-epoch. }
procedure CivilFromDays(Z: Int64; var Y, M, D: Int64);
var
Era, Doe, Yoe, Doy, Mp: Int64;
begin
Z := Z + 719468;
if Z >= 0 then Era := Z div 146097 else Era := (Z - 146096) div 146097;
Doe := Z - Era * 146097;
Yoe := (Doe - Doe div 1460 + Doe div 36524 - Doe div 146096) div 365;
Y := Yoe + Era * 400;
Doy := Doe - (365 * Yoe + Yoe div 4 - Yoe div 100);
Mp := (5 * Doy + 2) div 153;
D := Doy - (153 * Mp + 2) div 5 + 1;
if Mp < 10 then M := Mp + 3 else M := Mp - 9;
if M <= 2 then Y := Y + 1;
end;
procedure FillTm(T: Int64; Tm: Pointer);
var
Days, Secs, Y, M, D: Int64;
P: PInteger;
begin
Days := T div 86400;
Secs := T - Days * 86400;
if Secs < 0 then
begin
Secs := Secs + 86400;
Days := Days - 1;
end;
CivilFromDays(Days, Y, M, D);
P := PInteger(Pointer(PChar(Tm) + TM_SEC)); P^ := Integer(Secs mod 60);
P := PInteger(Pointer(PChar(Tm) + TM_MIN)); P^ := Integer((Secs div 60) mod 60);
P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); P^ := Integer(Secs div 3600);
P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); P^ := Integer(D);
P := PInteger(Pointer(PChar(Tm) + TM_MON)); P^ := Integer(M - 1); { 0-based }
P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); P^ := Integer(Y - 1900); { years since 1900 }
{ WDay: 1970-01-01 was a Thursday (4). }
P := PInteger(Pointer(PChar(Tm) + TM_WDAY));
P^ := Integer(((Days mod 7) + 4 + 7) mod 7);
P := PInteger(Pointer(PChar(Tm) + TM_YDAY));
P^ := Integer(Days - DaysFromCivil(Y, 1, 1));
P := PInteger(Pointer(PChar(Tm) + TM_ISDST)); P^ := 0;
end;
function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
begin
FillTm(PInt64(T)^, Tm);
Result := Tm;
end;
function localtime_r(T: Pointer; Tm: Pointer): Pointer;
begin
{ No timezone database in the freestanding RTL - treat local as UTC. }
Result := gmtime_r(T, Tm);
end;
function timegm(Tm: Pointer): Int64;
var
Y, M, D, Hh, Mm, Ss: Int64;
P: PInteger;
begin
P := PInteger(Pointer(PChar(Tm) + TM_SEC)); Ss := P^;
P := PInteger(Pointer(PChar(Tm) + TM_MIN)); Mm := P^;
P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); Hh := P^;
P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); D := P^;
P := PInteger(Pointer(PChar(Tm) + TM_MON)); M := P^ + 1;
P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); Y := P^ + 1900;
Result := DaysFromCivil(Y, M, D) * 86400 + Hh * 3600 + Mm * 60 + Ss;
end;
{ --- mkstemp --- }
function mkstemp(Template: PChar): Integer;
const
ALPHABET = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
var
Len, I, Tries, Got: Integer;
N: Int64;
RandBuf: array[0..5] of Byte;
Fd: Integer;
begin
Len := 0;
while (Template[Len] and $FF) <> 0 do Len := Len + 1;
if Len < 6 then Exit(-1);
Tries := 0;
while Tries < 256 do
begin
{ Fill all 6 bytes; getrandom may short-read, so loop until satisfied rather
than leave stale/zero bytes that would weaken the random suffix. }
Got := 0;
while Got < 6 do
begin
N := getrandom(@RandBuf[Got], 6 - Got, 0);
if N <= 0 then Continue; { EINTR / transient: retry }
Got := Got + Integer(N);
end;
for I := 0 to 5 do
Template[Len - 6 + I] := Ord(ALPHABET[(RandBuf[I] mod 62)]);
Fd := open(Template, O_RDWR or O_CREAT or O_EXCL, 384); { 0600 }
if Fd >= 0 then Exit(Fd);
Tries := Tries + 1;
end;
Result := -1;
end;
{ --- system --- }
function system(Cmd: PChar): Integer;
var
Pid, Status: Integer;
Argv: array[0..3] of Pointer;
ShPath, DashC: array[0..15] of Byte;
begin
{ Build argv = /bin/sh, -c, cmd, NULL. The /bin/sh path and -c flag are short
literals copied into local byte buffers so they have stable addresses. }
ShPath[0]:=Ord('/'); ShPath[1]:=Ord('b'); ShPath[2]:=Ord('i'); ShPath[3]:=Ord('n');
ShPath[4]:=Ord('/'); ShPath[5]:=Ord('s'); ShPath[6]:=Ord('h'); ShPath[7]:=0;
DashC[0]:=Ord('-'); DashC[1]:=Ord('c'); DashC[2]:=0;
Argv[0] := @ShPath[0];
Argv[1] := @DashC[0];
Argv[2] := Pointer(Cmd);
Argv[3] := nil;
Pid := fork();
if Pid = 0 then
begin
{ Child: replace image; on failure exit 127 like the shell. Forward the
process environment so the spawned shell sees PATH/HOME/etc. }
execve(PChar(@ShPath[0]), @Argv[0], environ);
_exit(127);
end;
if Pid < 0 then Exit(-1);
Status := 0;
wait4(Pid, @Status, 0, nil);
Result := Status;
end;
end.

68
compiler/src/main/pascal/runtime.setjmp.pas
View file

@ -1,68 +0,0 @@
{
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 runtime.setjmp;
// setjmp/longjmp for the exception runtime (try/except, try/finally).
//
// Inline-assembler port of runtime/src/main/asm/blaise_setjmp_x86_64.s — the
// bodies move into `asm … end` routines so the RTL needs no hand-written .s
// (docs/inline-asm-design.adoc, §"Migration of the .s files").
//
// The jmp_buf is a 64-byte block: callee-saved regs rbx/rbp/r12..r15 at
// 0/8/16..40, the caller's RSP at 48, and the return address at 56.
//
// System V AMD64 arg registers: Buf -> %rdi, Val -> %esi. Both routines own
// their frame (`nostackframe`); _blaise_setjmp captures the return address off
// the stack and _blaise_longjmp restores RSP and jumps through the saved
// return address, so a compiler-generated prologue must not intervene.
interface
function _blaise_setjmp(Buf: Pointer): Integer;
procedure _blaise_longjmp(Buf: Pointer; Val: Integer);
implementation
{ Save the machine context into Buf; returns 0 on the direct call. }
function _blaise_setjmp(Buf: Pointer): Integer; assembler; nostackframe;
asm
mov %rbx, (%rdi)
mov %rbp, 8(%rdi)
mov %r12, 16(%rdi)
mov %r13, 24(%rdi)
mov %r14, 32(%rdi)
mov %r15, 40(%rdi)
lea 8(%rsp), %rax
mov %rax, 48(%rdi)
mov (%rsp), %rax
mov %rax, 56(%rdi)
xor %eax, %eax
ret
end;
{ Restore the context saved in Buf and resume there, returning Val (or 1 if
Val is 0, mirroring C longjmp). }
procedure _blaise_longjmp(Buf: Pointer; Val: Integer); assembler; nostackframe;
asm
mov %esi, %eax
test %eax, %eax
jnz .Llj_nonzero
inc %eax
.Llj_nonzero:
mov (%rdi), %rbx
mov 8(%rdi), %rbp
mov 16(%rdi), %r12
mov 24(%rdi), %r13
mov 32(%rdi), %r14
mov 40(%rdi), %r15
mov 48(%rdi), %rsp
jmp *56(%rdi)
end;
end.

52
compiler/src/main/pascal/runtime.start.pas
View file

@ -1,52 +0,0 @@
{
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 runtime.start;
// Program entry point (x86_64, System V ABI, glibc-compatible).
//
// Inline-assembler port of runtime/src/main/asm/blaise_start_x86_64.s — _start
// is now an `asm … end` routine so the RTL needs no hand-written .s
// (docs/inline-asm-design.adoc, §"Migration of the .s files").
//
// This replaces the system Scrt1.o so the internal linker needs no
// gcc-provided startup object (issue #142). The linker uses '_start' as the
// ELF entry point; an unmangled unit-level routine named _start emits exactly
// that symbol.
//
// On entry the kernel hands us the initial process stack:
// (%rsp) argc 8(%rsp) argv[0] ... then NULL, envp, auxv
// and %rdx holds rtld_fini for PIE images. We marshal these into the args
// __libc_start_main(main, argc, argv, init=NULL, fini=NULL, rtld_fini,
// stack_end) expects; glibc runs the init array, calls main(argc, argv, envp),
// then exit(main's return). nostackframe: the body owns the whole frame.
interface
procedure _start;
implementation
procedure _start; assembler; nostackframe;
asm
endbr64
xor %ebp, %ebp
mov %rdx, %r9
pop %rsi
mov %rsp, %rdx
and $0xfffffffffffffff0, %rsp
push %rax
push %rsp
xor %r8d, %r8d
xor %ecx, %ecx
lea main(%rip), %rdi
call __libc_start_main@PLT
hlt
end;
end.

326
compiler/src/main/pascal/runtime.start.static.freebsd.pas
View file

@ -1,326 +0,0 @@
{
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 runtime.start.static.freebsd;
// Freestanding _start for a static, libc-free FreeBSD ET_EXEC (the FreeBSD
// kernel-leaf swap; docs/freebsd-x86_64-backend-design.adoc, Step 3/4c).
//
// The FreeBSD sibling of runtime.start.static.linux. A tiny asm trampoline
// captures the initial stack pointer and tail-calls the Pascal _BlaiseStartC,
// which:
// 1. parses argc / argv / envp (the kernel's initial stack);
// 2. sets up the static TLS block and the thread pointer (%fs) — required
// before any threadvar (%fs-relative) access, which a static binary's
// kernel does NOT do for us;
// 3. captures `environ`;
// 4. calls main(argc, argv);
// 5. exits via the FreeBSD `exit` syscall (main itself calls exit, so this
// is a guard).
//
// FreeBSD's process entry stack has the SAME shape as Linux: %rsp points at
// argc, followed by argv[0..argc-1], a NULL, envp[], a NULL, then the ELF auxv.
// (FreeBSD additionally passes an rtld cleanup pointer in %rdx for dynamic
// binaries; it is 0 for a static ET_EXEC and we ignore it.)
//
// TLS setup locates PT_TLS via the program headers, which SetupTLS reads
// DIRECTLY from this binary's own ELF header at the fixed non-PIE load base
// ($400000) rather than via the kernel auxv AT_PHDR entry — a non-PIE ET_EXEC
// always maps its header there, so this is exact and needs no auxv (identical
// on Linux and FreeBSD). x86-64 TLS is variant II on both. The ONE FreeBSD
// difference is how the %fs base is installed: Linux uses arch_prctl(
// ARCH_SET_FS, tp); FreeBSD uses sysarch(AMD64_SET_FSBASE, &tp) — note it takes
// a POINTER to the base value, not the value itself.
//
// x86-64 TLS (variant II): the thread pointer points at the TCB, which sits
// ABOVE the TLS block; threadvars are at negative offsets from the TP. %fs:0
// must hold the TP value itself (the TCB self-pointer). Layout we build:
// [ TLS block: memsz bytes ][ TCB: 8-byte self-pointer ]
// tp = block + memsz_aligned ; %fs = tp ; *(void**)tp = tp.
interface
uses
runtime.syscall.freebsd; { _exit, sysarch, mmap/munmap + the `environ` global }
procedure _start;
{ The static TLS template, captured from PT_TLS at startup so each spawned thread
can build its own TLS block (runtime.thread.static.freebsd uses these via
thr_new's tls_base parameter). Zero TlsMemSz means the program has no
thread-local storage. }
var
GTlsInitAddr: Pointer; { .tdata init image (= PT_TLS p_vaddr) }
GTlsFileSz: Int64; { bytes to copy from the init image }
GTlsMemSz: Int64; { total TLS size (.tdata + .tbss) }
GTlsAlign: Int64; { PT_TLS alignment }
{ Build a fresh TLS block for a new thread and return its thread pointer (the
value thr_new installs as the new thread's %fs base via tls_base). Layout
matches _start's SetupTLS: aligned TLS data followed by the TCB self-pointer.
Returns nil when the program has no TLS. }
function BuildThreadTLS: Pointer;
{ Unmap a TLS block created by BuildThreadTLS, given the thread pointer it
returned. Used to reclaim the block when thread creation fails after the TLS
was built (the offset from TP back to the mmap base is the same alignment math
BuildThreadTLS used, kept here so both sides agree). }
procedure FreeThreadTLS(ATp: Pointer);
{ The total size of a per-thread TLS block (aligned memsz + the TCB slot), which
thr_new wants as tls_size. Returns 0 when the program has no TLS. }
function ThreadTLSSize: Int64;
implementation
type
PPointer = ^Pointer;
PInt64 = ^Int64;
const
AMD64_SET_FSBASE = 129; { sysarch op — install the %fs base (verified vs
FreeBSD 14 x86/include/sysarch.h) }
PROT_RW = 3; { PROT_READ or PROT_WRITE }
MAP_PRIVANON = $1002; { FreeBSD MAP_PRIVATE ($0002) or MAP_ANON ($1000) }
PT_TLS = 7;
{ Our own ELF image. A non-PIE ET_EXEC is mapped at this fixed base (the
linker's TLinkTarget.BaseAddr), so the ELF header — and through e_phoff the
program-header table — is readable at compile-time-known addresses without
the kernel auxv. }
ELF_LOAD_BASE = $400000;
EH_PHOFF = $20; { e_phoff (u64) — file offset of the phdr table }
EH_PHENTSIZE = $36; { e_phentsize (u16) }
EH_PHNUM = $38; { e_phnum (u16) }
{ ELF64 Phdr field offsets. }
PH_TYPE = 0; { p_type (u32) }
PH_OFFSET = 8; { p_offset (u64) - file offset; == vaddr-base in our images }
PH_VADDR = 16; { p_vaddr (u64) }
PH_FILESZ = 32; { p_filesz (u64) }
PH_MEMSZ = 40; { p_memsz (u64) }
PH_ALIGN = 48; { p_align (u64) }
{ Round X up to the next multiple of A (A a power of two, >= 1). }
function AlignUp(X, A: Int64): Int64;
begin
if A < 1 then A := 1;
Result := (X + A - 1) and (not (A - 1));
end;
{ Install the %fs base to Tp. FreeBSD: sysarch(AMD64_SET_FSBASE, &Tp) — the
syscall takes the ADDRESS of the base value, not the value. }
procedure SetFsBase(Tp: Pointer);
var
Base: Pointer;
begin
Base := Tp;
sysarch(AMD64_SET_FSBASE, @Base);
end;
{ Locate the program headers, find PT_TLS, then build the static TLS block and
set the thread pointer. No-op when the program has no TLS.
We read the program-header table DIRECTLY from this binary's own ELF header,
which sits at the fixed non-PIE load base (ELF_LOAD_BASE = $400000, the
linker's TLinkTarget.BaseAddr): e_phoff at header offset 0x20, e_phentsize at
0x36, e_phnum at 0x38. A non-PIE ET_EXEC always maps its own ELF header at
the fixed base (the first PT_LOAD covers file offset 0), so reading e_phoff
there is exact and needs no kernel auxv — simpler and more self-contained than
walking the auxv for AT_PHDR (which FreeBSD does supply, but relying on it
couples startup to the auxv layout for no benefit on a non-PIE image). }
procedure SetupTLS;
var
PhdrAddr, PhEnt, PhNum: Int64;
EhEPhOff: PInt64;
EhEPhEnt, EhEPhNum: ^Word;
I: Int64;
Ph: PChar;
TlsVaddr, TlsFileSz, TlsMemSz, TlsAlign: Int64;
PType: ^Integer;
Block, Tp: Pointer;
BlockSize: Int64;
J: Int64;
Src, Dst: PChar;
TpSlot: PPointer;
begin
{ Read e_phoff / e_phentsize / e_phnum from our own ELF header at the load
base. e_phoff is a file offset; the first PT_LOAD maps file offset 0 to the
load base, so the phdr table is at base + e_phoff. }
EhEPhOff := PInt64(Pointer(ELF_LOAD_BASE + EH_PHOFF));
EhEPhEnt := Pointer(ELF_LOAD_BASE + EH_PHENTSIZE);
EhEPhNum := Pointer(ELF_LOAD_BASE + EH_PHNUM);
PhdrAddr := ELF_LOAD_BASE + EhEPhOff^;
PhEnt := EhEPhEnt^;
PhNum := EhEPhNum^;
if (PhdrAddr = 0) or (PhEnt = 0) or (PhNum = 0) then Exit;
{ Find PT_TLS among the program headers. }
TlsVaddr := 0; TlsFileSz := 0; TlsMemSz := 0; TlsAlign := 8;
I := 0;
while I < PhNum do
begin
Ph := PChar(Pointer(PhdrAddr + I * PhEnt));
PType := Pointer(Ph + PH_TYPE);
if PType^ = PT_TLS then
begin
TlsVaddr := PInt64(Pointer(Ph + PH_VADDR))^;
TlsFileSz := PInt64(Pointer(Ph + PH_FILESZ))^;
TlsMemSz := PInt64(Pointer(Ph + PH_MEMSZ))^;
TlsAlign := PInt64(Pointer(Ph + PH_ALIGN))^;
Break;
end;
I := I + 1;
end;
if TlsMemSz = 0 then Exit;
{ Stash the template so BuildThreadTLS can reproduce this block per thread. }
GTlsInitAddr := Pointer(TlsVaddr);
GTlsFileSz := TlsFileSz;
GTlsMemSz := TlsMemSz;
GTlsAlign := TlsAlign;
{ Allocate block = aligned(memsz) + 16 (TCB self-pointer + slack). mmap
zero-fills. }
BlockSize := AlignUp(TlsMemSz, TlsAlign) + 16;
Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Block) < 0 then Exit;
{ Copy the .tdata init image to the start of the block; .tbss stays zero. }
Src := PChar(Pointer(TlsVaddr));
Dst := PChar(Block);
J := 0;
while J < TlsFileSz do
begin
Dst[J] := Src[J];
J := J + 1;
end;
{ Thread pointer sits just past the TLS data (variant II); store the TCB
self-pointer at *tp and set %fs. }
Tp := Pointer(PChar(Block) + AlignUp(TlsMemSz, TlsAlign));
TpSlot := PPointer(Tp);
TpSlot^ := Tp;
SetFsBase(Tp);
end;
{ Build a per-thread TLS block from the template captured at startup and return
its thread pointer. Mirrors SetupTLS's block construction (variant II: TLS
data, then the TCB self-pointer at the thread pointer). On FreeBSD the caller
installs the returned TP as the new thread's %fs base via thr_new's tls_base. }
function BuildThreadTLS: Pointer;
var
Block, Tp: Pointer;
BlockSize, J: Int64;
Src, Dst: PChar;
TpSlot: PPointer;
begin
Result := nil;
if GTlsMemSz = 0 then Exit;
BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Block) < 0 then Exit;
Src := PChar(GTlsInitAddr);
Dst := PChar(Block);
J := 0;
while J < GTlsFileSz do
begin
Dst[J] := Src[J];
J := J + 1;
end;
Tp := Pointer(PChar(Block) + AlignUp(GTlsMemSz, GTlsAlign));
TpSlot := PPointer(Tp);
TpSlot^ := Tp;
Result := Tp;
end;
procedure FreeThreadTLS(ATp: Pointer);
var
Block: Pointer;
BlockSize: Int64;
begin
if (ATp = nil) or (GTlsMemSz = 0) then Exit;
Block := Pointer(PChar(ATp) - AlignUp(GTlsMemSz, GTlsAlign));
BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
munmap(Block, BlockSize);
end;
function ThreadTLSSize: Int64;
begin
if GTlsMemSz = 0 then
Result := 0
else
Result := AlignUp(GTlsMemSz, GTlsAlign) + 16;
end;
{ Call the program's `main(argc, argv)` (emitted by the backend) and return its
result. The asm thunk tail-jumps to the bare `main` symbol; argc/argv are
already in %edi/%rsi (SysV), exactly what main expects. }
function MainTrampoline(Argc: Integer; Argv: Pointer): Integer;
assembler; nostackframe;
asm
jmp main
end;
{ The C-level entry. The kernel hands us the initial process stack: argc, then
argv[], NULL, envp[], NULL, auxv. On FreeBSD the entry %rsp must be 16-byte
aligned, and the kernel achieves that by inserting a ZERO PAD WORD immediately
below argc when the argument-vector layout would otherwise leave argc at an
8-mod-16 address (this depends on the argc+envc pointer-count parity, so it
varies between the shell-launched top-level and an execve'd child with a
different environment). So argc is at [SP] usually, but at [SP+8] when a pad
word is present. Detect the pad: a real argc is a small non-negative count
and the slot after it (argv[0]) is a valid pointer; a pad word reads 0. If
[SP] is 0 and [SP+8] is a plausible argc, skip the pad word. }
procedure _BlaiseStartC(SP: Pointer);
var
Argc: Int64;
Argv, Envp: Pointer;
Ret: Integer;
begin
Argc := PInt64(SP)^;
{ Skip a kernel alignment pad word below argc, if present. }
if Argc = 0 then
begin
if PInt64(Pointer(PChar(SP) + 8))^ > 0 then
SP := Pointer(PChar(SP) + 8);
Argc := PInt64(SP)^;
end;
Argv := Pointer(PChar(SP) + 8);
{ envp = &argv[argc+1] }
Envp := Pointer(PChar(Argv) + (Argc + 1) * 8);
environ := Envp;
{ TLS is set up by reading our own ELF program headers directly from this
binary's ELF header at the fixed non-PIE load base (see SetupTLS). A
non-PIE ET_EXEC always maps its own header there, so this is exact and
needs no kernel auxv. }
SetupTLS();
Ret := MainTrampoline(Integer(Argc), Argv);
_exit(Ret);
end;
{ The kernel entry. Capture %rsp (points at argc), align, and call the Pascal
core. Never returns. }
procedure _start; assembler; nostackframe;
asm
endbr64
xor %ebp, %ebp
movq %rsp, %rdi { SP -> first arg }
andq $0xfffffffffffffff0, %rsp
call _BlaiseStartC
xorl %edi, %edi
movq $1, %rax { SYS_exit(0) guard }
syscall
hlt
end;
end.

260
compiler/src/main/pascal/runtime.start.static.linux.pas
View file

@ -1,260 +0,0 @@
{
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 runtime.start.static.linux;
// Freestanding _start for a static, libc-free Linux ET_EXEC (the --static
// kernel-leaf swap; docs/linux-syscall-migration.adoc).
//
// A tiny asm trampoline captures the initial stack pointer and tail-calls the
// Pascal _BlaiseStartC, which:
// 1. parses argc / argv / envp / the auxv (the kernel's initial stack);
// 2. sets up the static TLS block and the thread pointer (%fs) - required
// before any threadvar (%fs-relative) access, which a static binary's
// kernel does NOT do for us;
// 3. captures `environ`;
// 4. calls main(argc, argv);
// 5. exit_group with main's return (main itself calls exit, so this is a
// guard).
//
// x86-64 TLS (variant II): the thread pointer points at the TCB, which sits
// ABOVE the TLS block; threadvars are at negative offsets from the TP. %fs:0
// must hold the TP value itself (the TCB self-pointer). Layout we build:
// [ TLS block: memsz bytes ][ TCB: 8-byte self-pointer ]
// tp = block + memsz_aligned ; %fs = tp ; *(void**)tp = tp.
interface
uses
runtime.syscall.linux; { syscalls + the `environ` global }
procedure _start;
{ The static TLS template, captured from PT_TLS at startup so each spawned thread
can build its own TLS block (runtime.thread.static.linux uses these via clone +
CLONE_SETTLS). Zero TlsMemSz means the program has no thread-local storage. }
var
GTlsInitAddr: Pointer; { .tdata init image (= PT_TLS p_vaddr) }
GTlsFileSz: Int64; { bytes to copy from the init image }
GTlsMemSz: Int64; { total TLS size (.tdata + .tbss) }
GTlsAlign: Int64; { PT_TLS alignment }
{ Build a fresh TLS block for a new thread and return its thread pointer (the
value to load into %fs). Layout matches _start's SetupTLS: aligned TLS data
followed by the TCB self-pointer. Returns nil when the program has no TLS. }
function BuildThreadTLS: Pointer;
{ Unmap a TLS block created by BuildThreadTLS, given the thread pointer it
returned. Used to reclaim the block when thread creation fails after the TLS
was built (the offset from TP back to the mmap base is the same alignment math
BuildThreadTLS used, kept here so both sides agree). }
procedure FreeThreadTLS(ATp: Pointer);
implementation
type
PPointer = ^Pointer;
PInt64 = ^Int64;
const
ARCH_SET_FS = $1002;
PROT_RW = 3; { PROT_READ or PROT_WRITE }
MAP_PRIVANON = $22; { MAP_PRIVATE or MAP_ANONYMOUS }
AT_NULL = 0;
AT_PHDR = 3;
AT_PHENT = 4;
AT_PHNUM = 5;
PT_TLS = 7;
{ ELF64 Phdr field offsets. }
PH_TYPE = 0; { p_type (u32) }
PH_OFFSET = 8; { p_offset (u64) - file offset; == vaddr-base in our images }
PH_VADDR = 16; { p_vaddr (u64) }
PH_FILESZ = 32; { p_filesz (u64) }
PH_MEMSZ = 40; { p_memsz (u64) }
PH_ALIGN = 48; { p_align (u64) }
{ Round X up to the next multiple of A (A a power of two, >= 1). }
function AlignUp(X, A: Int64): Int64;
begin
if A < 1 then A := 1;
Result := (X + A - 1) and (not (A - 1));
end;
{ Walk the auxv for PT_TLS via AT_PHDR/AT_PHENT/AT_PHNUM, then build the static
TLS block and set the thread pointer. Auxv is an array of (Int64 tag, Int64
val) pairs terminated by AT_NULL. No-op when the program has no TLS. }
procedure SetupTLS(Auxv: Pointer);
var
P: PInt64;
PhdrAddr, PhEnt, PhNum: Int64;
I, Tag, Val: Int64;
Ph: PChar;
TlsVaddr, TlsFileSz, TlsMemSz, TlsAlign: Int64;
PType: ^Integer;
Block, Tp: Pointer;
BlockSize: Int64;
J: Int64;
Src, Dst: PChar;
TpSlot: PPointer;
begin
PhdrAddr := 0; PhEnt := 56; PhNum := 0;
P := PInt64(Auxv);
while True do
begin
Tag := P^;
P := PInt64(Pointer(PChar(P) + 8));
Val := P^;
P := PInt64(Pointer(PChar(P) + 8));
if Tag = AT_NULL then Break;
if Tag = AT_PHDR then PhdrAddr := Val;
if Tag = AT_PHENT then PhEnt := Val;
if Tag = AT_PHNUM then PhNum := Val;
end;
if PhdrAddr = 0 then Exit;
{ Find PT_TLS among the program headers. }
TlsVaddr := 0; TlsFileSz := 0; TlsMemSz := 0; TlsAlign := 8;
I := 0;
while I < PhNum do
begin
Ph := PChar(Pointer(PhdrAddr + I * PhEnt));
PType := Pointer(Ph + PH_TYPE);
if PType^ = PT_TLS then
begin
TlsVaddr := PInt64(Pointer(Ph + PH_VADDR))^;
TlsFileSz := PInt64(Pointer(Ph + PH_FILESZ))^;
TlsMemSz := PInt64(Pointer(Ph + PH_MEMSZ))^;
TlsAlign := PInt64(Pointer(Ph + PH_ALIGN))^;
Break;
end;
I := I + 1;
end;
if TlsMemSz = 0 then Exit;
{ Stash the template so BuildThreadTLS can reproduce this block per thread. }
GTlsInitAddr := Pointer(TlsVaddr);
GTlsFileSz := TlsFileSz;
GTlsMemSz := TlsMemSz;
GTlsAlign := TlsAlign;
{ Allocate block = aligned(memsz) + 8 (TCB self-pointer). mmap zero-fills. }
BlockSize := AlignUp(TlsMemSz, TlsAlign) + 16;
Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Block) < 0 then Exit;
{ Copy the .tdata init image to the start of the block; .tbss stays zero. }
Src := PChar(Pointer(TlsVaddr));
Dst := PChar(Block);
J := 0;
while J < TlsFileSz do
begin
Dst[J] := Src[J];
J := J + 1;
end;
{ Thread pointer sits just past the TLS data (variant II); store the TCB
self-pointer at *tp and set %fs. }
Tp := Pointer(PChar(Block) + AlignUp(TlsMemSz, TlsAlign));
TpSlot := PPointer(Tp);
TpSlot^ := Tp;
arch_prctl(ARCH_SET_FS, Tp);
end;
{ Build a per-thread TLS block from the template captured at startup and return
its thread pointer. Mirrors SetupTLS's block construction (variant II: TLS
data, then the TCB self-pointer at the thread pointer). The caller installs
the returned TP into %fs (clone's CLONE_SETTLS does that for a new thread). }
function BuildThreadTLS: Pointer;
var
Block, Tp: Pointer;
BlockSize, J: Int64;
Src, Dst: PChar;
TpSlot: PPointer;
begin
Result := nil;
if GTlsMemSz = 0 then Exit;
BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Block) < 0 then Exit;
Src := PChar(GTlsInitAddr);
Dst := PChar(Block);
J := 0;
while J < GTlsFileSz do
begin
Dst[J] := Src[J];
J := J + 1;
end;
Tp := Pointer(PChar(Block) + AlignUp(GTlsMemSz, GTlsAlign));
TpSlot := PPointer(Tp);
TpSlot^ := Tp;
Result := Tp;
end;
procedure FreeThreadTLS(ATp: Pointer);
var
Block: Pointer;
BlockSize: Int64;
begin
if (ATp = nil) or (GTlsMemSz = 0) then Exit;
Block := Pointer(PChar(ATp) - AlignUp(GTlsMemSz, GTlsAlign));
BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
munmap(Block, BlockSize);
end;
{ Call the program's `main(argc, argv)` (emitted by the backend) and return its
result. The asm thunk tail-jumps to the bare `main` symbol; argc/argv are
already in %edi/%rsi (SysV), exactly what main expects. }
function MainTrampoline(Argc: Integer; Argv: Pointer): Integer;
assembler; nostackframe;
asm
jmp main
end;
{ The C-level entry: SP points at the kernel's initial stack (argc at [SP]). }
procedure _BlaiseStartC(SP: Pointer);
var
Argc: Int64;
Argv, Envp, Auxv: Pointer;
I: Int64;
Ret: Integer;
begin
Argc := PInt64(SP)^;
Argv := Pointer(PChar(SP) + 8);
{ envp = &argv[argc+1] }
Envp := Pointer(PChar(Argv) + (Argc + 1) * 8);
environ := Envp;
{ auxv follows envp's NULL terminator. }
Auxv := Envp;
I := 0;
while PPointer(Pointer(PChar(Auxv) + I * 8))^ <> nil do
I := I + 1;
Auxv := Pointer(PChar(Auxv) + (I + 1) * 8);
SetupTLS(Auxv);
Ret := MainTrampoline(Integer(Argc), Argv);
_exit(Ret);
end;
{ The kernel entry. Capture %rsp (points at argc), align, and call the Pascal
core. Never returns. }
procedure _start; assembler; nostackframe;
asm
endbr64
xor %ebp, %ebp
movq %rsp, %rdi { SP -> first arg }
andq $0xfffffffffffffff0, %rsp
call _BlaiseStartC
xorl %edi, %edi
movq $231, %rax { exit_group(0) guard }
syscall
hlt
end;
end.

614
compiler/src/main/pascal/runtime.syscall.freebsd.pas
View file

@ -1,614 +0,0 @@
{
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 runtime.syscall.freebsd;
// FreeBSD x86_64 direct-syscall kernel leaf — the libc replacement for a static,
// libc-free FreeBSD ET_EXEC (docs/freebsd-x86_64-backend-design.adoc, Step 3/4).
//
// This is the FreeBSD sibling of runtime.syscall.linux. It DEFINES the bare
// POSIX names that rtl.platform.posix references via `external name 'write'`
// etc.; the FreeBSD RTL composition links it (the link-time swap) in place of
// the Linux leaf, so the resulting binary reaches the kernel with raw
// `syscall`s and needs no libc, no PT_INTERP.
//
// Step 4a scope: the file/process syscall leaves (open/close/read/write/lseek,
// stat/fstat/mkdir/rmdir/unlink/rename/chdir/chmod, getpid/dup2/pipe/fork/
// execve/wait4/kill/getcwd, mmap/munmap/nanosleep/clock_gettime), plus the
// pre-existing `_exit`, `_sys_write` and `environ`. The harder leaves
// (memcpy/memset, date math, the mmap allocator, threads) grow here in Steps
// 4b/4c.
//
// System V AMD64 -> FreeBSD syscall ABI:
// * syscall number in %rax; args in %rdi,%rsi,%rdx,%r10,%r8,%r9 (the 4th C
// arg %rcx must be moved to %r10 — the `syscall` instruction clobbers %rcx).
// * The syscall NUMBERS differ from Linux (exit=1, write=4, read=3, open=5,
// close=6 — see sys/syscall.h); they are NOT Linux's. FreeBSD 12 renumbered
// stat/fstat/lseek/mmap for the 64-bit-inode ("ino64") ABI; this leaf uses
// the ino64 numbers to match the FreeBSD 14 224-byte `struct stat` that the
// rtl.platform.layout.freebsd adapter expects.
// * ERROR CONVENTION — the key FreeBSD difference from Linux. FreeBSD reports
// errors via the CARRY FLAG: on error CF is set and %rax holds a POSITIVE
// errno; on success CF is clear and %rax is the result. The Pascal call
// sites in rtl.platform.posix expect the Linux -errno convention (they test
// `if Fd < 0`, `< 0`, `<> 0`). So every leaf that can fail translates:
// after `syscall`, `jae` past a `negq %rax` when CF is clear (success —
// leave %rax untouched); when CF is set, `negq %rax` turns the positive
// errno into -errno. Each body uses a UNIQUE local label (.Lok_xxx) so the
// forward-local jumps do not collide when the unit assembles to one object.
//
// `nostackframe` lets each asm body own the frame so the registers hold the raw
// incoming arguments unmodified.
interface
{ File descriptors. }
function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
function close(Fd: Integer): Integer;
function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
{ `write` collides with the Write/WriteLn builtin as a Pascal identifier, so the
Pascal name is _sys_write; the asm body additionally emits a bare `write`
label (.globl) so the linker symbol matches rtl.platform.posix's
`external name 'write'`. Every other leaf's name is a valid Pascal identifier
and needs no alias. }
function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
{ Filesystem. }
function fstat(Fd: Integer; Buf: Pointer): Integer;
{ FreeBSD's ino64 ABI has NO plain `stat` syscall — it is expressed as
fstatat(AT_FDCWD, path, buf, 0). This wrapper sets up that call so the bare
`stat` symbol posix imports still resolves. }
function stat(Path: PChar; Buf: Pointer): Integer;
function mkdir(Path: PChar; Mode: Integer): Integer;
function rmdir(Path: PChar): Integer;
function unlink(Path: PChar): Integer;
function rename(OldPath, NewPath: PChar): Integer;
function chdir(Path: PChar): Integer;
function chmod(Path: PChar; Mode: Integer): Integer;
{ Process. }
function getpid: Integer;
function dup2(OldFd, NewFd: Integer): Integer;
{ FreeBSD deprecated the 2-arg pipe(2) (legacy 42); this calls pipe2(fds, 0). }
function pipe(Fds: Pointer): Integer;
{ Memory. }
function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
Offset: Int64): Pointer;
function munmap(Addr: Pointer; Length: Int64): Integer;
{ mremap(old, oldsz, newsz, flags): FreeBSD has NO in-place remap syscall, so
this is a stub that always reports failure (MAP_FAILED = -1). runtime.mem's
large-realloc path already treats an mremap failure as "grow the slow way":
it allocates a fresh region, memcpy's the old contents across, and frees the
old one (see the MapFailed fall-through in _BlaiseReallocMem). Exporting the
`mremap` symbol as a failing stub therefore gives the allocator its no-mremap
grow fallback with no allocator changes. Signature matches the Linux leaf so
runtime.mem's `external name 'mremap'` binds on both targets. }
function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
NewAddr: Pointer): Pointer;
{ Time. }
function nanosleep(Req, Rem: Pointer): Integer;
function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
{ Process control + raw primitives the higher-level wrappers build on. }
function fork: Integer;
function execve(Path: PChar; Argv, Envp: Pointer): Integer;
function wait4(Pid: Integer; Status: Pointer; Options: Integer;
Rusage: Pointer): Integer;
function kill(Pid, Sig: Integer): Integer;
{ getrandom(buf, count, flags): fill buf with count random bytes; returns the
count written or -errno. Used by mkstemp's random suffix. }
function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
{ Raw __getcwd(2): fills Buf (up to Size); returns 0 on success or -errno. The
wrapper in the posix layer adapts that to libc's buffer-pointer contract. }
function sys_getcwd(Buf: PChar; Size: Int64): Int64;
{ Raw __sysctl(2) — SYS 202. FreeBSD's structured kernel-state query; the
freestanding sysconf (runtime.libc.freebsd) reads hw.ncpu through it since
FreeBSD has no sched_getaffinity. 6-arg syscall (arg4 %rcx -> %r10); returns
0 on success or -errno (CF-translated). }
function sysctl(Name: Pointer; NameLen: Integer; OldP: Pointer;
OldLenP: Pointer; NewP: Pointer; NewLen: Int64): Integer;
{ Threads + TLS (Step 4c) — the FreeBSD primitives runtime.thread.static.freebsd
and runtime.start.static.freebsd build on. These have no Linux equivalents
(Linux uses clone/futex/arch_prctl); the numbers are FreeBSD-specific. }
{ sysarch(op, parms) — SYS 165. The FreeBSD way to set the %fs base for TLS:
op = AMD64_SET_FSBASE (129), parms = a POINTER to the base value (NOT the value
itself). Returns 0 on success or -errno (CF-translated). }
function sysarch(Op: Integer; Parms: Pointer): Integer;
{ _umtx_op(obj, op, val, uaddr, uaddr2) — SYS 454. The FreeBSD futex analogue.
op = UMTX_OP_WAIT_UINT_PRIVATE (15) blocks while obj^ = val (returns at once if
obj^ <> val, like futex); op = UMTX_OP_WAKE_PRIVATE (16) wakes up to val waiters
on obj. 5-arg syscall: arg4 (uaddr) arrives in %rcx -> moved to %r10. }
function _umtx_op(Obj: Pointer; Op, Val: Integer; Uaddr, Uaddr2: Pointer): Integer;
{ thr_new(param, param_size) — SYS 455. Creates a new thread from a filled-in
`struct thr_param` (param_size = sizeof = 104 on amd64). The FreeBSD analogue
of clone(2). Returns 0 on success or -errno. }
function thr_new(Param: Pointer; ParamSize: Integer): Integer;
{ thr_exit(state) — SYS 431. Terminates JUST the calling thread (NOT the whole
process — that is exit(2)/SYS_exit). If state is non-nil the kernel writes 1
there and _umtx_op-wakes it; we clear/wake the join word ourselves and pass nil.
Never returns. }
procedure thr_exit(State: Pointer);
{ _exit(2) — SYS_exit = 1. Terminates the process; never returns. The
unit-level routine name `_exit` already emits the unmangled `_exit` symbol that
satisfies posix's `external name '_exit'`. }
procedure _exit(Code: Integer);
{ The current process environment (envp), captured by _start. rtl.platform.posix
/ getenv walk this NULL-terminated array. Defined here (as on Linux) so the
kernel leaf owns it. }
var
environ: Pointer;
implementation
{ ---- FreeBSD x86_64 syscall numbers (FreeBSD 14 sys/sys/syscall.h). ----
Verified against
https://raw.githubusercontent.com/freebsd/freebsd-src/release/14.0.0/sys/sys/syscall.h
ino64 variants used where FreeBSD 12 renumbered (fstat=551, lseek=478,
mmap=477; stat has no ino64 syscall — expressed via fstatat=552). }
const
SYS_exit = 1;
SYS_fork = 2;
SYS_read = 3;
SYS_write = 4;
SYS_open = 5;
SYS_close = 6;
SYS_wait4 = 7;
SYS_unlink = 10;
SYS_chdir = 12;
SYS_chmod = 15;
SYS_getpid = 20;
SYS_kill = 37;
SYS_munmap = 73;
SYS_dup2 = 90;
SYS_rename = 128;
SYS_mkdir = 136;
SYS_rmdir = 137;
SYS_getcwd = 326; { __getcwd }
SYS_sysctl = 202; { __sysctl (hw.ncpu for sysconf) }
SYS_getrandom = 563;
SYS_clock_gettime = 232;
SYS_nanosleep = 240;
SYS_mmap = 477; { ino64 (legacy freebsd6 mmap = 197) }
SYS_lseek = 478; { ino64 (legacy lseek = 199) }
SYS_fstat = 551; { ino64 (legacy freebsd11_fstat = 189) }
SYS_fstatat = 552; { ino64 (legacy freebsd11_fstatat = 493) }
SYS_pipe2 = 542; { pipe(2) legacy 42 deprecated }
SYS_execve = 59;
SYS_sysarch = 165; { %fs-base setup for TLS (AMD64_SET_FSBASE) }
SYS_thr_exit = 431; { terminate ONE thread (NOT exit(2)) }
SYS_umtx_op = 454; { the FreeBSD futex analogue }
SYS_thr_new = 455; { the FreeBSD clone(2) analogue }
AT_FDCWD = -100; { dirfd for path-relative *at() syscalls at cwd }
{ The asm bodies use literal immediates (the assembler needs a literal, not a
symbol); the const block above documents the number-to-name mapping. }
function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
assembler; nostackframe;
asm
movq $5, %rax { SYS_open }
syscall
jae .Lok_open { CF clear = success }
negq %rax { CF set = error: errno -> -errno }
.Lok_open:
ret
end;
function close(Fd: Integer): Integer;
assembler; nostackframe;
asm
movq $6, %rax { SYS_close }
syscall
jae .Lok_close
negq %rax
.Lok_close:
ret
end;
function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
assembler; nostackframe;
asm
movq $3, %rax { SYS_read }
syscall
jae .Lok_read
negq %rax
.Lok_read:
ret
end;
{ write CAN fail; posix's write-loop expects a negative return on error, so it
gets CF-translation too. }
function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
assembler; nostackframe;
asm
.globl write
write:
movq $4, %rax { SYS_write }
syscall
jae .Lok_write
negq %rax
.Lok_write:
ret
end;
function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
assembler; nostackframe;
asm
movq $478, %rax { SYS_lseek (ino64) }
syscall
jae .Lok_lseek
negq %rax
.Lok_lseek:
ret
end;
function fstat(Fd: Integer; Buf: Pointer): Integer;
assembler; nostackframe;
asm
movq $551, %rax { SYS_fstat (ino64) }
syscall
jae .Lok_fstat
negq %rax
.Lok_fstat:
ret
end;
{ stat(path, buf) -> fstatat(AT_FDCWD, path, buf, 0). Incoming: %rdi=Path,
%rsi=Buf. Shift to the fstatat argument layout: dirfd(%rdi)=AT_FDCWD,
path(%rsi)=Path, buf(%rdx)=Buf, flag(%r10)=0. arg4 goes straight to %r10
(the syscall's 4th kernel register); no %rcx move is needed since we build
the arguments here rather than receive four C args. }
function stat(Path: PChar; Buf: Pointer): Integer;
assembler; nostackframe;
asm
movq %rsi, %rdx { buf -> arg3 }
movq %rdi, %rsi { path -> arg2 }
movq $-100, %rdi { AT_FDCWD -> arg1 (dirfd) }
xorq %r10, %r10 { flag = 0 -> arg4 }
movq $552, %rax { SYS_fstatat (ino64) }
syscall
jae .Lok_stat
negq %rax
.Lok_stat:
ret
end;
function mkdir(Path: PChar; Mode: Integer): Integer;
assembler; nostackframe;
asm
movq $136, %rax { SYS_mkdir }
syscall
jae .Lok_mkdir
negq %rax
.Lok_mkdir:
ret
end;
function chmod(Path: PChar; Mode: Integer): Integer;
assembler; nostackframe;
asm
movq $15, %rax { SYS_chmod }
syscall
jae .Lok_chmod
negq %rax
.Lok_chmod:
ret
end;
function rmdir(Path: PChar): Integer;
assembler; nostackframe;
asm
movq $137, %rax { SYS_rmdir }
syscall
jae .Lok_rmdir
negq %rax
.Lok_rmdir:
ret
end;
function unlink(Path: PChar): Integer;
assembler; nostackframe;
asm
movq $10, %rax { SYS_unlink }
syscall
jae .Lok_unlink
negq %rax
.Lok_unlink:
ret
end;
function rename(OldPath, NewPath: PChar): Integer;
assembler; nostackframe;
asm
movq $128, %rax { SYS_rename }
syscall
jae .Lok_rename
negq %rax
.Lok_rename:
ret
end;
function chdir(Path: PChar): Integer;
assembler; nostackframe;
asm
movq $12, %rax { SYS_chdir }
syscall
jae .Lok_chdir
negq %rax
.Lok_chdir:
ret
end;
function getpid: Integer;
assembler; nostackframe;
asm
movq $20, %rax { SYS_getpid }
syscall
ret { getpid never fails; no CF translation }
end;
function dup2(OldFd, NewFd: Integer): Integer;
assembler; nostackframe;
asm
movq $90, %rax { SYS_dup2 }
syscall
jae .Lok_dup2
negq %rax
.Lok_dup2:
ret
end;
{ pipe(fds) -> pipe2(fds, 0). Incoming: %rdi=Fds; add flags=0 in %rsi. }
function pipe(Fds: Pointer): Integer;
assembler; nostackframe;
asm
xorq %rsi, %rsi { flags = 0 }
movq $542, %rax { SYS_pipe2 }
syscall
jae .Lok_pipe
negq %rax
.Lok_pipe:
ret
end;
{ mmap has 6 args; arg4 (Flags) arrives in %rcx (C ABI) but the kernel wants it
in %r10. Move it before the syscall.
Flag translation: the shared allocator (runtime.mem) and other callers pass
the LINUX MAP_ANONYMOUS bit (0x20); FreeBSD's MAP_ANON is 0x1000. Without
MAP_ANON the kernel treats the mapping as file-backed on fd -1 and fails with
EBADF (then the caller derefs the -errno result and SIGSEGVs). So if the
Linux anon bit is set, clear it and set FreeBSD's — keeping runtime.mem
OS-agnostic (it uses one canonical, Linux-shaped flag set; the per-OS leaf
reconciles it). 0x1000 already set (e.g. from runtime.start.static.freebsd)
passes through untouched. }
function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
Offset: Int64): Pointer;
assembler; nostackframe;
asm
testl $0x20, %ecx { Linux MAP_ANONYMOUS present? }
jz .Lnoanon_mmap
andl $0xffffffdf, %ecx { clear 0x20 }
orl $0x1000, %ecx { set FreeBSD MAP_ANON }
.Lnoanon_mmap:
movq %rcx, %r10
movq $477, %rax { SYS_mmap (ino64) }
syscall
jae .Lok_mmap
negq %rax
.Lok_mmap:
ret
end;
function munmap(Addr: Pointer; Length: Int64): Integer;
assembler; nostackframe;
asm
movq $73, %rax { SYS_munmap }
syscall
jae .Lok_munmap
negq %rax
.Lok_munmap:
ret
end;
{ mremap: no FreeBSD in-place-remap syscall. Always return MAP_FAILED (-1) so
the allocator takes its alloc-new-copy-free fallback (see the interface note). }
function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
NewAddr: Pointer): Pointer;
begin
Result := Pointer(-1);
end;
function nanosleep(Req, Rem: Pointer): Integer;
assembler; nostackframe;
asm
movq $240, %rax { SYS_nanosleep }
syscall
jae .Lok_nanosleep
negq %rax
.Lok_nanosleep:
ret
end;
function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
assembler; nostackframe;
asm
movq $232, %rax { SYS_clock_gettime }
syscall
jae .Lok_clock_gettime
negq %rax
.Lok_clock_gettime:
ret
end;
{ FreeBSD fork(2) has a two-register return the libc wrapper normalises and a
raw syscall must replicate: the kernel returns the child pid in %rax for the
PARENT with %edx = 0, but for the CHILD it returns the PARENT's pid in %rax
with %edx = 1 as the child indicator. Without zeroing the child's %eax when
%edx != 0, the child sees a non-zero "pid" and every `if fork() = 0 then
(child path)` check runs the PARENT branch in the child — so a spawned
subprocess never execve's its target and the parent reaps exit 127. Mirror
libc: if %edx != 0, this is the child -> return 0. }
function fork: Integer;
assembler; nostackframe;
asm
movq $2, %rax { SYS_fork }
syscall
jae .Lok_fork
negq %rax
ret
.Lok_fork:
testl %edx, %edx { %edx = 1 in the child, 0 in the parent }
jz .Lparent_fork
xorl %eax, %eax { child: return 0 }
.Lparent_fork:
ret
end;
function execve(Path: PChar; Argv, Envp: Pointer): Integer;
assembler; nostackframe;
asm
movq $59, %rax { SYS_execve }
syscall
jae .Lok_execve
negq %rax
.Lok_execve:
ret
end;
{ wait4 has 4 args; arg4 (Rusage) arrives in %rcx -> move to %r10. }
function wait4(Pid: Integer; Status: Pointer; Options: Integer;
Rusage: Pointer): Integer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $7, %rax { SYS_wait4 }
syscall
jae .Lok_wait4
negq %rax
.Lok_wait4:
ret
end;
function kill(Pid, Sig: Integer): Integer;
assembler; nostackframe;
asm
movq $37, %rax { SYS_kill }
syscall
jae .Lok_kill
negq %rax
.Lok_kill:
ret
end;
function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
assembler; nostackframe;
asm
movq $563, %rax { SYS_getrandom }
syscall
jae .Lok_getrandom
negq %rax
.Lok_getrandom:
ret
end;
function sys_getcwd(Buf: PChar; Size: Int64): Int64;
assembler; nostackframe;
asm
movq $326, %rax { SYS___getcwd }
syscall
jae .Lok_getcwd
negq %rax
.Lok_getcwd:
ret
end;
{ __sysctl(name, namelen, oldp, oldlenp, newp, newlen) — 6 args; SYS 202. arg4
(oldlenp) arrives in %rcx and must move to %r10 (syscall clobbers %rcx). }
function sysctl(Name: Pointer; NameLen: Integer; OldP: Pointer;
OldLenP: Pointer; NewP: Pointer; NewLen: Int64): Integer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $202, %rax { SYS___sysctl }
syscall
jae .Lok_sysctl
negq %rax
.Lok_sysctl:
ret
end;
{ sysarch(op, parms) — 2 args, both in %rdi/%rsi already; SYS 165. Used with
AMD64_SET_FSBASE to set the %fs base to the thread pointer. }
function sysarch(Op: Integer; Parms: Pointer): Integer;
assembler; nostackframe;
asm
movq $165, %rax { SYS_sysarch }
syscall
jae .Lok_sysarch
negq %rax
.Lok_sysarch:
ret
end;
{ _umtx_op(obj, op, val, uaddr, uaddr2) — 5 args; arg4 (uaddr) arrives in %rcx
(C ABI) but the kernel wants it in %r10. Move it before the syscall. SYS 454. }
function _umtx_op(Obj: Pointer; Op, Val: Integer; Uaddr, Uaddr2: Pointer): Integer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $454, %rax { SYS__umtx_op }
syscall
jae .Lok_umtx
negq %rax
.Lok_umtx:
ret
end;
{ thr_new(param, param_size) — 2 args, both in %rdi/%rsi already; SYS 455. }
function thr_new(Param: Pointer; ParamSize: Integer): Integer;
assembler; nostackframe;
asm
movq $455, %rax { SYS_thr_new }
syscall
jae .Lok_thr_new
negq %rax
.Lok_thr_new:
ret
end;
{ thr_exit(state) — SYS 431. Terminates JUST this thread; never returns, so no
CF translation is needed. State arrives in %rdi (nil in our use). }
procedure thr_exit(State: Pointer); assembler; nostackframe;
asm
movq $431, %rax { SYS_thr_exit }
syscall
ret
end;
{ _exit(code) — SYS_exit = 1. Terminates the process; never returns, so no
CF translation is needed. }
procedure _exit(Code: Integer); assembler; nostackframe;
asm
movq $1, %rax { SYS_exit }
syscall
ret
end;
end.

426
compiler/src/main/pascal/runtime.syscall.linux.pas
View file

@ -1,426 +0,0 @@
{
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 runtime.syscall.linux;
// Linux x86_64 direct-syscall kernel leaf - the libc replacement for the thin
// 1:1 syscall wrappers (docs/linux-syscall-migration.adoc).
//
// This unit DEFINES the bare POSIX names (open, read, write, ) that
// rtl.platform.posix.pas references via `external name 'open'` etc. When it is
// linked into a program (the --static link-time swap), those symbols resolve
// here as raw `syscall` stubs instead of being imported from libc.so.6 - so the
// resulting binary is a freestanding static ET_EXEC with no libc, no PT_INTERP.
//
// System V AMD64 -> Linux syscall ABI:
// * syscall number in %rax; the `syscall` instruction returns in %rax.
// * Argument registers DIFFER between the C ABI and the kernel ABI on the 4th
// argument: C passes arg4 in %rcx, the kernel expects it in %r10 (the
// `syscall` instruction itself clobbers %rcx). Wrappers with >= 4 args
// therefore `movq %rcx, %r10` first. Args 1-3 (%rdi,%rsi,%rdx) and 5-6
// (%r8,%r9) are already in the right registers.
// * The kernel returns -errno on error (a small negative value). libc would
// translate that to a -1 return + `errno`; the existing Pascal call sites
// test `if result < 0` / `if Fd < 0`, which a raw -errno also satisfies, so
// no errno table is needed for these leaves.
//
// `nostackframe` lets each asm body own the frame so the registers hold the raw
// incoming arguments unmodified.
interface
{ File descriptors. }
function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
function close(Fd: Integer): Integer;
function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
{ `write` collides with the Write/WriteLn builtin as a Pascal identifier, so the
Pascal name is _sys_write; the asm body additionally emits a bare `write`
label (.globl) so the linker symbol matches rtl.platform.posix's
`external name 'write'`. Every other leaf's name is a valid Pascal identifier
and needs no alias. }
function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
{ Filesystem. }
function fstat(Fd: Integer; Buf: Pointer): Integer;
function stat(Path: PChar; Buf: Pointer): Integer;
function mkdir(Path: PChar; Mode: Integer): Integer;
function rmdir(Path: PChar): Integer;
function unlink(Path: PChar): Integer;
function rename(OldPath, NewPath: PChar): Integer;
function chdir(Path: PChar): Integer;
function chmod(Path: PChar; Mode: Integer): Integer;
{ Process. }
function getpid: Integer;
function dup2(OldFd, NewFd: Integer): Integer;
function pipe(Fds: Pointer): Integer;
{ Memory. }
function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
Offset: Int64): Pointer;
function munmap(Addr: Pointer; Length: Int64): Integer;
{ mremap(old, oldsz, newsz, flags, newaddr) - 5 args; raw syscall. }
function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
NewAddr: Pointer): Pointer;
{ Time. }
function nanosleep(Req, Rem: Pointer): Integer;
function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
{ Process control + raw primitives the higher-level wrappers (runtime.libc.linux)
build on. These are the bare syscalls; the libc-shaped versions (execvp with
PATH search, waitpid, system, ) live in the wrapper unit. }
function fork: Integer;
function execve(Path: PChar; Argv, Envp: Pointer): Integer;
function wait4(Pid: Integer; Status: Pointer; Options: Integer;
Rusage: Pointer): Integer;
function sched_getaffinity(Pid: Integer; CpuSetSize: Int64;
Mask: Pointer): Integer;
{ futex(2): the kernel primitive the threads leaf builds mutexes and join on.
6-arg syscall; arg4 (Timeout) arrives in %rcx -> moved to %r10. Returns 0 or
a count on success, -errno on error. Op = FUTEX_WAIT(0) / FUTEX_WAKE(1). }
function futex(Uaddr: Pointer; Op, Val: Integer; Timeout: Pointer;
Uaddr2: Pointer; Val3: Integer): Integer;
function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
function arch_prctl(Code: Integer; Addr: Pointer): Integer;
function kill(Pid, Sig: Integer): Integer;
{ Raw time(2): returns seconds since the epoch; if T is non-nil it is also
written there. The kernel syscall handles the out-param itself. }
function sys_time(T: Pointer): Int64;
{ Raw getcwd(2): fills Buf (up to Size), returns the length INCLUDING the NUL on
success or -errno. (libc's getcwd returns the buffer pointer - the wrapper in
runtime.libc.linux adapts that.) }
function sys_getcwd(Buf: PChar; Size: Int64): Int64;
{ _exit(2) - exit_group, terminates all threads, runs NO atexit handlers.
The bare `exit` (which DOES run atexit handlers, called by main's epilogue) is
defined by runtime.libc2.linux alongside the registry, not here. }
procedure _exit(Code: Integer);
{ The process environment vector (NULL-terminated array of "KEY=VALUE" PChars),
captured by the freestanding _start from the initial stack. Lives in this
base unit (not the higher libc wrapper) so _start can use ONLY this unit and
avoid a diamond import; runtime.libc.linux's getenv/execvp read it. }
var
environ: Pointer;
implementation
{ ---- Linux x86_64 syscall numbers (arch/x86/entry/syscalls). ---- }
const
SYS_read = 0;
SYS_write = 1;
SYS_open = 2;
SYS_close = 3;
SYS_stat = 4;
SYS_fstat = 5;
SYS_lseek = 8;
SYS_mmap = 9;
SYS_munmap = 11;
SYS_pipe = 22;
SYS_dup2 = 33;
SYS_nanosleep = 35;
SYS_getpid = 39;
SYS_rename = 82;
SYS_mkdir = 83;
SYS_chmod = 90;
SYS_rmdir = 84;
SYS_unlink = 87;
SYS_chdir = 80;
SYS_clock_gettime = 228;
SYS_exit_group = 231;
SYS_mremap = 25;
SYS_fork = 57;
SYS_execve = 59;
SYS_wait4 = 61;
SYS_kill = 62;
SYS_getcwd = 79;
SYS_sched_getaffinity = 204;
SYS_futex = 202;
SYS_arch_prctl = 158;
SYS_time = 201;
SYS_getrandom = 318;
{ The asm bodies use literal immediates (the assembler needs a literal, not a
symbol); the const block above documents the number-to-name mapping. }
function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
assembler; nostackframe;
asm
movq $2, %rax { SYS_open }
syscall
ret
end;
function close(Fd: Integer): Integer;
assembler; nostackframe;
asm
movq $3, %rax { SYS_close }
syscall
ret
end;
function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
assembler; nostackframe;
asm
movq $0, %rax { SYS_read }
syscall
ret
end;
function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
assembler; nostackframe;
asm
.globl write
write:
movq $1, %rax { SYS_write }
syscall
ret
end;
function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
assembler; nostackframe;
asm
movq $8, %rax { SYS_lseek }
syscall
ret
end;
function fstat(Fd: Integer; Buf: Pointer): Integer;
assembler; nostackframe;
asm
movq $5, %rax { SYS_fstat }
syscall
ret
end;
function stat(Path: PChar; Buf: Pointer): Integer;
assembler; nostackframe;
asm
movq $4, %rax { SYS_stat }
syscall
ret
end;
function mkdir(Path: PChar; Mode: Integer): Integer;
assembler; nostackframe;
asm
movq $83, %rax { SYS_mkdir }
syscall
ret
end;
function chmod(Path: PChar; Mode: Integer): Integer;
assembler; nostackframe;
asm
movq $90, %rax { SYS_chmod }
syscall
ret
end;
function rmdir(Path: PChar): Integer;
assembler; nostackframe;
asm
movq $84, %rax { SYS_rmdir }
syscall
ret
end;
function unlink(Path: PChar): Integer;
assembler; nostackframe;
asm
movq $87, %rax { SYS_unlink }
syscall
ret
end;
function rename(OldPath, NewPath: PChar): Integer;
assembler; nostackframe;
asm
movq $82, %rax { SYS_rename }
syscall
ret
end;
function chdir(Path: PChar): Integer;
assembler; nostackframe;
asm
movq $80, %rax { SYS_chdir }
syscall
ret
end;
function getpid: Integer;
assembler; nostackframe;
asm
movq $39, %rax { SYS_getpid }
syscall
ret
end;
function dup2(OldFd, NewFd: Integer): Integer;
assembler; nostackframe;
asm
movq $33, %rax { SYS_dup2 }
syscall
ret
end;
function pipe(Fds: Pointer): Integer;
assembler; nostackframe;
asm
movq $22, %rax { SYS_pipe }
syscall
ret
end;
{ mmap has 6 args; arg4 (Flags) arrives in %rcx (C ABI) but the kernel wants it
in %r10. Move it before the syscall. }
function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
Offset: Int64): Pointer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $9, %rax { SYS_mmap }
syscall
ret
end;
function munmap(Addr: Pointer; Length: Int64): Integer;
assembler; nostackframe;
asm
movq $11, %rax { SYS_munmap }
syscall
ret
end;
function nanosleep(Req, Rem: Pointer): Integer;
assembler; nostackframe;
asm
movq $35, %rax { SYS_nanosleep }
syscall
ret
end;
function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
assembler; nostackframe;
asm
movq $228, %rax { SYS_clock_gettime }
syscall
ret
end;
{ mremap has 5 args; arg4 (Flags) arrives in %rcx -> move to %r10. }
function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
NewAddr: Pointer): Pointer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $25, %rax { SYS_mremap }
syscall
ret
end;
function fork: Integer;
assembler; nostackframe;
asm
movq $57, %rax { SYS_fork }
syscall
ret
end;
function execve(Path: PChar; Argv, Envp: Pointer): Integer;
assembler; nostackframe;
asm
movq $59, %rax { SYS_execve }
syscall
ret
end;
{ wait4 has 4 args; arg4 (Rusage) arrives in %rcx -> move to %r10. }
function wait4(Pid: Integer; Status: Pointer; Options: Integer;
Rusage: Pointer): Integer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $61, %rax { SYS_wait4 }
syscall
ret
end;
function sched_getaffinity(Pid: Integer; CpuSetSize: Int64;
Mask: Pointer): Integer;
assembler; nostackframe;
asm
movq $204, %rax { SYS_sched_getaffinity }
syscall
ret
end;
{ futex has 6 args; arg4 (Timeout) arrives in %rcx -> move to %r10. }
function futex(Uaddr: Pointer; Op, Val: Integer; Timeout: Pointer;
Uaddr2: Pointer; Val3: Integer): Integer;
assembler; nostackframe;
asm
movq %rcx, %r10
movq $202, %rax { SYS_futex }
syscall
ret
end;
function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
assembler; nostackframe;
asm
movq $318, %rax { SYS_getrandom }
syscall
ret
end;
function arch_prctl(Code: Integer; Addr: Pointer): Integer;
assembler; nostackframe;
asm
movq $158, %rax { SYS_arch_prctl }
syscall
ret
end;
function kill(Pid, Sig: Integer): Integer;
assembler; nostackframe;
asm
movq $62, %rax { SYS_kill }
syscall
ret
end;
function sys_time(T: Pointer): Int64;
assembler; nostackframe;
asm
movq $201, %rax { SYS_time }
syscall
ret
end;
function sys_getcwd(Buf: PChar; Size: Int64): Int64;
assembler; nostackframe;
asm
movq $79, %rax { SYS_getcwd }
syscall
ret
end;
{ _exit(2): terminate immediately via exit_group, running no atexit handlers.
Code arrives in %edi; exit_group reads its status from %rdi. }
procedure _exit(Code: Integer);
assembler; nostackframe;
asm
movq $231, %rax { SYS_exit_group }
syscall
ret
end;
end.

317
compiler/src/main/pascal/runtime.thread.static.freebsd.pas
View file

@ -1,317 +0,0 @@
{
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 runtime.thread.static.freebsd;
// Real POSIX threads for the FreeBSD --static (libc-free) build, implemented
// directly on the thr_new(2) and _umtx_op(2) syscalls
// (docs/freebsd-x86_64-backend-design.adoc, Step 4c). The FreeBSD sibling of
// runtime.thread.static.linux — the threads leaf that lets a static FreeBSD
// binary spawn worker threads (the compiler's TCompileWorker = class(TThread)).
//
// DEFINES the bare pthread_* names that runtime.weak, runtime.thread and
// classes.pas import via `external name`. The FreeBSD RTL composition links
// this unit (the link-time swap) in place of the Linux thread leaf / libc.
//
// Mutex: TARGET-INVARIANT — a 3-state futex mutex (Drepper, "Futexes Are
// Tricky"), copied verbatim from the Linux unit. The caller's mutex buffer is
// reused as the wait word (first Integer): 0 = unlocked, 1 = locked (no
// waiters), 2 = locked (waiters present). ONLY the kernel wait/wake primitive
// differs: Linux futex(WAIT/WAKE) -> FreeBSD _umtx_op(WAIT_UINT_PRIVATE=15 /
// WAKE_PRIVATE=16). WAIT_UINT returns at once if *word <> val (like futex), so
// the loop structure is identical.
//
// Thread: thr_new(2) with a filled `struct thr_param` (amd64 sizeof = 104). Each
// thread gets a fresh mmap'd stack + its own variant-II TLS block (built from
// the startup template; installed as the new thread's %fs base via thr_param's
// tls_base) so threadvar access (exception frames, the allocator) is per-thread.
//
// JOIN — the key FreeBSD difference from Linux. thr_new provides NO
// CLONE_CHILD_CLEARTID-style "clear-and-wake the tid word on exit"; child_tid is
// only written ONCE, on create, and never cleared on exit. So we use a dedicated
// JOIN word in the control block: the child's exit trampoline sets JoinWord = 1
// and _umtx_op-WAKEs it as its LAST act before thr_exit; pthread_join
// _umtx_op-WAITs on it while it reads 0. thr_exit (SYS 431) terminates JUST the
// thread — NOT exit(2)/SYS_exit, which would kill the whole process.
//
// Known limitation (same as the Linux leaf): a joined thread's TLS block is not
// unmapped — freeing it from the exiting thread is unsafe (the thread runs on it
// until thr_exit) and the join side cannot know its address. A small bounded
// per-thread leak, acceptable for the finite worker pools the compiler spawns.
interface
uses
runtime.syscall.freebsd, { mmap, _umtx_op, thr_new, thr_exit numbers }
runtime.start.static.freebsd; { BuildThreadTLS - the per-thread TLS template }
{ Mutex - the buffer's first Integer is the wait word. }
function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
function pthread_mutex_lock(Mutex: Pointer): Integer;
function pthread_mutex_unlock(Mutex: Pointer): Integer;
function pthread_mutex_destroy(Mutex: Pointer): Integer;
{ Thread create / join. *Thread receives an opaque handle (a control-block
pointer); pthread_join consumes it. }
function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
implementation
type
PInteger = ^Integer;
PInt64 = ^Int64;
const
{ Mutex wait-word states. }
MX_UNLOCKED = 0;
MX_LOCKED = 1;
MX_CONTENDED = 2;
{ _umtx_op operations (FreeBSD 14 sys/sys/umtx.h; verified). }
UMTX_OP_WAIT_UINT_PRIVATE = 15; { block while *obj = val }
UMTX_OP_WAKE_PRIVATE = 16; { wake up to `val` waiters on obj }
PROT_RW = 3; { PROT_READ or PROT_WRITE }
MAP_PRIVANON = $1002; { FreeBSD MAP_PRIVATE ($0002) or MAP_ANON ($1000) }
STACK_SIZE = 1024 * 1024; { 1 MiB per worker thread }
{ struct thr_param amd64 field offsets (FreeBSD 14 sys/sys/thr.h; verified). }
TP_START_FUNC = 0; { void (*)(void*) }
TP_ARG = 8; { void* }
TP_STACK_BASE = 16; { char* }
TP_STACK_SIZE = 24; { size_t }
TP_TLS_BASE = 32; { char* }
TP_TLS_SIZE = 40; { size_t }
TP_CHILD_TID = 48; { long* }
TP_PARENT_TID = 56; { long* }
TP_FLAGS = 64; { int (+ 4 bytes pad) }
TP_RTP = 72; { struct rtprio* }
TP_SPARE0 = 80; { void*[3] -> 80,88,96 }
THR_PARAM_SIZE = 104; { sizeof(struct thr_param) on amd64 }
{ The per-thread control block lives at the base of the mmap'd region.
StartRoutine/Arg are the real entry the trampoline calls; JoinWord is the
_umtx_op join word (child sets 1 + WAKEs on exit, parent WAITs while it reads 0);
TidWord is thr_new's child_tid (LONG* = 8 bytes on FreeBSD, so Int64 — the
kernel writes the 8-byte TID here on create; unlike Linux it is NOT cleared on
exit, hence the separate JoinWord). MapBase/MapSize record the region for
munmap after join. }
type
PThreadCB = ^TThreadCB;
TThreadCB = record
StartRoutine: Pointer;
Arg: Pointer;
JoinWord: Integer;
Pad: Integer;
TidWord: Int64;
MapBase: Pointer;
MapSize: Int64;
end;
{ ------------------------------------------------------------------ }
{ Mutex - 3-state futex (TARGET-INVARIANT; copied from the Linux leaf) }
{ ------------------------------------------------------------------ }
{ Atomic compare-and-swap on an Integer: if Ptr^ = Expected set it to NewVal;
returns the value that was in Ptr^ before the attempt. }
function CAS(Ptr: Pointer; Expected, NewVal: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax { %eax = Expected (cmpxchg compares against %eax) }
lock cmpxchgl %edx, (%rdi)
ret
end;
{ Atomic exchange: store NewVal into Ptr^, return the previous value. }
function Xchg(Ptr: Pointer; NewVal: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax
xchgl %eax, (%rdi)
ret
end;
function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
var
P: PInteger;
begin
P := PInteger(Mutex);
P^ := MX_UNLOCKED;
Result := 0;
end;
function pthread_mutex_lock(Mutex: Pointer): Integer;
var
C: Integer;
begin
{ Fast path: uncontended acquire. }
C := CAS(Mutex, MX_UNLOCKED, MX_LOCKED);
if C <> MX_UNLOCKED then
begin
{ Contended. Mark the lock contended and sleep until it is free. }
if C <> MX_CONTENDED then
C := Xchg(Mutex, MX_CONTENDED);
while C <> MX_UNLOCKED do
begin
{ WAIT_UINT_PRIVATE blocks while *Mutex = MX_CONTENDED (returns at once if
it already changed) — the FreeBSD analogue of FUTEX_WAIT. }
_umtx_op(Mutex, UMTX_OP_WAIT_UINT_PRIVATE, MX_CONTENDED, nil, nil);
C := Xchg(Mutex, MX_CONTENDED);
end;
end;
Result := 0;
end;
function pthread_mutex_unlock(Mutex: Pointer): Integer;
begin
{ If there were waiters (state 2), wake one after releasing. }
if Xchg(Mutex, MX_UNLOCKED) = MX_CONTENDED then
_umtx_op(Mutex, UMTX_OP_WAKE_PRIVATE, 1, nil, nil);
Result := 0;
end;
function pthread_mutex_destroy(Mutex: Pointer): Integer;
begin
Result := 0;
end;
{ ------------------------------------------------------------------ }
{ Thread create / join - thr_new(2) + _umtx_op(2) }
{ ------------------------------------------------------------------ }
{ Call Entry(Arg) — a raw indirect call so the trampoline can invoke the
caller-supplied StartRoutine held only as a Pointer. Entry arrives in %rdi,
Arg in %rsi; shuffle Arg to %rdi and call Entry. }
procedure CallEntry(Entry, Arg: Pointer); assembler; nostackframe;
asm
movq %rdi, %r11 { Entry }
movq %rsi, %rdi { Arg -> first arg }
call *%r11 { Entry(Arg) }
ret
end;
{ The thread's entry point (thr_param.start_func). The kernel starts the new
thread here with %rdi = thr_param.arg (our control-block pointer), on the fresh
stack, with the thread's own %fs already installed (tls_base). We call the real
StartRoutine(Arg), then set JoinWord = 1 and _umtx_op-WAKE it so pthread_join
unblocks, then thr_exit(nil) to terminate JUST this thread. }
procedure _thr_trampoline(CBPtr: Pointer);
var
CB: PThreadCB;
Entry: Pointer;
begin
CB := PThreadCB(CBPtr);
Entry := CB^.StartRoutine;
CallEntry(Entry, CB^.Arg);
{ Terminate this thread AND signal the joiner in one kernel step: pass the
join word as thr_exit's `state`. The kernel does `suword(state, 1)` +
umtx-wake on it AFTER the thread has stopped executing on its stack — so the
joiner cannot free the stack while this thread is still running on it. (The
previous code set JoinWord + WAKEd here, on the stack, BEFORE thr_exit, which
let pthread_join munmap the shared stack/CB region out from under this still-
live thread → SIGSEGV during teardown. Never touch the stack after the wake;
let thr_exit's kernel-side wake be the last event on this word.) }
thr_exit(@CB^.JoinWord);
end;
{ Store an 8-byte value at Base + Offset (used to fill struct thr_param). }
procedure PokeQ(Base: Pointer; Offset: Integer; Value: Int64);
var
Slot: PInt64;
begin
Slot := PInt64(Pointer(PChar(Base) + Offset));
Slot^ := Value;
end;
function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
var
Region: Pointer;
CB: PThreadCB;
StackTop: Pointer;
Tls: Pointer;
Param: array[0..THR_PARAM_SIZE - 1] of Byte;
ParamP: Pointer;
R: Integer;
HandleSlot: PInt64;
begin
{ One mapping holds the control block (at the base) and the thread stack
(above it). mmap zero-fills, so JoinWord starts at 0. }
Region := mmap(nil, STACK_SIZE, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Region) < 0 then
begin
Result := 11; { EAGAIN }
Exit;
end;
CB := PThreadCB(Region);
CB^.StartRoutine := StartRoutine;
CB^.Arg := Arg;
CB^.JoinWord := 0;
CB^.TidWord := 0;
CB^.MapBase := Region;
CB^.MapSize := STACK_SIZE;
{ Stack grows down from the top of the region; keep it 16-byte aligned. }
StackTop := Pointer(PChar(Region) + STACK_SIZE);
StackTop := Pointer(Int64(StackTop) and (not Int64(15)));
{ Each thread needs its own TLS block for threadvar access. }
Tls := BuildThreadTLS();
{ Fill struct thr_param on the stack (zero-init first so flags/rtp/spare = 0). }
ParamP := @Param[0];
PokeQ(ParamP, TP_START_FUNC, Int64(Pointer(@_thr_trampoline)));
PokeQ(ParamP, TP_ARG, Int64(CB));
PokeQ(ParamP, TP_STACK_BASE, Int64(Region));
{ stack_size = distance from the region base to the aligned stack top. }
PokeQ(ParamP, TP_STACK_SIZE, Int64(StackTop) - Int64(Region));
PokeQ(ParamP, TP_TLS_BASE, Int64(Tls));
PokeQ(ParamP, TP_TLS_SIZE, ThreadTLSSize());
PokeQ(ParamP, TP_CHILD_TID, Int64(@CB^.TidWord));
PokeQ(ParamP, TP_PARENT_TID, Int64(@CB^.TidWord));
PokeQ(ParamP, TP_FLAGS, 0); { flags = 0 (+ pad) }
PokeQ(ParamP, TP_RTP, 0); { rtp = nil -> default scheduling }
PokeQ(ParamP, TP_SPARE0, 0);
PokeQ(ParamP, TP_SPARE0 + 8, 0);
PokeQ(ParamP, TP_SPARE0 + 16, 0);
R := thr_new(ParamP, THR_PARAM_SIZE);
if R < 0 then
begin
munmap(Region, STACK_SIZE);
FreeThreadTLS(Tls); { reclaim the per-thread TLS block too }
Result := 11; { EAGAIN }
Exit;
end;
{ Hand the caller the control-block pointer as the opaque thread handle. }
HandleSlot := PInt64(Thread);
HandleSlot^ := Int64(CB);
Result := 0;
end;
function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
var
CB: PThreadCB;
W: Integer;
begin
CB := PThreadCB(Pointer(Thread));
{ The child sets JoinWord = 1 and _umtx_op-WAKEs it as its last act before
thr_exit. WAIT while it still reads 0. WAIT_UINT returns at once if the word
already changed, so no wake can be missed. }
W := CB^.JoinWord;
while W = 0 do
begin
_umtx_op(@CB^.JoinWord, UMTX_OP_WAIT_UINT_PRIVATE, 0, nil, nil);
W := CB^.JoinWord;
end;
munmap(CB^.MapBase, CB^.MapSize);
Result := 0;
end;
end.

283
compiler/src/main/pascal/runtime.thread.static.linux.pas
View file

@ -1,283 +0,0 @@
{
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 runtime.thread.static.linux;
// Real POSIX threads for the --static (libc-free) build, implemented directly on
// the clone(2) and futex(2) syscalls (docs/linux-syscall-migration.adoc). This
// is the threads leaf that lets a static binary spawn worker threads - the last
// piece needed for the compiler to self-host as a libc-free static ET_EXEC.
//
// DEFINES the bare pthread_* / sysconf names that runtime.weak, runtime.thread
// and classes.pas import via `external name`. The non-static build resolves the
// same names from libc.so; the --static link swaps in this unit instead.
//
// Mutex: a 3-state futex mutex (Drepper, "Futexes Are Tricky"). The caller's
// 48-byte pthread_mutex_t buffer is reused as the futex word (first Integer):
// 0 = unlocked, 1 = locked (no waiters), 2 = locked (waiters present).
//
// Thread: clone(2) with CLONE_VM|FS|FILES|SIGHAND|THREAD|SYSVSEM|SETTLS plus
// CLONE_PARENT_SETTID|CHILD_CLEARTID. Each thread gets a fresh mmap'd stack
// and its own TLS block (variant II) built from the startup template, so
// threadvar access (exception frames, the allocator) is per-thread. The
// kernel clears the child-tid futex word on thread exit; pthread_join
// futex-waits on it.
//
// Known limitation: a joined thread's TLS block (mmap'd by BuildThreadTLS) is
// not unmapped - freeing it from the exiting thread is unsafe (the thread runs
// on it until exit) and the join side cannot know its address. This is a small
// bounded per-thread leak, acceptable for the finite worker pools the compiler
// spawns; a thread-registry sweep can reclaim it later if needed.
interface
uses
runtime.syscall.linux, { mmap, futex, clone numbers }
runtime.start.static.linux; { BuildThreadTLS - the per-thread TLS template }
{ Mutex - the buffer's first Integer is the futex word. }
function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
function pthread_mutex_lock(Mutex: Pointer): Integer;
function pthread_mutex_unlock(Mutex: Pointer): Integer;
function pthread_mutex_destroy(Mutex: Pointer): Integer;
{ Thread create / join. *Thread receives an opaque handle (a control-block
pointer); pthread_join consumes it. }
function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
{ sysconf is provided by runtime.libc.linux (sched_getaffinity + popcount); it is
not redefined here. }
implementation
type
PInteger = ^Integer;
PInt64 = ^Int64;
const
{ Mutex futex states. }
MX_UNLOCKED = 0;
MX_LOCKED = 1;
MX_CONTENDED = 2;
{ futex ops. }
FUTEX_WAIT = 0;
FUTEX_WAKE = 1;
{ clone(2) flags for a thread sharing the address space. }
CLONE_VM = $00000100;
CLONE_FS = $00000200;
CLONE_FILES = $00000400;
CLONE_SIGHAND = $00000800;
CLONE_THREAD = $00010000;
CLONE_SYSVSEM = $00040000;
CLONE_SETTLS = $00080000;
CLONE_PARENT_SETTID = $00100000;
CLONE_CHILD_CLEARTID = $00200000;
THREAD_CLONE_FLAGS =
CLONE_VM or CLONE_FS or CLONE_FILES or CLONE_SIGHAND or
CLONE_THREAD or CLONE_SYSVSEM or CLONE_SETTLS or
CLONE_PARENT_SETTID or CLONE_CHILD_CLEARTID;
PROT_RW = 3; { PROT_READ or PROT_WRITE }
MAP_PRIVANON = $22; { MAP_PRIVATE or MAP_ANONYMOUS }
STACK_SIZE = 1024 * 1024; { 1 MiB per worker thread }
{ The per-thread control block lives at the base of the mmap'd region. TidWord
is the CLONE_CHILD_CLEARTID / CLONE_PARENT_SETTID futex word (the kernel writes
the new TID here on create and clears it on exit); MapBase/MapSize record the
region for munmap after join. }
type
PThreadCB = ^TThreadCB;
TThreadCB = record
TidWord: Integer;
Pad: Integer;
MapBase: Pointer;
MapSize: Int64;
end;
{ ------------------------------------------------------------------ }
{ Mutex - 3-state futex }
{ ------------------------------------------------------------------ }
{ Atomic compare-and-swap on an Integer: if Ptr^ = Expected set it to NewVal;
returns the value that was in Ptr^ before the attempt. }
function CAS(Ptr: Pointer; Expected, NewVal: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax { %eax = Expected (cmpxchg compares against %eax) }
lock cmpxchgl %edx, (%rdi)
ret
end;
{ Atomic exchange: store NewVal into Ptr^, return the previous value. }
function Xchg(Ptr: Pointer; NewVal: Integer): Integer;
assembler; nostackframe;
asm
movl %esi, %eax
xchgl %eax, (%rdi)
ret
end;
function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
var
P: PInteger;
begin
P := PInteger(Mutex);
P^ := MX_UNLOCKED;
Result := 0;
end;
function pthread_mutex_lock(Mutex: Pointer): Integer;
var
C: Integer;
begin
{ Fast path: uncontended acquire. }
C := CAS(Mutex, MX_UNLOCKED, MX_LOCKED);
if C <> MX_UNLOCKED then
begin
{ Contended. Mark the lock contended and sleep until it is free. }
if C <> MX_CONTENDED then
C := Xchg(Mutex, MX_CONTENDED);
while C <> MX_UNLOCKED do
begin
futex(Mutex, FUTEX_WAIT, MX_CONTENDED, nil, nil, 0);
C := Xchg(Mutex, MX_CONTENDED);
end;
end;
Result := 0;
end;
function pthread_mutex_unlock(Mutex: Pointer): Integer;
begin
{ If there were waiters (state 2), wake one after releasing. }
if Xchg(Mutex, MX_UNLOCKED) = MX_CONTENDED then
futex(Mutex, FUTEX_WAKE, 1, nil, nil, 0);
Result := 0;
end;
function pthread_mutex_destroy(Mutex: Pointer): Integer;
begin
Result := 0;
end;
{ ------------------------------------------------------------------ }
{ Thread create / join - clone(2) + futex(2) }
{ ------------------------------------------------------------------ }
{ Raw clone of a thread. Returns the child TID in the parent, 0 in the child.
The child resumes here on its own stack (ChildStack) with %rax = 0, then this
routine, in the child branch, calls Entry(EntryArg) and exits the thread.
Args (SysV): %rdi=Flags, %rsi=ChildStack(top), %rdx=ParentTid,
%rcx=ChildTid, %r8=Tls, %r9=Entry, [stack]=EntryArg.
The child stack is pre-seeded (below) with Entry and EntryArg so the child can
reach them after clone without relying on register state surviving across the
syscall: the child pops them off its own stack. }
function _clone_thread(Flags: Int64; ChildStack, ParentTid, ChildTid,
Tls, Entry, EntryArg: Pointer): Int64;
assembler; nostackframe;
asm
{ Seed Entry and EntryArg onto the child stack; the 7th arg EntryArg }
{ arrived on our stack at 8(%rsp) (return addr at 0(%rsp)). }
movq 8(%rsp), %rax { %rax = EntryArg }
subq $16, %rsi { %rsi = ChildStack top; grow down for the seeds }
movq %r9, 0(%rsi) { [child_sp+0] = Entry }
movq %rax, 8(%rsi) { [child_sp+8] = EntryArg }
{ clone kernel ABI: arg4 (ChildTid) came in %rcx -> move to %r10. }
movq %rcx, %r10
movq $56, %rax { SYS_clone }
syscall
testq %rax, %rax
jnz .Lparent { parent: %rax = child tid }
{ child: on the new stack, %rsp = seeded child_sp. }
popq %rax { %rax = Entry }
popq %rdi { %rdi = EntryArg (1st arg to Entry) }
xorq %rbp, %rbp { terminate the call chain for unwinders }
call *%rax { Entry(EntryArg) }
{ Thread done: exit(0) this thread only (NOT exit_group). }
xorl %edi, %edi
movq $60, %rax { SYS_exit }
syscall
hlt
.Lparent:
ret
end;
function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
var
Region: Pointer;
CB: PThreadCB;
StackTop: Pointer;
Tls: Pointer;
Tid: Int64;
HandleSlot: PInt64;
begin
{ One mapping holds the control block (at the base) and the thread stack
(above it). mmap zero-fills, so TidWord starts at 0. }
Region := mmap(nil, STACK_SIZE, PROT_RW, MAP_PRIVANON, -1, 0);
if Int64(Region) < 0 then
begin
Result := 11; { EAGAIN }
Exit;
end;
CB := PThreadCB(Region);
CB^.MapBase := Region;
CB^.MapSize := STACK_SIZE;
{ Stack grows down from the top of the region; keep it 16-byte aligned. }
StackTop := Pointer(PChar(Region) + STACK_SIZE);
StackTop := Pointer(Int64(StackTop) and (not Int64(15)));
{ Each thread needs its own TLS block for threadvar access. }
Tls := BuildThreadTLS();
Tid := _clone_thread(THREAD_CLONE_FLAGS, StackTop,
@CB^.TidWord, { CLONE_PARENT_SETTID -> our TidWord }
@CB^.TidWord, { CLONE_CHILD_CLEARTID -> same word }
Tls, StartRoutine, Arg);
if Tid < 0 then
begin
munmap(Region, STACK_SIZE);
FreeThreadTLS(Tls); { reclaim the per-thread TLS block too }
Result := 11; { EAGAIN }
Exit;
end;
{ Hand the caller the control-block pointer as the opaque thread handle. }
HandleSlot := PInt64(Thread);
HandleSlot^ := Int64(CB);
Result := 0;
end;
function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
var
CB: PThreadCB;
Tid: Integer;
begin
CB := PThreadCB(Pointer(Thread));
{ The kernel clears TidWord (CLONE_CHILD_CLEARTID) and futex-wakes it when the
thread exits. Wait until it reads 0. }
Tid := CB^.TidWord;
while Tid <> 0 do
begin
futex(@CB^.TidWord, FUTEX_WAIT, Tid, nil, nil, 0);
Tid := CB^.TidWord;
end;
munmap(CB^.MapBase, CB^.MapSize);
Result := 0;
end;
end.

147
compiler/src/main/pascal/runtime.utf8.pas
View file

@ -1,147 +0,0 @@
{
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 runtime.utf8;
// UTF-8 code-point counter — SIMD-accelerated (AVX2 with an SSE2 fallback and
// a scalar tail), with a one-time CPUID probe for AVX2.
//
// Inline-assembler port of runtime/src/main/asm/blaise_utf8_x86_64.s — the body
// (and its threshold/flag data) move into an `asm … end` routine so the RTL
// builds with Blaise's own internal assembler and needs no hand-written .s
// (docs/inline-asm-design.adoc, §"Migration of the .s files"). This was the
// last .s file; with it gone the RTL is pure Pascal + inline asm.
//
// Counts UTF-8 code points by counting bytes that are NOT continuation bytes
// (a byte is a continuation byte iff its top two bits are 10, i.e. signed value
// in [-128,-65]); the SIMD paths compare against the threshold -65 (0xBF).
//
// System V AMD64: Data -> %rdi, Len -> %esi; result (count) in %eax.
interface
function _Utf8CountCodePoints(Data: Pointer; Len: Integer): Integer;
implementation
function _Utf8CountCodePoints(Data: Pointer; Len: Integer): Integer;
assembler; nostackframe;
asm
testl %esi, %esi
jle .Lreturn_zero
movl %esi, %ecx
xorl %eax, %eax
xorl %edx, %edx
cmpl $0, .Lavx2_checked(%rip)
jne .Lavx2_known
call .Lcheck_avx2
xorl %eax, %eax
.Lavx2_known:
cmpl $0, .Lavx2_flag(%rip)
je .Lsse2_entry
cmpl $32, %ecx
jb .Lsse2_entry
vpcmpeqb %ymm2, %ymm2, %ymm2
vpsrlw $1, %ymm2, %ymm2
vpaddw %ymm2, %ymm2, %ymm1
vpcmpeqb %ymm2, %ymm2, %ymm2
vpsllw $7, %ymm2, %ymm1
vpcmpeqb %ymm1, %ymm1, %ymm1
vmovdqa .Lthreshold_avx(%rip), %ymm1
vpxor %ymm3, %ymm3, %ymm3
.Lavx2_loop:
vmovdqu (%rdi, %rdx), %ymm0
vpcmpgtb %ymm1, %ymm0, %ymm2
vpabsb %ymm2, %ymm2
vpaddb %ymm2, %ymm3, %ymm3
addl $32, %edx
subl $32, %ecx
cmpl $32, %ecx
jge .Lavx2_loop
vpxor %ymm4, %ymm4, %ymm4
vpsadbw %ymm4, %ymm3, %ymm3
vextracti128 $1, %ymm3, %xmm4
vpaddq %xmm4, %xmm3, %xmm3
vpshufd $0x0E, %xmm3, %xmm4
vpaddq %xmm4, %xmm3, %xmm3
vmovd %xmm3, %r8d
addl %r8d, %eax
vzeroupper
jmp .Lsse2_entry
.Lsse2_entry:
cmpl $16, %ecx
jb .Lscalar_entry
movdqa .Lthreshold_sse(%rip), %xmm1
pxor %xmm3, %xmm3
.Lsse2_loop:
movdqu (%rdi, %rdx), %xmm0
movdqa %xmm0, %xmm2
pcmpgtb %xmm1, %xmm2
pabsb %xmm2, %xmm2
paddb %xmm2, %xmm3
addl $16, %edx
subl $16, %ecx
cmpl $16, %ecx
jge .Lsse2_loop
pxor %xmm4, %xmm4
psadbw %xmm4, %xmm3
movd %xmm3, %r8d
pshufd $0x0E, %xmm3, %xmm3
movd %xmm3, %r9d
addl %r8d, %eax
addl %r9d, %eax
.Lscalar_entry:
testl %ecx, %ecx
jle .Lreturn
.Lscalar_loop:
movzbl (%rdi, %rdx), %r8d
movl %r8d, %r9d
andl $0xC0, %r9d
cmpl $0x80, %r9d
setne %r9b
movzbl %r9b, %r9d
addl %r9d, %eax
incl %edx
decl %ecx
jnz .Lscalar_loop
.Lreturn:
ret
.Lreturn_zero:
xorl %eax, %eax
ret
.Lcheck_avx2:
pushq %rbx
pushq %rcx
pushq %rdx
movl $7, %eax
xorl %ecx, %ecx
cpuid
testl $0x20, %ebx
setne %al
movzbl %al, %eax
movl %eax, .Lavx2_flag(%rip)
movl $1, .Lavx2_checked(%rip)
popq %rdx
popq %rcx
popq %rbx
ret
.section .rodata
.balign 32
.Lthreshold_avx:
.fill 32, 1, 0xBF
.balign 16
.Lthreshold_sse:
.fill 16, 1, 0xBF
.section .data
.Lavx2_checked:
.long 0
.Lavx2_flag:
.long 0
end;
end.

177
compiler/src/main/pascal/uAST.pas
View file

@ -94,10 +94,6 @@ type
pmJumboSetValue { by-value jumbo (>64) set param: by-ref aggregate ABI }
);
{ TMemberVisibility is declared in uSymbolTable (so the symbol-table
descriptors can carry it without a circular unit dependency); uAST re-uses
that type for the parser-level AST member decls. }
TIdentExpr = class(TASTExpr)
public
Name: string;
@ -117,31 +113,12 @@ type
ConstArraySymbol: string; { set by uSemantic — non-empty when this ident resolves
to an array const; the mangled QBE data-label codegen
must reference instead of $Name. }
QualifierUnit: string; { set by the parser — non-empty when written as a
unit-qualified reference 'Unit.Symbol'. uSemantic
resolves the name against this specific unit's
exports (per-unit cache) instead of the uses chain,
so a same-named const in another unit can't shadow it. }
ResolvedOwnerUnit: string; { set by uSemantic — for a module-scope global var,
the owning unit of the symbol actually resolved (the
uses-chain last-wins winner for a bare ref, or the
named unit for a qualified ref). Codegen mangles the
global's storage symbol with this owner so two used
units exporting the same var name reference distinct
slots. Not serialised — recomputed at analysis time;
empty falls back to the bare-name resolution. }
end;
TFieldAccessExpr = class(TASTExpr)
public
RecordName: string; { used when Base = nil (leaf access) }
FieldName: string;
QualifierUnit: string; { set by the parser — non-empty when the
base type was written unit-qualified, e.g.
'Unit.TEnum.Member' or 'Unit.TFoo.StaticVar'.
uSemantic resolves RecordName against this
specific unit's exports (directed lookup)
instead of the flat last-wins winner. }
Base: TASTExpr; { owned — when non-nil, chained access (e.g. A.B.C) }
FieldInfo: TFieldInfo; { set by uSemantic — nil for constructor calls }
IsConstant: Boolean; { set by uSemantic — TypeName.ConstName resolves to a class constant }
@ -168,15 +145,6 @@ type
PropIndexExpr: TASTExpr; { owned — non-nil = indexed property read (e.g. List.Items[i]) }
IsCharAccess: Boolean; { set by uSemantic — PropIndexExpr indexes a string field: S.Field[N] }
IsArrayAccess: Boolean; { set by uSemantic — PropIndexExpr subscripts an array field: R.Arr[I] }
IsClassVarRead: Boolean; { set by uSemantic — TypeName.StaticVar read; lower as a global load of ClassVarEmitName }
ClassVarEmitName: string; { mangled global label for an IsClassVarRead access }
IsStaticPropGet: Boolean; { set by uSemantic — TypeName.StaticProp read; ResolvedMethod is the static getter }
BackingFieldRedirect: Boolean; { set by uSemantic — FieldName was rewritten from a
property name to its (possibly private) backing
field; visibility was already enforced on the
property, so re-analysis of this node must NOT
re-check the backing field's visibility. Transient
analysis flag — not serialised. }
destructor Destroy; override;
end;
@ -261,10 +229,6 @@ type
_WeakAssign in place of the strong
addref/release pattern. }
ImplicitSelfField: TObject; { TFieldInfo — non-nil when LHS is bare field (implicit Self) }
ResolvedOwnerUnit: string; { set by uSemantic — owning unit of a module-scope global
var target; codegen mangles the store address with it so
same-named cross-unit globals write distinct slots. See
the matching field on TIdentExpr. }
destructor Destroy; override;
end;
@ -283,14 +247,6 @@ type
destructor Destroy; override;
end;
{ An inline-assembler block: the verbatim text of one `asm` ... `end` body.
The front end never interprets Code — it is GNU/AT&T assembly handed to the
backend's assembler verbatim (see docs/inline-asm-design.adoc). }
TAsmStmt = class(TASTStmt)
public
Code: string; { verbatim assembly text between asm and end }
end;
TWhileStmt = class(TASTStmt)
public
Condition: TASTExpr; { owned }
@ -451,16 +407,6 @@ type
FieldName has been rewritten to the SETTER method;
codegen dispatches it through the itab with Expr
as the single argument }
IsClassVarWrite: Boolean; { set by uSemantic — qualified STATIC (class-level)
variable write 'TFoo.StaticVar := V'. The target is
the single shared global emitted under
ClassVarEmitName; codegen lowers it exactly like a
bare global store (delegates to EmitAssignment),
ignoring RecordName/FieldName. }
[Unretained] ClassVarLhsType: TTypeDesc; { set with IsClassVarWrite — the
static var's type, for the delegated store. }
ClassVarEmitName: string; { set with IsClassVarWrite — the mangled data-label
of the static var's storage slot. }
destructor Destroy; override;
end;
@ -512,10 +458,6 @@ type
IsIndirectCall: Boolean; { set by uSemantic — Name is a procedural-typed variable }
IndirectCallIsGlobal: Boolean; { set by uSemantic — when IsIndirectCall, variable is global }
[Unretained] ResolvedProcType: TObject; { TProceduralTypeDesc — not owned; valid when IsIndirectCall }
IsProcFieldCall: Boolean; { set by uSemantic — unqualified Name is a
procedural-typed field of the current class
(implicit Self.Field), called as a statement }
[Unretained] ProcFieldInfo: TFieldInfo; { not owned — the procedural field, when IsProcFieldCall }
constructor Create;
destructor Destroy; override;
end;
@ -539,10 +481,6 @@ type
IsBuiltinHasClassAttr: Boolean; { set by uSemantic — HasClassAttribute builtin }
HasClassAttrClass: string; { class name for arg 1 (class being queried) }
HasClassAttrAttr: string; { attribute class name for arg 2 }
IsProcFieldCall: Boolean; { set by uSemantic — unqualified Name is a
procedural-typed field of the current class
(implicit Self.Field), used as an expression }
[Unretained] ProcFieldInfo: TFieldInfo; { not owned — the procedural field, when IsProcFieldCall }
constructor Create;
destructor Destroy; override;
end;
@ -600,9 +538,6 @@ type
IsBuiltinToString: Boolean; { set by uSemantic — built-in TObject.ToString virtual dispatch }
IsConstructorCall: Boolean; { set by uSemantic — metaclass-var Create in stmt position }
IsMetaclassDispatch: Boolean; { set by uSemantic — receiver is a metaclass var }
IsStaticCall: Boolean; { set by uSemantic — TypeName.StaticMethod(): a static
(class-level) call with NO Self. Codegen lowers it as a
plain call to the mangled method symbol, no receiver. }
IsProcFieldCall: Boolean; { set by uSemantic — Name is a procedural-typed field of
the receiver, invoked directly (F.Handler;). Codegen
loads the (Code, Data) pair from the field slot and
@ -751,14 +686,6 @@ type
TTypeAliasDef = class(TASTTypeDef)
public
TypeName: string;
{ When the RHS was a named integer subrange (type TIdx = lo..hi;) the alias
target is the narrowest fitting standard integer type (in TypeName), but
the original lo..hi bounds are retained here as compile-time metadata so
the array-index resolver can fold array[TIdx] -> array[lo..hi]. The value
still behaves as its underlying int (unchecked); only the bounds are kept. }
IsSubrange: Boolean;
SubrangeLow: Int64;
SubrangeHigh: Int64;
end;
{ Set type definition: type TOptions = set of TEnum; }
@ -789,29 +716,14 @@ type
Attributes: TStringList; { owned — see TVarDecl.Attributes. }
IsWeak: Boolean; { set by uSemantic when [Weak] is resolved. }
IsUnretained: Boolean; { set by uSemantic when [Unretained] is resolved. }
IsClassVar: Boolean; { set by uParser — declared `static var` (a.k.a.
class variable): one shared storage slot for the
whole type, not a per-instance field. Lowered to
a global slot by uSemantic; never gets an instance
offset. }
ClassVarEmitName: string; { set by uSemantic for an IsClassVar field — the
mangled global data-label (CurrentUnitPrefix +
Class + '_' + Name). Single source of truth so
BOTH backends emit the slot under the exact label
the read/write sites use, without re-deriving the
unit prefix. }
Visibility: TMemberVisibility; { set by uParser from the enclosing visibility
section; default mvPublic. Enforced by
uSemantic's member-access checks. }
constructor Create;
destructor Destroy; override;
end;
TRecordTypeDef = class(TASTTypeDef)
public
Fields: TObjectList; { owned TFieldDecl }
Methods: TObjectList; { owned TMethodDecl }
ConstDecls: TObjectList; { owned TConstDecl — record-level constants (static const) }
Fields: TObjectList; { owned TFieldDecl }
Methods: TObjectList; { owned TMethodDecl }
IsPacked: Boolean; { True iff declared `packed record` — disables
field alignment padding and tail padding;
ARC-managed fields (string/class/intf) still
@ -894,16 +806,7 @@ type
consumed by codegen for cross-unit references. }
IsExternal: Boolean; { declared with 'external' directive — no body }
ExternalName: string; { C symbol name from 'external name ''c_foo'''; empty = use Pascal name }
ExternalLib: string; { library from 'external ''c'' name ''malloc'''; bare name, link layer expands per platform. Also recorded unit-level in LinkLibs. }
NoStackFrame: Boolean; { declared 'nostackframe' — body is an asm
block that owns the whole frame; codegen
emits no compiler prologue/epilogue }
IsRecordMethod: Boolean; { set by uSemantic — owner type is a record (not a class) }
IsStatic: Boolean; { set by uParser — declared `static` (class method):
no implicit Self; type-associated dispatch.
Distinct from VTableSlot's "static dispatch"
(= non-virtual); a static method also never
receives a Self pointer. }
VTableSlot: Integer; { -1 = static; >=0 = vtable index (set by uSemantic) }
TypeParams: TStringList; { non-nil = generic function template; owns param names }
TypeParamConstraints: TStringList; { parallel to TypeParams; '' = unconstrained,
@ -925,12 +828,6 @@ type
CallingConv: string; { set by uParser — 'cdecl'/'stdcall'/'register'/'pascal'/
'safecall' directive (lowercased); '' = default }
OwningUnit: string; { set by uSemantic / uSemanticImport — unit that declares this routine }
IsImplOnly: Boolean; { set by uSemantic — standalone routine declared only in a unit's
implementation section (no interface forward). Such routines are
PRIVATE to the unit; overload resolution must not treat another
unit's same-named impl-only routine as a competing candidate. }
Visibility: TMemberVisibility; { set by uParser from the enclosing visibility section
when this is a class/record method; default mvPublic. }
constructor Create;
destructor Destroy; override;
end;
@ -939,18 +836,12 @@ type
public
ObjectName: string;
Name: string; { method name }
QualifierUnit: string; { set by the parser — unit of a qualified
receiver type 'Unit.Type.Method(...)', so a
constructor on a cross-unit same-named type
resolves against that specific unit. }
Args: TObjectList; { owned TASTExpr }
ObjExpr: TASTExpr; { owned — receiver expression when ObjectName = '' }
[Unretained] ResolvedClassType: TTypeDesc; { not owned; set by uSemantic }
[Unretained] ResolvedMethod: TObject; { TMethodDecl — not owned }
IsConstructorCall: Boolean; { set by uSemantic — TypeName.Create(args) }
IsMetaclassDispatch: Boolean; { set by uSemantic — receiver is a metaclass var }
IsStaticCall: Boolean; { set by uSemantic — TypeName.StaticMethod(): static
(class-level) call with NO Self; plain call to mangled name }
IsGlobal: Boolean; { set by uSemantic — ObjectName is a program-level global }
IsVarParam: Boolean; { set by uSemantic — ObjectName is a var/out parameter }
IsBuiltinToString: Boolean; { set by uSemantic — built-in TObject.ToString virtual dispatch }
@ -972,10 +863,6 @@ type
IndexParamName: string; { '' = non-indexed property }
IndexTypeName: string; { type name of the index parameter; '' when non-indexed }
IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) }
IsStatic: Boolean; { set by uParser — declared `static`: sugar over a
static getter/setter; no implicit Self. }
Visibility: TMemberVisibility; { set by uParser from the enclosing visibility
section; default mvPublic. }
end;
TClassTypeDef = class(TASTTypeDef)
@ -987,8 +874,6 @@ type
Methods: TObjectList; { owned TMethodDecl }
Properties: TObjectList; { owned TPropertyDecl }
Attributes: TStringList; { owned — class-level custom attribute names e.g. 'Threaded' }
IsForward: Boolean; { True for a forward decl 'TFoo = class;' (no ancestor,
no body) — completed by the full decl later in scope }
constructor Create;
destructor Destroy; override;
end;
@ -1049,7 +934,6 @@ type
ParentName: string;
Methods: TObjectList; { owned TMethodDecl — forward signatures only }
Properties: TObjectList; { owned TPropertyDecl — accessors are interface methods }
IsForward: Boolean; { True for a forward decl 'IFoo = interface;' — completed later in scope }
constructor Create;
destructor Destroy; override;
end;
@ -1100,28 +984,9 @@ type
public
Name: string;
Def: TASTTypeDef; { owned }
[Unretained] ResolvedDesc: TObject; { TTypeDesc — set by uSemantic to the
descriptor created for THIS decl. Lets
codegen emit a unit's own type even when
a same-named type from another used unit
won the flat-table slot (FindType by name
would return the other unit's desc). }
destructor Destroy; override;
end;
{ A library this compilation unit must be linked against — collected by the
parser from every 'external ''lib''' declaration (interface OR
implementation). Hoisted to the unit level so an implementation-private
import still records its link dependency: the private routine stays out of
the .bif, but the library it needs is serialised via
TUnitInterface.LinkLibs and propagates to any program that uses the unit.
LibName is the bare name ('c', 'kernel32') — the link layer expands it per
platform (-l<name> on ELF, <name>.dll on PE). }
TLinkLibDecl = class(TASTNode)
public
LibName: string;
end;
{ ------------------------------------------------------------------ }
{ Block and Program }
{ ------------------------------------------------------------------ }
@ -1137,7 +1002,6 @@ type
GenericMethodInstances: TObjectList; { owned TGenericMethodInstance — populated by uSemantic }
GenericIntfInstances: TObjectList; { owned TGenericInterfaceInstance — populated by uSemantic }
GenericRecordInstances: TObjectList; { owned TGenericRecordInstance — populated by uSemantic }
LinkLibs: TObjectList; { owned TLinkLibDecl — libraries to link, collected by the parser }
constructor Create;
destructor Destroy; override;
end;
@ -1161,7 +1025,6 @@ type
GenericMethodInstances: TObjectList;
GenericIntfInstances: TObjectList;
GenericRecordInstances: TObjectList;
LinkLibs: TObjectList; { owned TLinkLibDecl — libraries to link, collected by the parser }
constructor Create;
destructor Destroy; override;
end;
@ -1571,9 +1434,8 @@ end;
constructor TRecordTypeDef.Create;
begin
inherited Create();
Fields := TObjectList.Create(True);
Methods := TObjectList.Create(True);
ConstDecls := TObjectList.Create(True);
Fields := TObjectList.Create(True);
Methods := TObjectList.Create(True);
end;
destructor TRecordTypeDef.Destroy;
@ -1868,7 +1730,6 @@ begin
GenericMethodInstances := TObjectList.Create(True);
GenericIntfInstances := TObjectList.Create(True);
GenericRecordInstances := TObjectList.Create(True);
LinkLibs := TObjectList.Create(True);
end;
destructor TConstDecl.Destroy;
@ -1899,7 +1760,6 @@ begin
GenericMethodInstances := TObjectList.Create(True);
GenericIntfInstances := TObjectList.Create(True);
GenericRecordInstances := TObjectList.Create(True);
LinkLibs := TObjectList.Create(True);
end;
destructor TUnit.Destroy;
@ -2355,19 +2215,6 @@ begin
Result.Names.Add(ASrc.Names.Strings[I]);
for I := 0 to ASrc.Attributes.Count - 1 do
Result.Attributes.Add(ASrc.Attributes.Strings[I]);
{ Carry the resolved semantic flags through the export clone. Without
these, the .bif encoder sees defaults: a [Weak]/[Unretained] field
round-trips as a plain owning field, and a `static var` loses both its
class-var marker and its mangled emit label — so a cross-unit consumer
cannot register the shared global. }
Result.IsWeak := ASrc.IsWeak;
Result.IsUnretained := ASrc.IsUnretained;
Result.IsClassVar := ASrc.IsClassVar;
Result.ClassVarEmitName := ASrc.ClassVarEmitName;
{ Visibility must survive the export clone or a cross-unit consumer would see
every imported field as public and enforcement would silently disappear at
the unit boundary. }
Result.Visibility := ASrc.Visibility;
end;
function ClonePropertyDecl(ASrc: TPropertyDecl): TPropertyDecl;
@ -2379,11 +2226,6 @@ begin
Result.WriteName := ASrc.WriteName;
Result.IndexParamName := ASrc.IndexParamName;
Result.IndexTypeName := ASrc.IndexTypeName;
{ IsDefault round-trips the `default` directive; IsStatic marks a static
property whose accessors take no Self. Both were silently dropped. }
Result.IsDefault := ASrc.IsDefault;
Result.IsStatic := ASrc.IsStatic;
Result.Visibility := ASrc.Visibility;
end;
function CloneTypeDecl(ASrc: TTypeDecl): TTypeDecl;
@ -2496,14 +2338,8 @@ begin
Result.IsPublished := ASrc.IsPublished;
Result.IsExternal := ASrc.IsExternal;
Result.ExternalName := ASrc.ExternalName;
Result.ExternalLib := ASrc.ExternalLib;
Result.CallingConv := ASrc.CallingConv;
Result.IsRecordMethod := ASrc.IsRecordMethod;
{ Static (class-level) methods take no implicit Self. Dropping this in the
export clone made every cross-unit static method look like a normal
instance method, so TypeName.StaticMethod() resolution failed. }
Result.IsStatic := ASrc.IsStatic;
Result.Visibility := ASrc.Visibility;
for I := 0 to ASrc.Params.Count - 1 do
Result.Params.Add(CloneMethodParam(TMethodParam(ASrc.Params.Items[I])));
if ASrc.TypeParams <> nil then
@ -2550,9 +2386,6 @@ begin
begin
TA := TTypeAliasDef.Create();
TA.TypeName := TTypeAliasDef(ASrc).TypeName;
TA.IsSubrange := TTypeAliasDef(ASrc).IsSubrange;
TA.SubrangeLow := TTypeAliasDef(ASrc).SubrangeLow;
TA.SubrangeHigh := TTypeAliasDef(ASrc).SubrangeHigh;
Result := TA;
end
else if ASrc is TSetTypeDef then
@ -2615,7 +2448,6 @@ begin
if ASrc = nil then begin Result := nil; Exit; end;
Result := TClassTypeDef.Create();
Result.ParentName := ASrc.ParentName;
Result.IsForward := ASrc.IsForward;
for I := 0 to ASrc.ImplementsNames.Count - 1 do
Result.ImplementsNames.Add(ASrc.ImplementsNames.Strings[I]);
for I := 0 to ASrc.ConstDecls.Count - 1 do
@ -2656,7 +2488,6 @@ begin
if ASrc = nil then begin Result := nil; Exit; end;
Result := TInterfaceTypeDef.Create();
Result.ParentName := ASrc.ParentName;
Result.IsForward := ASrc.IsForward;
for I := 0 to ASrc.Methods.Count - 1 do
Result.Methods.Add(CloneMethodDecl(TMethodDecl(ASrc.Methods.Items[I])));
for I := 0 to ASrc.Properties.Count - 1 do

2
compiler/src/main/pascal/uCompilerId.pas
View file

@ -24,7 +24,7 @@ unit uCompilerId;
interface
const
COMPILER_ID = 'blaise-0.13.0-SNAPSHOT+bif2';
COMPILER_ID = 'blaise-0.12.0+bif2';
implementation

69
compiler/src/main/pascal/uConfig.pas
View file

@ -15,22 +15,10 @@ uses
function FindConfigFile: string;
{ Parse blaise.cfg lines. Recognised keys (KEY=VALUE, '#' comments, blank lines
ignored): `unit-path=<dir>` appends to APaths; `rtl-src=<dir>` sets ARtlSrc.
A relative VALUE is resolved against ABaseDir (the config file's directory).
ARtlSrc is only written when an rtl-src line is present (left unchanged
otherwise), so a caller can pre-seed it and let the config override only if
set. }
procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
APaths: TStringList; var ARtlSrc: string); overload;
APaths: TStringList);
{ Convenience overload for callers that only want unit-paths (ignores rtl-src). }
procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
APaths: TStringList); overload;
{ Load the resolved blaise.cfg: appends unit-path entries to APaths and returns
any rtl-src via ARtlSrc (unchanged if the file has none / no file). }
procedure LoadConfigPaths(APaths: TStringList; var ARtlSrc: string);
procedure LoadConfigPaths(APaths: TStringList);
implementation
@ -53,38 +41,8 @@ begin
Result := '';
end;
{ Resolve a blaise.cfg path value. An absolute path (leading '/') is used as
is; a leading '~' or '~/' expands to $HOME (so a config can name paths under
the user's home directory); anything else is relative and resolved against
ABaseDir (the config file's own directory). }
function ResolveCfgPath(const AValue, ABaseDir: string): string;
var
Home: string;
begin
if Length(AValue) = 0 then
Exit('');
{ Home expansion: '~' alone, or a '~/...' prefix. }
if (Copy(AValue, 0, 1) = '~') and
((Length(AValue) = 1) or (Copy(AValue, 1, 1) = '/')) then
begin
Home := GetEnvironmentVariable('HOME');
if Home <> '' then
begin
if Length(AValue) = 1 then
Exit(Home);
{ drop the '~', keep the rest (which starts with '/') }
Exit(IncludeTrailingPathDelimiter(Home) + Copy(AValue, 2, Length(AValue)));
end;
{ No $HOME — leave '~' untouched rather than mis-resolving. }
Exit(AValue);
end;
if Copy(AValue, 0, 1) = '/' then
Exit(AValue);
Result := IncludeTrailingPathDelimiter(ABaseDir) + AValue;
end;
procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
APaths: TStringList; var ARtlSrc: string);
APaths: TStringList);
var
I: Integer;
Line: string;
@ -105,24 +63,17 @@ begin
Key := Trim(Copy(Line, 0, EqPos));
Value := Trim(Copy(Line, EqPos + 1, Length(Line)));
if SameText(Key, 'unit-path') then
APaths.Add(ResolveCfgPath(Value, ABaseDir))
else if SameText(Key, 'rtl-src') then
ARtlSrc := ResolveCfgPath(Value, ABaseDir)
begin
if (Length(Value) > 0) and (Copy(Value, 0, 1) <> '/') then
Value := IncludeTrailingPathDelimiter(ABaseDir) + Value;
APaths.Add(Value);
end
else
; { silently skip unrecognised keys }
end;
end;
procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
APaths: TStringList);
var
IgnoredRtlSrc: string;
begin
IgnoredRtlSrc := '';
ParseConfigLines(ALines, ABaseDir, APaths, IgnoredRtlSrc);
end;
procedure LoadConfigPaths(APaths: TStringList; var ARtlSrc: string);
procedure LoadConfigPaths(APaths: TStringList);
var
CfgFile: string;
Lines: TStringList;
@ -135,7 +86,7 @@ begin
try
Lines.LoadFromFile(CfgFile);
BaseDir := ExtractFilePath(CfgFile);
ParseConfigLines(Lines, BaseDir, APaths, ARtlSrc);
ParseConfigLines(Lines, BaseDir, APaths);
finally
Lines.Free();
end;

155
compiler/src/main/pascal/uDebugOPDF.pas
View file

@ -63,8 +63,6 @@ type
procedure EmitLocalVars(ABlock: TBlock; AScopeID: Integer);
procedure EmitFunctionScope_Main(AScopeID, ADeclIdx: Integer);
procedure EmitUnitDirectory;
procedure EmitRuntimeHelper(AKind: Integer; const ASymbol: string);
procedure EmitRuntimeHelpers;
procedure EmitPointer(AType: TPointerTypeDesc);
procedure EmitArray(AType: TTypeDesc);
procedure EmitSet(AType: TSetTypeDesc);
@ -74,7 +72,6 @@ type
procedure EmitConstantsFromList(AList: TObjectList);
procedure EmitTypesFromBlock(ABlock: TBlock);
procedure EmitGlobalVarsFromList(AList: TObjectList);
procedure EmitStaticVarsFromBlock(ABlock: TBlock);
procedure EmitAllTypes;
procedure EmitGlobalVars;
procedure EmitFunctionScopes;
@ -132,16 +129,9 @@ const
REC_SET = 18;
REC_UNITDIR = 19;
REC_CONSTANT = 20;
REC_RUNTIMEHELPER = 25;
{ TRuntimeHelperKind ordinals (mirror opdf_types.TRuntimeHelperKind) }
RHK_STRING_RELEASE = 0;
RHK_DYNARRAY_RELEASE = 1;
SK_INTEGER = 0;
SK_BOOLEAN = 1;
{ SK_CHAR = 2; SK_WIDECHAR = 3; — reserved by the OPDF spec, not emitted yet }
SK_FLOAT = 4; { Single, Double — pdr renders via TFloatEvaluator }
LOC_RBP = 1;
LOC_RBP_INDIRECT = 3; { frame slot holds the value's address }
@ -197,44 +187,6 @@ begin
FDone := False;
end;
{ Escape a raw string value for a GNU-as / internal-assembler `.ascii "..."`
literal. A string CONSTANT's value is arbitrary user text — it may contain a
double-quote, backslash, `#`, or control characters, any of which would break
the surrounding `.ascii "<val>" # Value` line (an unescaped `"` closes the
literal early, leaving `..." # Value` as a garbage mnemonic). We emit the
C-style escapes both assemblers understand. The OPDF ValueLen field is the
RAW byte count (Length before escaping), which `.ascii` with these escapes
reproduces exactly, so escaping does not change the emitted byte length. }
function EscapeAsciiStr(const S: string): string;
var
I, B: Integer;
begin
Result := '';
for I := 0 to Length(S) - 1 do
begin
B := OrdAt(S, I) and $FF;
case B of
Ord('\'): Result := Result + '\\';
Ord('"'): Result := Result + '\"';
10: Result := Result + '\n';
13: Result := Result + '\r';
9: Result := Result + '\t';
else
{ Printable ASCII passes through; anything else (including '#', which is a
comment start OUTSIDE a quoted literal but harmless inside one, and any
non-printable byte) is emitted as a 3-digit octal escape so the line
stays a single well-formed token. }
if (B >= 32) and (B < 127) then
Result := Result + Chr(B)
else
Result := Result + '\' +
Chr(Ord('0') + ((B shr 6) and 7)) +
Chr(Ord('0') + ((B shr 3) and 7)) +
Chr(Ord('0') + (B and 7));
end;
end;
end;
function TOPDFEmitter.ActiveSymTable: TSymbolTable;
begin
if FUnit <> nil then
@ -409,8 +361,7 @@ begin
if HasBeenEmitted(CName) then Exit;
case AType.Kind of
tyInteger, tyInt64, tyUInt32, tyUInt64,
tySmallInt, tyWord, tyByte, tyBoolean,
tyDouble, tySingle:
tySmallInt, tyWord, tyByte, tyBoolean:
EmitPrimitive(AType);
tyString:
EmitUtf8Str();
@ -448,10 +399,6 @@ begin
tyBoolean: begin SubKind := SK_BOOLEAN; IsSigned := 0; end;
tyInt64, tyInteger, tySmallInt:
begin SubKind := SK_INTEGER; IsSigned := 1; end;
tyDouble, tySingle:
{ Single (4B) / Double (8B) — pdr keys off SubKind=skFloat
and reads the IEEE 754 value by SizeInBytes. }
begin SubKind := SK_FLOAT; IsSigned := 1; end;
else
SubKind := SK_INTEGER; IsSigned := 0;
end;
@ -706,28 +653,6 @@ begin
EmitStrField(FuncName);
end;
procedure TOPDFEmitter.EmitRuntimeHelper(AKind: Integer; const ASymbol: string);
begin
{ recRuntimeHelper: 1-byte kind + 8-byte linker-resolved RTL entry-point
address. Lets the debugger inject a call to the RTL release routine for a
+1 transient an injected property getter returns — see uDebugOPDF rationale
and opdf-specification.adoc (recRuntimeHelper = 25). }
L('');
L(' # recRuntimeHelper: ' + ASymbol);
EmitRecHdr(REC_RUNTIMEHELPER, 9);
L(' .byte ' + IntToStr(AKind) + ' # Kind');
L(' .quad ' + ASymbol + ' # Address (linker-resolved)');
end;
procedure TOPDFEmitter.EmitRuntimeHelpers;
begin
{ Emitted once per binary (program object only). The RTL release routines
are global symbols the linker resolves; the addresses land in the same
image as the OPDF section, so the ASLR slide applies uniformly. }
EmitRuntimeHelper(RHK_STRING_RELEASE, '_StringRelease');
EmitRuntimeHelper(RHK_DYNARRAY_RELEASE, '_DynArrayRelease');
end;
procedure TOPDFEmitter.EmitParameters(AMethod: TMethodDecl);
var
I: Integer;
@ -1050,7 +975,6 @@ var
ReadType, WriteType: Integer;
RecSize: Integer;
RF: TFieldInfo;
ReadMethSym, WriteMethSym: string;
begin
if AClass.Properties.Count = 0 then Exit;
ClassTypeID := GetOrAllocTypeID(AClass.Name);
@ -1078,23 +1002,8 @@ begin
else
WriteType := PAT_NONE;
{ Method-backed accessors carry the getter/setter SYMBOL name so the
debugger can resolve it via FindFunctionByName (which matches against the
recFunctionScope name = the mangled symbol) and inject the call. The
symbol is the same one written as ReadAddr/WriteAddr below. }
if ReadType = PAT_METHOD then
ReadMethSym := MangledClassSym(AClass.Name) + '_' + PI.ReadMethod
else
ReadMethSym := '';
if WriteType = PAT_METHOD then
WriteMethSym := MangledClassSym(AClass.Name) + '_' + PI.WriteMethod
else
WriteMethSym := '';
{ Fixed-size payload (30 bytes) + the three variable-length strings.
4(ClassTypeID)+4(PropTypeID)+1(ReadType)+1(WriteType)+8(ReadAddr)+
8(WriteAddr)+2(ReadMethodNameLen)+2(WriteMethodNameLen)+2(NameLen). }
RecSize := 32 + Length(ReadMethSym) + Length(WriteMethSym) + Length(PI.Name);
RecSize := 28 + Length(PI.Name);
{ 4(ClassTypeID)+4(PropTypeID)+1(ReadType)+1(WriteType)+8(ReadAddr)+8(WriteAddr)+2(NameLen) }
L('');
L(' # recProperty: ' + PI.Name);
@ -1132,14 +1041,7 @@ begin
else
L(' .quad 0 # WriteAddr (none)');
{ The reader (TDefProperty) expects all three length words FIRST, then the
three strings in order: ReadMethodName, WriteMethodName, Name. }
L(' .word ' + IntToStr(Length(ReadMethSym)) + ' # ReadMethodNameLen');
L(' .word ' + IntToStr(Length(WriteMethSym)) + ' # WriteMethodNameLen');
L(' .word ' + IntToStr(Length(PI.Name)) + ' # NameLen');
EmitNameData(ReadMethSym);
EmitNameData(WriteMethSym);
EmitNameData(PI.Name);
EmitStrField(PI.Name);
end;
end;
@ -1182,7 +1084,7 @@ begin
L(' .word ' + IntToStr(Length(C.StrVal)) + ' # ValueLen');
EmitNameLen(C.Name);
if Length(C.StrVal) > 0 then
L(' .ascii "' + EscapeAsciiStr(C.StrVal) + '" # Value');
L(' .ascii "' + C.StrVal + '" # Value');
EmitNameData(C.Name);
end
else
@ -1310,58 +1212,15 @@ begin
end;
end;
{ Static (class-level) variables are shared global pointer/value slots, not
instance fields, so they are not in any block's var-decl list and EmitFields
(instance fields only) skips them. Emit one recGlobalVar per IsClassVar field
under its mangled ClassVarEmitName so a debugger can print TFoo.FInstance. }
procedure TOPDFEmitter.EmitStaticVarsFromBlock(ABlock: TBlock);
var
I, K, N: Integer;
TD: TTypeDecl;
Flds: TObjectList;
FDecl: TFieldDecl;
Nm: string;
begin
if ABlock = nil then Exit;
for I := 0 to ABlock.TypeDecls.Count - 1 do
begin
TD := TTypeDecl(ABlock.TypeDecls.Items[I]);
Flds := nil;
if TD.Def is TClassTypeDef then
Flds := TClassTypeDef(TD.Def).Fields
else if TD.Def is TRecordTypeDef then
Flds := TRecordTypeDef(TD.Def).Fields;
if Flds = nil then Continue;
for K := 0 to Flds.Count - 1 do
begin
FDecl := TFieldDecl(Flds.Items[K]);
if not FDecl.IsClassVar then Continue;
for N := 0 to FDecl.Names.Count - 1 do
begin
if (FDecl.ClassVarEmitName <> '') and (FDecl.Names.Count = 1) then
Nm := FDecl.ClassVarEmitName
else
Continue; { multi-name static vars carry no per-name emit label yet }
EmitGlobalVar(Nm, FDecl.ResolvedType);
end;
end;
end;
end;
procedure TOPDFEmitter.EmitGlobalVars;
begin
if FUnit <> nil then
begin
EmitGlobalVarsFromList(FUnit.IntfBlock.Decls);
EmitGlobalVarsFromList(FUnit.ImplBlock.Decls);
EmitStaticVarsFromBlock(FUnit.IntfBlock);
EmitStaticVarsFromBlock(FUnit.ImplBlock);
end
else if FProgram <> nil then
begin
EmitGlobalVarsFromList(FProgram.Block.Decls);
EmitStaticVarsFromBlock(FProgram.Block);
end;
end;
procedure TOPDFEmitter.SetFacts(AFacts: TDbgFacts);
@ -1718,10 +1577,6 @@ begin
EmitAllTypes();
EmitGlobalVars();
EmitConstants();
{ recRuntimeHelper records are emitted ONLY by the program object (one set
per binary) — the RTL release routines are global symbols, not per-unit. }
if FProgram <> nil then
EmitRuntimeHelpers();
EmitFunctionScopes();
PatchTotalRecords();
PatchUnitDirRecordCount();

151
compiler/src/main/pascal/uLexer.pas
View file

@ -115,12 +115,7 @@ type
tkDot,
tkDotDot, { .. — array bounds separator and case range }
tkCaret, { ^ — pointer dereference / pointer type prefix }
tkAt, { @ — address-of operator }
tkAsmBlock { whole 'asm' ... 'end' block; Value holds the verbatim
assembly text (the front end never tokenises it).
Appended at the enum's END so adding it shifts no
existing ordinal (set-of-TTokenKind literals elsewhere
depend on stable ordinals). }
tkAt { @ — address-of operator }
);
TToken = record
@ -136,7 +131,6 @@ type
FFilename: string;
FDefines: TStringList; { conditional-compilation symbols, case-insensitive }
function MapKeyword(const AUpper: string): TTokenKind;
function CodepointToUtf8(ACodepoint: Integer): string;
function UnescapeString(const ARaw: string): string;
function ProcessTextBlock(const ARaw: string): string;
function DirectiveName(const AText: string): string;
@ -147,7 +141,6 @@ type
procedure SeedPredefines;
procedure SkipToElseOrEndif;
procedure SkipToEndif;
function ReadAsmBody: string;
public
constructor Create(const ASource: string; const AFilename: string = '');
destructor Destroy; override;
@ -155,8 +148,6 @@ type
{ Define a conditional-compilation symbol before lexing (e.g. from the
-d command-line flag). Case-insensitive. }
procedure AddDefine(const ASym: string);
{ Drop the host OS predefines so a cross-target's OS symbol replaces them. }
procedure ClearOSDefines;
function Next: TToken;
end;
@ -193,29 +184,15 @@ end;
{ Seed the always-on predefined conditional symbols. BLAISE identifies this
compiler (the headline use case: cross-compiler IFDEF BLAISE / ELSE / ENDIF);
the CPU/OS symbols mirror the FPC family so portable source compiles unchanged.
The OS symbols follow the HOST this compiler was built for, via compile-time
conditional compilation, so a FreeBSD-built blaise seeds FREEBSD (matching
HostTarget), which is what makes it default to producing FreeBSD binaries.
A cross-target does not re-seed these; source that switches on the target OS
is rare and the RTL selects per-target units structurally (BuildRTLUnitList),
not via conditional compilation. }
the CPU/OS symbols mirror the FPC family so portable source compiles
unchanged. Targets beyond Linux/x86-64 will extend this set. }
procedure TLexer.SeedPredefines;
begin
Self.DefineSymbol('BLAISE');
Self.DefineSymbol('CPUX86_64');
Self.DefineSymbol('CPUAMD64'); { FPC's alias for the same target }
{$IFDEF FREEBSD}
Self.DefineSymbol('FREEBSD');
Self.DefineSymbol('UNIX');
{$ELSE}
{$IFDEF WINDOWS}
Self.DefineSymbol('WINDOWS');
{$ELSE}
Self.DefineSymbol('LINUX');
Self.DefineSymbol('UNIX');
{$ENDIF}
{$ENDIF}
end;
function TLexer.IsDefined(const ASym: string): Boolean;
@ -238,17 +215,6 @@ begin
FDefines.Delete(Idx);
end;
{ Remove all OS predefines seeded for the host, so a cross --target's OS symbol
can take their place (the driver calls this before applying target defines). }
procedure TLexer.ClearOSDefines;
begin
Self.UndefSymbol('LINUX');
Self.UndefSymbol('FREEBSD');
Self.UndefSymbol('WINDOWS');
Self.UndefSymbol('DARWIN');
Self.UndefSymbol('UNIX');
end;
procedure TLexer.AddDefine(const ASym: string);
begin
Self.DefineSymbol(UpperCase(ASym));
@ -263,7 +229,6 @@ begin
else if AUpper = 'THREADVAR' then Result := tkThreadVar
else if AUpper = 'BEGIN' then Result := tkBegin
else if AUpper = 'END' then Result := tkEnd
else if AUpper = 'ASM' then Result := tkAsmBlock
else if AUpper = 'TYPE' then Result := tkType
else if AUpper = 'RECORD' then Result := tkRecord
else if AUpper = 'PACKED' then Result := tkPacked
@ -380,50 +345,14 @@ begin
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
end;
function TLexer.CodepointToUtf8(ACodepoint: Integer): string;
{ Encode a Unicode scalar value as its UTF-8 byte sequence. A `#nnnn` / `#$hhhh`
literal denotes a codepoint (NOT a raw byte), so the string it contributes is
that codepoint's UTF-8 encoding: #65 -> 'A' (1 byte), #$20AC -> 3 bytes,
#$1F600 -> 4 bytes. Rejects values outside 0..U+10FFFF and the surrogate
range U+D800..U+DFFF, which are not valid scalar values. }
var
N: Integer;
begin
N := ACodepoint;
if (N < 0) or (N > $10FFFF) or ((N >= $D800) and (N <= $DFFF)) then
raise Exception.Create(Format(
'Invalid Unicode codepoint in character literal: %d (must be 0..$10FFFF, '
+ 'excluding surrogates $D800..$DFFF)', [N]));
if N <= $7F then
Result := Chr(N)
else if N <= $7FF then
Result := Chr($C0 or (N shr 6))
+ Chr($80 or (N and $3F))
else if N <= $FFFF then
Result := Chr($E0 or (N shr 12))
+ Chr($80 or ((N shr 6) and $3F))
+ Chr($80 or (N and $3F))
else
Result := Chr($F0 or (N shr 18))
+ Chr($80 or ((N shr 12) and $3F))
+ Chr($80 or ((N shr 6) and $3F))
+ Chr($80 or (N and $3F));
end;
function TLexer.UnescapeString(const ARaw: string): string;
{ ARaw is the full source span. Handles: 'text' with '' → ' escaping,
<<<<<<< HEAD
#nnnn / #$hhhh Unicode-codepoint literals (decimal or hex, UTF-8 encoded),
and concatenated runs like 'abc'#13#10'def'. Uses OrdAt (0-based) so the body
parses under both FPC and the self-hosted Blaise compiler. }
=======
#nn numeric char literals (decimal), and concatenated runs like
'abc'#13#10'def'. Uses OrdAt (0-based) so the body parses under both
FPC and the self-hosted Blaise compiler.
UTF-8 note: Cyrillic characters inside quoted strings are preserved
as-is since string content is opaque to the tokeniser. }
>>>>>>> version-0.12.0
var
I, Len, N, C: Integer;
begin
@ -459,34 +388,18 @@ begin
end;
end;
end
else if C = 35 then { '#' — a Unicode codepoint, decimal #nnnn or hex #$hhhh }
else if C = 35 then { '#' }
begin
I := I + 1;
N := 0;
if (I < Len) and (OrdAt(ARaw, I) = 36) then { '$' -> hexadecimal }
while I < Len do
begin
C := OrdAt(ARaw, I);
if (C < 48) or (C > 57) then Break;
N := N * 10 + (C - 48);
I := I + 1;
while I < Len do
begin
C := OrdAt(ARaw, I);
if (C >= 48) and (C <= 57) then N := N * 16 + (C - 48)
else if (C >= 65) and (C <= 70) then N := N * 16 + (C - 55) { A-F }
else if (C >= 97) and (C <= 102) then N := N * 16 + (C - 87) { a-f }
else Break;
I := I + 1;
end;
end
else
begin
while I < Len do
begin
C := OrdAt(ARaw, I);
if (C < 48) or (C > 57) then Break;
N := N * 10 + (C - 48);
I := I + 1;
end;
end;
Result := Result + CodepointToUtf8(N);
Result := Result + Chr(N);
end
else
I := I + 1;
@ -686,42 +599,6 @@ begin
end;
end;
{ Called immediately after the 'asm' keyword token was produced (FTok.Token is
that keyword). Drives the tokeniser forward to the matching 'end' keyword and
returns the verbatim source text between the two — assembly is not Pascal, so
nothing in the block is re-interpreted. Only a standalone 'end' KEYWORD token
terminates the block (an 'end' inside an asm '#' line comment is a comment
token, never a keyword, so it is ignored). The terminating 'end' token is
consumed; normal tokenising resumes after it. }
function TLexer.ReadAsmBody: string;
var
raw: TFpgPasToken;
BlockStart: Integer; { 1-based source index of the first char after 'asm' }
EndStart: Integer; { 1-based source index of the terminating 'end' }
begin
{ FTok.Token is the 'asm' keyword; the body begins right after it. }
BlockStart := FTok.Token.TextStart + FTok.Token.Len;
EndStart := -1;
while True do
begin
raw := FTok.NextToken();
if raw.Kind = fptkEOF then
begin
{ Unterminated block: capture to end of source. }
EndStart := Length(FTok.Source) + 1;
Break;
end;
if (raw.Kind = fptkKeyword) and (FTok.TokenTextUpper() = 'END') then
begin
EndStart := FTok.Token.TextStart;
Break;
end;
end;
{ Slice [BlockStart, EndStart) — Copy is 0-based, so subtract 1 from the
1-based start; length is EndStart - BlockStart. }
Result := Copy(FTok.Source, BlockStart - 1, EndStart - BlockStart);
end;
function TLexer.Next: TToken;
var
raw: TFpgPasToken;
@ -781,14 +658,7 @@ begin
begin
text := FTok.TokenTextUpper();
Result.Kind := MapKeyword(text);
if Result.Kind = tkAsmBlock then
{ Capture the whole 'asm' ... 'end' block as verbatim text — its
content is GNU/AT&T assembly, not Pascal, so it must not be
tokenised. ReadAsmBody drives the tokeniser to the matching
'end' and slices the raw source. }
Result.Value := Self.ReadAsmBody()
else
Result.Value := FTok.TokenText();
Result.Value := FTok.TokenText();
end;
fptkIdentifier:
@ -955,7 +825,6 @@ begin
tkOut: Result := 'out';
tkConstructor: Result := 'constructor';
tkDestructor: Result := 'destructor';
tkAsmBlock: Result := 'asm block';
tkIdent: Result := 'identifier';
tkPlus: Result := '+';
tkMinus: Result := '-';

715
compiler/src/main/pascal/uParser.pas
View file

File diff suppressed because it is too large Load diff

2469
compiler/src/main/pascal/uSemantic.pas
View file

File diff suppressed because it is too large Load diff

17
compiler/src/main/pascal/uSemanticExport.pas
View file

@ -230,16 +230,6 @@ begin
Result.ResolvedQbeName := ASrc.ResolvedQbeName;
Result.IsVirtual := ASrc.IsVirtual;
Result.IsOverride := ASrc.IsOverride;
{ Carry static-ness so a cross-unit TypeName.StaticMethod() call resolves —
VTableSlot alone cannot distinguish a static method from a final
non-virtual instance method (both are -1). }
Result.IsStatic := ASrc.IsStatic;
{ Carry the `overload` directive so a cross-unit overload set whose members
are split across an imported class and its ancestor is not truncated by
ResolveMethodOverload's hiding walk (which stops at a non-overload). }
Result.IsOverload := ASrc.IsOverload;
{ Carry visibility so cross-unit member access enforces private/protected. }
Result.Visibility := ASrc.Visibility;
Result.ReturnType := ResolveTypeRef(ASrc.ReturnTypeName, AIface, ADeps);
for I := 0 to ASrc.Params.Count - 1 do
@ -481,13 +471,6 @@ begin
if AUnit.ImplUsedUnits <> nil then
for I := 0 to AUnit.ImplUsedUnits.Count - 1 do
AIface.ImplUsedUnits.Add(AUnit.ImplUsedUnits.Strings[I]);
{ Link libraries — hoisted from every 'external ''lib''' decl (interface or
implementation), deduped. Carries the unit's link dependencies into the
.bif even when the importing routine is implementation-private. }
if AUnit.LinkLibs <> nil then
for I := 0 to AUnit.LinkLibs.Count - 1 do
if AIface.LinkLibs.IndexOf(TLinkLibDecl(AUnit.LinkLibs.Items[I]).LibName) < 0 then
AIface.LinkLibs.Add(TLinkLibDecl(AUnit.LinkLibs.Items[I]).LibName);
AIface.HasInitialization :=
(AUnit.InitStmts <> nil) and (AUnit.InitStmts.Count > 0);
end;

161
compiler/src/main/pascal/uSemanticImport.pas
View file

@ -260,90 +260,17 @@ begin
ART.SetVTableSlotAt(ASig.VTableSlot, ASig.Name, ImplName);
end;
{ Register the shared globals for a `static var` (class variable) imported
from a .bif. Mirrors uSemantic.AnalyseTypeDecls (the IsClassVar branch):
a static var is NOT an instance field, so it must not advance the type
layout — instead it becomes one shared global reachable both bare (inside
the type's own methods) and qualified ('TFoo.Name' from anywhere).
CRITICAL: ClassVarEmitName is the mangled label computed at the DEFINING
unit's export time and serialised verbatim. The importer must use the
DECODED value, never recompute it — the importing unit's own prefix
differs, so re-deriving would produce a label that does not match the data
slot the exporting unit emitted. }
procedure RegisterImportedClassVar(const ATypeName, AFieldName,
AEmitName: string;
AFieldType: TTypeDesc;
ATable: TSymbolTable);
var
Sym: TSymbol;
begin
{ Bare name — usable unqualified inside the type's own methods. }
Sym := TSymbol.Create(AFieldName, skVariable, AFieldType);
Sym.IsGlobal := True;
Sym.IsClassVar := True;
Sym.GlobalEmitName := AEmitName;
if not ATable.Define(Sym) then Sym.Free();
{ Qualified name — usable as TFoo.Name from anywhere. }
Sym := TSymbol.Create(ATypeName + '.' + AFieldName, skVariable, AFieldType);
Sym.IsGlobal := True;
Sym.IsClassVar := True;
Sym.GlobalEmitName := AEmitName;
if not ATable.Define(Sym) then Sym.Free();
end;
{ Register class/record-level `static const` declarations imported from a
.bif. Mirrors the within-unit registration in uSemantic.AnalyseTypeDecls:
each const is reachable both bare and qualified ('TFoo.Tag'). Array consts
are out of scope here (the within-unit path supports them, but no cached
consumer needs them yet); only scalar int/string consts are imported. }
procedure RegisterImportedTypeConsts(const ATypeName: string;
AConstDecls: TObjectList;
ATable: TSymbolTable);
var
J: Integer;
CD: TConstDecl;
Par: TTypeDesc;
Sym: TSymbol;
begin
if AConstDecls = nil then Exit;
for J := 0 to AConstDecls.Count - 1 do
begin
CD := TConstDecl(AConstDecls.Items[J]);
if CD.IsArrayConst then Continue; { array static consts not yet imported }
if CD.IsString then
Par := ATable.FindType('string')
else
Par := ATable.FindType('Integer');
{ Unqualified name — usable inside the type's own methods without prefix. }
Sym := TSymbol.Create(CD.Name, skConstant, Par);
Sym.ConstValue := CD.IntVal;
Sym.ConstString := CD.StrVal;
if not ATable.Define(Sym) then Sym.Free();
{ Qualified name — usable as TFoo.Tag from anywhere. }
Sym := TSymbol.Create(ATypeName + '.' + CD.Name, skConstant, Par);
Sym.ConstValue := CD.IntVal;
Sym.ConstString := CD.StrVal;
if not ATable.Define(Sym) then Sym.Free();
end;
end;
function ResolveParentClassByName(const AParentName: string;
ATable: TSymbolTable): TRecordTypeDesc;
var
TD: TTypeDesc;
Sym: TSymbol;
begin
Result := nil;
if AParentName = '' then Exit;
{ Use FindType, not a bare Lookup: a cross-unit parent is serialised in the
.bif with its unit qualifier (e.g. `testing.TTestCase`), and FindType
strips the qualifier and resolves the tail through the uses chain. A bare
Lookup of the qualified name returns nil, leaving the parent unlinked — the
warm-cache "Undeclared procedure 'Ignore'" bug (inherited method on a
grandparent in another cached unit could not be reached). }
TD := ATable.FindType(AParentName);
if TD is TRecordTypeDesc then
Result := TRecordTypeDesc(TD);
Sym := ATable.Lookup(AParentName);
if (Sym = nil) or (Sym.Kind <> skType) then Exit;
if Sym.TypeDesc is TRecordTypeDesc then
Result := TRecordTypeDesc(Sym.TypeDesc);
end;
{ Build the comma-separated '1'/'0' var-flag string AddMethod expects.
@ -529,10 +456,6 @@ begin
begin
FldInfo := TFieldInfo(ParentRT.Fields.Items[I]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
{ Inherited field keeps the ancestor's visibility + declaring origin. }
RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
@ -545,25 +468,8 @@ begin
raise EImportError.CreateFmt(
'Class %s field type %s unresolved',
[AEntry.Name, FldDecl.TypeName]);
if FldDecl.IsClassVar then
{ `static var`: a shared global, NOT an instance field — do not AddField
(that would advance the layout). Register the global under the
DECODED emit label. Multi-name static-var decls are not produced by
the parser (ClassVarEmitName is only set for single-name decls), so
the single decoded label applies to FldDecl.Names[0]. }
RegisterImportedClassVar(AEntry.Name, FldDecl.Names.Strings[0],
FldDecl.ClassVarEmitName, FldType, ATable)
else
for J := 0 to FldDecl.Names.Count - 1 do
begin
RT.AddField(FldDecl.Names.Strings[J], FldType);
{ An imported field's privacy boundary is its own declaring unit, not
the importing unit — carry both so cross-unit private/protected is
enforced exactly as in the declaring unit. }
RT.FindField(FldDecl.Names.Strings[J]).Visibility := FldDecl.Visibility;
RT.FindField(FldDecl.Names.Strings[J]).DeclaringUnit := AUnitName;
RT.FindField(FldDecl.Names.Strings[J]).DeclaringType := AEntry.Name;
end;
for J := 0 to FldDecl.Names.Count - 1 do
RT.AddField(FldDecl.Names.Strings[J], FldType);
end;
{ Methods: walk TRoutineSig list; for virtual/override, register
@ -639,19 +545,9 @@ begin
if (FldSym <> nil) and (FldSym.Kind = skType) then
PropInfo.IndexTypeDesc := FldSym.TypeDesc;
end;
{ Static-property facts — TypeName.Prop reads/writes dispatch with no
implicit Self. Mirrors the within-unit pass (PropInfo.IsStatic). }
PropInfo.IsDefault := PropDecl.IsDefault;
PropInfo.IsStatic := PropDecl.IsStatic;
PropInfo.Visibility := PropDecl.Visibility;
PropInfo.DeclaringUnit := AUnitName;
PropInfo.DeclaringType := AEntry.Name;
RT.AddProperty(PropInfo);
end;
{ Class-level `static const` declarations — reachable bare and qualified. }
RegisterImportedTypeConsts(AEntry.Name, ClassDef.ConstDecls, ATable);
{ Class attributes. uSemanticExport currently copies the raw
attribute names ('Threaded', not 'ThreadedAttribute') — but
AddClassAttribute downstream wants the resolved-name form.
@ -708,22 +604,9 @@ begin
raise EImportError.CreateFmt(
'Record %s field type %s unresolved',
[AEntry.Name, FldDecl.TypeName]);
if FldDecl.IsClassVar then
{ record-level `static var`: shared global, not an instance field. }
RegisterImportedClassVar(AEntry.Name, FldDecl.Names.Strings[0],
FldDecl.ClassVarEmitName, FldType, ATable)
else
for J := 0 to FldDecl.Names.Count - 1 do
begin
RecDesc.AddField(FldDecl.Names.Strings[J], FldType);
RecDesc.FindField(FldDecl.Names.Strings[J]).Visibility := FldDecl.Visibility;
RecDesc.FindField(FldDecl.Names.Strings[J]).DeclaringUnit := AUnitName;
RecDesc.FindField(FldDecl.Names.Strings[J]).DeclaringType := AEntry.Name;
end;
for J := 0 to FldDecl.Names.Count - 1 do
RecDesc.AddField(FldDecl.Names.Strings[J], FldType);
end;
{ record-level `static const` declarations — reachable bare and qualified. }
RegisterImportedTypeConsts(AEntry.Name, RecDef.ConstDecls, ATable);
end;
procedure RegisterProcType(AEntry: TTypeEntry; ATable: TSymbolTable;
@ -896,13 +779,7 @@ begin
Sym.ConstString := Entry.Decl.StrVal;
Sym.OwningUnit := AIface.Name;
if not ATable.Define(Sym) then
begin
{ EXPERIMENT (last-wins): on a duplicate name, detach the slot the
table already holds (kept alive via the per-unit cache for
qualified access) and store this later unit's symbol instead. }
ATable.ExtractLocal(Entry.Decl.Name);
ATable.Define(Sym);
end;
Sym.Free(); { duplicate — silently skip }
end;
end;
@ -928,14 +805,7 @@ begin
Sym.IsThreadVar := Entry.IsThreadVar;
Sym.OwningUnit := AIface.Name;
if not ATable.Define(Sym) then
begin
{ Cross-unit collision (last-wins): detach the slot the table already
holds — kept alive via the per-unit cache (RegisterUnitIface) for
qualified access — and store this later unit's symbol instead.
Mirrors RegisterConsts and the source-path DefineGlobalLastWins. }
ATable.ExtractLocal(Entry.Name);
ATable.Define(Sym);
end;
Sym.Free();
end;
end;
@ -991,15 +861,6 @@ begin
Result.VTableSlot := ASig.VTableSlot;
Result.IsVirtual := ASig.IsVirtual;
Result.IsOverride := ASig.IsOverride;
{ Carry static-ness so the semantic pass's TypeName.StaticMethod() resolution
(which checks MDecl.IsStatic) succeeds for a method imported from a .bif. }
Result.IsStatic := ASig.IsStatic;
{ Carry the `overload` directive so ResolveMethodOverload's hiding walk treats
an imported overload as overloadable — otherwise an overload set split
across an imported class and its ancestor is truncated to the derived level. }
Result.IsOverload := ASig.IsOverload;
{ Carry visibility so cross-unit private/protected method access is enforced. }
Result.Visibility := ASig.Visibility;
for J := 0 to ASig.Params.Count - 1 do
begin
Param := TMethodParam(ASig.Params.Items[J]);

189
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -14,28 +14,6 @@ uses
Classes, SysUtils, contnrs;
type
{ Member visibility — class/record field, method, and property access scope.
Default (a member declared before any visibility keyword) is mvPublic, to
match Blaise's previous behaviour where visibility was parsed but never
enforced (everything was effectively public).
mvPublic / mvPublished — visible everywhere the type is.
mvPrivate — visible only within the declaring UNIT
(classic Pascal unit-scoped privacy).
mvProtected — as mvPrivate plus descendant types' methods,
regardless of unit.
mvStrictPrivate — visible only from the declaring TYPE's methods.
mvStrictProtected — declaring type plus its descendants' methods.
Declared here (not in uAST) so the symbol-table descriptors can carry it;
uAST uses uSymbolTable, so the type flows up to the AST member decls. }
TMemberVisibility = (
mvPublic,
mvPrivate,
mvProtected,
mvPublished,
mvStrictPrivate,
mvStrictProtected
);
{ ------------------------------------------------------------------ }
{ Type descriptors }
{ ------------------------------------------------------------------ }
@ -73,21 +51,6 @@ type
public
Kind: TTypeKind;
Name: string;
{ Name of the unit that declared this named type (empty for builtins and
program-scope types). Set by TSymbolTable.Define when the type symbol is
registered. Codegen mangles the type's storage symbols (typeinfo,
vtable, _FieldCleanup, itab) with this owner so two used units exporting a
same-named type emit distinct, non-colliding symbols. }
OwningUnit: string;
{ True when this descriptor was created for a NAMED integer subrange
(type TIdx = lo..hi;). Layout/Kind/RawSize remain those of the narrowest
fitting standard integer type — the value behaves as an ordinary unchecked
int — but the lo..hi bounds are retained as compile-time metadata so the
array-index resolver can fold array[TIdx] -> array[lo..hi]. No other path
(codegen, IsNumeric/IsOrdinal, assignment compatibility) consults these. }
IsSubrange: Boolean;
SubrangeLow: Int64;
SubrangeHigh: Int64;
function IsNumeric: Boolean;
function IsFloat: Boolean;
function IsString: Boolean;
@ -150,9 +113,8 @@ type
end;
{ Enum type descriptor. Members are ordered; ordinal values are 0..N-1.
Stored as QBE 'w' (same as Integer). Members are NOT registered as bare
global skConstants; a bare member name resolves through the semantic
analyser's type-keyed reverse index (see ResolveEnumMember). }
Stored as QBE 'w' (same as Integer). Each member is also registered in
the symbol table as a skConstant with this type descriptor. }
TEnumTypeDesc = class(TTypeDesc)
public
Members: TStringList; { owned — ordered member names }
@ -234,13 +196,6 @@ type
with neither addref nor release, and field cleanup
does nothing. Use only when the referent is
guaranteed to outlive this field. }
Visibility: TMemberVisibility; { access scope; default mvPublic }
DeclaringUnit: string; { name of the unit that declares the owning type — the
privacy boundary for mvPrivate/mvProtected }
DeclaringType: string; { name of the class/record that DECLARED this field; for
an inherited field this is the ancestor, not the
subclass that copied it — protected/strict checks walk
the descendant chain up to this type }
end;
{ One entry in a class vtable — tracks slot index and implementing method. }
@ -264,10 +219,6 @@ type
IndexParamName: string; { '' = non-indexed property }
[Unretained] IndexTypeDesc: TTypeDesc; { not owned; non-nil when IndexParamName <> '' }
IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) }
IsStatic: Boolean; { declared `static property` — accessors are static (no Self) }
Visibility: TMemberVisibility; { access scope; default mvPublic }
DeclaringUnit: string; { unit that declares the owning type — privacy boundary }
DeclaringType: string; { class/record that DECLARED this property (ancestor for inherited) }
end;
{ Type descriptor for zero-GUID interface types (Phase 3). }
@ -417,16 +368,6 @@ type
of the strong addref/release pattern. }
IsGlobal: Boolean; { true for program-level variables; codegen uses
QBE data-section storage instead of stack alloc }
IsClassVar: Boolean; { true for a STATIC (class-level) variable. Stored
as a single shared global (IsGlobal is also True),
under the mangled GlobalEmitName, not as a
per-instance field. }
GlobalEmitName: string; { when non-empty, the mangled data-label this symbol
emits/loads/stores under (e.g. 'TFoo_FInstance').
Lets a bare lookup key ('FInstance') and a
qualified one ('TFoo.FInstance') resolve to ONE
storage slot. Mirrors ConstArrayQbe for consts.
Empty = emit under Name. }
IsThreadVar: Boolean; { true for threadvar declarations; codegen emits
TLS storage instead of plain global data }
IsOverload: Boolean; { true when declared with the 'overload' directive;
@ -442,22 +383,6 @@ type
symbols owned by the unit being analysed. Read
by per-unit visibility and by unit-prefix
mangling on cross-unit references. }
IsImplPrivate: Boolean; { true for a symbol declared in the IMPLEMENTATION
section of its owning unit. Such a symbol is
visible only inside that unit — never to a used
unit (it is not in the unit's interface) — so
Lookup suppresses it whenever the viewing unit is
not the owner. Prevents an impl-section class/
type from leaking into an unrelated unit through
the flat global scope. }
Visibility: TMemberVisibility; { for a STATIC (class-level) variable: the
declared member visibility (private/protected/
strict/public). Default mvPublic. Read by the
qualified-access visibility checks. }
OwnerTypeName: string; { for a STATIC (class-level) variable: the class/
record that declared it. Empty for non-members.
Lets strict/protected checks resolve the owning
type the same way TFieldInfo.DeclaringType does. }
constructor Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc);
destructor Destroy; override;
end;
@ -485,13 +410,6 @@ type
references through every Register* helper. }
function SymbolCount: Integer;
function SymbolAt(AIdx: Integer): TSymbol;
{ Detach a directly-defined symbol from this scope WITHOUT freeing
it (FSymbols owns, so Extract not Remove). Returns the detached
symbol, or nil if not present. Caller takes responsibility for
the object's lifetime — used so a duplicate import can hand the
flat-scope slot to a later unit while a per-unit cache keeps the
original alive. }
function ExtractLocal(const AName: string): TSymbol;
end;
{ ------------------------------------------------------------------ }
@ -570,34 +488,12 @@ type
retrieve the canonical TSymbol — without this flag we'd loop. }
FBypassUsesChain: Boolean;
FInCodegen: Boolean; { True while a backend is emitting code.
Disables the Layer-6 impl-private
suppression in Lookup: that guard exists
only to stop an implementation-section
symbol of unit A leaking into a different
unit B DURING ANALYSIS. At codegen time a
backend legitimately resolves a unit's own
impl-section classes (to emit their
typeinfo/vtable/_FieldCleanup and the
references to them), but FDefineOwningUnit
can have drifted to a dependency unit
mid-emit, which made the suppression wrongly
fire and silently drop the class's typeinfo
— a dangling symbol the linker binds to
garbage. Set by the QBE and native
backends around Generate/GenerateUnit. }
FDefineOwningUnit: string; { auto-applied to Sym.OwningUnit on Define
when the symbol has no explicit value;
set by AnalyseUnit/AnalyseUnitForExport
so semantic-side Define sites don't
each need to thread the unit name. }
FDefineImplPrivate: Boolean; { when True, Define()/DefineGlobal() mark the
symbol IsImplPrivate. Set by the analyser
around impl-section type/const registration
so those symbols stay unit-private. }
function GetCurrentScope: TScope;
function GetScopeDepth: Integer;
function NewType(AKind: TTypeKind; const AName: string): TTypeDesc;
@ -617,9 +513,6 @@ type
function Define(ASymbol: TSymbol): Boolean;
{ Define in global (outermost) scope regardless of current push depth. }
function DefineGlobal(ASymbol: TSymbol): Boolean;
{ Detach a symbol from the current scope without freeing it (see
TScope.ExtractLocal). Returns the detached symbol or nil. }
function ExtractLocal(const AName: string): TSymbol;
function Lookup(const AName: string): TSymbol;
{ Auto-OwningUnit context. When set, Define()/DefineGlobal() will
@ -628,12 +521,6 @@ type
property DefineOwningUnit: string read FDefineOwningUnit
write FDefineOwningUnit;
{ Impl-private context. When True, Define()/DefineGlobal() mark the symbol
IsImplPrivate so it stays visible only to its owning unit. Set by the
analyser around implementation-section type/const registration. }
property DefineImplPrivate: Boolean read FDefineImplPrivate
write FDefineImplPrivate;
{ Hook into the analyser's uses-chain lookup. When non-nil,
Lookup() consults the chain after pushed scopes and before the
global scope. Wired by TSemanticAnalyser. Task #44 step 7. }
@ -647,9 +534,6 @@ type
property BypassUsesChain: Boolean read FBypassUsesChain
write FBypassUsesChain;
{ Set by a backend for the duration of code emission; see FInCodegen. }
property InCodegen: Boolean read FInCodegen write FInCodegen;
{ Type lookup — case-insensitive, returns nil if not found }
function FindType(const AName: string): TTypeDesc;
@ -726,14 +610,6 @@ function IsUnmangledUnit(const AUnitName: string): Boolean;
agree on the QBE global name. }
function MangleUnitPrefix(const AUnitName: string): string;
const
{ Sentinel owning-unit value meaning "this global's emit name is ALREADY a
fully-mangled symbol — codegen must add no further unit prefix". Used for
static class/record vars, whose label (Unit_Class_Field) is class-qualified
and complete; the module-var prefixing must not double-apply. The leading
control byte can never collide with a real unit name. }
PreMangledGlobalOwner = #1'premangled';
implementation
uses
@ -1385,17 +1261,6 @@ begin
Result := True;
end;
function TScope.ExtractLocal(const AName: string): TSymbol;
var
Idx: Integer;
begin
Result := nil;
if not FKeys.Find(AName, Idx) then Exit;
Result := TSymbol(FKeys.Objects[Idx]);
FKeys.Delete(Idx); { free the name }
FSymbols.Extract(Result); { detach without freeing }
end;
function TScope.LookupLocal(const AName: string): TSymbol;
var
Idx: Integer;
@ -1984,8 +1849,6 @@ function TSymbolTable.DefineGlobal(ASymbol: TSymbol): Boolean;
begin
if (ASymbol.OwningUnit = '') and (FDefineOwningUnit <> '') then
ASymbol.OwningUnit := FDefineOwningUnit;
if FDefineImplPrivate then
ASymbol.IsImplPrivate := True;
Result := TScope(FScopeStack.Items[0]).Define(ASymbol);
end;
@ -2025,22 +1888,9 @@ begin
if (ASymbol.OwningUnit = '') and (FDefineOwningUnit <> '')
and (FScopeStack.Count = 1) then
ASymbol.OwningUnit := FDefineOwningUnit;
if FDefineImplPrivate and (FScopeStack.Count = 1) then
ASymbol.IsImplPrivate := True;
{ Propagate the owning unit onto the type descriptor so codegen can mangle a
type's storage symbols by the declaring unit even after a same-named type
from another used unit wins the flat slot (cross-unit type last-wins). }
if (ASymbol.Kind = skType) and (ASymbol.TypeDesc <> nil)
and (ASymbol.TypeDesc.OwningUnit = '') and (ASymbol.OwningUnit <> '') then
ASymbol.TypeDesc.OwningUnit := ASymbol.OwningUnit;
Result := CurrentScope.Define(ASymbol);
end;
function TSymbolTable.ExtractLocal(const AName: string): TSymbol;
begin
Result := CurrentScope.ExtractLocal(AName);
end;
function TSymbolTable.Lookup(const AName: string): TSymbol;
var
I: Integer;
@ -2107,33 +1957,7 @@ begin
end;
{ Layer 6 — whatever the global walk produced earlier (builtins, or
flat-merged residue not yet caught above).
Suppress one specific leak: an IMPLEMENTATION-section symbol of unit A is
private to A and must never resolve while a DIFFERENT unit B is being
analysed. Without this, a class declared in A's implementation section
leaks into an unrelated B through the flat global scope (the root blocker
for "classes in unit implementation section"). Interface symbols are left
untouched here so existing transitive-visibility behaviour is unchanged.
The check only runs while a unit/program is being analysed
(FDefineOwningUnit <> '') and the chain walker is not mid-callback; outside
analysis (some codegen-side lookups clear FDefineOwningUnit) the residue is
returned unchanged so unit-prefix mangling still resolves owned symbols.
It is also disabled during code emission (FInCodegen): the leak it guards is
purely an analysis-time concern, whereas a backend legitimately resolves a
unit's own implementation-section classes to emit their typeinfo/vtable/
_FieldCleanup. FDefineOwningUnit can have drifted to a dependency unit
mid-emit, which would otherwise make this suppression wrongly fire and drop
the class's typeinfo, leaving a dangling symbol the linker binds to garbage. }
if (Sym <> nil) and Sym.IsImplPrivate and (FDefineOwningUnit <> '')
and not FBypassUsesChain and not FInCodegen
and not SameText(Sym.OwningUnit, FDefineOwningUnit) then
begin
Result := nil;
Exit;
end;
flat-merged residue not yet caught above). }
Result := Sym;
end;
@ -2188,18 +2012,11 @@ end;
function IsUnmangledUnit(const AUnitName: string): Boolean;
begin
{ RTL units export their runtime symbols (_SetArgs, _BlaiseGetMem, _start, …)
UNMANGLED — the compiler emits bare calls to them — so their unit prefix is
empty. The RTL units are: System, the rtl.* platform units, and the
runtime.* units (dotted-flat names after the RTL-unification move; the
legacy blaise_* names are still accepted for any not-yet-renamed source). }
Result := True;
if AUnitName = '' then Exit;
if SameText(AUnitName, 'System') then Exit;
if (Length(AUnitName) >= 4)
and SameText(Copy(AUnitName, 0, 4), 'rtl.') then Exit;
if (Length(AUnitName) >= 8)
and SameText(Copy(AUnitName, 0, 8), 'runtime.') then Exit;
if (Length(AUnitName) >= 7)
and SameText(Copy(AUnitName, 0, 7), 'blaise_') then Exit;
Result := False;

111
compiler/src/main/pascal/uToolchain.pas
View file

@ -36,13 +36,7 @@ type
{ Variant of a tool, determining the CLI syntax callers emit. }
TToolKind = (
tkUnknown, { resolver couldn't classify }
tkGnuAs, { as -o OUT IN.s — GNU assembler. Named tkGnuAs (not the
bare tkAs) so it does not collide with uLexer's
TTokenKind.tkAs: a bare `tkAs` here is ambiguous and
bare-member resolution is cross-unit order-fragile,
which could bind it to TTokenKind.tkAs (ordinal 40) —
out of range for this 4-member enum, sending downstream
Kind-indexing off the end into a layout-sensitive crash. }
tkAs, { as -o OUT IN.s — GNU assembler }
tkCCDriver, { cc / gcc / clang-as-driver — GNU link line }
tkQBE { qbe -o OUT IN.ssa }
);
@ -56,6 +50,7 @@ type
QBE: TTool; { QBE backend only }
Assembler: TTool; { native backend: assemble .s -> .o (reserved) }
Linker: TTool; { both backends: link final binary }
RTLPath: string; { '' if not found }
end;
{ One external tool a backend declares it needs (TBackendDriver.DescribeTools).
@ -92,14 +87,13 @@ function ResolveToolchain(const ATarget: TTargetDesc): TToolchain;
function ResolveQBE: TTool;
function ResolveAssembler: TTool;
function ResolveLinker(const ATarget: TTargetDesc): TTool;
function FindRTLArchive(const ATarget: TTargetDesc): string;
{ Directory containing the running compiler binary (ParamStr(0)). }
function CompilerBinDir: string;
{ RTL source directory (compiler/src/main/pascal), relative to the binary.
The driver builds the RTL objects from here when linking; overridable via
$BLAISE_RTL_SRC. }
function RTLSourceDir: string;
{ Locate the system CRT startup objects needed for dynamic (PIE) linking.
Returns True when all five objects are found; on False the paths are empty
and the caller should fall back to the external linker. }
function FindCrtObjects(out ACrt1, ACrti, ACrtn,
ACrtBeginS, ACrtEndS: string): Boolean;
{ Walks $PATH for the first file named ABaseName that exists. Returns the
absolute path on hit, '' on miss. On Windows hosts also tries '.exe'. }
@ -313,7 +307,7 @@ end;
function ResolveAssembler: TTool;
begin
Result.Path := ResolveToolPath('BLAISE_AS', 'as', '');
Result.Kind := tkGnuAs;
Result.Kind := tkAs;
end;
function ResolveLinker(const ATarget: TTargetDesc): TTool;
@ -331,40 +325,72 @@ begin
Result := ExtractFilePath(ParamStr(0));
end;
function RTLDirHasUnits(const ADir: string): Boolean;
function FindRTLArchive(const ATarget: TTargetDesc): string;
var
BinDir: string;
begin
Result := (ADir <> '') and
FileExists(IncludeTrailingPathDelimiter(ADir) + 'runtime.arc.pas');
Result := GetEnvironmentVariable('BLAISE_RTL');
if (Result <> '') and FileExists(Result) then Exit;
BinDir := CompilerBinDir();
Result := IncludeTrailingPathDelimiter(BinDir) + 'blaise_rtl.a';
if FileExists(Result) then Exit;
Result := '';
end;
function RTLSourceDir: string;
{ ------------------------------------------------------------------ }
{ CRT object discovery }
{ ------------------------------------------------------------------ }
function FindCrtObjects(out ACrt1, ACrti, ACrtn,
ACrtBeginS, ACrtEndS: string): Boolean;
const
CrtDirs: array[0..2] of string = (
'/usr/lib/x86_64-linux-gnu',
'/usr/lib64',
'/usr/lib'
);
GccVers: array[0..3] of string = ('14', '13', '12', '11');
GccBases: array[0..1] of string = (
'/usr/lib/gcc/x86_64-linux-gnu',
'/usr/lib/gcc/x86_64-redhat-linux'
);
var
Cand: string;
CrtDir, GccDir: string;
I, J: Integer;
begin
{ The RTL units (runtime.*, rtl.platform.*) live in the compiler's own source
tree. Resolve the directory robustly across the ways the compiler is run:
ACrt1 := '';
ACrti := '';
ACrtn := '';
ACrtBeginS := '';
ACrtEndS := '';
Result := False;
1. binary-relative: <bindir>/../src/main/pascal — the in-tree
compiler/target/blaise.
2. CWD-relative: compiler/src/main/pascal then src/main/pascal — the
binary may be copied elsewhere (e.g. /tmp during a fixpoint) but
invoked from the project root by the build.
for I := 0 to High(CrtDirs) do
begin
CrtDir := CrtDirs[I];
if FileExists(CrtDir + '/Scrt1.o') then
begin
ACrt1 := CrtDir + '/Scrt1.o';
ACrti := CrtDir + '/crti.o';
ACrtn := CrtDir + '/crtn.o';
Break;
end;
end;
if ACrt1 = '' then Exit;
The driver consults $BLAISE_RTL_SRC before calling this, for a fully
relocated binary (release) that ships its RTL source elsewhere. }
Cand := IncludeTrailingPathDelimiter(CompilerBinDir()) + '../src/main/pascal';
if RTLDirHasUnits(ExpandFileName(Cand)) then Exit(ExpandFileName(Cand));
Cand := 'compiler/src/main/pascal';
if RTLDirHasUnits(ExpandFileName(Cand)) then Exit(ExpandFileName(Cand));
Cand := 'src/main/pascal';
if RTLDirHasUnits(ExpandFileName(Cand)) then Exit(ExpandFileName(Cand));
{ Fall back to the binary-relative path so callers get a meaningful "not
found" message naming a concrete location. }
Result := ExpandFileName(IncludeTrailingPathDelimiter(CompilerBinDir())
+ '../src/main/pascal');
for I := 0 to High(GccBases) do
for J := 0 to High(GccVers) do
begin
GccDir := GccBases[I] + '/' + GccVers[J];
if FileExists(GccDir + '/crtbeginS.o') then
begin
ACrtBeginS := GccDir + '/crtbeginS.o';
ACrtEndS := GccDir + '/crtendS.o';
Result := FileExists(ACrti) and FileExists(ACrtn)
and FileExists(ACrtEndS);
Exit;
end;
end;
end;
{ ------------------------------------------------------------------ }
@ -376,6 +402,7 @@ begin
Result.QBE := ResolveQBE();
Result.Assembler := ResolveAssembler();
Result.Linker := ResolveLinker(ATarget);
Result.RTLPath := FindRTLArchive(ATarget);
end;
end.

22
compiler/src/main/pascal/uUnitInterface.pas
View file

@ -89,18 +89,6 @@ type
IsVirtual: Boolean; { virtual method that allocates a new
vtable slot }
IsOverride: Boolean; { override that replaces a parent slot }
IsStatic: Boolean; { static (class-level) method — takes no
implicit Self. VTableSlot is -1 for both
static and final non-virtual instance
methods, so this is a distinct flag rather
than being inferred from the slot. }
IsOverload: Boolean; { declared with the `overload` directive.
ResolveMethodOverload's hiding walk stops at
the first non-overload candidate, so this must
survive the .bif or an overload set split
across an imported class and its ancestor is
truncated to the more-derived level. }
Visibility: TMemberVisibility; { member access scope; default mvPublic }
constructor Create;
destructor Destroy; override;
end;
@ -204,14 +192,6 @@ type
that loads this unit from its cached .bif
still pulls in (and links) impl-only
dependencies. }
LinkLibs: TStringList; { owned — bare library names this unit must be
linked against (deduped), hoisted from every
'external ''lib''' decl, interface OR
implementation. An implementation-private
import keeps its symbol out of the .bif but
its library still propagates here, so a
downstream program links it (-l<name> /
<name>.dll). }
HasInitialization: Boolean; { unit has a non-empty initialization
section. An incremental rebuild loads this
unit from its cached .bif and must still
@ -410,7 +390,6 @@ begin
Name := AName;
UsedUnits := TStringList.Create();
ImplUsedUnits := TStringList.Create();
LinkLibs := TStringList.Create();
Types := TObjectList.Create(True);
Consts := TObjectList.Create(True);
@ -441,7 +420,6 @@ begin
Consts.Free();
Types.Free();
LinkLibs.Free();
ImplUsedUnits.Free();
UsedUnits.Free();
inherited Destroy();

225
compiler/src/main/pascal/uUnitInterfaceIO.pas
View file

@ -49,55 +49,11 @@ unit uUnitInterfaceIO;
interface
uses
Classes, SysUtils, streams, strutils, uAST, uUnitInterface, uStrCompat;
Classes, SysUtils, streams, strutils, uAST, uUnitInterface;
const
IFACE_MAGIC = 'BLAISE-IFACE';
IFACE_VERSION = 8; { v8 (this cycle): named integer subranges now round-trip.
A `type TIdx = lo..hi;` alias carries IsSubrange + the
lo..hi bounds so `array[TIdx] of T` folds to
`array[lo..hi] of T` across separate compilation. The
'alias' TYPE entry grew three trailing fields
(IsSubrange bool + SubrangeLow + SubrangeHigh, each an
lpstr) after TypeName, so v7 readers must reject these
.bif and recompile.
v7: external-library link dependencies now
round-trip. TUnitInterface.LinkLibs is serialised in
the META block (one EncodeStringList after
ImplUsedUnits, before HasInitialization) so a unit's
`external 'lib' name '...'` declarations propagate the
libraries to link. The META layout grew, so v6 readers
must reject these .bif and recompile.
v6: the `overload` directive now round-trips.
TRoutineSig.IsOverload added to EncodeMethodSig/
ReadMethodSig (one extra byte after IsStatic) and
TMethodDecl.IsOverload added to EncodeMethodDecl/
ReadMethodDecl (after IsOverride; this is the
interface- and generic-template-method path). Without
it a cross-unit overload set split across an imported
class and its ancestor is truncated by the importer's
hiding walk. Both method layouts grew, so v5 readers
must reject these .bif and recompile.
v5: member Visibility (private/protected/
strict) now serialised — field, method, and property
payloads each carry one extra byte for the visibility
ordinal, so v4 readers must reject these .bif and
recompile.
v4: TRoutineSig.IsStatic added to
EncodeMethodSig/ReadMethodSig so a cross-unit
TypeName.StaticMethod() call resolves through the
cached .bif (VTableSlot alone cannot distinguish a
static method from a final non-virtual instance
method — both are -1). The method-sig layout grew,
so v3 readers must reject these .bif and recompile.
v3: `static` (class-level) member facts now
serialised — TFieldDecl.IsClassVar + ClassVarEmitName in
EncodeFieldList/ReadFieldList, TPropertyDecl.IsStatic in
EncodePropertyList/ReadPropertyList, and record/class
static-const declarations (ConstDecls) in the record/class
payloads. The layout grew, so v2 readers must reject these
.bif and recompile.
v1: shipped through release v0.11.x (last public commit
IFACE_VERSION = 2; { v1: shipped through release v0.11.x (last public commit
d56bdbf).
v2 (release v0.12.0): a batch of META/record additions
made this cycle, all gated by this single bump since
@ -310,41 +266,7 @@ begin
Result := Result +
EncodeLpstr(F.Names.Strings[J]) +
EncodeLpstr(F.TypeName) +
EncodeBool(F.IsWeak) +
{ `static var` (class variable) facts: IsClassVar marks the field
as a shared global rather than an instance slot; ClassVarEmitName
is the defining unit's mangled global label (set by uSemantic).
An importer cannot re-derive that label — its own unit prefix
differs — so the label is carried verbatim. Both default to
False/'' for ordinary instance fields. }
EncodeBool(F.IsClassVar) +
EncodeLpstr(F.ClassVarEmitName) +
{ member visibility ordinal (private/protected/strict) }
EncodeLpstr(IntToStr(Ord(F.Visibility)));
end;
end;
{ Record/class-level `static const` declarations. These are scalar
constants folded by the semantic pass; we serialise the same five-
field scalar shape the unit-level CONST block uses (Name, TypeName,
IntVal, StrVal, IsString/IsFloat flags). Non-scalar const forms
(array consts, unfolded expression tokens) are not carried here —
static const members are scalar in the current language surface. }
function EncodeConstDeclList(AConsts: TObjectList): string;
var
I: Integer;
C: TConstDecl;
begin
Result := EncodeCount(AConsts.Count);
for I := 0 to AConsts.Count - 1 do
begin
C := TConstDecl(AConsts.Items[I]);
Result := Result +
EncodeLpstr(C.Name) +
EncodeLpstr(C.TypeName) +
EncodeInt64(C.IntVal) +
EncodeLpstr(C.StrVal) +
EncodeFlags(C.IsString, C.IsFloat);
EncodeBool(F.IsWeak);
end;
end;
@ -364,14 +286,6 @@ begin
EncodeBool (AR.IsOverride) +
EncodeLpstr(AR.ResolvedQbeName) +
EncodeLpstr(IntToStr(AR.VTableSlot)) +
{ static-method flag — distinct from VTableSlot (both static and final
non-virtual instance methods carry slot -1). }
EncodeBool (AR.IsStatic) +
{ `overload` directive — must round-trip so a split overload set is not
truncated by the importer's hiding walk. }
EncodeBool (AR.IsOverload) +
{ member visibility ordinal }
EncodeLpstr(IntToStr(Ord(AR.Visibility))) +
EncodeCount(AR.Params.Count);
for J := 0 to AR.Params.Count - 1 do
begin
@ -399,9 +313,7 @@ var
begin
Def := TRecordTypeDef(AEntry.Def);
Result := EncodeBool(Def.IsPacked) +
EncodeFieldList(Def.Fields) +
{ record-level `static const` declarations. }
EncodeConstDeclList(Def.ConstDecls);
EncodeFieldList(Def.Fields);
end;
function EncodePropertyList(AList: TObjectList): string;
@ -420,12 +332,7 @@ begin
EncodeLpstr(P.WriteName) +
EncodeLpstr(P.IndexParamName) +
EncodeLpstr(P.IndexTypeName) +
EncodeBool(P.IsDefault) +
{ `static property` — accessors take no implicit Self. An importer
needs this to dispatch reads/writes without a receiver. }
EncodeBool(P.IsStatic) +
{ member visibility ordinal }
EncodeLpstr(IntToStr(Ord(P.Visibility)));
EncodeBool(P.IsDefault);
end;
end;
@ -441,9 +348,7 @@ begin
EncodeStringList(AEntry.Implements) +
EncodeFieldList(Def.Fields) +
EncodeMethodList(AEntry.Methods) +
EncodePropertyList(Def.Properties) +
{ class-level `static const` declarations. }
EncodeConstDeclList(Def.ConstDecls);
EncodePropertyList(Def.Properties);
end;
{ Encode a TMethodDecl (AST) using the same per-method payload shape
@ -465,9 +370,6 @@ begin
resolved cross-unit refs }
EncodeBool (AM.IsVirtual) +
EncodeBool (AM.IsOverride) +
EncodeBool (AM.IsOverload) + { `overload` directive — generic-template
and interface methods share this path
and may be overloaded }
EncodeCount(AM.Params.Count);
for J := 0 to AM.Params.Count - 1 do
begin
@ -640,10 +542,7 @@ begin
else if Kind = 'alias' then
SB.AppendLine(EncodeLpstr('alias') +
EncodeLpstr(E.Name) +
EncodeLpstr(TTypeAliasDef(E.Def).TypeName) +
EncodeBool(TTypeAliasDef(E.Def).IsSubrange) +
EncodeLpstr(IntToStr(TTypeAliasDef(E.Def).SubrangeLow)) +
EncodeLpstr(IntToStr(TTypeAliasDef(E.Def).SubrangeHigh)))
EncodeLpstr(TTypeAliasDef(E.Def).TypeName))
else if Kind = 'record' then
SB.AppendLine(EncodeLpstr('record') +
EncodeLpstr(E.Name) +
@ -753,7 +652,6 @@ begin
EncodeInt64(AIface.SourceModTime) +
EncodeStringList(AIface.UsedUnits) +
EncodeStringList(AIface.ImplUsedUnits) +
EncodeStringList(AIface.LinkLibs) +
EncodeBool(AIface.HasInitialization));
SB.AppendLine('END');
Result := SB.ToString();
@ -813,8 +711,7 @@ begin
Result := EncodeLpstr('nillit')
else if AE is TIdentExpr then
Result := EncodeLpstr('id') +
EncodeLpstr(TIdentExpr(AE).Name) +
EncodeLpstr(TIdentExpr(AE).QualifierUnit)
EncodeLpstr(TIdentExpr(AE).Name)
else if AE is TBinaryExpr then
Result := EncodeLpstr('bin') +
EncodeLpstr(IntToStr(Ord(TBinaryExpr(AE).Op))) +
@ -831,7 +728,6 @@ begin
Result := EncodeLpstr('mcall') +
EncodeLpstr(TMethodCallExpr(AE).ObjectName) +
EncodeLpstr(TMethodCallExpr(AE).Name) +
EncodeLpstr(TMethodCallExpr(AE).QualifierUnit) +
EncodeExpr(TMethodCallExpr(AE).ObjExpr) +
EncodeExprList(TMethodCallExpr(AE).Args)
else if AE is TIndirectFuncCallExpr then
@ -842,7 +738,6 @@ begin
Result := EncodeLpstr('field') +
EncodeLpstr(TFieldAccessExpr(AE).RecordName) +
EncodeLpstr(TFieldAccessExpr(AE).FieldName) +
EncodeLpstr(TFieldAccessExpr(AE).QualifierUnit) +
EncodeExpr(TFieldAccessExpr(AE).Base) +
EncodeExpr(TFieldAccessExpr(AE).PropIndexExpr)
else if AE is TDerefExpr then
@ -1008,9 +903,6 @@ begin
Result := EncodeLpstr('inh') +
EncodeLpstr(TInheritedCallStmt(AStmt).Name) +
EncodeExprList(TInheritedCallStmt(AStmt).Args)
else if AStmt is TAsmStmt then
Result := EncodeLpstr('asm') +
EncodeLpstr(TAsmStmt(AStmt).Code)
else
raise EIfaceFormatError.Create(
'EncodeStmt: unhandled statement node ' + AStmt.ClassName);
@ -1212,28 +1104,19 @@ end;
uSemanticImport.ResolveRef. }
procedure DecodeQualRef(const ASrc: string; var AUnit, AType: string);
var
I, LastDot: Integer;
Dot: Integer;
begin
{ Blaise Pos and Copy are 0-based. Split at the LAST '.', not the first:
the unit qualifier may itself be dotted (e.g. 'blaise.testing'), while a
type name never contains a dot. Splitting at the first dot mangled a
qualified type from a dotted unit — 'blaise.testing.TTestCase' decoded to
unit='blaise', type='testing.TTestCase', so the bare type name was lost
and a cached parent class could not be relinked (warm --unit-cache
inherited-method resolution failure). }
LastDot := -1;
for I := 0 to Length(ASrc) - 1 do
if StrAt(ASrc, I) = Ord('.') then
LastDot := I;
if LastDot < 0 then
{ Blaise Pos and Copy are 0-based. }
Dot := Pos('.', ASrc);
if Dot < 0 then
begin
AUnit := '';
AType := ASrc;
end
else
begin
AUnit := Copy(ASrc, 0, LastDot);
AType := Copy(ASrc, LastDot + 1, Length(ASrc) - LastDot - 1);
AUnit := Copy(ASrc, 0, Dot);
AType := Copy(ASrc, Dot + 1, Length(ASrc) - Dot - 1);
end;
end;
@ -1508,7 +1391,6 @@ begin
begin
IE := TIdentExpr.Create();
IE.Name := ReadLpstrAt(AText, APos);
IE.QualifierUnit := ReadLpstrAt(AText, APos);
Result := IE;
end
else if Kind = 'bin' then
@ -1535,10 +1417,9 @@ begin
else if Kind = 'mcall' then
begin
MCE := TMethodCallExpr.Create();
MCE.ObjectName := ReadLpstrAt(AText, APos);
MCE.Name := ReadLpstrAt(AText, APos);
MCE.QualifierUnit := ReadLpstrAt(AText, APos);
MCE.ObjExpr := ReadExpr(AText, APos);
MCE.ObjectName := ReadLpstrAt(AText, APos);
MCE.Name := ReadLpstrAt(AText, APos);
MCE.ObjExpr := ReadExpr(AText, APos);
ReadExprList(AText, APos, MCE.Args);
Result := MCE;
end
@ -1554,7 +1435,6 @@ begin
FA := TFieldAccessExpr.Create();
FA.RecordName := ReadLpstrAt(AText, APos);
FA.FieldName := ReadLpstrAt(AText, APos);
FA.QualifierUnit := ReadLpstrAt(AText, APos);
FA.Base := ReadExpr(AText, APos);
FA.PropIndexExpr := ReadExpr(AText, APos);
Result := FA;
@ -1646,7 +1526,6 @@ var
PCn: TProcCall;
MCSn: TMethodCallStmt;
ICSn: TInheritedCallStmt;
ASMn: TAsmStmt;
C, I: Integer;
Body: TASTStmt;
begin
@ -1814,12 +1693,6 @@ begin
ReadExprList(AText, APos, ICSn.Args);
Result := ICSn;
end
else if Kind = 'asm' then
begin
ASMn := TAsmStmt.Create();
ASMn.Code := ReadLpstrAt(AText, APos);
Result := ASMn;
end
else
raise EIfaceFormatError.Create(
'ReadStmt: unknown statement kind ''' + Kind + '''');
@ -1877,14 +1750,11 @@ end;
procedure ReadFieldList(const AText: string; var APos: Integer;
ATarget: TObjectList);
var
C, I: Integer;
FldName: string;
FldType: string;
IsWeak: Boolean;
IsClassVar: Boolean;
ClassVarEmit: string;
Vis: Integer;
F: TFieldDecl;
C, I: Integer;
FldName: string;
FldType: string;
IsWeak: Boolean;
F: TFieldDecl;
begin
C := DecodeCount(AText, APos);
for I := 1 to C do
@ -1892,47 +1762,14 @@ begin
FldName := ReadLpstrAt(AText, APos);
FldType := ReadLpstrAt(AText, APos);
IsWeak := DecodeBool(AText, APos);
{ Order must mirror EncodeFieldList: IsClassVar then ClassVarEmitName
then the visibility ordinal. }
IsClassVar := DecodeBool(AText, APos);
ClassVarEmit := ReadLpstrAt(AText, APos);
Vis := StrToInt(ReadLpstrAt(AText, APos));
F := TFieldDecl.Create();
F.Names.Add(FldName);
F.TypeName := FldType;
F.IsWeak := IsWeak;
F.IsClassVar := IsClassVar;
F.ClassVarEmitName := ClassVarEmit;
F.Visibility := TMemberVisibility(Vis);
ATarget.Add(F);
end;
end;
{ Inverse of EncodeConstDeclList — rebuild record/class `static const`
decls. Mirrors the writer's five-field scalar shape exactly. }
procedure ReadConstDeclList(const AText: string; var APos: Integer;
ATarget: TObjectList);
var
C, I: Integer;
CD: TConstDecl;
IsString: Boolean;
IsFloat: Boolean;
begin
C := DecodeCount(AText, APos);
for I := 1 to C do
begin
CD := TConstDecl.Create();
CD.Name := ReadLpstrAt(AText, APos);
CD.TypeName := ReadLpstrAt(AText, APos);
CD.IntVal := ReadInt64At(AText, APos);
CD.StrVal := ReadLpstrAt(AText, APos);
ReadFlagsAt(AText, APos, IsString, IsFloat);
CD.IsString := IsString;
CD.IsFloat := IsFloat;
ATarget.Add(CD);
end;
end;
{ Inverse of EncodeMethodSig — builds a TRoutineSig from the
per-method payload. }
function ReadMethodSig(const AText: string; var APos: Integer): TRoutineSig;
@ -1954,11 +1791,6 @@ begin
Result.IsOverride := DecodeBool(AText, APos);
Result.ResolvedQbeName := ReadLpstrAt(AText, APos);
Result.VTableSlot := StrToInt(ReadLpstrAt(AText, APos));
{ Order must mirror EncodeMethodSig: IsStatic follows VTableSlot, then
IsOverload, then the visibility ordinal. }
Result.IsStatic := DecodeBool(AText, APos);
Result.IsOverload := DecodeBool(AText, APos);
Result.Visibility := TMemberVisibility(StrToInt(ReadLpstrAt(AText, APos)));
Pc := DecodeCount(AText, APos);
for J := 1 to Pc do
begin
@ -1989,7 +1821,6 @@ begin
Def := TRecordTypeDef.Create();
Def.IsPacked := DecodeBool(AText, APos);
ReadFieldList(AText, APos, Def.Fields);
ReadConstDeclList(AText, APos, Def.ConstDecls);
AEntry.Def := Def;
end;
@ -2012,7 +1843,6 @@ begin
ReadFieldList(AText, APos, Def.Fields);
ReadMethodList(AText, APos, AEntry.Methods);
ReadPropertyList(AText, APos, Def.Properties);
ReadConstDeclList(AText, APos, Def.ConstDecls);
AEntry.IsClass := True;
AEntry.Def := Def;
end;
@ -2031,7 +1861,6 @@ begin
if not HasReturn then Result.ReturnTypeName := '';
Result.IsVirtual := DecodeBool(AText, APos);
Result.IsOverride := DecodeBool(AText, APos);
Result.IsOverload := DecodeBool(AText, APos);
Pc := DecodeCount(AText, APos);
for J := 1 to Pc do
begin
@ -2071,10 +1900,6 @@ begin
P.IndexParamName := ReadLpstrAt(AText, APos);
P.IndexTypeName := ReadLpstrAt(AText, APos);
P.IsDefault := DecodeBool(AText, APos);
{ Order must mirror EncodePropertyList: IsStatic follows IsDefault, then
the visibility ordinal. }
P.IsStatic := DecodeBool(AText, APos);
P.Visibility := TMemberVisibility(StrToInt(ReadLpstrAt(AText, APos)));
ATarget.Add(P);
end;
end;
@ -2145,9 +1970,6 @@ begin
C := DecodeCount(AText, APos);
for I := 1 to C do
AIface.ImplUsedUnits.Add(ReadLpstrAt(AText, APos));
C := DecodeCount(AText, APos);
for I := 1 to C do
AIface.LinkLibs.Add(ReadLpstrAt(AText, APos));
AIface.HasInitialization := ReadLpstrAt(AText, APos) = '1';
if ReadTag(AText, APos) <> 'END' then
raise EIfaceFormatError.Create('META block: missing END marker');
@ -2329,9 +2151,6 @@ begin
Payload := ReadLpstrAt(AText, APos);
AliasDef := TTypeAliasDef.Create();
AliasDef.TypeName := Payload;
AliasDef.IsSubrange := ReadLpstrAt(AText, APos) = '1';
AliasDef.SubrangeLow := ReadInt64At(AText, APos);
AliasDef.SubrangeHigh := ReadInt64At(AText, APos);
Entry.Def := AliasDef;
end
else if Kind = 'record' then

86
compiler/src/main/pascal/uUnitLoader.pas
View file

@ -60,8 +60,7 @@ type
private
FSearchPaths: TStringList; { not owned }
FDefines: TStringList; { not owned — conditional symbols for each unit's lexer }
FLoading: TStringList; { units currently on the load stack (any edge) — guards re-entry / infinite recursion }
FIfaceChain: TStringList; { units reached along an unbroken chain of interface-section uses — a back-edge into this set is a true circular dependency. Implementation-section uses do NOT extend this chain (Pascal allows them to point back), so following one starts a fresh chain. }
FLoading: TStringList; { units currently on the load stack — cycle detection }
FLoadedNames: TStringList; { units already fully loaded }
FSourceLoadedNames: TStringList; { units taken via the SOURCE-recompile
path (stale cache or no cache). A
@ -103,15 +102,6 @@ type
implementation
{ True if ASym is one of the OS conditional-compilation symbols (the target's
OS define, injected by the driver, replaces the lexer's host-seeded ones). }
function DefineIsOS(const ASym: string): Boolean;
begin
Result := SameText(ASym, 'LINUX') or SameText(ASym, 'FREEBSD') or
SameText(ASym, 'WINDOWS') or SameText(ASym, 'DARWIN') or
SameText(ASym, 'UNIX');
end;
function TUnitLoader.IsBuiltin(const AName: string): Boolean;
begin
Result :=
@ -249,27 +239,16 @@ var
L: TLexer;
P: TParser;
DI: Integer;
HasOS: Boolean;
begin
SL := TStringList.Create();
try
SL.LoadFromFile(APath);
L := TLexer.Create(SL.Text, APath);
{ Apply the same -d/--define symbols the main program got, so IFDEF
directives resolve consistently across the program and all its units.
If the set carries an OS symbol (the target's, injected by the driver),
drop the lexer's host-seeded OS symbols first so the target wins here too
— mirrors AddDefinesTo in Blaise.pas. }
directives resolve consistently across the program and all its units. }
if FDefines <> nil then
begin
HasOS := False;
for DI := 0 to FDefines.Count - 1 do
if DefineIsOS(FDefines.Strings[DI]) then HasOS := True;
if HasOS then
L.ClearOSDefines();
for DI := 0 to FDefines.Count - 1 do
L.AddDefine(FDefines.Strings[DI]);
end;
try
P := TParser.Create(L);
try
@ -330,29 +309,18 @@ end;
procedure TUnitLoader.LoadTransitive(const AName: string);
var
Path: string;
ObjPath: string;
Iface: TUnitInterface;
U: TUnit;
I: Integer;
SavedChain: TStringList;
Path: string;
ObjPath: string;
Iface: TUnitInterface;
U: TUnit;
I: Integer;
begin
if IsBuiltin(AName) then Exit;
if FLoadedNames.IndexOf(AName) >= 0 then Exit; { already in result list }
if FLoading.IndexOf(AName) >= 0 then
begin
{ Already on the load stack. This is a true circular dependency only when
the back-edge closes a chain of interface-section uses (those cannot be
satisfied — each unit's interface needs the other's first). A back-edge
reached through an implementation-section use is legal in Pascal, so it
is simply skipped: the unit is already being loaded higher up the stack
and its interface will be available by the time bodies are compiled. }
if FIfaceChain.IndexOf(AName) >= 0 then
raise ECircularDependency.Create(Format(
'Circular unit dependency: ''%s''', [AName]));
Exit;
end;
raise ECircularDependency.Create(Format(
'Circular unit dependency: ''%s''', [AName]));
{ Auto-discovery: prefer a pre-built '<name>.o' on the search path
when it carries an embedded iface section. The .o + embedded
@ -380,10 +348,7 @@ begin
if Iface <> nil then
begin
FLoading.Add(AName);
FIfaceChain.Add(AName);
try
{ A prebuilt .bif carries only interface-section uses, so these all
extend the interface chain. }
for I := 0 to Iface.UsedUnits.Count - 1 do
LoadTransitive(Iface.UsedUnits.Strings[I]);
{ Staleness propagation: if any interface-use dependency was taken via
@ -420,7 +385,6 @@ begin
end;
finally
FLoading.Delete(FLoading.IndexOf(AName));
FIfaceChain.Delete(FIfaceChain.IndexOf(AName));
end;
if Iface <> nil then
Exit; { cached path taken — done. Otherwise fall through to source. }
@ -433,33 +397,17 @@ begin
'Unit ''%s'' not found in search paths', [AName]));
FLoading.Add(AName);
FIfaceChain.Add(AName);
U := nil;
try
U := LoadOne(Path);
{ Post-order DFS: process dependencies before this unit. Both interface-
and implementation-section uses are loaded — the parser splits them into
separate lists.
Interface-section uses extend the interface chain, so a loop among them
is reported as a circular dependency. Implementation-section uses are
traversed with a FRESH interface chain: Pascal permits a unit's
implementation to use a unit whose interface (transitively) uses it
back, and that is not a real cycle (interfaces compile first, bodies
after). A back-edge into a unit still on the load stack is then
tolerated by the guard at the top of this routine. }
{ Post-order DFS: process dependencies before this unit.
Both interface- and implementation-section uses are loaded —
they are stored on separate lists since the parser was
taught to split them, but the loader still needs both. }
for I := 0 to U.UsedUnits.Count - 1 do
LoadTransitive(U.UsedUnits.Strings[I]);
SavedChain := FIfaceChain;
FIfaceChain := TStringList.Create();
FIfaceChain.CaseSensitive := False;
try
for I := 0 to U.ImplUsedUnits.Count - 1 do
LoadTransitive(U.ImplUsedUnits.Strings[I]);
finally
FIfaceChain.Free();
FIfaceChain := SavedChain;
end;
for I := 0 to U.ImplUsedUnits.Count - 1 do
LoadTransitive(U.ImplUsedUnits.Strings[I]);
{ Append this unit after all its dependencies }
FResult.Add(U);
FLoadedNames.Add(AName);
@ -472,7 +420,6 @@ begin
finally
U.Free(); { no-op if U = nil (success path) or on error }
FLoading.Delete(FLoading.IndexOf(AName));
FIfaceChain.Delete(FIfaceChain.IndexOf(AName));
end;
end;
@ -484,8 +431,6 @@ begin
FDefines := ADefines;
FLoading := TStringList.Create();
FLoading.CaseSensitive := False;
FIfaceChain := TStringList.Create();
FIfaceChain.CaseSensitive := False;
FLoadedNames := TStringList.Create();
FLoadedNames.CaseSensitive := False;
FSourceLoadedNames := TStringList.Create();
@ -507,7 +452,6 @@ begin
FPrebuiltIfaces.Free();
FSourceLoadedNames.Free();
FLoadedNames.Free();
FIfaceChain.Free();
FLoading.Free();
inherited Destroy();
end;

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

@ -122,9 +122,6 @@ uses
cp.test.proctypes,
cp.test.overload,
cp.test.classof,
cp.test.staticmembers,
cp.test.e2e.staticmembers,
cp.test.visibility,
cp.test.publishedrtti,
cp.test.attributes,
cp.test.proctypes_ofobject,
@ -133,8 +130,6 @@ uses
cp.test.strutils,
cp.test.e2e.strutils,
cp.test.toolchain,
cp.test.targettoolkit,
cp.test.platformlayout.freebsd,
cp.test.dynarray,
cp.test.math,
cp.test.e2e.math,

16
compiler/src/test/pascal/cp.test.arc.pas
View file

@ -687,7 +687,7 @@ begin
f := TFoo.Create()
end;
begin
DoIt()
DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@ -725,7 +725,7 @@ begin
f := TFoo.Create()
end;
begin
DoIt()
DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@ -759,7 +759,7 @@ begin
f := TFoo.Create()
end;
begin
DoIt()
DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@ -800,7 +800,7 @@ begin
F := TFoo(P)
end;
begin
DoIt()
DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@ -832,7 +832,7 @@ const
r := Make()
end;
begin
Run()
Run
end.
''';
@ -848,7 +848,7 @@ const
b := a
end;
begin
Run()
Run
end.
''';
@ -868,7 +868,7 @@ const
r := Make()
end;
begin
Run()
Run
end.
''';
@ -883,7 +883,7 @@ const
b := a
end;
begin
Run()
Run
end.
''';

411
compiler/src/test/pascal/cp.test.assembler.pas
View file

@ -36,18 +36,6 @@ type
procedure TestErrorMessage_HasLineNumber;
procedure TestMovqXmmToReg_SseEncoding;
procedure TestMovqRegToXmm_SseEncoding;
procedure TestNegl_F7Slash3;
procedure TestLockXaddl_AtomicEncoding;
procedure TestUnsuffixedMov_InfersSize;
procedure TestJmpIndirectMem_FFSlash4;
procedure TestEndbr64AndHlt;
procedure TestSyscall_0F05;
procedure TestCallPltStripsSuffix;
procedure TestSse2_PxorAndPabsb;
procedure TestVex_Vpxor2byte;
procedure TestVex_Vpabsb3byte;
procedure TestVex_VextractI128;
procedure TestSibWhitespaceTolerated;
end;
{ ---- ELF writer unit tests ---- }
@ -83,6 +71,7 @@ type
FCompiler: string;
FRTLPath: string;
FStdlibPath: string;
FRTL: string;
FScratch: string;
FCounter: Integer;
function ProjectRoot: string;
@ -92,9 +81,6 @@ type
function RunProcNoArgs(const AExe: string; out AStdout: string): Integer;
function CompileAndRun(const ASrc: string;
out AStdout: string; out AExitCode: Integer): Boolean;
function CompileAndRunArgs(const ASrc: string;
const AArgs: array of string;
out AStdout: string; out AExitCode: Integer): Boolean;
protected
procedure SetUp; override;
published
@ -111,23 +97,6 @@ type
procedure TestClassVirtualCall;
procedure TestFloatArithmetic;
procedure TestFormatFloatArg;
{ Self-contained program entry (issue #142): the runtime supplies its own
_start (blaise_start_x86_64.s) so the internal linker needs no system
Scrt1.o / crtbegin / crtend. These assert the two things _start owns —
argc/argv forwarding and exit-code propagation through __libc_start_main. }
procedure TestEntry_ExitCodePropagates;
procedure TestEntry_ArgsForwarded;
{ Inline assembler blocks (asm ... end): a nostackframe asm-body function is
assembled verbatim by the internal assembler and called from Pascal. }
procedure TestInlineAsm_ReturnsValue;
procedure TestInlineAsm_AddsTwoArgs;
{ --debug-opdf appends the OPDF section to the SAME assembly text the
internal assembler consumes. A string constant whose value contains a
double-quote or newline used to break the recConstant `.ascii "<val>"`
line (the raw value closed the literal early), aborting the assemble.
Escaping the value fixes it; this compiles+runs such a program under
--debug-opdf --assembler internal. }
procedure TestDebugOPDF_StringConstSpecialChars_AssemblesAndRuns;
end;
implementation
@ -138,14 +107,6 @@ implementation
var
GInternalAsmSkipNoted: Boolean = False;
{ Validity-probe cache for the fallback compiler — see the matching note in
cp.test.cli.pas. The /tmp/fp_blaise2 fallback is a transient fixpoint
artifact that is often stale; a stale binary turns these e2e tests into a
cascade of cryptic failures. Probe once and skip (not fail) on a bad probe.
0 = not probed, 1 = good, 2 = bad. }
var
GInternalAsmProbeState: Integer = 0;
{ ---- TAsmEncodingTests ---- }
function TAsmEncodingTests.ContainsBytes(const ABuf, APat: string): Boolean;
@ -174,147 +135,6 @@ begin
ContainsBytes(Obj, Chr($48) + Chr($8B) + Chr($07)));
end;
procedure TAsmEncodingTests.TestNegl_F7Slash3;
var
Obj: string;
begin
{ negl %esi -> f7 de (F7 /3, reg=esi=6). Verified vs `cc`. }
Obj := AssembleToBytes('negl %esi' + LineEnding);
AssertTrue('f7 de missing',
ContainsBytes(Obj, Chr($F7) + Chr($DE)));
end;
procedure TAsmEncodingTests.TestLockXaddl_AtomicEncoding;
var
Obj: string;
begin
{ lock xaddl %eax, (%rdi) -> f0 0f c1 07. The atomic RTL primitive
(_AtomicAddInt32). f0 = lock prefix, 0f c1 = xadd, 07 = ModRM
(reg=eax=0, r/m=[rdi]). Verified vs `cc`. }
Obj := AssembleToBytes('lock xaddl %eax, (%rdi)' + LineEnding);
AssertTrue('f0 0f c1 07 missing',
ContainsBytes(Obj, Chr($F0) + Chr($0F) + Chr($C1) + Chr($07)));
end;
procedure TAsmEncodingTests.TestUnsuffixedMov_InfersSize;
var
Obj: string;
begin
{ Unsuffixed AT&T mnemonics infer size from the register operand.
mov %rbx, (%rdi) is 64-bit -> 48 89 1f (same as movq). Verified vs cc. }
Obj := AssembleToBytes('mov %rbx, (%rdi)' + LineEnding);
AssertTrue('48 89 1f missing (mov inferred q)',
ContainsBytes(Obj, Chr($48) + Chr($89) + Chr($1F)));
{ xor %eax, %eax is 32-bit -> 31 c0 (no REX.W). }
Obj := AssembleToBytes('xor %eax, %eax' + LineEnding);
AssertTrue('31 c0 missing (xor inferred l)',
ContainsBytes(Obj, Chr($31) + Chr($C0)));
end;
procedure TAsmEncodingTests.TestJmpIndirectMem_FFSlash4;
var
Obj: string;
begin
{ jmp *56(%rdi) -> ff 67 38 (FF /4, memory-indirect). The longjmp tail. }
Obj := AssembleToBytes('jmp *56(%rdi)' + LineEnding);
AssertTrue('ff 67 38 missing',
ContainsBytes(Obj, Chr($FF) + Chr($67) + Chr($38)));
end;
procedure TAsmEncodingTests.TestEndbr64AndHlt;
var
Obj: string;
begin
{ endbr64 -> f3 0f 1e fa ; hlt -> f4 }
Obj := AssembleToBytes('endbr64' + LineEnding);
AssertTrue('f3 0f 1e fa missing',
ContainsBytes(Obj, Chr($F3) + Chr($0F) + Chr($1E) + Chr($FA)));
Obj := AssembleToBytes('hlt' + LineEnding);
AssertTrue('f4 missing', ContainsBytes(Obj, Chr($F4)));
end;
procedure TAsmEncodingTests.TestSyscall_0F05;
var
Obj: string;
begin
{ syscall -> 0f 05 (needed for the FreeBSD direct-syscall stubs). }
Obj := AssembleToBytes('syscall' + LineEnding);
AssertTrue('0f 05 missing', ContainsBytes(Obj, Chr($0F) + Chr($05)));
end;
procedure TAsmEncodingTests.TestCallPltStripsSuffix;
var
Obj: string;
begin
{ call foo@PLT must reference symbol 'foo' (with a PLT32 reloc), NOT a bogus
symbol literally named 'foo@PLT' that no loader resolves. The @PLT suffix
is a relocation qualifier, not part of the name. Regression for the
_start migration (call __libc_start_main@PLT). }
Obj := AssembleToBytes('call foo@PLT' + LineEnding);
AssertTrue('symbol foo missing', ContainsBytes(Obj, 'foo'));
AssertTrue('bogus foo@PLT symbol present',
not ContainsBytes(Obj, 'foo@PLT'));
end;
procedure TAsmEncodingTests.TestSse2_PxorAndPabsb;
var
Obj: string;
begin
{ pxor %xmm3,%xmm3 -> 66 0f ef db ; pabsb is a 3-byte 0F38 op:
pabsb %xmm2,%xmm2 -> 66 0f 38 1c d2. Verified vs cc. }
Obj := AssembleToBytes('pxor %xmm3, %xmm3' + LineEnding);
AssertTrue('66 0f ef db missing',
ContainsBytes(Obj, Chr($66) + Chr($0F) + Chr($EF) + Chr($DB)));
Obj := AssembleToBytes('pabsb %xmm2, %xmm2' + LineEnding);
AssertTrue('66 0f 38 1c d2 missing',
ContainsBytes(Obj, Chr($66) + Chr($0F) + Chr($38) + Chr($1C) + Chr($D2)));
end;
procedure TAsmEncodingTests.TestVex_Vpxor2byte;
var
Obj: string;
begin
{ vpxor %ymm3,%ymm3,%ymm3 -> c5 e5 ef db (2-byte VEX). Verified vs cc. }
Obj := AssembleToBytes('vpxor %ymm3, %ymm3, %ymm3' + LineEnding);
AssertTrue('c5 e5 ef db missing',
ContainsBytes(Obj, Chr($C5) + Chr($E5) + Chr($EF) + Chr($DB)));
end;
procedure TAsmEncodingTests.TestVex_Vpabsb3byte;
var
Obj: string;
begin
{ vpabsb %ymm2,%ymm2 -> c4 e2 7d 1c d2 (3-byte VEX, 0F38 map). Verified vs cc. }
Obj := AssembleToBytes('vpabsb %ymm2, %ymm2' + LineEnding);
AssertTrue('c4 e2 7d 1c d2 missing',
ContainsBytes(Obj, Chr($C4) + Chr($E2) + Chr($7D) + Chr($1C) + Chr($D2)));
end;
procedure TAsmEncodingTests.TestVex_VextractI128;
var
Obj: string;
begin
{ vextracti128 $1,%ymm3,%xmm4 -> c4 e3 7d 39 dc 01 (L=1 despite xmm dst).
Verified vs cc. }
Obj := AssembleToBytes('vextracti128 $1, %ymm3, %xmm4' + LineEnding);
AssertTrue('c4 e3 7d 39 dc 01 missing',
ContainsBytes(Obj, Chr($C4) + Chr($E3) + Chr($7D) + Chr($39) + Chr($DC) + Chr($01)));
end;
procedure TAsmEncodingTests.TestSibWhitespaceTolerated;
var
A, B: string;
begin
{ GNU as allows whitespace after the SIB comma: `(%rdi, %rdx)` must encode
identically to `(%rdi,%rdx)` (movdqu -> f3 0f 6f 04 17). }
A := AssembleToBytes('movdqu (%rdi,%rdx), %xmm0' + LineEnding);
B := AssembleToBytes('movdqu (%rdi, %rdx), %xmm0' + LineEnding);
AssertTrue('f3 0f 6f 04 17 missing (no space)',
ContainsBytes(A, Chr($F3) + Chr($0F) + Chr($6F) + Chr($04) + Chr($17)));
AssertTrue('f3 0f 6f 04 17 missing (with space)',
ContainsBytes(B, Chr($F3) + Chr($0F) + Chr($6F) + Chr($04) + Chr($17)));
end;
procedure TAsmEncodingTests.TestQuadSymbol_EmitsReloc;
var
Obj: string;
@ -756,56 +576,24 @@ begin
FCompiler := '/tmp/fp_blaise2';
if not FileExists(FCompiler) then
FCompiler := '/tmp/fp_blaise3';
FRTLPath := ProjectRoot() + 'compiler/src/main/pascal';
FRTLPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibPath := ProjectRoot() + 'stdlib/src/main/pascal';
FRTL := ProjectRoot() + 'compiler/target/blaise_rtl.a';
FScratch := ProjectRoot() + 'compiler/target/asm_scratch/';
ForceDirectories(FScratch);
FCounter := 0;
end;
function TInternalAsmE2ETests.CompilerAvailable: Boolean;
var
SrcFile, OutFile, CompOut, RunOut: string;
Rc: Integer;
begin
{ The compiler binary source-builds the RTL itself (no blaise_rtl.a); only
the binary and the RTL source need to be present. }
Result := FileExists(FCompiler)
and FileExists(FRTLPath + '/runtime.arc.pas');
Result := FileExists(FCompiler) and FileExists(FRTL);
if (not Result) and (not GInternalAsmSkipNoted) then
begin
GInternalAsmSkipNoted := True;
WriteLn(StdErr, 'note: TInternalAsmE2ETests skipped — compiler binary "',
FCompiler, '" or RTL source not found ',
FCompiler, '" or RTL "', FRTL, '" not found ',
'(set BLAISE_QBE_COMPILER to a QBE-backend blaise binary to run them)');
Exit;
end;
if not Result then Exit;
{ Validity probe: compile+run a trivial program with --assembler internal.
A stale fallback binary compiles fine but produces a SIGILL/wrong-output
executable; detect that here and skip rather than emit a cryptic cascade. }
if GInternalAsmProbeState = 0 then
begin
SrcFile := FScratch + 'probe.pas';
OutFile := FScratch + 'probe';
WriteFile(SrcFile, 'program p; begin WriteLn(42); end.');
Rc := Self.RunProc(FCompiler, [
'--source', SrcFile, '--unit-path', FRTLPath, '--unit-path', FStdlibPath,
'--output', OutFile, '--backend', 'native', '--assembler', 'internal'
], CompOut);
if (Rc = 0) and (Self.RunProcNoArgs(OutFile, RunOut) = 0)
and (Pos('42', RunOut) >= 0) then
GInternalAsmProbeState := 1
else
begin
GInternalAsmProbeState := 2;
WriteLn(StdErr, 'note: TInternalAsmE2ETests skipped — compiler binary "',
FCompiler, '" is stale/broken (probe program did not run); ',
'rebuild it or set BLAISE_QBE_COMPILER to a current binary.');
end;
end;
Result := GInternalAsmProbeState = 1;
end;
function TInternalAsmE2ETests.RunProc(const AExe: string;
@ -887,39 +675,6 @@ begin
Result := True;
end;
{ Like CompileAndRun but runs the produced binary WITH command-line arguments,
so argc/argv forwarding through the runtime's own _start is exercised. }
function TInternalAsmE2ETests.CompileAndRunArgs(const ASrc: string;
const AArgs: array of string;
out AStdout: string; out AExitCode: Integer): Boolean;
var
SrcFile, OutFile, CompOut: string;
Rc: Integer;
begin
Result := False;
if not Self.CompilerAvailable() then Exit;
FCounter := FCounter + 1;
SrcFile := FScratch + 'test_asm_' + IntToStr(FCounter) + '.pas';
OutFile := FScratch + 'test_asm_' + IntToStr(FCounter);
WriteFile(SrcFile, ASrc);
Rc := Self.RunProc(FCompiler, [
'--source', SrcFile,
'--unit-path', FRTLPath,
'--unit-path', FStdlibPath,
'--output', OutFile,
'--backend', 'native',
'--assembler', 'internal'
], CompOut);
if Rc <> 0 then
Fail('compile failed (rc=' + IntToStr(Rc) + '): ' + CompOut);
AExitCode := Self.RunProc(OutFile, AArgs, AStdout);
Result := True;
end;
{ ---- Test methods ---- }
procedure TInternalAsmE2ETests.TestSimpleAdd;
@ -971,7 +726,7 @@ begin
'begin' + LineEnding +
' for I := 1 to 5 do' + LineEnding +
' Write(I);' + LineEnding +
' WriteLn()' + LineEnding +
' WriteLn' + LineEnding +
'end.',
Out_, EC) then
begin
@ -1044,7 +799,7 @@ begin
' Write(N);' + LineEnding +
' N := N + 1' + LineEnding +
' end;' + LineEnding +
' WriteLn()' + LineEnding +
' WriteLn' + LineEnding +
'end.',
Out_, EC) then
begin
@ -1170,7 +925,7 @@ begin
'begin' + LineEnding +
' G := TGreeter.Create;' + LineEnding +
' WriteLn(G.Greet());' + LineEnding +
' G.Free()' + LineEnding +
' G.Free' + LineEnding +
'end.',
Out_, EC) then
begin
@ -1234,156 +989,6 @@ begin
AssertEquals('1.2500' + LineEnding, Out_);
end;
procedure TInternalAsmE2ETests.TestEntry_ExitCodePropagates;
var
Out_: string;
EC: Integer;
begin
{ Halt(N): the runtime's own _start calls __libc_start_main(main, ...) and
glibc exits with main's return value. A broken entry sequence would crash
at startup or return the wrong code. No system Scrt1.o is involved. }
if not CompileAndRun(
'program test_exit;' + LineEnding +
'begin' + LineEnding +
' WriteLn(''before'');' + LineEnding +
' Halt(7)' + LineEnding +
'end.',
Out_, EC) then
begin
Ignore('<toolchain-missing>');
Exit;
end;
AssertEquals(7, EC);
AssertEquals('before' + LineEnding, Out_);
end;
procedure TInternalAsmE2ETests.TestEntry_ArgsForwarded;
var
Out_: string;
EC: Integer;
begin
{ argc/argv reach the program through _start -> __libc_start_main -> main ->
_SetArgs. ParamStr(0) is the program path; the passed args follow. }
if not CompileAndRunArgs(
'program test_args;' + LineEnding +
'begin' + LineEnding +
' WriteLn(ParamCount());' + LineEnding +
' WriteLn(ParamStr(1));' + LineEnding +
' WriteLn(ParamStr(2))' + LineEnding +
'end.',
['alpha', 'beta'], Out_, EC) then
begin
Ignore('<toolchain-missing>');
Exit;
end;
AssertEquals(0, EC);
AssertEquals('2' + LineEnding + 'alpha' + LineEnding + 'beta' + LineEnding, Out_);
end;
procedure TInternalAsmE2ETests.TestInlineAsm_ReturnsValue;
var
Out_: string;
EC: Integer;
begin
{ A nostackframe asm-body function returns 42 in %eax; the internal assembler
assembles the verbatim block, and Pascal calls it normally. }
if not CompileAndRun(
'program test_asmret;' + LineEnding +
'function GetFortyTwo: Integer; assembler; nostackframe;' + LineEnding +
'asm' + LineEnding +
' movl $42, %eax' + LineEnding +
' ret' + LineEnding +
'end;' + LineEnding +
'begin' + LineEnding +
' WriteLn(GetFortyTwo())' + LineEnding +
'end.',
Out_, EC) then
begin
Ignore('<toolchain-missing>');
Exit;
end;
AssertEquals(0, EC);
AssertEquals('42' + LineEnding, Out_);
end;
procedure TInternalAsmE2ETests.TestInlineAsm_AddsTwoArgs;
var
Out_: string;
EC: Integer;
begin
{ Two integer args arrive in %edi/%esi (SysV); the asm body sums them. Proves
a nostackframe asm function reads its parameters from the arg registers. }
if not CompileAndRun(
'program test_asmadd;' + LineEnding +
'function AddTwo(A, B: Integer): Integer; assembler; nostackframe;' + LineEnding +
'asm' + LineEnding +
' movl %edi, %eax' + LineEnding +
' addl %esi, %eax' + LineEnding +
' ret' + LineEnding +
'end;' + LineEnding +
'begin' + LineEnding +
' WriteLn(AddTwo(40, 2))' + LineEnding +
'end.',
Out_, EC) then
begin
Ignore('<toolchain-missing>');
Exit;
end;
AssertEquals(0, EC);
AssertEquals('42' + LineEnding, Out_);
end;
procedure TInternalAsmE2ETests.TestDebugOPDF_StringConstSpecialChars_AssemblesAndRuns;
var
SrcFile, OutFile, CompOut, RunOut: string;
Rc, EC: Integer;
Src: string;
begin
if not Self.CompilerAvailable() then
begin
Ignore('<toolchain-missing>');
Exit;
end;
{ A double-quote, a newline and a backslash in string-constant VALUES — each
would break the recConstant `.ascii` line if emitted unescaped. }
Src :=
'program test_opdf_qc;' + LineEnding +
'const' + LineEnding +
' Q = ' + '''' + '"' + '''' + ';' + LineEnding +
' NL = ' + '''' + 'a' + '''' + '#10' + '''' + 'b' + '''' + ';' + LineEnding +
' BS = ' + '''' + 'a\b' + '''' + ';' + LineEnding +
'begin' + LineEnding +
' WriteLn(Q);' + LineEnding +
' WriteLn(NL);' + LineEnding +
' WriteLn(BS)' + LineEnding +
'end.';
FCounter := FCounter + 1;
SrcFile := FScratch + 'test_opdf_' + IntToStr(FCounter) + '.pas';
OutFile := FScratch + 'test_opdf_' + IntToStr(FCounter);
WriteFile(SrcFile, Src);
Rc := Self.RunProc(FCompiler, [
'--source', SrcFile,
'--unit-path', FRTLPath,
'--unit-path', FStdlibPath,
'--output', OutFile,
'--backend', 'native',
'--assembler', 'internal',
'--debug-opdf'
], CompOut);
{ The bug manifested as an "Internal assembler error: ... unhandled mnemonic"
from the mangled .ascii line — a non-zero compile with that text. }
if Rc <> 0 then
Fail('compile under --debug-opdf failed (rc=' + IntToStr(Rc) + '): ' + CompOut);
EC := Self.RunProcNoArgs(OutFile, RunOut);
AssertEquals(0, EC);
AssertEquals('"' + LineEnding + 'a' + LineEnding + 'b' + LineEnding +
'a\b' + LineEnding, RunOut);
end;
{ ---- Registration ---- }
initialization

10
compiler/src/test/pascal/cp.test.attributes.pas
View file

@ -20,8 +20,7 @@ interface
uses
Classes, SysUtils, Process, blaise.testing,
uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe,
cp.test.rtllink;
uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe;
function ProjectRootAttr: string;
function RunCmdAttr(const AExe: string; const AArgs: array of string): Integer;
@ -155,7 +154,7 @@ function TCustomAttributeTests.CompileAndRun(const ASrc: string): string;
var
IR: string;
Root: string;
QBE, Scratch: string;
QBE, RTL, Scratch: string;
IRFile, AsmFile, BinFile: string;
Lst: TStringList;
Proc: TProcess;
@ -164,7 +163,8 @@ begin
Result := '';
Root := ProjectRootAttr();
QBE := Root + 'vendor/qbe/qbe';
if not RTLLinkToolchainAvailable(Root) then
RTL := Root + 'compiler/target/blaise_rtl.a';
if not (FileExists(QBE) and FileExists(RTL)) then
begin
Result := '<toolchain-missing>';
Exit;
@ -190,7 +190,7 @@ begin
Exit;
end;
if LinkProgramWithRTL(Root, AsmFile, BinFile) <> 0 then
if RunCmdAttr('cc', ['-o', BinFile, AsmFile, RTL]) <> 0 then
begin
Result := '<link-failed>';
Exit;

2
compiler/src/test/pascal/cp.test.bif_coverage.pas
View file

@ -102,7 +102,7 @@ begin
Proc.WaitOnExit();
Code := Proc.ExitCode
finally
Proc.Free()
Proc.Free
end;
if Code <> 0 then

375
compiler/src/test/pascal/cp.test.caseenum.pas
View file

@ -23,8 +23,6 @@ type
function GenIR(const ASrc: string): string;
procedure SemanticOK(const ASrc: string);
procedure ParseOK(const ASrc: string);
{ Analyse ASrc; return the raised semantic-error message, or '' if none. }
function SemanticErrText(const ASrc: string): string;
published
{ ------------------------------------------------------------------ }
{ case — parse }
@ -63,21 +61,6 @@ type
{ ------------------------------------------------------------------ }
procedure TestCodegen_Enum_MemberEmitsIntegerCopy;
procedure TestCodegen_Enum_AssignEmitsStore;
procedure TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal;
procedure TestSemantic_ScopedEnum_UnknownMemberRejected;
procedure TestSemantic_ScopedEnum_SharedMemberCompiles;
procedure TestSemantic_ScopedEnum_AssignmentDisambiguates;
procedure TestSemantic_ScopedEnum_CaseDisambiguates;
procedure TestSemantic_ScopedEnum_SetElementDisambiguates;
procedure TestSemantic_ScopedEnum_AmbiguousBareRejected;
procedure TestSemantic_ScopedEnum_UniqueBareResolves;
procedure TestSemantic_ScopedEnum_CallArgDisambiguates;
procedure TestSemantic_ScopedEnum_CallArgResolvesCleanly;
procedure TestSemantic_ScopedEnum_FieldAssignDisambiguates;
procedure TestCodegen_ScopedEnum_FieldAssignEmitsCorrectOrdinal;
procedure TestSemantic_ScopedEnum_MethodArgDisambiguates;
procedure TestCodegen_ScopedEnum_CallArgEmitsCorrectOrdinal;
procedure TestSemantic_ScopedEnum_ForBoundsDisambiguate;
{ ------------------------------------------------------------------ }
{ enum + case integration }
@ -262,31 +245,6 @@ begin
end;
end;
function TCaseEnumTests.SemanticErrText(const ASrc: string): string;
var
Lex: TLexer;
Par: TParser;
SA: TSemanticAnalyser;
Prog: TProgram;
begin
Result := '';
Lex := TLexer.Create(ASrc);
Par := TParser.Create(Lex);
Prog := Par.Parse();
Par.Free(); Lex.Free();
SA := TSemanticAnalyser.Create();
try
try
SA.Analyse(Prog);
except
on E: Exception do Result := E.Message;
end;
finally
SA.Free();
Prog.Free();
end;
end;
{ ------------------------------------------------------------------ }
{ case — parse }
{ ------------------------------------------------------------------ }
@ -618,339 +576,6 @@ begin
Pos('_StringEquals', IR) < 0);
end;
procedure TCaseEnumTests.TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal;
const
Src =
'''
program P;
type TDir = (dN, dE, dS, dW);
var x: Integer;
begin
x := Ord(TDir.dS)
end.
''';
var
IR: string;
begin
IR := GenIR(Src);
{ TDir.dS is the third member (ordinal 2); the type-qualified reference must
resolve to that member and emit copy 2, exactly as the bare dS would. }
AssertTrue('TDir.dS emits copy 2', Pos('copy 2', IR) > 0);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_UnknownMemberRejected;
const
Src =
'''
program P;
type TDir = (dN, dE, dS, dW);
var x: Integer;
begin
x := Ord(TDir.dNope)
end.
''';
var
Raised: Boolean;
begin
Raised := False;
try
SemanticOK(Src);
except
on E: Exception do Raised := True;
end;
AssertTrue('unknown enum member via TEnum.Member rejected', Raised);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_SharedMemberCompiles;
const
{ Two enums in one unit both declare 'Red'. Members are no longer bare
global symbols, so this is NOT a collision — each is reachable through its
own type, and the program compiles cleanly. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
begin
WriteLn(Ord(TColorA.Red));
WriteLn(Ord(TColorB.Red))
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_AssignmentDisambiguates;
const
{ 'Red' belongs to both enums; the assignment target type selects which one,
so BOTH assignments type-check (a fallback-only resolver would mis-type one). }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
var
a: TColorA;
b: TColorB;
begin
a := Red;
b := Red;
WriteLn(Ord(a) + Ord(b))
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_CaseDisambiguates;
const
{ The case selector's type picks the enum for a bare, shared member label. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
var
b: TColorB;
begin
b := Blue;
case b of
Red: WriteLn(1);
Blue: WriteLn(2)
end
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_SetElementDisambiguates;
const
{ The set's element type picks the enum for a bare, shared member element. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
var
s: set of TColorA;
begin
s := [Red, Green];
if Red in s then WriteLn(1)
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_AmbiguousBareRejected;
const
{ A bare, context-free reference to a member shared by two enums cannot be
resolved: it is rejected with an error that names the member and lists the
enums that declare it. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
begin
WriteLn(Ord(Red))
end.
''';
var
E: string;
begin
E := SemanticErrText(Src);
AssertTrue('the ambiguous bare member is rejected', E <> '');
AssertTrue('error names the ambiguous member', Pos('''Red''', E) >= 0);
AssertTrue('error names the first declaring enum', Pos('TColorA', E) >= 0);
AssertTrue('error names the second declaring enum', Pos('TColorB', E) >= 0);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_UniqueBareResolves;
const
{ A bare member unique across all enums needs no context and resolves
cleanly with no error. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Cyan, Blue);
begin
WriteLn(Ord(Green))
end.
''';
begin
AssertEquals('unique bare member resolves with no error', '',
SemanticErrText(Src));
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_CallArgDisambiguates;
const
{ 'Red' is shared; a bare member passed as a call argument is steered to the
enum the routine expects at that position, so both calls type-check. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
procedure TakeA(c: TColorA);
begin WriteLn(Ord(c)) end;
procedure TakeB(c: TColorB);
begin WriteLn(Ord(c)) end;
begin
TakeA(Red);
TakeB(Red)
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_CallArgResolvesCleanly;
const
{ A shared member resolved by the call target's parameter type is NOT
ambiguous — the hint pins it before bottom-up analysis, so no error. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
procedure TakeA(c: TColorA);
begin WriteLn(Ord(c)) end;
begin
TakeA(Red)
end.
''';
begin
AssertEquals('call-arg hint resolves with no error', '',
SemanticErrText(Src));
end;
procedure TCaseEnumTests.TestCodegen_ScopedEnum_CallArgEmitsCorrectOrdinal;
const
{ Red is ordinal 0 in TColorA but ordinal 1 in TColorB; the call target's
parameter type must select TColorB.Red so the argument lowers to copy 1. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red);
procedure TakeB(c: TColorB);
begin WriteLn(Ord(c)) end;
begin
TakeB(Red)
end.
''';
var
IR: string;
begin
IR := GenIR(Src);
AssertTrue('TakeB(Red) selects TColorB.Red and emits copy 1',
Pos('copy 1', IR) > 0);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_FieldAssignDisambiguates;
const
{ Assigning a bare shared member to a record field is disambiguated by the
field's declared enum type — the same context that lets the compiler's own
'Result.Kind := tkAs' resolve when tkAs is shared by two enums. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
TRec = record c: TColorB; end;
var r: TRec;
begin
r.c := Red;
WriteLn(Ord(r.c))
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestCodegen_ScopedEnum_FieldAssignEmitsCorrectOrdinal;
const
{ Red is ordinal 0 in TColorA but ordinal 1 in TColorB; the field's type
selects TColorB.Red, so the assignment lowers to copy 1. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red);
TRec = record c: TColorB; end;
var r: TRec;
begin
r.c := Red
end.
''';
var
IR: string;
begin
IR := GenIR(Src);
AssertTrue('r.c := Red selects TColorB.Red and emits copy 1',
Pos('copy 1', IR) > 0);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_MethodArgDisambiguates;
const
{ A bare shared member passed to a method argument is steered to the enum of
the method's parameter, resolved by walking the receiver's class. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
TFoo = class
procedure TakeB(c: TColorB);
end;
procedure TFoo.TakeB(c: TColorB);
begin WriteLn(Ord(c)) end;
var f: TFoo;
begin
f := TFoo.Create();
f.TakeB(Red);
f.Free()
end.
''';
begin
SemanticOK(Src);
end;
procedure TCaseEnumTests.TestSemantic_ScopedEnum_ForBoundsDisambiguate;
const
{ The loop variable's type picks the enum for bare, shared start/end bounds. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
var
b: TColorB;
begin
for b := Red to Blue do
WriteLn(Ord(b))
end.
''';
begin
SemanticOK(Src);
end;
initialization
RegisterTest(TCaseEnumTests);

124
compiler/src/test/pascal/cp.test.classes.pas
View file

@ -71,15 +71,6 @@ type
procedure TestCodegen_MethodCall_CaseInsensitive;
procedure TestCodegen_MethodBody_ReadsProgramGlobal;
{ ------------------------------------------------------------------ }
{ Forward class declarations (TFoo = class;) }
{ ------------------------------------------------------------------ }
procedure TestSemantic_ForwardClass_CompletedByFullDecl;
procedure TestSemantic_ForwardClass_MutualReference;
procedure TestSemantic_ForwardClass_Unresolved_RaisesError;
procedure TestSemantic_ForwardClass_DoubleForward_RaisesError;
procedure TestCodegen_ForwardClass_SingleVTable;
{ ------------------------------------------------------------------ }
{ Free built-in }
{ ------------------------------------------------------------------ }
@ -1189,121 +1180,6 @@ begin
end;
end;
{ ------------------------------------------------------------------ }
{ Forward class declarations }
{ ------------------------------------------------------------------ }
procedure TClassTests.TestSemantic_ForwardClass_CompletedByFullDecl;
var
Prog: TProgram;
begin
{ A bare `TFoo = class;` forward stub, completed by the full declaration
later in the same type section, must not be a duplicate-type error. }
Prog := AnalyseSrc(
'''
program P;
type
TFoo = class;
TFoo = class
X: Integer;
end;
begin
end.
''');
try
AssertTrue('forward class completed by full decl analyses OK', Prog <> nil);
finally
Prog.Free();
end;
end;
procedure TClassTests.TestSemantic_ForwardClass_MutualReference;
var
Prog: TProgram;
begin
{ The point of a forward decl: a class declared between the forward and the
full declaration can name the forward-declared type. }
Prog := AnalyseSrc(
'''
program P;
type
TFoo = class;
TBar = class
Foo: TFoo;
end;
TFoo = class
Bar: TBar;
end;
begin
end.
''');
try
AssertTrue('mutual class reference via forward decl analyses OK',
Prog <> nil);
finally
Prog.Free();
end;
end;
procedure TClassTests.TestSemantic_ForwardClass_Unresolved_RaisesError;
begin
{ A forward never completed in the scope is an error. }
AnalyseExpectError(
'''
program P;
type
TFoo = class;
begin
end.
''');
end;
procedure TClassTests.TestSemantic_ForwardClass_DoubleForward_RaisesError;
begin
{ The same type may be forward-declared only once. }
AnalyseExpectError(
'''
program P;
type
TFoo = class;
TFoo = class;
TFoo = class
X: Integer;
end;
begin
end.
''');
end;
procedure TClassTests.TestCodegen_ForwardClass_SingleVTable;
var
IR: string;
Count: Integer;
P: Integer;
begin
{ The forward stub is dropped after semantic analysis, so codegen must emit
the class's vtable exactly once — a second emission would be a duplicate
data symbol and fail to link. }
IR := GenIR(
'''
program P;
type
TFoo = class;
TFoo = class
X: Integer;
end;
begin
end.
''');
Count := 0;
P := 0;
repeat
P := PosEx('data $vtable_TFoo', IR, P);
if P >= 0 then begin Inc(Count); Inc(P) end;
until P < 0;
AssertEquals('vtable_TFoo emitted exactly once', 1, Count);
end;
initialization
RegisterTest(TClassTests);

38
compiler/src/test/pascal/cp.test.classof.pas
View file

@ -23,7 +23,6 @@ type
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
procedure AnalyseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
published
{ Parser }
procedure TestParse_ClassOf_AsAlias;
@ -57,11 +56,6 @@ type
procedure TestSemantic_MetaclassVar_Create_Accepted;
procedure TestCodegen_MetaclassVar_Create_IndirectCtor;
procedure TestCodegen_MetaclassVar_Create_NoCtor_NoIndirectCall;
{ Bare 'C.Create' (no parens) on a metaclass variable must give the
mandatory-parentheses diagnostic, not the misleading
'is not a record or class' error. }
procedure TestSemantic_MetaclassVar_BareCreate_RequiresParens;
end;
implementation
@ -119,20 +113,6 @@ begin
end;
end;
procedure TClassOfTests.AnalyseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
var Prog: TProgram;
begin
try
Prog := AnalyseSrc(ASrc);
Prog.Free();
Fail('Expected ESemanticError');
except
on E: ESemanticError do
AssertTrue('error message contains "' + AExpectedSubstr + '" (got: ' +
E.Message + ')', Pos(AExpectedSubstr, E.Message) >= 0);
end;
end;
{ ------------------------------------------------------------------ }
{ Parser }
{ ------------------------------------------------------------------ }
@ -568,24 +548,6 @@ begin
Pos('TFoo_Create', IR) < 0);
end;
procedure TClassOfTests.TestSemantic_MetaclassVar_BareCreate_RequiresParens;
const Src = '''
program P;
type
TFoo = class(TObject)
constructor Create;
end;
constructor TFoo.Create; begin end;
var C: class of TFoo; F: TFoo;
begin
C := TFoo;
F := C.Create
end.
''';
begin
AnalyseExpectErrorMsg(Src, 'requires () for a call');
end;
initialization
RegisterTest(TClassOfTests);
end.

154
compiler/src/test/pascal/cp.test.cli.pas
View file

@ -35,6 +35,7 @@ type
FCompiler: string;
FRTLPath: string;
FStdlibPath: string;
FRTL: string;
FScratch: string;
FCounter: Integer;
function ProjectRoot: string;
@ -75,22 +76,11 @@ type
procedure TestEmitAsm_WithExplicitQbeBackend_Rejected;
procedure TestEmitIr_WithoutBackend_StillWorks;
procedure TestEmitIr_WithExplicitQbeBackend_StillWorks;
{ ---- external 'lib' propagates a -l<name> to the real link command ---- }
{ A program declaring `external 'lib'` for a NON-EXISTENT library must fail
the link with the linker's "cannot find -l<lib>" — which only happens if
the driver actually emitted -l<lib>. The e2e harness can't test this (it
links with a hardcoded `cc ... -lm -lpthread` and never calls
LinkViaToolchain), so this drives the real compiler binary end to end. }
procedure TestExternalLib_MissingLib_FailsLink_QBE;
procedure TestExternalLib_MissingLib_FailsLink_Native;
{ ---- div/mod by zero raises a catchable EDivByZero (needs stdlib) ---- }
procedure TestDivByZeroCaught_QBE;
procedure TestDivByZeroCaught_Native;
procedure TestModByZeroCaught_QBE;
procedure TestModByZeroCaught_Native;
{ ---- a bare --output (no directory part) must not anchor per-unit
.o/.bif artefacts at the filesystem root ---- }
procedure TestBareOutput_UnitArtefacts_NotWrittenToRoot;
end;
implementation
@ -101,17 +91,6 @@ implementation
var
GCLISkipNoted: Boolean = False;
{ Validity-probe cache for the fallback compiler. The fallback path
(/tmp/fp_blaise2) is a transient fixpoint artifact that is frequently STALE —
built by an earlier, possibly-broken compiler. Running the contract tests
against a stale binary produces a cascade of cryptic failures (e.g. SIGILL
from a since-fixed mis-encoding) that look like regressions but are not.
We probe the binary once (compile+run a trivial program) and, if it does not
behave, skip the suite with an actionable message instead of failing.
0 = not probed, 1 = good, 2 = bad. }
var
GCLIProbeState: Integer = 0;
{ ---- helpers ---- }
function TCLIContractTests.ProjectRoot: string;
@ -149,49 +128,24 @@ begin
FCompiler := '/tmp/fp_blaise3';
if not FileExists(FCompiler) then
FCompiler := '/tmp/fp_blaise2';
FRTLPath := ProjectRoot() + 'compiler/src/main/pascal';
FRTLPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibPath := ProjectRoot() + 'stdlib/src/main/pascal';
FRTL := ProjectRoot() + 'compiler/target/blaise_rtl.a';
FScratch := ProjectRoot() + 'compiler/target/cli_scratch/';
ForceDirectories(FScratch);
FCounter := 0;
end;
function TCLIContractTests.CompilerAvailable: Boolean;
var
Out_: string;
EC: Integer;
begin
{ The compiler binary source-builds the RTL itself (no blaise_rtl.a); only
the binary and the RTL source need to be present. }
Result := FileExists(FCompiler)
and FileExists(FRTLPath + '/runtime.arc.pas');
Result := FileExists(FCompiler) and FileExists(FRTL);
if (not Result) and (not GCLISkipNoted) then
begin
GCLISkipNoted := True;
WriteLn(StdErr, 'note: TCLIContractTests skipped — compiler binary "',
FCompiler, '" or RTL source not found ',
FCompiler, '" or RTL "', FRTL, '" not found ',
'(set BLAISE_QBE_COMPILER to a QBE-backend blaise binary to run them)');
Exit;
end;
if not Result then Exit;
{ Validity probe: a stale fallback binary would otherwise turn into a cascade
of cryptic failures. Probe once; on a bad probe, treat as unavailable. }
if GCLIProbeState = 0 then
begin
if CompileRunFull('program p; begin WriteLn(42); end.', 'native', Out_, EC)
and (EC = 0) and (Pos('42', Out_) >= 0) then
GCLIProbeState := 1
else
begin
GCLIProbeState := 2;
WriteLn(StdErr, 'note: TCLIContractTests skipped — compiler binary "',
FCompiler, '" is stale/broken (probe program did not run); ',
'rebuild it or set BLAISE_QBE_COMPILER to a current QBE-backend ',
'blaise binary.');
end;
end;
Result := GCLIProbeState = 1;
end;
function TCLIContractTests.RunCompiler(const AArgs: array of string;
@ -565,52 +519,6 @@ const
' end' + LineEnding +
'end.';
const
{ Declares an external from a library that does not exist. The function is
never called, but the parser collects the library into Prog.LinkLibs at
parse time, so the driver must still emit -lnosuchlib_blaise_xyz on the link
line — which the system linker then rejects. If the -l<name> propagation
were broken (no flag emitted), the link would SUCCEED. }
SrcMissingExternalLib =
'program P;' + LineEnding +
'function f(X: Integer): Integer;' +
' external ''nosuchlib_blaise_xyz'' name ''nope'';' + LineEnding +
'begin' + LineEnding +
' WriteLn(''unreached'')' + LineEnding +
'end.';
procedure TCLIContractTests.TestExternalLib_MissingLib_FailsLink_QBE;
var SrcPath, BinPath, Out_: string; EC: Integer;
begin
if not CompilerAvailable() then begin Ignore('<toolchain-missing>'); Exit; end;
SrcPath := WriteScratchSource(SrcMissingExternalLib);
BinPath := FScratch + 'cli_misslib_qbe_' + IntToStr(FCounter);
EC := RunCompiler(['--source', SrcPath, '--backend', 'qbe',
'--unit-path', FRTLPath, '--unit-path', FStdlibPath,
'--output', BinPath], Out_);
AssertTrue('link must fail (missing library)', EC <> 0);
AssertTrue('linker reports the -l<name> it could not find',
Pos('nosuchlib_blaise_xyz', Out_) >= 0);
end;
procedure TCLIContractTests.TestExternalLib_MissingLib_FailsLink_Native;
var SrcPath, BinPath, Out_: string; EC: Integer;
begin
if not CompilerAvailable() then begin Ignore('<toolchain-missing>'); Exit; end;
SrcPath := WriteScratchSource(SrcMissingExternalLib);
BinPath := FScratch + 'cli_misslib_nat_' + IntToStr(FCounter);
{ --linker external: the internal linker cannot resolve -l<name> system
libraries (it errors out separately); the toolchain linker is what emits
and consumes -l<name>. }
EC := RunCompiler(['--source', SrcPath, '--backend', 'native',
'--linker', 'external',
'--unit-path', FRTLPath, '--unit-path', FStdlibPath,
'--output', BinPath], Out_);
AssertTrue('link must fail (missing library)', EC <> 0);
AssertTrue('linker reports the -l<name> it could not find',
Pos('nosuchlib_blaise_xyz', Out_) >= 0);
end;
procedure TCLIContractTests.TestDivByZeroCaught_QBE;
var Out_: string; EC: Integer;
begin
@ -651,58 +559,6 @@ begin
AssertTrue('mod by zero caught', Pos('mod caught', Out_) >= 0);
end;
procedure TCLIContractTests.TestBareOutput_UnitArtefacts_NotWrittenToRoot;
var
UnitPath, ProgPath, Out_: string;
EC: Integer;
begin
if not CompilerAvailable() then begin Ignore('<toolchain-missing>'); Exit; end;
{ Regression: incremental compilation (default) compiles each used unit to
its own .o/.bif via a worker. The worker's output directory was derived
from --output via IncludeTrailingPathDelimiter(ExtractFilePath(OutputFile)).
For a bare --output filename (no directory part) ExtractFilePath returns ''
and IncludeTrailingPathDelimiter('') yields '/', so the worker tried to
write '/<unit>.o.bif.tmp' at the filesystem root and failed with
'Cannot open file for writing: /<unit>.o.bif.tmp'. The artefacts must land
in the current directory instead. }
UnitPath := FScratch + 'clidemo_unit.pas';
WriteFile(UnitPath,
'unit clidemo_unit;' + LineEnding +
'interface' + LineEnding +
'function Answer: Integer;' + LineEnding +
'implementation' + LineEnding +
'function Answer: Integer;' + LineEnding +
'begin' + LineEnding +
' Result := 42' + LineEnding +
'end;' + LineEnding +
'end.');
ProgPath := WriteScratchSource(
'program cli_bareout;' + LineEnding +
'uses clidemo_unit;' + LineEnding +
'begin' + LineEnding +
' WriteLn(Answer())' + LineEnding +
'end.');
{ Bare --output name (no '/') is the trigger; the unit is found via the
scratch --unit-path. }
EC := RunCompiler([
'--source', ProgPath,
'--unit-path', FScratch,
'--unit-path', FRTLPath,
'--unit-path', FStdlibPath,
'--output', 'cli_bareout_bin'
], Out_);
{ The bare output name resolves relative to the compiler's CWD (the test
runner's working directory): the program binary and the per-unit .o land
there. Remove them so the working tree stays clean. }
if FileExists('cli_bareout_bin') then DeleteFile('cli_bareout_bin');
if FileExists('clidemo_unit.o') then DeleteFile('clidemo_unit.o');
AssertTrue('no root-path worker failure: ' + Out_,
Pos('Cannot open file for writing: /', Out_) < 0);
AssertTrue('no worker exception: ' + Out_,
Pos('Worker exception', Out_) < 0);
AssertEquals('bare --output compile exits 0: ' + Out_, 0, EC);
end;
{ ---- Registration ---- }
initialization

66
compiler/src/test/pascal/cp.test.codegen.pas
View file

@ -81,13 +81,6 @@ type
procedure TestInt64AssignDouble_EmitsSltof;
procedure TestIntAssignSingle_EmitsSwtof;
{ Integer→float conversion on a CLASS-FIELD store target (not just a
simple variable). Regression: the field-store path emitted a bare
integer store into the float slot. }
procedure TestInt64AssignDoubleField_EmitsSltof;
procedure TestIntAssignSingleField_EmitsSwtof;
procedure TestInt64AssignDoubleFieldBare_EmitsSltof;
{ Mixed Single×Double arithmetic }
procedure TestSingleMulDouble_PromotesSingleToDouble;
procedure TestSingleAddSingle_EmitsSTypedOp;
@ -674,65 +667,6 @@ begin
IRContains(IR, 'swtof'));
end;
procedure TCodeGenTests.TestInt64AssignDoubleField_EmitsSltof;
var IR: string;
begin
IR := GenerateIR('''
program P;
type TFoo = class
FD: Double;
procedure SetIt(AValue: Int64);
begin Self.FD := AValue end;
end;
var F: TFoo;
begin
F := TFoo.Create()
end.
''');
AssertTrue('Int64→Double field store should emit sltof',
IRContains(IR, 'sltof'));
AssertFalse('Int64→Double field store must not bare-store the integer',
IRContains(IR, 'storel %_t2, %_t1'));
end;
procedure TCodeGenTests.TestIntAssignSingleField_EmitsSwtof;
var IR: string;
begin
IR := GenerateIR('''
program P;
type TFoo = class
FS: Single;
procedure SetIt(AValue: Integer);
begin Self.FS := AValue end;
end;
var F: TFoo;
begin
F := TFoo.Create()
end.
''');
AssertTrue('Integer→Single field store should emit swtof',
IRContains(IR, 'swtof'));
end;
procedure TCodeGenTests.TestInt64AssignDoubleFieldBare_EmitsSltof;
var IR: string;
begin
IR := GenerateIR('''
program P;
type TFoo = class
FD: Double;
procedure SetIt(AValue: Int64);
begin FD := AValue end;
end;
var F: TFoo;
begin
F := TFoo.Create()
end.
''');
AssertTrue('Int64→Double bare implicit-Self field store should emit sltof',
IRContains(IR, 'sltof'));
end;
procedure TCodeGenTests.TestSingleMulDouble_PromotesSingleToDouble;
var IR: string;
begin

113
compiler/src/test/pascal/cp.test.config.pas
View file

@ -28,11 +28,6 @@ type
procedure TestParseRelativePath_ResolvedAgainstBaseDir;
procedure TestParseAbsolutePath_NotModified;
procedure TestParseUnknownKey_IgnoredSilently;
procedure TestParseRtlSrc_Absolute_SetsValue;
procedure TestParseRtlSrc_Relative_ResolvedAgainstBaseDir;
procedure TestParseRtlSrc_Absent_LeavesSeedUnchanged;
procedure TestParseTildePath_ExpandsToHome;
procedure TestParseRtlSrcTilde_ExpandsToHome;
procedure TestFindConfigFile_NextToBinary;
end;
@ -186,11 +181,11 @@ begin
Lines := TStringList.Create();
Paths := TStringList.Create();
try
Lines.Add('unit-path=../../compiler/src/main/pascal');
Lines.Add('unit-path=../../runtime/src/main/pascal');
ParseConfigLines(Lines, '/data/devel/new-pascal-compiler/compiler/target/', Paths);
AssertEquals('one path', 1, Paths.Count);
AssertEquals('resolved',
'/data/devel/new-pascal-compiler/compiler/target/../../compiler/src/main/pascal',
'/data/devel/new-pascal-compiler/compiler/target/../../runtime/src/main/pascal',
Paths.Strings[0]);
finally
Lines.Free();
@ -232,110 +227,6 @@ begin
end;
end;
procedure TConfigTests.TestParseRtlSrc_Absolute_SetsValue;
var
Lines, Paths: TStringList;
Rtl: string;
begin
Lines := TStringList.Create();
Paths := TStringList.Create();
try
Rtl := '';
Lines.Add('rtl-src=/opt/blaise/rtl');
ParseConfigLines(Lines, '/base', Paths, Rtl);
AssertEquals('rtl-src set', '/opt/blaise/rtl', Rtl);
AssertEquals('rtl-src is not a unit-path', 0, Paths.Count);
finally
Lines.Free();
Paths.Free();
end;
end;
procedure TConfigTests.TestParseRtlSrc_Relative_ResolvedAgainstBaseDir;
var
Lines, Paths: TStringList;
Rtl: string;
begin
Lines := TStringList.Create();
Paths := TStringList.Create();
try
Rtl := '';
Lines.Add('rtl-src=src/main/pascal');
ParseConfigLines(Lines, '/base/', Paths, Rtl);
AssertEquals('relative rtl-src resolved against base dir',
'/base/src/main/pascal', Rtl);
finally
Lines.Free();
Paths.Free();
end;
end;
procedure TConfigTests.TestParseRtlSrc_Absent_LeavesSeedUnchanged;
var
Lines, Paths: TStringList;
Rtl: string;
begin
Lines := TStringList.Create();
Paths := TStringList.Create();
try
{ Seed a value (as the driver does with a CLI --rtl-src); a config with no
rtl-src line must leave it untouched. }
Rtl := '/cli/override';
Lines.Add('unit-path=/opt/blaise/runtime');
ParseConfigLines(Lines, '/base', Paths, Rtl);
AssertEquals('seed unchanged when config has no rtl-src',
'/cli/override', Rtl);
finally
Lines.Free();
Paths.Free();
end;
end;
procedure TConfigTests.TestParseTildePath_ExpandsToHome;
var
Lines, Paths: TStringList;
Home: string;
begin
Home := GetEnvironmentVariable('HOME');
if Home = '' then begin Ignore('no $HOME'); Exit end;
Lines := TStringList.Create();
Paths := TStringList.Create();
try
{ A '~/...' unit-path expands to $HOME/..., NOT resolved against the base. }
Lines.Add('unit-path=~/devel/blaise/runtime');
ParseConfigLines(Lines, '/some/base', Paths);
AssertEquals('one path', 1, Paths.Count);
AssertEquals('~ expanded to $HOME',
IncludeTrailingPathDelimiter(Home) + 'devel/blaise/runtime',
Paths.Strings[0]);
finally
Lines.Free();
Paths.Free();
end;
end;
procedure TConfigTests.TestParseRtlSrcTilde_ExpandsToHome;
var
Lines, Paths: TStringList;
Rtl, Home: string;
begin
Home := GetEnvironmentVariable('HOME');
if Home = '' then begin Ignore('no $HOME'); Exit end;
Lines := TStringList.Create();
Paths := TStringList.Create();
try
Rtl := '';
Lines.Add('rtl-src=~/devel/blaise/compiler/src/main/pascal');
ParseConfigLines(Lines, '/some/base', Paths, Rtl);
AssertEquals('~ in rtl-src expanded to $HOME',
IncludeTrailingPathDelimiter(Home) + 'devel/blaise/compiler/src/main/pascal',
Rtl);
finally
Lines.Free();
Paths.Free();
end;
end;
procedure TConfigTests.TestFindConfigFile_NextToBinary;
var
CfgPath: string;

2
compiler/src/test/pascal/cp.test.constants.pas
View file

@ -480,7 +480,7 @@ begin
x := Threshold
end;
begin
DoWork()
DoWork
end.
'''
);

113
compiler/src/test/pascal/cp.test.driver.pas
View file

@ -22,24 +22,12 @@ interface
uses
SysUtils, Classes, blaise.testing,
blaise.codegen.driver,
blaise.codegen.target, { TTargetOS: osLinux / osFreeBSD }
blaise.codegen.qbe.driver, { registers the QBE driver }
blaise.codegen.native.driver; { registers the native driver }
type
TBackendDriverContractTests = class(TTestCase)
private
function ListContains(AList: TStringList; const AName: string): Boolean;
published
{ Per-target RTL unit-list selection (FreeBSD Step 5). BuildRTLUnitList is
the pure selection helper EnsureRTLObjects drives off AOpts.Static +
AOpts.Target.OS; these assert Linux vs FreeBSD swaps without invoking the
whole compile+link pipeline. }
procedure TestRTLUnits_LinuxDynamic_UsesLinuxLayout;
procedure TestRTLUnits_LinuxStatic_SwapsLinuxLeaf;
procedure TestRTLUnits_FreeBSDStatic_SwapsFreeBSDLeaf;
procedure TestRTLUnits_FreeBSDStatic_NoLinuxLeaf;
{ ClaimsEmitIR selection policy. }
procedure TestQBE_ClaimsEmitIR_True;
procedure TestNative_ClaimsEmitIR_False;
@ -66,107 +54,6 @@ type
implementation
function TBackendDriverContractTests.ListContains(AList: TStringList;
const AName: string): Boolean;
var
I: Integer;
begin
Result := False;
for I := 0 to AList.Count - 1 do
if SameText(AList.Strings[I], AName) then
Exit(True);
end;
procedure TBackendDriverContractTests.TestRTLUnits_LinuxDynamic_UsesLinuxLayout;
var
U: TStringList;
begin
{ A dynamic (libc) Linux link keeps the plain RTL list: the Linux layout
adapter is present and no freestanding kernel leaf is pulled in. }
U := BuildRTLUnitList(False, osLinux);
try
AssertTrue('linux layout present',
ListContains(U, 'rtl.platform.layout.linux'));
AssertFalse('no static start in dynamic mode',
ListContains(U, 'runtime.start.static.linux'));
AssertFalse('no syscall leaf in dynamic mode',
ListContains(U, 'runtime.syscall.linux'));
finally
U.Free();
end;
end;
procedure TBackendDriverContractTests.TestRTLUnits_LinuxStatic_SwapsLinuxLeaf;
var
U: TStringList;
begin
{ A --static Linux link swaps runtime.start for the freestanding
runtime.start.static.linux and adds the Linux syscall/cstub/libc leaf. }
U := BuildRTLUnitList(True, osLinux);
try
AssertTrue('freestanding start present',
ListContains(U, 'runtime.start.static.linux'));
AssertFalse('libc start dropped',
ListContains(U, 'runtime.start'));
AssertTrue('linux syscall leaf present',
ListContains(U, 'runtime.syscall.linux'));
AssertTrue('linux libc2 present',
ListContains(U, 'runtime.libc2.linux'));
AssertTrue('linux static thread leaf present',
ListContains(U, 'runtime.thread.static.linux'));
AssertTrue('linux layout present',
ListContains(U, 'rtl.platform.layout.linux'));
finally
U.Free();
end;
end;
procedure TBackendDriverContractTests.TestRTLUnits_FreeBSDStatic_SwapsFreeBSDLeaf;
var
U: TStringList;
begin
{ A --static FreeBSD link selects the FreeBSD adapter set: the FreeBSD
layout, freestanding start, syscall leaf, libc2 and static thread leaf. }
U := BuildRTLUnitList(True, osFreeBSD);
try
AssertTrue('freebsd layout present',
ListContains(U, 'rtl.platform.layout.freebsd'));
AssertTrue('freebsd freestanding start present',
ListContains(U, 'runtime.start.static.freebsd'));
AssertTrue('freebsd syscall leaf present',
ListContains(U, 'runtime.syscall.freebsd'));
AssertTrue('freebsd libc2 present',
ListContains(U, 'runtime.libc2.freebsd'));
AssertTrue('freebsd static thread leaf present',
ListContains(U, 'runtime.thread.static.freebsd'));
finally
U.Free();
end;
end;
procedure TBackendDriverContractTests.TestRTLUnits_FreeBSDStatic_NoLinuxLeaf;
var
U: TStringList;
begin
{ The FreeBSD list must contain NO Linux-specific RTL unit — the whole point
of the per-target swap. }
U := BuildRTLUnitList(True, osFreeBSD);
try
AssertFalse('no linux layout',
ListContains(U, 'rtl.platform.layout.linux'));
AssertFalse('no linux start',
ListContains(U, 'runtime.start.static.linux'));
AssertFalse('no linux syscall leaf',
ListContains(U, 'runtime.syscall.linux'));
AssertFalse('no linux libc2',
ListContains(U, 'runtime.libc2.linux'));
AssertFalse('no linux static thread leaf',
ListContains(U, 'runtime.thread.static.linux'));
finally
U.Free();
end;
end;
procedure TBackendDriverContractTests.TestQBE_ClaimsEmitIR_True;
begin
AssertTrue('QBE must claim --emit-ir',

76
compiler/src/test/pascal/cp.test.e2e.arc.pas
View file

@ -47,14 +47,6 @@ type
LHS (class) slot type. }
procedure TestRun_PtrRvalueToClassLocal_PreservesLifetime;
procedure TestRun_ClassVarAssignNil_Destroys;
{ A method call whose receiver is a deep field chain rooted in a
transient function result — MakeIt().A.B.Method() — must keep the
transient alive until the call completes. The native backend released
the transient after the FIRST field hop, and _ClassRelease at refcount 0
runs _FieldCleanup, freeing the intermediate objects (A, then B) the rest
of the chain still dereferences — a use-after-free that crashed when the
chain had two or more hops before the call. Guards both backends. }
procedure TestRun_TransientDeepChainMethodCall_NoUseAfterFree;
end;
implementation
@ -517,7 +509,7 @@ const
Freed := 0;
L := TObjectList.Create(True);
L.Add(TThing.Create());
Borrow();
Borrow;
WriteLn(Freed);
L.Free();
WriteLn(Freed)
@ -544,7 +536,7 @@ const
destructor TThing.Destroy;
begin
WriteLn('destroyed');
inherited Destroy()
inherited Destroy
end;
var O: TThing;
begin
@ -564,70 +556,6 @@ begin
'destroyed' + LE + 'done' + LE, Output);
end;
const
SrcTransientDeepChain = '''
program P;
type
TInner = class
Val: Integer;
function GetVal: Integer;
end;
TBlk = class
Inner: TInner;
constructor Create;
end;
TProg = class
Blk: TBlk;
constructor Create;
end;
function TInner.GetVal: Integer;
begin
Result := Self.Val
end;
constructor TBlk.Create;
begin
Self.Inner := TInner.Create();
Self.Inner.Val := 7
end;
constructor TProg.Create;
begin
Self.Blk := TBlk.Create()
end;
function MakeProg: TProg;
begin
Result := TProg.Create()
end;
var
V, I: Integer;
begin
{ Two field hops (.Blk.Inner) before the method call, on a transient
function result that is never explicitly freed. The loop forces the
freed-then-reused arena to surface a use-after-free deterministically. }
V := 0;
for I := 0 to 50 do
V := V + MakeProg().Blk.Inner.GetVal();
WriteLn(V)
end.
''';
procedure TE2EArcTests.TestRun_TransientDeepChainMethodCall_NoUseAfterFree;
var Log: string;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 51 iterations * 7 = 357. Both backends must agree on the value. }
AssertRunsOnAll(SrcTransientDeepChain, '357' + LE, 0);
{ The use-after-free is non-deterministic at the stdout level (a freed-then-
not-yet-reused read returns the old value), so the value check above can
pass even when the bug is present. valgrind on the NATIVE binary detects
the invalid read deterministically — this is the real regression guard. }
if not ValgrindAvailable() then begin Ignore('valgrind not installed'); Exit; end;
if not RunUnderValgrindNative(SrcTransientDeepChain, Log) then
begin
if Log = '' then Log := '(valgrind produced no output)';
Fail('native valgrind reported an invalid access (use-after-free):' + LE + Log);
end;
end;
initialization
RegisterTest(TE2EArcTests);

234
compiler/src/test/pascal/cp.test.e2e.base.pas
View file

@ -34,6 +34,7 @@ type
TE2ETestCase = class(TTestCase)
private
FQBE: string;
FRTL: string;
FRTLUnitPath: string;
FStdlibUnitPath: string;
FScratch: string;
@ -42,13 +43,6 @@ type
function RunProc(const AExe: string; const AArgs: array of string;
out AStdout: string): Integer;
function RunProcNoArgs(const AExe: string; out AStdout: string): Integer;
{ Link an assembled program (AAsmFile) into ABinFile against the RTL. The
RTL is built from source by scripts/build-rtl-objects.sh (no blaise_rtl.a
archive); --exclude-defined-by drops the RTL objects the whole-program
assembly already inlines, so the loose objects do not double-define.
Returns the cc exit code; AStdout carries any tool output. }
function LinkWithRTL(const AAsmFile, ABinFile: string;
out AStdout: string): Integer;
protected
function ToolchainAvailable(): Boolean;
function ValgrindAvailable(): Boolean;
@ -107,10 +101,6 @@ type
procedure AssertRunsOnOne(ABackend: TBackend; const AName, ASrc,
AExpectedOut: string; AExpectedCode: Integer);
function RunUnderValgrind(const ASrc: string; out ALog: string): Boolean;
{ Native-backend twin of RunUnderValgrind: compile ASrc with the NATIVE
codegen, link, and run under valgrind. Needed to detect native-only
use-after-free/leak bugs that the QBE-only RunUnderValgrind cannot see. }
function RunUnderValgrindNative(const ASrc: string; out ALog: string): Boolean;
function CompileAndRunWithRTL(const ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean; overload;
@ -146,15 +136,6 @@ type
function CompileAndRunWithUnitNative(const AUnitName, AUnitSrc, ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;
{ Two-written-units compile+run (QBE). Writes both units to the scratch
dir (filename derived from each `unit <name>;` header) so the program's
`uses` clause resolves them, then lowers + links + runs. Needed for
cross-unit tests (two units exporting the same name: last-wins shadowing,
unit-qualified disambiguation). Kept at 5 params (Self+5 = 6 register
slots) so the stage-1 native ABI does not overflow. }
function CompileAndRunWithUnits(const AUnit1Src, AUnit2Src, ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;
end;
implementation
@ -188,11 +169,7 @@ end;
function TE2ETestCase.ToolchainAvailable(): Boolean;
begin
{ Need the QBE assembler, the compiler binary (build-rtl-objects.sh drives it
to source-build the RTL), and the RTL source. No blaise_rtl.a archive. }
Result := FileExists(FQBE)
and FileExists(ProjectRoot() + 'compiler/target/blaise')
and FileExists(ProjectRoot() + 'compiler/src/main/pascal/runtime.arc.pas')
Result := FileExists(FQBE) and FileExists(FRTL)
end;
function TE2ETestCase.ValgrindAvailable(): Boolean;
@ -209,9 +186,10 @@ begin
FQBE := GetEnvironmentVariable('BLAISE_QBE');
if FQBE = '' then
FQBE := ProjectRoot() + 'vendor/qbe/qbe';
{ RTL units (runtime.*, rtl.platform.*) now live in the compiler's own source
tree after the RTL-unification move; the old runtime/src/main/pascal is empty. }
FRTLUnitPath := ProjectRoot() + 'compiler/src/main/pascal';
FRTL := GetEnvironmentVariable('BLAISE_RTL');
if FRTL = '' then
FRTL := ProjectRoot() + 'runtime/target/blaise_rtl.a';
FRTLUnitPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibUnitPath := ProjectRoot() + 'stdlib/src/main/pascal'
end;
@ -248,62 +226,6 @@ begin
end
end;
function TE2ETestCase.LinkWithRTL(const AAsmFile, ABinFile: string;
out AStdout: string): Integer;
var
ProgObj, ObjDir, Compiler, ScriptOut: string;
Objs: TStringList;
Proc: TProcess;
I: Integer;
begin
{ 1. Assemble the program to an object so build-rtl-objects.sh can see which
RTL symbols it already defines (it inlines the RTL units it uses). }
ProgObj := AAsmFile + '.o';
Result := RunProc('cc', ['-c', '-o', ProgObj, AAsmFile], AStdout);
if Result <> 0 then Exit;
{ 2. Build the RTL objects from source, excluding the units the program
already inlined. Compiler binary is the freshly-built compiler/target. }
Compiler := ProjectRoot() + 'compiler/target/blaise';
ObjDir := IncludeTrailingPathDelimiter(FScratch) + 'rtlobj';
Result := RunProc(ProjectRoot() + 'scripts/build-rtl-objects.sh',
[Compiler, ObjDir, '--exclude-defined-by', ProgObj],
ScriptOut);
if Result <> 0 then
begin
AStdout := 'build-rtl-objects failed: ' + ScriptOut;
Exit;
end;
{ 3. Link: cc -o Bin ProgObj <rtl objects> -lm -lpthread. Build the TProcess
directly so the object list (variable length) can be appended. }
Objs := TStringList.Create();
Proc := TProcess.Create(nil);
try
Objs.Text := ScriptOut;
Proc.Executable := 'cc';
Proc.Parameters.Add('-o');
Proc.Parameters.Add(ABinFile);
Proc.Parameters.Add(ProgObj);
for I := 0 to Objs.Count - 1 do
if Trim(Objs.Strings[I]) <> '' then
Proc.Parameters.Add(Trim(Objs.Strings[I]));
Proc.Parameters.Add('-lm');
Proc.Parameters.Add('-lpthread');
Proc.Execute();
AStdout := '';
repeat
ScriptOut := Proc.ReadOutput();
AStdout := AStdout + ScriptOut
until (ScriptOut = '') and not Proc.Running;
Proc.WaitOnExit();
Result := Proc.ExitCode;
finally
Proc.Free();
Objs.Free();
end;
end;
function TE2ETestCase.RunProcNoArgs(const AExe: string;
out AStdout: string): Integer;
var
@ -392,7 +314,7 @@ begin
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
@ -504,7 +426,7 @@ begin
WriteFile(IRFile, IR);
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end;
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProc(BinFile, AExtraArgs, AStdout);
Result := True
@ -548,7 +470,7 @@ begin
WriteFile(IRFile, IR);
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then Exit;
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then Exit;
Rc := RunProc('valgrind',
@ -556,53 +478,6 @@ begin
Result := Rc = 0
end;
function TE2ETestCase.RunUnderValgrindNative(const ASrc: string; out ALog: string): Boolean;
var
Lexer: TLexer;
Parser: TParser;
Prog: TProgram;
Semantic: TSemanticAnalyser;
NCG: TCodeGenNative;
CG: ICodeGen;
Asm_: string;
AsmFile: string;
BinFile: string;
ToolOut: string;
Rc: Integer;
begin
Result := False;
ALog := '';
Inc(FCounter);
AsmFile := FScratch + '/vgn' + IntToStr(FCounter) + '.s';
BinFile := FScratch + '/vgn' + IntToStr(FCounter);
Lexer := nil; Parser := nil; Prog := nil; Semantic := nil; CG := nil;
try
Lexer := TLexer.Create(ASrc);
Parser := TParser.Create(Lexer);
Prog := Parser.Parse();
Semantic := TSemanticAnalyser.Create();
Semantic.Analyse(Prog);
NCG := TCodeGenNative.Create();
NCG.SetTarget(HostTarget());
CG := NCG; { ARC-managed; released at scope exit }
CG.Generate(Prog);
Asm_ := CG.GetOutput()
finally
Semantic.Free(); Prog.Free(); Parser.Free(); Lexer.Free()
end;
WriteFile(AsmFile, Asm_);
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
if Rc <> 0 then begin ALog := 'cc failed: ' + ToolOut; Exit end;
{ --error-exitcode=99: any invalid read/write (the use-after-free) makes
valgrind exit non-zero even when the program does not itself crash. }
Rc := RunProc('valgrind',
['--error-exitcode=99', '--leak-check=no', '--quiet', BinFile], ALog);
Result := Rc = 0
end;
function TE2ETestCase.CompileAndRunWithRTL(const ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;
@ -787,7 +662,7 @@ begin
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
@ -887,94 +762,7 @@ begin
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
end;
{ Extract the unit name from a 'unit <name>;' header so the source can be
written to the matching <name>.pas the unit loader expects. Strings are
byte-indexed (S[i] returns a Byte); Pos is 0-based and returns -1 when the
substring is absent. }
function UnitNameOf(const ASrc: string): string;
var
P, Q: Integer;
begin
P := Pos('unit ', ASrc);
if P < 0 then begin Result := ''; Exit; end;
P := P + 5; { skip past 'unit ' }
Q := P;
while (Q < Length(ASrc)) and (ASrc[Q] <> Ord(';')) and (ASrc[Q] <> Ord(' '))
and (ASrc[Q] <> 10) and (ASrc[Q] <> 13) do
Q := Q + 1;
Result := Copy(ASrc, P, Q - P);
end;
function TE2ETestCase.CompileAndRunWithUnits(const AUnit1Src, AUnit2Src,
ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;
var
Lexer: TLexer;
Parser: TParser;
Prog: TProgram;
Semantic: TSemanticAnalyser;
QCG: TCodeGenQBE;
CG: ICodeGen;
Loader: TUnitLoader;
Units: TObjectList;
SearchPaths: TStringList;
Emitted: string;
IRFile, AsmFile, BinFile, ToolOut: string;
Rc, I: Integer;
begin
Result := False;
Inc(FCounter);
IRFile := FScratch + '/t' + IntToStr(FCounter) + '.ssa';
AsmFile := FScratch + '/t' + IntToStr(FCounter) + '.s';
BinFile := FScratch + '/t' + IntToStr(FCounter);
{ Write both user units to the scratch dir so the loader resolves them.
Filenames are derived from each unit's own `unit <name>;` header. }
WriteFile(FScratch + '/' + UnitNameOf(AUnit1Src) + '.pas', AUnit1Src);
WriteFile(FScratch + '/' + UnitNameOf(AUnit2Src) + '.pas', AUnit2Src);
Lexer := nil; Parser := nil; Prog := nil; Semantic := nil;
QCG := 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(FScratch);
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);
QCG := TCodeGenQBE.Create();
CG := QCG;
CG.SetSymbolTable(Prog.SymbolTable);
for I := 0 to Units.Count - 1 do
CG.AppendUnit(TUnit(Units.Items[I]));
CG.AppendProgram(Prog);
Emitted := CG.GetOutput()
finally
QCG.Free();
Semantic.Free();
Units.Free(); Loader.Free(); SearchPaths.Free();
Prog.Free(); Parser.Free(); Lexer.Free()
end;
WriteFile(IRFile, Emitted);
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end;
Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True

367
compiler/src/test/pascal/cp.test.e2e.caseenum.pas
View file

@ -28,17 +28,6 @@ type
procedure TestRun_Enum_ExplicitOrdinals;
procedure TestRun_Enum_AutoContinueAfterExplicit;
procedure TestRun_Enum_ExplicitInCase;
procedure TestRun_Enum_ScopedAccess;
procedure TestRun_Enum_SharedMemberByContext;
procedure TestRun_Enum_AmbiguousBareRejected;
procedure TestRun_Enum_CallArgByContext;
procedure TestRun_Enum_ForBoundsByContext;
procedure TestRun_Enum_FieldAssignByContext;
procedure TestRun_Enum_MethodArgByContext;
procedure TestRun_Enum_ArrayElemByContext;
procedure TestRun_Enum_PointerWriteByContext;
procedure TestRun_Enum_ProcTypeArgByContext;
procedure TestRun_Enum_ReturnByContext;
end;
implementation
@ -236,362 +225,6 @@ begin
AssertEquals('NotFound=404 matches case 404', 'not found', Trim(Output));
end;
procedure TE2ECaseEnumTests.TestRun_Enum_ScopedAccess;
const
{ Two enums in one unit share the member name 'Red'. Members are not bare
global symbols, so each enum's members are reachable through the
type-qualified form regardless of the shared name. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
begin
WriteLn(Ord(TColorA.Red));
WriteLn(Ord(TColorA.Green));
WriteLn(Ord(TColorB.Red));
WriteLn(Ord(TColorB.Blue))
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('TColorA.Red', '0', Lines.Strings[0]);
AssertEquals('TColorA.Green','1', Lines.Strings[1]);
AssertEquals('TColorB.Red', '0', Lines.Strings[2]);
AssertEquals('TColorB.Blue', '1', Lines.Strings[3]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_SharedMemberByContext;
const
{ 'Red' is shared by both enums. Each bare use is disambiguated by its
context — assignment target, case selector, set element — so the program
reaches the correct member of each enum at runtime. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Red, Blue);
var
a: TColorA;
b: TColorB;
s: set of TColorA;
begin
a := Red; WriteLn(Ord(a));
b := Blue; WriteLn(Ord(b));
s := [Red, Green];
if Red in s then WriteLn(10);
case b of
Red: WriteLn(20);
Blue: WriteLn(21)
end
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('a := Red (TColorA.Red)', '0', Lines.Strings[0]);
AssertEquals('b := Blue (TColorB.Blue)','1', Lines.Strings[1]);
AssertEquals('Red in s (TColorA.Red)', '10', Lines.Strings[2]);
AssertEquals('case b = Blue', '21', Lines.Strings[3]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_AmbiguousBareRejected;
const
{ A bare, context-free reference to a member shared by two enums cannot be
resolved and must fail to compile — there is no last-wins fallback. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red);
begin
WriteLn(Ord(Red))
end.
''';
var Output: string; RCode: Integer; Rejected: Boolean;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
Rejected := False;
try
if not CompileAndRun(Src, Output, RCode) then
Rejected := True;
except
on E: Exception do Rejected := True;
end;
AssertTrue('ambiguous bare member must not compile', Rejected);
end;
procedure TE2ECaseEnumTests.TestRun_Enum_CallArgByContext;
const
{ 'Red' is shared (ordinal 0 in TColorA, ordinal 1 in TColorB). Each bare
member passed as a call argument is steered to the enum of the callee's
parameter, so the right ordinal reaches the routine at runtime. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
procedure TakeA(c: TColorA);
begin WriteLn(Ord(c)) end;
procedure TakeB(c: TColorB);
begin WriteLn(Ord(c)) end;
begin
TakeA(Red);
TakeB(Red);
TakeB(Blue)
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('TakeA(Red) -> TColorA.Red', '0', Lines.Strings[0]);
AssertEquals('TakeB(Red) -> TColorB.Red', '1', Lines.Strings[1]);
AssertEquals('TakeB(Blue) -> TColorB.Blue','2', Lines.Strings[2]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_ForBoundsByContext;
const
{ The loop variable's type disambiguates the bare shared start bound 'Red'
(TColorB here), so the loop walks TColorB.Red(1)..TColorB.Blue(2). }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
var b: TColorB;
begin
for b := Red to Blue do
WriteLn(Ord(b))
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('first iter b=Red(1)', '1', Lines.Strings[0]);
AssertEquals('second iter b=Blue(2)','2', Lines.Strings[1]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_FieldAssignByContext;
const
{ A bare shared member assigned to a record field is disambiguated by the
field's enum type (TColorB), so r.c receives TColorB.Red (ordinal 1). }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
TRec = record c: TColorB; end;
var r: TRec;
begin
r.c := Red;
WriteLn(Ord(r.c))
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
AssertEquals('r.c := Red -> TColorB.Red (ordinal 1)', '1', Trim(Output));
end;
procedure TE2ECaseEnumTests.TestRun_Enum_MethodArgByContext;
const
{ A bare shared member passed to a method is steered to the enum of the
method's parameter (TColorB), so TColorB.Red (ordinal 1) reaches it. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
TFoo = class
procedure TakeB(c: TColorB);
end;
procedure TFoo.TakeB(c: TColorB);
begin WriteLn(Ord(c)) end;
var f: TFoo;
begin
f := TFoo.Create();
f.TakeB(Red);
f.TakeB(Blue);
f.Free()
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('TakeB(Red) -> TColorB.Red', '1', Lines.Strings[0]);
AssertEquals('TakeB(Blue) -> TColorB.Blue','2', Lines.Strings[1]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_ArrayElemByContext;
const
{ Writing a bare shared member into an array element is disambiguated by the
array's element type (TColorB), so arr[0] receives TColorB.Red (ordinal 1). }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
var arr: array[0..1] of TColorB;
begin
arr[0] := Red;
arr[1] := Blue;
WriteLn(Ord(arr[0]));
WriteLn(Ord(arr[1]))
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('arr[0] := Red -> TColorB.Red', '1', Lines.Strings[0]);
AssertEquals('arr[1] := Blue -> TColorB.Blue','2', Lines.Strings[1]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_PointerWriteByContext;
const
{ Writing a bare shared member through a typed pointer is disambiguated by
the pointer's base enum type (TColorB), so the target receives ordinal 2. }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
PColorB = ^TColorB;
var
b: TColorB;
q: PColorB;
begin
q := @b;
q^ := Blue;
WriteLn(Ord(b))
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
AssertEquals('q^ := Blue -> TColorB.Blue (ordinal 2)', '2', Trim(Output));
end;
procedure TE2ECaseEnumTests.TestRun_Enum_ProcTypeArgByContext;
const
{ Calling through a procedural-type variable steers a bare shared member to
the enum of the procedural type's parameter (TColorB). }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
TProcB = procedure(c: TColorB);
procedure ShowB(c: TColorB);
begin WriteLn(Ord(c)) end;
var cb: TProcB;
begin
cb := @ShowB;
cb(Red);
cb(Blue)
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('cb(Red) -> TColorB.Red', '1', Lines.Strings[0]);
AssertEquals('cb(Blue) -> TColorB.Blue','2', Lines.Strings[1]);
finally
Lines.Free();
end;
end;
procedure TE2ECaseEnumTests.TestRun_Enum_ReturnByContext;
const
{ A bare shared member returned from a function is disambiguated by the
function's return enum, via both Result := and Exit(). }
Src =
'''
program P;
type
TColorA = (Red, Green);
TColorB = (Amber, Red, Blue);
function ViaResult: TColorB;
begin Result := Red end;
function ViaExit: TColorB;
begin Exit(Blue) end;
begin
WriteLn(Ord(ViaResult()));
WriteLn(Ord(ViaExit()))
end.
''';
var Output: string; RCode: Integer; Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('Result := Red -> TColorB.Red', '1', Lines.Strings[0]);
AssertEquals('Exit(Blue) -> TColorB.Blue', '2', Lines.Strings[1]);
finally
Lines.Free();
end;
end;
initialization
RegisterTest(TE2ECaseEnumTests);

91
compiler/src/test/pascal/cp.test.e2e.classes2.pas
View file

@ -159,17 +159,6 @@ type
{ ClassCreate builtin still works (backwards compat) and now dispatches
the ctor body via vtable too. }
procedure TestRun_ClassCreate_StillWorks;
{ Forward class declaration with a managed (string) field: the forward
stub must complete into the same type so the full class — including its
ARC field — compiles and runs correctly. }
procedure TestRun_ForwardClass_MutualRefRuns;
{ Implicit Int64/Integer→float conversion when the assignment target is a
class FIELD (both Self.Field and bare implicit-Self forms), for Double
and Single fields. Regression: QBE deposited the raw integer bits into
the float slot; native stored a Double into a Single slot (movss of a
double) without narrowing. }
procedure TestRun_IntToFloatField_Converts;
procedure TestRun_SelfIndexedRecordFieldAssign;
end;
@ -212,35 +201,6 @@ const
end.
''';
{ Forward-declared TNode referenced by TEdge before its full definition,
then completed with a managed (string) field and a back-reference. }
SrcForwardClass =
'''
program Prg;
type
TNode = class;
TEdge = class
Target: TNode;
end;
TNode = class
Name: string;
Link: TEdge;
end;
var
N: TNode;
E: TEdge;
begin
N := TNode.Create();
N.Name := 'hello';
E := TEdge.Create();
E.Target := N;
N.Link := E;
WriteLn(E.Target.Name);
N.Free();
E.Free()
end.
''';
SrcToStringDefault = '''
program Prg;
type
@ -2326,57 +2286,6 @@ begin
AssertRunsOnAll(Src, '1' + LE, 0);
end;
procedure TE2EClasses2Tests.TestRun_ForwardClass_MutualRefRuns;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcForwardClass, Output, RCode));
AssertEquals('forward-declared TNode field read back', 'hello', Trim(Output));
end;
const
SrcIntToFloatField =
'''
program Prg;
type
TFoo = class
FD: Double;
FS: Single;
procedure SetD(AValue: Int64);
begin Self.FD := AValue end; { Int64 -> Double, Self.Field }
procedure SetDBare(AValue: Int64);
begin FD := AValue end; { Int64 -> Double, implicit Self }
procedure SetS(AValue: Integer);
begin Self.FS := AValue end; { Integer -> Single, Self.Field }
procedure SetSBare(AValue: Integer);
begin FS := AValue end; { Integer -> Single, implicit Self }
end;
var F: TFoo;
begin
F := TFoo.Create();
F.SetD(7);
WriteLn(Format('%g', [F.FD]));
F.SetDBare(42);
WriteLn(Format('%g', [F.FD]));
F.SetS(5);
WriteLn(Format('%g', [F.FS]));
F.SetSBare(9);
WriteLn(Format('%g', [F.FS]))
end.
''';
procedure TE2EClasses2Tests.TestRun_IntToFloatField_Converts;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ All four forms convert the integer to the field's float width — including
Integer->Single, where the native backend had stored a Double into the
4-byte Single slot. }
AssertTrue('compile+run', CompileAndRun(SrcIntToFloatField, Output, RCode));
AssertEquals('Int64/Integer→float field stores convert',
'7' + LE + '42' + LE + '5' + LE + '9', Trim(Output));
end;
initialization
RegisterTest(TE2EClasses2Tests);

40
compiler/src/test/pascal/cp.test.e2e.collections2.pas
View file

@ -26,7 +26,6 @@ type
procedure TestRun_Collections_Valgrind;
procedure TestRun_TwoDictInstancesInUnit_BothLink;
procedure TestRun_IntfFreeFunc_GenericReturn_Compiles;
procedure TestRun_DefaultProp_StringList_And_ObjectList;
end;
implementation
@ -365,45 +364,6 @@ begin
AssertEquals('list count', '2' + #10, Output);
end;
{ Regression (GitHub #138): the real classes.TStringList and contnrs.TObjectList
must both carry a `default` indexed property so SL[i] / OL[i] work as sugar
for SL.Strings[i] / OL.Items[i]. TStringList already had it; TObjectList did
not. The chained form TStringList(OL[0])[1] — a typecast whose operand is
itself a default-property subscript, indexed again by a default property —
crashed the compiler (unbounded re-analysis of the rewritten subscript node);
AnalyseStringSubscriptExpr now guards against re-analysis via ResolvedType. }
procedure TE2ECollections2Tests.TestRun_DefaultProp_StringList_And_ObjectList;
const
Src = '''
program P;
uses classes, contnrs;
var SL: TStringList; OL: TObjectList; i: Integer;
begin
SL := TStringList.Create;
SL.Add('alpha');
SL.Add('beta');
for i := 0 to SL.Count - 1 do
WriteLn(SL[i]); // default property read
SL[0] := 'ALPHA'; // default property write
WriteLn(SL[0]);
OL := TObjectList.Create(False);
OL.Add(SL);
WriteLn(TStringList(OL[0])[1]); // chained: cast(OL default) then default
SL.Free();
OL.Free()
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ CompileAndRunWithRTL runs on BOTH backends and asserts parity, and puts the
RTL + stdlib (classes, contnrs) on the unit search path. }
AssertTrue('compile+run', CompileAndRunWithRTL(Src, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('default-property output',
'alpha' + #10 + 'beta' + #10 + 'ALPHA' + #10 + 'beta' + #10, Output);
end;
initialization
RegisterTest(TE2ECollections2Tests);

47
compiler/src/test/pascal/cp.test.e2e.controlflow.pas
View file

@ -24,8 +24,6 @@ type
procedure TestRun_For_Upward_PrintsRange;
procedure TestRun_For_Downto_PrintsRange;
procedure TestRun_While_PrintsRange;
procedure TestRun_For_EmptyBody_NoCrash;
procedure TestRun_While_EmptyBody_NoCrash;
procedure TestRun_Repeat_PrintsRange;
procedure TestRun_For_BreakExitsEarly;
procedure TestRun_For_ContinueSkipsIteration;
@ -107,29 +105,6 @@ const
end.
''';
{ Empty loop body — `for ... do;` / `while ... do;` parse to a nil body.
Regression for issue #150: the native backend segfaulted (nil.ClassName in
the unsupported-statement fallback) and the QBE backend rejected it; both
must now treat the empty body as a valid no-op. }
SrcForEmptyBody = '''
program P;
var I: Integer;
begin
for I := 0 to 9 do;
WriteLn('done')
end.
''';
SrcWhileEmptyBody = '''
program P;
var I: Integer;
begin
I := 0;
while I < 0 do;
WriteLn('done')
end.
''';
SrcRepeat = '''
program P;
var I: Integer;
@ -192,11 +167,11 @@ const
end;
begin
Counter := 0;
Inner();
Inner;
WriteLn(Counter);
end;
begin
Outer();
Outer;
end.
''';
@ -227,20 +202,6 @@ begin
AssertEquals('1 2 3', '1' + LE + '2' + LE + '3' + LE, Output);
end;
procedure TE2EControlFlowTests.TestRun_For_EmptyBody_NoCrash;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Issue #150: an empty `for` body must compile + run as a no-op on both
backends (native previously segfaulted the compiler). }
AssertRunsOnAll(SrcForEmptyBody, 'done' + LE, 0);
end;
procedure TE2EControlFlowTests.TestRun_While_EmptyBody_NoCrash;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcWhileEmptyBody, 'done' + LE, 0);
end;
procedure TE2EControlFlowTests.TestRun_Repeat_PrintsRange;
var Output: string; RCode: Integer;
begin
@ -311,7 +272,7 @@ const
end;
Write(r); Write(' ');
end;
WriteLn()
WriteLn
end.
''';
@ -326,7 +287,7 @@ const
5, 7..9: Write('b');
else Write('.');
end;
WriteLn()
WriteLn
end.
''';

55
compiler/src/test/pascal/cp.test.e2e.crypto.pas
View file

@ -1,55 +0,0 @@
{
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.crypto;
{ E2E smoke test for the Security.Crypto stdlib unit.
Guards against native-backend miscompilation of the hash
implementations (the Ord(S[I]) precedent). }
interface
uses
blaise.testing, cp.test.e2e.base;
type
[Threaded]
TE2ECryptoTests = class(TE2ETestCase)
protected
procedure SetUp; override;
published
procedure TestRun_Sha256Hex_Empty;
end;
implementation
procedure TE2ECryptoTests.SetUp;
begin
inherited SetUp();
SetUpScratch('compiler/target/test-e2e-crypto');
end;
procedure TE2ECryptoTests.TestRun_Sha256Hex_Empty;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRTLRunsOnAll(
'''
program P;
uses Security.Crypto;
begin
WriteLn(Sha256Hex(''));
end.
''',
'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855' + LineEnding,
0);
end;
initialization
RegisterTest(TE2ECryptoTests);
end.

14
compiler/src/test/pascal/cp.test.e2e.dynarray.pas
View file

@ -85,7 +85,7 @@ const
program Prg;
var a: array of string; i: Integer;
begin SetLength(a, 3); a[0] := 'x'; a[1] := 'y'; a[2] := 'z';
for i := 0 to 2 do Write(a[i]); WriteLn() end.
for i := 0 to 2 do Write(a[i]); WriteLn end.
''';
SrcRefSem = '''
@ -125,7 +125,7 @@ const
SetLength(m, 2); SetLength(m[0], 2); SetLength(m[1], 2);
m[0][0] := 1; m[0][1] := 2; m[1][0] := 3; m[1][1] := 4;
for i := 0 to 1 do for j := 0 to 1 do Write(m[i][j]);
WriteLn()
WriteLn
end.
''';
@ -137,7 +137,7 @@ const
m[0][0] := 'a'; m[0][1] := 'b'; m[1][0] := 'c'; m[1][1] := 'd';
m[0][1] := 'B';
for i := 0 to 1 do for j := 0 to 1 do Write(m[i][j]);
WriteLn()
WriteLn
end.
''';
@ -154,7 +154,7 @@ const
c[i][j][k] := i*4 + j*2 + k;
for i := 0 to 1 do for j := 0 to 1 do for k := 0 to 1 do
Write(c[i][j][k]);
WriteLn()
WriteLn
end.
''';
@ -212,7 +212,7 @@ const
SetLength(G, Length(H));
for I := 0 to High(G) do G[I] := 9;
for I := 0 to High(G) do Write(G[I]);
WriteLn()
WriteLn
end.
''';
@ -226,7 +226,7 @@ const
SetLength(A, Length(B));
for I := 0 to High(A) do A[I] := 8;
for I := 0 to High(A) do Write(A[I]);
WriteLn()
WriteLn
end.
''';
@ -241,7 +241,7 @@ const
SetLength(A, Pick());
for I := 0 to High(A) do A[I] := 6;
for I := 0 to High(A) do Write(A[I]);
WriteLn()
WriteLn
end.
''';

17
compiler/src/test/pascal/cp.test.e2e.external.pas
View file

@ -26,11 +26,6 @@ type
{ Basic external call — strlen via external name }
procedure TestRun_ExternalName_Strlen;
{ Library-qualified external — external 'c' name 'strlen': the bare library
name is parsed and recorded (propagated via the unit's LinkLibs) while the
symbol resolves as usual. }
procedure TestRun_ExternalLibName_Strlen;
{ Narrow-int return masking: strlen returns size_t (64-bit) but declared
as Byte/Word/SmallInt — upper bits must be masked/sign-extended. }
procedure TestRun_ExternalByteReturn_MaskedCorrectly;
@ -75,18 +70,6 @@ begin
AssertRunsOnAll(Src, '5' + Chr(10), 0);
end;
procedure TE2EExternalTests.TestRun_ExternalLibName_Strlen;
const Src = '''
program T;
function c_strlen(S: PChar): Integer; external 'c' name 'strlen';
begin
WriteLn(c_strlen(PChar('hello')))
end.
''';
begin
AssertRunsOnAll(Src, '5' + Chr(10), 0);
end;
procedure TE2EExternalTests.TestRun_ExternalByteReturn_MaskedCorrectly;
const Src = '''
program T;

117
compiler/src/test/pascal/cp.test.e2e.interfaces.pas
View file

@ -48,15 +48,6 @@ type
(issue #130 bug3). }
procedure TestRun_InheritedInterface_DescendantToVar;
procedure TestRun_InheritedInterface_OverrideAndInheritedMethod;
procedure TestRun_InheritedInterface_NonVirtualMethod;
{ An itab-dispatched method returning a RECORD. Two ABI shapes:
a memory-class record (has a managed field -> sret) and a register-class
record (all-scalar, returned in registers). Both must work when the
result is ASSIGNED and when DISCARDED in statement position — the
discarded statement and the assignment used to mis-handle the
record-return ABI and corrupt memory (bug #5). }
procedure TestRun_InterfaceMethod_ReturnsSretRecord;
procedure TestRun_InterfaceMethod_ReturnsRegisterRecord;
end;
implementation
@ -372,9 +363,9 @@ const
begin WriteLn(g.Greet(), ' / ', g.Who()) end;
var per: TPerson; lou: TLoud; vl: TVeryLoud;
begin
per := TPerson.Create; Use(per); per.Free();
lou := TLoud.Create; Use(lou); lou.Free();
vl := TVeryLoud.Create; Use(vl); vl.Free()
per := TPerson.Create; Use(per); per.Free;
lou := TLoud.Create; Use(lou); lou.Free;
vl := TVeryLoud.Create; Use(vl); vl.Free
end.
''';
begin
@ -383,108 +374,6 @@ begin
'hi / person' + LE + 'HI / person' + LE + 'HI!!! / person' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InheritedInterface_NonVirtualMethod;
const
{ Regression (issue #130 bug3): a NON-virtual interface method inherited by a
descendant. A non-virtual method gets no vtable slot, so the itab method ref
cannot be resolved via the vtable; the descendant's itab used to name
$TDerived_Hello (which does not exist) instead of the declaring ancestor's
$TBase_Hello, causing an "undefined symbol"/link error. The earlier
inherited-interface tests only exercised VIRTUAL methods, which DO have
vtable slots, so this path went uncovered. Both backends must now link+run. }
Src = '''
program P;
type
IBase = interface procedure Hello; end;
TBase = class(IBase) procedure Hello; end;
TDerived = class(TBase) end;
procedure TBase.Hello; begin WriteLn('hello') end;
procedure Use(g: IBase); begin g.Hello() end;
var d: TDerived; i: IBase;
begin
d := TDerived.Create;
i := d; // assignment to interface
i.Hello();
Use(d); // parameter passing
d.Free()
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, 'hello' + LE + 'hello' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsSretRecord;
const
{ TRect has a managed (string) field, so ClassifyRecordReturn => sret. }
Src = '''
program P;
type
TRect = record Name: string; N: Integer; end;
IShape = interface
function MakeRect(AN: Integer): TRect;
end;
TShape = class(IShape)
function MakeRect(AN: Integer): TRect;
end;
function TShape.MakeRect(AN: Integer): TRect;
begin
Result.Name := 'r';
Result.N := AN;
WriteLn('callee ', AN)
end;
var
M: IShape;
R: TRect;
begin
M := TShape.Create();
R := M.MakeRect(5); { assigned sret record return }
WriteLn('assigned ', R.N);
M.MakeRect(7) { discarded sret record return }
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src,
'callee 5' + LE + 'assigned 5' + LE + 'callee 7' + LE, 0);
end;
procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsRegisterRecord;
const
{ TPt is all-scalar, so ClassifyRecordReturn => a register-class return
(no sret buffer); the itab dispatch must capture the register result. }
Src = '''
program P;
type
TPt = record X, Y: Integer; end;
IShape = interface
function MakePt(AN: Integer): TPt;
end;
TShape = class(IShape)
function MakePt(AN: Integer): TPt;
end;
function TShape.MakePt(AN: Integer): TPt;
begin
Result.X := AN;
Result.Y := AN * 2;
WriteLn('callee ', AN)
end;
var
M: IShape;
R: TPt;
begin
M := TShape.Create();
R := M.MakePt(5); { assigned register-class record return }
WriteLn('assigned ', R.X, ' ', R.Y);
M.MakePt(9) { discarded register-class record return }
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src,
'callee 5' + LE + 'assigned 5 10' + LE + 'callee 9' + LE, 0);
end;
initialization
RegisterTest(TE2EInterfaceTests);

2
compiler/src/test/pascal/cp.test.e2e.jumboset.pas
View file

@ -123,7 +123,7 @@ begin
' for e in s do n := n + 1;' + LE +
' WriteLn(n);' + LE + { 4 }
' for e in s do Write(Ord(e), '' '');' + LE +
' WriteLn()' + LE +
' WriteLn' + LE +
'end.';
AssertRunsOnAll(Src, '4' + LE + '5 40 70 79 ' + LE, 0);
end;

234
compiler/src/test/pascal/cp.test.e2e.leakcheck.pas
View file

@ -38,10 +38,6 @@ type
{ obj.Field := MakeClass() consumes the call's +1 — no leak per store. }
procedure TestDebug_ClassFieldFromCall_NoLeak;
{ local := MakeClass() consumes the call's +1 — no leak per assignment.
Pins the native class-assignment AddRef elision against the QBE backend. }
procedure TestDebug_FuncReturnAssign_NoLeak;
{ Multiple same-named typed handlers share one slot — no over-release. }
procedure TestDebug_MultiHandlerVar_NoOverRelease;
{ for-in over a TList: GetEnumerator's +1 result must be transferred
@ -59,20 +55,6 @@ type
release it after the call or one instance leaks. }
procedure TestDebug_IntfCallResultArg_NoLeak;
procedure TestDebug_IntfCallResultArg_NoLeak_Native;
{ A call/getter result used as a field-access receiver must be released
after the field load. L[I].HitPoints — the TList<T>.Get getter returns
+1, the field is read, then the transient base must be released. }
procedure TestDebug_ReceiverFieldAccess_NoLeak;
{ A static array of interfaces (array[0..N] of IFoo): the elements are
ARC-managed but the scope-exit cleanup previously skipped tyStaticArray
locals entirely, so every stored element leaked on BOTH backends. The
fix releases each element at scope exit. }
procedure TestDebug_StaticArrayOfInterface_NoLeak;
{ A string-returning call/getter used DIRECTLY as a Write/WriteLn argument
(WriteLn(GetBar)) returns a fresh +1 string that _SysWriteStr only borrows.
EmitWrite previously never released it, leaking one string per call. The
fix releases the owned string transient after the write (both backends). }
procedure TestDebug_WriteLnCallArg_NoLeak;
end;
implementation
@ -89,7 +71,7 @@ const
{ A clean program: object is created and properly released by ARC at scope exit. }
SrcNoLeak = '''
program P;
uses runtime.arc;
uses blaise_arc;
type
TBox = class
Value: Integer;
@ -110,7 +92,7 @@ const
use-after-free. With the fix it is freed exactly once: no leak, no crash. }
SrcExceptionHandlerVar = '''
program P;
uses runtime.arc;
uses blaise_arc;
type
Exception = class
FMessage: string;
@ -126,7 +108,7 @@ const
end
end;
begin
DoIt();
DoIt;
WriteLn('done')
end.
''';
@ -134,7 +116,7 @@ const
{ Constructor with args — must not double-AddRef; object must be clean after scope. }
SrcConstructorWithArgs = '''
program P;
uses runtime.arc;
uses blaise_arc;
type
TBox = class
Value: Integer;
@ -155,7 +137,7 @@ const
{ Deliberately leaked: object assigned to a raw Pointer, bypassing ARC release. }
SrcOneLeak = '''
program P;
uses runtime.arc;
uses blaise_arc;
type
TBox = class
Value: Integer;
@ -175,7 +157,7 @@ const
{ Two distinct classes leaked to verify count and class-name reporting. }
SrcTwoLeaks = '''
program P;
uses runtime.arc;
uses blaise_arc;
type
TAlpha = class
X: Integer;
@ -200,7 +182,7 @@ const
{ Reference cycle: each object holds the other — both leak. }
SrcCycleLeak = '''
program P;
uses runtime.arc;
uses blaise_arc;
type
TNode = class
Other: TNode;
@ -222,7 +204,7 @@ const
line number where the leaking TBox.Create() call was made. }
SrcLeakWithSite = '''
program LeakSite;
uses runtime.arc;
uses blaise_arc;
type
TBox = class
Value: Integer;
@ -240,7 +222,7 @@ const
Extra AddRef prevents scope-exit release from freeing it. }
SrcStringLeak = '''
program P;
uses runtime.arc;
uses blaise_arc;
var
S: string;
begin
@ -253,7 +235,7 @@ const
{ Clean string usage: no leak expected — scope-exit ARC releases properly. }
SrcStringClean = '''
program P;
uses runtime.arc;
uses blaise_arc;
var
S: string;
begin
@ -315,7 +297,7 @@ const
allocation site as 'generics.collections:<line>', not '<program>:<line>'. }
SrcGenericAllocSite = '''
program LeakGen;
uses runtime.arc, generics.collections;
uses blaise_arc, generics.collections;
var
L: TList<Integer>;
E: TListEnumerator<Integer>;
@ -530,35 +512,6 @@ const
end.
''';
{ A function returning a class leaves Result at +1 (the callee's `Result := x`
AddRef'd and the epilogue did not release it). Assigning that call result to
a local consumes the transferred reference — the assignment site must NOT
AddRef again, or one object leaks per call. The native backend used to
AddRef class assignments unconditionally; this pins the elision. }
SrcFuncReturnAssign = '''
program P;
type
TThing = class N: Integer; end;
function MakeThing(): TThing;
begin
Result := TThing.Create();
Result.N := 9;
end;
var
T: TThing;
I, Sum: Integer;
begin
Sum := 0;
for I := 1 to 100 do
begin
T := MakeThing();
Sum := Sum + T.N;
T := nil;
end;
WriteLn(Sum);
end.
''';
SrcMultiHandlerVar = '''
program P;
type
@ -597,24 +550,6 @@ begin
AssertTrue('no leak report (native)', Pos('leak', Output) < 0);
end;
procedure TE2ELeakCheckTests.TestDebug_FuncReturnAssign_NoLeak;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run (qbe)',
CompileAndRunWithRTLDebugOn(beQBE, SrcFuncReturnAssign, Output, ExitCode, True));
AssertEquals('exit 0 (qbe)', 0, ExitCode);
AssertEquals('stdout (qbe)', '900' + LE, Output);
AssertTrue('no leak report (qbe)', Pos('leak', Output) < 0);
AssertTrue('compile+run (native)',
CompileAndRunWithRTLDebugOn(beNative, SrcFuncReturnAssign, Output, ExitCode, True));
AssertEquals('exit 0 (native)', 0, ExitCode);
AssertEquals('stdout (native)', '900' + LE, Output);
AssertTrue('no leak report (native)', Pos('leak', Output) < 0);
end;
procedure TE2ELeakCheckTests.TestDebug_MultiHandlerVar_NoOverRelease;
var
Output: string;
@ -692,153 +627,6 @@ begin
AssertTrue('no leak report, got: ' + Output, Pos('leak', Output) < 0);
end;
const
{ Call result used as a field-access receiver — the getter's +1 must be
released after the field read, otherwise one object leaks per access.
Uses TList<T>[I].HitPoints which is the most common trigger. }
SrcReceiverFieldAccess = '''
program P;
type
TCreature = class
HitPoints: Integer;
end;
function MakeCreature(): TCreature;
begin
Result := TCreature.Create();
Result.HitPoints := 42;
end;
var
X: Integer;
begin
X := MakeCreature().HitPoints;
WriteLn(X);
end.
''';
{ Static array of interfaces: three IGreet elements stored into a local
array[0..2]. Scope-exit cleanup must release each element. Prints the
three greetings, then exits with no leak report. }
SrcStaticArrayOfInterface = '''
program P;
type
IGreet = interface
function Name(): string;
end;
TGreet = class(IGreet)
FName: string;
function Name(): string;
end;
function TGreet.Name(): string;
begin
Result := Self.FName;
end;
procedure MakeInto(var G: IGreet; const N: string);
var
T: TGreet;
begin
T := TGreet.Create();
T.FName := N;
G := T;
end;
procedure Run();
var
Arr: array[0..2] of IGreet;
I: Integer;
begin
MakeInto(Arr[0], 'a');
MakeInto(Arr[1], 'b');
MakeInto(Arr[2], 'c');
for I := 0 to 2 do
Write(Arr[I].Name());
WriteLn('');
end;
begin
Run();
end.
''';
{ A string-returning getter used directly as a WriteLn argument. The getter
returns a fresh +1 string (Copy result); WriteLn only borrows it, so the
caller must release it after the write. Three calls => three leaks before
the fix. }
SrcWriteLnCallArg = '''
program P;
type
TFoo = class
private
function GetBar: String;
public
property Bar: String read GetBar;
end;
function TFoo.GetBar: String;
begin
Result := Copy('abcd', 1, 3);
end;
var
X: TFoo;
begin
X := TFoo.Create;
WriteLn(X.Bar);
WriteLn(X.Bar);
WriteLn(X.Bar);
X := nil;
end.
''';
procedure TE2ELeakCheckTests.TestDebug_ReceiverFieldAccess_NoLeak;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run (qbe)',
CompileAndRunWithRTLDebugOn(beQBE, SrcReceiverFieldAccess, Output, ExitCode, True));
AssertEquals('exit 0 (qbe)', 0, ExitCode);
AssertEquals('stdout (qbe)', '42' + LE, Output);
AssertTrue('no leak report (qbe), got: ' + Output, Pos('leak', Output) < 0);
AssertTrue('compile+run (native)',
CompileAndRunWithRTLDebugOn(beNative, SrcReceiverFieldAccess, Output, ExitCode, True));
AssertEquals('exit 0 (native)', 0, ExitCode);
AssertEquals('stdout (native)', '42' + LE, Output);
AssertTrue('no leak report (native), got: ' + Output, Pos('leak', Output) < 0);
end;
procedure TE2ELeakCheckTests.TestDebug_StaticArrayOfInterface_NoLeak;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run (qbe)',
CompileAndRunWithRTLDebugOn(beQBE, SrcStaticArrayOfInterface, Output, ExitCode, True));
AssertEquals('exit 0 (qbe)', 0, ExitCode);
AssertEquals('stdout (qbe)', 'abc' + LE, Output);
AssertTrue('no leak report (qbe), got: ' + Output, Pos('leak', Output) < 0);
AssertTrue('compile+run (native)',
CompileAndRunWithRTLDebugOn(beNative, SrcStaticArrayOfInterface, Output, ExitCode, True));
AssertEquals('exit 0 (native)', 0, ExitCode);
AssertEquals('stdout (native)', 'abc' + LE, Output);
AssertTrue('no leak report (native), got: ' + Output, Pos('leak', Output) < 0);
end;
procedure TE2ELeakCheckTests.TestDebug_WriteLnCallArg_NoLeak;
var
Output: string;
ExitCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run (qbe)',
CompileAndRunWithRTLDebugOn(beQBE, SrcWriteLnCallArg, Output, ExitCode, True));
AssertEquals('exit 0 (qbe)', 0, ExitCode);
AssertEquals('stdout (qbe)', 'bcd' + LE + 'bcd' + LE + 'bcd' + LE, Output);
AssertTrue('no leak report (qbe), got: ' + Output, Pos('leak', Output) < 0);
AssertTrue('compile+run (native)',
CompileAndRunWithRTLDebugOn(beNative, SrcWriteLnCallArg, Output, ExitCode, True));
AssertEquals('exit 0 (native)', 0, ExitCode);
AssertEquals('stdout (native)', 'bcd' + LE + 'bcd' + LE + 'bcd' + LE, Output);
AssertTrue('no leak report (native), got: ' + Output, Pos('leak', Output) < 0);
end;
initialization
RegisterTest(TE2ELeakCheckTests);

602
compiler/src/test/pascal/cp.test.e2e.misc.pas
View file

@ -42,25 +42,6 @@ type
{ Procedural types }
procedure TestRun_ProcType_CallViaVariable;
procedure TestRun_ProcType_OfObject_Dispatch;
{ Procedural-typed class field called through a receiver (Self.FFn(...)). }
procedure TestRun_ProcFieldCall_ReturnValue;
procedure TestRun_ProcFieldCall_Statement;
procedure TestRun_ProcFieldCall_OutParam;
procedure TestRun_ProcFieldCall_MultiArg;
{ Method-pointer (of object) field: assign @Obj.Method into a field, then
dispatch through it — exercises the 16-byte (Code, Data) field store. }
procedure TestRun_MethodPtrField_AssignAndCall;
{ Capturing @Obj.VirtualMethod must bind the receiver's dynamic override,
not the statically-resolved declared-type method. }
procedure TestRun_MethodPtrVirtualCapture_Var;
procedure TestRun_MethodPtrVirtualCapture_Field;
procedure TestRun_MethodPtrReturn;
procedure TestRun_MethodPtrReturn_ReadsSelf;
procedure TestRun_MethodPtrImplicitSelfFieldAssign;
{ Unqualified call to a procedural-typed field via implicit Self (FFn(...)
with no 'Self.' prefix), as an expression and as a statement. }
procedure TestRun_ImplicitSelfProcField_Expr;
procedure TestRun_ImplicitSelfProcField_Stmt;
{ Default parameters }
procedure TestRun_DefaultParam_OmitLast;
@ -88,26 +69,6 @@ type
{ Nested procedures }
procedure TestRun_NestedProc_MutatesCapturedVar;
{ Nested proc captures an outer VAR RECORD PARAMETER (read + write through
the var-param fields). Previously the nested proc emitted the parameter
as a global symbol reference and the program failed to link / ran wrong. }
procedure TestRun_NestedProc_CapturesVarRecordParam;
{ Nested proc captures an outer plain LOCAL record (field read + write). }
procedure TestRun_NestedProc_CapturesLocalRecord;
{ Nested proc captures an outer VAR ARRAY PARAMETER (element read + write).
The captured var-param array slot is reached through the _cap_ pointer
with one extra dereference; without it the element address resolved to a
global symbol and the writes/reads hit the wrong storage. }
procedure TestRun_NestedProc_CapturesVarArrayParam;
{ Two sibling outer routines each declare a same-named nested function.
Each call must resolve to the nested function of its own enclosing
routine. Previously the call fell through to the global overload index
(which does not list nested procs) and errored with "Cannot find
declaration". }
procedure TestRun_NestedProc_SiblingSameName_ResolvesPerScope;
{ As above but the enclosing routines are METHODS. Nested-in-method
functions must be scoped to their method body, not registered globally. }
procedure TestRun_NestedFunc_InSiblingMethods_ResolvesPerScope;
{ Diamond operator: TFoo<> infers type args from LHS }
procedure TestRun_Diamond_SingleArg_WorksAtRuntime;
@ -363,337 +324,11 @@ const
Obj := TFoo.Create();
Obj.FVal := 55;
M := @Obj.Print;
M();
M;
Obj.Free()
end.
''';
{ Function-pointer class field called through a receiver, as an expression. }
SrcProcFieldReturn = '''
program Prg;
type
TFn = function(const S: string): Integer;
TBox = class
FFn: TFn;
function Run(const S: string): Integer;
end;
function Len2(const S: string): Integer;
begin Result := Length(S) end;
function TBox.Run(const S: string): Integer;
begin Result := Self.FFn(S) end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Len2;
WriteLn(IntToStr(B.Run('hello')));
B.Free()
end.
''';
{ Function-pointer class field called as a statement. }
SrcProcFieldStmt = '''
program Prg;
type
TFn = procedure(const S: string);
TBox = class
FFn: TFn;
procedure Run;
end;
procedure Hi(const S: string);
begin WriteLn(S) end;
procedure TBox.Run;
begin Self.FFn('hi') end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Hi;
B.Run();
B.Free()
end.
''';
{ Function-pointer class field with an out parameter — the argument must be
passed by reference so the callee writes back into the caller's variable. }
SrcProcFieldOut = '''
program Prg;
type
TFn = function(const S: string; out V: string): Boolean;
TBox = class
FFn: TFn;
function Run(const S: string): string;
end;
function Echo(const S: string; out V: string): Boolean;
begin V := S; Result := True end;
function TBox.Run(const S: string): string;
var V: string;
begin
if Self.FFn(S, V) then Result := V else Result := '?'
end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Echo;
WriteLn(B.Run('hi'));
B.Free()
end.
''';
{ Function-pointer class field with several value arguments. }
SrcProcFieldMultiArg = '''
program Prg;
type
TFn = function(A, B, C: Integer): Integer;
TBox = class
FFn: TFn;
function Run(X: Integer): Integer;
end;
function Sum3(A, B, C: Integer): Integer;
begin Result := A + B + C end;
function TBox.Run(X: Integer): Integer;
begin Result := Self.FFn(X, X + 1, X + 2) end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Sum3;
WriteLn(IntToStr(B.Run(10)));
B.Free()
end.
''';
{ Method-pointer (of object) class field: capture @Obj.Method into a field
and call through it. The capture stores a 16-byte (Code, Data) pair. }
SrcMethodPtrField = '''
program Prg;
type
TEvt = procedure(const S: string) of object;
TSrc = class
Tag: string;
procedure Handle(const S: string);
end;
TBox = class
FEvt: TEvt;
procedure Fire(const S: string);
end;
procedure TSrc.Handle(const S: string);
begin WriteLn(Self.Tag, ':', S) end;
procedure TBox.Fire(const S: string);
begin Self.FEvt(S) end;
var B: TBox; S: TSrc;
begin
S := TSrc.Create(); S.Tag := 'T';
B := TBox.Create();
B.FEvt := @S.Handle;
B.Fire('hello');
B.Free();
S.Free()
end.
''';
{ Method-pointer capture of a VIRTUAL method through a base-typed variable:
A is declared TAnimal but holds a TDog, so @A.Speak must capture TDog's
override (print 'dog'), resolving the Code half through A's vtable rather
than freezing the declared type's TAnimal.Speak. }
SrcMethodPtrVirtualCaptureVar = '''
program Prg;
type
TSpeak = procedure of object;
TAnimal = class
procedure Speak; virtual;
end;
TDog = class(TAnimal)
procedure Speak; override;
end;
procedure TAnimal.Speak;
begin WriteLn('animal') end;
procedure TDog.Speak;
begin WriteLn('dog') end;
var A: TAnimal; M: TSpeak;
begin
A := TDog.Create();
M := @A.Speak;
M();
A.Free()
end.
''';
{ Same dynamic-dispatch capture, but stored into a class FIELD rather than a
local variable — exercises the field-destination assignment path. }
SrcMethodPtrVirtualCaptureField = '''
program Prg;
type
TSpeak = procedure of object;
TAnimal = class
procedure Speak; virtual;
end;
TDog = class(TAnimal)
procedure Speak; override;
end;
TBox = class
M: TSpeak;
end;
procedure TAnimal.Speak;
begin WriteLn('animal') end;
procedure TDog.Speak;
begin WriteLn('dog') end;
var A: TAnimal; B: TBox;
begin
A := TDog.Create();
B := TBox.Create();
B.M := @A.Speak;
B.M();
B.Free();
A.Free()
end.
''';
{ A method returning a 'function ... of object' value. The return is a
16-byte (Code, Data) aggregate; it must travel back by the two-register/
sret record-return ABI rather than a scalar that drops the Data half.
Op(3, 4) invokes the captured method pointer and must print 7. }
SrcMethodPtrReturn = '''
program Prg;
type TBinOp = function(X, Y: Integer): Integer of object;
type
TCalc = class
function Add(X, Y: Integer): Integer;
function GetOp: TBinOp;
end;
function TCalc.Add(X, Y: Integer): Integer;
begin Result := X + Y end;
function TCalc.GetOp: TBinOp;
begin Result := @Self.Add end;
var C: TCalc; Op: TBinOp;
begin
C := TCalc.Create();
Op := C.GetOp();
WriteLn(Op(3, 4));
C.Free()
end.
''';
{ Method pointer whose RETURNED method READS an instance field (Self.Base).
A method ptr is a 16-byte [Code; Data] aggregate; if a backend returns only
the Code half the Data (Self) pointer is lost and the invoked method
dereferences garbage — which it only observes when it actually uses Self.
SrcMethodPtrReturn's Add(X,Y)=X+Y never touches Self, so it cannot catch
that defect; this one does, on every backend. Also exercises a field
destination (Self.FStored), a free-function method-ptr return, and an
immediate invoke of the returned pointer (C.GetFn()(9)). }
SrcMethodPtrReturnSelf = '''
program Prg;
type TFn = function(X: Integer): Integer of object;
type
TCalc = class
Base: Integer;
FStored: TFn;
function AddBase(X: Integer): Integer;
function GetFn: TFn;
procedure StoreFn;
function CallStored(X: Integer): Integer;
end;
function TCalc.AddBase(X: Integer): Integer;
begin Result := Self.Base + X end;
function TCalc.GetFn: TFn;
begin Result := @Self.AddBase end;
procedure TCalc.StoreFn;
begin Self.FStored := Self.GetFn() end;
function TCalc.CallStored(X: Integer): Integer;
begin Result := Self.FStored(X) end;
var GC: TCalc;
function GetGlobalFn: TFn;
begin Result := @GC.AddBase end;
var C: TCalc; F: TFn;
begin
C := TCalc.Create();
C.Base := 100;
F := C.GetFn();
WriteLn(F(7));
C.StoreFn();
WriteLn(C.CallStored(5));
GC := C;
F := GetGlobalFn();
WriteLn(F(3));
WriteLn(C.GetFn()(9));
C.Free()
end.
''';
{ Assigning @Self.Method to a bare (implicit-Self) method-pointer field:
FFn := @Self.DoIt inside a method, with no 'Self.' on the LHS. DoIt reads
another field through Self, so a wrong Data half (the bug) would crash or
print garbage rather than 'T:x'. }
SrcMethodPtrImplicitSelfFieldAssign = '''
program Prg;
type
TProc = procedure(const S: string) of object;
TA = class
FName: string;
FFn: TProc;
procedure DoIt(const S: string);
procedure Fire;
end;
procedure TA.DoIt(const S: string);
begin WriteLn(FName + ':' + S) end;
procedure TA.Fire;
begin
FFn := @Self.DoIt;
FFn('x')
end;
var A: TA;
begin
A := TA.Create();
A.FName := 'T';
A.Fire();
A.Free()
end.
''';
{ Unqualified (implicit-Self) call to a procedural-typed field, as an
expression — FFn(...) with no 'Self.' prefix. }
SrcImplicitProcFieldExpr = '''
program Prg;
type
TFn = function(A, B, C: Integer): Integer;
TBox = class
FFn: TFn;
function Run(X: Integer): Integer;
end;
function Sum3(A, B, C: Integer): Integer;
begin Result := A + B + C end;
function TBox.Run(X: Integer): Integer;
begin Result := FFn(X, X + 1, X + 2) end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Sum3;
WriteLn(IntToStr(B.Run(10)));
B.Free()
end.
''';
{ Unqualified (implicit-Self) call to a procedural-typed field, as a
statement. }
SrcImplicitProcFieldStmt = '''
program Prg;
type
TFn = procedure(const S: string);
TBox = class
FFn: TFn;
procedure Run;
end;
procedure Hi(const S: string);
begin WriteLn(S) end;
procedure TBox.Run;
begin FFn('hi') end;
var B: TBox;
begin
B := TBox.Create();
B.FFn := @Hi;
B.Run();
B.Free()
end.
''';
SrcDefaultParam = '''
program Prg;
function Add(A: Integer; B: Integer = 10): Integer;
@ -1011,81 +646,6 @@ begin
AssertEquals('55', '55' + LE, Output);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_ReturnValue;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldReturn, '5' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_Statement;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldStmt, 'hi' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_OutParam;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldOut, 'hi' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ProcFieldCall_MultiArg;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcProcFieldMultiArg, '33' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrField_AssignAndCall;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrField, 'T:hello' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Var;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrVirtualCaptureVar, 'dog' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Field;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrVirtualCaptureField, 'dog' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrReturn;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrReturn, '7' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrReturn_ReadsSelf;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 107, 105, 103, 109 — each line proves the Data (Self) half of the returned
16-byte method pointer survived: AddBase reads Self.Base (100). }
AssertRunsOnAll(SrcMethodPtrReturnSelf,
'107' + LE + '105' + LE + '103' + LE + '109' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_MethodPtrImplicitSelfFieldAssign;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcMethodPtrImplicitSelfFieldAssign, 'T:x' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Expr;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcImplicitProcFieldExpr, '33' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Stmt;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcImplicitProcFieldStmt, 'hi' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_DefaultParam_OmitLast;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
@ -1199,11 +759,11 @@ const
begin
x := 5;
WriteLn(IntToStr(x));
Inner();
Inner;
WriteLn(IntToStr(x))
end;
begin
Outer()
Outer
end.
''';
var Output: string; RCode: Integer;
@ -1215,162 +775,6 @@ begin
'5' + LE + '15' + LE + '15' + LE, Output);
end;
procedure TE2EMiscTests.TestRun_NestedProc_SiblingSameName_ResolvesPerScope;
const
Src =
'''
program Prg;
procedure First;
function Helper(X: Integer): Integer;
begin
Result := X + 1
end;
begin
WriteLn(IntToStr(Helper(10)))
end;
procedure Second;
function Helper(X: Integer): Integer;
begin
Result := X + 2
end;
begin
WriteLn(IntToStr(Helper(20)))
end;
begin
First();
Second()
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('First.Helper(10)=11, Second.Helper(20)=22',
'11' + LE + '22' + LE, Output);
end;
procedure TE2EMiscTests.TestRun_NestedFunc_InSiblingMethods_ResolvesPerScope;
const
Src =
'''
program Prg;
type
TFoo = class
procedure MethodA;
procedure MethodB;
end;
procedure TFoo.MethodA;
function Helper(X: Integer): Integer;
begin
Result := X + 1
end;
begin
WriteLn(IntToStr(Helper(10)))
end;
procedure TFoo.MethodB;
function Helper(X: Integer): Integer;
begin
Result := X + 2
end;
begin
WriteLn(IntToStr(Helper(20)))
end;
var F: TFoo;
begin
F := TFoo.Create;
F.MethodA();
F.MethodB()
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('MethodA.Helper(10)=11, MethodB.Helper(20)=22',
'11' + LE + '22' + LE, Output);
end;
procedure TE2EMiscTests.TestRun_NestedProc_CapturesVarRecordParam;
const
Src =
'''
program Prg;
type TRec = record A, B: Integer; end;
procedure Outer(var R: TRec);
procedure Inner;
var Sum: Integer;
begin
Sum := R.A + R.B;
R.A := Sum;
R.B := Sum * 2
end;
begin
Inner()
end;
var Rec: TRec;
begin
Rec.A := 3; Rec.B := 4;
Outer(Rec);
WriteLn(IntToStr(Rec.A), ' ', IntToStr(Rec.B))
end.
''';
begin
AssertRunsOnAll(Src, '7 14' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_NestedProc_CapturesLocalRecord;
const
Src =
'''
program Prg;
type TRec = record A, B: Integer; end;
procedure Outer;
var R: TRec;
procedure Inner;
begin
R.A := R.A + 10;
R.B := R.B + 20
end;
begin
R.A := 1; R.B := 2;
Inner();
WriteLn(IntToStr(R.A), ' ', IntToStr(R.B))
end;
begin
Outer()
end.
''';
begin
AssertRunsOnAll(Src, '11 22' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_NestedProc_CapturesVarArrayParam;
const
Src =
'''
program Prg;
type TArr = array[0..2] of Integer;
procedure Outer(var A: TArr);
procedure Inner;
begin
A[0] := 10; A[1] := 20; A[2] := A[0] + A[1]
end;
begin
Inner()
end;
var Ar: TArr;
begin
Ar[0] := 0; Ar[1] := 0; Ar[2] := 0;
Outer(Ar);
WriteLn(IntToStr(Ar[0]), ' ', IntToStr(Ar[1]), ' ', IntToStr(Ar[2]))
end.
''';
begin
AssertRunsOnAll(Src, '10 20 30' + LE, 0);
end;
procedure TE2EMiscTests.TestRun_Diamond_SingleArg_WorksAtRuntime;
const
Src = '''

92
compiler/src/test/pascal/cp.test.e2e.native.pas
View file

@ -386,10 +386,6 @@ type
{ Record value assigned into a record-typed field of the sret Result
must be a full ARC-aware copy, not an 8-byte pointer store. }
procedure TestRun_Native_SretResult_NestedRecordFieldAssign;
{ Regression: implicit-Self method calls whose Self+args exceed six integer
registers must spill the overflow to the stack (the expression path used
to abort codegen with 'arg register index 6 out of range'). }
procedure TestRun_Native_ImplicitSelfCall_RegisterOverflow;
{ Subscripting a string-typed FIELD (Rec.S[I] / Obj.Data[I]) must be
0-based like every other Blaise subscript (regression: QBE
subtracted 1, native read garbage through the unhandled path). }
@ -1226,7 +1222,7 @@ const
WriteLn(D)
end;
begin
ShowDouble()
ShowDouble
end.
''';
@ -1421,43 +1417,6 @@ const
end.
''';
{ Implicit-Self method calls whose register slots (Self + args) exceed the
six System V integer registers must spill the overflow to the stack — the
implicit-Self expression path previously aborted codegen. Covers a
non-virtual call (Self + 8 args = 9 slots, 3 spilled) and a virtual/vtable
call (Self + 7 args = 8 slots, 2 spilled); the values verify that every
arg, including the spilled ones, arrives intact. }
SrcImplicitSelfArgOverflow = '''
program Prg;
type
TWorker = class
function Sum8(a, b, c, d, e, f, g, h: Integer): Integer;
function VSum7(a, b, c, d, e, f, g: Integer): Integer; virtual;
function Drive(): string;
end;
function TWorker.Sum8(a, b, c, d, e, f, g, h: Integer): Integer;
begin
Result := a + b + c + d + e + f + g + h;
end;
function TWorker.VSum7(a, b, c, d, e, f, g: Integer): Integer;
begin
Result := a * 1 + b * 2 + c * 3 + d * 4 + e * 5 + f * 6 + g * 7;
end;
function TWorker.Drive(): string;
begin
WriteLn(Sum8(1, 2, 3, 4, 5, 6, 7, 8));
WriteLn(VSum7(1, 1, 1, 1, 1, 1, 1));
Result := 'ok';
end;
var
W: TWorker;
begin
W := TWorker.Create();
WriteLn(W.Drive());
W.Free();
end.
''';
const
SrcStringFieldCharRead = '''
program Prg;
@ -1487,7 +1446,7 @@ const
WriteLn(B.Data[4]);
WriteLn(B.Data[I + 2]);
WriteLn(B.At(1));
B.Free();
B.Free;
end.
''';
@ -1513,13 +1472,6 @@ begin
'1' + LE + '5' + LE + '7' + LE + '70' + LE + 'x' + LE + '9' + LE, 0);
end;
procedure TE2ENativeTests.TestRun_Native_ImplicitSelfCall_RegisterOverflow;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcImplicitSelfArgOverflow,
'36' + LE + '28' + LE + 'ok' + LE, 0);
end;
procedure TE2ENativeTests.TestRun_Native_EmptyProgram_ExitsZero;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
@ -2843,13 +2795,13 @@ const
end;
procedure Tmi.use;
begin
im.print();
im.print;
end;
var
im: Tmi;
begin
im := Tmi.Create(Toutput.Create());
im.use();
im.use;
end.
''';
@ -3157,7 +3109,7 @@ const
destructor TThing.Destroy;
begin
WriteLn('destroyed');
inherited Destroy()
inherited Destroy
end;
var O: TThing;
begin
@ -3486,7 +3438,7 @@ const
destructor TVal.Destroy;
begin
WriteLn('destroyed');
inherited Destroy()
inherited Destroy
end;
var
S: IVal;
@ -3624,7 +3576,7 @@ const
destructor TGreeter.Destroy;
begin
WriteLn('greeter-gone');
inherited Destroy()
inherited Destroy
end;
var
H: THolder;
@ -3659,7 +3611,7 @@ const
destructor TInner.Destroy;
begin
WriteLn('inner-gone');
inherited Destroy()
inherited Destroy
end;
var H: THolder;
begin
@ -4966,7 +4918,7 @@ begin
begin
B := TBox.Create(99);
WriteLn(B.Val);
B.Free()
B.Free
end.
''',
'99' + LE, 0);
@ -4992,7 +4944,7 @@ begin
A := TArr.Create;
WriteLn(A.Items[0]);
WriteLn(A.Items[1]);
A.Free()
A.Free
end.
''',
'10' + LE + '30' + LE, 0);
@ -5018,7 +4970,7 @@ begin
B := TBox.Create;
B.Val := 42;
WriteLn(B.Val);
B.Free()
B.Free
end.
''',
'42' + LE, 0);
@ -5046,7 +4998,7 @@ begin
A.Items[1] := 30;
WriteLn(A.Items[0]);
WriteLn(A.Items[1]);
A.Free()
A.Free
end.
''',
'10' + LE + '30' + LE, 0);
@ -5062,7 +5014,7 @@ begin
begin
F := TFoo.Create;
WriteLn(F.ClassName);
F.Free()
F.Free
end.
''',
'TFoo' + LE, 0);
@ -5084,7 +5036,7 @@ begin
begin
Obj := TCalc.Create;
WriteLn(Obj.Sum6(1, 2, 3, 4, 5, 6));
Obj.Free()
Obj.Free
end.
''',
'21' + LE, 0);
@ -5109,8 +5061,8 @@ begin
O := TOuter.Create;
O.FInner := I;
WriteLn(O.GetVal());
O.Free();
I.Free()
O.Free;
I.Free
end.
''',
'42' + LE, 0);
@ -5137,8 +5089,8 @@ begin
begin
O := TMyObj.Create;
O.FVal := 99;
O.Show();
O.Free()
O.Show;
O.Free
end.
''',
'99' + LE, 0);
@ -5176,7 +5128,7 @@ begin
begin
B := TChild.Create;
WriteLn(B.GetVal());
B.Free()
B.Free
end.
''',
'42' + LE, 0);
@ -5322,7 +5274,7 @@ begin
procedure TCalc.Run;
begin
FVal := 5;
Step();
Step;
WriteLn(FVal);
WriteLn(Double())
end;
@ -5360,8 +5312,8 @@ begin
var P: TParser;
begin
P := TParser.Create();
P.Setup();
P.Advance();
P.Setup;
P.Advance;
WriteLn(P.FA.Kind, ':', P.FA.Value, ':', P.FA.Line, ':', P.FA.Col);
WriteLn(P.FB.Kind, ':', P.FB.Value, ':', P.FB.Line, ':', P.FB.Col);
P.Free()

183
compiler/src/test/pascal/cp.test.e2e.properties.pas
View file

@ -35,17 +35,6 @@ type
procedure TestRun_DefaultProperty_ReadWrite;
procedure TestRun_DefaultProperty_StringElement;
procedure TestRun_DefaultProperty_Inherited;
{ Default array property read through a property-read result:
Obj.Prop[I] where Prop returns a class carrying a default property. }
procedure TestRun_DefaultProperty_ViaFieldBackedProperty;
procedure TestRun_DefaultProperty_ViaMethodBackedProperty;
{ Write through a default array property on a member result:
Obj.Field[I] := V and Obj.Prop[I] := V. }
procedure TestRun_DefaultProperty_WriteThroughField;
procedure TestRun_DefaultProperty_WriteThroughProperty;
{ Implicit-Self write/read: Field[I] := V / Field[I] inside a method, where
Field is a class with a default array property. }
procedure TestRun_DefaultProperty_WriteThroughImplicitSelf;
{ Static-array field accessed from inside a method (implicit Self). }
procedure TestRun_StaticArrayField_ReadInMethod;
procedure TestRun_StaticArrayField_WriteInMethod;
@ -305,178 +294,6 @@ begin
AssertRunsOnAll(SrcDefaultInherited, '12' + LE, 0);
end;
const
{ Obj.Prop[I] where Prop is a field-backed property returning a class with a
default array property — reads through the property result. }
SrcDefaultViaFieldProp = '''
program P;
type
TVec = class
FData: array[0..4] of Integer;
function Get(i: Integer): Integer; begin Result := FData[i] end;
procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
property Items[i: Integer]: Integer read Get write Put; default;
end;
TOwner = class
FVec: TVec;
constructor Create;
property Vec: TVec read FVec;
end;
constructor TOwner.Create;
begin
inherited Create();
FVec := TVec.Create;
FVec.Put(0, 3); FVec.Put(1, 4);
end;
var o: TOwner;
begin
o := TOwner.Create;
WriteLn(o.Vec[0] + o.Vec[1]);
o := nil
end.
''';
{ Same, but Prop is a method-backed (getter) property. }
SrcDefaultViaMethodProp = '''
program P;
type
TVec = class
FData: array[0..4] of Integer;
function Get(i: Integer): Integer; begin Result := FData[i] end;
procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
property Items[i: Integer]: Integer read Get write Put; default;
end;
TOwner = class
FVec: TVec;
constructor Create;
function GetVec: TVec; begin Result := FVec end;
property Vec: TVec read GetVec;
end;
constructor TOwner.Create;
begin
inherited Create();
FVec := TVec.Create;
FVec.Put(0, 5); FVec.Put(1, 4);
end;
var o: TOwner;
begin
o := TOwner.Create;
WriteLn(o.Vec[0] + o.Vec[1]);
o := nil
end.
''';
procedure TE2EPropertyTests.TestRun_DefaultProperty_ViaFieldBackedProperty;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDefaultViaFieldProp, '7' + LE, 0);
end;
procedure TE2EPropertyTests.TestRun_DefaultProperty_ViaMethodBackedProperty;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDefaultViaMethodProp, '9' + LE, 0);
end;
const
{ Write through a class field's default property: Obj.Field[I] := V. }
SrcDefaultWriteField = '''
program P;
type
TVec = class
FData: array[0..4] of Integer;
function Get(i: Integer): Integer; begin Result := FData[i] end;
procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
property Items[i: Integer]: Integer read Get write Put; default;
end;
TOwner = class
FVec: TVec;
constructor Create;
property Vec: TVec read FVec;
end;
constructor TOwner.Create; begin inherited Create(); FVec := TVec.Create end;
var o: TOwner;
begin
o := TOwner.Create;
o.FVec[0] := 3; o.FVec[1] := 4;
WriteLn(o.Vec[0] + o.Vec[1]);
o := nil
end.
''';
{ Write through a read-only property's result default property:
Obj.Prop[I] := V. }
SrcDefaultWriteProp = '''
program P;
type
TVec = class
FData: array[0..4] of Integer;
function Get(i: Integer): Integer; begin Result := FData[i] end;
procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
property Items[i: Integer]: Integer read Get write Put; default;
end;
TOwner = class
FVec: TVec;
constructor Create;
property Vec: TVec read FVec;
end;
constructor TOwner.Create; begin inherited Create(); FVec := TVec.Create end;
var o: TOwner;
begin
o := TOwner.Create;
o.Vec[0] := 5; o.Vec[1] := 4;
WriteLn(o.Vec[0] + o.Vec[1]);
o := nil
end.
''';
procedure TE2EPropertyTests.TestRun_DefaultProperty_WriteThroughField;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDefaultWriteField, '7' + LE, 0);
end;
procedure TE2EPropertyTests.TestRun_DefaultProperty_WriteThroughProperty;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDefaultWriteProp, '9' + LE, 0);
end;
const
{ Implicit Self.Field[I] := V and Field[I] read, inside methods. }
SrcDefaultWriteImplicitSelf = '''
program P;
type
TVec = class
FData: array[0..4] of Integer;
function Get(i: Integer): Integer; begin Result := FData[i] end;
procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
property Items[i: Integer]: Integer read Get write Put; default;
end;
TOwner = class
FVec: TVec;
constructor Create;
procedure Fill;
function Sum: Integer;
end;
constructor TOwner.Create; begin inherited Create(); FVec := TVec.Create end;
procedure TOwner.Fill; begin FVec[0] := 3; FVec[1] := 4; end;
function TOwner.Sum: Integer; begin Result := FVec[0] + FVec[1]; end;
var o: TOwner;
begin
o := TOwner.Create;
o.Fill();
WriteLn(o.Sum());
o := nil
end.
''';
procedure TE2EPropertyTests.TestRun_DefaultProperty_WriteThroughImplicitSelf;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcDefaultWriteImplicitSelf, '7' + LE, 0);
end;
initialization
RegisterTest(TE2EPropertyTests);

300
compiler/src/test/pascal/cp.test.e2e.recordret.pas
View file

@ -97,14 +97,6 @@ type
procedure TestRun_ChainedRecvManyArgs;
procedure TestRun_ChainedRecvDoubleChain;
procedure TestRun_ChainedRecvManagedRecord_TDecimalLike;
{ Regression: a record-returning method assigned back into the SAME variable
that is its receiver (M := M.Method(...)). The sret destination buffer
would alias Self, so the callee wrote Result (== Self) while still reading
Self — clobbering it mid-flight. Fix routes the call through a fresh temp
and moves the result into the destination only after the call returns.
Both backends; managed (string) and scalar fields both checked. }
procedure TestRun_SelfAssignRecordMethod_ManagedField;
procedure TestRun_SelfAssignRecordMethod_ScalarFields;
{ Regression: a record-returning method that takes an INTERFACE parameter.
An interface is a fat pointer (obj + itab) occupying TWO integer-register
slots, but the native sret/record call paths popped one register per
@ -124,36 +116,6 @@ type
already fixed; this covers the free-function path. Both backends. }
procedure TestRun_InterfaceArg_FreeFunc_SretReturn;
procedure TestRun_InterfaceArg_FreeFunc_IntThenInterface;
{ Regression: an override that returns a record with a managed (string)
field by value, sourced from `inherited`. The inherited call path
dropped the hidden sret pointer and passed Self into the sret slot, so
the base wrote its managed field over the Self object and _StringRelease
ran on garbage → heap corruption / segfault. Both backends. Covers the
assignment form (Result := inherited M()) and the implicit-Result
statement form (inherited M;). }
procedure TestRun_InheritedRecordReturn_ManagedField;
procedure TestRun_InheritedRecordReturn_StatementForm;
{ Regression: reading the OFFSET-0 field of an sret function's own Result
mid-body (read-modify) after assigning Result from a record-returning
call. The native offset-0 field-read shortcut loaded the Result slot
directly — but for an sret function that slot holds a POINTER to the
record, so the buffer pointer was read as the field value (garbage).
Offset>0 fields were fine (they always deref). Both backends. (The fix
lives in the inline-asm commit; this test, from Andrew's parallel fix,
locks it in.) }
procedure TestRun_SretResult_ReadModifyOffsetZeroField;
{ Regression: calling a record-returning METHOD as a statement (result
discarded) with no assignment target. The SysV sret ABI puts the sret
pointer in %rdi and Self in %rsi, but without a buffer the callee wrote
the record through Self, corrupting the object. Both backends. }
procedure TestRun_DiscardedRecordReturn_ManagedField;
{ Same for a small record with only scalar fields (register-returned,
not sret) — the return value goes to %rax and is harmlessly discarded,
but we must verify codegen doesn't crash. }
procedure TestRun_DiscardedRecordReturn_ScalarOnly;
{ Discarded record-returning call via an expression receiver
(Obj.RecordMethod();). Tests the ObjExpr path. }
procedure TestRun_DiscardedRecordReturn_ObjExprReceiver;
end;
implementation
@ -671,7 +633,7 @@ const
K := TMaker.Create;
R := K.Make(0.25);
WriteLn(R.X);
K.Free()
K.Free
end.
''';
begin
@ -817,60 +779,6 @@ begin
AssertRunsOnAll(Src, '15' + LE + '25' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_SelfAssignRecordMethod_ManagedField;
const
{ Managed (string) field record method assigned back into its own receiver.
The non-aliasing case (C := A.Up(B)) and the receiver staying intact after
the self-assign are both checked as regression guards. }
Src = '''
program P;
type
TR = record
S: string;
function Up(const X: TR): TR;
end;
function TR.Up(const X: TR): TR;
begin Result.S := Self.S + X.S end;
var A, B, C: TR;
begin
A.S := 'a'; B.S := 'b';
A := A.Up(B);
WriteLn(A.S);
C := A.Up(B);
WriteLn(C.S);
WriteLn(A.S)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, 'ab' + LE + 'abb' + LE + 'ab' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_SelfAssignRecordMethod_ScalarFields;
const
{ Two-integer record (register-return class) self-assigned through its own
receiver. }
Src = '''
program P;
type
TR = record
A, B: Integer;
function Add(const X: TR): TR;
end;
function TR.Add(const X: TR): TR;
begin Result.A := Self.A + X.A; Result.B := Self.B + X.B end;
var R, Q: TR;
begin
R.A := 1; R.B := 10; Q.A := 2; Q.B := 20;
R := R.Add(Q);
WriteLn(R.A, ' ', R.B)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, '3 30' + LE, 0);
end;
{ ------------------------------------------------------------------ }
{ Record-returning method with an interface (fat-pointer) parameter }
{ ------------------------------------------------------------------ }
@ -1013,212 +921,6 @@ begin
AssertRunsOnAll(Src, '12' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_InheritedRecordReturn_ManagedField;
const
Src = '''
program P;
type
TTok = record Kind: Integer; Value: string; Line: Integer; end;
TBase = class
function Next(N: Integer): TTok; virtual;
end;
TDeriv = class(TBase)
function Next(N: Integer): TTok; override;
end;
function TBase.Next(N: Integer): TTok;
begin
Result.Kind := N;
Result.Value := 'hello-world';
Result.Line := 99
end;
function TDeriv.Next(N: Integer): TTok;
begin
Result := inherited Next(N)
end;
var D: TDeriv; T: TTok;
begin
D := TDeriv.Create();
T := D.Next(7);
WriteLn(T.Kind);
WriteLn(T.Value);
WriteLn(T.Line);
D.Free()
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, '7' + LE + 'hello-world' + LE + '99' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_InheritedRecordReturn_StatementForm;
const
Src = '''
program P;
type
TTok = record Kind: Integer; Value: string; end;
TBase = class
function Make(N: Integer): TTok; virtual;
end;
TDeriv = class(TBase)
function Make(N: Integer): TTok; override;
end;
function TBase.Make(N: Integer): TTok;
begin
Result.Kind := N + 100;
Result.Value := 'base'
end;
function TDeriv.Make(N: Integer): TTok;
begin
inherited Make(N)
end;
var D: TDeriv; T: TTok;
begin
D := TDeriv.Create();
T := D.Make(5);
WriteLn(T.Kind);
WriteLn(T.Value);
D.Free()
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ `inherited Make(N);` with no explicit assignment sets the override's
Result through the sret pointer. }
AssertRunsOnAll(Src, '105' + LE + 'base' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_SretResult_ReadModifyOffsetZeroField;
const
Src = '''
program P;
type TR = record A: Integer; S: string; B: Integer; end;
function Raw(N: Integer): TR;
begin
Result.A := N;
Result.S := 'hi';
Result.B := 20
end;
function Make(N: Integer): TR;
begin
Result := Raw(N);
Result.A := Result.A + 1
end;
var R: TR;
begin
R := Make(10);
WriteLn(R.A, ' ', R.S, ' ', R.B)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ The string field forces a genuine sret return (24 bytes); reading
Result.A (offset 0) mid-body must deref the Result pointer. }
AssertRunsOnAll(Src, '11 hi 20' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_DiscardedRecordReturn_ManagedField;
const
Src = '''
program P;
type
TToken = record
Kind: Integer;
Value: string;
end;
TLexer = class
FName: string;
function Next(): TToken;
function GetName(): string;
end;
function TLexer.Next(): TToken;
begin
Result.Kind := 42;
Result.Value := 'hello'
end;
function TLexer.GetName(): string;
begin
Result := FName
end;
var L: TLexer;
begin
L := TLexer.Create();
L.FName := 'mylex';
L.Next();
WriteLn(L.GetName());
L.Free()
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, 'mylex' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_DiscardedRecordReturn_ScalarOnly;
const
Src = '''
program P;
type
TPoint = record X, Y: Integer; end;
TObj = class
function Pos(): TPoint;
end;
function TObj.Pos(): TPoint;
begin
Result.X := 10;
Result.Y := 20
end;
var O: TObj;
begin
O := TObj.Create();
O.Pos();
WriteLn('ok');
O.Free()
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, 'ok' + LE, 0);
end;
procedure TE2ERecordReturnTests.TestRun_DiscardedRecordReturn_ObjExprReceiver;
const
Src = '''
program P;
type
TRec = record N: Integer; S: string; end;
TFactory = class
FTag: string;
function Make(): TRec;
function GetTag(): string;
end;
THolder = class
F: TFactory;
end;
function TFactory.Make(): TRec;
begin
Result.N := 7;
Result.S := 'test'
end;
function TFactory.GetTag(): string;
begin
Result := FTag
end;
var H: THolder;
begin
H := THolder.Create();
H.F := TFactory.Create();
H.F.FTag := 'mytag';
H.F.Make();
WriteLn(H.F.GetTag());
H.F.Free();
H.Free()
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(Src, 'mytag' + LE, 0);
end;
initialization
RegisterTest(TE2ERecordReturnTests);

39
compiler/src/test/pascal/cp.test.e2e.records.pas
View file

@ -27,7 +27,6 @@ type
procedure TestRun_Record_PassByVar;
procedure TestRun_Record_AssignToVarParam;
procedure TestRun_Record_StringField_ARC;
procedure TestRun_Record_VarToVarCopy_StringField_ARC;
procedure TestRun_Record_NestedRecord;
procedure TestRun_Record_FourByteFields_PackedAndRoundTrip;
procedure TestRun_Record_ByteThenInteger_RoundTrip;
@ -645,42 +644,6 @@ begin
AssertEquals('Ada Lovelace', 'Ada Lovelace' + LE, Output);
end;
const
{ Copying a record with a managed (string) field var-to-var (B := A) must
field-copy with ARC: AddRef the source's string so the copy owns its own
reference, and Release the destination's prior string. A bare memcpy left
both records sharing one buffer at refcount 1 — mutating/churning the source
then dropped it to 0 and freed it, so the copy held a dangling pointer
(use-after-free → '_StringRelease double-free' abort). This is the same
record-copy path TList<TRec>.Get uses (Result := Src^), so it also fixes the
generic-container crash. }
SrcRecordVarToVarCopy = '''
program Prg;
type
TPerson = record Name: string; Age: Integer; end;
var
A, B: TPerson;
I: Integer;
begin
A.Name := 'Alice-' + IntToStr(42);
A.Age := 30;
B := A;
A.Name := 'Bob';
for I := 0 to 200 do
A.Name := 'churn-' + IntToStr(I);
WriteLn(B.Name, ' ', B.Age)
end.
''';
procedure TE2ERecordsTests.TestRun_Record_VarToVarCopy_StringField_ARC;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(SrcRecordVarToVarCopy, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('copy retained own string', 'Alice-42 30' + LE, Output);
end;
procedure TE2ERecordsTests.TestRun_Record_NestedRecord;
var Output: string; RCode: Integer;
begin
@ -967,7 +930,7 @@ const
var c: TC;
begin
c := TC.Create();
c.Fill();
c.Fill;
writeln(c.A[0]);
writeln(c.A[1]);
writeln(c.A[2]);

684
compiler/src/test/pascal/cp.test.e2e.sepcompile.pas
View file

@ -49,27 +49,6 @@ type
procedure TestDuplicateExternalAcrossUnits_Compiles;
procedure TestNativeIncremental_MultiUnitClass_Compiles;
procedure TestNativeNoIncremental_MultiUnitClass_Compiles;
{ Regression: a class declared in a unit's IMPLEMENTATION section (not its
interface) was rejected at compile and never had its method bodies /
typeinfo / vtable / _FieldCleanup emitted — both backends' unit-emission
loops only walked IntfBlock.TypeDecls. The fix registers impl-section
types unit-private, analyses their method bodies, and emits them
alongside IntfBlock ones. }
procedure TestNativeImplSectionClass_Compiles;
procedure TestQBEImplSectionClass_Compiles;
{ Regression: an IMPLEMENTATION-section class referenced as a METACLASS value
(class-of / `TFoo` used as a value) in the unit's OWN initialization block.
Per-unit codegen left DefineOwningUnit pointing at a dependency unit by the
time the init block was emitted, so the impl-section class symbol was
suppressed by Lookup's cross-unit-leak guard and the metaclass ref mangled
to a bare, undefined typeinfo symbol -> link-time garbage -> SIGSEGV.
Both backends. }
procedure TestNativeImplSectionMetaclassInInit_Runs;
procedure TestQBEImplSectionMetaclassInInit_Runs;
{ Regression: a class declared in unit A's IMPLEMENTATION section must NOT
be visible to an unrelated unit B that never `uses` A — it previously
leaked through the flat global scope. }
procedure TestImplSectionClass_DoesNotLeakCrossUnit;
{ Regression: compiling a UNIT (unit-mode, top source is a `unit`) that
USES another unit, with the default incremental path, segfaulted — the
incremental worker setup read Prog.SymbolTable, but in unit-mode Prog is
@ -106,29 +85,7 @@ type
object's fields stayed nil. This crashed the stdlib JSON test suite
when its TTestCase base came from target/units. }
procedure TestIncrementalRebuild_VirtualCtorVtableSlot;
{ Regression (bugs.txt warm --unit-cache): a leaf class inherits a method
from a GRANDPARENT class that lives in a different cached unit. On a
warm rebuild the leaf unit recompiles from source while its ancestors
load from cached .bif ifaces. A cross-unit parent is serialised in the
.bif with its unit qualifier (e.g. `base.TBase`); the importer resolved
the parent with a bare Lookup that missed the qualified name, leaving the
intermediate class's Parent pointer nil — so the leaf's inherited-method
walk dead-ended and reported "Undeclared procedure". }
procedure TestIncrementalRebuild_QualifiedGrandparentMethod;
procedure TestDebugOpdf_PerUnitSection_InDependencyObject;
{ Regression (F1-followup cross-unit static members): a class with `static`
members — a static var, a static method, and a static const — declared in
one unit and used through the COMPILED .bif boundary from another unit.
The wire format already encoded the static facts, but the export clone
dropped TFieldDecl.IsClassVar/ClassVarEmitName, TMethodDecl.IsStatic and
TPropertyDecl.IsStatic before encoding; the importer ignored them and the
decoded ConstDecls; and TRoutineSig carried no IsStatic field at all. So
a cross-unit TReg.Next() failed with "is not a static method", a static
var did not register as a shared global, and TReg.Tag did not resolve.
Driving through --unit-cache exercises the real .bif write+read path on
both backends. }
procedure TestStaticMembers_CrossUnit_QBE;
procedure TestStaticMembers_CrossUnit_Native;
end;
implementation
@ -659,375 +616,6 @@ begin
AssertEquals('use_shapes_ni stdout', 'shape:box' + #10, Captured)
end;
procedure TSepCompileTests.TestNativeImplSectionClass_Compiles;
{ A class declared entirely in a unit's IMPLEMENTATION section, used by an
interface-exported routine of that unit. The unit object must emit the
class's method bodies, typeinfo, vtable and _FieldCleanup so the call site
links. Native default (incremental) path. }
const
UnitSrc =
'''
unit ImplCls;
interface
function MakeAndGet: Integer;
implementation
type
TFoo = class
FX: Integer;
constructor Create(AX: Integer);
function GetX: Integer;
end;
constructor TFoo.Create(AX: Integer);
begin FX := AX end;
function TFoo.GetX: Integer;
begin Result := FX end;
function MakeAndGet: Integer;
var F: TFoo;
begin
F := TFoo.Create(7);
Result := F.GetX();
F.Free()
end;
end.
''';
ProgSrc =
'''
program UseImplCls;
uses ImplCls;
begin
WriteLn(MakeAndGet())
end.
''';
var
UnitPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/ImplCls.pas';
ProgPas := FScratch + '/use_implcls.pas';
ProgBin := FScratch + '/use_implcls';
WriteFile(UnitPas, UnitSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'native',
'--unit-path', FScratch], Captured);
AssertEquals('blaise(use_implcls) exit code (out: ' + Captured + ')', 0, Rc);
AssertTrue('use_implcls exists', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('use_implcls exit code', 0, Rc);
AssertEquals('use_implcls stdout', '7' + #10, Captured)
end;
procedure TSepCompileTests.TestQBEImplSectionClass_Compiles;
{ Same as TestNativeImplSectionClass_Compiles but forces the QBE backend —
the QBE unit-emission loop (AppendUnit) must also walk ImplBlock classes. }
const
UnitSrc =
'''
unit ImplClsQ;
interface
function MakeAndGet: Integer;
implementation
type
TFoo = class
FX: Integer;
constructor Create(AX: Integer);
function GetX: Integer;
end;
constructor TFoo.Create(AX: Integer);
begin FX := AX end;
function TFoo.GetX: Integer;
begin Result := FX end;
function MakeAndGet: Integer;
var F: TFoo;
begin
F := TFoo.Create(7);
Result := F.GetX();
F.Free()
end;
end.
''';
ProgSrc =
'''
program UseImplClsQ;
uses ImplClsQ;
begin
WriteLn(MakeAndGet())
end.
''';
var
UnitPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/ImplClsQ.pas';
ProgPas := FScratch + '/use_implclsq.pas';
ProgBin := FScratch + '/use_implclsq';
WriteFile(UnitPas, UnitSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'qbe',
'--unit-path', FScratch], Captured);
AssertEquals('blaise(use_implclsq) exit code (out: ' + Captured + ')', 0, Rc);
AssertTrue('use_implclsq exists', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('use_implclsq exit code', 0, Rc);
AssertEquals('use_implclsq stdout', '7' + #10, Captured)
end;
procedure TSepCompileTests.TestNativeImplSectionMetaclassInInit_Runs;
{ The unit's INITIALIZATION block references an impl-section class as a metaclass
value (assigns the class to a `class of` global). Before the
DefineOwningUnit re-assertion fix, per-unit codegen emitted that metaclass ref
under a bare, undefined `typeinfo_<TFoo>` symbol, linking to garbage and
crashing at runtime. Native (default) path. }
const
UnitSrc =
'''
unit ImplMetaN;
interface
function MakeViaMeta: Integer;
implementation
type
TFoo = class
FX: Integer;
constructor Create;
function GetX: Integer;
end;
TFooClass = class of TFoo;
var
GCls: TFooClass;
constructor TFoo.Create;
begin FX := 42 end;
function TFoo.GetX: Integer;
begin Result := FX end;
function MakeViaMeta: Integer;
var F: TFoo;
begin
F := GCls.Create();
Result := F.GetX();
F.Free()
end;
initialization
GCls := TFoo;
end.
''';
ProgSrc =
'''
program UseImplMetaN;
uses ImplMetaN;
begin
WriteLn(MakeViaMeta())
end.
''';
var
UnitPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/ImplMetaN.pas';
ProgPas := FScratch + '/use_implmetan.pas';
ProgBin := FScratch + '/use_implmetan';
WriteFile(UnitPas, UnitSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'native',
'--unit-path', FScratch], Captured);
AssertEquals('blaise(use_implmetan) exit code (out: ' + Captured + ')', 0, Rc);
AssertTrue('use_implmetan exists', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('use_implmetan exit code', 0, Rc);
AssertEquals('use_implmetan stdout', '42' + #10, Captured)
end;
procedure TSepCompileTests.TestQBEImplSectionMetaclassInInit_Runs;
{ Same as TestNativeImplSectionMetaclassInInit_Runs but forces the QBE backend. }
const
UnitSrc =
'''
unit ImplMetaQ;
interface
function MakeViaMeta: Integer;
implementation
type
TFoo = class
FX: Integer;
constructor Create;
function GetX: Integer;
end;
TFooClass = class of TFoo;
var
GCls: TFooClass;
constructor TFoo.Create;
begin FX := 42 end;
function TFoo.GetX: Integer;
begin Result := FX end;
function MakeViaMeta: Integer;
var F: TFoo;
begin
F := GCls.Create();
Result := F.GetX();
F.Free()
end;
initialization
GCls := TFoo;
end.
''';
ProgSrc =
'''
program UseImplMetaQ;
uses ImplMetaQ;
begin
WriteLn(MakeViaMeta())
end.
''';
var
UnitPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/ImplMetaQ.pas';
ProgPas := FScratch + '/use_implmetaq.pas';
ProgBin := FScratch + '/use_implmetaq';
WriteFile(UnitPas, UnitSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'qbe',
'--unit-path', FScratch], Captured);
AssertEquals('blaise(use_implmetaq) exit code (out: ' + Captured + ')', 0, Rc);
AssertTrue('use_implmetaq exists', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('use_implmetaq exit code', 0, Rc);
AssertEquals('use_implmetaq stdout', '42' + #10, Captured)
end;
procedure TSepCompileTests.TestImplSectionClass_DoesNotLeakCrossUnit;
{ A class declared in unit A's IMPLEMENTATION section is private to A. A second
unit B that never `uses` A must NOT see it — referencing it must be a compile
error, not a silent success via the flat global scope. (Both A and B sit on
the same unit path, so before the fix B resolved A's impl class by leak.) }
const
UnitASrc =
'''
unit LeakA;
interface
procedure Noop;
implementation
type
TPrivate = class
V: Integer;
end;
procedure Noop; begin end;
end.
''';
UnitBSrc =
'''
unit LeakB;
interface
function Use: Integer;
implementation
function Use: Integer;
var X: TPrivate; // LeakB does NOT use LeakA — must be unknown
begin
X := TPrivate.Create();
Result := X.V;
X.Free()
end;
end.
''';
ProgSrc =
'''
program UseLeak;
uses LeakA, LeakB;
begin
WriteLn(Use())
end.
''';
var
UnitAPas, UnitBPas, ProgPas, ProgBin: string;
Captured: string;
Rc: Integer;
begin
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitAPas := FScratch + '/LeakA.pas';
UnitBPas := FScratch + '/LeakB.pas';
ProgPas := FScratch + '/use_leak.pas';
ProgBin := FScratch + '/use_leak';
WriteFile(UnitAPas, UnitASrc);
WriteFile(UnitBPas, UnitBSrc);
WriteFile(ProgPas, ProgSrc);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'native',
'--unit-path', FScratch], Captured);
AssertTrue('compile must FAIL (impl-section class is unit-private), out: '
+ Captured, Rc <> 0);
AssertTrue('error names the unknown type TPrivate, out: ' + Captured,
Pos('TPrivate', Captured) >= 0)
end;
procedure TSepCompileTests.TestNativeIncremental_UnitUsesUnit_Compiles;
{ Compile a UNIT that uses another unit, in unit-mode (--source <unit>.pas
--output <unit>.o), via the default incremental path. This is the runtime
@ -1264,144 +852,6 @@ begin
AssertEquals('build2 stdout', '43' + #10, Captured)
end;
procedure TSepCompileTests.TestIncrementalRebuild_QualifiedGrandparentMethod;
const
{ Three-level chain mirroring TAssert->TTestCase->TE2ETestCase. Greet is
defined on the grandparent TBase. CRITICAL: the grandparent unit has a
DOTTED name (chain.base) — the trigger for this bug. A cross-unit parent
is serialised in the .bif as `Unit.Type`; when the unit is dotted
(chain.base.TBase) the decoder must split at the LAST dot. Splitting at
the first dot yielded type='base.TBase', so the cached parent could not be
relinked and the leaf's inherited-method walk dead-ended. }
BaseSrc =
'''
unit chain.base;
interface
type
TBase = class
function Greet: Integer;
end;
implementation
function TBase.Greet: Integer;
begin Result := 7 end;
end.
''';
{ TMid's parent TBase lives in the dotted unit chain.base, so chain.mid's
.bif serialises the parent qualified as `chain.base.TBase`. }
MidSrc =
'''
unit chain.mid;
interface
uses chain.base;
type
TMid = class(TBase)
function MidOnly: Integer;
end;
implementation
function TMid.MidOnly: Integer;
begin Result := 1 end;
end.
''';
{ Leaf unit: TLeaf inherits Greet from TBase via TMid (two cached units up).
The marker comment is edited between builds to force a recompile-from-
source of THIS unit while chain.base/chain.mid stay cached. }
LeafSrc =
'''
unit chain.leaf;
interface
uses chain.mid;
type
TLeaf = class(TMid)
function Run: Integer;
end;
implementation
{ rev 1 }
function TLeaf.Run: Integer;
begin Result := Greet() + MidOnly() end;
end.
''';
LeafSrc2 =
'''
unit chain.leaf;
interface
uses chain.mid;
type
TLeaf = class(TMid)
function Run: Integer;
end;
implementation
{ rev 2 — edited to force recompile from source }
function TLeaf.Run: Integer;
begin Result := Greet() + MidOnly() end;
end.
''';
ProgSrc =
'''
program UseLeaf;
uses chain.leaf;
var L: TLeaf;
begin
L := TLeaf.Create();
WriteLn(L.Run());
L.Free()
end.
''';
var
BasePas, MidPas, LeafPas, ProgPas, ProgBin, CacheDir: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
BasePas := FScratch + '/chain.base.pas';
MidPas := FScratch + '/chain.mid.pas';
LeafPas := FScratch + '/chain.leaf.pas';
ProgPas := FScratch + '/use_leaf.pas';
ProgBin := FScratch + '/use_leaf';
CacheDir := FScratch + '/units-qgp';
WriteFile(BasePas, BaseSrc);
WriteFile(MidPas, MidSrc);
WriteFile(LeafPas, LeafSrc);
WriteFile(ProgPas, ProgSrc);
ForceDirectories(CacheDir);
{ Build 1 (clean cache): all units from source; populates the cache. }
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--unit-cache', CacheDir,
'--unit-path', FScratch], Captured);
AssertEquals('build1 exit code (out: ' + Captured + ')', 0, Rc);
Rc := RunBinary(ProgBin, Captured);
AssertEquals('build1 run exit code', 0, Rc);
AssertEquals('build1 stdout', '8' + #10, Captured);
{ Edit the LEAF unit's content so build 2 recompiles it FROM SOURCE while
BaseU and MidU load from their cached .bif/.o. The inherited Greet (on
the cached grandparent TBase) must still resolve through MidU's
qualified parent link. }
WriteFile(LeafPas, LeafSrc2);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--unit-cache', CacheDir,
'--unit-path', FScratch], Captured);
AssertEquals('build2 exit code — grandparent method must resolve (out: '
+ Captured + ')', 0, Rc);
AssertTrue('use_leaf exists after rebuild', FileExists(ProgBin));
Rc := RunBinary(ProgBin, Captured);
AssertEquals('build2 run exit code', 0, Rc);
AssertEquals('build2 stdout', '8' + #10, Captured)
end;
{ Regression for the cached-unit virtual-constructor vtable-slot bug.
BaseU declares a class with a non-virtual constructor Create (which still
@ -1598,140 +1048,6 @@ begin
Captured)
end;
{ Shared source for the two cross-unit static-member tests below. RegModU
declares a class with all three static member forms; the consuming program
reaches them across the compiled .bif boundary. }
const
StaticRegModSrc =
'''
unit RegModU;
interface
type
TReg = class
private static var
FCount: Integer;
public
static function Next: Integer;
{ Static property whose getter is a static method: exercises
TPropertyDecl.IsStatic surviving the .bif round-trip (a non-static
import would dispatch with a bogus Self). }
static property Counter: Integer read Next;
public static const
Tag = 7;
end;
implementation
static function TReg.Next: Integer;
begin
FCount := FCount + 1;
Result := FCount;
end;
end.
''';
StaticRegProgSrc =
'''
program UseReg;
uses RegModU;
begin
WriteLn(TReg.Next());
WriteLn(TReg.Next());
WriteLn(TReg.Counter);
WriteLn(TReg.Tag)
end.
''';
procedure TSepCompileTests.TestStaticMembers_CrossUnit_QBE;
var
UnitPas, ProgPas, ProgBin, CacheDir: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/RegModU.pas';
ProgPas := FScratch + '/use_reg_qbe.pas';
ProgBin := FScratch + '/use_reg_qbe';
CacheDir := FScratch + '/units-static-qbe';
WriteFile(UnitPas, StaticRegModSrc);
WriteFile(ProgPas, StaticRegProgSrc);
ForceDirectories(CacheDir);
{ Build 1 (clean cache): RegModU compiled from source, .o/.bif cached. }
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'qbe',
'--unit-cache', CacheDir,
'--unit-path', FScratch], Captured);
AssertEquals('qbe build1 exit (out: ' + Captured + ')', 0, Rc);
Rc := RunBinary(ProgBin, Captured);
AssertEquals('qbe build1 run exit', 0, Rc);
AssertEquals('qbe build1 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured);
{ Build 2 (warm cache): RegModU loaded purely from its cached .bif — the
static facts must survive the .bif round-trip. }
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'qbe',
'--unit-cache', CacheDir,
'--unit-path', FScratch], Captured);
AssertEquals('qbe build2 exit (out: ' + Captured + ')', 0, Rc);
Rc := RunBinary(ProgBin, Captured);
AssertEquals('qbe build2 run exit', 0, Rc);
AssertEquals('qbe build2 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured)
end;
procedure TSepCompileTests.TestStaticMembers_CrossUnit_Native;
var
UnitPas, ProgPas, ProgBin, CacheDir: string;
Captured: string;
Rc: Integer;
begin
if not ToolchainAvailable() then
begin
Fail('toolchain missing — qbe or RTL not found');
Exit
end;
if not FileExists(BlaisePath()) then
begin
Fail('blaise binary missing at ' + BlaisePath());
Exit
end;
UnitPas := FScratch + '/RegModU.pas';
ProgPas := FScratch + '/use_reg_native.pas';
ProgBin := FScratch + '/use_reg_native';
CacheDir := FScratch + '/units-static-native';
WriteFile(UnitPas, StaticRegModSrc);
WriteFile(ProgPas, StaticRegProgSrc);
ForceDirectories(CacheDir);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'native',
'--unit-cache', CacheDir,
'--unit-path', FScratch], Captured);
AssertEquals('native build1 exit (out: ' + Captured + ')', 0, Rc);
Rc := RunBinary(ProgBin, Captured);
AssertEquals('native build1 run exit', 0, Rc);
AssertEquals('native build1 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured);
Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
'--backend', 'native',
'--unit-cache', CacheDir,
'--unit-path', FScratch], Captured);
AssertEquals('native build2 exit (out: ' + Captured + ')', 0, Rc);
Rc := RunBinary(ProgBin, Captured);
AssertEquals('native build2 run exit', 0, Rc);
AssertEquals('native build2 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured)
end;
initialization
RegisterTest(TSepCompileTests);

76
compiler/src/test/pascal/cp.test.e2e.staticarray.pas
View file

@ -35,10 +35,6 @@ type
procedure TestRun_TypeAlias_AsParam_Length;
procedure TestRun_TypeAlias_MultipleVarsShareType;
procedure TestRun_TypeAlias_GlobalAndLocal;
{ A named integer subrange (TIdx = 0..2) used as an array index type:
array[TIdx] of T resolves to array[0..2] of T (ordinal-indexed). }
procedure TestRun_NamedSubrange_AsArrayIndex;
procedure TestRun_NamedSubrange_NonZeroBase_AsArrayIndex;
{ Range-indexed const array: const X: array[L..H] of T = (...) }
procedure TestRun_ConstArray_RangeIndexed_Strings;
@ -202,48 +198,12 @@ const
G[2] := L[2]
end;
begin
Fill();
Fill;
WriteLn(G[0]);
WriteLn(G[2])
end.
''';
{ A named integer subrange used as an array index type. array[TIdx] of T,
where TIdx = 0..2, must resolve to array[0..2] of T (ordinal-indexed,
like array[TEnum]). FPC compiles this; Blaise must too. }
SrcSubrangeIndex =
'''
program P;
type
TIdx = 0..2;
TBuf = array[TIdx] of Integer;
var A: TBuf;
begin
A[0] := 11; A[1] := 22; A[2] := 33;
WriteLn(A[0]);
WriteLn(A[1]);
WriteLn(A[2]);
WriteLn(Length(A))
end.
''';
{ Non-zero-based named subrange index: array[2..4] via a named subrange. }
SrcSubrangeIndexNonZero =
'''
program P;
type
TIdx = 2..4;
TBuf = array[TIdx] of Integer;
var A: TBuf;
begin
A[2] := 100; A[3] := 200; A[4] := 300;
WriteLn(A[2]);
WriteLn(A[4]);
WriteLn(Low(A));
WriteLn(High(A))
end.
''';
{ ------------------------------------------------------------------ }
{ Setup }
{ ------------------------------------------------------------------ }
@ -379,40 +339,6 @@ begin
finally Lines.Free() end
end;
procedure TE2EStaticArrayTests.TestRun_NamedSubrange_AsArrayIndex;
var Output: string; RCode: Integer;
Lines: TStringList;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertTrue('compile+run', CompileAndRun(SrcSubrangeIndex, Output, RCode));
AssertEquals('exit 0', 0, RCode);
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('A[0]=11', '11', Lines.Strings[0]);
AssertEquals('A[1]=22', '22', Lines.Strings[1]);
AssertEquals('A[2]=33', '33', Lines.Strings[2]);
AssertEquals('Length(A)=3', '3', Lines.Strings[3]);
finally Lines.Free() end
end;
procedure TE2EStaticArrayTests.TestRun_NamedSubrange_NonZeroBase_AsArrayIndex;
var Output: string; RCode: Integer;
Lines: TStringList;
begin
if not ToolchainAvailable() then begin Fail('<toolchain-missing>'); Exit end;
AssertTrue('compile+run', CompileAndRun(SrcSubrangeIndexNonZero, Output, RCode));
AssertEquals('exit 0', 0, RCode);
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('A[2]=100', '100', Lines.Strings[0]);
AssertEquals('A[4]=300', '300', Lines.Strings[1]);
AssertEquals('Low(A)=2', '2', Lines.Strings[2]);
AssertEquals('High(A)=4', '4', Lines.Strings[3]);
finally Lines.Free() end
end;
procedure TE2EStaticArrayTests.TestRun_ConstArray_RangeIndexed_Strings;
const
Src =

370
compiler/src/test/pascal/cp.test.e2e.staticmembers.pas
View file

@ -1,370 +0,0 @@
{
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.staticmembers;
{ E2E tests for `static` class/record members: static var, static method,
static property, and the lazy-singleton pattern. Each program is compiled
and run on every backend (QBE + native). Parser/semantic/IR tests live in
cp.test.staticmembers.pas; these guard the codegen -> QBE -> run boundary
the IR harness cannot see (data-slot emission, no-Self call ABI, qualified
static reads). }
interface
uses
classes, blaise.testing, cp.test.e2e.base;
type
[Threaded]
TE2EStaticMembersTests = class(TE2ETestCase)
protected
procedure SetUp; override;
published
procedure TestRun_StaticMethod_NoSelf;
procedure TestRun_StaticVar_SharedAcrossCalls;
procedure TestRun_StaticVar_QualifiedRead;
procedure TestRun_StaticVar_QualifiedWrite_Scalar;
procedure TestRun_StaticVar_QualifiedWrite_ClassARC;
procedure TestRun_StaticVar_InterfaceStore;
procedure TestRun_StaticVar_ChainedLValueBase;
procedure TestRun_StaticProperty_QualifiedRead;
procedure TestRun_Singleton_LazyGetInstance;
procedure TestRun_StaticConst_OnClass;
procedure TestRun_RecordStaticFactory;
end;
implementation
procedure TE2EStaticMembersTests.SetUp;
begin
inherited SetUp();
SetUpScratch('compiler/target/test-e2e-staticmembers')
end;
procedure TE2EStaticMembersTests.TestRun_StaticMethod_NoSelf;
const Src =
'''
program P;
type
TMath = class
public
static function Square(X: Integer): Integer;
end;
static function TMath.Square(X: Integer): Integer;
begin
Result := X * X;
end;
begin
WriteLn(TMath.Square(7))
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '49' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_SharedAcrossCalls;
const Src =
'''
program P;
type
TCounter = class
private static var
FN: Integer;
public
static function Next: Integer;
end;
static function TCounter.Next: Integer;
begin
FN := FN + 1;
Result := FN;
end;
begin
WriteLn(TCounter.Next());
WriteLn(TCounter.Next());
WriteLn(TCounter.Next())
end.
''';
var LE: string;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
LE := LineEnding;
AssertRunsOnAll(Src, '1' + LE + '2' + LE + '3' + LE, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_QualifiedRead;
const Src =
'''
program P;
type
TCounter = class
public static var
Total: Integer;
static procedure Bump;
end;
static procedure TCounter.Bump;
begin
Total := Total + 10;
end;
begin
TCounter.Bump();
TCounter.Bump();
WriteLn(TCounter.Total)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '20' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_QualifiedWrite_Scalar;
const Src =
'''
program P;
type
TFoo = class
public static var
GCount: Integer;
end;
begin
TFoo.GCount := 5;
TFoo.GCount := TFoo.GCount + 37;
WriteLn(TFoo.GCount)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '42' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_QualifiedWrite_ClassARC;
const Src =
'''
program P;
type
TObj = class
public
V: Integer;
end;
THolder = class
public static var
GObj: TObj;
end;
var local: TObj;
begin
THolder.GObj := TObj.Create();
local := THolder.GObj;
local.V := 99;
WriteLn(local.V);
THolder.GObj := nil;
if THolder.GObj = nil then WriteLn('released')
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '99' + LineEnding + 'released' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_InterfaceStore;
{ Interface-typed static var: the bare store inside a static method
(FCache := X) must write BOTH slots of the 2-slot fat pointer (obj + itab)
with correct ARC, and the bare read (Result := FCache) must reconstruct it.
Regression for the static-call interface-arg leading-comma bug that made
THolder.SetIt(T) emit an invalid QBE call and segfault native. }
const Src =
'''
program P;
type
IThing = interface
procedure Speak;
end;
TThing = class(IThing)
public
Tag: Integer;
procedure Speak;
end;
THolder = class
public static var
FCache: IThing;
static procedure SetIt(X: IThing);
static function GetIt: IThing;
end;
procedure TThing.Speak;
begin
WriteLn('thing ', Tag);
end;
static procedure THolder.SetIt(X: IThing);
begin
FCache := X;
end;
static function THolder.GetIt: IThing;
begin
Result := FCache;
end;
var
T: TThing;
Got: IThing;
begin
T := TThing.Create();
T.Tag := 7;
THolder.SetIt(T);
Got := THolder.GetIt();
Got.Speak();
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, 'thing 7' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticVar_ChainedLValueBase;
{ A qualified static var of class type used as the BASE of a further l-value
chain: 'TFoo.GObj.Field := V' (field write through the chained base) and
'TFoo.GObj.Method()' (method call on the chained base). The read form
(TFoo.GObj.Field as an expression) already worked; the write/call receiver
path through the chained base was unresolved ("Field access requires a record
or class base, got 'class of TFoo'"). }
const Src =
'''
program P;
type
TObj = class
public
V: Integer;
procedure Bump;
end;
THolder = class
public static var
GObj: TObj;
end;
procedure TObj.Bump;
begin
V := V + 1;
end;
begin
THolder.GObj := TObj.Create();
WriteLn(THolder.GObj.V);
THolder.GObj.V := 5;
WriteLn(THolder.GObj.V);
THolder.GObj.Bump();
WriteLn(THolder.GObj.V);
THolder.GObj := nil
end.
''';
var LE: string;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
LE := LineEnding;
AssertRunsOnAll(Src, '0' + LE + '5' + LE + '6' + LE, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticProperty_QualifiedRead;
const Src =
'''
program P;
type
TRegistry = class
private static var
FCounter: Integer;
public
static function NextId: Integer;
static property Counter: Integer read NextId;
end;
static function TRegistry.NextId: Integer;
begin
FCounter := FCounter + 1;
Result := FCounter;
end;
begin
WriteLn(TRegistry.Counter);
WriteLn(TRegistry.Counter)
end.
''';
var LE: string;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
LE := LineEnding;
AssertRunsOnAll(Src, '1' + LE + '2' + LE, 0);
end;
procedure TE2EStaticMembersTests.TestRun_Singleton_LazyGetInstance;
const Src =
'''
program P;
type
TConfig = class
private static var
FInstance: TConfig;
public
FValue: Integer;
static function Instance: TConfig;
end;
static function TConfig.Instance: TConfig;
begin
if FInstance = nil then
FInstance := TConfig.Create();
Result := FInstance;
end;
begin
TConfig.Instance().FValue := 42;
WriteLn(TConfig.Instance().FValue)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '42' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_StaticConst_OnClass;
const Src =
'''
program P;
type
TLimits = class
public static const
MaxItems = 128;
end;
begin
WriteLn(TLimits.MaxItems)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '128' + LineEnding, 0);
end;
procedure TE2EStaticMembersTests.TestRun_RecordStaticFactory;
const Src =
'''
program P;
type
TPoint = record
X, Y: Integer;
static function Make(AX, AY: Integer): TPoint;
end;
static function TPoint.Make(AX, AY: Integer): TPoint;
begin
Result.X := AX;
Result.Y := AY;
end;
var Pt: TPoint;
begin
Pt := TPoint.Make(3, 4);
WriteLn(Pt.X + Pt.Y)
end.
''';
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertRunsOnAll(Src, '7' + LineEnding, 0);
end;
initialization
RegisterTest(TE2EStaticMembersTests);
end.

30
compiler/src/test/pascal/cp.test.e2e.sysutils.pas
View file

@ -45,7 +45,6 @@ type
procedure TestRun_SetCurrentDir_ChangesDir;
procedure TestRun_ExtractFileExt_ReturnsExt;
procedure TestRun_BoolToStr_TrueAndFalse;
procedure TestRun_SameFileName_ExactMatch;
procedure TestRun_PlatformConstants;
procedure TestRun_GetCurrentDir_ReturnsNonEmpty;
procedure TestRun_FileAge_ReturnsTimestamp;
@ -535,16 +534,6 @@ const
end.
''';
SrcSameFileName =
'''
program P;
uses SysUtils;
begin
WriteLn(SameFileName('a/b.pas', 'a/b.pas'));
WriteLn(SameFileName('a/b.pas', 'a/c.pas'))
end.
''';
SrcPlatformConstants =
'''
program P;
@ -670,25 +659,6 @@ begin
end;
end;
procedure TE2ESysUtilsTests.TestRun_SameFileName_ExactMatch;
var
Output: string;
RCode: Integer;
Lines: TStringList;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRunWithRTL(SrcSameFileName, Output, RCode));
AssertEquals('exit code 0', 0, RCode);
Lines := TStringList.Create();
try
Lines.Text := Trim(Output);
AssertEquals('identical names match', 'True', Lines.Strings[0]);
AssertEquals('different names differ', 'False', Lines.Strings[1]);
finally
Lines.Free();
end;
end;
procedure TE2ESysUtilsTests.TestRun_PlatformConstants;
var
Output: string;

166
compiler/src/test/pascal/cp.test.e2e.threading.pas
View file

@ -32,8 +32,6 @@ type
procedure TestRun_Thread_InheritedDestroy_CleanExit;
procedure TestRun_ThreadVar_MainThread_ReadWrite;
procedure TestRun_ThreadVar_MixedWithGlobalVar;
procedure TestRun_ThreadVar_RecordField_PerThreadIsolation;
procedure TestRun_ThreadVar_RecordMethod_PerThreadIsolation;
procedure TestRun_PerThreadAllocator_IndependentAllocs;
procedure TestRun_AtomicARC_SharedObject_NoCorruption;
end;
@ -110,20 +108,18 @@ const
var I: Integer;
begin
{ Spin until terminated. The loop must exit *only* via the terminate
flag so Terminated is guaranteed True when read — an early-break
flag so FTerminated is guaranteed True when read — an early-break
escape would let the worker finish before the main thread's Terminate
landed, making the printed flag race between 0 and 1. The large cap is
only a safety net so a missed Terminate cannot hang the test forever.
Read the public Terminated property — the backing FTerminated field is
private to TThread and not visible to subclasses. }
only a safety net so a missed Terminate cannot hang the test forever. }
I := 0;
while not Self.Terminated do
while not Self.FTerminated do
begin
I := I + 1;
if I > 2000000000 then
break
end;
WriteLn(Self.Terminated)
WriteLn(Self.FTerminated)
end;
var T: TLoopThread;
begin
@ -149,13 +145,11 @@ const
end;
var T: TQuickThread;
begin
{ Read the public Finished property — the backing FFinished field is
private to TThread and not visible outside the class. }
T := TQuickThread.Create(True);
WriteLn(T.Finished);
WriteLn(T.FFinished);
T.Start();
T.WaitFor();
WriteLn(T.Finished)
WriteLn(T.FFinished)
end.
''';
@ -373,154 +367,6 @@ begin
AssertEquals('stdout', '30' + LE, Output)
end;
const
{ A RECORD-typed threadvar mutated and read back per-thread. Each thread
stamps its own id into the record-field threadvar, then spins re-reading it
and asserting it never changes. If the record threadvar is addressed
statically (leaq Name(%rip)) instead of via TLS (%fs:0 + @tpoff), all
threads share one slot and clobber each other -> 'CORRUPT'. Scalar
threadvars already use TLS; the bug was that record/aggregate threadvar
field access bypassed it. }
SrcThreadVarRecordIsolation =
'''
program P;
uses Classes;
type
TRec = record
Tag: Integer;
end;
TStampThread = class(TThread)
MyId: Integer;
protected
procedure Execute; override;
end;
threadvar
TVR: TRec;
var
Corrupt: Integer;
procedure TStampThread.Execute;
var I: Integer;
begin
TVR.Tag := Self.MyId;
for I := 0 to 200000 do
if TVR.Tag <> Self.MyId then
begin
Corrupt := 1;
Exit
end
end;
var
A, B, C: TStampThread;
begin
Corrupt := 0;
A := TStampThread.Create(True);
B := TStampThread.Create(True);
C := TStampThread.Create(True);
A.MyId := 11;
B.MyId := 22;
C.MyId := 33;
A.Start();
B.Start();
C.Start();
A.WaitFor();
B.WaitFor();
C.WaitFor();
if Corrupt = 0 then
WriteLn('ok')
else
WriteLn('CORRUPT')
end.
''';
procedure TE2EThreadingTests.TestRun_ThreadVar_RecordField_PerThreadIsolation;
var
Output: string;
RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run', CompileAndRunWithRTL(SrcThreadVarRecordIsolation, Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('stdout', 'ok' + LE, Output)
end;
const
{ Same per-thread isolation guarantee, but the record threadvar is accessed
through METHOD CALLS (GR.Put / GR.Get) rather than direct field access. The
method-call receiver ladder loads the record base too, and used the same
static `leaq Name(%rip)` for a global receiver — so this exercises the
receiver-load path specifically. }
SrcThreadVarRecordMethod =
'''
program P;
uses Classes;
type
TRec = record
N: Integer;
procedure Put(V: Integer);
function Get: Integer;
end;
TStampThread = class(TThread)
MyId: Integer;
protected
procedure Execute; override;
end;
procedure TRec.Put(V: Integer);
begin
N := V
end;
function TRec.Get: Integer;
begin
Result := N
end;
threadvar
GR: TRec;
var
Corrupt: Integer;
procedure TStampThread.Execute;
var I: Integer;
begin
GR.Put(Self.MyId);
for I := 0 to 200000 do
if GR.Get() <> Self.MyId then
begin
Corrupt := 1;
Exit
end
end;
var
A, B, C: TStampThread;
begin
Corrupt := 0;
A := TStampThread.Create(True);
B := TStampThread.Create(True);
C := TStampThread.Create(True);
A.MyId := 11;
B.MyId := 22;
C.MyId := 33;
A.Start();
B.Start();
C.Start();
A.WaitFor();
B.WaitFor();
C.WaitFor();
if Corrupt = 0 then
WriteLn('ok')
else
WriteLn('CORRUPT')
end.
''';
procedure TE2EThreadingTests.TestRun_ThreadVar_RecordMethod_PerThreadIsolation;
var
Output: string;
RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
AssertTrue('compile+run', CompileAndRunWithRTL(SrcThreadVarRecordMethod, Output, RCode));
AssertEquals('exit code', 0, RCode);
AssertEquals('stdout', 'ok' + LE, Output)
end;
const
SrcPerThreadAlloc =
'''

41
compiler/src/test/pascal/cp.test.e2e.tlist.pas
View file

@ -38,10 +38,6 @@ type
{ Default array property: List[i] subscript for read and write. }
procedure TestRun_TList_DefaultProperty_ReadWrite;
procedure TestRun_TList_DefaultProperty_Polymorphic;
{ Clear and Free release managed elements (ARC cascade): a class element's
destructor must run when the list is cleared or freed. }
procedure TestRun_TList_FreeAndClear_ReleasesElements;
end;
implementation
@ -278,43 +274,6 @@ begin
AssertEquals('List[i].Area (native)', '25' + #10, Output);
end;
const
SrcTListFreeClear = '''
program P;
uses generics.collections;
type
TC = class
N: Integer;
constructor Create(AN: Integer);
destructor Destroy; override;
end;
constructor TC.Create(AN: Integer);
begin N := AN end;
destructor TC.Destroy;
begin WriteLn('d', N) end;
var
L: TList<TC>;
begin
L := TList<TC>.Create();
L.Add(TC.Create(1));
L.Add(TC.Create(2));
L.Clear();
WriteLn('cleared');
L.Add(TC.Create(3));
L.Free();
WriteLn('done')
end.
''';
procedure TE2ETListTests.TestRun_TList_FreeAndClear_ReleasesElements;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Clear releases elements 1 and 2; the final Free releases element 3 — each
destructor fires, proving the managed-element release cascade. }
AssertRTLRunsOnAll(SrcTListFreeClear,
'd1' + #10 + 'd2' + #10 + 'cleared' + #10 + 'd3' + #10 + 'done' + #10, 0);
end;
initialization
RegisterTest(TE2ETListTests);

512
compiler/src/test/pascal/cp.test.e2e.useschain.pas
View file

@ -29,50 +29,6 @@ type
procedure TestRun_ImplicitSystem_NoUsesClause_WriteLnInt;
procedure TestRun_ImplicitSystem_NoUsesClause_IntToStr;
procedure TestRun_ImplicitSystem_NoUsesClause_Length;
{ Unit-qualified symbol references 'UnitName.Symbol'. }
procedure TestRun_QualifiedSystem_CallExprAndStmt;
procedure TestRun_QualifiedUnit_CallAndVar;
procedure TestRun_DottedQualifiedUnit_CallAndVar;
{ Cross-unit const shadowing: two used units export the same const name;
the unit later in the `uses` clause wins (last-in-uses), and reversing
the order flips the winner. }
procedure TestRun_CrossUnitConst_LastWins;
procedure TestRun_CrossUnitConst_LastWins_Reversed;
{ Unit-qualified const disambiguation: a 'Unit.Foo' reference resolves
against that specific unit's exports, so it is never shadowed by a
same-named const in another used unit, regardless of `uses` order. }
procedure TestRun_CrossUnitConst_QualifiedDisambig;
{ Unit-qualified ancestor in a class declaration: class(Unit.TParent)
binds to that unit's type so inheritance works across units. }
procedure TestRun_QualifiedInheritance;
{ Two units each declare an impl-private global of the SAME name; with
unit-prefix mangling on module-scope globals they no longer collide at
link, so a program using both links and runs. }
procedure TestRun_SameNamedGlobals_NoLinkCollision;
{ Cross-unit interface VAR shadowing: two used units export the same var
name; the unit later in `uses` wins a bare reference (last-in-uses), and
reversing the order flips the winner — mirrors the const last-wins rule. }
procedure TestRun_CrossUnitVar_LastWins;
procedure TestRun_CrossUnitVar_LastWins_Reversed;
{ Unit-qualified VAR disambiguation: 'Unit.V' references that specific
unit's own slot (distinct storage), independent of the bare last-wins
winner, so both values are readable side by side. }
procedure TestRun_CrossUnitVar_QualifiedDisambig;
{ Cross-unit TYPE shadowing: two used units export a class of the same name;
they coexist (no 'Duplicate type name' error, no link collision) and a
bare reference binds to the unit later in `uses` (last-in-uses wins),
flipping when the order is reversed — mirrors the const/var rule. }
procedure TestRun_CrossUnitType_LastWins;
procedure TestRun_CrossUnitType_LastWins_Reversed;
{ Unit-qualified TYPE disambiguation: 'Unit.TShape' binds to that unit's own
class (distinct vtable/dispatch), independent of the bare last-wins
winner, so both behaviours are observable side by side. }
procedure TestRun_CrossUnitType_QualifiedDisambig;
{ Unit-qualified ENUM member 'Unit.TEnum.Member' (field-access form) binds
the enum type to that specific unit's exports via directed lookup, so it
reaches members the bare/last-wins enum type does not — independent of
`uses` order. }
procedure TestRun_CrossUnitEnum_QualifiedMember;
end;
implementation
@ -142,474 +98,6 @@ begin
AssertEquals('Length(''hello'')', '5' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_QualifiedSystem_CallExprAndStmt;
const
Src = '''
program P;
begin
System.WriteLn(System.Length('hello'))
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ 'System.WriteLn' (qualified call statement) and 'System.Length(...)'
(qualified call expression) both resolve via the implicit System unit. }
AssertTrue(CompileAndRun(Src, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('Length(''hello'') = 5', '5' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_QualifiedUnit_CallAndVar;
const
UnitSrc = '''
unit qsym;
interface
function Add3(N: Integer): Integer;
var
GBase: Integer;
implementation
function Add3(N: Integer): Integer;
begin
Result := N + 3
end;
end.
''';
DrvSrc = '''
program P;
uses qsym;
begin
qsym.GBase := 10;
WriteLn(qsym.Add3(qsym.GBase))
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Qualified assignment target (qsym.GBase :=), qualified var read
(qsym.GBase), and qualified function call (qsym.Add3) across a used unit. }
AssertTrue('compile+link+run',
CompileAndRunWithUnit('qsym', UnitSrc, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('Add3(10) = 13', '13' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_DottedQualifiedUnit_CallAndVar;
const
UnitSrc = '''
unit My.Pkg;
interface
function Add3(N: Integer): Integer;
var
GBase: Integer;
implementation
function Add3(N: Integer): Integer;
begin
Result := N + 3
end;
end.
''';
DrvSrc = '''
program P;
uses My.Pkg;
begin
My.Pkg.GBase := 10;
WriteLn(My.Pkg.Add3(My.Pkg.GBase))
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Same as above but through a two-part dotted unit name 'My.Pkg'. }
AssertTrue('compile+link+run',
CompileAndRunWithUnit('My.Pkg', UnitSrc, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('Add3(10) = 13', '13' + LE, Output);
end;
const
UA_Const = '''
unit ua;
interface
const Foo = 100;
implementation
end.
''';
UB_Const = '''
unit ub;
interface
const Foo = 200;
implementation
end.
''';
procedure TE2EUsesChainTests.TestRun_CrossUnitConst_LastWins;
const
DrvSrc = '''
program P;
uses ua, ub;
begin
WriteLn(Foo)
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Both ua and ub export `Foo`; ub is later in `uses`, so bare Foo = 200. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UA_Const, UB_Const, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('last-in-uses (ub) wins', '200' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_CrossUnitConst_LastWins_Reversed;
const
DrvSrc = '''
program P;
uses ub, ua;
begin
WriteLn(Foo)
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Reversed `uses` order: ua is now later, so bare Foo = 100. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UA_Const, UB_Const, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('last-in-uses (ua) wins', '100' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_CrossUnitConst_QualifiedDisambig;
const
DrvSrc = '''
program P;
uses ua, ub;
begin
WriteLn(ua.Foo);
WriteLn(ub.Foo)
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Both ua and ub export `Foo`; qualified references pick each unit's own
value (ua.Foo = 100, ub.Foo = 200) independent of the bare last-wins rule. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UA_Const, UB_Const, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('ua.Foo then ub.Foo', '100' + LE + '200' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_QualifiedInheritance;
const
UnitSrc = '''
unit ua;
interface
type
TParent = class
function Base: Integer;
end;
implementation
function TParent.Base: Integer;
begin
Result := 41
end;
end.
''';
DrvSrc = '''
program P;
uses ua;
type
TChild = class(ua.TParent)
function Plus1: Integer;
end;
function TChild.Plus1: Integer;
begin
Result := Base() + 1
end;
var
C: TChild;
begin
C := TChild.Create();
WriteLn(C.Plus1())
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ class(ua.TParent) resolves the qualified ancestor to ua's type; the child
inherits Base (41) and adds 1 -> 42. }
AssertTrue('compile+link+run',
CompileAndRunWithUnit('ua', UnitSrc, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('inherited Base + 1', '42' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_SameNamedGlobals_NoLinkCollision;
const
UnitOne = '''
unit uone;
interface
function GetOne: Integer;
implementation
var G: Integer;
function GetOne: Integer;
begin
G := 11;
Result := G
end;
end.
''';
UnitTwo = '''
unit utwo;
interface
function GetTwo: Integer;
implementation
var G: Integer;
function GetTwo: Integer;
begin
G := 22;
Result := G
end;
end.
''';
DrvSrc = '''
program P;
uses uone, utwo;
begin
WriteLn(GetOne() + GetTwo())
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Both units emit a global named G; without unit-prefix mangling the two
'$G' definitions collide at link. Mangling makes them distinct, so the
program links and prints 11 + 22 = 33. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UnitOne, UnitTwo, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('GetOne + GetTwo', '33' + LE, Output);
end;
const
UVA_Var = '''
unit uva;
interface
var V: Integer = 7;
implementation
end.
''';
UVB_Var = '''
unit uvb;
interface
var V: Integer = 9;
implementation
end.
''';
procedure TE2EUsesChainTests.TestRun_CrossUnitVar_LastWins;
const
DrvSrc = '''
program P;
uses uva, uvb;
begin
WriteLn(V)
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Both uva and uvb export `V`; uvb is later in `uses`, so bare V = 9.
The shadowed uva.V keeps its own slot (no link collision). }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UVA_Var, UVB_Var, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('last-in-uses (uvb) wins', '9' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_CrossUnitVar_LastWins_Reversed;
const
DrvSrc = '''
program P;
uses uvb, uva;
begin
WriteLn(V)
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Reversed `uses` order: uva is now later, so bare V = 7. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UVA_Var, UVB_Var, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('last-in-uses (uva) wins', '7' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_CrossUnitVar_QualifiedDisambig;
const
DrvSrc = '''
program P;
uses uva, uvb;
begin
WriteLn(uva.V);
WriteLn(uvb.V)
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Qualified references pick each unit's own slot (uva.V = 7, uvb.V = 9)
regardless of the bare last-wins rule — distinct storage per unit. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(UVA_Var, UVB_Var, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('uva.V then uvb.V', '7' + LE + '9' + LE, Output);
end;
const
TCA_Type = '''
unit tca;
interface
type
TShape = class
function Sides: Integer;
end;
implementation
function TShape.Sides: Integer;
begin
Result := 3
end;
end.
''';
TCB_Type = '''
unit tcb;
interface
type
TShape = class
function Sides: Integer;
end;
implementation
function TShape.Sides: Integer;
begin
Result := 4
end;
end.
''';
procedure TE2EUsesChainTests.TestRun_CrossUnitType_LastWins;
const
DrvSrc = '''
program P;
uses tca, tcb;
var S: TShape;
begin
S := TShape.Create();
WriteLn(S.Sides())
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Both tca and tcb export class `TShape`; tcb is later in `uses`, so bare
TShape binds to tcb (Sides = 4). The two types coexist with distinct
code symbols — no duplicate-identifier error and no link collision. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(TCA_Type, TCB_Type, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('last-in-uses (tcb) wins', '4' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_CrossUnitType_LastWins_Reversed;
const
DrvSrc = '''
program P;
uses tcb, tca;
var S: TShape;
begin
S := TShape.Create();
WriteLn(S.Sides())
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Reversed `uses` order: tca is now later, so bare TShape binds to tca
(Sides = 3). }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(TCA_Type, TCB_Type, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('last-in-uses (tca) wins', '3' + LE, Output);
end;
procedure TE2EUsesChainTests.TestRun_CrossUnitType_QualifiedDisambig;
const
DrvSrc = '''
program P;
uses tca, tcb;
var
A: tca.TShape;
B: tcb.TShape;
begin
A := tca.TShape.Create();
B := tcb.TShape.Create();
WriteLn(A.Sides());
WriteLn(B.Sides())
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
{ Qualified references bind each variable to its own unit's class, so
A.Sides = 3 (tca) and B.Sides = 4 (tcb) regardless of last-wins. }
AssertTrue('compile+link+run',
CompileAndRunWithUnits(TCA_Type, TCB_Type, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('tca.TShape then tcb.TShape', '3' + LE + '4' + LE, Output);
end;
const
EA_Enum = '''
unit ea;
interface
type TPalette = (paOne, paTwo, paThree);
implementation
end.
''';
EB_Enum = '''
unit eb;
interface
type TPalette = (paZero, paOne);
implementation
end.
''';
procedure TE2EUsesChainTests.TestRun_CrossUnitEnum_QualifiedMember;
const
{ ea.TPalette.paThree exists only in ea (ordinal 2); eb.TPalette.paZero only
in eb (ordinal 0). A flat/last-wins enum-type lookup would resolve one of
them to the other unit's TPalette and fail "no member"; the qualifier picks
each unit's own enum. }
DrvSrc = '''
program P;
uses ea, eb;
begin
WriteLn(Ord(ea.TPalette.paThree));
WriteLn(Ord(eb.TPalette.paZero))
end.
''';
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+link+run',
CompileAndRunWithUnits(EA_Enum, EB_Enum, DrvSrc, Output, RCode));
AssertEquals('exit 0', 0, RCode);
AssertEquals('ea.paThree=2, eb.paZero=0', '2' + LE + '0' + LE, Output);
end;
initialization
RegisterTest(TE2EUsesChainTests);

2
compiler/src/test/pascal/cp.test.exceptions.pas
View file

@ -254,7 +254,7 @@ const
end
end;
begin
Run()
Run
end.
''';

33
compiler/src/test/pascal/cp.test.external.pas
View file

@ -26,9 +26,6 @@ type
procedure TestParse_ExternalProc_IsExternal;
procedure TestParse_ExternalProc_ExternalNameEmpty;
procedure TestParse_ExternalProcNamed_ExternalName;
{ Parser — library-qualified external records ExternalLib and hoists
the bare library name into the program's LinkLibs set. }
procedure TestParse_ExternalLibName_RecordsLibAndLinkLib;
{ Parser — standalone function }
procedure TestParse_ExternalFunc_IsExternal;
procedure TestParse_ExternalFuncNamed_ExternalName;
@ -202,36 +199,6 @@ begin
end;
end;
procedure TExternalTests.TestParse_ExternalLibName_RecordsLibAndLinkLib;
var
Prog: TProgram;
Decl: TMethodDecl;
Lib: TLinkLibDecl;
begin
Prog := ParseSrc(
'''
program Test;
function c_strlen(S: PChar): Integer; external 'c' name 'strlen';
begin
end.
'''
);
try
Decl := TMethodDecl(Prog.Block.ProcDecls.Items[0]);
AssertTrue('IsExternal should be True', Decl.IsExternal);
AssertEquals('ExternalName should be strlen', 'strlen', Decl.ExternalName);
AssertEquals('ExternalLib should be c', 'c', Decl.ExternalLib);
{ The bare library name is hoisted into the program's LinkLibs set so
the link layer can expand it to -l<name>. }
AssertEquals('one link lib collected', 1, Prog.LinkLibs.Count);
Lib := TLinkLibDecl(Prog.LinkLibs.Items[0]);
AssertEquals('link lib name', 'c', Lib.LibName);
finally
Prog.Free();
end;
end;
procedure TExternalTests.TestParse_ExternalFunc_IsExternal;
var
Prog: TProgram;

2
compiler/src/test/pascal/cp.test.flowjumps.pas
View file

@ -171,7 +171,7 @@ const
Exit(5)
end;
begin
DoIt()
DoIt
end.
''';

6
compiler/src/test/pascal/cp.test.generics.pas
View file

@ -736,8 +736,8 @@ var
IR: string;
begin
IR := GenUnitIR(SrcUnitIntfGenericVar);
AssertTrue('global data slot for G emitted (unit-prefix mangled)',
Pos('data $U_G', IR) > 0);
AssertTrue('global data slot for G emitted',
Pos('data $G', IR) > 0);
AssertTrue('typeinfo for TBox_Integer emitted',
Pos('$typeinfo_TBox_Integer', IR) > 0);
end;
@ -793,7 +793,7 @@ const
program Prg;
uses UPair;
begin
InitPair();
InitPair;
end.
''';

71
compiler/src/test/pascal/cp.test.inherit.pas
View file

@ -23,7 +23,6 @@ type
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
procedure ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
published
{ ------------------------------------------------------------------ }
{ nil literal }
@ -71,11 +70,6 @@ type
procedure TestCodegen_Inherited_NoArgs_CallsParentMethod;
procedure TestCodegen_Inherited_WithArgs_ForwardsArgs;
{ Mandatory parentheses: a bare 'inherited Method' (no parens) is a
call and must carry (), in both statement and expression position. }
procedure TestParse_Inherited_BareStmt_RequiresParens;
procedure TestParse_Inherited_BareExpr_RequiresParens;
{ ------------------------------------------------------------------ }
{ TObject.InheritsFrom }
{ ------------------------------------------------------------------ }
@ -145,20 +139,6 @@ begin
end;
end;
procedure TInheritTests.ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
var Prog: TProgram;
begin
try
Prog := ParseSrc(ASrc);
Prog.Free();
Fail('Expected EParseError');
except
on E: EParseError do
AssertTrue('error message contains "' + AExpectedSubstr + '" (got: ' +
E.Message + ')', Pos(AExpectedSubstr, E.Message) >= 0);
end;
end;
{ ------------------------------------------------------------------ }
{ Shared source snippets }
{ ------------------------------------------------------------------ }
@ -477,7 +457,7 @@ begin
var C: TChild;
begin
C := TChild.Create();
C.NoSuchMethod()
C.NoSuchMethod
end.
''');
end;
@ -604,55 +584,6 @@ begin
AssertTrue('call $TBase_SetX in IR', Pos('call $TBase_SetX', IR) > 0);
end;
procedure TInheritTests.TestParse_Inherited_BareStmt_RequiresParens;
const Src = '''
program P;
type
TBase = class
procedure Init;
end;
TChild = class(TBase)
procedure Init;
end;
procedure TBase.Init;
begin
end;
procedure TChild.Init;
begin
inherited Init
end;
begin
end.
''';
begin
ParseExpectErrorMsg(Src, 'requires () for a call');
end;
procedure TInheritTests.TestParse_Inherited_BareExpr_RequiresParens;
const Src = '''
program P;
type
TBase = class
function Value: Integer;
end;
TChild = class(TBase)
function Value: Integer;
end;
function TBase.Value: Integer;
begin
Result := 1
end;
function TChild.Value: Integer;
begin
Result := inherited Value + 1
end;
begin
end.
''';
begin
ParseExpectErrorMsg(Src, 'requires () for a call');
end;
{ ------------------------------------------------------------------ }
{ TObject.InheritsFrom }
{ ------------------------------------------------------------------ }

52
compiler/src/test/pascal/cp.test.interfaces.pas
View file

@ -130,12 +130,6 @@ type
procedure TestCodegen_IntfDispatch_RecordArg_PassesAggregate;
procedure TestCodegen_IntfDispatch_OutString_PassesSlotAddr;
procedure TestCodegen_DiscardedIntfReturnStmt_GetsSretAndRelease;
{ ------------------------------------------------------------------ }
{ Forward interface declarations (IFoo = interface;) }
{ ------------------------------------------------------------------ }
procedure TestSemantic_ForwardInterface_CompletedByFullDecl;
procedure TestSemantic_ForwardInterface_Unresolved_RaisesError;
end;
implementation
@ -525,7 +519,7 @@ const
end;
procedure Tmi.use;
begin
im.print();
im.print;
end;
var
im: Tmi;
@ -1780,50 +1774,6 @@ begin
Pos('call $_ClassRelease', Copy(IR, CallPos, MaxInt)) > 0);
end;
{ ------------------------------------------------------------------ }
{ Forward interface declarations }
{ ------------------------------------------------------------------ }
procedure TInterfaceTests.TestSemantic_ForwardInterface_CompletedByFullDecl;
var
Prog: TProgram;
begin
{ `IFoo = interface;` forward stub completed later in the same scope. }
Prog := AnalyseSrc(
'''
program P;
type
IFoo = interface;
IBar = interface
function GetFoo: IFoo;
end;
IFoo = interface
function GetBar: IBar;
end;
begin
end.
''');
try
AssertTrue('forward interface completed by full decl analyses OK',
Prog <> nil);
finally
Prog.Free();
end;
end;
procedure TInterfaceTests.TestSemantic_ForwardInterface_Unresolved_RaisesError;
begin
{ A forward interface never completed in the scope is an error. }
AnalyseExpectError(
'''
program P;
type
IFoo = interface;
begin
end.
''');
end;
initialization
RegisterTest(TInterfaceTests);

95
compiler/src/test/pascal/cp.test.lexer.pas
View file

@ -44,11 +44,6 @@ type
procedure TestKeywords_CaseInsensitive;
procedure TestIdent_NotKeyword_Prefix;
{ Inline assembler blocks — asm ... end captured as one raw-text token }
procedure TestAsmBlock_CapturesRawText;
procedure TestAsmBlock_EndMentionedInComment_NotTerminator;
procedure TestAsmBlock_FollowedByDecl_StopsAtEnd;
{ Identifiers }
procedure TestIdent_Simple;
procedure TestIdent_WithUnderscore;
@ -82,11 +77,6 @@ type
procedure TestStringLit_Simple;
procedure TestStringLit_Empty;
procedure TestStringLit_EmbeddedQuote;
{ #nnnn / #$hhhh Unicode codepoint -> UTF-8 string literals }
procedure TestCodepoint_DecimalAscii;
procedure TestCodepoint_HexBmp_ThreeBytes;
procedure TestCodepoint_HexAstral_FourBytes;
procedure TestCodepoint_MergesWithStringAndEachOther;
{ Operators and punctuation }
procedure TestOp_Plus;
@ -323,50 +313,6 @@ begin
AssertEquals('Value', 'beginning', tok.Value);
end;
{ Inline assembler blocks }
procedure TLexerTests.TestAsmBlock_CapturesRawText;
var
tok: TToken;
begin
{ An asm ... end block is returned as ONE tkAsmBlock token whose Value is
the verbatim text between (exclusive) the asm keyword and the end keyword. }
SetLexer('asm' + #10 + ' movl %eax, %ebx' + #10 + ' ret' + #10 + 'end');
tok := FLexer.Next();
AssertEquals('Kind', Ord(tkAsmBlock), Ord(tok.Kind));
AssertTrue('has movl', Pos('movl %eax, %ebx', tok.Value) >= 0);
AssertTrue('has ret', Pos('ret', tok.Value) >= 0);
AssertTrue('no trailing end keyword captured', Pos('end', tok.Value) < 0);
end;
procedure TLexerTests.TestAsmBlock_EndMentionedInComment_NotTerminator;
var
tok: TToken;
begin
{ 'end' appearing inside a # line comment must NOT terminate the block —
only a standalone end keyword does. }
SetLexer('asm' + #10 + ' ret # this ends the block' + #10 + 'end');
tok := FLexer.Next();
AssertEquals('Kind', Ord(tkAsmBlock), Ord(tok.Kind));
AssertTrue('comment text preserved', Pos('this ends the block', tok.Value) >= 0);
AssertTrue('has ret', Pos('ret', tok.Value) >= 0);
end;
procedure TLexerTests.TestAsmBlock_FollowedByDecl_StopsAtEnd;
var
tok: TToken;
begin
{ After the block's end, normal tokenising resumes — the trailing ';' and the
next token are produced as usual. }
SetLexer('asm' + #10 + ' ret' + #10 + 'end; begin');
tok := FLexer.Next();
AssertEquals('asm block', Ord(tkAsmBlock), Ord(tok.Kind));
tok := FLexer.Next();
AssertEquals('semicolon after end', Ord(tkSemicolon), Ord(tok.Kind));
tok := FLexer.Next();
AssertEquals('begin resumes', Ord(tkBegin), Ord(tok.Kind));
end;
{ Identifiers }
procedure TLexerTests.TestIdent_Simple;
@ -454,47 +400,6 @@ begin
AssertEquals('Value', 'it''s', tok.Value);
end;
{ #nnnn / #$hhhh Unicode codepoint -> UTF-8 string literals }
procedure TLexerTests.TestCodepoint_DecimalAscii;
var tok: TToken;
begin
SetLexer('#65');
tok := FLexer.Next();
AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
AssertEquals('Value', 'A', tok.Value); { codepoint 65 -> 1 byte $41 }
end;
procedure TLexerTests.TestCodepoint_HexBmp_ThreeBytes;
var tok: TToken;
begin
SetLexer('#$20AC'); { EURO SIGN -> UTF-8 E2 82 AC }
tok := FLexer.Next();
AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
AssertEquals('len', 3, Length(tok.Value));
AssertEquals('Value', Chr($E2) + Chr($82) + Chr($AC), tok.Value);
end;
procedure TLexerTests.TestCodepoint_HexAstral_FourBytes;
var tok: TToken;
begin
SetLexer('#$1F600'); { GRINNING FACE -> UTF-8 F0 9F 98 80 }
tok := FLexer.Next();
AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
AssertEquals('len', 4, Length(tok.Value));
AssertEquals('Value', Chr($F0) + Chr($9F) + Chr($98) + Chr($80), tok.Value);
end;
procedure TLexerTests.TestCodepoint_MergesWithStringAndEachOther;
var tok: TToken;
begin
{ Adjacent # and '...' literals merge into one compile-time string. }
SetLexer('#72#73''!'''); { 'H' 'I' '!' }
tok := FLexer.Next();
AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
AssertEquals('Value', 'HI!', tok.Value);
end;
{ Operators and punctuation }
procedure TLexerTests.TestOp_Plus;

653
compiler/src/test/pascal/cp.test.linker.pas
View file

@ -18,7 +18,7 @@ unit cp.test.linker;
interface
uses
classes, SysUtils, process, blaise.testing, Generics.Collections,
SysUtils, process, blaise.testing, Generics.Collections,
blaise.elfreader, blaise.linker.elf, blaise.assembler.x86_64;
type
@ -58,8 +58,7 @@ type
procedure TestSym_SynthesisedSymbolsDefined;
{ Static relocations }
procedure TestReloc_PC32CrossObjectCall;
procedure TestReloc_Quad64_ResolvesToAbsoluteAddr;
procedure TestReloc_Abs32_ResolvesInStaticMode;
procedure TestReloc_Quad64_Raises;
{ Executable structure }
procedure TestExe_ElfHeaderIsExec;
procedure TestExe_EntryPointMatchesSymbol;
@ -75,34 +74,6 @@ type
procedure SetUp; override;
published
procedure TestRun_SyscallHelloWorld;
{ Linking with the FreeBSD target stamps EI_OSABI = 9 (ELFOSABI_FREEBSD)
in the ELF header and keeps the static ET_EXEC / _start shape. The
FreeBSD binary cannot execute on the Linux test host (different syscall
numbers), so this asserts the emitted header shape only — the structural
check the cross-compile lane relies on. }
procedure TestLink_FreeBSDTarget_StampsOSABI;
{ Step 3: linking the freestanding FreeBSD _start with the FreeBSD target
yields a static ET_EXEC whose entry point is _start and which has no
PT_INTERP — the Strategy-B shape a cross-compiled FreeBSD binary needs.
Asserts header shape only (it cannot run on the Linux host). }
procedure TestLink_FreeBSDStart_StaticExecShape;
{ Step 4a: a fixture that mirrors the runtime.syscall.freebsd file/process
leaves (open/read/write/mmap/stat) links under the FreeBSD target with the
bare POSIX symbols DEFINED, and the linked .text carries the FreeBSD
ino64 syscall NUMBERS (open=5, write=4, mmap=477, fstatat=552) plus the
CF-error-translation idiom (jae + negq). Standalone — no FreeBSD
emulation, header/byte shape only. }
procedure TestLink_FreeBSDSyscallLeaf_SymbolsAndNumbers;
{ Step 4b: the FreeBSD leaf additions — getrandom uses the FreeBSD number
(563, not Linux's 318) and the mremap stub is a plain function that returns
MAP_FAILED (-1) so runtime.mem takes its alloc-copy-free grow fallback (no
in-place remap syscall on FreeBSD). Standalone byte/symbol shape. }
procedure TestLink_FreeBSDSyscallLeaf_GetrandomAndMremapStub;
{ Step 4c: the FreeBSD threads/TLS leaf — thr_new (455), _umtx_op (454) and
thr_exit (431) link under the FreeBSD target with their FreeBSD syscall
numbers present in the linked .text, and NOT Linux's clone (56) / futex
(202). Standalone byte/symbol shape. }
procedure TestLink_FreeBSDThreadLeaf_SyscallNumbers;
end;
TDynLinkerTests = class(TTestCase)
@ -147,12 +118,6 @@ type
procedure TestRun_ExceptionHandling;
procedure TestRun_ClassAndVirtual;
procedure TestLink_MissingRTL_FailsLoudly;
{ Step 6: a full compiler-CLI cross-compile with --target freebsd-x86_64
selects the FreeBSD RTL adapter set (BuildRTLUnitList) and emits a static,
freestanding FreeBSD ET_EXEC — EI_OSABI = 9, no PT_INTERP, entry _start —
with no external tools. The binary cannot run on the Linux host, so this
asserts the emitted ELF shape only. }
procedure TestCompile_FreeBSDTarget_EmitsStaticFreeBSDExe;
end;
implementation
@ -359,92 +324,30 @@ end;
procedure TElfReaderTests.TestArchive_ParsesRTL;
var
Root, ObjDir, ArPath, ScriptOut: string;
Compiler: string;
RTLPath: string;
Members: TList<TArchiveMember>;
ObjList: TStringList;
Proc: TProcess;
Chunk: string;
I: Integer;
M: TArchiveMember;
Obj: TElfObjectFile;
SawLongName: Boolean;
SawSetjmp: Boolean;
begin
{ The shipped blaise_rtl.a is gone (RTL-unification Stage 3). To still
exercise the archive parser — including the GNU long-name (//) table on the
>15-char member rtl.platform.layout.linux.o — build the RTL objects from
source and bundle them into a THROWAWAY .a with `ar` just for this test.
`ar` is a test-time dependency only; the product/bootstrap no longer use it. }
Root := ProjectRoot();
Compiler := Root + 'compiler/target/blaise';
if (not FileExists(Compiler))
or (not FileExists(Root + 'compiler/src/main/pascal/runtime.arc.pas')) then
RTLPath := ProjectRoot() + 'compiler/target/blaise_rtl.a';
if not FileExists(RTLPath) then
begin
Ignore('<toolchain-missing>');
Exit;
end;
ObjDir := Root + 'compiler/target/test-archive-rtl';
ScriptOut := '';
Proc := TProcess.Create(nil);
try
Proc.Executable := Root + 'scripts/build-rtl-objects.sh';
Proc.Parameters.Add(Compiler);
Proc.Parameters.Add(ObjDir);
Proc.Parameters.Add('--with-startup');
Proc.Execute();
repeat
Chunk := Proc.ReadOutput();
ScriptOut := ScriptOut + Chunk
until (Chunk = '') and not Proc.Running;
Proc.WaitOnExit();
if Proc.ExitCode <> 0 then
begin
Ignore('<toolchain-missing>');
Exit;
end;
finally
Proc.Free();
end;
{ Bundle the built objects into a temp archive with ar. Split the script's
stdout (one object path per line) via TStringList. }
ArPath := IncludeTrailingPathDelimiter(ObjDir) + 'rtl_test.a';
DeleteFile(ArPath);
ObjList := TStringList.Create();
Proc := TProcess.Create(nil);
try
ObjList.Text := ScriptOut;
Proc.Executable := 'ar';
Proc.Parameters.Add('rcs');
Proc.Parameters.Add(ArPath);
for I := 0 to ObjList.Count - 1 do
if Trim(ObjList.Strings[I]) <> '' then
Proc.Parameters.Add(Trim(ObjList.Strings[I]));
Proc.Execute();
Proc.WaitOnExit();
if (Proc.ExitCode <> 0) or (not FileExists(ArPath)) then
begin
Ignore('<toolchain-missing>');
Exit;
end;
finally
Proc.Free();
ObjList.Free();
end;
Members := TList<TArchiveMember>.Create();
try
ReadArchiveFile(ArPath, Members);
ReadArchiveFile(RTLPath, Members);
AssertTrue('expected several RTL members, got '
+ IntToStr(Members.Count), Members.Count >= 5);
{ A member whose name exceeds 15 chars exercises the GNU long-name (//)
table. rtl.platform.layout.linux.o is the longest current RTL member. }
SawLongName := False;
SawSetjmp := False;
for I := 0 to Members.Count - 1 do
begin
M := Members.Get(I);
if M.Name = 'rtl.platform.layout.linux.o' then
SawLongName := True;
if M.Name = 'blaise_setjmp_x86_64.o' then
SawSetjmp := True;
{ Every member must parse as a valid x86-64 relocatable object
with at least its NULL section + one real section. }
Obj := ParseElfObject(M.Data, M.Name);
@ -455,8 +358,8 @@ begin
Obj.Free();
end;
end;
AssertTrue('long-named member rtl.platform.layout.linux.o not found '
+ '(GNU long-name table mishandled?)', SawLongName);
AssertTrue('long-named member blaise_setjmp_x86_64.o not found '
+ '(GNU long-name table mishandled?)', SawSetjmp);
finally
for I := 0 to Members.Count - 1 do
Members.Get(I).Free();
@ -815,73 +718,29 @@ begin
end;
end;
procedure TLinkerTests.TestReloc_Quad64_ResolvesToAbsoluteAddr;
procedure TLinkerTests.TestReloc_Quad64_Raises;
var
Lk: TLinker;
Bytes: string;
Raised: Boolean;
begin
{ An absolute 64-bit pointer to a symbol (`.quad target`, R_X86_64_64) is
resolvable at link time in a non-PIE ET_EXEC: every symbol has a fixed load
address. The static linker must patch the slot with target's absolute
address (no dynamic relocation) — this is what makes a freestanding static
--static link possible (docs/linux-syscall-migration.adoc). }
Lk := LinkObjs(
['.data' + LineEnding + 'ptr:' + LineEnding + '.quad target' + LineEnding +
'.text' + LineEnding + '.globl target' + LineEnding + 'target:' +
LineEnding + 'ret' + LineEnding +
'.globl _start' + LineEnding + '_start:' + LineEnding + 'ret' + LineEnding],
'_start', Bytes);
{ An absolute 64-bit pointer to a symbol needs dynamic linking under
a real PIE; Phase B rejects R_X86_64_64 explicitly. }
Raised := False;
Lk := nil;
try
{ The link must succeed and produce a valid ET_EXEC. }
AssertTrue('static R_X86_64_64 link produced no output', Length(Bytes) >= 64);
AssertEquals('e_type ET_EXEC', 2,
(Ord(Bytes[16]) and $FF) or ((Ord(Bytes[17]) and $FF) shl 8));
finally
Lk.Free();
end;
end;
procedure TLinkerTests.TestReloc_Abs32_ResolvesInStaticMode;
var
Lk: TLinker;
Bytes: string;
Addr, Got: Int64;
I, Slot: Integer;
begin
{ An absolute 32-bit data reference (.long target, R_X86_64_32) is
resolvable at link time in a non-PIE ET_EXEC: the image is linked at a
fixed base (0x400000) and every mapped address fits in 32 bits. The
OPDF emitter uses exactly this form (.long label) inside the .opdf
section, so a static FreeBSD link with debug info must accept it.
A marker word (0xDEADBEEF as decimal) precedes the slot so the test can
locate the patched bytes in the flat image. }
Lk := LinkObjs(
['.data' + LineEnding +
'marker:' + LineEnding + '.long 3735928559' + LineEnding +
'ptr32:' + LineEnding + '.long target' + LineEnding +
'.text' + LineEnding + '.globl target' + LineEnding + 'target:' +
LineEnding + 'ret' + LineEnding +
'.globl _start' + LineEnding + '_start:' + LineEnding + 'ret' + LineEnding],
'_start', Bytes);
try
Addr := Lk.AddrOfSymbol('target');
AssertTrue('target resolved above base', Addr > $400000);
{ Find the marker; the patched abs32 slot follows it. }
Slot := -1;
for I := 0 to Length(Bytes) - 9 do
if (OrdAt(Bytes, I) = $EF) and (OrdAt(Bytes, I + 1) = $BE) and
(OrdAt(Bytes, I + 2) = $AD) and (OrdAt(Bytes, I + 3) = $DE) then
begin
Slot := I + 4;
Break;
end;
AssertTrue('marker found in image', Slot >= 0);
Got := OrdAt(Bytes, Slot) or (OrdAt(Bytes, Slot + 1) shl 8) or
(OrdAt(Bytes, Slot + 2) shl 16) or (OrdAt(Bytes, Slot + 3) shl 24);
AssertEquals('abs32 slot patched with target address', Addr, Got);
finally
Lk.Free();
Lk := LinkObjs(
['.data' + LineEnding + 'ptr:' + LineEnding + '.quad target' + LineEnding +
'.text' + LineEnding + '.globl target' + LineEnding + 'target:' +
LineEnding + 'ret' + LineEnding +
'.globl _start' + LineEnding + '_start:' + LineEnding + 'ret' + LineEnding],
'_start', Bytes);
except
on E: ELinker do
Raised := True;
end;
Lk.Free();
AssertTrue('R_X86_64_64 must raise ELinker in Phase B', Raised);
end;
procedure TLinkerTests.TestExe_ElfHeaderIsExec;
@ -1053,354 +912,6 @@ begin
'Hello, linker!' + Chr(10), Output);
end;
procedure TLinkerE2ETests.TestLink_FreeBSDTarget_StampsOSABI;
const
FixtureAsm =
'.text' + LineEnding +
'.globl _start' + LineEnding +
'_start:' + LineEnding +
' movq $1, %rax' + LineEnding +
' movq $1, %rdi' + LineEnding +
' movq $60, %rax' + LineEnding +
' movq $0, %rdi' + LineEnding +
' .byte 15' + LineEnding + ' .byte 5' + LineEnding;
var
Lk: TLinker;
Obj: TElfObjectFile;
BinPath, Bytes: string;
begin
BinPath := FScratch + '/freebsd_osabi';
{ Build the linker with the FreeBSD link target (OSABI = 9). }
Lk := TLinker.Create(FreeBSDX86_64Target());
try
Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fb.o');
Lk.AddOwnedObject(Obj);
Lk.Link('_start', BinPath);
finally
Lk.Free();
end;
AssertTrue('linked FreeBSD binary missing', FileExists(BinPath));
Bytes := ReadFile(BinPath);
AssertTrue('output too small to be an ELF', Length(Bytes) >= 8);
{ ELF magic 0x7F 'E' 'L' 'F' at [0..3]; EI_OSABI is byte [7]. }
AssertEquals('ELF magic byte 0', $7F, OrdAt(Bytes, 0));
AssertEquals('EI_CLASS = ELFCLASS64', 2, OrdAt(Bytes, 4));
AssertEquals('EI_OSABI = ELFOSABI_FREEBSD (9)', 9, OrdAt(Bytes, 7));
end;
procedure TLinkerE2ETests.TestLink_FreeBSDStart_StaticExecShape;
const
{ A self-contained FreeBSD _start: capture the stack, then exit(0) via
SYS_exit = 1. Mirrors runtime.start.static.freebsd's entry shape without
pulling in main/_SetArgs, so it links with no undefined symbols. }
FixtureAsm =
'.text' + LineEnding +
'.globl _start' + LineEnding +
'_start:' + LineEnding +
' endbr64' + LineEnding +
' xorl %ebp, %ebp' + LineEnding +
' movq %rsp, %rdi' + LineEnding +
' xorl %edi, %edi' + LineEnding +
' movq $1, %rax' + LineEnding + { SYS_exit }
' syscall' + LineEnding +
' hlt' + LineEnding;
var
Lk: TLinker;
Obj: TElfObjectFile;
Bytes: string;
Entry, StartAddr: Int64;
PhOff, PhEntSz, PhCount, J, PType: Integer;
FoundInterp: Boolean;
begin
{ LinkToBytes returns the binary in memory — ReadFile would truncate at the
first NUL, which an ELF header hits at byte 8. }
Lk := TLinker.Create(FreeBSDX86_64Target());
try
Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbstart.o');
Lk.AddOwnedObject(Obj);
Bytes := Lk.LinkToBytes('_start');
StartAddr := Lk.AddrOfSymbol('_start');
finally
Lk.Free();
end;
AssertTrue('output too small to be an ELF', Length(Bytes) >= 64);
{ e_type at offset 16 must be ET_EXEC (2) — a static, non-PIE executable. }
AssertEquals('e_type ET_EXEC', 2, OrdAt(Bytes, 16) or (OrdAt(Bytes, 17) shl 8));
{ EI_OSABI byte 7 = ELFOSABI_FREEBSD. }
AssertEquals('EI_OSABI FreeBSD', 9, OrdAt(Bytes, 7));
{ e_entry (offset 24, 8 bytes LE) must equal the address of _start. }
Entry := Int64(OrdAt(Bytes, 24)) or (Int64(OrdAt(Bytes, 25)) shl 8) or
(Int64(OrdAt(Bytes, 26)) shl 16) or (Int64(OrdAt(Bytes, 27)) shl 24) or
(Int64(OrdAt(Bytes, 28)) shl 32) or (Int64(OrdAt(Bytes, 29)) shl 40) or
(Int64(OrdAt(Bytes, 30)) shl 48) or (Int64(OrdAt(Bytes, 31)) shl 56);
AssertEquals('entry point is _start', StartAddr, Entry);
{ No PT_INTERP (type 3) among the program headers — a freestanding binary has
no dynamic loader. }
PhOff := OrdAt(Bytes, 32) or (OrdAt(Bytes, 33) shl 8) or
(OrdAt(Bytes, 34) shl 16) or (OrdAt(Bytes, 35) shl 24);
PhEntSz := OrdAt(Bytes, 54) or (OrdAt(Bytes, 55) shl 8);
PhCount := OrdAt(Bytes, 56) or (OrdAt(Bytes, 57) shl 8);
FoundInterp := False;
for J := 0 to PhCount - 1 do
begin
PType := OrdAt(Bytes, PhOff + J * PhEntSz) or
(OrdAt(Bytes, PhOff + J * PhEntSz + 1) shl 8) or
(OrdAt(Bytes, PhOff + J * PhEntSz + 2) shl 16) or
(OrdAt(Bytes, PhOff + J * PhEntSz + 3) shl 24);
if PType = 3 then FoundInterp := True;
end;
AssertTrue('static ET_EXEC must have no PT_INTERP', not FoundInterp);
end;
procedure TLinkerE2ETests.TestLink_FreeBSDSyscallLeaf_SymbolsAndNumbers;
const
{ Mirrors the runtime.syscall.freebsd leaf bodies byte-for-byte (a handful of
representative leaves): each is `movq $N, %rax; syscall; jae ok; negq %rax;
ok: ret`, with mmap's `movq %rcx, %r10` and stat lowered to
fstatat(AT_FDCWD, path, buf, 0). Names are the bare POSIX symbols posix
imports. A leading _start keeps the linker's entry resolvable. }
FixtureAsm =
'.text' + LineEnding +
'.globl _start' + LineEnding +
'_start:' + LineEnding +
' callq open' + LineEnding +
' callq read' + LineEnding +
' callq write' + LineEnding +
' callq mmap' + LineEnding +
' callq stat' + LineEnding +
' xorl %edi, %edi' + LineEnding +
' movq $1, %rax' + LineEnding + { SYS_exit }
' syscall' + LineEnding +
' hlt' + LineEnding +
'.globl open' + LineEnding +
'open:' + LineEnding +
' movq $5, %rax' + LineEnding + { SYS_open }
' syscall' + LineEnding +
' jae .Lok_open' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_open:' + LineEnding +
' ret' + LineEnding +
'.globl read' + LineEnding +
'read:' + LineEnding +
' movq $3, %rax' + LineEnding + { SYS_read }
' syscall' + LineEnding +
' jae .Lok_read' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_read:' + LineEnding +
' ret' + LineEnding +
'.globl write' + LineEnding +
'write:' + LineEnding +
' movq $4, %rax' + LineEnding + { SYS_write }
' syscall' + LineEnding +
' jae .Lok_write' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_write:' + LineEnding +
' ret' + LineEnding +
'.globl mmap' + LineEnding +
'mmap:' + LineEnding +
' movq %rcx, %r10' + LineEnding +
' movq $477, %rax' + LineEnding + { SYS_mmap (ino64) }
' syscall' + LineEnding +
' jae .Lok_mmap' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_mmap:' + LineEnding +
' ret' + LineEnding +
'.globl stat' + LineEnding +
'stat:' + LineEnding +
' movq %rsi, %rdx' + LineEnding +
' movq %rdi, %rsi' + LineEnding +
' movq $-100, %rdi' + LineEnding + { AT_FDCWD }
' xorq %r10, %r10' + LineEnding +
' movq $552, %rax' + LineEnding + { SYS_fstatat (ino64) }
' syscall' + LineEnding +
' jae .Lok_stat' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_stat:' + LineEnding +
' ret' + LineEnding;
{ Encoded `movq $imm32, %rax` = 48 C7 C0 <imm32-LE>. These byte strings must
appear in the linked .text if the correct syscall number was emitted. }
function MovRaxImm(AImm: Integer): string;
begin
Result := Chr($48) + Chr($C7) + Chr($C0) +
Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
end;
var
Lk: TLinker;
Obj: TElfObjectFile;
Bytes: string;
begin
Lk := TLinker.Create(FreeBSDX86_64Target());
try
Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbsys.o');
Lk.AddOwnedObject(Obj);
Bytes := Lk.LinkToBytes('_start');
{ 1. The bare POSIX leaf symbols must be DEFINED (non-zero address). }
AssertTrue('open defined', Lk.AddrOfSymbol('open') > 0);
AssertTrue('read defined', Lk.AddrOfSymbol('read') > 0);
AssertTrue('write defined', Lk.AddrOfSymbol('write') > 0);
AssertTrue('mmap defined', Lk.AddrOfSymbol('mmap') > 0);
AssertTrue('stat defined', Lk.AddrOfSymbol('stat') > 0);
finally
Lk.Free();
end;
{ 2. FreeBSD ino64 syscall NUMBERS present in the linked .text as the
`movq $N, %rax` encoding — NOT Linux's numbers. }
AssertTrue('SYS_open=5 movq imm present', Pos(MovRaxImm(5), Bytes) >= 0);
AssertTrue('SYS_read=3 movq imm present', Pos(MovRaxImm(3), Bytes) >= 0);
AssertTrue('SYS_write=4 movq imm present', Pos(MovRaxImm(4), Bytes) >= 0);
AssertTrue('SYS_mmap=477 movq imm present', Pos(MovRaxImm(477), Bytes) >= 0);
AssertTrue('SYS_fstatat=552 movq imm present (stat via fstatat)',
Pos(MovRaxImm(552), Bytes) >= 0);
{ 3. The CF-error-translation idiom: negq %rax (48 F7 D8) must appear. This
is the FreeBSD-specific errno translation the Linux leaf does not emit. }
AssertTrue('negq %rax (CF translation) present',
Pos(Chr($48) + Chr($F7) + Chr($D8), Bytes) >= 0);
{ mmap's arg4 shuffle: movq %rcx, %r10 (49 89 CA). }
AssertTrue('movq %rcx,%r10 (mmap arg4) present',
Pos(Chr($49) + Chr($89) + Chr($CA), Bytes) >= 0);
end;
procedure TLinkerE2ETests.TestLink_FreeBSDSyscallLeaf_GetrandomAndMremapStub;
const
{ getrandom is a raw syscall with the FreeBSD number 563 (Linux's is 318).
mremap has no FreeBSD syscall, so the leaf's stub just returns MAP_FAILED
(-1) — a mov of -1 into %rax then ret; runtime.mem's realloc path treats
that as "grow the slow way". A leading _start keeps the entry resolvable. }
FixtureAsm =
'.text' + LineEnding +
'.globl _start' + LineEnding +
'_start:' + LineEnding +
' callq getrandom' + LineEnding +
' callq mremap' + LineEnding +
' xorl %edi, %edi' + LineEnding +
' movq $1, %rax' + LineEnding + { SYS_exit }
' syscall' + LineEnding +
' hlt' + LineEnding +
'.globl getrandom' + LineEnding +
'getrandom:' + LineEnding +
' movq $563, %rax' + LineEnding + { SYS_getrandom (FreeBSD) }
' syscall' + LineEnding +
' jae .Lok_gr' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_gr:' + LineEnding +
' ret' + LineEnding +
'.globl mremap' + LineEnding +
'mremap:' + LineEnding +
' movq $-1, %rax' + LineEnding + { MAP_FAILED — no FreeBSD mremap }
' ret' + LineEnding;
function MovRaxImm(AImm: Integer): string;
begin
Result := Chr($48) + Chr($C7) + Chr($C0) +
Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
end;
var
Lk: TLinker;
Obj: TElfObjectFile;
Bytes: string;
begin
Lk := TLinker.Create(FreeBSDX86_64Target());
try
Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbsys2.o');
Lk.AddOwnedObject(Obj);
Bytes := Lk.LinkToBytes('_start');
AssertTrue('getrandom defined', Lk.AddrOfSymbol('getrandom') > 0);
AssertTrue('mremap defined', Lk.AddrOfSymbol('mremap') > 0);
finally
Lk.Free();
end;
{ getrandom uses the FreeBSD number 563 — NOT Linux's 318. }
AssertTrue('SYS_getrandom=563 movq imm present', Pos(MovRaxImm(563), Bytes) >= 0);
AssertTrue('Linux SYS_getrandom=318 NOT present', Pos(MovRaxImm(318), Bytes) < 0);
{ mremap stub loads -1 (movq $-1,%rax = 48 C7 C0 FF FF FF FF). }
AssertTrue('mremap stub returns -1 (MAP_FAILED)', Pos(MovRaxImm(-1), Bytes) >= 0);
end;
procedure TLinkerE2ETests.TestLink_FreeBSDThreadLeaf_SyscallNumbers;
const
{ Mirrors the runtime.syscall.freebsd threads/TLS leaf bodies: thr_new (455),
_umtx_op (454, with its arg4 %rcx->%r10 shuffle) and thr_exit (431). These
are the FreeBSD analogues of Linux's clone (56) / futex (202) / exit (60);
the numbers MUST be FreeBSD's, not Linux's. A leading _start keeps the
linker's entry resolvable. }
FixtureAsm =
'.text' + LineEnding +
'.globl _start' + LineEnding +
'_start:' + LineEnding +
' callq thr_new' + LineEnding +
' callq _umtx_op' + LineEnding +
' callq thr_exit' + LineEnding +
' xorl %edi, %edi' + LineEnding +
' movq $1, %rax' + LineEnding + { SYS_exit }
' syscall' + LineEnding +
' hlt' + LineEnding +
'.globl thr_new' + LineEnding +
'thr_new:' + LineEnding +
' movq $455, %rax' + LineEnding + { SYS_thr_new }
' syscall' + LineEnding +
' jae .Lok_thr_new' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_thr_new:' + LineEnding +
' ret' + LineEnding +
'.globl _umtx_op' + LineEnding +
'_umtx_op:' + LineEnding +
' movq %rcx, %r10' + LineEnding +
' movq $454, %rax' + LineEnding + { SYS__umtx_op }
' syscall' + LineEnding +
' jae .Lok_umtx' + LineEnding +
' negq %rax' + LineEnding +
'.Lok_umtx:' + LineEnding +
' ret' + LineEnding +
'.globl thr_exit' + LineEnding +
'thr_exit:' + LineEnding +
' movq $431, %rax' + LineEnding + { SYS_thr_exit }
' syscall' + LineEnding +
' ret' + LineEnding;
{ Encoded `movq $imm32, %rax` = 48 C7 C0 <imm32-LE>. }
function MovRaxImm(AImm: Integer): string;
begin
Result := Chr($48) + Chr($C7) + Chr($C0) +
Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
end;
var
Lk: TLinker;
Obj: TElfObjectFile;
Bytes: string;
begin
Lk := TLinker.Create(FreeBSDX86_64Target());
try
Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbthr.o');
Lk.AddOwnedObject(Obj);
Bytes := Lk.LinkToBytes('_start');
{ The bare thread-primitive symbols must be DEFINED (non-zero address). }
AssertTrue('thr_new defined', Lk.AddrOfSymbol('thr_new') > 0);
AssertTrue('_umtx_op defined', Lk.AddrOfSymbol('_umtx_op') > 0);
AssertTrue('thr_exit defined', Lk.AddrOfSymbol('thr_exit') > 0);
finally
Lk.Free();
end;
{ FreeBSD thread syscall NUMBERS present in the linked .text. }
AssertTrue('SYS_thr_new=455 movq imm present', Pos(MovRaxImm(455), Bytes) >= 0);
AssertTrue('SYS__umtx_op=454 movq imm present', Pos(MovRaxImm(454), Bytes) >= 0);
AssertTrue('SYS_thr_exit=431 movq imm present', Pos(MovRaxImm(431), Bytes) >= 0);
{ NOT Linux's clone (56) / futex (202) — those numbers must be absent. }
AssertTrue('Linux SYS_clone=56 NOT present', Pos(MovRaxImm(56), Bytes) < 0);
AssertTrue('Linux SYS_futex=202 NOT present', Pos(MovRaxImm(202), Bytes) < 0);
{ _umtx_op's arg4 shuffle: movq %rcx, %r10 (49 89 CA). }
AssertTrue('movq %rcx,%r10 (_umtx_op arg4) present',
Pos(Chr($49) + Chr($89) + Chr($CA), Bytes) >= 0);
end;
{ ---- TDynLinkerTests ---- }
function TDynLinkerTests.ProjectRoot: string;
@ -1675,7 +1186,7 @@ procedure TInternalLinkerE2ETests.SetUp;
begin
inherited SetUp();
FCompiler := ProjectRoot() + 'compiler/target/blaise';
FRTLPath := ProjectRoot() + 'compiler/src/main/pascal';
FRTLPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibPath := ProjectRoot() + 'stdlib/src/main/pascal';
FScratch := ProjectRoot() + 'compiler/target/intlink_scratch/';
ForceDirectories(FScratch);
@ -1684,15 +1195,13 @@ end;
function TInternalLinkerE2ETests.CompilerAvailable: Boolean;
begin
{ The compiler source-builds the RTL itself (no blaise_rtl.a); only the binary
and the RTL source need to be present. }
Result := FileExists(FCompiler) and
FileExists(FRTLPath + '/runtime.arc.pas');
FileExists(ProjectRoot() + 'compiler/target/blaise_rtl.a');
if (not Result) and (not GIntLinkSkipNoted) then
begin
GIntLinkSkipNoted := True;
WriteLn(StdErr, 'note: TInternalLinkerE2ETests skipped — compiler binary "',
FCompiler, '" or RTL source not found');
FCompiler, '" not found');
end;
end;
@ -1906,7 +1415,17 @@ begin
FCounter := FCounter + 1;
IsoDir := FScratch + 'no_rtl_' + IntToStr(FCounter) + '/';
ForceDirectories(IsoDir);
IsoCompiler := FCompiler;
IsoCompiler := IsoDir + 'blaise';
{ Symlink the real compiler into the isolated dir — argv[0]'s dirname is the
isolated dir, which has NO blaise_rtl.a beside it, so FindRTLArchive
returns ''. (A symlink avoids copying the multi-MB binary and the
byte-exactness pitfalls of a string round-trip.) }
if FileExists(IsoCompiler) then DeleteFile(IsoCompiler);
if _test_symlink(PChar(FCompiler), PChar(IsoCompiler)) <> 0 then
begin
Ignore('<symlink-unavailable>');
Exit;
end;
SrcFile := IsoDir + 'prog.pas';
OutFile := IsoDir + 'prog';
@ -1916,93 +1435,23 @@ begin
' WriteLn(6 * 7)' + LineEnding +
'end.');
{ The RTL is now compiled from SOURCE by the compiler at link time (no prebuilt
blaise_rtl.a). Point --rtl-src at a nonexistent directory so the RTL source
is unreachable: the driver must fail loudly rather than emit a broken binary. }
{ BLAISE_RTL is normally unset in the test environment; the isolated dir has
no blaise_rtl.a, so FindRTLArchive returns '' and the guard must fire. }
Rc := Self.RunProc(IsoCompiler, [
'--source', SrcFile,
'--unit-path', FStdlibPath,
'--output', OutFile,
'--backend', 'native',
'--assembler', 'internal',
'--linker', 'internal',
'--rtl-src', IsoDir + 'no_such_rtl_src'
], CompOut);
AssertTrue('compiler must FAIL when the RTL source is unreachable (got rc=0)',
Rc <> 0);
AssertTrue('error must name the missing RTL source: ' + CompOut,
Pos('RTL source', CompOut) >= 0);
AssertFalse('no output binary should be produced on RTL-missing failure',
FileExists(OutFile));
end;
procedure TInternalLinkerE2ETests.TestCompile_FreeBSDTarget_EmitsStaticFreeBSDExe;
var
SrcFile, OutFile, CompOut, Bytes: string;
Rc, PhOff, PhEntSz, PhCount, J, PType: Integer;
FoundInterp: Boolean;
begin
if not Self.CompilerAvailable() then
begin
Ignore('<toolchain-missing>');
Exit;
end;
FCounter := FCounter + 1;
SrcFile := FScratch + 'test_fbsd_' + IntToStr(FCounter) + '.pas';
OutFile := FScratch + 'test_fbsd_' + IntToStr(FCounter);
WriteFile(SrcFile,
'program test_fbsd;' + LineEnding +
'begin' + LineEnding +
' WriteLn(''Hello'')' + LineEnding +
'end.');
{ Full compiler-CLI cross-compile. --target freebsd-x86_64 must select the
FreeBSD RTL adapter set and drive the static, freestanding link with no
external tools (internal assembler + linker). }
Rc := Self.RunProc(FCompiler, [
'--source', SrcFile,
'--unit-path', FRTLPath,
'--unit-path', FStdlibPath,
'--output', OutFile,
'--backend', 'native',
'--assembler', 'internal',
'--linker', 'internal',
'--target', 'freebsd-x86_64'
'--linker', 'internal'
], CompOut);
if Rc <> 0 then
Fail('--target freebsd-x86_64 compile failed (rc=' + IntToStr(Rc) + '): ' +
CompOut);
AssertTrue('FreeBSD binary was produced', FileExists(OutFile));
{ The FreeBSD binary cannot run on the Linux host — assert its ELF shape.
ReadWholeFile is NUL-safe (unlike the RTL ReadFile, which stops at the
first NUL — an ELF header hits one at byte 8). }
Bytes := ReadWholeFile(OutFile);
AssertTrue('output too small to be an ELF', Length(Bytes) >= 64);
{ EI_OSABI byte 7 = ELFOSABI_FREEBSD (9). }
AssertEquals('EI_OSABI FreeBSD', 9, OrdAt(Bytes, 7));
{ e_type at offset 16 = ET_EXEC (2) — static, non-PIE. }
AssertEquals('e_type ET_EXEC', 2, OrdAt(Bytes, 16) or (OrdAt(Bytes, 17) shl 8));
{ No PT_INTERP (program-header type 3): a freestanding binary has no dynamic
loader. }
PhOff := OrdAt(Bytes, 32) or (OrdAt(Bytes, 33) shl 8) or
(OrdAt(Bytes, 34) shl 16) or (OrdAt(Bytes, 35) shl 24);
PhEntSz := OrdAt(Bytes, 54) or (OrdAt(Bytes, 55) shl 8);
PhCount := OrdAt(Bytes, 56) or (OrdAt(Bytes, 57) shl 8);
FoundInterp := False;
for J := 0 to PhCount - 1 do
begin
PType := OrdAt(Bytes, PhOff + J * PhEntSz) or
(OrdAt(Bytes, PhOff + J * PhEntSz + 1) shl 8) or
(OrdAt(Bytes, PhOff + J * PhEntSz + 2) shl 16) or
(OrdAt(Bytes, PhOff + J * PhEntSz + 3) shl 24);
if PType = 3 then FoundInterp := True;
end;
AssertFalse('freestanding FreeBSD exe must have no PT_INTERP', FoundInterp);
AssertTrue('compiler must FAIL when RTL is unreachable (got rc=0)', Rc <> 0);
AssertTrue('error must name the missing RTL archive: ' + CompOut,
Pos('blaise_rtl.a', CompOut) >= 0);
AssertFalse('no output binary should be produced on RTL-missing failure',
FileExists(OutFile));
end;
initialization

2
compiler/src/test/pascal/cp.test.math.pas
View file

@ -192,7 +192,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;

2
compiler/src/test/pascal/cp.test.methods.pas
View file

@ -376,7 +376,7 @@ begin
var F: TFoo;
begin
F := TFoo.Create();
F.NoSuchMethod()
F.NoSuchMethod
end.
''');
end;

398
compiler/src/test/pascal/cp.test.multifile.pas
View file

@ -37,33 +37,17 @@ type
procedure TestUnitLoader_LocatesUnitInSearchPath;
procedure TestUnitLoader_RaisesOnMissingUnit;
procedure TestUnitLoader_DetectsCycle;
procedure TestUnitLoader_ImplSectionBackEdge_Tolerated;
procedure TestUnitLoader_DependencyOrder;
{ ------------------------------------------------------------------ }
{ AnalyseUnitForExport }
{ ------------------------------------------------------------------ }
procedure TestSemanticAnalyser_ExportedTypeVisibleInProgram;
procedure TestSemanticAnalyser_ExportedFuncVisibleInProgram;
{ Flat-merge of units that each privately bind the same external C symbol,
or bind to a real RTL function — must not raise a false
"ambiguous overload" / "duplicate identifier" (bugs.txt: runtime module
library compile failed). }
procedure TestSemanticAnalyser_DuplicateExternalBindingTolerated;
procedure TestSemanticAnalyser_ExternalBindingToRealFuncTolerated;
procedure TestSemanticAnalyser_PrivateImplProcsPerUnitNotAmbiguous;
{ ------------------------------------------------------------------ }
{ Combined code generation }
{ ------------------------------------------------------------------ }
procedure TestCodegen_TwoFileCompile_UnitFuncExported;
procedure TestCodegen_TwoFileCompile_MainPresent;
{ Two used units export the same global var name; a qualified reference
'Unit.V' must emit each unit's own owner-prefixed storage symbol so the
two refer to distinct slots rather than colliding on a bare '$V'. }
procedure TestCodegen_CrossUnitQualifiedVar_DistinctSymbols;
{ Two used units export a class of the same name; each unit's codegen pass
must emit its type's storage symbols (typeinfo/vtable/__cn) keyed on its
own unit, so the two coexist instead of colliding on the flat winner. }
procedure TestCodegen_CrossUnitType_DistinctSymbols;
end;
implementation
@ -250,57 +234,6 @@ begin
end;
end;
procedure TMultifileTests.TestUnitLoader_ImplSectionBackEdge_Tolerated;
const
{ BackA's INTERFACE uses BackB; BackB's IMPLEMENTATION uses BackA. This is a
legal Object Pascal arrangement — interfaces are compiled before bodies, so
BackB's body may name BackA even though BackA's interface (transitively)
needs BackB. It must load without an ECircularDependency, unlike the
interface↔interface cycle above. }
SrcA =
'''
unit BackA;
interface
uses BackB;
implementation
end.
''';
SrcB =
'''
unit BackB;
interface
implementation
uses BackA;
end.
''';
var
Paths: TStringList;
Loader: TUnitLoader;
Names: TStringList;
Units: TObjectList;
begin
WriteUnit('BackA', SrcA);
WriteUnit('BackB', SrcB);
Paths := MakeSearchPaths();
Loader := TUnitLoader.Create(Paths);
Names := TStringList.Create();
try
Names.Add('BackA');
{ Must NOT raise — the back-edge is through an implementation-section use. }
Units := Loader.LoadAll(Names);
try
AssertEquals('both units loaded', 2, Units.Count);
finally
Units.Free();
end;
finally
Names.Free();
Loader.Free();
Paths.Free();
end;
end;
procedure TMultifileTests.TestUnitLoader_DependencyOrder;
const
SrcC =
@ -446,197 +379,6 @@ begin
end;
end;
procedure TMultifileTests.TestSemanticAnalyser_DuplicateExternalBindingTolerated;
const
{ Two units each declare the SAME parameterless external C binding in their
implementation section and call it. In the flat-merge both land in the
one global overload group; they denote ONE function and must collapse. }
UnitASrc =
'''
unit AltA;
interface
procedure DoA;
implementation
procedure ext_abort; external name 'abort';
procedure DoA;
begin
ext_abort()
end;
end.
''';
UnitBSrc =
'''
unit AltB;
interface
procedure DoB;
implementation
procedure ext_abort; external name 'abort';
procedure DoB;
begin
ext_abort()
end;
end.
''';
ProgSrc =
'''
program TestP;
uses AltA, AltB;
begin
DoA(); DoB()
end.
''';
var
UA, UB: TUnit;
Prog: TProgram;
SA: TSemanticAnalyser;
begin
UA := ParseUnitSrc(UnitASrc);
UB := ParseUnitSrc(UnitBSrc);
Prog := ParseProg(ProgSrc);
SA := TSemanticAnalyser.Create();
try
SA.AnalyseUnitForExport(UA);
SA.AnalyseUnitForExport(UB);
SA.Analyse(Prog);
AssertNotNull('prog analysed without ambiguity', Prog.SymbolTable);
finally
SA.Free();
Prog.Free();
UB.Free();
UA.Free();
end;
end;
procedure TMultifileTests.TestSemanticAnalyser_ExternalBindingToRealFuncTolerated;
const
{ An unmangled RTL-style unit (blaise_*) exports a real function whose link
symbol is its bare name; a second unit binds to it via `external name`.
The flat-merge sees one real def + one external binding for the same link
symbol — must not be a duplicate identifier nor an ambiguous overload. }
MemSrc =
'''
unit blaise_testmem;
interface
function _TestGetMem(Size: Integer): Pointer;
implementation
function _TestGetMem(Size: Integer): Pointer;
begin
Result := nil
end;
end.
''';
UseSrc =
'''
unit UserU;
interface
function GrabMem: Pointer;
implementation
function _TestGetMem(Size: Integer): Pointer; external name '_TestGetMem';
function GrabMem: Pointer;
begin
Result := _TestGetMem(8)
end;
end.
''';
ProgSrc =
'''
program TestP;
uses blaise_testmem, UserU;
var p: Pointer;
begin
p := GrabMem()
end.
''';
var
UM, UU: TUnit;
Prog: TProgram;
SA: TSemanticAnalyser;
begin
UM := ParseUnitSrc(MemSrc);
UU := ParseUnitSrc(UseSrc);
Prog := ParseProg(ProgSrc);
SA := TSemanticAnalyser.Create();
try
SA.AnalyseUnitForExport(UM);
SA.AnalyseUnitForExport(UU);
SA.Analyse(Prog);
AssertNotNull('prog analysed: external binding to real func', Prog.SymbolTable);
finally
SA.Free();
Prog.Free();
UU.Free();
UM.Free();
end;
end;
procedure TMultifileTests.TestSemanticAnalyser_PrivateImplProcsPerUnitNotAmbiguous;
const
{ Two units each declare a PRIVATE (implementation-only, non-external) helper
of the same name and call it. Each unit's call must bind to its own copy;
the other unit's private helper is not a visible competing candidate. }
UnitASrc =
'''
unit PrivA;
interface
function GoA: Integer;
implementation
function Helper(X: Integer): Integer;
begin
Result := X + 1
end;
function GoA: Integer;
begin
Result := Helper(10)
end;
end.
''';
UnitBSrc =
'''
unit PrivB;
interface
function GoB: Integer;
implementation
function Helper(X: Integer): Integer;
begin
Result := X + 2
end;
function GoB: Integer;
begin
Result := Helper(20)
end;
end.
''';
ProgSrc =
'''
program TestP;
uses PrivA, PrivB;
var r: Integer;
begin
r := GoA() + GoB()
end.
''';
var
UA, UB: TUnit;
Prog: TProgram;
SA: TSemanticAnalyser;
begin
UA := ParseUnitSrc(UnitASrc);
UB := ParseUnitSrc(UnitBSrc);
Prog := ParseProg(ProgSrc);
SA := TSemanticAnalyser.Create();
try
SA.AnalyseUnitForExport(UA);
SA.AnalyseUnitForExport(UB);
SA.Analyse(Prog);
AssertNotNull('prog analysed: per-unit private helpers', Prog.SymbolTable);
finally
SA.Free();
Prog.Free();
UB.Free();
UA.Free();
end;
end;
{ ------------------------------------------------------------------ }
{ Combined code generation tests }
{ ------------------------------------------------------------------ }
@ -741,146 +483,6 @@ begin
end;
end;
procedure TMultifileTests.TestCodegen_CrossUnitQualifiedVar_DistinctSymbols;
const
UnitA =
'''
unit uva;
interface
var V: Integer = 7;
implementation
end.
''';
UnitB =
'''
unit uvb;
interface
var V: Integer = 9;
implementation
end.
''';
ProgSrc =
'''
program TestP;
uses uva, uvb;
var r: Integer;
begin
r := uva.V;
r := uvb.V
end.
''';
var
UA, UB: TUnit;
Prog: TProgram;
SA: TSemanticAnalyser;
CG: TCodeGenQBE;
IR: string;
begin
UA := ParseUnitSrc(UnitA);
UB := ParseUnitSrc(UnitB);
Prog := ParseProg(ProgSrc);
SA := TSemanticAnalyser.Create();
CG := TCodeGenQBE.Create();
try
SA.AnalyseUnitForExport(UA);
SA.AnalyseUnitForExport(UB);
SA.Analyse(Prog);
CG.AppendUnit(UA);
CG.AppendUnit(UB);
CG.AppendProgram(Prog);
IR := CG.GetOutput();
{ Each unit defines its own owner-prefixed slot, and the qualified loads
reference both — proving the two same-named vars do not collapse. }
AssertTrue('uva.V slot referenced', Pos('$uva_V', IR) > 0);
AssertTrue('uvb.V slot referenced', Pos('$uvb_V', IR) > 0);
finally
CG.Free();
SA.Free();
Prog.Free();
UB.Free();
UA.Free();
end;
end;
procedure TMultifileTests.TestCodegen_CrossUnitType_DistinctSymbols;
const
UnitA =
'''
unit tca;
interface
type
TShape = class
function Sides: Integer;
end;
implementation
function TShape.Sides: Integer;
begin
Result := 3
end;
end.
''';
UnitB =
'''
unit tcb;
interface
type
TShape = class
function Sides: Integer;
end;
implementation
function TShape.Sides: Integer;
begin
Result := 4
end;
end.
''';
ProgSrc =
'''
program TestP;
uses tca, tcb;
var S: TShape;
begin
S := TShape.Create()
end.
''';
var
UA, UB: TUnit;
Prog: TProgram;
SA: TSemanticAnalyser;
CG: TCodeGenQBE;
IR: string;
begin
UA := ParseUnitSrc(UnitA);
UB := ParseUnitSrc(UnitB);
Prog := ParseProg(ProgSrc);
SA := TSemanticAnalyser.Create();
CG := TCodeGenQBE.Create();
try
SA.AnalyseUnitForExport(UA);
SA.AnalyseUnitForExport(UB);
SA.Analyse(Prog);
CG.SetSymbolTable(Prog.SymbolTable);
CG.AppendUnit(UA);
CG.AppendUnit(UB);
CG.AppendProgram(Prog);
IR := CG.GetOutput();
{ Each unit emits its own owner-prefixed type symbols — no collision on a
single bare/winner symbol, and both class-name string blobs are distinct. }
AssertTrue('tca typeinfo', Pos('typeinfo_tca_TShape', IR) > 0);
AssertTrue('tcb typeinfo', Pos('typeinfo_tcb_TShape', IR) > 0);
AssertTrue('tca vtable', Pos('vtable_tca_TShape', IR) > 0);
AssertTrue('tcb vtable', Pos('vtable_tcb_TShape', IR) > 0);
AssertTrue('tca classname', Pos('__cn_tca_TShape', IR) > 0);
AssertTrue('tcb classname', Pos('__cn_tcb_TShape', IR) > 0);
finally
CG.Free();
SA.Free();
Prog.Free();
UB.Free();
UA.Free();
end;
end;
initialization
RegisterTest(TMultifileTests);
end.

2
compiler/src/test/pascal/cp.test.multiwrite.pas
View file

@ -155,7 +155,7 @@ begin
'''
program P;
begin
WriteLn()
WriteLn
end.
''');
AssertTrue('empty WriteLn still emits newline',

77
compiler/src/test/pascal/cp.test.nativeconstarg.pas
View file

@ -65,13 +65,6 @@ type
into an SSE (xmm) argument register per the System V ABI, not an integer
register. Asserts the call site emits movsd into %xmm0. }
procedure TestMethodFloatArg_LoadedIntoXmm;
{ Inline asm: a nostackframe asm-body function emits the verbatim block and
NO compiler prologue (no pushq %rbp / frame subq). }
procedure TestInlineAsm_VerbatimBody_NoPrologue;
{ Regression: an implicit-Self call whose Self+args exceed the six integer
argument registers spills the overflow to the stack (it used to abort
codegen). Asserts the slot-block overflow shape and the dispatch. }
procedure TestImplicitSelfCall_RegisterOverflow_Spills;
end;
implementation
@ -650,76 +643,14 @@ const
end.
''';
var
AsmText: string;
Asm: string;
begin
AsmText := GenAsm(Src);
Asm := GenAsm(Src);
{ The Double argument must reach the SSE arg register, not an integer one. }
AssertTrue('float method arg loaded into %xmm0',
Pos('movsd', AsmText) >= 0);
Pos('movsd', Asm) >= 0);
AssertTrue('float method arg targets the SSE arg register',
Pos('%xmm0', AsmText) >= 0);
end;
procedure TNativeConstArgTests.TestInlineAsm_VerbatimBody_NoPrologue;
const
Src = '''
program P;
function GetFortyTwo: Integer; assembler; nostackframe;
asm
movl $42, %eax
ret
end;
begin
WriteLn(GetFortyTwo())
end.
''';
var
AsmText: string;
Region: string;
begin
AsmText := GenAsm(Src);
Region := Self.FuncRegion(AsmText, 'GetFortyTwo');
{ The verbatim asm instructions appear in the function body. }
AssertTrue('verbatim movl $42', Pos('movl $42, %eax', Region) >= 0);
AssertTrue('verbatim ret', Pos('ret', Region) >= 0);
{ nostackframe: no compiler-emitted prologue inside the function. }
AssertTrue('no pushq %rbp prologue', Pos('pushq %rbp', Region) < 0);
end;
procedure TNativeConstArgTests.TestImplicitSelfCall_RegisterOverflow_Spills;
const
Src = '''
program P;
type
TW = class
function C(a, b, c, d, e, f, g: Integer): Integer;
function D(): Integer;
end;
function TW.C(a, b, c, d, e, f, g: Integer): Integer;
begin
Result := a;
end;
function TW.D(): Integer;
begin
Result := C(1, 2, 3, 4, 5, 6, 7);
end;
begin
end.
''';
var
Region: string;
begin
{ Implicit-Self call C(...): Self (%rdi) + 7 args = 8 integer slots. Six load
into registers; the last two spill to the stack. The slot-block overflow
path stores Self into 0(%rsp) and fills all six integer arg registers —
unlike the <=6 push/pop fast path. Before the fix this aborted codegen with
'arg register index 6 out of range'. }
Region := FuncRegion(GenAsm(Src), 'TW_D');
AssertTrue('overflow call dispatched', Pos('callq TW_C', Region) >= 0);
AssertTrue('Self stored into slot 0 (overflow slot-block path)',
Pos('movq %rax, 0(%rsp)', Region) >= 0);
AssertTrue('arg registers filled through %r9',
(Pos('%r8', Region) >= 0) and (Pos('%r9', Region) >= 0));
Pos('%xmm0', Asm) >= 0);
end;
initialization

2
compiler/src/test/pascal/cp.test.numerics.decimal.pas
View file

@ -91,7 +91,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;

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

@ -79,7 +79,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;

158
compiler/src/test/pascal/cp.test.opdf.pas
View file

@ -27,13 +27,7 @@ type
procedure TestOPDF_Primitive_Integer;
procedure TestOPDF_Primitive_Boolean;
procedure TestOPDF_Primitive_Int64;
procedure TestOPDF_Primitive_Double_SubKindFloat;
procedure TestOPDF_Primitive_Single_SubKindFloat;
procedure TestOPDF_AnsiStr_Record;
{ A string constant whose value contains a double-quote, newline or
backslash must be C-escaped in the recConstant `.ascii` line, else the
literal closes early and the assembler sees a garbage mnemonic. }
procedure TestOPDF_StringConst_SpecialChars_Escaped;
procedure TestOPDF_GlobalVar_QuadLabel;
procedure TestOPDF_GlobalVar_RecType;
procedure TestOPDF_Enum_RecType;
@ -67,7 +61,6 @@ type
procedure TestOPDF_Set_RecType;
procedure TestOPDF_Set_SizeInBytes;
procedure TestOPDF_Property_RecType;
procedure TestOPDF_Property_MethodBacked_LayoutIntact;
procedure TestOPDF_Interface_RecType;
procedure TestOPDF_Constant_OrdRecord;
procedure TestOPDF_Constant_OrdValue;
@ -76,11 +69,6 @@ type
procedure TestOPDF_Constant_Real;
procedure TestOPDF_UnitDir_Present;
procedure TestOPDF_UnitDir_UnitCount;
{ recRuntimeHelper — RTL release routines the debugger injects to free a
+1 transient an injected property getter returns. }
procedure TestOPDF_RuntimeHelper_StringRelease;
procedure TestOPDF_RuntimeHelper_DynArrayRelease;
procedure TestOPDF_RuntimeHelper_KindOrdinals;
end;
implementation
@ -181,44 +169,6 @@ begin
AssertTrue('recPrimitive Int64 present', Contains(IR, '# recPrimitive: Int64'));
end;
procedure TOPDFTests.TestOPDF_Primitive_Double_SubKindFloat;
{ Regression: float types emitted NO recPrimitive at all, so a Double/Single
variable referenced a TypeID with no type record and pdr could not print it
(locals/print/gl all failed for floats). A Double must now emit a recPrimitive
with SubKind=SK_FLOAT(4) and SizeInBytes=8 so pdr's TFloatEvaluator
(Category=tcFloat, keyed off SubKind in [skFloat, skCurrency]) renders it. }
var
IR: string;
P: Integer;
begin
IR := GenOPDF('program P; var D: Double; begin D := 1.5 end.');
AssertTrue('recPrimitive Double comment', Contains(IR, '# recPrimitive: Double'));
AssertTrue('Double name emitted', Contains(IR, '.ascii "Double"'));
P := Pos('# recPrimitive: Double', IR);
AssertTrue('Double recPrimitive present', P >= 0);
{ SubKind must be SK_FLOAT (4) and size 8, in the Double record's payload. }
AssertTrue('Double SubKind = 4 (skFloat)',
Pos('.byte 4 # SubKind', Copy(IR, P, 220)) >= 0);
AssertTrue('Double SizeInBytes = 8',
Pos('.byte 8 # SizeInBytes', Copy(IR, P, 220)) >= 0);
end;
procedure TOPDFTests.TestOPDF_Primitive_Single_SubKindFloat;
{ Single is the 4-byte float counterpart; same recPrimitive shape, size 4. }
var
IR: string;
P: Integer;
begin
IR := GenOPDF('program P; var S: Single; begin S := 1.5 end.');
AssertTrue('recPrimitive Single comment', Contains(IR, '# recPrimitive: Single'));
P := Pos('# recPrimitive: Single', IR);
AssertTrue('Single recPrimitive present', P >= 0);
AssertTrue('Single SubKind = 4 (skFloat)',
Pos('.byte 4 # SubKind', Copy(IR, P, 220)) >= 0);
AssertTrue('Single SizeInBytes = 4',
Pos('.byte 4 # SizeInBytes', Copy(IR, P, 220)) >= 0);
end;
procedure TOPDFTests.TestOPDF_AnsiStr_Record;
var
IR: string;
@ -228,41 +178,6 @@ begin
AssertTrue('Utf8String name emitted', Contains(IR, '.ascii "Utf8String"'));
end;
procedure TOPDFTests.TestOPDF_StringConst_SpecialChars_Escaped;
var
IR: string;
begin
{ A string const whose value is a single double-quote must be emitted as
`.ascii "\""`, NOT `.ascii """` (which closes the literal after the first
quote and leaves `" # Value` as a stray token). }
IR := GenOPDF(
'''
program P;
const Q = '"';
begin end.
''');
AssertTrue('quote value is escaped', Contains(IR, '.ascii "\"" # Value'));
AssertFalse('no unescaped triple-quote', Contains(IR, '.ascii """ # Value'));
{ A newline in the value must become \n, not a literal line break. }
IR := GenOPDF(
'''
program P;
const NL = 'a'#10'b';
begin end.
''');
AssertTrue('newline escaped as \n', Contains(IR, '.ascii "a\nb" # Value'));
{ A backslash must be doubled. }
IR := GenOPDF(
'''
program P;
const BS = 'a\b';
begin end.
''');
AssertTrue('backslash doubled', Contains(IR, '.ascii "a\\b" # Value'));
end;
procedure TOPDFTests.TestOPDF_GlobalVar_QuadLabel;
var
IR: string;
@ -691,47 +606,6 @@ begin
AssertTrue('recProperty comment', Contains(IR, '# recProperty: Val'));
end;
procedure TOPDFTests.TestOPDF_Property_MethodBacked_LayoutIntact;
{ Regression for the recProperty corruption (bugs.txt, opdebugger #10/#13 era):
a method-backed property must emit a COMPLETE, correctly-sized recProperty so
the reader (which reads SizeOf(TDefProperty)=32 fixed bytes then the three
length-prefixed strings) does not overshoot into the next record. The fixed
payload is 32 bytes (4 ClassTypeID + 4 PropTypeID + 1 ReadType + 1 WriteType +
8 ReadAddr + 8 WriteAddr + 2+2+2 length words); RecSize = 32 + len(getterSym) +
len(setterSym) + len(name). For TGadget.Val read GetVal write SetVal:
getterSym = "TGadget_GetVal" (14), setterSym = "TGadget_SetVal" (14),
name = "Val" (3) -> RecSize = 32 + 14 + 14 + 3 = 63. }
var
IR: string;
begin
IR := GenOPDF(
'''
program P;
type TGadget = class
FVal: Integer;
function GetVal: Integer;
procedure SetVal(AValue: Integer);
property Val: Integer read GetVal write SetVal;
end;
function TGadget.GetVal: Integer;
begin Result := FVal; end;
procedure TGadget.SetVal(AValue: Integer);
begin FVal := AValue; end;
begin end.
''');
AssertTrue('recProperty comment', Contains(IR, '# recProperty: Val'));
{ RecSize must match the fixed payload (32) + the three string lengths. }
AssertTrue('recProperty RecSize is 63', Contains(IR, '.int 63 # RecSize'));
{ The getter/setter symbol names and the property name must be present as the
three trailing strings (the fields the corruption garbled). }
AssertTrue('getter method symbol string', Contains(IR, '.ascii "TGadget_GetVal"'));
AssertTrue('setter method symbol string', Contains(IR, '.ascii "TGadget_SetVal"'));
{ The length words must match the actual symbol lengths. }
AssertTrue('ReadMethodNameLen = 14', Contains(IR, '.word 14 # ReadMethodNameLen'));
AssertTrue('WriteMethodNameLen = 14', Contains(IR, '.word 14 # WriteMethodNameLen'));
AssertTrue('NameLen = 3', Contains(IR, '.word 3 # NameLen'));
end;
procedure TOPDFTests.TestOPDF_Interface_RecType;
var
IR: string;
@ -836,38 +710,6 @@ begin
AssertTrue('unit count is 1', Contains(IR, '.int 1 # UnitCount'));
end;
procedure TOPDFTests.TestOPDF_RuntimeHelper_StringRelease;
var
IR: string;
begin
IR := GenOPDF('program P; begin end.');
AssertTrue('recRuntimeHelper comment for _StringRelease',
Contains(IR, '# recRuntimeHelper: _StringRelease'));
AssertTrue('_StringRelease address quad (linker-resolved)',
Contains(IR, '.quad _StringRelease # Address (linker-resolved)'));
end;
procedure TOPDFTests.TestOPDF_RuntimeHelper_DynArrayRelease;
var
IR: string;
begin
IR := GenOPDF('program P; begin end.');
AssertTrue('recRuntimeHelper comment for _DynArrayRelease',
Contains(IR, '# recRuntimeHelper: _DynArrayRelease'));
AssertTrue('_DynArrayRelease address quad (linker-resolved)',
Contains(IR, '.quad _DynArrayRelease # Address (linker-resolved)'));
end;
procedure TOPDFTests.TestOPDF_RuntimeHelper_KindOrdinals;
var
IR: string;
begin
{ Kind ordinals must match opdf_types.TRuntimeHelperKind: string=0, dynarray=1 }
IR := GenOPDF('program P; begin end.');
AssertTrue('rhkStringRelease kind byte = 0', Contains(IR, '.byte 0 # Kind'));
AssertTrue('rhkDynArrayRelease kind byte = 1', Contains(IR, '.byte 1 # Kind'));
end;
procedure TOPDFTests.TestOPDF_MethodScope_Emitted;
var O: string;
begin

2
compiler/src/test/pascal/cp.test.overload.pas
View file

@ -175,7 +175,7 @@ const
WriteLn(N)
end;
begin
Greet();
Greet;
Greet(42)
end.
''';

Some files were not shown because too many files have changed in this diff Show more