library std;
library ieee; 

use std.textio.all;
use ieee.std_logic_1164.all;
use ieee.std_logic_arith.all;

package test_pkg is

   subtype SLV4    is std_logic_vector(3 downto 0);
   type lprint_radix_t is (BIN, OCT, DEC, HEX);
   subtype hex_t is integer range 0 to 15;

--pragma translate_off
   procedure echo (
      constant str      : in string
   );
--pragma translate_on   

   function ctov4 (
      constant c     : in character
   ) return slv4;

   function htov (
      constant s  : in string;
      l           : integer
   ) return std_logic_vector;

   procedure lprint ( 
      variable l        : inout line;
      constant x        : in std_logic;
      constant b        : in lprint_radix_t := BIN
   );

   procedure lprint ( 
      variable l        : inout line;
      constant x        : in std_logic_vector;
      constant b        : in lprint_radix_t := BIN
   );

   procedure lprint ( 
      variable l        : inout line;
      constant x        : in integer;
      constant b        : in lprint_radix_t := BIN
   );

   function compare (   
      constant vectora  : in std_logic;
      constant vectorb  : in std_logic
   ) return boolean;

   function compare (   
      constant vectora     : in std_logic_vector;
      constant vectorb     : in std_logic_vector
   ) return boolean;

   procedure data_fail (
      constant where    : in string;
      constant addr     : in std_logic_vector;
      constant data     : in std_logic_vector;
      constant exp_data : in std_logic_vector;
      fail_on_err       : in boolean
   );

-- pragma translate_on
end test_pkg;


package body test_pkg is

--pragma translate_off

   ---------------------------
   -- echo out line to stdout
   ---------------------------
   procedure echo(
      constant str : in string
       ) is
    variable l: line;
   begin
      write(l, string'("<"));
      write(l, time'(now));
      write(l, string'("> "));
      write(l, str);
      writeline(output,l);
   end echo;
   
--pragma translate_on   

   ------------------------------------------------------------------
       -- convert hex digit to std_logic_vector(3 downto 0);
   ------------------------------------------------------------------

   function ctov4 (
                constant c : in character
               ) return slv4 is
       variable r : std_logic_vector(3 downto 0);
     begin
       case c is
         when '0' => r := "0000";
         when '1' => r := "0001";
         when '2' => r := "0010";
         when '3' => r := "0011";
         when '4' => r := "0100";
         when '5' => r := "0101";
         when '6' => r := "0110";
         when '7' => r := "0111";
         when '8' => r := "1000";
         when '9' => r := "1001";
         when 'a'|'A' => r := "1010";
         when 'b'|'B' => r := "1011";
         when 'c'|'C' => r := "1100";
         when 'd'|'D' => r := "1101";
         when 'e'|'E' => r := "1110";
         when 'f'|'F' => r := "1111";
         when 'z'|'Z' => r := "ZZZZ";
         when 'x'|'X' => r := "XXXX";
       when others => r:= "UUUU";
     end case;
     return r;
   end;

   -------------------------------------------
   -- convert hex string to std_logic_vector;
   -------------------------------------------

   function htov (
      constant s        : in string; 
      l                 : integer
   ) return std_logic_vector is
      variable v4       : std_logic_vector(3 downto 0);
      variable r        : std_logic_vector(l-1 downto 0);
   begin
      assert s'left <= s'right
      report "htov: string range must be descending" severity FAILURE;

      if l < 1 then
         assert false
         report "htov: length must be positive" severity FAILURE;
      end if;

      r := (others => '0');
      for i in s'range loop
         exit when s(i) = NUL;
         v4 := ctov4(s(i));
         if l > 4 then 
            r := r(l-5 downto 0) & v4;
         elsif l = 4 then 
            r:= v4;
         else 
            r:= v4(l-1 downto 0);
         end if;
      end loop;
      return r;
   end;

--pragma translate_off

   ----------------------------------------
   -- convert input integer into character
   ----------------------------------------

   function tochar (constant x : hex_t) return character
   is
      variable res      : character;
   begin
      if x < 10 then
         res := character'val(character'pos('0') + x);
      else
         res := character'val(character'pos('A') + (x-10));
      end if;
      return res;
   end tochar;

   -----------------------------------------
   -- convert input std_logic into character
   -----------------------------------------

   function tochar (constant x : std_logic) return character
   is
      variable res      : character;
   begin
      case x is
         when '0' => res := '0';
         when '1' => res := '1';
         when 'X' => res := 'X';
         when 'Z' => res := 'Z';
         when 'L' => res := 'L';
         when 'H' => res := 'H';
         when 'W' => res := 'W';
         when 'U' => res := 'U';
         when '-' => res := '-';
         when others =>
            assert false report "tochar: unknown bit value" severity error;
      end case;
      return res;
   end tochar;

   --------------------------------------------------------------
   -- convert input std_logic_vector(3:0) or less into character
   --------------------------------------------------------------

   function tochar (constant x : std_logic_vector) return character
   is
      variable res         : character;
      variable dval, i     : natural;
      variable isX         : boolean;
      alias r              : std_logic_vector (x'length-1 downto 0) is x;
   begin
      assert x'length <= 4 report "tochar: argument must be <= 4 bits"
      severity ERROR;
      dval := 0;
      i := 1;
      isX := FALSE;
      for j in r'right to r'left loop
         case x(j) is
            when '0' | 'L' => null;
            when '1' | 'H' => dval := dval + i;
            when others => isX := TRUE;
         end case;
         exit when isX;
         i := i * 2;
      end loop;
      if isX then
         res := 'X';
      else
         assert dval <= 15 report "tochar: argument is > 16" severity error;
         res := tochar (dval);
      end if;
      return res;
   end tochar;

   ---------------------------------------------------
   -- write input integer into radix format to line
   ---------------------------------------------------

   procedure lprint (
      variable l     : inout LINE; 
      constant x     : in integer; 
      constant b     : in lprint_radix_t := BIN 
   ) is
      variable bb, look, last, xx   : integer;
   begin
      if b = DEC then write(l, x);
      elsif x=0 then write(l, x);
      else
         -- cheap way to handle negatives
         xx := x;
         if xx < 0 then
            write (l, character'('-'));
            xx := -xx;
         end if;
         case b is
            when BIN => bb := 2;
            when HEX => bb := 16;
            when OCT => bb := 8;
            when others =>
            assert FALSE report "lprint: unknown radix" severity ERROR;
         end case;
         -- find highest divisor
         last := 1;
         look := bb;
         while look <= xx loop
            last := look;
            look := look * bb;
         end loop; 
         while last > 0 loop
            look := xx / last;
            write (l, character'(tochar(look)));
            xx := xx - (look * last);
            last := last / bb;
         end loop;
      end if;
   end lprint;

   ---------------------------------------------------
   -- write input std_logic into radix format to line
   ---------------------------------------------------

  procedure lprint (
      variable l     : inout LINE; 
      constant x     : in std_logic;
      constant b     : in lprint_radix_t := BIN 
   ) is
   begin
      write (l, tochar(x)); 
   end lprint;

   ----------------------------------------------------------
   -- write input std_logic_vector into radix format to line
   ----------------------------------------------------------

  procedure lprint (
      variable l     : inout LINE; 
      constant x     : in std_logic_vector; 
      constant b     : in lprint_radix_t := BIN 
   ) is
      variable bs          : std_logic_vector (3 downto 0);
      constant zero        : std_logic_vector (3 downto 0) := "0000";
      variable bb          : std_logic;
      alias xr             : std_logic_vector (x'length-1 downto 0) is x;
      variable binsize     : integer; 
      variable numbins     : integer;
      variable hangover,j  : integer;
   begin
      if b=BIN then
         for i in x'range loop
            bb := x(i); 
            lprint (l, bb);
         end loop;
      else
         case b is
            when OCT => binsize := 3;
            when HEX => binsize := 4;
            when others =>
               assert FALSE report "lprint: unsupported radix" severity ERROR;
         end case;
         numbins := x'length / binsize;
         hangover := x'length REM binsize;
         j := xr'left;
         -- take care of leading part, if any
         if hangover > 0 then
            bs := zero;
            for i in hangover-1 downto 0 loop
               bs(i) := xr(j);
               j := j-1;
            end loop;
            write (l, tochar(bs));
         end if;
         while j >= 0 loop
            for i in binsize-1 downto 0 loop
               bs(i) := xr(j);
               j := j - 1;
            end loop;
            write (l, tochar(bs));
         end loop;
      end if;
   end lprint;

   -------------------------------------------------------------------
   -- compare two std_logic values, std_logic B don't care value is X
   -------------------------------------------------------------------

   function compare (   
      constant vectora  : in std_logic;
      constant vectorb  : in std_logic
   ) return boolean is
      variable tmpveca  : std_logic;
      variable tmpvecb  : std_logic;
      variable exitval  : boolean;
   begin
      exitval := false;
      case vectora is
         when 'H' => tmpveca := '1';
         when 'L' => tmpveca := '0';
         when others => tmpveca := vectora;
      end case;
      case vectorb is
         when 'H' => tmpvecb := '1';
         when 'L' => tmpvecb := '0';
         when others => tmpvecb := vectorb;
      end case;
      if ((tmpvecb /= 'X') and (tmpveca /= tmpvecb)) then
         exitval := true;
      end if;
      return exitval;
   end compare;

   -----------------------------------------------------------------------
   -- compare two std_logic_vector values, vector B don't care value is X
   -----------------------------------------------------------------------

   function compare (   
      constant vectora  : in std_logic_vector;
      constant vectorb  : in std_logic_vector
   ) return boolean is
      variable tmpveca  : std_logic_vector((vectora'length-1) downto 0);
      variable tmpvecb  : std_logic_vector((vectorb'length-1) downto 0);
      variable exitval  : boolean;
      variable b        : integer;
   begin
      exitval := false;
      if (vectora'length) /= (vectorb'length) then
         assert false report "logic_compare: vectors not same size"
         severity failure;
      end if;
      b := 0;
      for i in vectora'range loop
         case vectora(i) is
            when 'H' => tmpveca(b) := '1';
            when 'L' => tmpveca(b) := '0';
            when others => tmpveca(b) := vectora(i);
         end case;
         b := b + 1;
      end loop;
      b := 0;
      for i in vectorb'range loop
         case vectorb(i) is
            when 'H' => tmpvecb(b) := '1';
            when 'L' => tmpvecb(b) := '0';
            when others => tmpvecb(b) := vectorb(i);
         end case;
         b := b + 1;
      end loop;
      spewloop: for i in 0 to vectora'length-1 loop
         if ((tmpvecb(i) /= 'X') and (tmpveca(i) /= tmpvecb(i))) then
            exitval := true;
            exit spewloop;
         end if;
      end loop spewloop;
      return exitval;
   end compare;

   -------------------------------------------------
   -- procedure to complain about a data comparison
   -------------------------------------------------

   procedure data_fail (
      constant where    : in string;
      constant addr     : in std_logic_vector;
      constant data     : in std_logic_vector;
      constant exp_data : in std_logic_vector;
      fail_on_err       : in boolean
   ) is
      variable l        : line;
   begin
      write(l, string'("<"));
      write(l, time'(now));
      write(l, string'("> "));
      write(l, where);
      write(l, string'(", address: "));
      lprint(l, addr, HEX);
      write(l, string'(" expected: ")); 
      lprint(l, exp_data, HEX);
      write(l, string'("  actual: ")); 
      lprint(l, data, HEX);
      writeline(output, l);
      if (fail_on_err) then
         assert false report "data miscompare" severity FAILURE;
      else
         assert false report "data miscompare" severity ERROR;
      end if;
   end;

--pragma translate_on
end test_pkg;