feat(semantic): type-directed resolution of bare enum members
Enum members are no longer registered as bare global constants. They are held in a type-keyed reverse index (member name -> list of declaring enum, ordinal, declaration order), so two enums may share a member name without colliding in the global scope. A bare member reference resolves by a fixed cascade: 1. a real symbol of that name wins (backwards compatible); 2. otherwise the expected type at the use site selects the enum; 3. otherwise a single unique candidate is accepted. When a bare member is ambiguous and no type context is available, this is now a hard error that names the declaring enums and tells the user to qualify it as <EnumType>.Member, replacing the previous last-wins warning. The separate duplicate-member warning channel is removed. Expected-type context is supplied at every site that knows its target type without changing the AnalyseExpr signature: variable/field/element assignment (static, dynamic, open and multi-dimensional arrays, plus implicit-Self and default-property writes), pointer-target writes, case values and ranges, set elements and ranges, the `in` left operand, for loop bounds, standalone and method call arguments (including implicit-Self, qualified, metaclass and constructor calls), procedural- type indirect-call arguments, and function results via Result and Exit. Qualified forms (TEnum.Member, Unit.Member, Unit.TEnum.Member) continue to resolve unchanged. Tests cover each context above plus the ambiguity error, in both the semantic/IR suite and the end-to-end suite.
This commit is contained in:
parent
4d0c7c461d
commit
3db2476983
File diff suppressed because it is too large
Load diff
|
|
@ -135,8 +135,9 @@ type
|
|||
end;
|
||||
|
||||
{ Enum type descriptor. Members are ordered; ordinal values are 0..N-1.
|
||||
Stored as QBE 'w' (same as Integer). Each member is also registered in
|
||||
the symbol table as a skConstant with this type descriptor. }
|
||||
Stored as QBE 'w' (same as Integer). Members are NOT registered as bare
|
||||
global skConstants; a bare member name resolves through the semantic
|
||||
analyser's type-keyed reverse index (see ResolveEnumMember). }
|
||||
TEnumTypeDesc = class(TTypeDesc)
|
||||
public
|
||||
Members: TStringList; { owned — ordered member names }
|
||||
|
|
|
|||
|
|
@ -23,6 +23,8 @@ type
|
|||
function GenIR(const ASrc: string): string;
|
||||
procedure SemanticOK(const ASrc: string);
|
||||
procedure ParseOK(const ASrc: string);
|
||||
{ Analyse ASrc; return the raised semantic-error message, or '' if none. }
|
||||
function SemanticErrText(const ASrc: string): string;
|
||||
published
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ case — parse }
|
||||
|
|
@ -63,6 +65,19 @@ type
|
|||
procedure TestCodegen_Enum_AssignEmitsStore;
|
||||
procedure TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal;
|
||||
procedure TestSemantic_ScopedEnum_UnknownMemberRejected;
|
||||
procedure TestSemantic_ScopedEnum_SharedMemberCompiles;
|
||||
procedure TestSemantic_ScopedEnum_AssignmentDisambiguates;
|
||||
procedure TestSemantic_ScopedEnum_CaseDisambiguates;
|
||||
procedure TestSemantic_ScopedEnum_SetElementDisambiguates;
|
||||
procedure TestSemantic_ScopedEnum_AmbiguousBareRejected;
|
||||
procedure TestSemantic_ScopedEnum_UniqueBareResolves;
|
||||
procedure TestSemantic_ScopedEnum_CallArgDisambiguates;
|
||||
procedure TestSemantic_ScopedEnum_CallArgResolvesCleanly;
|
||||
procedure TestSemantic_ScopedEnum_FieldAssignDisambiguates;
|
||||
procedure TestCodegen_ScopedEnum_FieldAssignEmitsCorrectOrdinal;
|
||||
procedure TestSemantic_ScopedEnum_MethodArgDisambiguates;
|
||||
procedure TestCodegen_ScopedEnum_CallArgEmitsCorrectOrdinal;
|
||||
procedure TestSemantic_ScopedEnum_ForBoundsDisambiguate;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ enum + case integration }
|
||||
|
|
@ -247,6 +262,31 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
function TCaseEnumTests.SemanticErrText(const ASrc: string): string;
|
||||
var
|
||||
Lex: TLexer;
|
||||
Par: TParser;
|
||||
SA: TSemanticAnalyser;
|
||||
Prog: TProgram;
|
||||
begin
|
||||
Result := '';
|
||||
Lex := TLexer.Create(ASrc);
|
||||
Par := TParser.Create(Lex);
|
||||
Prog := Par.Parse();
|
||||
Par.Free(); Lex.Free();
|
||||
SA := TSemanticAnalyser.Create();
|
||||
try
|
||||
try
|
||||
SA.Analyse(Prog);
|
||||
except
|
||||
on E: Exception do Result := E.Message;
|
||||
end;
|
||||
finally
|
||||
SA.Free();
|
||||
Prog.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ case — parse }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
@ -621,6 +661,296 @@ begin
|
|||
AssertTrue('unknown enum member via TEnum.Member rejected', Raised);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_SharedMemberCompiles;
|
||||
const
|
||||
{ Two enums in one unit both declare 'Red'. Members are no longer bare
|
||||
global symbols, so this is NOT a collision — each is reachable through its
|
||||
own type, and the program compiles cleanly. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
begin
|
||||
WriteLn(Ord(TColorA.Red));
|
||||
WriteLn(Ord(TColorB.Red))
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_AssignmentDisambiguates;
|
||||
const
|
||||
{ 'Red' belongs to both enums; the assignment target type selects which one,
|
||||
so BOTH assignments type-check (a fallback-only resolver would mis-type one). }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
var
|
||||
a: TColorA;
|
||||
b: TColorB;
|
||||
begin
|
||||
a := Red;
|
||||
b := Red;
|
||||
WriteLn(Ord(a) + Ord(b))
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_CaseDisambiguates;
|
||||
const
|
||||
{ The case selector's type picks the enum for a bare, shared member label. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
var
|
||||
b: TColorB;
|
||||
begin
|
||||
b := Blue;
|
||||
case b of
|
||||
Red: WriteLn(1);
|
||||
Blue: WriteLn(2)
|
||||
end
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_SetElementDisambiguates;
|
||||
const
|
||||
{ The set's element type picks the enum for a bare, shared member element. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
var
|
||||
s: set of TColorA;
|
||||
begin
|
||||
s := [Red, Green];
|
||||
if Red in s then WriteLn(1)
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_AmbiguousBareRejected;
|
||||
const
|
||||
{ A bare, context-free reference to a member shared by two enums cannot be
|
||||
resolved: it is rejected with an error that names the member and lists the
|
||||
enums that declare it. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
begin
|
||||
WriteLn(Ord(Red))
|
||||
end.
|
||||
''';
|
||||
var
|
||||
E: string;
|
||||
begin
|
||||
E := SemanticErrText(Src);
|
||||
AssertTrue('the ambiguous bare member is rejected', E <> '');
|
||||
AssertTrue('error names the ambiguous member', Pos('''Red''', E) >= 0);
|
||||
AssertTrue('error names the first declaring enum', Pos('TColorA', E) >= 0);
|
||||
AssertTrue('error names the second declaring enum', Pos('TColorB', E) >= 0);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_UniqueBareResolves;
|
||||
const
|
||||
{ A bare member unique across all enums needs no context and resolves
|
||||
cleanly with no error. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Cyan, Blue);
|
||||
begin
|
||||
WriteLn(Ord(Green))
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
AssertEquals('unique bare member resolves with no error', '',
|
||||
SemanticErrText(Src));
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_CallArgDisambiguates;
|
||||
const
|
||||
{ 'Red' is shared; a bare member passed as a call argument is steered to the
|
||||
enum the routine expects at that position, so both calls type-check. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
procedure TakeA(c: TColorA);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
procedure TakeB(c: TColorB);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
begin
|
||||
TakeA(Red);
|
||||
TakeB(Red)
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_CallArgResolvesCleanly;
|
||||
const
|
||||
{ A shared member resolved by the call target's parameter type is NOT
|
||||
ambiguous — the hint pins it before bottom-up analysis, so no error. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
procedure TakeA(c: TColorA);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
begin
|
||||
TakeA(Red)
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
AssertEquals('call-arg hint resolves with no error', '',
|
||||
SemanticErrText(Src));
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestCodegen_ScopedEnum_CallArgEmitsCorrectOrdinal;
|
||||
const
|
||||
{ Red is ordinal 0 in TColorA but ordinal 1 in TColorB; the call target's
|
||||
parameter type must select TColorB.Red so the argument lowers to copy 1. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red);
|
||||
procedure TakeB(c: TColorB);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
begin
|
||||
TakeB(Red)
|
||||
end.
|
||||
''';
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(Src);
|
||||
AssertTrue('TakeB(Red) selects TColorB.Red and emits copy 1',
|
||||
Pos('copy 1', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_FieldAssignDisambiguates;
|
||||
const
|
||||
{ Assigning a bare shared member to a record field is disambiguated by the
|
||||
field's declared enum type — the same context that lets the compiler's own
|
||||
'Result.Kind := tkAs' resolve when tkAs is shared by two enums. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
TRec = record c: TColorB; end;
|
||||
var r: TRec;
|
||||
begin
|
||||
r.c := Red;
|
||||
WriteLn(Ord(r.c))
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestCodegen_ScopedEnum_FieldAssignEmitsCorrectOrdinal;
|
||||
const
|
||||
{ Red is ordinal 0 in TColorA but ordinal 1 in TColorB; the field's type
|
||||
selects TColorB.Red, so the assignment lowers to copy 1. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red);
|
||||
TRec = record c: TColorB; end;
|
||||
var r: TRec;
|
||||
begin
|
||||
r.c := Red
|
||||
end.
|
||||
''';
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(Src);
|
||||
AssertTrue('r.c := Red selects TColorB.Red and emits copy 1',
|
||||
Pos('copy 1', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_MethodArgDisambiguates;
|
||||
const
|
||||
{ A bare shared member passed to a method argument is steered to the enum of
|
||||
the method's parameter, resolved by walking the receiver's class. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
TFoo = class
|
||||
procedure TakeB(c: TColorB);
|
||||
end;
|
||||
procedure TFoo.TakeB(c: TColorB);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
var f: TFoo;
|
||||
begin
|
||||
f := TFoo.Create();
|
||||
f.TakeB(Red);
|
||||
f.Free()
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
procedure TCaseEnumTests.TestSemantic_ScopedEnum_ForBoundsDisambiguate;
|
||||
const
|
||||
{ The loop variable's type picks the enum for bare, shared start/end bounds. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
var
|
||||
b: TColorB;
|
||||
begin
|
||||
for b := Red to Blue do
|
||||
WriteLn(Ord(b))
|
||||
end.
|
||||
''';
|
||||
begin
|
||||
SemanticOK(Src);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TCaseEnumTests);
|
||||
|
||||
|
|
|
|||
|
|
@ -29,6 +29,16 @@ type
|
|||
procedure TestRun_Enum_AutoContinueAfterExplicit;
|
||||
procedure TestRun_Enum_ExplicitInCase;
|
||||
procedure TestRun_Enum_ScopedAccess;
|
||||
procedure TestRun_Enum_SharedMemberByContext;
|
||||
procedure TestRun_Enum_AmbiguousBareRejected;
|
||||
procedure TestRun_Enum_CallArgByContext;
|
||||
procedure TestRun_Enum_ForBoundsByContext;
|
||||
procedure TestRun_Enum_FieldAssignByContext;
|
||||
procedure TestRun_Enum_MethodArgByContext;
|
||||
procedure TestRun_Enum_ArrayElemByContext;
|
||||
procedure TestRun_Enum_PointerWriteByContext;
|
||||
procedure TestRun_Enum_ProcTypeArgByContext;
|
||||
procedure TestRun_Enum_ReturnByContext;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
|
@ -228,9 +238,9 @@ 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. }
|
||||
{ Two enums in one unit share the member name 'Red'. Members are not bare
|
||||
global symbols, so each enum's members are reachable through the
|
||||
type-qualified form regardless of the shared name. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
|
|
@ -260,6 +270,328 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_SharedMemberByContext;
|
||||
const
|
||||
{ 'Red' is shared by both enums. Each bare use is disambiguated by its
|
||||
context — assignment target, case selector, set element — so the program
|
||||
reaches the correct member of each enum at runtime. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Red, Blue);
|
||||
var
|
||||
a: TColorA;
|
||||
b: TColorB;
|
||||
s: set of TColorA;
|
||||
begin
|
||||
a := Red; WriteLn(Ord(a));
|
||||
b := Blue; WriteLn(Ord(b));
|
||||
s := [Red, Green];
|
||||
if Red in s then WriteLn(10);
|
||||
case b of
|
||||
Red: WriteLn(20);
|
||||
Blue: WriteLn(21)
|
||||
end
|
||||
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('a := Red (TColorA.Red)', '0', Lines.Strings[0]);
|
||||
AssertEquals('b := Blue (TColorB.Blue)','1', Lines.Strings[1]);
|
||||
AssertEquals('Red in s (TColorA.Red)', '10', Lines.Strings[2]);
|
||||
AssertEquals('case b = Blue', '21', Lines.Strings[3]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_AmbiguousBareRejected;
|
||||
const
|
||||
{ A bare, context-free reference to a member shared by two enums cannot be
|
||||
resolved and must fail to compile — there is no last-wins fallback. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red);
|
||||
begin
|
||||
WriteLn(Ord(Red))
|
||||
end.
|
||||
''';
|
||||
var Output: string; RCode: Integer; Rejected: Boolean;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
Rejected := False;
|
||||
try
|
||||
if not CompileAndRun(Src, Output, RCode) then
|
||||
Rejected := True;
|
||||
except
|
||||
on E: Exception do Rejected := True;
|
||||
end;
|
||||
AssertTrue('ambiguous bare member must not compile', Rejected);
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_CallArgByContext;
|
||||
const
|
||||
{ 'Red' is shared (ordinal 0 in TColorA, ordinal 1 in TColorB). Each bare
|
||||
member passed as a call argument is steered to the enum of the callee's
|
||||
parameter, so the right ordinal reaches the routine at runtime. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
procedure TakeA(c: TColorA);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
procedure TakeB(c: TColorB);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
begin
|
||||
TakeA(Red);
|
||||
TakeB(Red);
|
||||
TakeB(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('TakeA(Red) -> TColorA.Red', '0', Lines.Strings[0]);
|
||||
AssertEquals('TakeB(Red) -> TColorB.Red', '1', Lines.Strings[1]);
|
||||
AssertEquals('TakeB(Blue) -> TColorB.Blue','2', Lines.Strings[2]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_ForBoundsByContext;
|
||||
const
|
||||
{ The loop variable's type disambiguates the bare shared start bound 'Red'
|
||||
(TColorB here), so the loop walks TColorB.Red(1)..TColorB.Blue(2). }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
var b: TColorB;
|
||||
begin
|
||||
for b := Red to Blue do
|
||||
WriteLn(Ord(b))
|
||||
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('first iter b=Red(1)', '1', Lines.Strings[0]);
|
||||
AssertEquals('second iter b=Blue(2)','2', Lines.Strings[1]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_FieldAssignByContext;
|
||||
const
|
||||
{ A bare shared member assigned to a record field is disambiguated by the
|
||||
field's enum type (TColorB), so r.c receives TColorB.Red (ordinal 1). }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
TRec = record c: TColorB; end;
|
||||
var r: TRec;
|
||||
begin
|
||||
r.c := Red;
|
||||
WriteLn(Ord(r.c))
|
||||
end.
|
||||
''';
|
||||
var Output: string; RCode: Integer;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
|
||||
AssertEquals('r.c := Red -> TColorB.Red (ordinal 1)', '1', Trim(Output));
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_MethodArgByContext;
|
||||
const
|
||||
{ A bare shared member passed to a method is steered to the enum of the
|
||||
method's parameter (TColorB), so TColorB.Red (ordinal 1) reaches it. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
TFoo = class
|
||||
procedure TakeB(c: TColorB);
|
||||
end;
|
||||
procedure TFoo.TakeB(c: TColorB);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
var f: TFoo;
|
||||
begin
|
||||
f := TFoo.Create();
|
||||
f.TakeB(Red);
|
||||
f.TakeB(Blue);
|
||||
f.Free()
|
||||
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('TakeB(Red) -> TColorB.Red', '1', Lines.Strings[0]);
|
||||
AssertEquals('TakeB(Blue) -> TColorB.Blue','2', Lines.Strings[1]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_ArrayElemByContext;
|
||||
const
|
||||
{ Writing a bare shared member into an array element is disambiguated by the
|
||||
array's element type (TColorB), so arr[0] receives TColorB.Red (ordinal 1). }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
var arr: array[0..1] of TColorB;
|
||||
begin
|
||||
arr[0] := Red;
|
||||
arr[1] := Blue;
|
||||
WriteLn(Ord(arr[0]));
|
||||
WriteLn(Ord(arr[1]))
|
||||
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('arr[0] := Red -> TColorB.Red', '1', Lines.Strings[0]);
|
||||
AssertEquals('arr[1] := Blue -> TColorB.Blue','2', Lines.Strings[1]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_PointerWriteByContext;
|
||||
const
|
||||
{ Writing a bare shared member through a typed pointer is disambiguated by
|
||||
the pointer's base enum type (TColorB), so the target receives ordinal 2. }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
PColorB = ^TColorB;
|
||||
var
|
||||
b: TColorB;
|
||||
q: PColorB;
|
||||
begin
|
||||
q := @b;
|
||||
q^ := Blue;
|
||||
WriteLn(Ord(b))
|
||||
end.
|
||||
''';
|
||||
var Output: string; RCode: Integer;
|
||||
begin
|
||||
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
|
||||
AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
|
||||
AssertEquals('q^ := Blue -> TColorB.Blue (ordinal 2)', '2', Trim(Output));
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_ProcTypeArgByContext;
|
||||
const
|
||||
{ Calling through a procedural-type variable steers a bare shared member to
|
||||
the enum of the procedural type's parameter (TColorB). }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
TProcB = procedure(c: TColorB);
|
||||
procedure ShowB(c: TColorB);
|
||||
begin WriteLn(Ord(c)) end;
|
||||
var cb: TProcB;
|
||||
begin
|
||||
cb := @ShowB;
|
||||
cb(Red);
|
||||
cb(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('cb(Red) -> TColorB.Red', '1', Lines.Strings[0]);
|
||||
AssertEquals('cb(Blue) -> TColorB.Blue','2', Lines.Strings[1]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TE2ECaseEnumTests.TestRun_Enum_ReturnByContext;
|
||||
const
|
||||
{ A bare shared member returned from a function is disambiguated by the
|
||||
function's return enum, via both Result := and Exit(). }
|
||||
Src =
|
||||
'''
|
||||
program P;
|
||||
type
|
||||
TColorA = (Red, Green);
|
||||
TColorB = (Amber, Red, Blue);
|
||||
function ViaResult: TColorB;
|
||||
begin Result := Red end;
|
||||
function ViaExit: TColorB;
|
||||
begin Exit(Blue) end;
|
||||
begin
|
||||
WriteLn(Ord(ViaResult()));
|
||||
WriteLn(Ord(ViaExit()))
|
||||
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('Result := Red -> TColorB.Red', '1', Lines.Strings[0]);
|
||||
AssertEquals('Exit(Blue) -> TColorB.Blue', '2', Lines.Strings[1]);
|
||||
finally
|
||||
Lines.Free();
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TE2ECaseEnumTests);
|
||||
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ type
|
|||
procedure TestVarDecl_DuplicatesInterfaceType_RaisesError;
|
||||
procedure TestVarDecl_ShadowsBuiltinType_RaisesError;
|
||||
procedure TestVarDecl_ShadowsOuterScopeType_RaisesError;
|
||||
procedure TestVarDecl_ShadowsEnumMember_RaisesError;
|
||||
procedure TestVarDecl_SharesEnumMemberName_OK;
|
||||
{ Const then var with same name in same block is a duplicate }
|
||||
procedure TestVarDecl_DuplicatesConst_RaisesError;
|
||||
{ Const redeclared with same name in same block is a duplicate }
|
||||
|
|
@ -239,13 +239,16 @@ begin
|
|||
'begin Q(); end.');
|
||||
end;
|
||||
|
||||
procedure TSemanticTests.TestVarDecl_ShadowsEnumMember_RaisesError;
|
||||
procedure TSemanticTests.TestVarDecl_SharesEnumMemberName_OK;
|
||||
var
|
||||
Prog: TProgram;
|
||||
begin
|
||||
{ A var may not shadow a visible enum member — shadowing silently retargets
|
||||
the member in a set literal to the variable, miscompiling the bitmask.
|
||||
Blaise rejects it, in the same spirit as the type-name-shadow rule. }
|
||||
AnalyseExpectError(
|
||||
'program P; type TC = (A, B, C); var c: TC; begin end.');
|
||||
{ A variable may share a name with an enum member. Enum members are not
|
||||
bare global symbols, so there is no collision: the variable wins by normal
|
||||
scoping and the member stays reachable through its type (TC.C). Here 'c'
|
||||
shares the name of member 'C' (names are case-insensitive). }
|
||||
Prog := Analyse('program P; type TC = (A, B, C); var c: TC; begin end.');
|
||||
Prog.Free();
|
||||
end;
|
||||
|
||||
procedure TSemanticTests.TestVarDecl_DuplicatesConst_RaisesError;
|
||||
|
|
|
|||
Loading…
Reference in a new issue