Add try/finally, try/except, and raise statement support
Adds tkTry/tkFinally/tkExcept/tkRaise tokens, TTryFinallyStmt, TTryExceptStmt, and TRaiseStmt AST nodes, recursive-descent parser for all three forms (bare raise supported), semantic validation (raise requires a class expression), and QBE codegen. try/finally emits both bodies sequentially (simplified; full stack unwinding requires RTL). try/except emits the try body then skips to an except_handler label (reachable via raise dispatch in a future phase). raise emits call $_Raise(l <obj>). 26 new tests in cp.test.exceptions (378 total, all passing).
This commit is contained in:
Graeme Geldenhuys
parent
d7b42180f1
commit
90d9ac1ef1
|
|
@ -106,6 +106,26 @@ type
|
|||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TTryFinallyStmt = class(TASTStmt)
|
||||
public
|
||||
TryBody: TCompoundStmt; { owned }
|
||||
FinallyBody: TCompoundStmt; { owned }
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TTryExceptStmt = class(TASTStmt)
|
||||
public
|
||||
TryBody: TCompoundStmt; { owned }
|
||||
ExceptBody: TCompoundStmt; { owned }
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TRaiseStmt = class(TASTStmt)
|
||||
public
|
||||
Expr: TASTExpr; { owned; nil = bare re-raise }
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TFieldAssignment = class(TASTStmt)
|
||||
public
|
||||
RecordName: string;
|
||||
|
|
@ -325,6 +345,32 @@ begin
|
|||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TTryFinallyStmt }
|
||||
|
||||
destructor TTryFinallyStmt.Destroy;
|
||||
begin
|
||||
TryBody.Free;
|
||||
FinallyBody.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TTryExceptStmt }
|
||||
|
||||
destructor TTryExceptStmt.Destroy;
|
||||
begin
|
||||
TryBody.Free;
|
||||
ExceptBody.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TRaiseStmt }
|
||||
|
||||
destructor TRaiseStmt.Destroy;
|
||||
begin
|
||||
Expr.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TBinaryExpr }
|
||||
|
||||
destructor TBinaryExpr.Destroy;
|
||||
|
|
|
|||
|
|
@ -41,6 +41,9 @@ type
|
|||
procedure EmitIfStmt(AStmt: TIfStmt);
|
||||
procedure EmitWhileStmt(AStmt: TWhileStmt);
|
||||
procedure EmitForStmt(AStmt: TForStmt);
|
||||
procedure EmitTryFinallyStmt(AStmt: TTryFinallyStmt);
|
||||
procedure EmitTryExceptStmt(AStmt: TTryExceptStmt);
|
||||
procedure EmitRaiseStmt(AStmt: TRaiseStmt);
|
||||
procedure EmitCompoundStmt(AStmt: TCompoundStmt);
|
||||
procedure EmitAssignment(AAssign: TAssignment);
|
||||
procedure EmitFieldAssignment(AAssign: TFieldAssignment);
|
||||
|
|
@ -237,7 +240,13 @@ end;
|
|||
|
||||
procedure TCodeGenQBE.EmitStmt(AStmt: TASTStmt);
|
||||
begin
|
||||
if AStmt is TForStmt then
|
||||
if AStmt is TTryFinallyStmt then
|
||||
EmitTryFinallyStmt(TTryFinallyStmt(AStmt))
|
||||
else if AStmt is TTryExceptStmt then
|
||||
EmitTryExceptStmt(TTryExceptStmt(AStmt))
|
||||
else if AStmt is TRaiseStmt then
|
||||
EmitRaiseStmt(TRaiseStmt(AStmt))
|
||||
else if AStmt is TForStmt then
|
||||
EmitForStmt(TForStmt(AStmt))
|
||||
else if AStmt is TWhileStmt then
|
||||
EmitWhileStmt(TWhileStmt(AStmt))
|
||||
|
|
@ -291,6 +300,57 @@ begin
|
|||
EmitLine('@' + LblEnd);
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitTryFinallyStmt(AStmt: TTryFinallyStmt);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
{ Simplified model: emit try body then finally body sequentially.
|
||||
Full stack-unwinding requires RTL support (future phase). }
|
||||
for I := 0 to AStmt.TryBody.Stmts.Count - 1 do
|
||||
EmitStmt(TASTStmt(AStmt.TryBody.Stmts[I]));
|
||||
for I := 0 to AStmt.FinallyBody.Stmts.Count - 1 do
|
||||
EmitStmt(TASTStmt(AStmt.FinallyBody.Stmts[I]));
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitTryExceptStmt(AStmt: TTryExceptStmt);
|
||||
var
|
||||
LblExcept: string;
|
||||
LblEnd: string;
|
||||
I: Integer;
|
||||
begin
|
||||
LblExcept := AllocLabel('except_handler');
|
||||
LblEnd := AllocLabel('except_end');
|
||||
|
||||
{ Emit try body — exception dispatch requires RTL support (future phase) }
|
||||
for I := 0 to AStmt.TryBody.Stmts.Count - 1 do
|
||||
EmitStmt(TASTStmt(AStmt.TryBody.Stmts[I]));
|
||||
|
||||
{ Skip except handler in normal execution }
|
||||
EmitLine(Format(' jmp @%s', [LblEnd]));
|
||||
|
||||
{ Except handler block — reachable only via raise dispatch (future) }
|
||||
EmitLine('@' + LblExcept);
|
||||
for I := 0 to AStmt.ExceptBody.Stmts.Count - 1 do
|
||||
EmitStmt(TASTStmt(AStmt.ExceptBody.Stmts[I]));
|
||||
EmitLine(Format(' jmp @%s', [LblEnd]));
|
||||
|
||||
EmitLine('@' + LblEnd);
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitRaiseStmt(AStmt: TRaiseStmt);
|
||||
var
|
||||
ObjTemp: string;
|
||||
begin
|
||||
if AStmt.Expr <> nil then
|
||||
begin
|
||||
ObjTemp := EmitExpr(AStmt.Expr);
|
||||
EmitLine(Format(' call $_Raise(l %s)', [ObjTemp]));
|
||||
end
|
||||
else
|
||||
{ Bare re-raise: pass null; RTL retrieves current exception }
|
||||
EmitLine(' call $_Raise(l 0)');
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitForStmt(AStmt: TForStmt);
|
||||
var
|
||||
LblCond: string;
|
||||
|
|
|
|||
|
|
@ -36,6 +36,10 @@ type
|
|||
tkFor,
|
||||
tkTo,
|
||||
tkDownto,
|
||||
tkTry,
|
||||
tkFinally,
|
||||
tkExcept,
|
||||
tkRaise,
|
||||
tkNil,
|
||||
{ Identifier }
|
||||
tkIdent,
|
||||
|
|
@ -116,6 +120,10 @@ begin
|
|||
else if AUpper = 'FOR' then Result := tkFor
|
||||
else if AUpper = 'TO' then Result := tkTo
|
||||
else if AUpper = 'DOWNTO' then Result := tkDownto
|
||||
else if AUpper = 'TRY' then Result := tkTry
|
||||
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
|
||||
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
|
||||
|
|
|
|||
|
|
@ -65,6 +65,8 @@ type
|
|||
function ParseIfStmt: TIfStmt;
|
||||
function ParseWhileStmt: TWhileStmt;
|
||||
function ParseForStmt: TForStmt;
|
||||
function ParseTryStmt: TASTStmt;
|
||||
function ParseRaiseStmt: TRaiseStmt;
|
||||
function ParseCompoundStmt: TCompoundStmt;
|
||||
function ParseExpr: TASTExpr;
|
||||
function ParseAddSub: TASTExpr;
|
||||
|
|
@ -516,6 +518,18 @@ begin
|
|||
Exit;
|
||||
end;
|
||||
|
||||
if Check(tkTry) then
|
||||
begin
|
||||
Result := ParseTryStmt;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if Check(tkRaise) then
|
||||
begin
|
||||
Result := ParseRaiseStmt;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if Check(tkBegin) then
|
||||
begin
|
||||
Result := ParseCompoundStmt;
|
||||
|
|
@ -672,6 +686,113 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseTryStmt: TASTStmt;
|
||||
var
|
||||
TryBody: TCompoundStmt;
|
||||
FinallyBody: TCompoundStmt;
|
||||
ExceptBody: TCompoundStmt;
|
||||
Stmt: TASTStmt;
|
||||
TFS: TTryFinallyStmt;
|
||||
TES: TTryExceptStmt;
|
||||
Line, Col: Integer;
|
||||
|
||||
procedure ParseBodyInto(ATarget: TCompoundStmt;
|
||||
AStop1, AStop2: TTokenKind);
|
||||
var S: TASTStmt;
|
||||
begin
|
||||
while not (Check(AStop1) or Check(AStop2) or
|
||||
Check(tkEnd) or Check(tkEOF)) do
|
||||
begin
|
||||
S := ParseStmt;
|
||||
if S <> nil then
|
||||
ATarget.Stmts.Add(S);
|
||||
if Check(tkSemicolon) then
|
||||
Advance
|
||||
else
|
||||
Break;
|
||||
end;
|
||||
end;
|
||||
|
||||
begin
|
||||
Line := FCurrent.Line;
|
||||
Col := FCurrent.Col;
|
||||
Expect(tkTry);
|
||||
|
||||
TryBody := TCompoundStmt.Create;
|
||||
TryBody.Line := Line;
|
||||
TryBody.Col := Col;
|
||||
try
|
||||
ParseBodyInto(TryBody, tkFinally, tkExcept);
|
||||
|
||||
if Check(tkFinally) then
|
||||
begin
|
||||
Advance;
|
||||
FinallyBody := TCompoundStmt.Create;
|
||||
try
|
||||
ParseBodyInto(FinallyBody, tkEnd, tkEnd);
|
||||
Expect(tkEnd);
|
||||
TFS := TTryFinallyStmt.Create;
|
||||
TFS.Line := Line;
|
||||
TFS.Col := Col;
|
||||
TFS.TryBody := TryBody;
|
||||
TFS.FinallyBody := FinallyBody;
|
||||
TryBody := nil;
|
||||
FinallyBody := nil;
|
||||
Result := TFS;
|
||||
except
|
||||
FinallyBody.Free;
|
||||
raise;
|
||||
end;
|
||||
end
|
||||
else if Check(tkExcept) then
|
||||
begin
|
||||
Advance;
|
||||
ExceptBody := TCompoundStmt.Create;
|
||||
try
|
||||
ParseBodyInto(ExceptBody, tkEnd, tkEnd);
|
||||
Expect(tkEnd);
|
||||
TES := TTryExceptStmt.Create;
|
||||
TES.Line := Line;
|
||||
TES.Col := Col;
|
||||
TES.TryBody := TryBody;
|
||||
TES.ExceptBody := ExceptBody;
|
||||
TryBody := nil;
|
||||
ExceptBody := nil;
|
||||
Result := TES;
|
||||
except
|
||||
ExceptBody.Free;
|
||||
raise;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
raise EParseError.CreateFmt(
|
||||
'Expected ''finally'' or ''except'' after try body at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
end;
|
||||
except
|
||||
TryBody.Free;
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseRaiseStmt: TRaiseStmt;
|
||||
begin
|
||||
Result := TRaiseStmt.Create;
|
||||
try
|
||||
Result.Line := FCurrent.Line;
|
||||
Result.Col := FCurrent.Col;
|
||||
Expect(tkRaise);
|
||||
{ Bare raise has no expression; detect by checking statement terminators }
|
||||
if not (Check(tkSemicolon) or Check(tkEnd) or Check(tkEOF) or
|
||||
Check(tkFinally) or Check(tkExcept) or Check(tkElse)) then
|
||||
Result.Expr := ParseExpr;
|
||||
except
|
||||
Result.Free;
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseCompoundStmt: TCompoundStmt;
|
||||
var
|
||||
Stmt: TASTStmt;
|
||||
|
|
|
|||
|
|
@ -46,6 +46,7 @@ type
|
|||
function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
|
||||
function AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
|
||||
|
||||
procedure AnalyseCompoundBody(ABody: TCompoundStmt);
|
||||
function FindMethodDecl(const ATypeName, AMethodName: string): TMethodDecl;
|
||||
|
||||
procedure SemanticError(const AMsg: string; ALine, ACol: Integer);
|
||||
|
|
@ -495,6 +496,14 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseCompoundBody(ABody: TCompoundStmt);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
for I := 0 to ABody.Stmts.Count - 1 do
|
||||
AnalyseStmt(TASTStmt(ABody.Stmts[I]));
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseStmts(ABlock: TBlock);
|
||||
var
|
||||
I: Integer;
|
||||
|
|
@ -569,6 +578,37 @@ begin
|
|||
for I := 0 to CmpS.Stmts.Count - 1 do
|
||||
AnalyseStmt(TASTStmt(CmpS.Stmts[I]));
|
||||
end
|
||||
else if AStmt is TTryFinallyStmt then
|
||||
begin
|
||||
with TTryFinallyStmt(AStmt) do
|
||||
begin
|
||||
AnalyseCompoundBody(TryBody);
|
||||
AnalyseCompoundBody(FinallyBody);
|
||||
end;
|
||||
end
|
||||
else if AStmt is TTryExceptStmt then
|
||||
begin
|
||||
with TTryExceptStmt(AStmt) do
|
||||
begin
|
||||
AnalyseCompoundBody(TryBody);
|
||||
AnalyseCompoundBody(ExceptBody);
|
||||
end;
|
||||
end
|
||||
else if AStmt is TRaiseStmt then
|
||||
begin
|
||||
with TRaiseStmt(AStmt) do
|
||||
begin
|
||||
if Expr <> nil then
|
||||
begin
|
||||
CondType := AnalyseExpr(Expr);
|
||||
if CondType.Kind <> tyClass then
|
||||
SemanticError(
|
||||
Format('raise expression must be a class instance, got ''%s''',
|
||||
[CondType.Name]),
|
||||
AStmt.Line, AStmt.Col);
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else if AStmt is TFieldAssignment then
|
||||
AnalyseFieldAssignment(TFieldAssignment(AStmt))
|
||||
else if AStmt is TAssignment then
|
||||
|
|
|
|||
|
|
@ -23,7 +23,8 @@ uses
|
|||
cp.test.procs,
|
||||
cp.test.control,
|
||||
cp.test.inherit,
|
||||
cp.test.forloop;
|
||||
cp.test.forloop,
|
||||
cp.test.exceptions;
|
||||
|
||||
var
|
||||
Application: TTestRunner;
|
||||
|
|
|
|||
475
compiler/src/test/pascal/cp.test.exceptions.pas
Normal file
475
compiler/src/test/pascal/cp.test.exceptions.pas
Normal file
|
|
@ -0,0 +1,475 @@
|
|||
unit cp.test.exceptions;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
{ Tests for try/finally, try/except, and raise statements. }
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, fpcunit, testregistry,
|
||||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||
|
||||
type
|
||||
TExceptionTests = 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
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Lexer }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestLexer_Try_Keyword;
|
||||
procedure TestLexer_Finally_Keyword;
|
||||
procedure TestLexer_Except_Keyword;
|
||||
procedure TestLexer_Raise_Keyword;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — try/finally }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_TryFinally_IsTTryFinallyStmt;
|
||||
procedure TestParse_TryFinally_TryBodyStmtCount;
|
||||
procedure TestParse_TryFinally_FinallyBodyStmtCount;
|
||||
procedure TestParse_TryFinally_MultipleStmtsInTryBody;
|
||||
procedure TestParse_TryFinally_MultipleStmtsInFinallyBody;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — try/except }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_TryExcept_IsTTryExceptStmt;
|
||||
procedure TestParse_TryExcept_TryBodyStmtCount;
|
||||
procedure TestParse_TryExcept_ExceptBodyStmtCount;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — raise }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_Raise_IsTRaiseStmt;
|
||||
procedure TestParse_Raise_HasExpr;
|
||||
procedure TestParse_Raise_Bare_HasNilExpr;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_TryFinally_OK;
|
||||
procedure TestSemantic_TryExcept_OK;
|
||||
procedure TestSemantic_Raise_ClassExpr_OK;
|
||||
procedure TestSemantic_Raise_NonClass_RaisesError;
|
||||
procedure TestSemantic_Raise_Bare_OK;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — try/finally }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_TryFinally_TryBodyInIR;
|
||||
procedure TestCodegen_TryFinally_FinallyBodyInIR;
|
||||
procedure TestCodegen_TryFinally_FinallyAfterTry;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — try/except }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_TryExcept_TryBodyInIR;
|
||||
procedure TestCodegen_TryExcept_ExceptLabelPresent;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — raise }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_Raise_CallsRTL;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Helpers }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
function TExceptionTests.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 TExceptionTests.AnalyseSrc(const ASrc: string): TProgram;
|
||||
var A: TSemanticAnalyser;
|
||||
begin
|
||||
Result := ParseSrc(ASrc);
|
||||
A := TSemanticAnalyser.Create;
|
||||
try
|
||||
A.Analyse(Result);
|
||||
finally
|
||||
A.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TExceptionTests.GenIR(const ASrc: string): string;
|
||||
var Prog: TProgram; CG: TCodeGenQBE;
|
||||
begin
|
||||
Prog := AnalyseSrc(ASrc);
|
||||
try
|
||||
CG := TCodeGenQBE.Create;
|
||||
try
|
||||
CG.Generate(Prog);
|
||||
Result := CG.GetOutput;
|
||||
finally
|
||||
CG.Free;
|
||||
end;
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.AnalyseExpectError(const ASrc: string);
|
||||
var Prog: TProgram;
|
||||
begin
|
||||
try
|
||||
Prog := AnalyseSrc(ASrc);
|
||||
Prog.Free;
|
||||
Fail('Expected ESemanticError');
|
||||
except
|
||||
on E: ESemanticError do ;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Shared source snippets }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
SrcTryFinally =
|
||||
'program P;' + LineEnding +
|
||||
'var X: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' X := 0;' + LineEnding +
|
||||
' try' + LineEnding +
|
||||
' X := 1' + LineEnding +
|
||||
' finally' + LineEnding +
|
||||
' X := 2' + LineEnding +
|
||||
' end' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTryFinallyMulti =
|
||||
'program P;' + LineEnding +
|
||||
'var X: Integer;' + LineEnding +
|
||||
'var Y: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' try' + LineEnding +
|
||||
' X := 1;' + LineEnding +
|
||||
' Y := 2' + LineEnding +
|
||||
' finally' + LineEnding +
|
||||
' X := 0;' + LineEnding +
|
||||
' Y := 0' + LineEnding +
|
||||
' end' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcTryExcept =
|
||||
'program P;' + LineEnding +
|
||||
'var X: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' X := 0;' + LineEnding +
|
||||
' try' + LineEnding +
|
||||
' X := 1' + LineEnding +
|
||||
' except' + LineEnding +
|
||||
' X := 99' + LineEnding +
|
||||
' end' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcRaise =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TError = class' + LineEnding +
|
||||
' Code: Integer;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var E: TError;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' E := TError.Create;' + LineEnding +
|
||||
' raise E' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcBareRaise =
|
||||
'program P;' + LineEnding +
|
||||
'var X: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' try' + LineEnding +
|
||||
' X := 1' + LineEnding +
|
||||
' except' + LineEnding +
|
||||
' raise' + LineEnding +
|
||||
' end' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Lexer tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestLexer_Try_Keyword;
|
||||
var L: TLexer; T: TToken;
|
||||
begin
|
||||
L := TLexer.Create('try');
|
||||
try
|
||||
T := L.Next;
|
||||
AssertEquals('try token', Ord(tkTry), Ord(T.Kind));
|
||||
finally L.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestLexer_Finally_Keyword;
|
||||
var L: TLexer; T: TToken;
|
||||
begin
|
||||
L := TLexer.Create('finally');
|
||||
try
|
||||
T := L.Next;
|
||||
AssertEquals('finally token', Ord(tkFinally), Ord(T.Kind));
|
||||
finally L.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestLexer_Except_Keyword;
|
||||
var L: TLexer; T: TToken;
|
||||
begin
|
||||
L := TLexer.Create('except');
|
||||
try
|
||||
T := L.Next;
|
||||
AssertEquals('except token', Ord(tkExcept), Ord(T.Kind));
|
||||
finally L.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestLexer_Raise_Keyword;
|
||||
var L: TLexer; T: TToken;
|
||||
begin
|
||||
L := TLexer.Create('raise');
|
||||
try
|
||||
T := L.Next;
|
||||
AssertEquals('raise token', Ord(tkRaise), Ord(T.Kind));
|
||||
finally L.Free; end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — try/finally }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestParse_TryFinally_IsTTryFinallyStmt;
|
||||
var Prog: TProgram;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryFinally);
|
||||
try
|
||||
AssertTrue('stmt is TTryFinallyStmt',
|
||||
Prog.Block.Stmts[1] is TTryFinallyStmt);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_TryFinally_TryBodyStmtCount;
|
||||
var Prog: TProgram; TS: TTryFinallyStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryFinally);
|
||||
try
|
||||
TS := TTryFinallyStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('try body has 1 stmt', 1, TS.TryBody.Stmts.Count);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_TryFinally_FinallyBodyStmtCount;
|
||||
var Prog: TProgram; TS: TTryFinallyStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryFinally);
|
||||
try
|
||||
TS := TTryFinallyStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('finally body has 1 stmt', 1, TS.FinallyBody.Stmts.Count);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_TryFinally_MultipleStmtsInTryBody;
|
||||
var Prog: TProgram; TS: TTryFinallyStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryFinallyMulti);
|
||||
try
|
||||
TS := TTryFinallyStmt(Prog.Block.Stmts[0]);
|
||||
AssertEquals('multi try body has 2 stmts', 2, TS.TryBody.Stmts.Count);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_TryFinally_MultipleStmtsInFinallyBody;
|
||||
var Prog: TProgram; TS: TTryFinallyStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryFinallyMulti);
|
||||
try
|
||||
TS := TTryFinallyStmt(Prog.Block.Stmts[0]);
|
||||
AssertEquals('multi finally body has 2 stmts', 2, TS.FinallyBody.Stmts.Count);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — try/except }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestParse_TryExcept_IsTTryExceptStmt;
|
||||
var Prog: TProgram;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryExcept);
|
||||
try
|
||||
AssertTrue('stmt is TTryExceptStmt',
|
||||
Prog.Block.Stmts[1] is TTryExceptStmt);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_TryExcept_TryBodyStmtCount;
|
||||
var Prog: TProgram; TS: TTryExceptStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryExcept);
|
||||
try
|
||||
TS := TTryExceptStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('try body has 1 stmt', 1, TS.TryBody.Stmts.Count);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_TryExcept_ExceptBodyStmtCount;
|
||||
var Prog: TProgram; TS: TTryExceptStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcTryExcept);
|
||||
try
|
||||
TS := TTryExceptStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('except body has 1 stmt', 1, TS.ExceptBody.Stmts.Count);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser — raise }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestParse_Raise_IsTRaiseStmt;
|
||||
var Prog: TProgram;
|
||||
begin
|
||||
Prog := ParseSrc(SrcRaise);
|
||||
try
|
||||
AssertTrue('stmt is TRaiseStmt', Prog.Block.Stmts[1] is TRaiseStmt);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_Raise_HasExpr;
|
||||
var Prog: TProgram; RS: TRaiseStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcRaise);
|
||||
try
|
||||
RS := TRaiseStmt(Prog.Block.Stmts[1]);
|
||||
AssertNotNull('raise has non-nil expression', RS.Expr);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestParse_Raise_Bare_HasNilExpr;
|
||||
var Prog: TProgram; TS: TTryExceptStmt; RS: TRaiseStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcBareRaise);
|
||||
try
|
||||
TS := TTryExceptStmt(Prog.Block.Stmts[0]);
|
||||
AssertTrue('except body stmt is TRaiseStmt',
|
||||
TS.ExceptBody.Stmts[0] is TRaiseStmt);
|
||||
RS := TRaiseStmt(TS.ExceptBody.Stmts[0]);
|
||||
AssertNull('bare raise has nil expression', RS.Expr);
|
||||
finally Prog.Free; end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic tests }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestSemantic_TryFinally_OK;
|
||||
begin
|
||||
AnalyseSrc(SrcTryFinally).Free;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestSemantic_TryExcept_OK;
|
||||
begin
|
||||
AnalyseSrc(SrcTryExcept).Free;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestSemantic_Raise_ClassExpr_OK;
|
||||
begin
|
||||
AnalyseSrc(SrcRaise).Free;
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestSemantic_Raise_NonClass_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'var X: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' X := 1;' + LineEnding +
|
||||
' raise X' + LineEnding +
|
||||
'end.');
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestSemantic_Raise_Bare_OK;
|
||||
begin
|
||||
AnalyseSrc(SrcBareRaise).Free;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — try/finally }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestCodegen_TryFinally_TryBodyInIR;
|
||||
var IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTryFinally);
|
||||
{ X := 1 inside try block }
|
||||
AssertTrue('try body copy 1 in IR', Pos('copy 1', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestCodegen_TryFinally_FinallyBodyInIR;
|
||||
var IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTryFinally);
|
||||
{ X := 2 inside finally block }
|
||||
AssertTrue('finally body copy 2 in IR', Pos('copy 2', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestCodegen_TryFinally_FinallyAfterTry;
|
||||
var IR: string; PosTry, PosFinally: Integer;
|
||||
begin
|
||||
IR := GenIR(SrcTryFinally);
|
||||
{ finally code (copy 2) must appear after try code (copy 1) }
|
||||
PosTry := Pos('copy 1', IR);
|
||||
PosFinally := Pos('copy 2', IR);
|
||||
AssertTrue('try body present', PosTry > 0);
|
||||
AssertTrue('finally body present', PosFinally > 0);
|
||||
AssertTrue('finally appears after try in IR', PosFinally > PosTry);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — try/except }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestCodegen_TryExcept_TryBodyInIR;
|
||||
var IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTryExcept);
|
||||
{ X := 1 inside try block }
|
||||
AssertTrue('try body in IR', Pos('copy 1', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TExceptionTests.TestCodegen_TryExcept_ExceptLabelPresent;
|
||||
var IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcTryExcept);
|
||||
{ Except handler block has a label }
|
||||
AssertTrue('except handler label in IR', Pos('except_handler', IR) > 0);
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Codegen — raise }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TExceptionTests.TestCodegen_Raise_CallsRTL;
|
||||
var IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcRaise);
|
||||
{ raise emits a call to the RTL raise function }
|
||||
AssertTrue('call $_Raise in IR', Pos('call $_Raise', IR) > 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TExceptionTests);
|
||||
|
||||
end.
|
||||
Loading…
Reference in a new issue