feat(generics): for..in support on generic collections (Step 9b)
Three fixes to unblock for..in over generic collection types: 1. SubstTypeParam: extend to substitute type params inside generic instantiation names. Previously only bare 'T' and '^T' were handled; 'SomeName<T>' was left unsubstituted, so a method returning 'TListEnumerator<T>' kept the raw param name after cloning. 2. InstantiateGeneric: clone TClassTypeDef.Properties with type-param substitution (same pattern as fields and methods). Without this the 'Current: T' property was invisible on instantiated enumerator types and FindProperty returned nil during for..in semantic checks. 3. AnalyseFieldAccess + ResolveScopeBoundTypeParams: when a generic RecordName such as 'TGenEnum<T>' isn't found in the symbol table, resolve each type argument against the current scope (where T=Integer is pushed during method body analysis) and retry the lookup with the concrete name 'TGenEnum<Integer>'. New: cp.test.genericforin.pas — 10 tests covering property visibility, property type after instantiation, and end-to-end for..in IR emission. 1141 tests total, all passing.
This commit is contained in:
Graeme Geldenhuys
parent
5af72daac7
commit
aafd004973
|
|
@ -52,6 +52,12 @@ type
|
||||||
function SubstTypeParam(const ATypeName: string;
|
function SubstTypeParam(const ATypeName: string;
|
||||||
AParamNames, AArgs: TStringList): string;
|
AParamNames, AArgs: TStringList): string;
|
||||||
|
|
||||||
|
{ Resolves scope-bound type params inside a generic type name such as
|
||||||
|
'TGenEnum<T>' when 'T' is bound in the current scope as a skType symbol.
|
||||||
|
Returns the canonical name (e.g. 'TGenEnum<Integer>') suitable for
|
||||||
|
FindTypeOrInstantiate. Has no effect on names without '<'. }
|
||||||
|
function ResolveScopeBoundTypeParams(const ATypeName: string): string;
|
||||||
|
|
||||||
{ Generic function instantiation: resolves 'Identity<Integer>' on demand. }
|
{ Generic function instantiation: resolves 'Identity<Integer>' on demand. }
|
||||||
function InstantiateGenericFunc(const AInstName: string): TMethodDecl;
|
function InstantiateGenericFunc(const AInstName: string): TMethodDecl;
|
||||||
|
|
||||||
|
|
@ -736,6 +742,55 @@ begin
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
function TSemanticAnalyser.ResolveScopeBoundTypeParams(const ATypeName: string): string;
|
||||||
|
var
|
||||||
|
BrOpen, BrClose, I: Integer;
|
||||||
|
BasePart, ArgsPart, OutArgs, Arg: string;
|
||||||
|
ArgList: TStringList;
|
||||||
|
Sym: TSymbol;
|
||||||
|
begin
|
||||||
|
Result := ATypeName;
|
||||||
|
BrOpen := Pos('<', ATypeName);
|
||||||
|
if BrOpen = 0 then Exit;
|
||||||
|
BrClose := Length(ATypeName);
|
||||||
|
BasePart := Copy(ATypeName, 1, BrOpen - 1);
|
||||||
|
ArgsPart := Copy(ATypeName, BrOpen + 1, BrClose - BrOpen - 1);
|
||||||
|
ArgList := TStringList.Create;
|
||||||
|
try
|
||||||
|
while ArgsPart <> '' do
|
||||||
|
begin
|
||||||
|
I := Pos(',', ArgsPart);
|
||||||
|
if I > 0 then
|
||||||
|
begin
|
||||||
|
ArgList.Add(Trim(Copy(ArgsPart, 1, I - 1)));
|
||||||
|
ArgsPart := Trim(Copy(ArgsPart, I + 1, MaxInt));
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
ArgList.Add(Trim(ArgsPart));
|
||||||
|
ArgsPart := '';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
OutArgs := '';
|
||||||
|
for I := 0 to ArgList.Count - 1 do
|
||||||
|
begin
|
||||||
|
Arg := ArgList.Strings[I];
|
||||||
|
{ If this arg is a bare ident bound as skType in the current scope,
|
||||||
|
replace it with the concrete type name. }
|
||||||
|
Sym := FTable.Lookup(Arg);
|
||||||
|
if (Sym <> nil) and (Sym.Kind = skType) and (Sym.TypeDesc <> nil) then
|
||||||
|
Arg := Sym.TypeDesc.Name;
|
||||||
|
if OutArgs = '' then
|
||||||
|
OutArgs := Arg
|
||||||
|
else
|
||||||
|
OutArgs := OutArgs + ',' + Arg;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
ArgList.Free;
|
||||||
|
end;
|
||||||
|
Result := BasePart + '<' + OutArgs + '>';
|
||||||
|
end;
|
||||||
|
|
||||||
function TSemanticAnalyser.FindTypeOrInstantiate(const AName: string): TTypeDesc;
|
function TSemanticAnalyser.FindTypeOrInstantiate(const AName: string): TTypeDesc;
|
||||||
var
|
var
|
||||||
BaseName: string;
|
BaseName: string;
|
||||||
|
|
@ -818,7 +873,9 @@ end;
|
||||||
function TSemanticAnalyser.SubstTypeParam(const ATypeName: string;
|
function TSemanticAnalyser.SubstTypeParam(const ATypeName: string;
|
||||||
AParamNames, AArgs: TStringList): string;
|
AParamNames, AArgs: TStringList): string;
|
||||||
var
|
var
|
||||||
I: Integer;
|
I, BrOpen, BrClose: Integer;
|
||||||
|
BasePart, ArgsPart, OutArgs, Arg: string;
|
||||||
|
ArgList: TStringList;
|
||||||
begin
|
begin
|
||||||
Result := ATypeName;
|
Result := ATypeName;
|
||||||
{ Direct match: T → Integer }
|
{ Direct match: T → Integer }
|
||||||
|
|
@ -830,7 +887,47 @@ begin
|
||||||
end;
|
end;
|
||||||
{ Prefix caret: ^T → ^Integer, ^^T → ^^Integer, etc. }
|
{ Prefix caret: ^T → ^Integer, ^^T → ^^Integer, etc. }
|
||||||
if (Length(Result) > 0) and (Result[1] = '^') then
|
if (Length(Result) > 0) and (Result[1] = '^') then
|
||||||
|
begin
|
||||||
Result := '^' + Self.SubstTypeParam(Copy(Result, 2, MaxInt), AParamNames, AArgs);
|
Result := '^' + Self.SubstTypeParam(Copy(Result, 2, MaxInt), AParamNames, AArgs);
|
||||||
|
Exit;
|
||||||
|
end;
|
||||||
|
{ Generic instantiation: SomeName<T,...> — substitute each type argument }
|
||||||
|
BrOpen := Pos('<', Result);
|
||||||
|
if BrOpen > 0 then
|
||||||
|
begin
|
||||||
|
BrClose := Length(Result); { closing '>' is always the last char }
|
||||||
|
BasePart := Copy(Result, 1, BrOpen - 1);
|
||||||
|
ArgsPart := Copy(Result, BrOpen + 1, BrClose - BrOpen - 1);
|
||||||
|
ArgList := TStringList.Create;
|
||||||
|
try
|
||||||
|
while ArgsPart <> '' do
|
||||||
|
begin
|
||||||
|
I := Pos(',', ArgsPart);
|
||||||
|
if I > 0 then
|
||||||
|
begin
|
||||||
|
ArgList.Add(Trim(Copy(ArgsPart, 1, I - 1)));
|
||||||
|
ArgsPart := Trim(Copy(ArgsPart, I + 1, MaxInt));
|
||||||
|
end
|
||||||
|
else
|
||||||
|
begin
|
||||||
|
ArgList.Add(Trim(ArgsPart));
|
||||||
|
ArgsPart := '';
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
OutArgs := '';
|
||||||
|
for I := 0 to ArgList.Count - 1 do
|
||||||
|
begin
|
||||||
|
Arg := Self.SubstTypeParam(ArgList.Strings[I], AParamNames, AArgs);
|
||||||
|
if OutArgs = '' then
|
||||||
|
OutArgs := Arg
|
||||||
|
else
|
||||||
|
OutArgs := OutArgs + ',' + Arg;
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
ArgList.Free;
|
||||||
|
end;
|
||||||
|
Result := BasePart + '<' + OutArgs + '>';
|
||||||
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TSemanticAnalyser.InstantiateGeneric(const ATypeName: string): TRecordTypeDesc;
|
function TSemanticAnalyser.InstantiateGeneric(const ATypeName: string): TRecordTypeDesc;
|
||||||
|
|
@ -848,11 +945,15 @@ var
|
||||||
NewMDecl: TMethodDecl;
|
NewMDecl: TMethodDecl;
|
||||||
Par: TMethodParam;
|
Par: TMethodParam;
|
||||||
NewPar: TMethodParam;
|
NewPar: TMethodParam;
|
||||||
|
PDecl: TPropertyDecl;
|
||||||
|
NewPDecl: TPropertyDecl;
|
||||||
Sym: TSymbol;
|
Sym: TSymbol;
|
||||||
Key: string;
|
Key: string;
|
||||||
FldType: TTypeDesc;
|
FldType: TTypeDesc;
|
||||||
FldName: string;
|
FldName: string;
|
||||||
ParType: TTypeDesc;
|
ParType: TTypeDesc;
|
||||||
|
PropType: TTypeDesc;
|
||||||
|
PropInfo: TPropertyInfo;
|
||||||
RT: TRecordTypeDesc;
|
RT: TRecordTypeDesc;
|
||||||
GI: TGenericInstance;
|
GI: TGenericInstance;
|
||||||
Subst: string;
|
Subst: string;
|
||||||
|
|
@ -947,6 +1048,20 @@ begin
|
||||||
ClonedCD.Methods.Add(NewMDecl);
|
ClonedCD.Methods.Add(NewMDecl);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
{ Clone property declarations with type-param substitution }
|
||||||
|
for I := 0 to Templ.ClassDef.Properties.Count - 1 do
|
||||||
|
begin
|
||||||
|
PDecl := TPropertyDecl(Templ.ClassDef.Properties.Items[I]);
|
||||||
|
NewPDecl := TPropertyDecl.Create;
|
||||||
|
NewPDecl.Name := PDecl.Name;
|
||||||
|
NewPDecl.TypeName := SubstTypeParam(PDecl.TypeName, Templ.ParamNames, Args);
|
||||||
|
NewPDecl.ReadName := PDecl.ReadName;
|
||||||
|
NewPDecl.WriteName := PDecl.WriteName;
|
||||||
|
NewPDecl.IndexParamName := PDecl.IndexParamName;
|
||||||
|
NewPDecl.IndexTypeName := SubstTypeParam(PDecl.IndexTypeName, Templ.ParamNames, Args);
|
||||||
|
ClonedCD.Properties.Add(NewPDecl);
|
||||||
|
end;
|
||||||
|
|
||||||
{ Pre-pass: vtable slots (before fields so vptr is counted in offsets) }
|
{ Pre-pass: vtable slots (before fields so vptr is counted in offsets) }
|
||||||
for J := 0 to ClonedCD.Methods.Count - 1 do
|
for J := 0 to ClonedCD.Methods.Count - 1 do
|
||||||
begin
|
begin
|
||||||
|
|
@ -1012,6 +1127,39 @@ begin
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
{ Resolve property declarations — type-param already substituted in clone pass }
|
||||||
|
for J := 0 to ClonedCD.Properties.Count - 1 do
|
||||||
|
begin
|
||||||
|
NewPDecl := TPropertyDecl(ClonedCD.Properties.Items[J]);
|
||||||
|
PropType := FindTypeOrInstantiate(NewPDecl.TypeName);
|
||||||
|
if PropType = nil then
|
||||||
|
SemanticError(
|
||||||
|
Format('Unknown type ''%s'' for property ''%s'' in ''%s''',
|
||||||
|
[NewPDecl.TypeName, NewPDecl.Name, ATypeName]),
|
||||||
|
0, 0);
|
||||||
|
PropInfo := TPropertyInfo.Create;
|
||||||
|
PropInfo.Name := NewPDecl.Name;
|
||||||
|
PropInfo.TypeDesc := PropType;
|
||||||
|
if NewPDecl.ReadName <> '' then
|
||||||
|
begin
|
||||||
|
if RT.FindField(NewPDecl.ReadName) <> nil then
|
||||||
|
PropInfo.ReadField := NewPDecl.ReadName
|
||||||
|
else
|
||||||
|
PropInfo.ReadMethod := NewPDecl.ReadName;
|
||||||
|
end;
|
||||||
|
if NewPDecl.WriteName <> '' then
|
||||||
|
begin
|
||||||
|
if RT.FindField(NewPDecl.WriteName) <> nil then
|
||||||
|
PropInfo.WriteField := NewPDecl.WriteName
|
||||||
|
else
|
||||||
|
PropInfo.WriteMethod := NewPDecl.WriteName;
|
||||||
|
end;
|
||||||
|
PropInfo.IndexParamName := NewPDecl.IndexParamName;
|
||||||
|
if NewPDecl.IndexTypeName <> '' then
|
||||||
|
PropInfo.IndexTypeDesc := FindTypeOrInstantiate(NewPDecl.IndexTypeName);
|
||||||
|
RT.AddProperty(PropInfo);
|
||||||
|
end;
|
||||||
|
|
||||||
{ Analyse method bodies with concrete types in scope.
|
{ Analyse method bodies with concrete types in scope.
|
||||||
Push type-param bindings (T=Integer etc.) so that SizeOf(T) and
|
Push type-param bindings (T=Integer etc.) so that SizeOf(T) and
|
||||||
local var declarations like 'var P: ^T' resolve to concrete types. }
|
local var declarations like 'var P: ^T' resolve to concrete types. }
|
||||||
|
|
@ -3935,6 +4083,15 @@ begin
|
||||||
end;
|
end;
|
||||||
|
|
||||||
RecSym := FTable.Lookup(AAccess.RecordName);
|
RecSym := FTable.Lookup(AAccess.RecordName);
|
||||||
|
{ If the name contains '<' and wasn't found, resolve scope-bound type params
|
||||||
|
(e.g. 'TGenEnum<T>' → 'TGenEnum<Integer>' when T=Integer is in scope)
|
||||||
|
and update AAccess.RecordName so codegen sees the concrete instantiation. }
|
||||||
|
if (RecSym = nil) and (Pos('<', AAccess.RecordName) > 0) then
|
||||||
|
begin
|
||||||
|
AAccess.RecordName := ResolveScopeBoundTypeParams(AAccess.RecordName);
|
||||||
|
FindTypeOrInstantiate(AAccess.RecordName);
|
||||||
|
RecSym := FTable.Lookup(AAccess.RecordName);
|
||||||
|
end;
|
||||||
if RecSym = nil then
|
if RecSym = nil then
|
||||||
begin
|
begin
|
||||||
{ Implicit Self.RecordName.FieldName — RecordName is a field of current class }
|
{ Implicit Self.RecordName.FieldName — RecordName is a field of current class }
|
||||||
|
|
|
||||||
|
|
@ -67,7 +67,8 @@ uses
|
||||||
cp.test.constants,
|
cp.test.constants,
|
||||||
cp.test.external,
|
cp.test.external,
|
||||||
cp.test.opdf,
|
cp.test.opdf,
|
||||||
cp.test.forin;
|
cp.test.forin,
|
||||||
|
cp.test.genericforin;
|
||||||
|
|
||||||
var
|
var
|
||||||
Application: TTestRunner;
|
Application: TTestRunner;
|
||||||
|
|
|
||||||
414
compiler/src/test/pascal/cp.test.genericforin.pas
Normal file
414
compiler/src/test/pascal/cp.test.genericforin.pas
Normal file
|
|
@ -0,0 +1,414 @@
|
||||||
|
{
|
||||||
|
Blaise - An Object Pascal Compiler
|
||||||
|
Copyright (c) 2026 Graeme Geldenhuys
|
||||||
|
SPDX-License-Identifier: BSD-3-Clause
|
||||||
|
See LICENSE file in the project root for full license terms.
|
||||||
|
}
|
||||||
|
|
||||||
|
unit cp.test.genericforin;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
{ Tests for for..in support on generic collections (Step 9b).
|
||||||
|
|
||||||
|
Two blockers:
|
||||||
|
1. InstantiateGeneric doesn't clone TClassTypeDef.Properties with
|
||||||
|
type-param substitution, so 'Current: T' is invisible on the
|
||||||
|
instantiated enumerator type.
|
||||||
|
2. generics.collections.pas has no TListEnumerator<T> +
|
||||||
|
TList<T>.GetEnumerator; the existing for..in class-enumerator
|
||||||
|
protocol path handles everything once those are added. }
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils, fpcunit, testregistry,
|
||||||
|
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||||
|
|
||||||
|
type
|
||||||
|
TGenericForInTests = class(TTestCase)
|
||||||
|
private
|
||||||
|
function ParseSrc(const ASrc: string): TProgram;
|
||||||
|
function AnalyseSrc(const ASrc: string): TProgram;
|
||||||
|
function GenIR(const ASrc: string): string;
|
||||||
|
procedure AnalyseExpectError(const ASrc: string);
|
||||||
|
published
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ Blocker 1: property cloning in InstantiateGeneric }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
procedure TestSemantic_GenericEnumerator_CurrentPropertyVisible;
|
||||||
|
procedure TestSemantic_GenericEnumerator_CurrentPropertyType;
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ Blocker 2: TListEnumerator<T> + TList<T>.GetEnumerator in RTL }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
procedure TestParse_TListEnumerator_IsGenericTypeDef;
|
||||||
|
procedure TestParse_TList_GetEnumerator_Declared;
|
||||||
|
procedure TestSemantic_TList_Integer_HasGetEnumerator;
|
||||||
|
procedure TestSemantic_TListEnumerator_Integer_HasCurrentProperty;
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ End-to-end: for..in on TList<Integer> }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
procedure TestSemantic_ForIn_GenericList_OK;
|
||||||
|
procedure TestCodegen_ForIn_GenericList_CallsGetEnumerator;
|
||||||
|
procedure TestCodegen_ForIn_GenericList_CallsMoveNext;
|
||||||
|
procedure TestCodegen_ForIn_GenericList_CallsGetCurrent;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ Source constants }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
|
||||||
|
const
|
||||||
|
{ Minimal generic enumerator with a property backed by a getter. }
|
||||||
|
SrcGenericEnumerator =
|
||||||
|
'program P;' + LineEnding +
|
||||||
|
'type' + LineEnding +
|
||||||
|
' TGenEnum<T> = class' + LineEnding +
|
||||||
|
' FData: T;' + LineEnding +
|
||||||
|
' FDone: Boolean;' + LineEnding +
|
||||||
|
' function MoveNext: Boolean;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := not Self.FDone;' + LineEnding +
|
||||||
|
' Self.FDone := True' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' function GetCurrent: T;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := Self.FData' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' property Current: T read GetCurrent;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
'begin end.';
|
||||||
|
|
||||||
|
{ A minimal generic collection that exposes GetEnumerator. }
|
||||||
|
SrcGenericCollection =
|
||||||
|
'program P;' + LineEnding +
|
||||||
|
'type' + LineEnding +
|
||||||
|
' TGenEnum<T> = class' + LineEnding +
|
||||||
|
' FData: T;' + LineEnding +
|
||||||
|
' FDone: Boolean;' + LineEnding +
|
||||||
|
' function MoveNext: Boolean;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := not Self.FDone;' + LineEnding +
|
||||||
|
' Self.FDone := True' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' function GetCurrent: T;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := Self.FData' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' property Current: T read GetCurrent;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' TColl<T> = class' + LineEnding +
|
||||||
|
' FItem: T;' + LineEnding +
|
||||||
|
' function GetEnumerator: TGenEnum<T>;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := TGenEnum<T>.Create' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
'var' + LineEnding +
|
||||||
|
' C: TColl<Integer>;' + LineEnding +
|
||||||
|
' X: Integer;' + LineEnding +
|
||||||
|
'begin' + LineEnding +
|
||||||
|
' C := TColl<Integer>.Create;' + LineEnding +
|
||||||
|
' for X in C do' + LineEnding +
|
||||||
|
' WriteLn(X)' + LineEnding +
|
||||||
|
'end.';
|
||||||
|
|
||||||
|
{ Source that requires TList<T> and TListEnumerator<T> from the RTL.
|
||||||
|
Uses a minimal inline definition so the test is self-contained. }
|
||||||
|
SrcTListEnumeratorDecl =
|
||||||
|
'program P;' + LineEnding +
|
||||||
|
'type' + LineEnding +
|
||||||
|
' TListEnumerator<T> = class' + LineEnding +
|
||||||
|
' FList: ^T;' + LineEnding +
|
||||||
|
' FIndex: Integer;' + LineEnding +
|
||||||
|
' FCount: Integer;' + LineEnding +
|
||||||
|
' function MoveNext: Boolean;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Self.FIndex := Self.FIndex + 1;' + LineEnding +
|
||||||
|
' Result := Self.FIndex < Self.FCount' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' function GetCurrent: T;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := (Self.FList + Self.FIndex)^' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' property Current: T read GetCurrent;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' TMyList<T> = class' + LineEnding +
|
||||||
|
' FData: ^T;' + LineEnding +
|
||||||
|
' FCount: Integer;' + LineEnding +
|
||||||
|
' function GetEnumerator: TListEnumerator<T>;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := TListEnumerator<T>.Create' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
'begin end.';
|
||||||
|
|
||||||
|
SrcForInGenericList =
|
||||||
|
'program P;' + LineEnding +
|
||||||
|
'type' + LineEnding +
|
||||||
|
' TListEnumerator<T> = class' + LineEnding +
|
||||||
|
' FList: ^T;' + LineEnding +
|
||||||
|
' FIndex: Integer;' + LineEnding +
|
||||||
|
' FCount: Integer;' + LineEnding +
|
||||||
|
' function MoveNext: Boolean;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Self.FIndex := Self.FIndex + 1;' + LineEnding +
|
||||||
|
' Result := Self.FIndex < Self.FCount' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' function GetCurrent: T;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := (Self.FList + Self.FIndex)^' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' property Current: T read GetCurrent;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' TMyList<T> = class' + LineEnding +
|
||||||
|
' FData: ^T;' + LineEnding +
|
||||||
|
' FCount: Integer;' + LineEnding +
|
||||||
|
' function GetEnumerator: TListEnumerator<T>;' + LineEnding +
|
||||||
|
' begin' + LineEnding +
|
||||||
|
' Result := TListEnumerator<T>.Create' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
' end;' + LineEnding +
|
||||||
|
'var' + LineEnding +
|
||||||
|
' L: TMyList<Integer>;' + LineEnding +
|
||||||
|
' X: Integer;' + LineEnding +
|
||||||
|
'begin' + LineEnding +
|
||||||
|
' L := TMyList<Integer>.Create;' + LineEnding +
|
||||||
|
' for X in L do' + LineEnding +
|
||||||
|
' WriteLn(X)' + LineEnding +
|
||||||
|
'end.';
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ Helpers }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
|
||||||
|
function TGenericForInTests.ParseSrc(const ASrc: string): TProgram;
|
||||||
|
var
|
||||||
|
Lex: TLexer;
|
||||||
|
Par: TParser;
|
||||||
|
begin
|
||||||
|
Lex := TLexer.Create(ASrc);
|
||||||
|
Par := TParser.Create(Lex);
|
||||||
|
try
|
||||||
|
Result := Par.Parse;
|
||||||
|
finally
|
||||||
|
Par.Free;
|
||||||
|
Lex.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TGenericForInTests.AnalyseSrc(const ASrc: string): TProgram;
|
||||||
|
var
|
||||||
|
SA: TSemanticAnalyser;
|
||||||
|
begin
|
||||||
|
Result := ParseSrc(ASrc);
|
||||||
|
SA := TSemanticAnalyser.Create;
|
||||||
|
try
|
||||||
|
SA.Analyse(Result);
|
||||||
|
finally
|
||||||
|
SA.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TGenericForInTests.GenIR(const ASrc: string): string;
|
||||||
|
var
|
||||||
|
CG: TCodeGenQBE;
|
||||||
|
Prog: TProgram;
|
||||||
|
begin
|
||||||
|
Prog := AnalyseSrc(ASrc);
|
||||||
|
CG := TCodeGenQBE.Create;
|
||||||
|
try
|
||||||
|
CG.Generate(Prog);
|
||||||
|
Result := CG.GetOutput;
|
||||||
|
finally
|
||||||
|
CG.Free;
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.AnalyseExpectError(const ASrc: string);
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
SA: TSemanticAnalyser;
|
||||||
|
begin
|
||||||
|
Prog := ParseSrc(ASrc);
|
||||||
|
SA := TSemanticAnalyser.Create;
|
||||||
|
try
|
||||||
|
try
|
||||||
|
SA.Analyse(Prog);
|
||||||
|
Fail('Expected ESemanticError but none was raised');
|
||||||
|
except
|
||||||
|
on E: ESemanticError do { expected };
|
||||||
|
end;
|
||||||
|
finally
|
||||||
|
SA.Free;
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ Blocker 1: property cloning }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestSemantic_GenericEnumerator_CurrentPropertyVisible;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
RT: TRecordTypeDesc;
|
||||||
|
begin
|
||||||
|
Prog := AnalyseSrc(SrcGenericEnumerator);
|
||||||
|
try
|
||||||
|
{ The instantiated type is not used in a var decl, so trigger instantiation
|
||||||
|
by using the collection source which references TGenEnum<Integer>. }
|
||||||
|
{ Use the generic enumerator source that references no concrete param —
|
||||||
|
check that the template class definition itself still parsed the property. }
|
||||||
|
RT := TRecordTypeDesc(Prog.SymbolTable.FindType('TGenEnum'));
|
||||||
|
{ TGenEnum is generic, not a concrete type; FindType should return nil. }
|
||||||
|
AssertNull('TGenEnum is not a concrete type', RT);
|
||||||
|
finally
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestSemantic_GenericEnumerator_CurrentPropertyType;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
RT: TRecordTypeDesc;
|
||||||
|
Prop: TPropertyInfo;
|
||||||
|
begin
|
||||||
|
{ Instantiate TGenEnum<Integer> via the collection source }
|
||||||
|
Prog := AnalyseSrc(SrcGenericCollection);
|
||||||
|
try
|
||||||
|
RT := TRecordTypeDesc(Prog.SymbolTable.FindType('TGenEnum<Integer>'));
|
||||||
|
AssertNotNull('TGenEnum<Integer> was instantiated', RT);
|
||||||
|
Prop := RT.FindProperty('Current');
|
||||||
|
AssertNotNull('Current property present on TGenEnum<Integer>', Prop);
|
||||||
|
AssertEquals('Current property type is tyInteger',
|
||||||
|
Ord(tyInteger), Ord(Prop.TypeDesc.Kind));
|
||||||
|
finally
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ Blocker 2: TListEnumerator<T> + TList<T>.GetEnumerator }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestParse_TListEnumerator_IsGenericTypeDef;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
TD: TTypeDecl;
|
||||||
|
begin
|
||||||
|
Prog := ParseSrc(SrcTListEnumeratorDecl);
|
||||||
|
try
|
||||||
|
AssertEquals('Two type decls', 2, Prog.Block.TypeDecls.Count);
|
||||||
|
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
|
||||||
|
AssertEquals('Name is TListEnumerator', 'TListEnumerator', TD.Name);
|
||||||
|
AssertTrue('Def is TGenericTypeDef', TD.Def is TGenericTypeDef);
|
||||||
|
finally
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestParse_TList_GetEnumerator_Declared;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
TD: TTypeDecl;
|
||||||
|
GD: TGenericTypeDef;
|
||||||
|
MD: TMethodDecl;
|
||||||
|
Found: Boolean;
|
||||||
|
I: Integer;
|
||||||
|
begin
|
||||||
|
Prog := ParseSrc(SrcTListEnumeratorDecl);
|
||||||
|
try
|
||||||
|
TD := TTypeDecl(Prog.Block.TypeDecls[1]); { TMyList }
|
||||||
|
GD := TGenericTypeDef(TD.Def);
|
||||||
|
Found := False;
|
||||||
|
for I := 0 to GD.ClassDef.Methods.Count - 1 do
|
||||||
|
begin
|
||||||
|
MD := TMethodDecl(GD.ClassDef.Methods.Items[I]);
|
||||||
|
if MD.Name = 'GetEnumerator' then
|
||||||
|
Found := True;
|
||||||
|
end;
|
||||||
|
AssertTrue('GetEnumerator method declared on TMyList', Found);
|
||||||
|
finally
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestSemantic_TList_Integer_HasGetEnumerator;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
begin
|
||||||
|
{ A var of TMyList<Integer> should trigger instantiation; semantic must
|
||||||
|
not raise an error (GetEnumerator return type TListEnumerator<Integer>
|
||||||
|
must instantiate transitively). }
|
||||||
|
Prog := AnalyseSrc(SrcForInGenericList);
|
||||||
|
Prog.Free; { no exception = pass }
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestSemantic_TListEnumerator_Integer_HasCurrentProperty;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
RT: TRecordTypeDesc;
|
||||||
|
Prop: TPropertyInfo;
|
||||||
|
begin
|
||||||
|
Prog := AnalyseSrc(SrcForInGenericList);
|
||||||
|
try
|
||||||
|
RT := TRecordTypeDesc(Prog.SymbolTable.FindType('TListEnumerator<Integer>'));
|
||||||
|
AssertNotNull('TListEnumerator<Integer> instantiated', RT);
|
||||||
|
Prop := RT.FindProperty('Current');
|
||||||
|
AssertNotNull('Current property on TListEnumerator<Integer>', Prop);
|
||||||
|
AssertEquals('Current type is tyInteger',
|
||||||
|
Ord(tyInteger), Ord(Prop.TypeDesc.Kind));
|
||||||
|
finally
|
||||||
|
Prog.Free;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
{ End-to-end: for..in on TList<Integer> }
|
||||||
|
{ ------------------------------------------------------------------ }
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestSemantic_ForIn_GenericList_OK;
|
||||||
|
var
|
||||||
|
Prog: TProgram;
|
||||||
|
begin
|
||||||
|
Prog := AnalyseSrc(SrcForInGenericList);
|
||||||
|
Prog.Free; { no exception = semantic check passed }
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestCodegen_ForIn_GenericList_CallsGetEnumerator;
|
||||||
|
var
|
||||||
|
IR: string;
|
||||||
|
begin
|
||||||
|
IR := GenIR(SrcForInGenericList);
|
||||||
|
AssertTrue('IR calls GetEnumerator',
|
||||||
|
Pos('TMyList_Integer_GetEnumerator', IR) > 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestCodegen_ForIn_GenericList_CallsMoveNext;
|
||||||
|
var
|
||||||
|
IR: string;
|
||||||
|
begin
|
||||||
|
IR := GenIR(SrcForInGenericList);
|
||||||
|
AssertTrue('IR calls MoveNext',
|
||||||
|
Pos('TListEnumerator_Integer_MoveNext', IR) > 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TGenericForInTests.TestCodegen_ForIn_GenericList_CallsGetCurrent;
|
||||||
|
var
|
||||||
|
IR: string;
|
||||||
|
begin
|
||||||
|
IR := GenIR(SrcForInGenericList);
|
||||||
|
AssertTrue('IR calls GetCurrent (Current getter)',
|
||||||
|
Pos('TListEnumerator_Integer_GetCurrent', IR) > 0);
|
||||||
|
end;
|
||||||
|
|
||||||
|
initialization
|
||||||
|
RegisterTest(TGenericForInTests);
|
||||||
|
|
||||||
|
end.
|
||||||
Loading…
Reference in a new issue