view release on metacpan or  search on metacpan

lib/Zero/Emulator.pm  view on Meta::CPAN

  $pack
 }

sub disAssemble($)                                                              # Disassemble machine code.
 {my ($mc) = @_;                                                                # Machine code string

  my $C = Code;

  my $n = length($mc) / 32;                                                     # The instructions are formatted into 32 byte blocks
  for my $i(1..$n)
   {my $c = substr($mc, ($i-1)*32, 32);
    my $i = $C->instruction
     (action=>  unpackInstruction(substr($c,  0, 8)),
      target=>  $C->unpackRef    (substr($c,  8, 8)),
      source=>  $C->unpackRef    (substr($c, 16, 8)),
      source2=> $C->unpackRef    (substr($c, 24, 8)));
   }
  $C
 }

sub disAssembleMinusContext($)                                                  #P Disassemble and remove context information from disassembly to make testing easier.
 {my ($D) = @_;                                                                 # Machine code string

  my $d = disAssemble  $D;

  for my $c($d->code->@*)                                                       # Remove context fields
   {delete @$c{qw(context executed file line number)};
    delete $$c{$_}{name} for qw(target source source2);
   }

  delete @$d{qw(assembled files labelCounter labels procedures variables)};

  $d
 }

sub GenerateMachineCodeDisAssembleExecute(%)                                    #i Round trip: generate machine code and write it onto a string, disassemble the generated machine code string and recreate a block of code from it, then execute the reco...
 {my (%options) = @_;                                                           # Options
  my $m = GenerateMachineCode;
  my $M = disAssemble $m;
     $M->execute(checkArrayNames=>0,  %options);
 }

#D0

use Exporter qw(import);
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

@ISA         = qw(Exporter);
@EXPORT      = qw();
@EXPORT_OK   = qw(GenerateMachineCodeDisAssembleExecute Add Array ArrayCountGreater ArrayCountLess ArrayDump ArrayIndex ArraySize Assert AssertEq AssertFalse AssertGe AssertGt AssertLe AssertLt AssertNe AssertTrue Bad Block Call Clear Confess Dec Dum...
%EXPORT_TAGS = (all=>[@EXPORT, @EXPORT_OK]);

return 1 if caller;

# Tests

#Test::More->builder->output("/dev/null");                                       # Reduce number of confirmation messages during testing

my $debug = -e q(/home/phil/);                                                  # Assume debugging if testing locally
sub is_deeply;
sub ok($;$);
sub x {exit if $debug}                                                          # Stop if debugging.
Test::More->builder->output("/dev/null");                                       # Reduce number of confirmation messages during testing

=pod

Tests are run using different combinations of execution engine and memory
manager to prove that different implementations produce the same results.

=cut

for my $testSet(1..4) {                                                         # Select various combinations of execution engine and memory handler
say STDOUT "TestSet: $testSet";
my $ee = $testSet % 2 ? \&Execute :                                             # Assemble and execute
                        \&GenerateMachineCodeDisAssembleExecute;                # Generate machine code, load code and execute

$memoryTechnique = $testSet <= 2 ? undef : \&setStringMemoryTechnique;          # Set memory allocation technique

eval {goto latest if $debug};

#latest:;
if (1)                                                                          ##Out ##Start ##Execute
 {Start 1;
  Out "Hello", "World";
  my $e = Execute(suppressOutput=>1);
  is_deeply $e->out, <<END;
Hello World
END
 }

#latest:;
if (1)                                                                          ##Var
 {Start 1;
  my $a = Var 22;
  AssertEq $a, 22;
  my $e = &$ee(suppressOutput=>1);
  is_deeply $e->out, "";
 }

#latest:;
if (1)                                                                          ##Nop
 {Start 1;
  Nop;
  my $e = &$ee;
  is_deeply $e->out, "";
 }

#latest:;
if (1)                                                                          ##Mov
 {Start 1;
  my $a = Mov 2;
  Out $a;
  my $e = &$ee(suppressOutput=>1);
  is_deeply $e->out, <<END;
2
END
 }

#latest:;
if (1)
 {Start 1;                                                                      ##Mov