diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index b8c554a..9ed814c 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index db9d1cc..b79e77e 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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); diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 709bdbd..55c71a1 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 0d9b561..c4f6afb 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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); diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index 289aee0..9996ea2 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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); diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 97cbc23..70b96f3 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.interfaces.pas b/compiler/src/test/pascal/cp.test.interfaces.pas new file mode 100644 index 0000000..505d097 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.interfaces.pas @@ -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. diff --git a/docs/design.adoc b/docs/design.adoc index 0192ca5..c85cc94 100644 --- a/docs/design.adoc +++ b/docs/design.adoc @@ -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