t/App-Scheme79asm.t

   1 #!/usr/bin/perl
   2 use strict;
   3 use warnings;
   4
   5 use Test::More tests => 17;
   6 BEGIN { use_ok('App::Scheme79asm') };
   7
   8 sub run_test {
   9         my ($args, $input, $expected_verilog, $expected_binary16, $name) = @_;
  10         my ($actual, $fh, $asm);
  11         open $fh, '>', \$actual;
  12         $asm = App::Scheme79asm->new(%$args);
  13         $asm->parse_and_print_binary16($input, $fh);
  14         close $fh;
  15         $actual = uc join ' ', unpack '(H2)*', $actual;
  16         is $actual, $expected_binary16, "print_binary16 $name";
  17
  18         open $fh, '>', \$actual;
  19         $asm = App::Scheme79asm->new(%$args);
  20         $asm->parse_and_print_verilog($input, $fh);
  21         close $fh;
  22         is $actual, $expected_verilog, "print_verilog $name";
  23 }
  24
  25 my $expbin;
  26
  27 $expbin = '00 07 00 00 00 00 01 00 01 00 00 07 01 03 00 00';
  28
  29 run_test {}, '(number 3)', <<'EOF', $expbin, '3';
  30 mem[0] <= 0;                // (cdr part of NIL)
  31 mem[1] <= 0;                // (car part of NIL)
  32 mem[2] <= 11'b00100000000;  // (cdr part of T)
  33 mem[3] <= 11'b00100000000;  // (car part of T)
  34 mem[4] <= 11'd7;            // (free storage pointer)
  35 mem[5] <= 11'b00100000011;  // NUMBER 3
  36 mem[6] <= 0;                // (result of computation)
  37 EOF
  38
  39 $expbin = '00 08 00 00 00 00 00 20 00 20 00 08 00 E7 00 00 00 25';
  40
  41 run_test {addr_bits => 5}, '(quoted (symbol 5))', <<'EOF', $expbin, '(QUOTE 5)';
  42 mem[0] <= 0;             // (cdr part of NIL)
  43 mem[1] <= 0;             // (car part of NIL)
  44 mem[2] <= 8'b00100000;   // (cdr part of T)
  45 mem[3] <= 8'b00100000;   // (car part of T)
  46 mem[4] <= 8'd8;          // (free storage pointer)
  47 mem[5] <= 8'b11100111;   // QUOTED 7
  48 mem[6] <= 0;             // (result of computation)
  49 mem[7] <= 8'b00100101;   // SYMBOL 5
  50 EOF
  51
  52 $expbin = '00 0C 00 00 00 00 20 00 20 00 00 0C C0 07 00 00 00 09 20 05 E0 00 80 0B 5F FE';
  53 run_test {addr_bits => 13}, '(call (more (funcall 0) (proc (var -2))) (number 5))', <<'EOF', $expbin, '((LAMBDA ID (X) X) 5)';
  54 mem[ 0] <= 0;                     // (cdr part of NIL)
  55 mem[ 1] <= 0;                     // (car part of NIL)
  56 mem[ 2] <= 16'b0010000000000000;  // (cdr part of T)
  57 mem[ 3] <= 16'b0010000000000000;  // (car part of T)
  58 mem[ 4] <= 16'd12;                // (free storage pointer)
  59 mem[ 5] <= 16'b1100000000000111;  // CALL 7
  60 mem[ 6] <= 0;                     // (result of computation)
  61 mem[ 7] <= 16'b0000000000001001;  // MORE 9
  62 mem[ 8] <= 16'b0010000000000101;  // NUMBER 5
  63 mem[ 9] <= 16'b1110000000000000;  // FUNCALL 0
  64 mem[10] <= 16'b1000000000001011;  // PROC 11
  65 mem[11] <= 16'b0101111111111110;  // VAR -2
  66 EOF
  67
  68 my %test = (
  69         addr_bits => 13,
  70         type_bits => 3,
  71         memory => [0, 1, 2, 3, 4, 5, 6, 7, 8, 9],
  72         freeptr => 9
  73 );
  74
  75 $expbin = '00 0E 00 00 00 01 00 02 00 03 00 0E C0 0A 00 06 00 07 00 08 00 09 00 0C 20 0A 60 00 20 0B';
  76
  77 run_test \%test, '(call (more (cons 0) (number 11)) (number 10))', <<'EOF', $expbin, '(CONS 10 11)';
  78 mem[ 0] <= 0;                     // (cdr part of NIL)
  79 mem[ 1] <= 16'b0000000000000001;  // (car part of NIL)
  80 mem[ 2] <= 16'b0000000000000010;  // (cdr part of T)
  81 mem[ 3] <= 16'b0000000000000011;  // (car part of T)
  82 mem[ 4] <= 16'd14;                // (free storage pointer)
  83 mem[ 5] <= 16'b1100000000001010;  // CALL 10
  84 mem[ 6] <= 16'b0000000000000110;  // (result of computation)
  85 mem[ 7] <= 16'b0000000000000111;
  86 mem[ 8] <= 16'b0000000000001000;
  87 mem[ 9] <= 16'b0000000000001001;
  88 mem[10] <= 16'b0000000000001100;  // MORE 12
  89 mem[11] <= 16'b0010000000001010;  // NUMBER 10
  90 mem[12] <= 16'b0110000000000000;  // CONS 0
  91 mem[13] <= 16'b0010000000001011;  // NUMBER 11
  92 EOF
  93
  94 sub expect_error_like (&$) {
  95         my ($block, $error_re) = @_;
  96         my $name = "test error like /$error_re/";
  97         my $result = eval { $block->(); 1 };
  98         if ($result) {
  99                 note 'Block did not throw an exception, failing test';
 100                 fail $name;
 101         } else {
 102                 like $@, qr/$error_re/, $name;
 103         }
 104 }
 105
 106 expect_error_like { run_test {}, 'symbol' } 'Toplevel is not a list';
 107 expect_error_like { run_test {}, '((type is a list) 5)'} 'Type of toplevel is not atom';
 108 expect_error_like { run_test {}, '(badtype 5)'} 'No such type';
 109 expect_error_like { run_test {}, '(number)'} 'Computed addr is not a number';
 110 expect_error_like { run_test {}, '(70000 5)'} 'Type too large';
 111 expect_error_like { run_test {}, '(5 700000)'} 'Addr too large';
 112 expect_error_like { run_test {addr_bits => 20}, '(list 0)' } 'addr_bits ';
 113 expect_error_like { App::Scheme79asm->new->process([5, {}]) } 'Addr of toplevel is not atom';