diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index e7e6d09..98658d2 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -274,6 +274,15 @@ type destructor Destroy; override; end; + TUnit = class(TASTNode) + public + Name: string; + IntfBlock: TBlock; { owned — forward decls + type decls } + ImplBlock: TBlock; { owned — full implementations } + constructor Create; + destructor Destroy; override; + end; + function BinaryOpName(AOp: TBinaryOp): string; function IsComparisonOp(AOp: TBinaryOp): Boolean; @@ -569,4 +578,20 @@ begin inherited Destroy; end; +{ TUnit } + +constructor TUnit.Create; +begin + inherited Create; + IntfBlock := TBlock.Create; + ImplBlock := TBlock.Create; +end; + +destructor TUnit.Destroy; +begin + IntfBlock.Free; + ImplBlock.Free; + inherited Destroy; +end; + end. diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 92e1907..58cf2ca 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -33,6 +33,7 @@ type procedure EmitMethodDef(const ATypeName: string; AMethod: TMethodDecl); procedure EmitStandaloneDefs(AProg: TProgram); procedure EmitStandaloneDef(ADecl: TMethodDecl); + procedure EmitFuncDef(ADecl: TMethodDecl; AExported: Boolean); procedure EmitBlock(ABlock: TBlock); procedure EmitVarAllocs(ABlock: TBlock); procedure EmitParamAllocs(AMethod: TMethodDecl; AClassType: TRecordTypeDesc); @@ -58,6 +59,7 @@ type constructor Create; destructor Destroy; override; procedure Generate(AProg: TProgram); + procedure GenerateUnit(AUnit: TUnit); function GetOutput: string; end; @@ -680,7 +682,7 @@ begin end; end; -procedure TCodeGenQBE.EmitStandaloneDef(ADecl: TMethodDecl); +procedure TCodeGenQBE.EmitFuncDef(ADecl: TMethodDecl; AExported: Boolean); var Sig: string; I: Integer; @@ -689,11 +691,12 @@ var IsFunc: Boolean; RetQType: string; RetTemp: string; + Prefix: string; begin FuncName := '$' + ADecl.Name; IsFunc := ADecl.ResolvedReturnType <> nil; + if AExported then Prefix := 'export ' else Prefix := ''; - { Build parameter signature: [qtype %_par_Name ...] } Sig := ''; for I := 0 to ADecl.Params.Count - 1 do begin @@ -705,14 +708,13 @@ begin if IsFunc then begin RetQType := QbeTypeOf(ADecl.ResolvedReturnType); - EmitLine(Format('function %s %s(%s) {', [RetQType, FuncName, Sig])); + EmitLine(Format('%sfunction %s %s(%s) {', [Prefix, RetQType, FuncName, Sig])); end else - EmitLine(Format('function %s(%s) {', [FuncName, Sig])); + EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig])); EmitLine('@start'); - { Spill explicit params into local slots } for I := 0 to ADecl.Params.Count - 1 do begin Par := TMethodParam(ADecl.Params[I]); @@ -730,7 +732,6 @@ begin end; end; - { For functions, allocate zero-initialised Result slot } if IsFunc then begin if RetQType = 'w' then @@ -763,6 +764,11 @@ begin EmitLine(''); end; +procedure TCodeGenQBE.EmitStandaloneDef(ADecl: TMethodDecl); +begin + EmitFuncDef(ADecl, False); +end; + procedure TCodeGenQBE.EmitStandaloneDefs(AProg: TProgram); var I: Integer; @@ -1088,6 +1094,52 @@ begin end; end; +procedure TCodeGenQBE.GenerateUnit(AUnit: TUnit); +var + I: Integer; + ImplDecl: TMethodDecl; + IntfNames: TStringList; + Body: TStringList; + SavedOut: TStringList; +begin + FOutput.Clear; + FStrLits.Clear; + FTempCount := 0; + FLabelCount := 0; + + IntfNames := TStringList.Create; + try + IntfNames.CaseSensitive := False; + for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do + IntfNames.Add(TMethodDecl(AUnit.IntfBlock.ProcDecls[I]).Name); + + Body := TStringList.Create; + try + SavedOut := FOutput; + FOutput := Body; + try + for I := 0 to AUnit.ImplBlock.ProcDecls.Count - 1 do + begin + ImplDecl := TMethodDecl(AUnit.ImplBlock.ProcDecls[I]); + EmitFuncDef(ImplDecl, IntfNames.IndexOf(ImplDecl.Name) >= 0); + end; + finally + FOutput := SavedOut; + end; + + EmitLine('# Generated by Blaise Compiler (Phase 2)'); + EmitLine('# Unit: ' + AUnit.Name); + EmitLine(''); + EmitDataSection; + FOutput.AddStrings(Body); + finally + Body.Free; + end; + finally + IntfNames.Free; + end; +end; + function TCodeGenQBE.GetOutput: string; begin Result := FOutput.Text; diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index c05ff09..2e7f2ef 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -41,6 +41,9 @@ type tkExcept, tkRaise, tkNil, + tkUnit, + tkIntf, + tkImplementation, { Identifier } tkIdent, { Arithmetic operators } @@ -124,7 +127,10 @@ begin else if AUpper = 'FINALLY' then Result := tkFinally else if AUpper = 'EXCEPT' then Result := tkExcept else if AUpper = 'RAISE' then Result := tkRaise - else if AUpper = 'NIL' then Result := tkNil + else if AUpper = 'NIL' then Result := tkNil + else if AUpper = 'UNIT' then Result := tkUnit + else if AUpper = 'INTERFACE' then Result := tkIntf + else if AUpper = 'IMPLEMENTATION' then Result := tkImplementation else Result := tkIdent; { keyword outside Phase 1 grammar treated as ident } end; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 8b6608c..a8fd3b1 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -67,6 +67,7 @@ type function ParseForStmt: TForStmt; function ParseTryStmt: TASTStmt; function ParseRaiseStmt: TRaiseStmt; + function ParseForwardDecl(IsFunction: Boolean): TMethodDecl; function ParseCompoundStmt: TCompoundStmt; function ParseExpr: TASTExpr; function ParseAddSub: TASTExpr; @@ -77,6 +78,7 @@ type public constructor Create(ALexer: TLexer); function Parse: TProgram; + function ParseUnit: TUnit; end; implementation @@ -839,6 +841,99 @@ begin end; end; +{ ------------------------------------------------------------------ } +{ Unit parsing } +{ ------------------------------------------------------------------ } + +function TParser.ParseForwardDecl(IsFunction: Boolean): TMethodDecl; +begin + Result := TMethodDecl.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + if IsFunction then + Expect(tkFunction) + else + Expect(tkProcedure); + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected name at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + Result.Name := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + Advance; + if not Check(tkRParen) then + ParseParamList(Result.Params); + Expect(tkRParen); + end; + if IsFunction then + begin + Expect(tkColon); + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected return type at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + Result.ReturnTypeName := FCurrent.Value; + Advance; + end; + Expect(tkSemicolon); + { Body remains nil — forward declaration } + except + Result.Free; + raise; + end; +end; + +function TParser.ParseUnit: TUnit; +begin + Result := TUnit.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + + Expect(tkUnit); + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected unit name at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + Result.Name := FCurrent.Value; + Advance; + Expect(tkSemicolon); + + { Interface section } + Expect(tkIntf); + if Check(tkType) then + ParseTypeSection(Result.IntfBlock); + while Check(tkProcedure) or Check(tkFunction) do + begin + if Check(tkFunction) then + Result.IntfBlock.ProcDecls.Add(ParseForwardDecl(True)) + else + Result.IntfBlock.ProcDecls.Add(ParseForwardDecl(False)); + end; + + { Implementation section } + Expect(tkImplementation); + while Check(tkProcedure) or Check(tkFunction) do + begin + if Check(tkFunction) then + Result.ImplBlock.ProcDecls.Add(ParseMethodDecl(True)) + else + Result.ImplBlock.ProcDecls.Add(ParseMethodDecl(False)); + end; + + Expect(tkEnd); + Expect(tkDot); + + if not Check(tkEOF) then + raise EParseError.CreateFmt( + 'Unexpected tokens after unit end at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + except + Result.Free; + raise; + end; +end; + { ------------------------------------------------------------------ } { Expression parsing — standard precedence climbing } { ------------------------------------------------------------------ } diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 037d9a3..bde6ea5 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -56,6 +56,7 @@ type constructor Create; destructor Destroy; override; procedure Analyse(AProg: TProgram); + procedure AnalyseUnit(AUnit: TUnit); end; implementation @@ -107,6 +108,141 @@ begin FTable := nil; end; +procedure TSemanticAnalyser.AnalyseUnit(AUnit: TUnit); +var + I, J: Integer; + MDecl: TMethodDecl; + ImplDecl: TMethodDecl; + ImplIdx: Integer; + Par: TMethodParam; + ParType: TTypeDesc; + Sym: TSymbol; +begin + FTable.PushScope; + try + { Resolve interface type declarations } + AnalyseTypeDecls(AUnit.IntfBlock); + + { Register interface forward declaration signatures } + for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do + begin + MDecl := TMethodDecl(AUnit.IntfBlock.ProcDecls[I]); + + for J := 0 to MDecl.Params.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[J]); + ParType := FTable.FindType(Par.TypeName); + if ParType = nil then + SemanticError( + Format('Unknown type ''%s'' for parameter ''%s''', + [Par.TypeName, Par.ParamName]), + MDecl.Line, MDecl.Col); + Par.ResolvedType := ParType; + end; + + if MDecl.ReturnTypeName <> '' then + begin + ParType := FTable.FindType(MDecl.ReturnTypeName); + if ParType = nil then + SemanticError( + Format('Unknown return type ''%s'' for ''%s''', + [MDecl.ReturnTypeName, MDecl.Name]), + MDecl.Line, MDecl.Col); + MDecl.ResolvedReturnType := ParType; + end; + + FProcIndex.AddObject(MDecl.Name, MDecl); + + if MDecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(MDecl.Name, skFunction, MDecl.ResolvedReturnType) + else + Sym := TSymbol.Create(MDecl.Name, skProcedure, nil); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate identifier ''%s''', [MDecl.Name]), + MDecl.Line, MDecl.Col); + end; + end; + + { Process implementation declarations } + for I := 0 to AUnit.ImplBlock.ProcDecls.Count - 1 do + begin + ImplDecl := TMethodDecl(AUnit.ImplBlock.ProcDecls[I]); + + for J := 0 to ImplDecl.Params.Count - 1 do + begin + Par := TMethodParam(ImplDecl.Params[J]); + ParType := FTable.FindType(Par.TypeName); + if ParType = nil then + SemanticError( + Format('Unknown type ''%s'' for parameter ''%s''', + [Par.TypeName, Par.ParamName]), + ImplDecl.Line, ImplDecl.Col); + Par.ResolvedType := ParType; + end; + + if ImplDecl.ReturnTypeName <> '' then + begin + ParType := FTable.FindType(ImplDecl.ReturnTypeName); + if ParType = nil then + SemanticError( + Format('Unknown return type ''%s'' for ''%s''', + [ImplDecl.ReturnTypeName, ImplDecl.Name]), + ImplDecl.Line, ImplDecl.Col); + ImplDecl.ResolvedReturnType := ParType; + end; + + ImplIdx := FProcIndex.IndexOf(ImplDecl.Name); + if ImplIdx >= 0 then + begin + { Matched an interface forward decl — verify param count } + MDecl := TMethodDecl(FProcIndex.Objects[ImplIdx]); + if MDecl.Params.Count <> ImplDecl.Params.Count then + SemanticError( + Format('Signature mismatch for ''%s'': interface has %d params, implementation has %d', + [ImplDecl.Name, MDecl.Params.Count, ImplDecl.Params.Count]), + ImplDecl.Line, ImplDecl.Col); + { Update index to point to the full implementation } + FProcIndex.Objects[ImplIdx] := ImplDecl; + end + else + begin + { Impl-only declaration — register symbol and index it } + FProcIndex.AddObject(ImplDecl.Name, ImplDecl); + if ImplDecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(ImplDecl.Name, skFunction, ImplDecl.ResolvedReturnType) + else + Sym := TSymbol.Create(ImplDecl.Name, skProcedure, nil); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate identifier ''%s''', [ImplDecl.Name]), + ImplDecl.Line, ImplDecl.Col); + end; + end; + end; + + { Verify every interface declaration has a matching implementation } + for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do + begin + MDecl := TMethodDecl(AUnit.IntfBlock.ProcDecls[I]); + ImplIdx := FProcIndex.IndexOf(MDecl.Name); + if (ImplIdx < 0) or + (TMethodDecl(FProcIndex.Objects[ImplIdx]).Body = nil) then + SemanticError( + Format('Interface function ''%s'' has no implementation', [MDecl.Name]), + MDecl.Line, MDecl.Col); + end; + + { Analyse all implementation bodies } + for I := 0 to AUnit.ImplBlock.ProcDecls.Count - 1 do + AnalyseStandaloneDecl(TMethodDecl(AUnit.ImplBlock.ProcDecls[I])); + finally + FTable.PopScope; + end; +end; + procedure TSemanticAnalyser.AnalyseBlock(ABlock: TBlock); begin { Type declarations are registered in the outer scope so they remain visible diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index b6fdf78..b80380f 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -24,7 +24,8 @@ uses cp.test.control, cp.test.inherit, cp.test.forloop, - cp.test.exceptions; + cp.test.exceptions, + cp.test.units; var Application: TTestRunner; diff --git a/compiler/src/test/pascal/cp.test.units.pas b/compiler/src/test/pascal/cp.test.units.pas new file mode 100644 index 0000000..e3a838f --- /dev/null +++ b/compiler/src/test/pascal/cp.test.units.pas @@ -0,0 +1,400 @@ +unit cp.test.units; + +{$mode objfpc}{$H+} + +{ Tests for unit interface/implementation: parsing, semantic analysis, + and code generation. Cross-unit 'uses' loading is out of scope here. } + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, + uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE; + +type + TUnitTests = class(TTestCase) + private + function ParseUnit(const ASrc: string): TUnit; + function AnalyseUnit(const ASrc: string): TUnit; + function GenUnitIR(const ASrc: string): string; + procedure AnalyseUnitExpectError(const ASrc: string); + published + { ------------------------------------------------------------------ } + { Lexer } + { ------------------------------------------------------------------ } + procedure TestLexer_Unit_Keyword; + procedure TestLexer_Interface_Keyword; + procedure TestLexer_Implementation_Keyword; + + { ------------------------------------------------------------------ } + { Parser — structure } + { ------------------------------------------------------------------ } + procedure TestParse_Unit_IsNotProgram; + procedure TestParse_Unit_Name; + procedure TestParse_Unit_IntfHasForwardDecls; + procedure TestParse_Unit_ForwardDeclHasNilBody; + procedure TestParse_Unit_ImplHasFullBodies; + procedure TestParse_Unit_ImplBodyIsNotNil; + procedure TestParse_Unit_IntfTypeDecl; + procedure TestParse_Unit_ForwardDeclParamCount; + procedure TestParse_Unit_MultipleForwardDecls; + + { ------------------------------------------------------------------ } + { Semantic } + { ------------------------------------------------------------------ } + procedure TestSemantic_Unit_OK; + procedure TestSemantic_Unit_WithType_OK; + procedure TestSemantic_Unit_ImplBodyUsesIntfType; + procedure TestSemantic_Unit_SignatureMismatch_ParamCount_RaisesError; + procedure TestSemantic_Unit_MissingImpl_RaisesError; + procedure TestSemantic_Unit_ImplOnlyDecl_OK; + + { ------------------------------------------------------------------ } + { Codegen } + { ------------------------------------------------------------------ } + procedure TestCodegen_Unit_NoMainFunction; + procedure TestCodegen_Unit_IntfFunctionsExported; + procedure TestCodegen_Unit_FunctionBodyInIR; + procedure TestCodegen_Unit_ImplOnlyFuncNotExported; + procedure TestCodegen_Unit_CorrectArithmetic; + end; + +implementation + +{ ------------------------------------------------------------------ } +{ Helpers } +{ ------------------------------------------------------------------ } + +function TUnitTests.ParseUnit(const ASrc: string): TUnit; +var L: TLexer; P: TParser; +begin + L := TLexer.Create(ASrc); + P := TParser.Create(L); + try + Result := P.ParseUnit; + finally + P.Free; L.Free; + end; +end; + +function TUnitTests.AnalyseUnit(const ASrc: string): TUnit; +var A: TSemanticAnalyser; +begin + Result := ParseUnit(ASrc); + A := TSemanticAnalyser.Create; + try + A.AnalyseUnit(Result); + finally + A.Free; + end; +end; + +function TUnitTests.GenUnitIR(const ASrc: string): string; +var U: TUnit; CG: TCodeGenQBE; +begin + U := AnalyseUnit(ASrc); + try + CG := TCodeGenQBE.Create; + try + CG.GenerateUnit(U); + Result := CG.GetOutput; + finally + CG.Free; + end; + finally + U.Free; + end; +end; + +procedure TUnitTests.AnalyseUnitExpectError(const ASrc: string); +var U: TUnit; +begin + try + U := AnalyseUnit(ASrc); + U.Free; + Fail('Expected ESemanticError'); + except + on E: ESemanticError do ; + end; +end; + +{ ------------------------------------------------------------------ } +{ Shared source snippets } +{ ------------------------------------------------------------------ } + +const + SrcUnitFuncs = + 'unit MathUtils;' + LineEnding + + 'interface' + LineEnding + + 'function Add(A, B: Integer): Integer;' + LineEnding + + 'function Mul(A, B: Integer): Integer;' + LineEnding + + 'implementation' + LineEnding + + 'function Add(A, B: Integer): Integer;' + LineEnding + + 'begin' + LineEnding + + ' Result := A + B' + LineEnding + + 'end;' + LineEnding + + 'function Mul(A, B: Integer): Integer;' + LineEnding + + 'begin' + LineEnding + + ' Result := A * B' + LineEnding + + 'end;' + LineEnding + + 'end.'; + + SrcUnitWithType = + 'unit Shapes;' + LineEnding + + 'interface' + LineEnding + + 'type' + LineEnding + + ' TBox = record' + LineEnding + + ' W: Integer;' + LineEnding + + ' H: Integer;' + LineEnding + + ' end;' + LineEnding + + 'function Area(W, H: Integer): Integer;' + LineEnding + + 'implementation' + LineEnding + + 'function Area(W, H: Integer): Integer;' + LineEnding + + 'begin' + LineEnding + + ' Result := W * H' + LineEnding + + 'end;' + LineEnding + + 'end.'; + + SrcUnitImplOnly = + 'unit Internals;' + LineEnding + + 'interface' + LineEnding + + 'function Pub(X: Integer): Integer;' + LineEnding + + 'implementation' + LineEnding + + 'function Helper(X: Integer): Integer;' + LineEnding + + 'begin' + LineEnding + + ' Result := X + 1' + LineEnding + + 'end;' + LineEnding + + 'function Pub(X: Integer): Integer;' + LineEnding + + 'begin' + LineEnding + + ' Result := Helper(X)' + LineEnding + + 'end;' + LineEnding + + 'end.'; + +{ ------------------------------------------------------------------ } +{ Lexer tests } +{ ------------------------------------------------------------------ } + +procedure TUnitTests.TestLexer_Unit_Keyword; +var L: TLexer; T: TToken; +begin + L := TLexer.Create('unit'); + try + T := L.Next; + AssertEquals('unit token', Ord(tkUnit), Ord(T.Kind)); + finally L.Free; end; +end; + +procedure TUnitTests.TestLexer_Interface_Keyword; +var L: TLexer; T: TToken; +begin + L := TLexer.Create('interface'); + try + T := L.Next; + AssertEquals('interface token', Ord(tkIntf), Ord(T.Kind)); + finally L.Free; end; +end; + +procedure TUnitTests.TestLexer_Implementation_Keyword; +var L: TLexer; T: TToken; +begin + L := TLexer.Create('implementation'); + try + T := L.Next; + AssertEquals('implementation token', Ord(tkImplementation), Ord(T.Kind)); + finally L.Free; end; +end; + +{ ------------------------------------------------------------------ } +{ Parser tests } +{ ------------------------------------------------------------------ } + +procedure TUnitTests.TestParse_Unit_IsNotProgram; +var U: TUnit; +begin + U := ParseUnit(SrcUnitFuncs); + try + AssertNotNull('TUnit returned', U); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_Name; +var U: TUnit; +begin + U := ParseUnit(SrcUnitFuncs); + try + AssertEquals('unit name is MathUtils', 'MathUtils', U.Name); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_IntfHasForwardDecls; +var U: TUnit; +begin + U := ParseUnit(SrcUnitFuncs); + try + AssertEquals('intf has 2 forward decls', 2, U.IntfBlock.ProcDecls.Count); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_ForwardDeclHasNilBody; +var U: TUnit; MD: TMethodDecl; +begin + U := ParseUnit(SrcUnitFuncs); + try + MD := TMethodDecl(U.IntfBlock.ProcDecls[0]); + AssertNull('forward decl body is nil', MD.Body); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_ImplHasFullBodies; +var U: TUnit; +begin + U := ParseUnit(SrcUnitFuncs); + try + AssertEquals('impl has 2 full decls', 2, U.ImplBlock.ProcDecls.Count); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_ImplBodyIsNotNil; +var U: TUnit; MD: TMethodDecl; +begin + U := ParseUnit(SrcUnitFuncs); + try + MD := TMethodDecl(U.ImplBlock.ProcDecls[0]); + AssertNotNull('impl body is not nil', MD.Body); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_IntfTypeDecl; +var U: TUnit; +begin + U := ParseUnit(SrcUnitWithType); + try + AssertEquals('intf has 1 type decl', 1, U.IntfBlock.TypeDecls.Count); + AssertEquals('type name is TBox', + 'TBox', TTypeDecl(U.IntfBlock.TypeDecls[0]).Name); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_ForwardDeclParamCount; +var U: TUnit; MD: TMethodDecl; +begin + U := ParseUnit(SrcUnitFuncs); + try + MD := TMethodDecl(U.IntfBlock.ProcDecls[0]); { Add } + AssertEquals('Add has 2 params', 2, MD.Params.Count); + finally U.Free; end; +end; + +procedure TUnitTests.TestParse_Unit_MultipleForwardDecls; +var U: TUnit; +begin + U := ParseUnit(SrcUnitImplOnly); + try + AssertEquals('intf has 1 forward decl', 1, U.IntfBlock.ProcDecls.Count); + AssertEquals('impl has 2 full decls', 2, U.ImplBlock.ProcDecls.Count); + finally U.Free; end; +end; + +{ ------------------------------------------------------------------ } +{ Semantic tests } +{ ------------------------------------------------------------------ } + +procedure TUnitTests.TestSemantic_Unit_OK; +begin + AnalyseUnit(SrcUnitFuncs).Free; +end; + +procedure TUnitTests.TestSemantic_Unit_WithType_OK; +begin + AnalyseUnit(SrcUnitWithType).Free; +end; + +procedure TUnitTests.TestSemantic_Unit_ImplBodyUsesIntfType; +begin + { TBox is declared in interface; impl body can reference it } + AnalyseUnit(SrcUnitWithType).Free; +end; + +procedure TUnitTests.TestSemantic_Unit_SignatureMismatch_ParamCount_RaisesError; +begin + AnalyseUnitExpectError( + 'unit Bad;' + LineEnding + + 'interface' + LineEnding + + 'function Add(A, B: Integer): Integer;' + LineEnding + + 'implementation' + LineEnding + + 'function Add(A: Integer): Integer;' + LineEnding + { wrong: 1 param } + 'begin' + LineEnding + + ' Result := A' + LineEnding + + 'end;' + LineEnding + + 'end.'); +end; + +procedure TUnitTests.TestSemantic_Unit_MissingImpl_RaisesError; +begin + AnalyseUnitExpectError( + 'unit Bad;' + LineEnding + + 'interface' + LineEnding + + 'function Add(A, B: Integer): Integer;' + LineEnding + + 'implementation' + LineEnding + + 'end.'); { no implementation of Add } +end; + +procedure TUnitTests.TestSemantic_Unit_ImplOnlyDecl_OK; +begin + { Helper is impl-only; Pub calls Helper — both should resolve } + AnalyseUnit(SrcUnitImplOnly).Free; +end; + +{ ------------------------------------------------------------------ } +{ Codegen tests } +{ ------------------------------------------------------------------ } + +procedure TUnitTests.TestCodegen_Unit_NoMainFunction; +var IR: string; +begin + IR := GenUnitIR(SrcUnitFuncs); + AssertFalse('no $main in unit IR', Pos('$main', IR) > 0); +end; + +procedure TUnitTests.TestCodegen_Unit_IntfFunctionsExported; +var IR: string; +begin + IR := GenUnitIR(SrcUnitFuncs); + { Interface-declared functions carry the export keyword } + AssertTrue('export present for Add', Pos('export function', IR) > 0); +end; + +procedure TUnitTests.TestCodegen_Unit_FunctionBodyInIR; +var IR: string; +begin + IR := GenUnitIR(SrcUnitFuncs); + AssertTrue('$Add in IR', Pos('$Add', IR) > 0); + AssertTrue('$Mul in IR', Pos('$Mul', IR) > 0); +end; + +procedure TUnitTests.TestCodegen_Unit_ImplOnlyFuncNotExported; +var IR: string; HelperPos: Integer; ExportPos: Integer; +begin + IR := GenUnitIR(SrcUnitImplOnly); + { Helper is impl-only: its definition must NOT have 'export' prefix. + Pub is interface-declared: it must have 'export'. } + HelperPos := Pos('$Helper', IR); + ExportPos := Pos('export function', IR); + AssertTrue('$Helper present', HelperPos > 0); + { The 'export' keyword must not appear immediately before $Helper } + AssertTrue('$Pub exported', Pos('export function w $Pub', IR) > 0); + AssertFalse('$Helper not exported', Pos('export function w $Helper', IR) > 0); +end; + +procedure TUnitTests.TestCodegen_Unit_CorrectArithmetic; +var IR: string; +begin + IR := GenUnitIR(SrcUnitFuncs); + AssertTrue('add instruction for Add', Pos('add', IR) > 0); + AssertTrue('mul instruction for Mul', Pos('mul', IR) > 0); +end; + +initialization + RegisterTest(TUnitTests); + +end.