mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-11 16:48:12 +02:00
+ unified erroru unit for error generation
This commit is contained in:
parent
722ce4b7e9
commit
28e6c92973
71
tests/erroru.pp
Normal file
71
tests/erroru.pp
Normal file
@ -0,0 +1,71 @@
|
||||
unit erroru;
|
||||
|
||||
interface
|
||||
|
||||
procedure error;
|
||||
|
||||
procedure accept_error(num : longint);
|
||||
|
||||
procedure require_error(num : longint);
|
||||
|
||||
implementation
|
||||
|
||||
const program_has_error : boolean = false;
|
||||
|
||||
procedure error;
|
||||
begin
|
||||
Writeln('Error in ',paramstr(0));
|
||||
program_has_error:=true;
|
||||
end;
|
||||
|
||||
const
|
||||
store_exitproc : pointer = nil;
|
||||
accepted_error_num : longint = 0;
|
||||
required_error_num : longint = 0;
|
||||
|
||||
|
||||
procedure accept_error(num : longint);
|
||||
begin
|
||||
accepted_error_num:=num;
|
||||
end;
|
||||
|
||||
procedure require_error(num : longint);
|
||||
begin
|
||||
required_error_num:=num;
|
||||
end;
|
||||
|
||||
procedure error_unit_exit;
|
||||
begin
|
||||
exitproc:=store_exitproc;
|
||||
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);
|
||||
end;
|
||||
|
||||
begin
|
||||
store_exitproc:=exitproc;
|
||||
exitproc:=@error_unit_exit;
|
||||
end.
|
Loading…
Reference in New Issue
Block a user