paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-19 07:09:17 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ exception handling testing

Browse Source 
(still missing raise / on node testing)
This commit is contained in:
carl 2002-08-03 11:05:14 +00:00
parent 54011b5bea
commit 657aa6d1cc
5 changed files with 1646 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

828
tests/test/cg/ttryexc1.pp Normal file
View File

@ -0,0 +1,828 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondtryexcept() }
{ secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{ REMARKS : Tested with Delphi 3 as reference implementation }
{****************************************************************}
program ttryexc1;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
constructor create(c: longint);
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
var
global_counter : integer;
constructor tbobject.create(c:longint);
begin
inherited create;
b:=c;
end;
Procedure raiseanexception;
Var A : TAObject;
var B : TAobject;
begin
{ Writeln ('Creating exception object');}
A:=TAObject.Create;
{ Writeln ('Raising with this object');}
raise A;
{ this should never happen, if it does there is a problem! }
RunError(255);
end;
procedure IncrementCounter(x: integer);
begin
Inc(global_counter);
end;
procedure DecrementCounter(x: integer);
begin
Dec(global_counter);
end;
Function DoTryExceptOne: boolean;
var
failed : boolean;
begin
Write('Try..Except clause...');
global_counter:=0;
failed:=true;
DoTryExceptOne := failed;
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
except
end;
if global_counter = 0 then
failed :=false;
DoTryExceptOne := failed;
end;
Function DoTryExceptTwo : boolean;
var
failed : boolean;
begin
Write('Try..Except with break statement...');
global_counter:=0;
failed:=true;
DoTryExceptTwo := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
break;
except
end;
end;
if global_counter = 0 then
failed :=false;
DoTryExceptTwo := failed;
end;
Function DoTryExceptFour: boolean;
var
failed : boolean;
begin
Write('Try..Except with exit statement...');
global_counter:=0;
failed:=true;
DoTryExceptFour := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
DoTryExceptFour := false;
exit;
except
end;
end;
end;
Function DoTryExceptFive: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses (three-level nesting)...');
global_counter:=0;
failed:=true;
DoTryExceptFive := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
except
Inc(x);
end;
except
Inc(x);
End;
except
end;
if (global_counter = 0) then
failed :=false;
DoTryExceptFive := failed;
end;
Function DoTryExceptSix : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Except nested clauses with break statement...');
global_counter:=0;
x:=0;
failed:=true;
DoTryExceptSix := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
break;
except
Inc(x);
end;
except
Inc(x);
End;
except
end;
end;
if (global_counter = 0) then
failed :=false;
DoTryExceptSix := failed;
end;
Function DoTryExceptEight : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Except nested clauses with exit statement...');
global_counter:=0;
x:=0;
failed:=true;
DoTryExceptEight := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
DoTryExceptEight := false;
exit;
except
Inc(x);
end;
except
Inc(x);
End;
except
end;
end;
end;
Function DoTryExceptNine : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Except nested clauses with break statement in other try-block...');
global_counter:=0;
x:=0;
failed:=true;
DoTryExceptNine := failed;
Try
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
break;
except
Inc(x);
end;
except
Inc(x);
End;
except
end;
end; {end while }
except
{ normally this should execute! }
DoTryExceptNine := failed;
end;
if (global_counter = 0) and (x = 0) then
failed :=false;
DoTryExceptNine := failed;
end;
{****************************************************************************}
{***************************************************************************}
{ Exception is thrown }
{***************************************************************************}
Function DoTryExceptTen: boolean;
var
failed : boolean;
begin
Write('Try..Except clause with raise...');
global_counter:=0;
failed:=true;
DoTryExceptTen := failed;
Try
IncrementCounter(global_counter);
RaiseAnException;
DecrementCounter(global_counter);
except
if global_counter = 1 then
failed :=false;
DoTryExceptTen := failed;
end;
end;
Function DoTryExceptEleven : boolean;
var
failed : boolean;
begin
Write('Try..Except with raise and break statement...');
global_counter:=0;
failed:=true;
DoTryExceptEleven := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
RaiseAnException;
break;
except
if global_counter = 0 then
failed :=false;
DoTryExceptEleven := failed;
end;
end;
end;
Function DoTryExceptTwelve: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses (three-level nesting)...');
global_counter:=0;
failed:=true;
DoTryExceptTwelve := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptTwelve := failed;
end;
except
DoTryExceptTwelve := true;
End;
except
DoTryExceptTwelve := true;
end;
end;
Function DoTryExceptThirteen: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses (three-level nesting)...');
global_counter:=0;
failed:=true;
DoTryExceptThirteen := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
RaiseAnException;
Try
DecrementCounter(global_counter);
except
DoTryExceptThirteen := true;
end;
except
if (global_counter = 1) then
failed :=false;
DoTryExceptThirteen := failed;
End;
except
DoTryExceptThirteen := true;
end;
end;
{***************************************************************************}
{ Exception is thrown in except block }
{***************************************************************************}
Function DoTryExceptFourteen: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with single re-raise...');
global_counter:=0;
failed:=true;
DoTryExceptFourteen := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
Raise;
end;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptFourteen := failed;
End;
except
DoTryExceptFourteen := true;
end;
end;
Function DoTryExceptFifteen: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with re-reraises (1)...');
global_counter:=0;
failed:=true;
DoTryExceptFifteen := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
Raise;
end;
except
{ re-raise to next block }
Raise;
End;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptFifteen := failed;
end;
end;
procedure nestedtryblock(var global_counter: integer);
begin
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
Raise;
end;
except
{ re-raise to next block }
Raise;
End;
end;
Function DoTryExceptSixteen: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with re-reraises (2)...');
global_counter:=0;
failed:=true;
DoTryExceptSixteen := failed;
x:=0;
Try
NestedTryBlock(global_counter);
except
if (global_counter = 0) then
failed :=false;
DoTryExceptSixteen := failed;
end;
end;
Function DoTryExceptSeventeen: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with raises...');
global_counter:=0;
failed:=true;
DoTryExceptSeventeen := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
raise TAObject.Create;
end;
except
{ re-raise to next block }
raise TBObject.Create(1234);
End;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptSeventeen := failed;
end;
end;
{***************************************************************************}
{ Exception flow control in except block }
{***************************************************************************}
Function DoTryExceptEighteen: boolean;
var
failed : boolean;
begin
Write('Try..Except clause with raise with break in except block...');
global_counter:=0;
failed:=true;
DoTryExceptEighteen := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
RaiseAnException;
DecrementCounter(global_counter);
except
if global_counter = 1 then
failed :=false;
DoTryExceptEighteen := failed;
break;
end;
end;
end;
Function DoTryExceptNineteen: boolean;
var
failed : boolean;
begin
Write('Try..Except clause with raise with exit in except block...');
global_counter:=0;
failed:=true;
DoTryExceptNineteen := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
RaiseAnException;
DecrementCounter(global_counter);
except
if global_counter = 1 then
failed :=false;
DoTryExceptNineteen := failed;
exit;
end;
end;
end;
Function DoTryExceptTwenty: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with raises with break in inner try...');
global_counter:=0;
failed:=true;
DoTryExceptTwenty := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
while (x = 0) do
begin
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
raise TAObject.Create;
break;
end;
end;
except
{ re-raise to next block }
raise TBObject.Create(1234);
End;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptTwenty := failed;
end;
end;
Function DoTryExceptTwentyOne: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with raises with continue in inner try...');
global_counter:=0;
failed:=true;
DoTryExceptTwentyOne := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
while (x = 0) do
begin
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
raise TAObject.Create;
x:=1;
continue;
end;
end;
except
{ re-raise to next block }
raise TBObject.Create(1234);
End;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptTwentyOne := failed;
end;
end;
Function DoTryExceptTwentyTwo: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Except nested clauses with raises with exit in inner try...');
global_counter:=0;
failed:=true;
DoTryExceptTwentyTwo := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
while (x = 0) do
begin
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
RaiseAnException;
except
{ raise to next block }
raise TAObject.Create;
exit;
end;
end;
except
{ re-raise to next block }
raise TBObject.Create(1234);
End;
except
if (global_counter = 0) then
failed :=false;
DoTryExceptTwentyTwo := failed;
end;
end;
var
failed: boolean;
begin
failed := DoTryExceptOne;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptTwo;
if failed then
fail
else
WriteLn('Success!');
{ failed := DoTryExceptThree;
if failed then
fail
else
WriteLn('Success!');}
failed := DoTryExceptFour;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptFive;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptSix;
if failed then
fail
else
WriteLn('Success!');
{ failed := DoTryExceptSeven;
if failed then
fail
else
WriteLn('Success!');}
failed := DoTryExceptEight;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptNine;
if failed then
fail
else
WriteLn('Success!');
(************************ Exceptions are created from here ****************************)
failed := DoTryExceptTen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptEleven;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptTwelve;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptThirteen;
if failed then
fail
else
WriteLn('Success!');
(************************ Exceptions in except block ****************************)
failed := DoTryExceptFourteen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptFifteen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptSixteen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptSeventeen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptEighteen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptNineteen;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptTwenty;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptTwentyOne;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryExceptTwentyTwo;
if failed then
fail
else
WriteLn('Success!');
end.
{
$Log$
Revision 1.1 2002-08-03 11:05:14 carl
+ exception handling testing
(still missing raise / on node testing)
}

506
tests/test/cg/ttryfin1.pp Normal file
View File

@ -0,0 +1,506 @@
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondtryfinally() }
{ secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{****************************************************************}
program ttryfin1;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
var
global_counter : integer;
Procedure raiseanexception;
Var A : TAObject;
begin
{ Writeln ('Creating exception object');}
A:=TAObject.Create;
{ Writeln ('Raising with this object');}
raise A;
{ this should never happen, if it does there is a problem! }
RunError(255);
end;
procedure IncrementCounter(x: integer);
begin
Inc(global_counter);
end;
procedure DecrementCounter(x: integer);
begin
Dec(global_counter);
end;
{ Will the finally clause of a try block be called if the try block exited normally? }
Function DoTryFinallyOne: boolean;
var
failed : boolean;
begin
Write('Try..Finally clause...');
global_counter:=0;
failed:=true;
DoTryFinallyOne := failed;
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
finally
if global_counter = 0 then
failed :=false;
DoTryFinallyOne := failed;
end;
end;
{
Will the finally clause of a try block be called if the try block
is inside a sub-block and the try block is exited with the break
statement?
}
Function DoTryFinallyTwo : boolean;
var
failed : boolean;
begin
Write('Try..Finally with break statement...');
global_counter:=0;
failed:=true;
DoTryFinallyTwo := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
break;
finally
if global_counter = 0 then
failed :=false;
DoTryFinallyTwo := failed;
end;
end;
end;
{
Will the finally clause of a try block be called if the try block
is inside a sub-block and the try block is exited with the continue
statement?
}
Function DoTryFinallyThree : boolean;
var
failed : boolean;
begin
Write('Try..Finally with continue statement...');
global_counter:=0;
failed:=true;
DoTryFinallyThree := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
continue;
finally
if global_counter = 0 then
failed :=false;
DoTryFinallyThree := failed;
end;
end;
end;
{
Will the finally clause of a try block be called if the try block
is inside a sub-block and the try block is exited with the exit
statement?
}
Function DoTryFinallyFour: boolean;
var
failed : boolean;
begin
Write('Try..Finally with exit statement...');
global_counter:=0;
failed:=true;
DoTryFinallyFour := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
exit;
finally
if global_counter = 0 then
failed :=false;
DoTryFinallyFour := failed;
end;
end;
end;
(*
{ Will the finally clause of a try block be called if the try block raises an exception? }
Procedure DoTryFinallyThree;
var
failed : boolean;
begin
Write('Try..Finally with exception rise...');
global_counter:=0;
failed:=true;
Try
IncrementCounter(global_counter);
RaiseAnException;
DecrementCounter(global_counter);
finally
if global_counter = 1 then
failed :=false;
if failed then
fail
else
WriteLn('Success!');
end;
end;
*)
{ Will the finally clause of all nested try blocks be called if the try blocks exited normally? }
Function DoTryFinallyFive: boolean;
var
failed : boolean;
x : integer;
begin
Write('Try..Finally nested clauses (three-level nesting)...');
global_counter:=0;
failed:=true;
DoTryFinallyFive := failed;
x:=0;
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
finally
Inc(x);
end;
finally
Inc(x);
End;
finally
if (global_counter = 0) and (x = 2) then
failed :=false;
DoTryFinallyFive := failed;
end;
end;
{
Will the finally clauses of all try blocks be called if they are
nested within each other and all are nested within a sub-block
and a break statement is encountered in the innermost try
block?
}
Function DoTryFinallySix : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Finally nested clauses with break statement...');
global_counter:=0;
x:=0;
failed:=true;
DoTryFinallySix := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
break;
finally
Inc(x);
end;
finally
Inc(x);
End;
finally
if (global_counter = 0) and (x = 2) then
failed :=false;
DoTryFinallySix := failed;
end;
end;
end;
{
Will the finally clauses of all try blocks be called if they are
nested within each other and all are nested within a sub-block
and a continue statement is encountered in the innermost try
block?
}
Function DoTryFinallySeven : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Finally nested clauses with continue statement...');
global_counter:=0;
x:=0;
failed:=true;
DoTryFinallySeven := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
continue;
finally
Inc(x);
end;
finally
Inc(x);
End;
finally
if (global_counter = 0) and (x = 2) then
failed :=false;
DoTryFinallySeven := failed;
end;
end;
end;
{
Will the finally clauses of all try blocks be called if they are
nested within each other and all are nested within a sub-block
and an exit statement is encountered in the innermost try
block?
}
Function DoTryFinallyEight : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Finally nested clauses with exit statement...');
global_counter:=0;
x:=0;
failed:=true;
DoTryFinallyEight := failed;
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
exit;
finally
Inc(x);
end;
finally
Inc(x);
End;
finally
if (global_counter = 0) and (x = 2) then
failed :=false;
DoTryFinallyEight := failed;
end;
end;
end;
(*
------------------
*)
{
If several try blocks are nested within a sub-block, and that sub-block is
nested in a try block within another try block, and the innermost try
blocks are exited due to a break, will all finally clauses be called?
}
Function DoTryFinallyNine : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Finally nested clauses with break statement in other try-block...');
global_counter:=0;
x:=0;
failed:=true;
DoTryFinallyNine := failed;
Try
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
break;
finally
Inc(x);
end;
finally
Inc(x);
End;
finally
if (global_counter = 0) and (x = 2) then
failed :=false;
DoTryFinallyNine := failed;
end;
end; {end while }
finally
{ normally this should execute! }
DoTryFinallyNine := failed;
end;
end;
{
If several try blocks are nested within a sub-block, and that sub-block is
nested in a try block within another try block, and the innermost try
blocks are exited due to an exit, will all finally clauses be called?
}
Function DoTryFinallyTen : boolean;
var
failed : boolean;
x: integer;
begin
Write('Try..Finally nested clauses with exit statement in other try-block...');
global_counter:=0;
x:=0;
failed:=true;
DoTryFinallyTen := failed;
Try
while (failed) do
begin
Try
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
IncrementCounter(global_counter);
Try
DecrementCounter(global_counter);
exit;
finally
Inc(x);
end;
finally
Inc(x);
End;
finally
x:=1;
end;
end; {end while }
finally
{ normally this should execute! }
if (global_counter = 0) and (x = 1) then
failed :=false;
DoTryFinallyTen := failed;
end;
end;
var
failed: boolean;
begin
failed := DoTryFinallyOne;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyTwo;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyThree;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyFour;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyFive;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallySix;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallySeven;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyEight;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyNine;
if failed then
fail
else
WriteLn('Success!');
failed := DoTryFinallyTen;
if failed then
fail
else
WriteLn('Success!');
end.
{
$Log$
Revision 1.1 2002-08-03 11:05:14 carl
+ exception handling testing
(still missing raise / on node testing)
}

105
tests/test/cg/ttryfin2.pp Normal file
View File

@ -0,0 +1,105 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondtryfinally() }
{ secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{****************************************************************}
program ttryfin2;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
var
global_counter : integer;
Procedure raiseanexception;
Var A : TAObject;
begin
{ Writeln ('Creating exception object');}
A:=TAObject.Create;
{ Writeln ('Raising with this object');}
raise A;
{ this should never happen, if it does there is a problem! }
RunError(255);
end;
procedure IncrementCounter(x: integer);
begin
Inc(global_counter);
end;
procedure DecrementCounter(x: integer);
begin
Dec(global_counter);
end;
{ Will the finally clause of a try block be called if the try block raises an exception? }
Procedure DoTryFinallyOne;
var
failed : boolean;
begin
Write('Try..Finally with exception rise...');
global_counter:=0;
failed:=true;
Try
IncrementCounter(global_counter);
RaiseAnException;
DecrementCounter(global_counter);
finally
if global_counter = 1 then
failed :=false;
if failed then
fail
else
WriteLn('Success!');
end;
end;
Begin
DoTryFinallyOne;
end.
{
$Log$
Revision 1.1 2002-08-03 11:05:14 carl
+ exception handling testing
(still missing raise / on node testing)
}

99
tests/test/cg/ttryfin3.pp Normal file
View File

@ -0,0 +1,99 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondtryfinally() }
{ secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{****************************************************************}
program ttryfin3;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
var
global_counter : integer;
Procedure raiseanexception;
Var A : TAObject;
begin
{ Writeln ('Creating exception object');}
A:=TAObject.Create;
{ Writeln ('Raising with this object');}
raise A;
{ this should never happen, if it does there is a problem! }
RunError(255);
end;
procedure IncrementCounter(x: integer);
begin
Inc(global_counter);
end;
procedure DecrementCounter(x: integer);
begin
Dec(global_counter);
end;
{ }
Procedure DoTryFinallyOne;
var
failed : boolean;
begin
Write('Try..Finally with exception rise in finally block...');
global_counter:=0;
failed:=true;
Try
IncrementCounter(global_counter);
DecrementCounter(global_counter);
finally
RaiseAnException;
end;
end;
Begin
DoTryFinallyOne;
end.
{
$Log$
Revision 1.1 2002-08-03 11:05:14 carl
+ exception handling testing
(still missing raise / on node testing)
}

108
tests/test/cg/ttryfin4.pp Normal file
View File

@ -0,0 +1,108 @@
{ %RESULT=217 }
{****************************************************************}
{ CODE GENERATOR TEST PROGRAM }
{ By Carl Eric Codere }
{****************************************************************}
{ NODE TESTED : secondtryfinally() }
{ secondraise() }
{****************************************************************}
{ PRE-REQUISITES: secondload() }
{ secondassign() }
{ secondtypeconv() }
{ secondtryexcept() }
{ secondcalln() }
{ secondadd() }
{****************************************************************}
{ DEFINES: }
{ FPC = Target is FreePascal compiler }
{****************************************************************}
{****************************************************************}
program ttryfin4;
{$ifdef fpc}
{$mode objfpc}
{$endif}
Type
TAObject = class(TObject)
a : longint;
end;
TBObject = Class(TObject)
b : longint;
end;
{ The test cases were taken from the SAL internal architecture manual }
procedure fail;
begin
WriteLn('Failure.');
halt(1);
end;
var
global_counter : integer;
Procedure raiseanexception;
Var A : TAObject;
begin
{ Writeln ('Creating exception object');}
A:=TAObject.Create;
{ Writeln ('Raising with this object');}
raise A;
{ this should never happen, if it does there is a problem! }
RunError(255);
end;
procedure IncrementCounter(x: integer);
begin
Inc(global_counter);
end;
procedure DecrementCounter(x: integer);
begin
Dec(global_counter);
end;
{ }
Procedure DoTryFinallyOne;
var
failed : boolean;
begin
Write('Try..Finally nested block with exception rise in finally block...');
global_counter:=0;
failed:=true;
Try
Try
IncrementCounter(global_counter);
IncrementCounter(global_counter);
finally
RaiseAnException;
end;
finally
if global_counter = 2 then
failed :=false;
if failed then
fail
else
WriteLn('Success!');
end;
end;
Begin
DoTryFinallyOne;
end.
{
$Log$
Revision 1.1 2002-08-03 11:05:14 carl
+ exception handling testing
(still missing raise / on node testing)
}