Implement interface type declarations, class implements, and interface dispatch
Parser: TInterfaceTypeDef AST node; ParseInterfaceDef; ParseClassDef extended to parse comma-separated implements list (first name = parent class, rest = interfaces); ParseMethodDecl body remains optional. Symbol table: tyInterface added to TTypeKind; TInterfaceTypeDesc with unsorted (declaration-order) method list for correct itab slot indexing; FImplements non-owning list on TRecordTypeDesc tracks class→interface pairs; TObject pre-registered as built-in root class. Semantic: AnalyseTypeDecls handles TInterfaceTypeDef (register, inherit parent methods); verifies class implements all interface methods; CheckTypesMatch extended for class→interface assignment; AnalyseMethodCall handles tyInterface object vars via itab dispatch path; TAssignment carries ResolvedLhsType. Codegen: EmitInterfaceDefs emits $typeinfo_IFoo and $itab_TFoo_IFoo data blocks; EmitVarAllocs allocates two-slot fat pointer (_obj + _itab) for interface vars; EmitAssignment stores both obj pointer and itab address on interface assignment; EmitMethodCall dispatches via itab on tyInterface receiver. 15 new tests, 484 total, 0 failures.
This commit is contained in:
Graeme Geldenhuys
parent
c13901a2e2
commit
c371272811
|
|
@ -84,9 +84,10 @@ type
|
|||
|
||||
TAssignment = class(TASTStmt)
|
||||
public
|
||||
Name: string;
|
||||
Expr: TASTExpr; { owned }
|
||||
IsVarParam: Boolean; { set by uSemantic — True if target is a var parameter }
|
||||
Name: string;
|
||||
Expr: TASTExpr; { owned }
|
||||
IsVarParam: Boolean; { set by uSemantic — True if target is a var parameter }
|
||||
ResolvedLhsType: TTypeDesc; { set by uSemantic — type of the target variable }
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
|
|
@ -255,10 +256,19 @@ type
|
|||
end;
|
||||
|
||||
TClassTypeDef = class(TASTTypeDef)
|
||||
public
|
||||
ParentName: string;
|
||||
ImplementsNames: TStringList; { owned — names of implemented interfaces }
|
||||
Fields: TObjectList; { owned TFieldDecl }
|
||||
Methods: TObjectList; { owned TMethodDecl }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TInterfaceTypeDef = class(TASTTypeDef)
|
||||
public
|
||||
ParentName: string;
|
||||
Fields: TObjectList; { owned TFieldDecl }
|
||||
Methods: TObjectList; { owned TMethodDecl }
|
||||
Methods: TObjectList; { owned TMethodDecl — forward signatures only }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
|
@ -560,14 +570,30 @@ end;
|
|||
constructor TClassTypeDef.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
Fields := TObjectList.Create(True);
|
||||
Methods := TObjectList.Create(True);
|
||||
ImplementsNames := TStringList.Create;
|
||||
Fields := TObjectList.Create(True);
|
||||
Methods := TObjectList.Create(True);
|
||||
end;
|
||||
|
||||
destructor TClassTypeDef.Destroy;
|
||||
begin
|
||||
Methods.Free;
|
||||
Fields.Free;
|
||||
ImplementsNames.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TInterfaceTypeDef }
|
||||
|
||||
constructor TInterfaceTypeDef.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
Methods := TObjectList.Create(True);
|
||||
end;
|
||||
|
||||
destructor TInterfaceTypeDef.Destroy;
|
||||
begin
|
||||
Methods.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,6 +33,7 @@ type
|
|||
procedure EmitTypeInfoDefs(AProg: TProgram);
|
||||
procedure EmitVTableDefs(AProg: TProgram);
|
||||
procedure EmitMethodDefs(AProg: TProgram);
|
||||
procedure EmitInterfaceDefs(AProg: TProgram);
|
||||
procedure EmitMethodDef(const ATypeName: string; AMethod: TMethodDecl);
|
||||
procedure EmitStandaloneDefs(AProg: TProgram);
|
||||
procedure EmitStandaloneDef(ADecl: TMethodDecl);
|
||||
|
|
@ -212,6 +213,15 @@ begin
|
|||
EmitLine(Format(' storel 0, %%_var_%s', [VarName]));
|
||||
end;
|
||||
|
||||
tyInterface:
|
||||
begin
|
||||
{ Interface var = fat pointer: obj slot + itab slot, both nil-init }
|
||||
EmitLine(Format(' %%_var_%s_obj =l alloc8 1', [VarName]));
|
||||
EmitLine(Format(' storel 0, %%_var_%s_obj', [VarName]));
|
||||
EmitLine(Format(' %%_var_%s_itab =l alloc8 1', [VarName]));
|
||||
EmitLine(Format(' storel 0, %%_var_%s_itab', [VarName]));
|
||||
end;
|
||||
|
||||
else
|
||||
raise ECodeGenError.CreateFmt(
|
||||
'Unsupported type kind %d for variable ''%s''',
|
||||
|
|
@ -539,11 +549,28 @@ end;
|
|||
procedure TCodeGenQBE.EmitAssignment(AAssign: TAssignment);
|
||||
var
|
||||
ValTemp, OldTemp, QType, StoreInstr, PtrTemp: string;
|
||||
IntfDesc: TInterfaceTypeDesc;
|
||||
ClassRT: TRecordTypeDesc;
|
||||
ItabName: string;
|
||||
begin
|
||||
if AAssign.Expr.ResolvedType = nil then
|
||||
raise ECodeGenError.CreateFmt(
|
||||
'Expression in assignment to ''%s'' has no resolved type', [AAssign.Name]);
|
||||
|
||||
{ Interface assignment: store obj pointer + itab pointer }
|
||||
if (AAssign.ResolvedLhsType <> nil) and
|
||||
(AAssign.ResolvedLhsType.Kind = tyInterface) and
|
||||
(AAssign.Expr.ResolvedType.Kind = tyClass) then
|
||||
begin
|
||||
IntfDesc := TInterfaceTypeDesc(AAssign.ResolvedLhsType);
|
||||
ClassRT := TRecordTypeDesc(AAssign.Expr.ResolvedType);
|
||||
ItabName := '$itab_' + ClassRT.Name + '_' + IntfDesc.Name;
|
||||
ValTemp := EmitExpr(AAssign.Expr);
|
||||
EmitLine(Format(' storel %s, %%_var_%s_obj', [ValTemp, AAssign.Name]));
|
||||
EmitLine(Format(' storel %s, %%_var_%s_itab', [ItabName, AAssign.Name]));
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if AAssign.IsVarParam then
|
||||
begin
|
||||
{ Var param: load the stored pointer, then store the value through it }
|
||||
|
|
@ -638,7 +665,31 @@ var
|
|||
VTblTemp: string;
|
||||
FPtrTemp: string;
|
||||
SlotOff: Integer;
|
||||
IntfDesc: TInterfaceTypeDesc;
|
||||
begin
|
||||
{ Interface method dispatch: load obj + itab, index by method slot }
|
||||
if (ACall.ResolvedClassType <> nil) and
|
||||
(ACall.ResolvedClassType.Kind = tyInterface) then
|
||||
begin
|
||||
IntfDesc := TInterfaceTypeDesc(ACall.ResolvedClassType);
|
||||
SelfTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l loadl %%_var_%s_obj', [SelfTemp, ACall.ObjectName]));
|
||||
VTblTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l loadl %%_var_%s_itab', [VTblTemp, ACall.ObjectName]));
|
||||
SlotOff := IntfDesc.MethodIndex(ACall.Name) * 8;
|
||||
FPtrTemp := AllocTemp;
|
||||
if SlotOff = 0 then
|
||||
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, VTblTemp]))
|
||||
else
|
||||
begin
|
||||
ArgTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l add %s, %d', [ArgTemp, VTblTemp, SlotOff]));
|
||||
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
|
||||
end;
|
||||
EmitLine(Format(' call %%%s(l %s)', [FPtrTemp, SelfTemp]));
|
||||
Exit;
|
||||
end;
|
||||
|
||||
{ Built-in Free: load Self pointer and call C free() }
|
||||
if (ACall.ResolvedMethod = nil) and SameText(ACall.Name, 'Free') then
|
||||
begin
|
||||
|
|
@ -849,6 +900,55 @@ begin
|
|||
EmitLine('');
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitInterfaceDefs(AProg: TProgram);
|
||||
{ Emit typeinfo blocks for interfaces and itab blocks for class-interface pairs.
|
||||
Interface typeinfo: data $typeinfo_IFoo = { l 0 } (address IS the identity)
|
||||
Itab: data $itab_TFoo_IFoo = { l $TFoo_DoIt, l $TFoo_GetVal }
|
||||
Methods appear in declaration order (itab slot N = interface method N). }
|
||||
var
|
||||
I, J, K: Integer;
|
||||
TD: TTypeDecl;
|
||||
TDesc: TTypeDesc;
|
||||
IntfDesc: TInterfaceTypeDesc;
|
||||
ClassRT: TRecordTypeDesc;
|
||||
ItabLine: string;
|
||||
MethName: string;
|
||||
begin
|
||||
{ Typeinfo blocks for every interface }
|
||||
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
|
||||
begin
|
||||
TD := TTypeDecl(AProg.Block.TypeDecls[I]);
|
||||
if not (TD.Def is TInterfaceTypeDef) then Continue;
|
||||
EmitLine('data $typeinfo_' + TD.Name + ' = { l 0 }');
|
||||
end;
|
||||
|
||||
{ Itab blocks for each (class, interface) pair }
|
||||
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
|
||||
begin
|
||||
TD := TTypeDecl(AProg.Block.TypeDecls[I]);
|
||||
if not (TD.Def is TClassTypeDef) then Continue;
|
||||
TDesc := AProg.SymbolTable.FindType(TD.Name);
|
||||
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
|
||||
ClassRT := TRecordTypeDesc(TDesc);
|
||||
for J := 0 to ClassRT.ImplementsCount - 1 do
|
||||
begin
|
||||
IntfDesc := ClassRT.ImplementsIntfAt(J);
|
||||
ItabLine := 'data $itab_' + TD.Name + '_' + IntfDesc.Name + ' = {';
|
||||
for K := 0 to IntfDesc.MethodCount - 1 do
|
||||
begin
|
||||
MethName := IntfDesc.MethodName(K);
|
||||
if K = 0 then
|
||||
ItabLine := ItabLine + ' l $' + TD.Name + '_' + MethName
|
||||
else
|
||||
ItabLine := ItabLine + ', l $' + TD.Name + '_' + MethName;
|
||||
end;
|
||||
ItabLine := ItabLine + ' }';
|
||||
EmitLine(ItabLine);
|
||||
end;
|
||||
end;
|
||||
EmitLine('');
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitMethodDefs(AProg: TProgram);
|
||||
var
|
||||
I, J: Integer;
|
||||
|
|
@ -1409,6 +1509,7 @@ begin
|
|||
EmitLine('# Source: ' + AProg.Name);
|
||||
EmitLine('');
|
||||
EmitDataSection;
|
||||
EmitInterfaceDefs(AProg);
|
||||
EmitTypeInfoDefs(AProg);
|
||||
EmitVTableDefs(AProg);
|
||||
FOutput.AddStrings(Body);
|
||||
|
|
|
|||
|
|
@ -54,6 +54,7 @@ type
|
|||
procedure ParseTypeDecl(ABlock: TBlock);
|
||||
function ParseRecordDef: TRecordTypeDef;
|
||||
function ParseClassDef: TClassTypeDef;
|
||||
function ParseInterfaceDef: TInterfaceTypeDef;
|
||||
procedure ParseFieldDecl(AFields: TObjectList);
|
||||
function ParseMethodDecl(IsFunction: Boolean): TMethodDecl;
|
||||
procedure ParseParamList(AParams: TObjectList);
|
||||
|
|
@ -228,9 +229,11 @@ begin
|
|||
TD.Def := ParseRecordDef
|
||||
else if Check(tkClass) then
|
||||
TD.Def := ParseClassDef
|
||||
else if Check(tkIntf) then
|
||||
TD.Def := ParseInterfaceDef
|
||||
else
|
||||
raise EParseError.CreateFmt(
|
||||
'Expected ''record'' or ''class'' at line %d col %d',
|
||||
'Expected ''record'', ''class'', or ''interface'' at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Expect(tkSemicolon);
|
||||
ABlock.TypeDecls.Add(TD);
|
||||
|
|
@ -271,6 +274,16 @@ begin
|
|||
[FCurrent.Line, FCurrent.Col]);
|
||||
Result.ParentName := FCurrent.Value;
|
||||
Advance;
|
||||
{ Additional names after a comma are implemented interface names }
|
||||
while Check(tkComma) do
|
||||
begin
|
||||
Advance;
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected interface name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Result.ImplementsNames.Add(FCurrent.Value);
|
||||
Advance;
|
||||
end;
|
||||
Expect(tkRParen);
|
||||
end;
|
||||
while Check(tkIdent) do
|
||||
|
|
@ -289,6 +302,37 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseInterfaceDef: TInterfaceTypeDef;
|
||||
begin
|
||||
Result := TInterfaceTypeDef.Create;
|
||||
try
|
||||
Result.Line := FCurrent.Line;
|
||||
Result.Col := FCurrent.Col;
|
||||
Expect(tkIntf);
|
||||
if Check(tkLParen) then
|
||||
begin
|
||||
Advance;
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected parent interface name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Result.ParentName := FCurrent.Value;
|
||||
Advance;
|
||||
Expect(tkRParen);
|
||||
end;
|
||||
while Check(tkProcedure) or Check(tkFunction) do
|
||||
begin
|
||||
if Check(tkFunction) then
|
||||
Result.Methods.Add(ParseMethodDecl(True))
|
||||
else
|
||||
Result.Methods.Add(ParseMethodDecl(False));
|
||||
end;
|
||||
Expect(tkEnd);
|
||||
except
|
||||
Result.Free;
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseMethodDecl(IsFunction: Boolean): TMethodDecl;
|
||||
begin
|
||||
Result := TMethodDecl.Create;
|
||||
|
|
|
|||
|
|
@ -111,15 +111,26 @@ end;
|
|||
|
||||
procedure TSemanticAnalyser.CheckTypesMatch(AExpected, AActual: TTypeDesc;
|
||||
const AContext: string; ALine, ACol: Integer);
|
||||
var
|
||||
RT: TRecordTypeDesc;
|
||||
I: Integer;
|
||||
begin
|
||||
if AExpected = AActual then
|
||||
Exit;
|
||||
{ nil is compatible with any class type }
|
||||
if (AActual.Kind = tyNil) and (AExpected.Kind = tyClass) then
|
||||
{ nil is compatible with any class or interface type }
|
||||
if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface]) then
|
||||
Exit;
|
||||
{ subtype assignment: TDerived → TBase is allowed }
|
||||
if IsSubtypeOf(AActual, AExpected) then
|
||||
Exit;
|
||||
{ class → interface: allowed when the class implements that interface }
|
||||
if (AExpected.Kind = tyInterface) and (AActual.Kind = tyClass) then
|
||||
begin
|
||||
RT := TRecordTypeDesc(AActual);
|
||||
for I := 0 to RT.ImplementsCount - 1 do
|
||||
if RT.ImplementsIntfAt(I) = AExpected then
|
||||
Exit;
|
||||
end;
|
||||
SemanticError(
|
||||
Format('Type mismatch in %s: expected ''%s'' but got ''%s''',
|
||||
[AContext, AExpected.Name, AActual.Name]),
|
||||
|
|
@ -328,6 +339,7 @@ end;
|
|||
procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock);
|
||||
var
|
||||
I, J, K: Integer;
|
||||
L: Integer;
|
||||
TD: TTypeDecl;
|
||||
FieldList: TObjectList;
|
||||
MethodList: TObjectList;
|
||||
|
|
@ -343,6 +355,10 @@ var
|
|||
Sym: TSymbol;
|
||||
Key: string;
|
||||
FldInfo: TFieldInfo;
|
||||
IntfDesc: TInterfaceTypeDesc;
|
||||
IntfName: string;
|
||||
IntfSym: TSymbol;
|
||||
ITD: TInterfaceTypeDef;
|
||||
begin
|
||||
{ Pass 1 — register all type symbols with empty descriptors.
|
||||
This allows self-referential field types to resolve in pass 2. }
|
||||
|
|
@ -353,9 +369,20 @@ begin
|
|||
RT := FTable.NewRecordType(TD.Name)
|
||||
else if TD.Def is TClassTypeDef then
|
||||
RT := FTable.NewClassType(TD.Name)
|
||||
else if TD.Def is TInterfaceTypeDef then
|
||||
begin
|
||||
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;
|
||||
Continue;
|
||||
end
|
||||
else
|
||||
begin
|
||||
SemanticError('Only record and class type definitions are supported',
|
||||
SemanticError('Only record, class, or interface type definitions are supported',
|
||||
TD.Line, TD.Col);
|
||||
Continue;
|
||||
end;
|
||||
|
|
@ -372,6 +399,30 @@ begin
|
|||
begin
|
||||
TD := TTypeDecl(ABlock.TypeDecls[I]);
|
||||
|
||||
{ Interface types: register methods and resolve optional parent }
|
||||
if TD.Def is TInterfaceTypeDef then
|
||||
begin
|
||||
ITD := TInterfaceTypeDef(TD.Def);
|
||||
IntfSym := FTable.Lookup(TD.Name);
|
||||
IntfDesc := TInterfaceTypeDesc(IntfSym.TypeDesc);
|
||||
if ITD.ParentName <> '' then
|
||||
begin
|
||||
Sym := FTable.Lookup(ITD.ParentName);
|
||||
if (Sym = nil) or not (Sym.TypeDesc is TInterfaceTypeDesc) then
|
||||
SemanticError(
|
||||
Format('Unknown parent interface ''%s'' for ''%s''',
|
||||
[ITD.ParentName, TD.Name]),
|
||||
TD.Line, TD.Col);
|
||||
IntfDesc.Parent := TInterfaceTypeDesc(Sym.TypeDesc);
|
||||
{ Inherit parent methods }
|
||||
for J := 0 to IntfDesc.Parent.MethodCount - 1 do
|
||||
IntfDesc.AddMethod(IntfDesc.Parent.MethodName(J));
|
||||
end;
|
||||
for J := 0 to ITD.Methods.Count - 1 do
|
||||
IntfDesc.AddMethod(TMethodDecl(ITD.Methods[J]).Name);
|
||||
Continue;
|
||||
end;
|
||||
|
||||
Sym := FTable.Lookup(TD.Name);
|
||||
RT := TRecordTypeDesc(Sym.TypeDesc);
|
||||
|
||||
|
|
@ -479,6 +530,42 @@ begin
|
|||
MDecl.ResolvedReturnType := ParType;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ Verify class implements all methods of each declared interface }
|
||||
if TD.Def is TClassTypeDef then
|
||||
for L := 0 to TClassTypeDef(TD.Def).ImplementsNames.Count - 1 do
|
||||
begin
|
||||
IntfName := TClassTypeDef(TD.Def).ImplementsNames[L];
|
||||
IntfSym := FTable.Lookup(IntfName);
|
||||
if (IntfSym = nil) or not (IntfSym.TypeDesc is TInterfaceTypeDesc) then
|
||||
SemanticError(
|
||||
Format('Unknown interface ''%s'' in implements list of ''%s''',
|
||||
[IntfName, TD.Name]),
|
||||
TD.Line, TD.Col);
|
||||
IntfDesc := TInterfaceTypeDesc(IntfSym.TypeDesc);
|
||||
RT.AddImplements(IntfDesc);
|
||||
for J := 0 to IntfDesc.MethodCount - 1 do
|
||||
begin
|
||||
Key := IntfDesc.MethodName(J);
|
||||
if RT.FindField(Key) = nil then
|
||||
begin
|
||||
{ Check method exists in class — search method list }
|
||||
MDecl := nil;
|
||||
if TD.Def is TClassTypeDef then
|
||||
for K := 0 to TClassTypeDef(TD.Def).Methods.Count - 1 do
|
||||
if SameText(TMethodDecl(TClassTypeDef(TD.Def).Methods[K]).Name, Key) then
|
||||
begin
|
||||
MDecl := TMethodDecl(TClassTypeDef(TD.Def).Methods[K]);
|
||||
Break;
|
||||
end;
|
||||
if MDecl = nil then
|
||||
SemanticError(
|
||||
Format('Class ''%s'' does not implement method ''%s'' from interface ''%s''',
|
||||
[TD.Name, Key, IntfName]),
|
||||
TD.Line, TD.Col);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
|
@ -875,11 +962,25 @@ begin
|
|||
SemanticError(
|
||||
Format('''%s'' is not a variable', [ACall.ObjectName]),
|
||||
ACall.Line, ACall.Col);
|
||||
if ObjSym.TypeDesc.Kind <> tyClass then
|
||||
if not (ObjSym.TypeDesc.Kind in [tyClass, tyInterface]) then
|
||||
SemanticError(
|
||||
Format('''%s'' is not a class variable', [ACall.ObjectName]),
|
||||
Format('''%s'' is not a class or interface variable', [ACall.ObjectName]),
|
||||
ACall.Line, ACall.Col);
|
||||
|
||||
{ Interface method call: look up method in interface type descriptor }
|
||||
if ObjSym.TypeDesc.Kind = tyInterface then
|
||||
begin
|
||||
if not TInterfaceTypeDesc(ObjSym.TypeDesc).HasMethod(ACall.Name) then
|
||||
SemanticError(
|
||||
Format('Interface ''%s'' has no method ''%s''',
|
||||
[ObjSym.TypeDesc.Name, ACall.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
{ Args for interface methods not checked in Phase 3 (no param info stored) }
|
||||
ACall.ResolvedClassType := ObjSym.TypeDesc;
|
||||
ACall.ResolvedMethod := nil; { nil = interface dispatch, not class dispatch }
|
||||
Exit;
|
||||
end;
|
||||
|
||||
RT := TRecordTypeDesc(ObjSym.TypeDesc);
|
||||
MDecl := FindMethodDecl(RT.Name, ACall.Name);
|
||||
if MDecl = nil then
|
||||
|
|
@ -930,7 +1031,8 @@ begin
|
|||
Format('''%s'' is not a variable', [AAssign.Name]),
|
||||
AAssign.Line, AAssign.Col);
|
||||
|
||||
AAssign.IsVarParam := (VarSym.Kind = skVarParameter);
|
||||
AAssign.IsVarParam := (VarSym.Kind = skVarParameter);
|
||||
AAssign.ResolvedLhsType := VarSym.TypeDesc;
|
||||
|
||||
ExprType := AnalyseExpr(AAssign.Expr);
|
||||
CheckTypesMatch(VarSym.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col);
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ type
|
|||
tyString, { ARC-managed UTF-8 string }
|
||||
tyRecord, { Stack-allocated aggregate (Phase 2) }
|
||||
tyClass, { Heap-allocated, single-inheritance (Phase 2) }
|
||||
tyInterface, { Zero-GUID interface reference (Phase 3) }
|
||||
tyVoid, { No value — used as procedure return type }
|
||||
tyNil { Pseudo-type for the nil literal; compatible with tyClass }
|
||||
);
|
||||
|
|
@ -55,13 +56,16 @@ type
|
|||
ImplName: string; { fully-qualified QBE label, e.g. $TDog_Speak }
|
||||
end;
|
||||
|
||||
TInterfaceTypeDesc = class; { forward }
|
||||
|
||||
{ Extended type descriptor for record types. }
|
||||
TRecordTypeDesc = class(TTypeDesc)
|
||||
private
|
||||
FFields: TObjectList; { owned TFieldInfo }
|
||||
FKeys: TStringList; { sorted, case-insensitive; Objects[] = TFieldInfo (not owned) }
|
||||
FParent: TRecordTypeDesc; { not owned; nil for root classes }
|
||||
FVTable: TObjectList; { owned TVTableEntry; nil if no virtual methods }
|
||||
FFields: TObjectList; { owned TFieldInfo }
|
||||
FKeys: TStringList; { sorted, case-insensitive; Objects[] = TFieldInfo (not owned) }
|
||||
FParent: TRecordTypeDesc; { not owned; nil for root classes }
|
||||
FVTable: TObjectList; { owned TVTableEntry; nil if no virtual methods }
|
||||
FImplements: TObjectList; { not owned — TInterfaceTypeDesc references }
|
||||
public
|
||||
constructor Create(const AName: string; AKind: TTypeKind = tyRecord);
|
||||
destructor Destroy; override;
|
||||
|
|
@ -75,17 +79,35 @@ type
|
|||
function VTableCount: Integer;
|
||||
function VTableEntryAt(ASlot: Integer): TVTableEntry;
|
||||
function FindVTableSlot(const AMethodName: string): Integer;
|
||||
{ Assigns a new slot for a virtual method; returns the slot index. }
|
||||
function AddVTableSlot(const AMethodName, AImplName: string): Integer;
|
||||
{ Overrides an existing slot (for 'override' declarations). }
|
||||
procedure OverrideVTableSlot(ASlot: Integer; const AImplName: string);
|
||||
{ Copies all vtable entries from the parent (called during class analysis). }
|
||||
procedure CopyVTableFrom(AParent: TRecordTypeDesc);
|
||||
|
||||
{ Interface implements tracking }
|
||||
procedure AddImplements(AIntf: TInterfaceTypeDesc);
|
||||
function ImplementsCount: Integer;
|
||||
function ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc;
|
||||
|
||||
property Fields: TObjectList read FFields;
|
||||
property Parent: TRecordTypeDesc read FParent write FParent;
|
||||
end;
|
||||
|
||||
{ Type descriptor for zero-GUID interface types (Phase 3). }
|
||||
TInterfaceTypeDesc = class(TTypeDesc)
|
||||
private
|
||||
FMethods: TStringList; { method names, case-insensitive sorted }
|
||||
FParent: TInterfaceTypeDesc; { not owned; nil if no parent }
|
||||
public
|
||||
constructor Create(const AName: string);
|
||||
destructor Destroy; override;
|
||||
procedure AddMethod(const AName: string);
|
||||
function HasMethod(const AName: string): Boolean;
|
||||
function MethodCount: Integer;
|
||||
function MethodName(AIndex: Integer): string;
|
||||
function MethodIndex(const AName: string): Integer;
|
||||
property Parent: TInterfaceTypeDesc read FParent write FParent;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Symbols }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
@ -182,6 +204,9 @@ type
|
|||
{ Creates a new class type descriptor (tyClass, heap-allocated). }
|
||||
function NewClassType(const AName: string): TRecordTypeDesc;
|
||||
|
||||
{ Creates a new interface type descriptor (tyInterface). }
|
||||
function NewInterfaceType(const AName: string): TInterfaceTypeDesc;
|
||||
|
||||
{ Convenience type accessors }
|
||||
property TypeInteger: TTypeDesc read FTypeInteger;
|
||||
property TypeInt64: TTypeDesc read FTypeInt64;
|
||||
|
|
@ -252,18 +277,20 @@ end;
|
|||
constructor TRecordTypeDesc.Create(const AName: string; AKind: TTypeKind = tyRecord);
|
||||
begin
|
||||
inherited Create;
|
||||
Kind := AKind;
|
||||
Name := AName;
|
||||
FFields := TObjectList.Create(True);
|
||||
FKeys := TStringList.Create;
|
||||
Kind := AKind;
|
||||
Name := AName;
|
||||
FFields := TObjectList.Create(True);
|
||||
FKeys := TStringList.Create;
|
||||
FKeys.Sorted := True;
|
||||
FKeys.CaseSensitive := False;
|
||||
FKeys.Duplicates := dupIgnore;
|
||||
FVTable := nil; { allocated on first use }
|
||||
FVTable := nil; { allocated on first use }
|
||||
FImplements := TObjectList.Create(False); { not owned }
|
||||
end;
|
||||
|
||||
destructor TRecordTypeDesc.Destroy;
|
||||
begin
|
||||
FImplements.Free;
|
||||
FKeys.Free;
|
||||
FFields.Free;
|
||||
FVTable.Free;
|
||||
|
|
@ -381,6 +408,21 @@ begin
|
|||
TVTableEntry(FVTable[ASlot]).ImplName := AImplName;
|
||||
end;
|
||||
|
||||
procedure TRecordTypeDesc.AddImplements(AIntf: TInterfaceTypeDesc);
|
||||
begin
|
||||
FImplements.Add(AIntf);
|
||||
end;
|
||||
|
||||
function TRecordTypeDesc.ImplementsCount: Integer;
|
||||
begin
|
||||
Result := FImplements.Count;
|
||||
end;
|
||||
|
||||
function TRecordTypeDesc.ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc;
|
||||
begin
|
||||
Result := TInterfaceTypeDesc(FImplements[AIndex]);
|
||||
end;
|
||||
|
||||
procedure TRecordTypeDesc.CopyVTableFrom(AParent: TRecordTypeDesc);
|
||||
var
|
||||
I: Integer;
|
||||
|
|
@ -400,6 +442,51 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TInterfaceTypeDesc }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
constructor TInterfaceTypeDesc.Create(const AName: string);
|
||||
begin
|
||||
inherited Create;
|
||||
Kind := tyInterface;
|
||||
Name := AName;
|
||||
FMethods := TStringList.Create;
|
||||
FMethods.CaseSensitive := False; { unsorted — preserves declaration order }
|
||||
FParent := nil;
|
||||
end;
|
||||
|
||||
destructor TInterfaceTypeDesc.Destroy;
|
||||
begin
|
||||
FMethods.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTypeDesc.AddMethod(const AName: string);
|
||||
begin
|
||||
FMethods.Add(AName);
|
||||
end;
|
||||
|
||||
function TInterfaceTypeDesc.HasMethod(const AName: string): Boolean;
|
||||
begin
|
||||
Result := FMethods.IndexOf(AName) >= 0;
|
||||
end;
|
||||
|
||||
function TInterfaceTypeDesc.MethodCount: Integer;
|
||||
begin
|
||||
Result := FMethods.Count;
|
||||
end;
|
||||
|
||||
function TInterfaceTypeDesc.MethodName(AIndex: Integer): string;
|
||||
begin
|
||||
Result := FMethods[AIndex];
|
||||
end;
|
||||
|
||||
function TInterfaceTypeDesc.MethodIndex(const AName: string): Integer;
|
||||
begin
|
||||
Result := FMethods.IndexOf(AName);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ TSymbol }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
@ -522,6 +609,12 @@ begin
|
|||
FAllTypes.Add(Result);
|
||||
end;
|
||||
|
||||
function TSymbolTable.NewInterfaceType(const AName: string): TInterfaceTypeDesc;
|
||||
begin
|
||||
Result := TInterfaceTypeDesc.Create(AName);
|
||||
FAllTypes.Add(Result);
|
||||
end;
|
||||
|
||||
procedure TSymbolTable.RegisterBuiltins;
|
||||
var
|
||||
Sym: TSymbol;
|
||||
|
|
@ -544,6 +637,9 @@ begin
|
|||
Define(TSymbol.Create('Boolean', skType, FTypeBoolean));
|
||||
Define(TSymbol.Create('string', skType, FTypeString));
|
||||
|
||||
{ TObject — root of the class hierarchy; no fields, no parent }
|
||||
Define(TSymbol.Create('TObject', skType, NewClassType('TObject')));
|
||||
|
||||
{ Built-in I/O procedures }
|
||||
Sym := TSymbol.Create('Write', skProcedure, nil);
|
||||
Define(Sym);
|
||||
|
|
|
|||
|
|
@ -28,7 +28,8 @@ uses
|
|||
cp.test.units,
|
||||
cp.test.varparams,
|
||||
cp.test.vtable,
|
||||
cp.test.typetests;
|
||||
cp.test.typetests,
|
||||
cp.test.interfaces;
|
||||
|
||||
var
|
||||
Application: TTestRunner;
|
||||
|
|
|
|||
428
compiler/src/test/pascal/cp.test.interfaces.pas
Normal file
428
compiler/src/test/pascal/cp.test.interfaces.pas
Normal file
|
|
@ -0,0 +1,428 @@
|
|||
unit cp.test.interfaces;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, StrUtils, fpcunit, testregistry,
|
||||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||
|
||||
type
|
||||
TInterfaceTests = 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
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_Interface_Empty;
|
||||
procedure TestParse_Interface_WithMethods;
|
||||
procedure TestParse_Interface_WithParent;
|
||||
procedure TestParse_Class_ImplementsInterface;
|
||||
procedure TestParse_Class_ImplementsMultiple;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_Interface_Registered;
|
||||
procedure TestSemantic_Interface_IsInterfaceKind;
|
||||
procedure TestSemantic_Interface_MethodsRegistered;
|
||||
procedure TestSemantic_ClassImplements_OK;
|
||||
procedure TestSemantic_ClassImplements_MissingMethod_RaisesError;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Code generation }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_Interface_TypeInfo_Emitted;
|
||||
procedure TestCodegen_Class_Itab_Emitted;
|
||||
procedure TestCodegen_Itab_ContainsMethodPointer;
|
||||
procedure TestCodegen_InterfaceVar_AllocsTwoSlots;
|
||||
procedure TestCodegen_InterfaceMethodCall_IndirectDispatch;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
const
|
||||
SrcInterfaceEmpty =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IFoo = interface' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcInterfaceWithMethods =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IFoo = interface' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' function GetVal: Integer;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcInterfaceWithParent =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IBase = interface' + LineEnding +
|
||||
' procedure Base;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' IChild = interface(IBase)' + LineEnding +
|
||||
' procedure Child;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcClassImplements =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IFoo = interface' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' function GetVal: Integer;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' TFoo = class(TObject, IFoo)' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' function GetVal: Integer;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'procedure TFoo.DoIt;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end;' + LineEnding +
|
||||
'function TFoo.GetVal: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' Result := 42' + LineEnding +
|
||||
'end;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcClassImplementsMultiple =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IFoo = interface' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' IBar = interface' + LineEnding +
|
||||
' procedure DoBar;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' TFoo = class(TObject, IFoo, IBar)' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' procedure DoBar;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'procedure TFoo.DoIt;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end;' + LineEnding +
|
||||
'procedure TFoo.DoBar;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcClassMissingMethod =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IFoo = interface' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' TFoo = class(TObject, IFoo)' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcInterfaceVar =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' IFoo = interface' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' TFoo = class(TObject, IFoo)' + LineEnding +
|
||||
' procedure DoIt;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'procedure TFoo.DoIt;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
'end;' + LineEnding +
|
||||
'var' + LineEnding +
|
||||
' F: IFoo;' + LineEnding +
|
||||
' T: TFoo;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' T := TFoo.Create;' + LineEnding +
|
||||
' F := T;' + LineEnding +
|
||||
' F.DoIt' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Helpers }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
function TInterfaceTests.ParseSrc(const ASrc: string): TProgram;
|
||||
var
|
||||
L: TLexer;
|
||||
P: TParser;
|
||||
begin
|
||||
L := TLexer.Create(ASrc);
|
||||
P := TParser.Create(L);
|
||||
try
|
||||
Result := P.Parse;
|
||||
finally
|
||||
P.Free;
|
||||
L.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TInterfaceTests.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 TInterfaceTests.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 TInterfaceTests.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;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TInterfaceTests.TestParse_Interface_Empty;
|
||||
var
|
||||
Prog: TProgram;
|
||||
TD: TTypeDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcInterfaceEmpty);
|
||||
try
|
||||
AssertEquals('one type decl', 1, Prog.Block.TypeDecls.Count);
|
||||
TD := TTypeDecl(Prog.Block.TypeDecls[0]);
|
||||
AssertEquals('name is IFoo', 'IFoo', TD.Name);
|
||||
AssertTrue('def is TInterfaceTypeDef', TD.Def is TInterfaceTypeDef);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestParse_Interface_WithMethods;
|
||||
var
|
||||
Prog: TProgram;
|
||||
ITD: TInterfaceTypeDef;
|
||||
begin
|
||||
Prog := ParseSrc(SrcInterfaceWithMethods);
|
||||
try
|
||||
ITD := TInterfaceTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
AssertEquals('two methods', 2, ITD.Methods.Count);
|
||||
AssertEquals('first method DoIt', 'DoIt', TMethodDecl(ITD.Methods[0]).Name);
|
||||
AssertEquals('second method GetVal','GetVal', TMethodDecl(ITD.Methods[1]).Name);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestParse_Interface_WithParent;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Child: TInterfaceTypeDef;
|
||||
begin
|
||||
Prog := ParseSrc(SrcInterfaceWithParent);
|
||||
try
|
||||
Child := TInterfaceTypeDef(TTypeDecl(Prog.Block.TypeDecls[1]).Def);
|
||||
AssertEquals('parent is IBase', 'IBase', Child.ParentName);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestParse_Class_ImplementsInterface;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
begin
|
||||
Prog := ParseSrc(SrcClassImplements);
|
||||
try
|
||||
{ type decl index 0 = IFoo, index 1 = TFoo }
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[1]).Def);
|
||||
AssertEquals('one implements name', 1, CD.ImplementsNames.Count);
|
||||
AssertEquals('implements IFoo', 'IFoo', CD.ImplementsNames[0]);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestParse_Class_ImplementsMultiple;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
begin
|
||||
Prog := ParseSrc(SrcClassImplementsMultiple);
|
||||
try
|
||||
{ type decl indices 0=IFoo, 1=IBar, 2=TFoo }
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[2]).Def);
|
||||
AssertEquals('two implements names', 2, CD.ImplementsNames.Count);
|
||||
AssertEquals('first is IFoo', 'IFoo', CD.ImplementsNames[0]);
|
||||
AssertEquals('second is IBar', 'IBar', CD.ImplementsNames[1]);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TInterfaceTests.TestSemantic_Interface_Registered;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Sym: TSymbol;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcInterfaceWithMethods);
|
||||
try
|
||||
Sym := Prog.SymbolTable.Lookup('IFoo');
|
||||
AssertNotNull('IFoo symbol exists', Sym);
|
||||
AssertEquals('IFoo is skType', Ord(skType), Ord(Sym.Kind));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestSemantic_Interface_IsInterfaceKind;
|
||||
var
|
||||
Prog: TProgram;
|
||||
TD: TTypeDesc;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcInterfaceWithMethods);
|
||||
try
|
||||
TD := Prog.SymbolTable.FindType('IFoo');
|
||||
AssertNotNull('IFoo type exists', TD);
|
||||
AssertEquals('kind is tyInterface', Ord(tyInterface), Ord(TD.Kind));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestSemantic_Interface_MethodsRegistered;
|
||||
var
|
||||
Prog: TProgram;
|
||||
ITD: TInterfaceTypeDesc;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcInterfaceWithMethods);
|
||||
try
|
||||
ITD := TInterfaceTypeDesc(Prog.SymbolTable.FindType('IFoo'));
|
||||
AssertTrue('has DoIt', ITD.HasMethod('DoIt'));
|
||||
AssertTrue('has GetVal', ITD.HasMethod('GetVal'));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestSemantic_ClassImplements_OK;
|
||||
var
|
||||
Prog: TProgram;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcClassImplements);
|
||||
try
|
||||
{ No exception = success }
|
||||
AssertNotNull('prog not nil', Prog);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestSemantic_ClassImplements_MissingMethod_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(SrcClassMissingMethod);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TInterfaceTests.TestCodegen_Interface_TypeInfo_Emitted;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcClassImplements);
|
||||
AssertTrue('typeinfo_IFoo in IR', Pos('$typeinfo_IFoo', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestCodegen_Class_Itab_Emitted;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcClassImplements);
|
||||
AssertTrue('itab_TFoo_IFoo in IR', Pos('$itab_TFoo_IFoo', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestCodegen_Itab_ContainsMethodPointer;
|
||||
var
|
||||
IR: string;
|
||||
ItabPos: Integer;
|
||||
begin
|
||||
IR := GenIR(SrcClassImplements);
|
||||
ItabPos := Pos('$itab_TFoo_IFoo', IR);
|
||||
AssertTrue('itab present', ItabPos > 0);
|
||||
AssertTrue('TFoo_DoIt appears after itab label',
|
||||
PosEx('$TFoo_DoIt', IR, ItabPos) > 0);
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestCodegen_InterfaceVar_AllocsTwoSlots;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcInterfaceVar);
|
||||
AssertTrue('obj slot for F', Pos('_var_F_obj', IR) > 0);
|
||||
AssertTrue('itab slot for F', Pos('_var_F_itab', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TInterfaceTests.TestCodegen_InterfaceMethodCall_IndirectDispatch;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcInterfaceVar);
|
||||
{ Interface dispatch loads the itab pointer and calls indirectly }
|
||||
AssertTrue('loads itab pointer', Pos('_var_F_itab', IR) > 0);
|
||||
AssertTrue('indirect call via register', Pos('call %', IR) > 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TInterfaceTests);
|
||||
|
||||
end.
|
||||
|
|
@ -583,6 +583,9 @@ These are not open for reconsideration:
|
|||
| Hello World compiles to a native binary via PasBuild
|
||||
| Phase 1
|
||||
|
||||
| A non-trivial Linked-List program using TObject descendants.
|
||||
| Phase 2
|
||||
|
||||
| A real library (generic list, hash map) compiles and passes tests
|
||||
| Phase 3
|
||||
|
||||
|
|
@ -715,50 +718,57 @@ are required for correct generic type bounds).
|
|||
| Item | Status | Notes
|
||||
|
||||
| Interface declaration parsing
|
||||
| Pending
|
||||
| Done
|
||||
| `type IFoo = interface ... end;` — methods only, no fields;
|
||||
`interface(IParent)` for inheritance; `['{GUID}']` attribute silently ignored
|
||||
(zero-GUID design)
|
||||
(zero-GUID design); `TInterfaceTypeDef` AST node; `tkIntf` token reused from
|
||||
unit interface section (context disambiguates)
|
||||
|
||||
| TYPEID generation
|
||||
| Pending
|
||||
| `TYPEID = CRC32(UnitName + '.' + InterfaceName)` emitted as a data constant;
|
||||
used for interface identity checks at runtime
|
||||
| Done
|
||||
| `data $typeinfo_IFoo = { l 0 }` — address of block IS the identity token;
|
||||
emitted by `EmitInterfaceDefs`; used for future `is`/`as` interface checks
|
||||
|
||||
| Interface type in symbol table
|
||||
| Pending
|
||||
| `TInterfaceTypeDesc` alongside `TRecordTypeDesc`; method signature storage;
|
||||
`implements` relationship on class types
|
||||
| Done
|
||||
| `TInterfaceTypeDesc` (tyInterface) alongside `TRecordTypeDesc`; methods stored
|
||||
in declaration order (unsorted list for correct itab indexing);
|
||||
`FImplements` non-owning list on `TRecordTypeDesc` tracks class→interface pairs;
|
||||
`TObject` pre-registered as built-in root class
|
||||
|
||||
| Semantic: class implements interface
|
||||
| Pending
|
||||
| Verify all interface methods are present on the class with matching signatures;
|
||||
record `implements` list on `TRecordTypeDesc` for codegen
|
||||
| Done
|
||||
| Parser parses `class(TBase, IFoo, IBar)` — first name = parent class, rest =
|
||||
interfaces; semantic pass verifies all interface methods exist on the class;
|
||||
`CheckTypesMatch` extended to allow class→interface assignment when class
|
||||
implements that interface
|
||||
|
||||
| Interface vtable (itab) generation
|
||||
| Pending
|
||||
| Per `(class, interface)` pair: `data $itab_TFoo_IBar = { l $TFoo_Method, ... }`;
|
||||
itab pointer stored as a hidden field alongside the object pointer in interface
|
||||
variable slots
|
||||
| Done
|
||||
| `data $itab_TFoo_IFoo = { l $TFoo_DoIt, ... }` emitted by `EmitInterfaceDefs`;
|
||||
method order matches interface declaration order; one itab per (class, interface)
|
||||
pair
|
||||
|
||||
| Interface variable assignment
|
||||
| Pending
|
||||
| Assigning a class instance to an interface variable loads the matching itab;
|
||||
ARC addref/release on interface variables (same RC string rules)
|
||||
| Done
|
||||
| Interface var = fat pointer: `%_var_F_obj` + `%_var_F_itab` (two alloc8 slots);
|
||||
assignment stores obj pointer and itab address; ARC on interface refs deferred
|
||||
(Phase 3 follow-up)
|
||||
|
||||
| Interface method dispatch
|
||||
| Pending
|
||||
| Load itab pointer from interface var slot; index into itab by method slot;
|
||||
indirect `call %fptr(l obj, ...)` — similar to virtual method dispatch
|
||||
| Done
|
||||
| Load obj from `%_var_F_obj`, load itab from `%_var_F_itab`; index by method
|
||||
slot (slot × 8); indirect `call %fptr(l obj)` — same pattern as virtual dispatch
|
||||
|
||||
| `as` cast to interface
|
||||
| Pending
|
||||
| Checked downcast: verify class implements interface via TYPEID lookup;
|
||||
| Checked downcast: verify class implements interface via typeinfo pointer walk;
|
||||
raise `EInvalidCast` on failure
|
||||
|
||||
| `is` test against interface
|
||||
| Pending
|
||||
| Runtime check: walk class `implements` list for matching TYPEID; return boolean
|
||||
| Runtime check: walk class `implements` list for matching typeinfo pointer;
|
||||
return boolean
|
||||
|
||||
| RTL: `IInterface` base
|
||||
| Pending
|
||||
|
|
|
|||
Loading…
Reference in a new issue