Ich schrieb eine, die ich sehr oft verwendet habe, aber ich habe es nie verteilt. Hier ist es (das nicht enthaltene base_pkg hat meistens to_string() Implementierungen für alles).
-- Copyright © 2010 Wesley J. Landaker <[email protected]>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
-- Output is standard TAP (Test Anything Protocol) version 13
package test_pkg is
procedure test_redirect(filename : string);
procedure test_plan(tests : natural; directive : string := "");
procedure test_abort(reason : string);
procedure test_finished(directive : string := "");
procedure test_comment (message : string);
procedure test_pass (description : string := ""; directive : string := "");
procedure test_fail (description : string := ""; directive : string := "");
procedure test_ok (result : boolean; description : string := ""; directive : string := "");
procedure test_equal(actual, expected : integer; description : string := ""; directive : string := "");
procedure test_equal(actual, expected : real; description : string := ""; directive : string := "");
procedure test_equal(actual, expected : time; description : string := ""; directive : string := "");
procedure test_equal(actual, expected : string; description : string := ""; directive : string := "");
procedure test_equal(actual, expected : bit_vector; description : string := ""; directive : string := "");
procedure test_approx_absolute(actual, expected, absolute_error : real; description : string := ""; directive : string := "");
procedure test_approx_relative(actual, expected, relative_error : real; description : string := ""; directive : string := "");
end package;
use std.textio.all;
use work.base_pkg.all;
package body test_pkg is
file test_output : text;
shared variable initialized : boolean := false;
shared variable have_plan : boolean := false;
shared variable last_test_number : natural := 0;
function remove_eol(s : string) return string is
variable s_no_eol : string(s'range);
begin
for i in s'range loop
case s(i) is
when LF | CR => s_no_eol(i) := '_';
when others => s_no_eol(i) := s(i);
end case;
end loop;
return s_no_eol;
end function;
function make_safe (s : string) return string is
variable s_no_hash : string(s'range);
begin
for i in s'range loop
case s(i) is
when '#' => s_no_hash(i) := '_';
when others => s_no_hash(i) := s(i);
end case;
end loop;
return remove_eol(s_no_hash);
end function;
procedure init is
variable l : line;
begin
if initialized then
return;
end if;
initialized := true;
file_open(test_output, "STD_OUTPUT", write_mode);
write(l, string'("TAP version 13"));
writeline(test_output, l);
end procedure;
procedure test_redirect(filename : string) is
begin
init;
file_close(test_output);
file_open(test_output, filename, write_mode);
end procedure;
procedure test_plan(tests : natural; directive : string := "") is
variable l : line;
begin
init;
have_plan := true;
write(l, string'("1.."));
write(l, tests);
if directive'length > 0 then
write(l, " # " & remove_eol(directive));
end if;
writeline(test_output, l);
end procedure;
procedure test_abort(reason : string) is
variable l : line;
begin
init;
write(l, "Bail out! " & remove_eol(reason));
writeline(test_output, l);
assert false
report "abort called"
severity failure;
end procedure;
procedure test_finished (directive : string := "") is
begin
if not have_plan then
test_plan(last_test_number, directive);
elsif directive'length > 0 then
test_comment("1.." & integer'image(last_test_number) & " # " & directive);
else
test_comment("1.." & integer'image(last_test_number));
end if;
end procedure;
procedure test_comment (message : string) is
variable l : line;
begin
init;
write(l, '#');
if message'length > 0 then
write(l, " " & remove_eol(message));
end if;
writeline(test_output, l);
end procedure;
procedure result (status : string; description : string; directive : string) is
variable l : line;
begin
init;
last_test_number := last_test_number + 1;
write(l, status & " ");
write(l, last_test_number);
if description'length > 0 then
write(l, " " & make_safe(description));
end if;
if directive'length > 0 then
write(l, " # " & remove_eol(directive));
end if;
writeline(test_output, l);
end procedure;
procedure test_pass (description : string := ""; directive : string := "") is
begin
result("ok", description, directive);
end procedure;
procedure test_fail (description : string := ""; directive : string := "") is
begin
result("not ok", description, directive);
end procedure;
procedure test_ok (result : boolean; description : string := ""; directive : string := "") is
begin
if result then
test_pass(description, directive);
else
test_fail(description, directive);
end if;
end procedure;
procedure test_equal(actual, expected : integer; description : string := ""; directive : string := "") is
variable ok : boolean := actual = expected;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & integer'image(actual) & ", expected = " & integer'image(expected));
end if;
end procedure;
procedure test_equal(actual, expected : real; description : string := ""; directive : string := "") is
variable ok : boolean := actual = expected;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & real'image(actual) & ", expected = " & real'image(expected));
end if;
end procedure;
procedure test_equal(actual, expected : time; description : string := ""; directive : string := "") is
variable ok : boolean := actual = expected;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & time'image(actual) & ", expected = " & time'image(expected));
end if;
end procedure;
procedure test_equal(actual, expected : string; description : string := ""; directive : string := "") is
variable ok : boolean := actual = expected;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & actual & ", expected = " & expected);
end if;
end procedure;
procedure test_equal(actual, expected : bit_vector; description : string := ""; directive : string := "") is
variable ok : boolean := actual = expected;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & to_string(actual) & ", expected = " & to_string(expected));
end if;
end procedure;
procedure test_approx_absolute(actual, expected, absolute_error : real; description : string := ""; directive : string := "") is
variable err : real := abs(actual - expected);
variable ok : boolean := err <= absolute_error;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & to_string(actual) & ", expected = " & to_string(expected) & ", absolute error = " & to_string(err));
end if;
end procedure;
procedure test_approx_relative(actual, expected, relative_error : real; description : string := ""; directive : string := "") is
variable err : real := abs(actual - expected)/abs(expected);
variable ok : boolean := err <= relative_error;
begin
test_ok(ok, description, directive);
if not ok then
test_comment("actual = " & to_string(actual) & ", expected = " & to_string(expected) & ", relative error = " & to_string(err));
end if;
end procedure;
end package body;