Ticket #9123: tstack.pp

File tstack.pp, 1.2 KB (added by fpcmuller, 9 years ago)

Source of the endless test

Line 
1{$S+}
2
3{ Program to check that an infinite recursion
4 does generate a RTE ... }
5
6{$R-}
7{ make that recursion really infinite
8 needs that range check is disabled }
9
10const
11 level : longint = 0;
12
13function inf_rec(x : longint) : longint;
14
15begin
16 inc(level);
17 inf_rec:=x+inf_rec(x-1);
18end;
19
20
21const
22 saveexit : pointer = nil;
23 x : longint = 0;
24
25{$S-}
26{ the stack overflowed already so don't do much here and depend on stack_margin }
27procedure stack_check_exit;
28
29begin
30 exitproc:=saveexit;
31 if errorcode<>0 then
32 begin
33 Writeln('An error occured at level ',level);
34 if errorcode=202 then
35 begin
36 Writeln('Stack overflow correctly handled');
37 erroraddr:=nil;
38 errorcode:=0;
39 exitcode:=0;
40 end
41 else if errorcode=216 then
42 begin
43 Writeln('RTL returns an RTE 216 on stack overflow');
44 Writeln('Not perfect, but acceptable');
45 erroraddr:=nil;
46 errorcode:=0;
47 exitcode:=0;
48 end;
49 end
50 else
51 begin
52 exitcode:=1;
53 errorcode:=1;
54 end;
55 exitproc:=saveexit;
56end;
57
58begin
59 saveexit:=exitproc;
60 exitproc:=@stack_check_exit;
61 x:=inf_rec(5000);
62end.