administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

feat(exceptions): typed except handlers and bare re-raise (Step 8)

Browse source 
Implements `on E: TClass do` dispatch inside except blocks and correct
bare `raise` propagation inside typed handlers.

New AST node TExceptHandlerClause carries VarName, TypeName, and Body.
TTryExceptStmt gains a Handlers list and ElseBody for the typed case;
ExceptBody remains for the legacy catch-all form.

Parser detects the 'on' identifier after 'except' to switch between the
typed-handler path and the plain catch-all path.  The no-binding form
`on TFoo do` is also supported.

Semantic pass validates that handler types resolve to classes, injects
a synthetic TVarDecl into the enclosing block for each bound variable
(so EmitVarAllocs allocates a stack slot at function entry), and opens a
local scope so the variable is accessible inside the handler body.

Codegen emits a _CurrentException call (before _PopExcFrame) followed by
an _IsInstance check per handler.  The first matching handler stores the
exception pointer into the variable slot and runs the body.  If no handler
matches and there is no else clause, _Reraise propagates to the enclosing
handler.

RTL: _CurrentException now reads g_current_exception (set by _Raise at
raise time) rather than g_exc_top->exception.  This is correct because
_PopExcFrame has already unwound the handler's own frame by the time a
bare raise is executed inside the handler body.

EmitRaiseStmt bare-raise path now calls _CurrentException then _Reraise
instead of _Raise(0), which previously cleared g_current_exception.

22 new tests (17 unit + 5 E2E): parser, semantic, codegen, and runtime
dispatch (correct handler selection, subclass matching, unmatched reraise,
bare raise propagation, else clause execution).  Total: 1131 tests, 0 failures.
This commit is contained in:
Graeme Geldenhuys 2026-05-03 10:30:15 +01:00
parent 5df182da86
commit 5af72daac7
9 changed files with 757 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
compiler/src/main/pascal/uAST.pas
View file

@ -222,10 +222,26 @@ type
destructor Destroy; override;
end;
{ One 'on [VarName :] TypeName do Stmt' arm inside a try/except block.
VarName is empty when the source uses the no-binding form 'on TFoo do'. }
TExceptHandlerClause = class
public
VarName: string; { bound variable name, or '' }
TypeName: string; { exception class name }
Body: TCompoundStmt; { owned }
destructor Destroy; override;
end;
TTryExceptStmt = class(TASTStmt)
public
TryBody: TCompoundStmt; { owned }
{ Typed handlers (on E: T do): non-empty when the except block contains
'on' clauses. Mutually exclusive with ExceptBody. }
Handlers: TObjectList; { owned list of TExceptHandlerClause }
ElseBody: TCompoundStmt; { owned; catch-all after typed handlers, or nil }
{ Plain catch-all body: non-nil only when the except block has no 'on' clauses. }
ExceptBody: TCompoundStmt; { owned }
constructor Create;
destructor Destroy; override;
end;
@ -714,11 +730,27 @@ begin
inherited Destroy;
end;
{ TExceptHandlerClause }
destructor TExceptHandlerClause.Destroy;
begin
Body.Free;
inherited Destroy;
end;
{ TTryExceptStmt }
constructor TTryExceptStmt.Create;
begin
inherited Create;
Handlers := TObjectList.Create(True);
end;
destructor TTryExceptStmt.Destroy;
begin
TryBody.Free;
Handlers.Free;
ElseBody.Free;
ExceptBody.Free;
inherited Destroy;
end;

84
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -760,12 +760,17 @@ end;
procedure TCodeGenQBE.EmitTryExceptStmt(AStmt: TTryExceptStmt);
var
LblTry: string;
LblExcept: string;
LblEnd: string;
FrameTemp: string;
SjrTemp: string;
I: Integer;
LblTry: string;
LblExcept: string;
LblEnd: string;
FrameTemp: string;
SjrTemp: string;
ExcTemp: string;
MatchTemp: string;
LblBody: string;
LblNext: string;
I, J: Integer;
H: TExceptHandlerClause;
begin
LblTry := AllocLabel('try_body');
LblExcept := AllocLabel('except_handler');
@ -789,12 +794,60 @@ begin
EmitLine(' call $_PopExcFrame()');
EmitLine(Format(' jmp @%s', [LblEnd]));
{ Exception path: frame still at top (exception set), pop then handle }
{ Exception path: capture exception before popping frame, then pop }
EmitLine('@' + LblExcept);
EmitLine(' call $_PopExcFrame()');
for I := 0 to AStmt.ExceptBody.Stmts.Count - 1 do
EmitStmt(TASTStmt(AStmt.ExceptBody.Stmts.Items[I]));
EmitLine(Format(' jmp @%s', [LblEnd]));
if AStmt.Handlers.Count > 0 then
begin
{ Capture current exception while frame is still on the stack (g_exc_top
points to our frame, so _CurrentException returns its exception field). }
ExcTemp := AllocTemp;
EmitLine(Format(' %s =l call $_CurrentException()', [ExcTemp]));
EmitLine(' call $_PopExcFrame()');
for I := 0 to AStmt.Handlers.Count - 1 do
begin
H := TExceptHandlerClause(AStmt.Handlers[I]);
LblBody := AllocLabel('exc_handler_body');
LblNext := AllocLabel('exc_handler_next');
MatchTemp := AllocTemp;
EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)',
[MatchTemp, ExcTemp, H.TypeName]));
EmitLine(Format(' jnz %s, @%s, @%s', [MatchTemp, LblBody, LblNext]));
EmitLine('@' + LblBody);
if H.VarName <> '' then
EmitLine(Format(' storel %s, %%_var_%s', [ExcTemp, H.VarName]));
for J := 0 to H.Body.Stmts.Count - 1 do
EmitStmt(TASTStmt(H.Body.Stmts.Items[J]));
EmitLine(Format(' jmp @%s', [LblEnd]));
EmitLine('@' + LblNext);
end;
{ No handler matched: run else body (if any), otherwise re-raise }
if AStmt.ElseBody <> nil then
begin
for J := 0 to AStmt.ElseBody.Stmts.Count - 1 do
EmitStmt(TASTStmt(AStmt.ElseBody.Stmts.Items[J]));
EmitLine(Format(' jmp @%s', [LblEnd]));
end
else
begin
{ No else: re-raise the unhandled exception }
EmitLine(Format(' call $_Reraise(l %s)', [ExcTemp]));
EmitLine(Format(' jmp @%s', [LblEnd])); { unreachable; satisfies QBE SSA }
end;
end
else
begin
{ Plain catch-all body }
EmitLine(' call $_PopExcFrame()');
for I := 0 to AStmt.ExceptBody.Stmts.Count - 1 do
EmitStmt(TASTStmt(AStmt.ExceptBody.Stmts.Items[I]));
EmitLine(Format(' jmp @%s', [LblEnd]));
end;
EmitLine('@' + LblEnd);
end;
@ -809,8 +862,13 @@ begin
EmitLine(Format(' call $_Raise(l %s)', [ObjTemp]));
end
else
{ Bare re-raise: pass null; RTL retrieves current exception }
EmitLine(' call $_Raise(l 0)');
begin
{ Bare re-raise: retrieve the current exception, then call _Reraise.
_Raise(0) would incorrectly clear g_current_exception to null. }
ObjTemp := AllocTemp;
EmitLine(Format(' %s =l call $_CurrentException()', [ObjTemp]));
EmitLine(Format(' call $_Reraise(l %s)', [ObjTemp]));
end;
end;
procedure TCodeGenQBE.EmitForStmt(AStmt: TForStmt);

105
compiler/src/main/pascal/uParser.pas
View file

@ -87,6 +87,7 @@ type
function ParseRepeatStmt: TRepeatStmt;
function ParseForStmt: TASTStmt;
function ParseTryStmt: TASTStmt;
function ParseExceptHandlerClause: TExceptHandlerClause;
procedure ParseBodyInto(ATarget: TCompoundStmt; AStop1, AStop2: TTokenKind);
function ParseRaiseStmt: TRaiseStmt;
function ParseInheritedStmt: TInheritedCallStmt;
@ -1759,7 +1760,6 @@ var
TryBody: TCompoundStmt;
FinallyBody: TCompoundStmt;
ExceptBody: TCompoundStmt;
Stmt: TASTStmt;
TFS: TTryFinallyStmt;
TES: TTryExceptStmt;
Line, Col: Integer;
@ -1797,20 +1797,47 @@ begin
else if Check(tkExcept) then
begin
Advance;
ExceptBody := TCompoundStmt.Create;
TES := TTryExceptStmt.Create;
TES.Line := Line;
TES.Col := Col;
TES.TryBody := TryBody;
TryBody := nil;
try
ParseBodyInto(ExceptBody, tkEnd, tkEnd);
{ Typed handler form: 'on [Var :] TypeName do Stmt' }
if Check(tkIdent) and SameText(FCurrent.Value, 'on') then
begin
while Check(tkIdent) and SameText(FCurrent.Value, 'on') do
begin
TES.Handlers.Add(ParseExceptHandlerClause);
if Check(tkSemicolon) then
Advance;
end;
{ Optional catch-all else clause }
if Check(tkElse) then
begin
Advance;
TES.ElseBody := TCompoundStmt.Create;
ParseBodyInto(TES.ElseBody, tkEnd, tkEnd);
end;
end
else
begin
{ Plain catch-all body }
ExceptBody := TCompoundStmt.Create;
try
ParseBodyInto(ExceptBody, tkEnd, tkEnd);
TES.ExceptBody := ExceptBody;
ExceptBody := nil;
except
ExceptBody.Free;
raise;
end;
end;
Expect(tkEnd);
TES := TTryExceptStmt.Create;
TES.Line := Line;
TES.Col := Col;
TES.TryBody := TryBody;
TES.ExceptBody := ExceptBody;
TryBody := nil;
ExceptBody := nil;
Result := TES;
TES := nil;
except
ExceptBody.Free;
TES.Free;
raise;
end;
end
@ -1826,6 +1853,62 @@ begin
end;
end;
{ Parse one 'on [VarName :] TypeName do Stmt' clause.
The leading 'on' keyword (as identifier) must be the current token. }
function TParser.ParseExceptHandlerClause: TExceptHandlerClause;
var
Name1: string;
H: TExceptHandlerClause;
begin
{ consume 'on' }
Expect(tkIdent); { value is 'on' — caller already checked }
H := TExceptHandlerClause.Create;
try
if not Check(tkIdent) then
raise EParseError.Create(Format(
'Expected identifier after ''on'' at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
Name1 := FCurrent.Value;
Advance;
if Check(tkColon) then
begin
{ 'on VarName : TypeName do' form }
Advance;
if not Check(tkIdent) then
raise EParseError.Create(Format(
'Expected type name after '':'' at line %d col %d in %s',
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
H.VarName := Name1;
H.TypeName := FCurrent.Value;
Advance;
end
else
begin
{ 'on TypeName do' form — no variable binding }
H.VarName := '';
H.TypeName := Name1;
end;
Expect(tkDo);
H.Body := TCompoundStmt.Create;
{ Handler body is a single statement (Delphi/FPC standard) }
if Check(tkBegin) then
begin
Advance;
ParseBodyInto(H.Body, tkEnd, tkEnd);
Expect(tkEnd);
end
else
begin
{ Single statement }
H.Body.Stmts.Add(ParseStmt);
end;
Result := H;
except
H.Free;
raise;
end;
end;
function TParser.ParseRaiseStmt: TRaiseStmt;
begin
Result := TRaiseStmt.Create;

46
compiler/src/main/pascal/uSemantic.pas
View file

@ -2076,6 +2076,7 @@ var
RS: TRepeatStmt;
TFS: TTryFinallyStmt;
TES: TTryExceptStmt;
H: TExceptHandlerClause;
RaiseS: TRaiseStmt;
I: Integer;
CondType: TTypeDesc;
@ -2378,7 +2379,50 @@ begin
begin
TES := TTryExceptStmt(AStmt);
AnalyseCompoundBody(TES.TryBody);
AnalyseCompoundBody(TES.ExceptBody);
if TES.Handlers.Count > 0 then
begin
for I := 0 to TES.Handlers.Count - 1 do
begin
H := TExceptHandlerClause(TES.Handlers[I]);
CondType := FindTypeOrInstantiate(H.TypeName);
if CondType = nil then
SemanticError(
Format('Unknown exception type ''%s''', [H.TypeName]),
AStmt.Line, AStmt.Col);
if CondType.Kind <> tyClass then
SemanticError(
Format('Exception handler type must be a class, got ''%s''', [H.TypeName]),
AStmt.Line, AStmt.Col);
if H.VarName <> '' then
begin
{ Inject a synthetic local so EmitVarAllocs allocates a stack slot. }
if FCurrentLocalBlock <> nil then
begin
SynthDecl := TVarDecl.Create;
SynthDecl.Names.Add(H.VarName);
SynthDecl.TypeName := H.TypeName;
SynthDecl.ResolvedType := CondType;
SynthDecl.IsGlobal := False;
FCurrentLocalBlock.Decls.Add(SynthDecl);
end;
FTable.PushScope;
try
VarSym := TSymbol.Create(H.VarName, skVariable, CondType);
if not FTable.Define(VarSym) then
VarSym.Free;
AnalyseCompoundBody(H.Body);
finally
FTable.PopScope;
end;
end
else
AnalyseCompoundBody(H.Body);
end;
if TES.ElseBody <> nil then
AnalyseCompoundBody(TES.ElseBody);
end
else
AnalyseCompoundBody(TES.ExceptBody);
end
else if AStmt is TRaiseStmt then
begin

151
compiler/src/test/pascal/cp.test.e2e.pas
View file

@ -161,6 +161,14 @@ type
{ ------------------------------------------------------------------ }
procedure TestRun_ProcessBuiltins_CapturesOutput;
procedure TestRun_ProcessBuiltins_ExitCode;
{ ------------------------------------------------------------------ }
{ Typed except handlers (Step 8) }
{ ------------------------------------------------------------------ }
procedure TestRun_TypedExcept_CorrectHandlerMatched;
procedure TestRun_TypedExcept_SubclassMatchesParentHandler;
procedure TestRun_TypedExcept_UnmatchedReraises;
procedure TestRun_TypedExcept_BareRaisePropagatesToOuter;
procedure TestRun_TypedExcept_ElseBodyRunsWhenNoMatch;
end;
implementation
@ -2235,6 +2243,149 @@ begin
AssertEquals('true exits with 0', '0', Trim(Output));
end;
{ ------------------------------------------------------------------ }
{ Typed except handlers — shared source base }
{ ------------------------------------------------------------------ }
const
SrcExcBase2 =
'program P;' + LineEnding +
'type' + LineEnding +
' Exception = class' + LineEnding +
' FMessage: string;' + LineEnding +
' property Message: string read FMessage;' + LineEnding +
' end;' + LineEnding +
' EFoo = class(Exception) end;' + LineEnding +
' EBar = class(EFoo) end;' + LineEnding;
SrcTypedExceptCorrect =
SrcExcBase2 +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := 0;' + LineEnding +
' try' + LineEnding +
' raise EFoo.Create' + LineEnding +
' except' + LineEnding +
' on E: EFoo do X := 42;' + LineEnding +
' on E: Exception do X := 1' + LineEnding +
' end;' + LineEnding +
' WriteLn(X)' + LineEnding +
'end.';
SrcTypedExceptSubclass =
SrcExcBase2 +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := 0;' + LineEnding +
' try' + LineEnding +
' raise EBar.Create' + LineEnding +
' except' + LineEnding +
' on E: EFoo do X := 7' + LineEnding +
' end;' + LineEnding +
' WriteLn(X)' + LineEnding +
'end.';
SrcTypedExceptElseRun =
SrcExcBase2 +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := 0;' + LineEnding +
' try' + LineEnding +
' raise EFoo.Create' + LineEnding +
' except' + LineEnding +
' on E: EBar do X := 9' + LineEnding +
' else X := 5' + LineEnding +
' end;' + LineEnding +
' WriteLn(X)' + LineEnding +
'end.';
SrcTypedExceptBareRaise =
SrcExcBase2 +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := 0;' + LineEnding +
' try' + LineEnding +
' try' + LineEnding +
' raise EFoo.Create' + LineEnding +
' except' + LineEnding +
' on E: EFoo do' + LineEnding +
' begin' + LineEnding +
' X := 1;' + LineEnding +
' raise' + LineEnding +
' end' + LineEnding +
' end' + LineEnding +
' except' + LineEnding +
' on E: EFoo do X := 2' + LineEnding +
' end;' + LineEnding +
' WriteLn(X)' + LineEnding +
'end.';
SrcTypedExceptUnmatched =
SrcExcBase2 +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' X := 0;' + LineEnding +
' try' + LineEnding +
' try' + LineEnding +
' raise EFoo.Create' + LineEnding +
' except' + LineEnding +
' on E: EBar do X := 9' + LineEnding +
' end' + LineEnding +
' except' + LineEnding +
' on E: EFoo do X := 3' + LineEnding +
' end;' + LineEnding +
' WriteLn(X)' + LineEnding +
'end.';
{ ------------------------------------------------------------------ }
{ Typed except handler — E2E tests }
{ ------------------------------------------------------------------ }
procedure TE2ETests.TestRun_TypedExcept_CorrectHandlerMatched;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcTypedExceptCorrect, Output, RCode, []));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('EFoo handler ran', '42', Trim(Output));
end;
procedure TE2ETests.TestRun_TypedExcept_SubclassMatchesParentHandler;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcTypedExceptSubclass, Output, RCode, []));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('EBar matches EFoo handler', '7', Trim(Output));
end;
procedure TE2ETests.TestRun_TypedExcept_UnmatchedReraises;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcTypedExceptUnmatched, Output, RCode, []));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('unmatched inner re-raises to outer', '3', Trim(Output));
end;
procedure TE2ETests.TestRun_TypedExcept_BareRaisePropagatesToOuter;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcTypedExceptBareRaise, Output, RCode, []));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('bare raise propagated to outer handler', '2', Trim(Output));
end;
procedure TE2ETests.TestRun_TypedExcept_ElseBodyRunsWhenNoMatch;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run', CompileAndRun(SrcTypedExceptElseRun, Output, RCode, []));
AssertEquals('exit code 0', 0, RCode);
AssertEquals('else body ran when no handler matched', '5', Trim(Output));
end;
initialization
RegisterTest(TE2ETests);

294
compiler/src/test/pascal/cp.test.exceptions.pas
View file

@ -102,6 +102,39 @@ type
procedure TestCodegen_TryFinally_ArcRelease_BeforeReraise;
procedure TestCodegen_TryFinally_ArcRelease_ZerosVar;
procedure TestCodegen_ExceptionSubclass_CtorCallWithMessage;
{ ------------------------------------------------------------------ }
{ Parser — typed except handlers (on E: TClass do) }
{ ------------------------------------------------------------------ }
procedure TestParse_TypedExcept_HasOneHandler;
procedure TestParse_TypedExcept_HandlerTypeName;
procedure TestParse_TypedExcept_HandlerVarName;
procedure TestParse_TypedExcept_HandlerBodyStmtCount;
procedure TestParse_TypedExcept_TwoHandlers;
procedure TestParse_TypedExcept_WithElseBody;
procedure TestParse_TypedExcept_NoVarBinding;
{ ------------------------------------------------------------------ }
{ Semantic — typed except handlers }
{ ------------------------------------------------------------------ }
procedure TestSemantic_TypedExcept_SingleHandler_OK;
procedure TestSemantic_TypedExcept_TwoHandlers_OK;
procedure TestSemantic_TypedExcept_NonClassType_RaisesError;
procedure TestSemantic_TypedExcept_WithElse_OK;
procedure TestSemantic_TypedExcept_HandlerVarUsableInBody;
{ ------------------------------------------------------------------ }
{ Codegen — typed except handlers }
{ ------------------------------------------------------------------ }
procedure TestCodegen_TypedExcept_CallsIsInstance;
procedure TestCodegen_TypedExcept_TwoHandlers_TwoIsInstanceCalls;
procedure TestCodegen_TypedExcept_ElseBodyPresent;
procedure TestCodegen_TypedExcept_UsesCurrentException;
{ ------------------------------------------------------------------ }
{ Codegen — bare raise in except handler }
{ ------------------------------------------------------------------ }
procedure TestCodegen_BareRaise_InTypedHandler_CallsReraise;
end;
implementation
@ -678,6 +711,267 @@ begin
AssertTrue('raise RTL call', Pos('$_Raise', IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ Shared source — typed except handlers }
{ ------------------------------------------------------------------ }
const
SrcExcBase =
'program P;' + LineEnding +
'type' + LineEnding +
' Exception = class' + LineEnding +
' FMessage: string;' + LineEnding +
' constructor Create(AMessage: string);' + LineEnding +
' property Message: string read FMessage;' + LineEnding +
' end;' + LineEnding +
' EFoo = class(Exception) end;' + LineEnding +
' EBar = class(Exception) end;' + LineEnding;
SrcTypedExceptSingle =
SrcExcBase +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on E: EFoo do' + LineEnding +
' X := 42' + LineEnding +
' end' + LineEnding +
'end.';
SrcTypedExceptTwo =
SrcExcBase +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on E: EFoo do' + LineEnding +
' X := 42;' + LineEnding +
' on E: EBar do' + LineEnding +
' X := 99' + LineEnding +
' end' + LineEnding +
'end.';
SrcTypedExceptWithElse =
SrcExcBase +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on E: EFoo do' + LineEnding +
' X := 42' + LineEnding +
' else' + LineEnding +
' X := 0' + LineEnding +
' end' + LineEnding +
'end.';
SrcTypedExceptNoVar =
SrcExcBase +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on EFoo do' + LineEnding +
' X := 42' + LineEnding +
' end' + LineEnding +
'end.';
{ ------------------------------------------------------------------ }
{ Parser — typed except handlers }
{ ------------------------------------------------------------------ }
procedure TExceptionTests.TestParse_TypedExcept_HasOneHandler;
var Prog: TProgram; TES: TTryExceptStmt;
begin
Prog := ParseSrc(SrcTypedExceptSingle);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
AssertEquals('one handler', 1, TES.Handlers.Count);
finally Prog.Free; end;
end;
procedure TExceptionTests.TestParse_TypedExcept_HandlerTypeName;
var Prog: TProgram; TES: TTryExceptStmt; H: TExceptHandlerClause;
begin
Prog := ParseSrc(SrcTypedExceptSingle);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
H := TExceptHandlerClause(TES.Handlers[0]);
AssertEquals('handler type EFoo', 'EFoo', H.TypeName);
finally Prog.Free; end;
end;
procedure TExceptionTests.TestParse_TypedExcept_HandlerVarName;
var Prog: TProgram; TES: TTryExceptStmt; H: TExceptHandlerClause;
begin
Prog := ParseSrc(SrcTypedExceptSingle);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
H := TExceptHandlerClause(TES.Handlers[0]);
AssertEquals('handler var E', 'E', H.VarName);
finally Prog.Free; end;
end;
procedure TExceptionTests.TestParse_TypedExcept_HandlerBodyStmtCount;
var Prog: TProgram; TES: TTryExceptStmt; H: TExceptHandlerClause;
begin
Prog := ParseSrc(SrcTypedExceptSingle);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
H := TExceptHandlerClause(TES.Handlers[0]);
AssertEquals('handler body 1 stmt', 1, H.Body.Stmts.Count);
finally Prog.Free; end;
end;
procedure TExceptionTests.TestParse_TypedExcept_TwoHandlers;
var Prog: TProgram; TES: TTryExceptStmt;
begin
Prog := ParseSrc(SrcTypedExceptTwo);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
AssertEquals('two handlers', 2, TES.Handlers.Count);
finally Prog.Free; end;
end;
procedure TExceptionTests.TestParse_TypedExcept_WithElseBody;
var Prog: TProgram; TES: TTryExceptStmt;
begin
Prog := ParseSrc(SrcTypedExceptWithElse);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
AssertNotNull('else body present', TES.ElseBody);
AssertEquals('else body 1 stmt', 1, TES.ElseBody.Stmts.Count);
finally Prog.Free; end;
end;
procedure TExceptionTests.TestParse_TypedExcept_NoVarBinding;
var Prog: TProgram; TES: TTryExceptStmt; H: TExceptHandlerClause;
begin
Prog := ParseSrc(SrcTypedExceptNoVar);
try
TES := TTryExceptStmt(Prog.Block.Stmts[0]);
H := TExceptHandlerClause(TES.Handlers[0]);
AssertEquals('no-var handler: empty VarName', '', H.VarName);
AssertEquals('no-var handler: TypeName is EFoo', 'EFoo', H.TypeName);
finally Prog.Free; end;
end;
{ ------------------------------------------------------------------ }
{ Semantic — typed except handlers }
{ ------------------------------------------------------------------ }
procedure TExceptionTests.TestSemantic_TypedExcept_SingleHandler_OK;
begin
AnalyseSrc(SrcTypedExceptSingle).Free;
end;
procedure TExceptionTests.TestSemantic_TypedExcept_TwoHandlers_OK;
begin
AnalyseSrc(SrcTypedExceptTwo).Free;
end;
procedure TExceptionTests.TestSemantic_TypedExcept_NonClassType_RaisesError;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on E: Integer do' + LineEnding +
' X := 0' + LineEnding +
' end' + LineEnding +
'end.');
end;
procedure TExceptionTests.TestSemantic_TypedExcept_WithElse_OK;
begin
AnalyseSrc(SrcTypedExceptWithElse).Free;
end;
procedure TExceptionTests.TestSemantic_TypedExcept_HandlerVarUsableInBody;
begin
{ Handler variable E should be in scope and usable inside the handler body. }
AnalyseSrc(
SrcExcBase +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on E: EFoo do' + LineEnding +
' X := 0' + LineEnding +
' end' + LineEnding +
'end.').Free;
end;
{ ------------------------------------------------------------------ }
{ Codegen — typed except handlers }
{ ------------------------------------------------------------------ }
procedure TExceptionTests.TestCodegen_TypedExcept_CallsIsInstance;
var IR: string;
begin
IR := GenIR(SrcTypedExceptSingle);
AssertTrue('_IsInstance call for EFoo', Pos('$_IsInstance', IR) > 0);
AssertTrue('typeinfo_EFoo referenced', Pos('typeinfo_EFoo', IR) > 0);
end;
procedure TExceptionTests.TestCodegen_TypedExcept_TwoHandlers_TwoIsInstanceCalls;
var IR: string; N: Integer; Idx: Integer;
begin
IR := GenIR(SrcTypedExceptTwo);
N := 0; Idx := 1;
while True do
begin
Idx := PosEx('$_IsInstance', IR, Idx);
if Idx = 0 then Break;
Inc(N); Inc(Idx);
end;
AssertTrue('two _IsInstance calls for two handlers', N >= 2);
end;
procedure TExceptionTests.TestCodegen_TypedExcept_ElseBodyPresent;
var IR: string;
begin
IR := GenIR(SrcTypedExceptWithElse);
{ The else body assigns 0 to X }
AssertTrue('else body (copy 0) in IR', Pos('copy 0', IR) > 0);
end;
procedure TExceptionTests.TestCodegen_TypedExcept_UsesCurrentException;
var IR: string;
begin
IR := GenIR(SrcTypedExceptSingle);
{ Handler must call _CurrentException to get the live exception object }
AssertTrue('_CurrentException called', Pos('$_CurrentException', IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ Codegen — bare raise in except handler }
{ ------------------------------------------------------------------ }
procedure TExceptionTests.TestCodegen_BareRaise_InTypedHandler_CallsReraise;
var IR: string;
begin
IR := GenIR(
SrcExcBase +
'var X: Integer;' + LineEnding +
'begin' + LineEnding +
' try' + LineEnding +
' X := 1' + LineEnding +
' except' + LineEnding +
' on E: EFoo do' + LineEnding +
' raise' + LineEnding +
' end' + LineEnding +
'end.');
AssertTrue('bare raise calls _Reraise', Pos('call $_Reraise', IR) > 0);
end;
initialization
RegisterTest(TExceptionTests);

11
docs/grammar.ebnf
View file

@ -460,7 +460,16 @@ TryFinallyStmt
;
TryExceptStmt
= TRY StmtList EXCEPT StmtList END
= TRY StmtList EXCEPT ExceptBody END
;
ExceptBody
= OnClause { ";" OnClause } [ ";" ] [ ELSE StmtList ]
| StmtList
;
OnClause
= "on" [ IDENT ":" ] TypeRef DO Stmt
;
RaiseStmt

54
docs/language-rationale.adoc
View file

@ -949,6 +949,60 @@ releases the enumerator automatically.
---
== Exception Handling
=== Typed `except` Handlers (`on E: TClass do`)
==== Decision
Blaise supports typed exception dispatch inside `except` blocks using the
`on [Var :] TypeName do Stmt` syntax, matching FPC and Delphi semantics.
Multiple `on` clauses are checked in order; an optional `else` clause runs if
no typed handler matches. A catch-all `except ... end` block (no `on` clauses)
remains supported for simple cases.
==== Grammar
[source,ebnf]
----
TryExceptStmt = TRY StmtList EXCEPT ExceptBody END ;
ExceptBody = OnClause { ";" OnClause } [ ";" ] [ ELSE StmtList ]
| StmtList ;
OnClause = "on" [ IDENT ":" ] TypeRef DO Stmt ;
----
==== Semantics
* The type after `:` must resolve to a class type; primitive types are rejected
by the semantic pass with an error.
* When a variable binding is present (`on E: EFoo do`), a synthetic local
variable of the handler's type is injected into the enclosing function's
declaration block so that `EmitVarAllocs` allocates a stack slot at function
entry. The slot is initialised to the current exception pointer at the start
of each matched handler body.
* Handler matching uses `_IsInstance` (the same C helper used by the `is`
operator), which walks the vtable TypeInfo parent chain — so `on E: EBase do`
correctly catches instances of any subclass of `EBase`.
* If no `on` clause matches and there is no `else` clause, the exception is
re-raised to the enclosing handler via `_Reraise`.
* Bare `raise` inside a typed handler retrieves the live exception from
`g_current_exception` (via `_CurrentException()`) and re-raises it.
Using `g_current_exception` (set by `_Raise` at raise time) rather than
`g_exc_top->exception` (which reads the _current_ frame's field) is critical
for correctness: by the time the handler body runs, `_PopExcFrame` has already
unlinked the handler's own frame, so `g_exc_top` either points to an enclosing
frame (with `exception = NULL`) or is NULL at the outermost level.
==== Alternatives Rejected
* *Storing exception in the frame before popping* — the frame is on the stack
and its lifetime ends with `_PopExcFrame`. Capturing via `g_current_exception`
(a thread-local global) avoids frame lifetime issues.
* *Requiring `on E: T` to always have a variable binding* — Delphi and FPC
both permit the no-binding form `on T do`; Blaise follows suit.
---
== Open Language Questions
These items are under active consideration but not yet decided.

10
rtl/src/main/c/blaise_exc.c
View file

@ -78,12 +78,14 @@ void _Raise(void* obj) {
}
/*
* _CurrentException — return the live exception object from the current frame.
* Called from an except/finally handler on the exception path, before
* _PopExcFrame, to capture the exception pointer for re-raise.
* _CurrentException — return the live exception object.
* Called from an except handler to capture the exception pointer.
* Uses g_current_exception (set by _Raise) rather than g_exc_top->exception
* so that bare re-raise inside a typed handler continues to work after
* _PopExcFrame has already unwound the handler's own frame.
*/
void* _CurrentException(void) {
return g_exc_top ? g_exc_top->exception : NULL;
return g_current_exception;
}
/*