paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-03 13:30:55 +02:00
Code Issues Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
florian 2000-02-06 15:45:12 +00:00
parent 340c0d2772
commit 9d71810663
4 changed files with 393 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
tests/test/dotest.pp Normal file
View File

@ -0,0 +1,20 @@
unit dotest;
interface
{$ifdef go32v2}
uses
dpmiexcp;
{$endif go32v2}
procedure do_error(l : longint);
implementation
procedure do_error(l : longint);
begin
writeln('Error near: ',l);
halt(100);
end;
end.

7
tests/test/readme.txt Normal file
View File

@ -0,0 +1,7 @@
This directory contains tests for several parts of the compiler:
The tests ordered how they should be executed
Ansistrings .................. testansi.pp
Classes ...................... testdom.pp
Exceptions ................... testexc.pp
testexc2.pp

28
tests/test/testexc2.pp Normal file
View File

@ -0,0 +1,28 @@
{$mode objfpc}
uses
dotest,
sysutils;
procedure d;
var
d1 : double;
begin
d1:=0;
d1:=1/d1;
end;
var
i : longint;
begin
d;
for i:=1 to 20 do
try
d;
except
on exception do
;
end;
end.

338
tests/test/testexc3.pp Normal file
View File

@ -0,0 +1,338 @@
uses
dotest;
var
i : longint;
procedure test1;
begin
try
i:=0;
exit;
finally
inc(i);
end;
i:=-2;
end;
procedure test2;
begin
try
i:=0;
raise exception.create('');
finally
inc(i);
end;
i:=-2;
end;
procedure test3;
begin
try
try
i:=0;
raise exception.create('');
finally
inc(i);
end;
finally
inc(i);
end;
i:=-2;
end;
procedure test4;
begin
try
try
i:=0;
exit;
finally
inc(i);
end;
finally
inc(i);
end;
i:=-2;
end;
procedure test5;
var
j : longint;
begin
for l:=1 to 10 do
begin
try
i:=0;
break;
finally
inc(i);
end;
dec(i);
end;
end;
procedure test6;
var
j : longint;
begin
i:=0;
for l:=1 to 10 do
try
continue;
finally
inc(i);
end;
dec(i);
end;
end;
procedure test7;
var
j : longint;
begin
for j:=1 to 10 do
begin
try
try
i:=0;
break;
finally
inc(i);
end;
dec(i);
finally
inc(i);
end;
end;
end;
procedure test8;
var
j : longint;
begin
i:=0;
for j:=1 to 10 do
begin
try
try
continue;
finally
inc(i);
end;
finally
inc(i);
end;
dec(i);
end;
end;
{ some combined test ... }
procedure test9;
var
j : longint;
begin
try
i:=0;
finally
for j:=1 to 10 do
begin
try
if j<2 then
continue
else
break;
finally
inc(i);
end;
dec(i);
end;
end;
end;
procedure test10;
var
j : longint;
begin
try
i:=0;
j:=1;
finally
while j<=10 do
begin
try
if j<2 then
continue
else
break;
finally
inc(i);
inc(j);
end;
dec(i);
end;
end;
end;
{ the do_raise function is a little bit more complicated }
{ so we also check if memory is lost }
function do_raise : ansistring;
var
a1,a2 : ansistring;
begin
for i:=1 to 3 do
begin
a1:=copy('Hello world',1,5);
do_raise:=copy(a2,1,1);
end;
raise exception.create('A string to test memory allocation');
do_error(99998);
end;
{ now test real exceptions }
procedure test100;
begin
try
i:=0;
do_raise;
except
inc(i);
end;
end;
procedure test101;
begin
try
try
i:=0;
do_raise;
except
inc(i);
do_raise;
end;
except
inc(i);
end;
end;
procedure test102;
begin
try
try
i:=0;
do_raise;
except
inc(i);
reraise;
end;
except
inc(i);
end;
end;
var
startmemvail : longint;
begin
startmemavail:=memavail;
i:=-1;
try
test1;
except
inc(i);
end;
if i<>2 then
do_error(1001);
i:=-1;
test2;
if i<>1 then
do_error(1002);
i:=-1;
try
test3;
except
inc(i);
end;
if i<>3 then
do_error(1003);
i:=-1;
test4;
if i<>2 then
do_error(1004);
i:=-1;
test5;
if i<>1 then
do_error(1005);
i:=-1;
test6;
if i<>10 then
do_error(1006);
i:=-1;
test7;
if i<>2 then
do_error(1007);
i:=-1;
test8;
if i<>20 then
do_error(1008);
i:=-1;
test9;
if i<>2 then
do_error(1009);
i:=-1;
test10;
if i<>2 then
do_error(1010);
i:=-1;
test100;
if i<>1 then
do_error(1100);
i:=-1;
test101;
if i<>2 then
do_error(1101);
i:=-1;
test102;
if i<>2 then
do_error(1102);
if memavail<>startmemvail then
do_error(99999);
halt(0);
end.