From 9ec970393dffcec81e6e6f2dffbf5711e1e1e829 Mon Sep 17 00:00:00 2001 From: Andrew Haines Date: Mon, 29 Jun 2026 11:03:47 -0400 Subject: [PATCH] feat(units): cross-unit type last-wins and unit-qualified type disambiguation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- .../pascal/blaise.codegen.native.x86_64.pas | 74 +++--- .../src/main/pascal/blaise.codegen.qbe.pas | 230 ++++++++++++------ compiler/src/main/pascal/uAST.pas | 10 + compiler/src/main/pascal/uParser.pas | 1 + compiler/src/main/pascal/uSemantic.pas | 217 +++++++++++++---- compiler/src/main/pascal/uSymbolTable.pas | 12 + .../src/test/pascal/cp.test.e2e.useschain.pas | 111 +++++++++ .../src/test/pascal/cp.test.multifile.pas | 83 +++++++ 8 files changed, 588 insertions(+), 150 deletions(-) diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index 5e300ba..000f1da 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -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 diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index b6ce74a..5461496 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -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); diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 7b65471..0a70b52 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 00cdd16..8a31bac 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -5093,6 +5093,7 @@ begin MCallNode.Col := Col; MCallNode.ObjectName := Name; MCallNode.Name := SecondName; + MCallNode.QualifierUnit := QualUnit; Advance(); if not Check(tkRParen) then begin diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 581b901..5a77459 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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' → 'TListEnumerator' 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. diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index bf40934..cb62fc0 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.e2e.useschain.pas b/compiler/src/test/pascal/cp.test.e2e.useschain.pas index 9bce7c9..a893a32 100644 --- a/compiler/src/test/pascal/cp.test.e2e.useschain.pas +++ b/compiler/src/test/pascal/cp.test.e2e.useschain.pas @@ -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); diff --git a/compiler/src/test/pascal/cp.test.multifile.pas b/compiler/src/test/pascal/cp.test.multifile.pas index 4e29868..988c26c 100644 --- a/compiler/src/test/pascal/cp.test.multifile.pas +++ b/compiler/src/test/pascal/cp.test.multifile.pas @@ -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.