1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
{$J+}
unit erroru;
interface
procedure do_error(l : longint);
procedure error;
procedure accept_error(num : longint);
procedure require_error(num : longint);
function DoMem (Var StartMem : sizeint): sizeint;
implementation
const
program_has_error : boolean = false;
accepted_error_num : longint = 0;
required_error_num : longint = 0;
procedure do_error(l : longint);
begin
writeln('Error near: ',l);
halt(100);
end;
procedure error;
begin
Writeln('Error in ',paramstr(0));
program_has_error:=true;
end;
procedure accept_error(num : longint);
begin
accepted_error_num:=num;
end;
procedure require_error(num : longint);
begin
required_error_num:=num;
accepted_error_num:=num;
end;
procedure error_unit_exit;
begin
if exitcode<>0 then
begin
if (required_error_num<>0) and (exitcode<>required_error_num) then
begin
Write('Program ',paramstr(0));
Write(' exited with error ',exitcode,' whereas error ');
Writeln(required_error_num,' was expected');
Halt(1);
end
else if exitcode<>accepted_error_num then
begin
Write('Program ',paramstr(0));
Write(' exited with error ',exitcode,' whereas only error ');
Writeln(accepted_error_num,' was expected');
Halt(1);
end;
end
else if required_error_num<>0 then
begin
Write('Program ',paramstr(0));
Write(' exited without error whereas error ');
Writeln(required_error_num,' was expected');
Halt(1);
end;
if program_has_error then
Halt(1)
else
begin
exitcode:=0;
erroraddr:=nil;
end;
end;
function DoMem (Var StartMem : sizeint): sizeint;
function getsize(l:sizeint):string;
begin
if l<16*1024 then
begin
str(l,getsize);
getsize:=getsize+' bytes';
end
else
begin
str(l shr 10,getsize);
getsize:=getsize+' Kb';
end;
end;
var
hstatus : TFPCHeapstatus;
begin
hstatus:=GetFPCHeapStatus;
if StartMem=0 then
begin
Writeln ('[HEAP] Size: ',getsize(hstatus.CurrHeapSize),', Used: ',getsize(hstatus.CurrHeapUsed));
DoMem:=0;
end
else
begin
Writeln ('[HEAP] Size: ',getsize(hstatus.CurrHeapSize),', Used: ',getsize(hstatus.CurrHeapUsed),
', Lost: ',getsize(hstatus.CurrHeapUsed-StartMem));
DoMem:=hstatus.CurrHeapUsed-StartMem;
end;
StartMem:=hstatus.CurrHeapUsed;
end;
initialization
finalization
error_unit_exit;
end.
|
