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 09d8b2c..5e300ba 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -17449,6 +17449,7 @@ var VD: TVarDecl; Decl: TMethodDecl; begin + if FSymTable <> nil then FSymTable.InCodegen := True; FCurrentUnitName := AProg.Name; FDbgSrcFile := ''; FProgramName := AProg.Name; @@ -17724,6 +17725,10 @@ begin UnitSym := AUnit.SymbolTable else UnitSym := FSymTable; + { Disable the analysis-time impl-private suppression in Lookup for the table + EmitClassSection consults — at codegen the backend must resolve THIS unit's + own implementation-section classes (see TSymbolTable.FInCodegen). } + if UnitSym <> nil then UnitSym.InCodegen := True; { Re-assert the viewing context (see the init-block note above): the class section emits unit-qualified typeinfo/vtable/_FieldCleanup names via ClassSymName, which must resolve THIS unit's own impl-section classes. } diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 43950a4..d6e15db 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -14472,6 +14472,10 @@ begin begin SavedDOU := FSymTable.DefineOwningUnit; FSymTable.DefineOwningUnit := AUnit.Name; + { Disable the analysis-time impl-private suppression in Lookup: at codegen + the backend must resolve THIS unit's own implementation-section classes to + emit their typeinfo/vtable/_FieldCleanup (see TSymbolTable.FInCodegen). } + FSymTable.InCodegen := True; end; { Combined type-decl list (interface first, then implementation) — borrowed diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index b1ef2ac..673201a 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -11333,6 +11333,7 @@ var BaseType: TTypeDesc; IntfDesc: TInterfaceTypeDesc; MDecl: TMethodDecl; + EnumOrd: Integer; begin { Chained access: A.B.C — base is another expression whose type must be a record or class. Leaf lookup uses Base.ResolvedType; RecordName path @@ -11678,6 +11679,26 @@ begin AAccess.RecordName := RecSym.Name; { normalise to declared casing } + { Type-qualified enum member: TMyEnum.meValue. Resolve the member straight + from the named enum's own member list, so the reference is unambiguous even + when another enum in scope declares a member of the same name (the bare name + resolves to whichever enum claimed the global slot; the qualified form + always names this one). } + if (RecSym.Kind = skType) and (RecSym.TypeDesc <> nil) and + (RecSym.TypeDesc.Kind = tyEnum) then + begin + EnumOrd := TEnumTypeDesc(RecSym.TypeDesc).OrdinalOf(AAccess.FieldName); + if EnumOrd < 0 then + SemanticError( + Format('Enum ''%s'' has no member ''%s''', + [AAccess.RecordName, AAccess.FieldName]), + AAccess.Line, AAccess.Col); + AAccess.IsConstant := True; + AAccess.ConstValue := EnumOrd; + AAccess.ResolvedType := RecSym.TypeDesc; + Exit(RecSym.TypeDesc); + end; + { Constructor call: TypeName.Create } if RecSym.Kind = skType then begin diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index a9d0fe6..36016b2 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -547,6 +547,23 @@ type retrieve the canonical TSymbol — without this flag we'd loop. } FBypassUsesChain: Boolean; + FInCodegen: Boolean; { True while a backend is emitting code. + Disables the Layer-6 impl-private + suppression in Lookup: that guard exists + only to stop an implementation-section + symbol of unit A leaking into a different + unit B DURING ANALYSIS. At codegen time a + backend legitimately resolves a unit's own + impl-section classes (to emit their + typeinfo/vtable/_FieldCleanup and the + references to them), but FDefineOwningUnit + can have drifted to a dependency unit + mid-emit, which made the suppression wrongly + fire and silently drop the class's typeinfo + — a dangling symbol the linker binds to + garbage. Set by the QBE and native + backends around Generate/GenerateUnit. } + FDefineOwningUnit: string; { auto-applied to Sym.OwningUnit on Define when the symbol has no explicit value; set by AnalyseUnit/AnalyseUnitForExport @@ -604,6 +621,9 @@ type property BypassUsesChain: Boolean read FBypassUsesChain write FBypassUsesChain; + { Set by a backend for the duration of code emission; see FInCodegen. } + property InCodegen: Boolean read FInCodegen write FInCodegen; + { Type lookup — case-insensitive, returns nil if not found } function FindType(const AName: string): TTypeDesc; @@ -2043,9 +2063,16 @@ begin The check only runs while a unit/program is being analysed (FDefineOwningUnit <> '') and the chain walker is not mid-callback; outside analysis (some codegen-side lookups clear FDefineOwningUnit) the residue is - returned unchanged so unit-prefix mangling still resolves owned symbols. } + returned unchanged so unit-prefix mangling still resolves owned symbols. + + It is also disabled during code emission (FInCodegen): the leak it guards is + purely an analysis-time concern, whereas a backend legitimately resolves a + unit's own implementation-section classes to emit their typeinfo/vtable/ + _FieldCleanup. FDefineOwningUnit can have drifted to a dependency unit + mid-emit, which would otherwise make this suppression wrongly fire and drop + the class's typeinfo, leaving a dangling symbol the linker binds to garbage. } if (Sym <> nil) and Sym.IsImplPrivate and (FDefineOwningUnit <> '') - and not FBypassUsesChain + and not FBypassUsesChain and not FInCodegen and not SameText(Sym.OwningUnit, FDefineOwningUnit) then begin Result := nil; diff --git a/compiler/src/test/pascal/cp.test.caseenum.pas b/compiler/src/test/pascal/cp.test.caseenum.pas index 9ba4267..f96175b 100644 --- a/compiler/src/test/pascal/cp.test.caseenum.pas +++ b/compiler/src/test/pascal/cp.test.caseenum.pas @@ -61,6 +61,8 @@ type { ------------------------------------------------------------------ } procedure TestCodegen_Enum_MemberEmitsIntegerCopy; procedure TestCodegen_Enum_AssignEmitsStore; + procedure TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal; + procedure TestSemantic_ScopedEnum_UnknownMemberRejected; { ------------------------------------------------------------------ } { enum + case integration } @@ -576,6 +578,49 @@ begin Pos('_StringEquals', IR) < 0); end; +procedure TCaseEnumTests.TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal; +const + Src = + ''' + program P; + type TDir = (dN, dE, dS, dW); + var x: Integer; + begin + x := Ord(TDir.dS) + end. + '''; +var + IR: string; +begin + IR := GenIR(Src); + { TDir.dS is the third member (ordinal 2); the type-qualified reference must + resolve to that member and emit copy 2, exactly as the bare dS would. } + AssertTrue('TDir.dS emits copy 2', Pos('copy 2', IR) > 0); +end; + +procedure TCaseEnumTests.TestSemantic_ScopedEnum_UnknownMemberRejected; +const + Src = + ''' + program P; + type TDir = (dN, dE, dS, dW); + var x: Integer; + begin + x := Ord(TDir.dNope) + end. + '''; +var + Raised: Boolean; +begin + Raised := False; + try + SemanticOK(Src); + except + on E: Exception do Raised := True; + end; + AssertTrue('unknown enum member via TEnum.Member rejected', Raised); +end; + initialization RegisterTest(TCaseEnumTests); diff --git a/compiler/src/test/pascal/cp.test.e2e.caseenum.pas b/compiler/src/test/pascal/cp.test.e2e.caseenum.pas index bb30dd5..0cdc928 100644 --- a/compiler/src/test/pascal/cp.test.e2e.caseenum.pas +++ b/compiler/src/test/pascal/cp.test.e2e.caseenum.pas @@ -28,6 +28,7 @@ type procedure TestRun_Enum_ExplicitOrdinals; procedure TestRun_Enum_AutoContinueAfterExplicit; procedure TestRun_Enum_ExplicitInCase; + procedure TestRun_Enum_ScopedAccess; end; implementation @@ -225,6 +226,40 @@ begin AssertEquals('NotFound=404 matches case 404', 'not found', Trim(Output)); end; +procedure TE2ECaseEnumTests.TestRun_Enum_ScopedAccess; +const + { Two enums in one unit share the member name 'Red'. The bare name resolves + to whichever enum claimed the global slot (TColorA), so TColorB.Red and + TColorB.Blue are reachable ONLY through the type-qualified form. } + Src = + ''' + program P; + type + TColorA = (Red, Green); + TColorB = (Red, Blue); + begin + WriteLn(Ord(TColorA.Red)); + WriteLn(Ord(TColorA.Green)); + WriteLn(Ord(TColorB.Red)); + WriteLn(Ord(TColorB.Blue)) + end. + '''; +var Output: string; RCode: Integer; Lines: TStringList; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRun(Src, Output, RCode)); + Lines := TStringList.Create(); + try + Lines.Text := Trim(Output); + AssertEquals('TColorA.Red', '0', Lines.Strings[0]); + AssertEquals('TColorA.Green','1', Lines.Strings[1]); + AssertEquals('TColorB.Red', '0', Lines.Strings[2]); + AssertEquals('TColorB.Blue', '1', Lines.Strings[3]); + finally + Lines.Free(); + end; +end; + initialization RegisterTest(TE2ECaseEnumTests);