Add unit interface/implementation: lexer, AST, parser, semantic, codegen
TUnit AST node with IntfBlock/ImplBlock; ParseUnit and ParseForwardDecl; AnalyseUnit with signature verification and missing-impl detection; GenerateUnit with export prefix for interface-declared functions.
This commit is contained in:
Graeme Geldenhuys
parent
90d9ac1ef1
commit
4c6c3d9b2c
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
400
compiler/src/test/pascal/cp.test.units.pas
Normal file
400
compiler/src/test/pascal/cp.test.units.pas
Normal file
|
|
@ -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.
|
||||
Loading…
Reference in a new issue