program test_seh_complex;
{$mode objfpc}{$H+}
{ Complex SEH test suite - focused on edge cases }
uses
SysUtils;
var
TestsPassed, TestsFailed: Integer;
procedure Check(const TestName: string; Condition: Boolean);
begin
Write(TestName, ' ... ');
if Condition then
begin
WriteLn('PASS');
Inc(TestsPassed);
end
else
begin
WriteLn('FAIL');
Inc(TestsFailed);
end;
end;
{ Test 1: Very deep nesting (10 levels) with exit }
function Test_DeepNesting: Integer;
var
FC: Integer;
begin
Result := 0;
FC := 0;
try
try
try
try
try
try
try
try
try
try
Result := 100;
Exit;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
finally Inc(FC); end;
Result := FC;
end;
{ Test 2: Recursive function with try/finally and early exit }
function Test_Recursive(Depth: Integer): Integer;
begin
if Depth <= 0 then
begin
Result := 1;
Exit;
end;
try
Result := Test_Recursive(Depth - 1) + 1;
if Depth = 3 then Exit;
finally
// Finally runs even on recursive exit
end;
end;
{ Test 3: Break from deeply nested loops }
function Test_NestedLoopBreak: Integer;
var
I, J, K, FC: Integer;
begin
FC := 0;
for I := 1 to 3 do
begin
try
for J := 1 to 3 do
begin
try
for K := 1 to 3 do
begin
try
if (I = 2) and (J = 2) and (K = 2) then Break;
finally Inc(FC); end;
end;
if (I = 2) and (J = 2) then Break;
finally Inc(FC); end;
end;
if I = 2 then Break;
finally Inc(FC); end;
end;
Result := FC;
end;
{ Test 4: Continue in nested loops }
function Test_NestedContinue: Integer;
var
I, J, FC: Integer;
begin
FC := 0;
for I := 1 to 5 do
begin
try
if I mod 2 = 0 then Continue;
for J := 1 to 5 do
begin
try
if J mod 2 = 0 then Continue;
finally Inc(FC); end;
end;
finally Inc(FC); end;
end;
Result := FC;
end;
{ Test 5: Large local arrays with exit }
function Test_LargeLocals: Integer;
var
Arr: array[0..999] of Integer;
I, Sum: Integer;
OK: Boolean;
begin
for I := 0 to 999 do Arr[I] := I;
try
Sum := 0;
for I := 0 to 999 do Sum := Sum + Arr[I];
Result := Sum;
Exit;
finally
OK := (Arr[0] = 0) and (Arr[500] = 500) and (Arr[999] = 999);
if not OK then Result := -1;
end;
end;
{ Test 6: Mixed break/continue/exit }
function Test_MixedFlow: Integer;
var
I, FC, Mode: Integer;
begin
FC := 0;
for Mode := 1 to 3 do
begin
for I := 1 to 5 do
begin
try
case Mode of
1: if I = 3 then Break;
2: if I mod 2 = 0 then Continue;
3: if I = 4 then begin Result := FC; Exit; end;
end;
finally Inc(FC); end;
end;
end;
Result := FC;
end;
{ Test 7: While loop with break }
function Test_WhileBreak: Integer;
var
I, FC: Integer;
begin
FC := 0;
I := 0;
while I < 100 do
begin
try
Inc(I);
if I = 5 then Break;
finally Inc(FC); end;
end;
Result := FC;
end;
{ Test 8: Repeat-until with break }
function Test_RepeatBreak: Integer;
var
I, FC: Integer;
begin
FC := 0;
I := 0;
repeat
try
Inc(I);
if I = 7 then Break;
finally Inc(FC); end;
until I >= 100;
Result := FC;
end;
{ Test 9: Exception then exit }
function Test_ExceptionThenExit: Integer;
var
FC: Integer;
begin
FC := 0;
try
try
raise Exception.Create('Test');
except
Inc(FC);
end;
try
Inc(FC);
Result := FC;
Exit;
finally Inc(FC); end;
finally
Inc(FC);
Result := FC; // Set result in finally
end;
end;
{ Test 10: String operations in finally }
function Test_StringFinally: Integer;
var
S: string;
begin
Result := 0;
S := '';
try
S := 'A';
try
S := S + 'B';
Result := 42;
Exit;
finally S := S + 'C'; end;
finally
S := S + 'D';
if S = 'ABCD' then Result := 1 else Result := 0;
end;
end;
{ Test 11: Multiple returns preserving value }
function Test_MultiReturn(Mode: Integer): Integer;
begin
try
case Mode of
1: begin Result := 10; Exit; end;
2: begin Result := 20; Exit; end;
3: begin Result := 30; Exit; end;
end;
Result := 0;
finally
// Result should be preserved
end;
end;
{ Test 12: Nested procedures }
function Test_NestedProc: Integer;
var
InnerRan: Boolean;
procedure Inner;
begin
try
Exit;
finally InnerRan := True; end;
end;
begin
InnerRan := False;
try
Inner;
Result := 1;
Exit;
finally
if not InnerRan then Result := 0;
end;
end;
{ Test 13: Break in case statement }
function Test_CaseBreak: Integer;
var
I, FC: Integer;
begin
FC := 0;
for I := 1 to 10 do
begin
try
case I of
1..3: ;
4, 5: Break;
6..10: ;
end;
finally Inc(FC); end;
end;
Result := FC;
end;
{ Test 14: Exception caught then normal exit }
function Test_DeepMixed: Integer;
var
FC: Integer;
begin
FC := 0;
try
try
try
raise Exception.Create('Deep');
finally Inc(FC); end;
except
Inc(FC);
// Exit from except block (simpler case)
end;
try
Inc(FC);
Exit;
finally Inc(FC); end;
finally
Inc(FC);
Result := FC;
end;
end;
{ Test 15: Array bounds in finally }
function Test_ArrayFinally: Integer;
var
Arr: array[0..9] of Integer;
I, Sum: Integer;
begin
for I := 0 to 9 do Arr[I] := I * 10;
try
Result := 999;
Exit;
finally
Sum := 0;
for I := 0 to 9 do Sum := Sum + Arr[I];
if Sum = 450 then Result := 1 else Result := 0;
end;
end;
{ Main }
begin
WriteLn('=== Complex SEH Test Suite ===');
WriteLn;
TestsPassed := 0;
TestsFailed := 0;
Check('Test 1: Deep nesting (10 levels)', Test_DeepNesting = 100);
Check('Test 2: Recursive with exit', Test_Recursive(5) >= 3);
Check('Test 3: Nested loop break', Test_NestedLoopBreak > 0);
Check('Test 4: Nested loop continue', Test_NestedContinue > 0);
Check('Test 5: Large locals (4KB array)', Test_LargeLocals = 499500);
Check('Test 6: Mixed control flow', Test_MixedFlow > 0);
Check('Test 7: While break', Test_WhileBreak = 5);
Check('Test 8: Repeat break', Test_RepeatBreak = 7);
Check('Test 9: Exception then exit', Test_ExceptionThenExit = 4);
Check('Test 10: String in finally', Test_StringFinally = 1);
Check('Test 11: Multi-return values', (Test_MultiReturn(1)=10) and (Test_MultiReturn(2)=20) and (Test_MultiReturn(3)=30));
Check('Test 12: Nested procedures', Test_NestedProc = 1);
Check('Test 13: Case break', Test_CaseBreak = 4);
Check('Test 14: Deep mixed', Test_DeepMixed = 5);
Check('Test 15: Array in finally', Test_ArrayFinally = 1);
WriteLn;
WriteLn('=== Results ===');
WriteLn('Passed: ', TestsPassed);
WriteLn('Failed: ', TestsFailed);
WriteLn;
if TestsFailed = 0 then
WriteLn('All tests passed!')
else
WriteLn('SOME TESTS FAILED!');
end.
Recent
