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

feat(units): cross-unit type last-wins and unit-qualified type disambiguation

Browse source 
Two used units exporting a class of the same name previously errored with
"Duplicate type name".  Give types the same cross-unit semantics as consts
and vars: the units coexist, a bare reference binds to the unit later in
`uses` (last-in-uses wins), and a qualified `Unit.TName` reference binds to
that specific unit's own type — with distinct typeinfo, vtable, field
cleanup and method dispatch.

Semantic:
- DefineTypeLastWins detaches the prior unit's type on a cross-unit collision
  (kept in the per-unit cache for qualified access) and installs the later
  unit as the flat winner; same-unit redeclaration stays a hard error.  The
  duplicate-method and impl-body-link guards skip foreign-owned entries (with
  a signature fallback so a generic instance whose template lives in another
  unit still links).  FindMethodDecl and a one-shot owner hint on
  ResolveMethodOverload bind a call to the method on the type that actually
  resolved, not the first-registered.  FindTypeOrInstantiate resolves a
  qualified type name through the directed per-unit lookup BEFORE the flat
  FindType (which would strip the qualifier to the uses-chain winner).

- TTypeDesc gains OwningUnit (stamped on Define); the AST type decl gains
  ResolvedDesc; a method-call expr gains QualifierUnit (set by the parser for
  `Unit.Type.Create`), so a qualified constructor resolves against its unit.

Codegen (QBE and native): a type's storage symbols (typeinfo / vtable /
_FieldCleanup / __cn) are mangled by the unit currently being emitted, and
qualified reference sites mangle by the resolved descriptor's owner — so two
used units' same-named types emit and are referenced under distinct,
non-colliding symbols.  Generic instances stay unprefixed.

Tests: e2e cross-unit type last-wins (+ reversed) and qualified
disambiguation; an IR-level check that the two types emit distinct symbols.
This commit is contained in:
Andrew Haines 2026-06-29 11:03:47 -04:00 committed by Graeme Geldenhuys
parent cd9af9ac7b
commit 9ec970393d
8 changed files with 588 additions and 150 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -280,6 +280,12 @@ type
unit prefix when the type is defined in a non-system unit. Mirrors the
QBE backend's ClassSymName logic. }
function ClassSymName(const AClassName: string): string;
{ Allowlist + dot-collapse owner→prefix core, shared by ClassSymName (name
based) and ClassSymNameForDecl (emitting-unit based). }
function ClassOwnerPrefix(const AOwner: string): string;
{ Owner-correct class-symbol suffix for a type DEFINITION, keyed on the unit
currently being emitted (cross-unit last-wins safe). }
function ClassSymNameForDecl(ATypeDecl: TTypeDecl): string;
{ Emit a property accessor (getter/setter) call. The receiver instance
must already be in %rdi. When AVSlot >= 0 the accessor is virtual and
the call dispatches through the vtable so an overridden accessor is
@ -1790,41 +1796,53 @@ begin
Result := CodegenMangle(AName);
end;
function TX86_64Backend.ClassOwnerPrefix(const AOwner: string): string;
var
I: Integer;
Ch: string;
begin
Result := '';
{ Program-scope classes keep bare names — see the QBE backend's
ClassUnitPrefix and uSemantic.CurrentUnitPrefix. }
if (AOwner <> '') and
not ((FProgramName <> '') and SameText(AOwner, FProgramName)) and
not SameText(AOwner, 'System') and
not ((Length(AOwner) >= 4) and SameText(Copy(AOwner, 0, 4), 'rtl.')) and
not ((Length(AOwner) >= 7) and SameText(Copy(AOwner, 0, 7), 'blaise_')) then
begin
for I := 0 to Length(AOwner) - 1 do
begin
Ch := Copy(AOwner, I, 1);
if Ch = '.' then Result := Result + '_'
else Result := Result + Ch;
end;
Result := Result + '_';
end;
end;
function TX86_64Backend.ClassSymName(const AClassName: string): string;
var
Sym: TSymbol;
Owner: string;
I: Integer;
Ch: string;
begin
Result := '';
if FSymTable <> nil then
begin
Sym := FSymTable.Lookup(AClassName);
if Sym <> nil then
begin
Owner := Sym.OwningUnit;
{ Program-scope classes keep bare names — see the QBE backend's
ClassUnitPrefix and uSemantic.CurrentUnitPrefix. }
if (Owner <> '') and
not ((FProgramName <> '') and SameText(Owner, FProgramName)) and
not SameText(Owner, 'System') and
not ((Length(Owner) >= 4) and SameText(Copy(Owner, 0, 4), 'rtl.')) and
not ((Length(Owner) >= 7) and SameText(Copy(Owner, 0, 7), 'blaise_')) then
begin
for I := 0 to Length(Owner) - 1 do
begin
Ch := Copy(Owner, I, 1);
if Ch = '.' then Result := Result + '_'
else Result := Result + Ch;
end;
Result := Result + '_';
end;
end;
Result := ClassOwnerPrefix(Sym.OwningUnit);
end;
Result := Result + NativeMangle(AClassName);
end;
function TX86_64Backend.ClassSymNameForDecl(ATypeDecl: TTypeDecl): string;
begin
{ A type's definition is emitted under its own unit's codegen pass, so key the
symbol on the unit currently being emitted (FCurrentUnitName) rather than a
flat-table name re-lookup — which would mis-mangle a cross-unit last-wins
loser as the winner. Mirrors the QBE backend's ClassSymNameForDecl. }
Result := ClassOwnerPrefix(FCurrentUnitName) + NativeMangle(ATypeDecl.Name);
end;
procedure TX86_64Backend.EmitPropAccessorCallNative(
const AOwnerType, AMethod: string; AVSlot: Integer);
begin
@ -2177,7 +2195,7 @@ begin
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
CD := TClassTypeDef(TD.Def);
CSym := Self.ClassSymName(TD.Name);
CSym := Self.ClassSymNameForDecl(TD);
{ Class-name string blob — the symbol uses the unit-prefixed name so
__cn_ matches the typeinfo class-name reference, but the content is
@ -2260,7 +2278,7 @@ begin
TDesc := ASymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
CSym := Self.ClassSymName(TD.Name);
CSym := Self.ClassSymNameForDecl(TD);
if RT.Parent <> nil then
ParentStr := 'typeinfo_' + Self.ClassSymName(RT.Parent.Name)
@ -2357,7 +2375,7 @@ begin
TDesc := ASymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
Self.EmitFieldCleanupFn(Self.ClassSymName(TD.Name), RT);
Self.EmitFieldCleanupFn(Self.ClassSymNameForDecl(TD), RT);
end;
{ Field cleanup for generic class instances. }
for I := 0 to AGenericInstances.Count - 1 do
@ -2394,7 +2412,7 @@ begin
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if not RT.HasVTable() then Continue;
CSym := Self.ClassSymName(TD.Name);
CSym := Self.ClassSymNameForDecl(TD);
Self.Emit('.balign 8');
Self.Emit('.globl vtable_' + CSym);
@ -2951,7 +2969,7 @@ begin
begin
TD := TTypeDecl(ATypeDecls.Items[I]);
if not (TD.Def is TInterfaceTypeDef) then Continue;
CSym := Self.ClassSymName(TD.Name);
CSym := Self.ClassSymNameForDecl(TD);
Self.Emit('.balign 8');
Self.Emit('.globl typeinfo_' + CSym);
Self.Emit('typeinfo_' + CSym + ':');
@ -2979,7 +2997,7 @@ begin
{ Skip only when neither this class NOR any ancestor implements an interface
— a descendant inherits its parent's interfaces (issue #130 bug3). }
if not Self.ClassOrAncestorImplements(ClassRT) then Continue;
CSym := Self.ClassSymName(TD.Name);
CSym := Self.ClassSymNameForDecl(TD);
{ Collect each implemented interface PLUS every ancestor on its parent
chain so a class instance can narrow directly to a base interface (an

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

@ -543,6 +543,20 @@ type
for the class's TSymbol.OwningUnit, then applies the same
allowlist semantics as uSemantic.MangleUnitPrefix. }
function ClassUnitPrefix(const AClassName: string): string;
{ Owner-string core of ClassUnitPrefix (allowlist + dot-collapse), shared
by the name-based and descriptor-based forms. }
function ClassUnitPrefixOwner(const AOwner: string): string;
{ Descriptor-based prefix/symbol — mangle by the type's own OwningUnit so a
cross-unit same-named type emits and is referenced under its own symbols,
not the flat-table winner's. }
function ClassUnitPrefixOf(ADesc: TTypeDesc): string;
function ClassSymNameOf(ADesc: TTypeDesc): string;
{ Owner-correct class-symbol suffix for an AST type decl, via its attached
ResolvedDesc (name-based fallback for descriptor-less decls). }
function ClassSymNameForDecl(ATypeDecl: TTypeDecl): string;
{ Emit the $__cn_ class-name string for a type DEFINITION, keyed on the
emitting unit (cross-unit last-wins safe); returns the inline ref. }
function EmitClassNameRefForDecl(ATypeDecl: TTypeDecl): string;
function GlobalVarUnitPrefix(const AName: string): string;
{ Map an owning unit to its global-var mangle prefix (program-scope and
the RTL allowlist stay bare). The shared core of GlobalVarUnitPrefix
@ -6989,7 +7003,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
ItabName := '$itab_' +
ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
ClassSymNameOf(TASTExpr(ACall.Args.Items[I]).ResolvedType)
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ItabName]);
end
@ -7501,7 +7515,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
ItabName := '$itab_' +
ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
ClassSymNameOf(TASTExpr(ACall.Args.Items[I]).ResolvedType)
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ItabName]);
end
@ -7685,7 +7699,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(AArgs.Items[I]));
ArgTemp2 := '$itab_' +
ClassSymName(QBEMangle(TASTExpr(AArgs.Items[I]).ResolvedType.Name))
ClassSymNameOf(TASTExpr(AArgs.Items[I]).ResolvedType)
+ '_' + QBEMangle(Par.ResolvedType.Name);
Result := Result + Format(', l %s, l %s', [ArgTemp, ArgTemp2]);
end
@ -8234,7 +8248,8 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := AProg.SymbolTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
CD := TClassTypeDef(TD.Def);
@ -8248,12 +8263,12 @@ begin
if StrPos('<', RT.Parent.Name) >= 0 then
ParentStr := '$typeinfo_' + QBEMangle(RT.Parent.Name)
else
ParentStr := '$typeinfo_' + ClassSymName(RT.Parent.Name);
ParentStr := '$typeinfo_' + ClassSymNameOf(RT.Parent);
end
else
ParentStr := '0';
if RT.ImplementsCount() > 0 then
ImplStr := '$impllist_' + ClassSymName(TD.Name)
ImplStr := '$impllist_' + ClassSymNameForDecl(TD)
else
ImplStr := '0';
@ -8265,7 +8280,7 @@ begin
Inc(PubCount);
if PubCount > 0 then
begin
MethLine := 'data $methods_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(PubCount);
MethLine := 'data $methods_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(PubCount);
for J := 0 to CD.Methods.Count - 1 do
begin
MD := TMethodDecl(CD.Methods.Items[J]);
@ -8276,30 +8291,30 @@ begin
end;
MethLine := MethLine + ' }';
EmitLine(MethLine);
MethStr := '$methods_' + ClassSymName(TD.Name);
MethStr := '$methods_' + ClassSymNameForDecl(TD);
end
else
MethStr := '0';
if RT.ClassAttributeCount() > 0 then
begin
AttrsLine := 'data $attrs_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
AttrsLine := 'data $attrs_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
for J := 0 to RT.ClassAttributeCount() - 1 do
AttrsLine := AttrsLine + ', l $typeinfo_' + ClassSymName(RT.ClassAttributeAt(J));
AttrsLine := AttrsLine + ' }';
EmitLine(AttrsLine);
AttrsStr := '$attrs_' + ClassSymName(TD.Name);
AttrsStr := '$attrs_' + ClassSymNameForDecl(TD);
end
else
AttrsStr := '0';
EmitLine('data $typeinfo_' + ClassSymName(TD.Name) +
EmitLine('data $typeinfo_' + ClassSymNameForDecl(TD) +
' = { l ' + ParentStr + ', l ' + ImplStr +
', l ' + EmitClassNameRef(TD.Name) +
', l ' + EmitClassNameRefForDecl(TD) +
', l ' + MethStr +
', l ' + IntToStr(RT.TotalSize()) +
', l $_FieldCleanup_' + ClassSymName(TD.Name) +
', l $vtable_' + ClassSymName(TD.Name) +
', l $_FieldCleanup_' + ClassSymNameForDecl(TD) +
', l $vtable_' + ClassSymNameForDecl(TD) +
', l ' + AttrsStr + ' }');
end;
@ -8359,7 +8374,8 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := AProg.SymbolTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if not RT.HasVTable() then Continue;
@ -8367,8 +8383,8 @@ begin
vtable is exported so the separately-assembled .opdf section can reference
it (the OPDF class record stores each class's VMTAddress); otherwise it
stays a local symbol, keeping non-debug output unchanged. }
Line := VTableDataPrefix() + '$vtable_' + ClassSymName(TD.Name) +
' = { l $typeinfo_' + ClassSymName(TD.Name);
Line := VTableDataPrefix() + '$vtable_' + ClassSymNameForDecl(TD) +
' = { l $typeinfo_' + ClassSymNameForDecl(TD);
for S := 0 to RT.VTableCount() - 1 do
begin
E := RT.VTableEntryAt(S);
@ -8498,7 +8514,7 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TInterfaceTypeDef) then Continue;
EmitLine('data $typeinfo_' + ClassSymName(TD.Name) + ' = { l 0 }');
EmitLine('data $typeinfo_' + ClassSymNameForDecl(TD) + ' = { l 0 }');
end;
{ Typeinfo blocks for generic interface instantiations }
@ -8513,7 +8529,8 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := AProg.SymbolTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
ClassRT := TRecordTypeDesc(TDesc);
{ Skip only when neither this class NOR any ancestor implements an
@ -8560,7 +8577,7 @@ begin
begin
IntfDesc := TInterfaceTypeDesc(EmitIntfs.Items[J]);
IntfMangle := QBEMangle(IntfDesc.Name);
ItabLine := 'data $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle + ' = {';
ItabLine := 'data $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle + ' = {';
for K := 0 to IntfDesc.MethodCount() - 1 do
begin
MethName := IntfDesc.MethodName(K);
@ -8588,17 +8605,17 @@ begin
{ One impllist per class: NULL-terminated (typeinfo_intf, itab) pairs.
Includes ancestor interfaces so _GetItab(obj, typeinfo_IBase) resolves. }
ImplLine := 'data $impllist_' + ClassSymName(TD.Name) + ' = {';
ImplLine := 'data $impllist_' + ClassSymNameForDecl(TD) + ' = {';
for J := 0 to EmitIntfs.Count - 1 do
begin
IntfDesc := TInterfaceTypeDesc(EmitIntfs.Items[J]);
IntfMangle := QBEMangle(IntfDesc.Name);
if J = 0 then
ImplLine := ImplLine + ' l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle
', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle
else
ImplLine := ImplLine + ', l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle;
', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle;
end;
ImplLine := ImplLine + ', l 0 }';
EmitLine(ImplLine);
@ -8813,10 +8830,11 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := AProg.SymbolTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
EmitFieldCleanupFn(ClassSymName(TD.Name), RT);
EmitFieldCleanupFn(ClassSymNameForDecl(TD), RT);
end;
for I := 0 to AProg.GenericInstances.Count - 1 do
begin
@ -9492,7 +9510,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
ArgTemp2 := '$itab_' +
ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
ClassSymNameOf(TASTExpr(ACall.Args.Items[I]).ResolvedType)
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ArgTemp2]);
end
@ -9572,7 +9590,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
ArgTemp2 := '$itab_' +
ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
ClassSymNameOf(TASTExpr(ACall.Args.Items[I]).ResolvedType)
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format('l %s, l %s', [ArgTemp, ArgTemp2]);
end
@ -11730,16 +11748,16 @@ begin
else
begin
EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)',
[SelfTemp, RT.TotalSize(), ClassSymName(QBEMangle(RT.Name))]));
[SelfTemp, RT.TotalSize(), ClassSymNameOf(RT)]));
if RT.HasVTable() then
EmitLine(Format(' storel $vtable_%s, %s',
[ClassSymName(QBEMangle(RT.Name)), SelfTemp]));
[ClassSymNameOf(RT), SelfTemp]));
end;
if FDebugMode then
begin
L := AllocTemp();
EmitLine(Format(' %s =l add $typeinfo_%s, 16',
[L, ClassSymName(QBEMangle(RT.Name))]));
[L, ClassSymNameOf(RT)]));
R := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [R, L]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s, l %s, l %d)',
@ -11775,7 +11793,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
ItabName := '$itab_' +
ClassSymName(QBEMangle(TASTExpr(MCallExpr.Args.Items[I]).ResolvedType.Name))
ClassSymNameOf(TASTExpr(MCallExpr.Args.Items[I]).ResolvedType)
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ItabName]);
end
@ -12650,16 +12668,16 @@ begin
T := AllocTemp();
EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)',
[T, TRecordTypeDesc(FldAccess.ResolvedType).TotalSize(),
ClassSymName(QBEMangle(FldAccess.ResolvedType.Name))]));
ClassSymNameOf(FldAccess.ResolvedType)]));
{ Store vtable pointer at offset 0 if this class has virtual methods }
if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable() then
EmitLine(Format(' storel $vtable_%s, %s',
[ClassSymName(QBEMangle(FldAccess.ResolvedType.Name)), T]));
[ClassSymNameOf(FldAccess.ResolvedType), T]));
if FDebugMode then
begin
L := AllocTemp();
EmitLine(Format(' %s =l add $typeinfo_%s, 16',
[L, ClassSymName(QBEMangle(FldAccess.ResolvedType.Name))]));
[L, ClassSymNameOf(FldAccess.ResolvedType)]));
R := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [R, L]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s, l %s, l %d)',
@ -14236,34 +14254,88 @@ begin
end;
end;
function TCodeGenQBE.ClassUnitPrefixOwner(const AOwner: string): string;
var
I: Integer;
Ch: string;
begin
Result := '';
{ Allowlist mirrors uSemantic.IsUnmangledUnit. }
if AOwner = '' then Exit;
{ Program-scope classes keep bare names: uSemantic.CurrentUnitPrefix gives
program-scope methods unprefixed ResolvedQbeNames, so reference sites
(itabs, property setter calls) must not add a prefix either. }
if (FProgramName <> '') and SameText(AOwner, FProgramName) then Exit;
if SameText(AOwner, 'System') then Exit;
if (Length(AOwner) >= 4) and SameText(Copy(AOwner, 0, 4), 'rtl.') then Exit;
if (Length(AOwner) >= 7) and SameText(Copy(AOwner, 0, 7), 'blaise_') then Exit;
for I := 0 to Length(AOwner) - 1 do
begin
Ch := Copy(AOwner, I, 1);
if Ch = '.' then Result := Result + '_'
else Result := Result + Ch;
end;
Result := Result + '_';
end;
function TCodeGenQBE.ClassUnitPrefix(const AClassName: string): string;
var
Sym: TSymbol;
Owner: string;
I: Integer;
Ch: string;
begin
Result := '';
if FSymTable = nil then Exit;
Sym := FSymTable.Lookup(AClassName);
if Sym = nil then Exit;
Owner := Sym.OwningUnit;
{ Allowlist mirrors uSemantic.IsUnmangledUnit. }
if Owner = '' then Exit;
{ Program-scope classes keep bare names: uSemantic.CurrentUnitPrefix gives
program-scope methods unprefixed ResolvedQbeNames, so reference sites
(itabs, property setter calls) must not add a prefix either. }
if (FProgramName <> '') and SameText(Owner, FProgramName) then Exit;
if SameText(Owner, 'System') then Exit;
if (Length(Owner) >= 4) and SameText(Copy(Owner, 0, 4), 'rtl.') then Exit;
if (Length(Owner) >= 7) and SameText(Copy(Owner, 0, 7), 'blaise_') then Exit;
for I := 0 to Length(Owner) - 1 do
begin
Ch := Copy(Owner, I, 1);
if Ch = '.' then Result := Result + '_'
else Result := Result + Ch;
end;
Result := Result + '_';
Result := ClassUnitPrefixOwner(Sym.OwningUnit);
end;
function TCodeGenQBE.ClassUnitPrefixOf(ADesc: TTypeDesc): string;
begin
{ Mangle by the descriptor's own OwningUnit — correct even when a same-named
type from another used unit won the flat slot (a name re-lookup would
return the other unit's owner). Generic instances are emitted under their
QBEMangle'd name with no unit prefix (see EmitTypeInfoDefs), so never prefix
one — keep parity with the name-based reference form. }
if (ADesc = nil) or (StrPos('<', ADesc.Name) >= 0) then
Result := ''
else
Result := ClassUnitPrefixOwner(ADesc.OwningUnit);
end;
function TCodeGenQBE.ClassSymNameOf(ADesc: TTypeDesc): string;
begin
{ QBEMangle the name to match ClassSymNameForDecl and the name-based
ClassSymName(QBEMangle(...)) reference form, so a qualified reference to a
cross-unit type resolves to the same symbol that type's definition emits. }
if ADesc = nil then
Result := ''
else
Result := ClassUnitPrefixOf(ADesc) + QBEMangle(ADesc.Name);
end;
function TCodeGenQBE.ClassSymNameForDecl(ATypeDecl: TTypeDecl): string;
begin
{ A type's definition is always emitted under its own unit's codegen pass, so
key the symbol on the unit currently being emitted (FCurrentUnitName). This
is authoritative even when two used units share one descriptor for a
same-named type, or in separate compilation where a name re-lookup would
mis-mangle the loser as the flat-table winner. QBEMangle matches the
reference-site form ClassSymName(QBEMangle(...)). }
Result := ClassUnitPrefixOwner(FCurrentUnitName) + QBEMangle(ATypeDecl.Name);
end;
function TCodeGenQBE.EmitClassNameRefForDecl(ATypeDecl: TTypeDecl): string;
var
Sym: string;
begin
{ Like EmitClassNameRef but keyed on the emitting unit (cross-unit last-wins
safe), so two used units exporting a same-named class emit distinct $__cn_
string blobs instead of colliding on the flat-table winner's symbol. }
Sym := ClassSymNameForDecl(ATypeDecl);
EmitLine(Format('%sdata $__cn_%s = { w -1, w %d, w %d, b "%s", b 0 }',
[ExportPrefix(), Sym, Length(ATypeDecl.Name), Length(ATypeDecl.Name),
ATypeDecl.Name]));
Result := '$__cn_' + Sym + ' + 12';
end;
function TCodeGenQBE.PropAccessorTarget(const AOwnerType, AMethod: string;
@ -14657,10 +14729,11 @@ begin
begin
TD := TTypeDecl(AllTD.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := FSymTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
EmitFieldCleanupFn(ClassSymName(TD.Name), RT);
EmitFieldCleanupFn(ClassSymNameForDecl(TD), RT);
end;
{ System-unit (TObject / TCustomAttribute) FieldCleanup stubs.
@ -14745,7 +14818,7 @@ begin
begin
TD := TTypeDecl(AllTD.Items[I]);
if TD.Def is TInterfaceTypeDef then
EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymName(TD.Name) + ' = { l 0 }');
EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymNameForDecl(TD) + ' = { l 0 }');
end;
{ System-unit (TObject / TCustomAttribute) typeinfo + vtable.
@ -14782,15 +14855,16 @@ begin
TD := TTypeDecl(AllTD.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
CD := TClassTypeDef(TD.Def);
TDesc := FSymTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if RT.Parent <> nil then
ParentStr := '$typeinfo_' + ClassSymName(RT.Parent.Name)
ParentStr := '$typeinfo_' + ClassSymNameOf(RT.Parent)
else
ParentStr := '0';
if RT.ImplementsCount() > 0 then
ImplStr := '$impllist_' + ClassSymName(TD.Name)
ImplStr := '$impllist_' + ClassSymNameForDecl(TD)
else
ImplStr := '0';
@ -14800,7 +14874,7 @@ begin
Inc(PubCount);
if PubCount > 0 then
begin
MethLine := ExportPrefix() + 'data $methods_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(PubCount);
MethLine := ExportPrefix() + 'data $methods_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(PubCount);
for J := 0 to CD.Methods.Count - 1 do
begin
MDecl := TMethodDecl(CD.Methods.Items[J]);
@ -14811,30 +14885,30 @@ begin
end;
MethLine := MethLine + ' }';
EmitLine(MethLine);
MethStr := '$methods_' + ClassSymName(TD.Name);
MethStr := '$methods_' + ClassSymNameForDecl(TD);
end
else
MethStr := '0';
if RT.ClassAttributeCount() > 0 then
begin
AttrsLine := ExportPrefix() + 'data $attrs_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
AttrsLine := ExportPrefix() + 'data $attrs_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
for J := 0 to RT.ClassAttributeCount() - 1 do
AttrsLine := AttrsLine + ', l $typeinfo_' + ClassSymName(RT.ClassAttributeAt(J));
AttrsLine := AttrsLine + ' }';
EmitLine(AttrsLine);
AttrsStr := '$attrs_' + ClassSymName(TD.Name);
AttrsStr := '$attrs_' + ClassSymNameForDecl(TD);
end
else
AttrsStr := '0';
EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymName(TD.Name) +
EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymNameForDecl(TD) +
' = { l ' + ParentStr + ', l ' + ImplStr +
', l ' + EmitClassNameRef(TD.Name) +
', l ' + EmitClassNameRefForDecl(TD) +
', l ' + MethStr +
', l ' + IntToStr(RT.TotalSize()) +
', l $_FieldCleanup_' + ClassSymName(TD.Name) +
', l $vtable_' + ClassSymName(TD.Name) +
', l $_FieldCleanup_' + ClassSymNameForDecl(TD) +
', l $vtable_' + ClassSymNameForDecl(TD) +
', l ' + AttrsStr + ' }');
end;
@ -14846,12 +14920,13 @@ begin
begin
TD := TTypeDecl(AllTD.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := FSymTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if not RT.HasVTable() then Continue;
VLine := ExportPrefix() + 'data $vtable_' + ClassSymName(TD.Name) +
' = { l $typeinfo_' + ClassSymName(TD.Name);
VLine := ExportPrefix() + 'data $vtable_' + ClassSymNameForDecl(TD) +
' = { l $typeinfo_' + ClassSymNameForDecl(TD);
for S := 0 to RT.VTableCount() - 1 do
begin
E := RT.VTableEntryAt(S);
@ -14969,7 +15044,8 @@ begin
begin
TD := TTypeDecl(AllTD.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
TDesc := FSymTable.FindType(TD.Name);
TDesc := TTypeDesc(TD.ResolvedDesc);
if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
ClassRT := TRecordTypeDesc(TDesc);
if ClassRT.ImplementsCount() = 0 then Continue;
@ -14977,7 +15053,7 @@ begin
begin
IntfDesc := ClassRT.ImplementsIntfAt(J);
IntfMangle := QBEMangle(IntfDesc.Name);
ItabLine := ExportPrefix() + 'data $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle + ' = {';
ItabLine := ExportPrefix() + 'data $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle + ' = {';
for K := 0 to IntfDesc.MethodCount() - 1 do
begin
MethName := IntfDesc.MethodName(K);
@ -14985,7 +15061,7 @@ begin
ClassRT.VTableEntryAt(ClassRT.FindVTableSlot(MethName)).IsAbstract then
ItabRef := '$_AbstractMethodError'
else
ItabRef := '$' + ClassSymName(TD.Name) + '_' + MethName;
ItabRef := '$' + ClassSymNameForDecl(TD) + '_' + MethName;
if K = 0 then
ItabLine := ItabLine + ' l ' + ItabRef
else
@ -14994,17 +15070,17 @@ begin
ItabLine := ItabLine + ' }';
EmitLine(ItabLine);
end;
ImplLine := ExportPrefix() + 'data $impllist_' + ClassSymName(TD.Name) + ' = {';
ImplLine := ExportPrefix() + 'data $impllist_' + ClassSymNameForDecl(TD) + ' = {';
for J := 0 to ClassRT.ImplementsCount() - 1 do
begin
IntfDesc := ClassRT.ImplementsIntfAt(J);
IntfMangle := QBEMangle(IntfDesc.Name);
if J = 0 then
ImplLine := ImplLine + ' l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle
', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle
else
ImplLine := ImplLine + ', l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle;
', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle;
end;
ImplLine := ImplLine + ', l 0 }';
EmitLine(ImplLine);

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

@ -925,6 +925,10 @@ 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 }
@ -1082,6 +1086,12 @@ 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;

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

@ -5093,6 +5093,7 @@ begin
MCallNode.Col := Col;
MCallNode.ObjectName := Name;
MCallNode.Name := SecondName;
MCallNode.QualifierUnit := QualUnit;
Advance();
if not Check(tkRParen) then
begin

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

@ -94,6 +94,13 @@ type
FArrayConstCounter: Integer; { counter for generating unique array-const data labels }
FAnonEnumCounter: Integer; { counter for unique anonymous-enum type names (inline 'set of (a,b,c)') }
FCurrentUnitName: string; { name of the unit/program currently being analysed }
FMethodOwnerHint: string; { receiver owning-unit hint for the NEXT
ResolveMethodOverload call, consumed and
cleared at its start. Disambiguates a
method on a cross-unit same-named type to
the receiver's actual unit. A field, not
a parameter, to keep ResolveMethodOverload
within the 6-register call ABI. }
FCurrentEnclosingDecl: TMethodDecl; { the innermost standalone proc/func currently being analysed;
nil at program level. Used to set EnclosingDecl on nested procs. }
FUnitIfaces: TStringList; { owned list (case-insensitive) — keys are unit
@ -513,6 +520,15 @@ type
redeclaration and module-name markers stay hard errors. }
procedure DefineGlobalLastWins(ASym: TSymbol; ALine, ACol: Integer);
{ Define a type name with the same cross-unit last-found-wins rule as
DefineGlobalLastWins: a collision against a type owned by a DIFFERENT
used unit detaches the prior type (kept in the per-unit cache so a
qualified Unit.Type reference still reaches it) and installs this unit's
type as the flat winner; a same-unit redeclaration or a non-unit/module
collision stays the hard 'Duplicate type name' error. }
procedure DefineTypeLastWins(ASym: TSymbol; ATypeDecl: TTypeDecl;
ALine, ACol: Integer);
{ Record one enum member in the reverse index (FEnumMemberIndex).
Called once per member as its enum type is analysed. Enum members
are NOT registered as bare global symbols any more — a bare member
@ -2657,9 +2673,16 @@ begin
Match := nil;
Grp := GroupOf(FMethodGroups, Key);
if Grp <> nil then
begin
{ Prefer a declaration owned by the unit whose impl body this is: with
cross-unit type last-wins the group can also hold a same-named method
on another used unit's same-named type. }
for K := 0 to Grp.Count - 1 do
begin
CD := TMethodDecl(Grp.Items[K]);
if (CD.OwningUnit <> '') and (FCurrentUnitName <> '') and
not SameText(CD.OwningUnit, FCurrentUnitName) then
Continue;
if CD.IsOverload then
begin
if MangleParamSig(CD) = ImplSig then
@ -2675,6 +2698,28 @@ begin
Break;
end;
end;
{ Fallback: no declaration is owned by the current unit — e.g. a generic
instance whose template (and method decls) live in another unit. Match
by signature regardless of owner, preserving the pre-last-wins behaviour. }
if Match = nil then
for K := 0 to Grp.Count - 1 do
begin
CD := TMethodDecl(Grp.Items[K]);
if CD.IsOverload then
begin
if MangleParamSig(CD) = ImplSig then
begin
Match := CD;
Break;
end;
end
else
begin
Match := CD;
Break;
end;
end;
end;
if Match = nil then
SemanticError(
Format('Method ''%s'' is not declared in class ''%s''',
@ -3179,6 +3224,24 @@ var
DAT: TDynArrayTypeDesc;
I, LtPos, DotPos: Integer;
begin
{ Unit-qualified type 'Unit.TypeName' — resolve against that specific unit's
own exports FIRST, before the flat FindType below (which strips the
qualifier and binds the tail through the uses chain, i.e. to the cross-unit
last-wins winner). Only short-circuits on a directed hit; a miss (the
common single-definition case, or a dotted stdlib qualifier the per-unit
cache has not harvested) falls through to the existing resolution. }
LtPos := StrPos('<', AName);
if LtPos < 0 then LtPos := Length(AName);
DotPos := -1;
for I := 0 to LtPos - 1 do
if StrAt(AName, I) = Ord('.') then DotPos := I;
if DotPos >= 0 then
begin
Sym := ResolveQualified(Copy(AName, 0, DotPos),
StrCopyTail(AName, DotPos + 1));
if (Sym <> nil) and (Sym.Kind = skType) and (Sym.TypeDesc <> nil) then
Exit(Sym.TypeDesc);
end;
Result := FTable.FindType(AName);
if Result <> nil then Exit;
{ Dynamic array: 'array of TypeName' — create on demand. Key cache by
@ -5314,6 +5377,47 @@ begin
RegisterUnitSymbol(ASym.OwningUnit, ASym);
end;
procedure TSemanticAnalyser.DefineTypeLastWins(ASym: TSymbol;
ATypeDecl: TTypeDecl; ALine, ACol: Integer);
var
RefSym: TSymbol;
Prev: TSymbol;
AName: string;
begin
AName := ATypeDecl.Name;
{ Record the descriptor created for THIS decl so codegen can emit this unit's
own type even after a same-named type from another used unit wins the flat
slot (extracted below). }
ATypeDecl.ResolvedDesc := ASym.TypeDesc;
if not FTable.Define(ASym) then
begin
RefSym := FTable.CurrentScope.LookupLocal(AName);
{ Only a genuine cross-unit collision (two used units exporting the same
type name) gets last-wins; a module marker, a non-unit symbol, or a
same-unit redeclaration stays a hard error. }
if (RefSym = nil) or (RefSym.Kind = skModule) or
(RefSym.OwningUnit = '') or
SameText(RefSym.OwningUnit, ASym.OwningUnit) then
begin
ASym.Free();
SemanticError(Format('Duplicate type name ''%s''', [AName]), ALine, ACol);
Exit;
end;
{ Detach the prior unit's type and stash it in the per-unit cache so a
qualified reference (Unit.Type) still resolves against it; install this
unit's type as the flat winner. }
Prev := FTable.ExtractLocal(AName);
if (Prev <> nil) and (Prev.OwningUnit <> '') then
RegisterUnitSymbol(Prev.OwningUnit, Prev);
FTable.Define(ASym);
end;
{ Register every type in the per-unit cache keyed by its owning unit, so a
qualified reference resolves against the declaring unit regardless of which
unit won the bare (flat) slot. }
if ASym.OwningUnit <> '' then
RegisterUnitSymbol(ASym.OwningUnit, ASym);
end;
function TSemanticAnalyser.NewArrayConstLabel(const AName: string): string;
begin
Inc(FArrayConstCounter);
@ -5647,11 +5751,7 @@ begin
end;
IntfDesc := FTable.NewInterfaceType(TD.Name);
Sym := TSymbol.Create(TD.Name, skType, IntfDesc);
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
Continue;
end
else if TD.Def is TEnumTypeDef then
@ -5670,11 +5770,7 @@ begin
RegisterEnumMember(MName, EnumDesc, EnumDef.OrdinalAt(K));
end;
Sym := TSymbol.Create(TD.Name, skType, EnumDesc);
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
Continue;
end
else if TD.Def is TSetTypeDef then
@ -5689,12 +5785,7 @@ begin
SetDesc := FTable.NewOrdinalSetType(TD.Name, SetSubDesc.BaseType,
SetSubDesc.BitCount);
Sym := TSymbol.Create(TD.Name, skType, SetDesc);
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]),
TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
Continue;
end;
BaseSym := FTable.Lookup(SetDef.BaseTypeName);
@ -5724,11 +5815,7 @@ begin
SetDesc := nil;
end;
Sym := TSymbol.Create(TD.Name, skType, SetDesc);
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
Continue;
end
else if TD.Def is TProceduralTypeDef then
@ -5737,11 +5824,7 @@ begin
resolution happens in pass 2. }
Sym := TSymbol.Create(TD.Name, skType,
FTable.NewProceduralType(TD.Name));
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
Continue;
end
else if TD.Def is TTypeAliasDef then
@ -5798,11 +5881,7 @@ begin
end;
end;
Sym := TSymbol.Create(TD.Name, skType, AliasDesc);
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
Continue;
end
else
@ -5812,11 +5891,7 @@ begin
Continue;
end;
Sym := TSymbol.Create(TD.Name, skType, RT);
if not FTable.Define(Sym) then
begin
Sym.Free();
SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
end;
DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
end;
{ Pass 2 — resolve parent, fields, and method signatures for each type. }
@ -6282,11 +6357,20 @@ begin
existing FMethodIndex entries for this (TypeName.Name) — if
any sibling has IsOverload=False or the new MDecl lacks
IsOverload, this is a duplicate-identifier error. }
if (MDecl.OwningUnit = '') and (FCurrentUnitName <> '') then
MDecl.OwningUnit := FCurrentUnitName;
Key := TD.Name + '.' + MDecl.Name;
Grp := GroupOf(FMethodGroups, Key);
if Grp <> nil then
for K := 0 to Grp.Count - 1 do
begin
{ A same-named method on a same-named type owned by a DIFFERENT
used unit is a distinct method (it carries its own unit-prefixed
ResolvedQbeName), not a missing-overload duplicate — the two
types coexist under cross-unit last-wins. }
if not SameText(TMethodDecl(Grp.Items[K]).OwningUnit,
MDecl.OwningUnit) then
Continue;
if (not MDecl.IsOverload) or
(not TMethodDecl(Grp.Items[K]).IsOverload) then
SemanticError(
@ -6661,10 +6745,12 @@ function TSemanticAnalyser.FindMethodDecl(
const ATypeName, AMethodName: string): TMethodDecl;
var
CurrName: string;
Idx: Integer;
Idx, K: Integer;
Key: string;
Sym: TSymbol;
RT: TRecordTypeDesc;
OwnerUnit: string;
Grp: TObjectList;
begin
CurrName := ATypeName;
while CurrName <> '' do
@ -6679,6 +6765,24 @@ begin
lookups, where the access is legitimate regardless of the member's
declared visibility. Enforcement happens at the user-written call /
member-access sites (EnforceMethodVisible / AssertMemberVisibleV). }
{ Cross-unit last-wins: two used units may export a same-named type, so
the group holds both their methods under one key. FMethodIndex returns
the first-registered, which may belong to the OTHER unit; bind instead
to the method on the type that actually resolved (its owning unit). }
OwnerUnit := '';
Sym := FTable.Lookup(CurrName);
if Sym <> nil then OwnerUnit := Sym.OwningUnit;
if (OwnerUnit <> '') and not SameText(Result.OwningUnit, OwnerUnit) then
begin
Grp := GroupOf(FMethodGroups, Key);
if Grp <> nil then
for K := 0 to Grp.Count - 1 do
if SameText(TMethodDecl(Grp.Items[K]).OwningUnit, OwnerUnit) then
begin
Result := TMethodDecl(Grp.Items[K]);
Break;
end;
end;
Exit;
end;
{ Walk to parent }
@ -6746,6 +6850,7 @@ var
Sym: TSymbol;
RT: TRecordTypeDesc;
Key: string;
OwnerHint: string;
Cand: TMethodDecl;
Grp: TObjectList;
ArityMatch: TObjectList;
@ -6764,6 +6869,9 @@ var
SawHiding: Boolean;
begin
Result := nil;
{ Consume the one-shot receiver owner hint set by the caller. }
OwnerHint := FMethodOwnerHint;
FMethodOwnerHint := '';
if AArgs <> nil then Arity := AArgs.Count else Arity := -1;
TotalCnt := 0;
ArityMatch := TObjectList.Create(False);
@ -6777,8 +6885,16 @@ begin
if Grp <> nil then
for K := 0 to Grp.Count - 1 do
begin
Inc(TotalCnt);
Cand := TMethodDecl(Grp.Items[K]);
{ Cross-unit last-wins: at the receiver's OWN type level the group can
also hold a same-named method on another used unit's same-named type.
Bind to the receiver's actual unit (the hint) — a name re-lookup
would pick the flat-table winner instead. }
if (OwnerHint <> '') and SameText(CurrName, ATypeName) and
(Cand.OwningUnit <> '') and
not SameText(Cand.OwningUnit, OwnerHint) then
Continue;
Inc(TotalCnt);
{ A method declared WITHOUT `overload` hides all inherited methods of
the same name — once seen at this (more-derived) level, the parent
chain is not consulted. Methods WITH `overload` merge with the
@ -11202,8 +11318,9 @@ begin
AExpr.ResolvedType := Result;
Exit;
end;
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
AExpr.Line, AExpr.Col);
FMethodOwnerHint := RT.OwningUnit;
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
AExpr.Line, AExpr.Col);
if MDecl = nil then
begin
FldInfo := RT.FindField(AExpr.Name);
@ -11233,7 +11350,15 @@ begin
Exit;
end;
ObjSym := FTable.Lookup(AExpr.ObjectName);
{ A unit-qualified receiver type 'Unit.Type.Method' resolves against that
specific unit's exports (directed lookup), so a constructor on a cross-unit
same-named type binds to the named unit rather than the flat last-wins
winner. Falls back to the normal lookup on a miss. }
ObjSym := nil;
if AExpr.QualifierUnit <> '' then
ObjSym := ResolveQualified(AExpr.QualifierUnit, AExpr.ObjectName);
if ObjSym = nil then
ObjSym := FTable.Lookup(AExpr.ObjectName);
{ If the name contains '<' and wasn't found, resolve scope-bound type params
(e.g. 'TListEnumerator<T>' → 'TListEnumerator<Integer>' when T=Integer is
in scope) and trigger on-demand instantiation. Mirrors the field-access
@ -11302,8 +11427,9 @@ begin
HintBareEnumMethodArgs(RT.Name, AExpr.Name, AExpr.Args);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
AExpr.Line, AExpr.Col);
FMethodOwnerHint := RT.OwningUnit;
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
AExpr.Line, AExpr.Col);
if MDecl = nil then
begin
FldInfo := RT.FindField(AExpr.Name);
@ -11547,8 +11673,9 @@ begin
AExpr.ResolvedType := Result;
Exit;
end;
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
AExpr.Line, AExpr.Col);
FMethodOwnerHint := RT.OwningUnit;
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
AExpr.Line, AExpr.Col);
if MDecl = nil then
MDecl := FindMethodDecl(RT.Name, AExpr.Name);
{ Built-in TObject.ToString: virtual dispatch yielding string.

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

@ -73,6 +73,12 @@ 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;
function IsNumeric: Boolean;
function IsFloat: Boolean;
function IsString: Boolean;
@ -2012,6 +2018,12 @@ begin
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;

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

@ -58,6 +58,16 @@ type
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;
end;
implementation
@ -455,6 +465,107 @@ begin
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;
initialization
RegisterTest(TE2EUsesChainTests);

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

@ -60,6 +60,10 @@ type
'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
@ -798,6 +802,85 @@ begin
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.