diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 58d54ba..d3d8a03 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemanticImport.pas b/compiler/src/main/pascal/uSemanticImport.pas index 1587cc6..45929a8 100644 --- a/compiler/src/main/pascal/uSemanticImport.pas +++ b/compiler/src/main/pascal/uSemanticImport.pas @@ -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; diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index a5e04ad..07ba347 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.e2e.base.pas b/compiler/src/test/pascal/cp.test.e2e.base.pas index 1b935aa..964ac11 100644 --- a/compiler/src/test/pascal/cp.test.e2e.base.pas +++ b/compiler/src/test/pascal/cp.test.e2e.base.pas @@ -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 ;` 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 ;' header so the source can be + written to the matching .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 ;` 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. diff --git a/compiler/src/test/pascal/cp.test.e2e.useschain.pas b/compiler/src/test/pascal/cp.test.e2e.useschain.pas index 71adc36..2ce6325 100644 --- a/compiler/src/test/pascal/cp.test.e2e.useschain.pas +++ b/compiler/src/test/pascal/cp.test.e2e.useschain.pas @@ -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);