feat(semantic): cross-unit const shadowing with last-in-uses wins

When two used units export a constant of the same name, the importer
silently kept whichever was registered first and destroyed the other,
so the later unit in the `uses` clause could never shadow the earlier
one. Pascal's rule is last-in-uses wins.

Add TScope.ExtractLocal / TSymbolTable.ExtractLocal, which detach a
symbol from a scope without freeing it (the owning list keeps the
object alive for any per-unit cache that still references it). On a
cross-unit const collision, both the source-analysis path
(AnalyseConstDecls) and the prebuilt-import path (RegisterConsts) now
extract the prior unit's const and install the later unit's as the
flat-scope winner, instead of dropping the newcomer. Same-block and
unit-name-marker duplicates remain hard errors.

Adds a two-written-units e2e helper (CompileAndRunWithUnits) and
regression tests asserting the `uses` order decides the winner.
This commit is contained in:
Andrew Haines 2026-06-29 02:45:18 -04:00 committed by Graeme Geldenhuys
parent 3db2476983
commit 6bc8aff47d
5 changed files with 204 additions and 7 deletions

View file

@ -5180,17 +5180,17 @@ begin
Sym.ConstString := CD.StrVal;
if not FTable.Define(Sym) then
begin
Sym.Free();
{ A module-name marker blocking the Define is always a hard error
(issue #84) — without this check the const would be silently
dropped by the cross-unit shadowing tolerance below. }
(issue #84). }
RefSym := FTable.CurrentScope.LookupLocal(CD.Name);
if (RefSym <> nil) and (RefSym.Kind = skModule) then
begin
Sym.Free();
SemanticError(Format('Duplicate identifier ''%s''', [CD.Name]),
CD.Line, CD.Col);
{ Only error for same-block duplicates. Cross-unit const shadowing
(e.g. a unit redefining a system.pas constant) is silently accepted,
matching FPC behaviour and preserving the existing test coverage. }
end;
{ Same-block duplicate (the unit declares the name twice itself) is a
hard error. }
IsSameBlockDup := False;
for J := 0 to I - 1 do
if SameText(TConstDecl(ABlock.ConstDecls.Items[J]).Name, CD.Name) then
@ -5199,7 +5199,17 @@ begin
Break;
end;
if IsSameBlockDup then
begin
Sym.Free();
SemanticError(Format('Duplicate identifier ''%s''', [CD.Name]), CD.Line, CD.Col);
end;
{ Cross-unit collision: last-in-uses wins. Detach the prior unit's
const — kept alive via the per-unit cache for qualified access
(Unit.Const) — and install this unit's const as the flat winner.
Mirrors RegisterConsts on the prebuilt-import path so source-loaded
and prebuilt deps behave identically. }
FTable.ExtractLocal(CD.Name);
FTable.Define(Sym);
end;
end;
end;

View file

@ -896,7 +896,13 @@ begin
Sym.ConstString := Entry.Decl.StrVal;
Sym.OwningUnit := AIface.Name;
if not ATable.Define(Sym) then
Sym.Free(); { duplicate — silently skip }
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;
end;
end;

View file

@ -470,6 +470,13 @@ 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;
{ ------------------------------------------------------------------ }
@ -595,6 +602,9 @@ 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
@ -1352,6 +1362,17 @@ 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;
@ -1986,6 +2007,11 @@ begin
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;

View file

@ -146,6 +146,15 @@ 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
@ -884,4 +893,91 @@ begin
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);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
end;
end.

View file

@ -33,6 +33,11 @@ type
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;
end;
implementation
@ -187,6 +192,60 @@ begin
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;
initialization
RegisterTest(TE2EUsesChainTests);