package QNICE;

use strict;
use warnings;

use Bit::Vector::Overload;
 Bit::Vector->Configuration("in=hex,ops=arithmetic,out=hex");

use Carp;

use Data::Dumper;
 $Data::Dumper::Indent=1;

our $VERSION = 0.4;

## Export Settings
use base qw/Exporter/;

our @EXPORT_OK = qw/
   assemble
   disassemble
   init_code
   init_memory
   init_registers
   loadbin
   step
   @Status_Bits
/;

our %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );

use constant INSTR_SIZE     => 16;
use constant INSTR_SIZE_HEX => INSTR_SIZE >> 2;
use constant INSTR_SIZE_DEC => length(2 ** INSTR_SIZE);
use constant INSTR_FMT_HEX  => '0x%0' . INSTR_SIZE_HEX . 'x';
use constant REGISTERS      => 16;

## Paramter Definitions

our @Status_Bits = qw(1 X C Z N V I M);

my %Instructions = (
   HALT  => {
      OPCODE  => 0x0,
      OPCOUNT => -1,
   },
   MOVE => {
      OPCODE  => 0x1,
      OPCOUNT => 1,
      EXEC    => sub {
         my($m, $r, $p) = @_;
         my $left = _read_op($m, $r, $p->[0], 0);
         _update_status_register($left, $left, qw/C V/);
#         _write_op($m, $r, $left, $changed);
         return;
      },
   },
   ADD  => {
      OPCODE  => 0x2,
      OPCOUNT => 1,
      EXEC => sub {
         my($p, $use_carry, $c_in) = @_;
         return(
            $p->[0]{value}->add(
               $p->[1]{value},
               $p->[2]{value},
               0,
            )
         );
      },
   },
   ADDC  => {
      OPCODE  => 0x3,
      OPCOUNT => 1,
      EXEC => sub {
         my($p, $use_carry, $c_in) = @_;
         return(
            $p->[0]{value}->add(
               $p->[1]{value},
               $p->[2]{value},
               $c_in,
            )
         );
      },
   },
   SUB  => {
      OPCODE  => 0x4,
      OPCOUNT => 1,
      EXEC    => sub {
         my($p, $use_carry, $c_in) = @_;
         return(
            $p->[0]{value}->subtract(
               $p->[1]{value},
               $p->[2]{value},
               $use_carry && $c_in,
            )
         );
      },
   },
   SUBC  => {
      OPCODE  => 0x5,
      OPCOUNT => 1,
      EXEC    => sub {
         my($p, $use_carry, $c_in) = @_;
         return(
            $p->[0]{value}->subtract(
               $p->[1]{value},
               $p->[2]{value},
               $use_carry && $c_in,
            )
         );
      },
   },
   SHL  => {
      OPCODE  => 0x6,
      OPCOUNT => 1,
      EXEC => sub {
         my($p, $use_carry, $c_in) = @_;
         return(
            $p->[0]{value}->add(
               $p->[1]{value},
               $p->[1]{value} & $p->[2]{value},
               $use_carry && $c_in,
            )
         );
      },
   },
   SHR  => {
      OPCODE  => 0x7,
      OPCOUNT => 1,
      EXEC => sub {
         my($p, $use_carry, $c_in) = @_;
         return(
            $p->[0]{value}->add(
               $p->[1]{value},
               $p->[1]{value},
               $use_carry && $c_in,
            )
         );
      },
   },
   SWAP  => {
      OPCODE  => 0x8,
      OPCOUNT => 0,
      EXEC => sub {
         my($p) = @_;
         return(0, $p->[0]{value}->dec($p->[1]{value}));
      },
   },
   NEG  => {
      OPCODE  => 0x9,
      OPCOUNT => 1,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->Not($p->[1]{value});
         return;
      },
   },
   AND => {
      OPCODE  => 0xA,
      OPCOUNT => 1,
      EXEC => sub {
         my($p) = @_;
         $p->[1]{value}->Flip();
         $p->[0]{value}->And($p->[1]{value}, $p->[2]{value});
         return;
      },
   },
   OR => {
      OPCODE  => 0xB,
      OPCOUNT => 1,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->And($p->[1]{value}, $p->[2]{value});
         $p->[0]{value}->Flip();
         return;
      },
   },
   XOR  => {
      OPCODE  => 0xC,
      OPCOUNT => 1,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->Xor($p->[1]{value}, $p->[2]{value});
         return;
      },
   },
   ABRA => {
      OPCODE  => 0xD,
      OPCOUNT => 1,
      BTYPE   => 0,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->Xor($p->[1]{value}, $p->[2]{value});
         $p->[0]{value}->Flip();
         #my $exec_instr = $pi->{negate} ^ $reg->[14]->bit_test($pi->{cond} + 24);
         return;
      },
   },
   ASUB => {
      OPCODE  => 0xD,
      OPCOUNT => 1,
      BTYPE   => 1,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->And($p->[1]{value}, $p->[2]{value});
         return;
      },
   },
   RBRA => {
      OPCODE  => 0xD,
      OPCOUNT => 1,
      BTYPE   => 2,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->And($p->[1]{value}, $p->[2]{value});
         return;
      },
   },
   RSUB => {
      OPCODE  => 0xD,
      OPCOUNT => 1,
      BTYPE   => 3,
      EXEC => sub {
         my($p) = @_;
         $p->[0]{value}->And($p->[1]{value}, $p->[2]{value});
         return;
      },
   },
);


my %Opcode_Names = map {
   $Instructions{$_}{OPCODE} => $_
} keys(%Instructions);

my %Branch_Ops = map {
   ($Instructions{$_}{OPCODE} == 0xD) ?
   ($Instructions{$_}{BTYPE} => $_)   :
   ();
} keys(%Instructions);

my %Valid_Dir 
   = map { $_ => 1 } qw/.ASCII_B .ASCII_W .BLK .EQU .ORG .DAT/;

my %SB_Nr = map { $Status_Bits[$_] => $_ } 0..$#Status_Bits;

my $ws = '__WS__';


## SUBS

sub disassemble {
   my($mem, $code, $changed_mem) = @_;

   croak('usage: disassemble(<mem_aref>, <code_aref>, [<changed_mem_href>])')
      unless
         ref($mem)  eq 'ARRAY' and
         ref($code) eq 'ARRAY' and
         (!$changed_mem or ref($changed_mem) eq 'HASH');

   # $changed_mem undef --> check all
   my @check = $changed_mem                           ?
               sort { $a <=> $b } keys(%$changed_mem) :
               0..$#{$mem}                            ;

   my %new_code;
   my $last = 0;
   for my $addr ( @check ) {

      # go back to last instruction, skipping constants
      while (
         $code->[$addr]        and
         $code->[$addr] eq ' ' and
         $addr > 0
      ) {
         $addr--;
      }

      # dissassemble until synch (tmp code eq old code)
      my $sync;
      my %tmp;
      while ( !$sync and $addr < @$mem ) {

         %tmp = ();

         # already done while backtracking ?
         next if exists($new_code{$addr});

         # parsing
         my $pi = _parse_instr($mem->[$addr]);

         # build operands
         my @ops;
         my $cnbr = 1;
         for my $i ( 0..$pi->{opcount} ) {

            # check for indirect address mode
            my $op = $pi->{params}[$i]{addr} ? '@' : '';

            SWITCH: {
               $_ = $pi->{params}[$i]{addr};

               my $reg = 'R' . $pi->{params}[$i]{reg};

               /0|1/ && do {
                  # normal register
                  $op .= $reg;
                  last SWITCH;
               };

               /2/ && do {
                  # post increment or constant
                  if ( $reg eq 'R15' ) {
                     my $const_addr = $addr + $cnbr++;
                     $op = '0x' . $mem->[$const_addr];
                     # constants are coded with single space
                     $tmp{$const_addr}  = ' ';
                  } else {
                     $op .= "$reg++";
                  }
                  last SWITCH;
               };

               /3/ && do {
                  # pre decrement
                  $op .= "--$reg";
                  last SWITCH;
               };
            }
            # save operand
            push(@ops, $op);
         }

         # join operands column aligned
         my $opstr   = join(' ', map { sprintf("%-10s", $_) } @ops);

         # combine statement
         $tmp{$addr}
            = sprintf(
                 "%-4s %s %s%s",
                 $pi->{op_name},
                 $opstr,
                 $pi->{negate} ? '!' : '',
                 $pi->{cond} || '',
              );

      } continue {

         $sync = (
            !defined($tmp{$addr}) or
            $code->[$addr] eq $tmp{$addr}
         );

         # only save to %new_code hash if changed
         unless ( $sync ) {
            for ( keys(%tmp) ) {
               $code->[$_]   = $tmp{$_};
               $new_code{$_} = $tmp{$_};
            }
         }

         $addr++;
      }
   }

   return(\%new_code);
}


sub step {
   my($mem, $reg, $changed) = @_;

   croak('usage: step(<mem_aref>, <reg_aref>, <changed_mem_href>)')
      unless
         ref($mem)     eq 'ARRAY' and
         ref($reg)     eq 'ARRAY' and
         ref($changed) eq 'HASH';

   # keep reg[14][1] set
   $reg->[14] |= "00000001";

   my $instruct = $mem->[$reg->[15]->to_Dec()];
   ++$reg->[15];

   my $pi = _parse_instr($instruct);

   return if $pi->{op_name} eq 'HALT';

   $Instructions{$pi->{op_name}}{EXEC}->(
      $mem,
      $reg,
      $pi->{params},
   );

   $reg->[14] |= "00000001";

   return(1);
}


sub _read_op {
   my($mem, $reg, $p, $supress_inc) = @_;

   my $rval;

   SWITCH: {
      $_ = $p->{addr};

      /0/ && do {
         $rval = $reg->[$p->{reg}];
         last SWITCH;
      };

      /1/ && do {
         $rval = $mem->[$reg->[$p->{reg}]->to_Dec()];
         last SWITCH;
      };

      /2/ && do {
         $rval = $mem->[$reg->[$p->{reg}]->to_Dec()];
         $reg->[$p->{reg}]++ unless $supress_inc;
         last SWITCH;
      };

      /3/ && do {
         --$reg->[$p->{reg}];
         $rval = $mem->[$reg->[$p->{reg}]->to_Dec()];
         last SWITCH;
      };
   }
   return($rval);
}


sub _write_op {
   my($mem, $reg, $mod, $c_out, $ovfl, $p, $mem_changed) = @_;

   SWITCH: {
      $_ = $p->{addr};

      /0/ && do {
         $reg->[$p->{reg}]->Copy($p->{value});
         last SWITCH;
      };

      /1/ && do {
         $reg->[$p->{reg}]->Copy($p->{value});
         $reg->[$p->{reg}]--;
         last SWITCH;
      };

      /2/ && do {
         $reg->[$p->{reg}]->Copy($p->{value});
         $reg->[$p->{reg}]++;
         last SWITCH;
      };

      /3|7/ && do {
         my $addr = $reg->[$p->{reg}]->to_Dec() + $p->{mem}->to_Dec();
         unless ( $mem->[$addr] == $p->{value} ) {
            $mem->[$addr]->Copy($p->{value});
            $mem_changed->{$addr} = 1;
         }
         last SWITCH;
      };

      /4/ && do {
         my $addr = $reg->[$p->{reg}]->to_Dec();
         unless ( $mem->[$addr] == $p->{value} ) {
            $mem->[$addr]->Copy($p->{value});
            $mem_changed->{$addr} = 1;
         }
         last SWITCH;
      };

      /5/ && do {
         $reg->[$p->{reg}]--;
         my $addr = $reg->[$p->{reg}]->to_Dec();
         unless ( $mem->[$addr] == $p->{value} ) {
            $mem->[$addr]->Copy($p->{value});
            $mem_changed->{$addr} = 1;
         }
         last SWITCH;
      };

      /6/ && do {
         my $addr = $reg->[$p->{reg}]->to_Dec();
         unless ( $mem->[$addr] == $p->{value} ) {
            $mem->[$addr]->Copy($p->{value});
            $mem_changed->{$addr} = 1;
         }
         $reg->[$p->{reg}]++;
         last SWITCH;
      };
   }

   if ( $mod ) {
      $reg->[14] &= '01000000';

      $reg->[14]->Bit_On(25) if $p->{value} == 0xFFFFFFFF;
      $reg->[14]->Bit_On(26) if $c_out;
      $reg->[14]->Bit_On(27) if $p->{value} == 0;
      $reg->[14]->Bit_On(28) if $p->{value}->bit_test(31);
      $reg->[14]->Bit_On(29) if $ovfl;
      # m
      # i
   }

   return($mem_changed);
}

# TODO code align with assembled binary
sub assemble {
   my($lines, $prg, $err, $cmap) = @_;

   croak('usage: assemble(<code_aref>, <bin_aref>, <err_aref>, <map_aref>)')
      unless
         ref($lines) eq 'ARRAY' and
         ref($prg)   eq 'HASH' and
         ref($err)   eq 'ARRAY' and
         ref($cmap)  eq 'HASH';

   # first pass: parse
   my $stmt = _parse_asm($lines, $err);
   
   $_->{source} = $lines->[$_->{line} - 1] for @$err;
   
   # stop on errors
   foreach my $e ( @$err ) {
      return if $e->{level} eq 'error';
   }

   # second pass 
   my(%bin, %labels, %substitute);
   my $addr = 0;
   foreach my $s ( @$stmt ) {

      # skip empty lines
      next unless keys(%$s);

      # label addresses as hex strings
      $labels{$s->{label}} = sprintf(INSTR_FMT_HEX, $addr) if $s->{label};


      if ( $_ = $s->{directive} ) {

         /\.ORG/ && do {
            $addr = $s->{operands}[0] =~ /^0/ ?
                    oct($s->{operands}[0])    :
                    $s->{operands}[0];
            next;
         };

         /\.DAT/ && do {
            my $value = $s->{operands}[0] =~ /^0/ ?
                        oct($s->{operands}[0])    :
                        $s->{operands}[0];
            write_bin(\%bin, $cmap, $s->{line}, \$addr, [$value]);
            next;
         };

         /\.BLK/ && do {
            my $len = $s->{operands}[0] =~ /^0/ ?
                      oct($s->{operands}[0])    :
                      $s->{operands}[0];
            write_bin(\%bin, $cmap, $s->{line}, \$addr, [map {0} 1..$len]);
            next;
         };

         /\.ASCII_B/ && do {
            my $fill = length($s->{operands}[0]) % 2;
            $s->{operands}[0] .= "\0" x (2 - $fill);
            my @parts = map {
               my @char = map { ord } split(//, $_);
               $char[0] + ($char[1] << 8); 
            } $s->{operands}[0] =~ /.{2}/g;
            write_bin(\%bin, $cmap, $s->{line}, \$addr, \@parts);
            next;
         };

         /\.ASCII_W/ && do {
            $s->{operands}[0] .= "\0";
            my @parts = map { ord } split(//, $s->{operands}[0]); 
            write_bin(\%bin, $cmap, $s->{line}, \$addr, \@parts);
            next;
         }
      }

      if ( $s->{mnemonic} ) {
          
         my $instr = $Instructions{$s->{mnemonic}};

         my $opc = @{$s->{operands}};

         my $bin = 0;

         # special treatment for branches
         # second operand is condition
         if ( $instr->{OPCODE} == 0xD and $opc == 2) {

            $bin |= $instr->{BTYPE} << 4;

            my $cond_str = pop(@{$s->{operands}});
            my($neg, $bit_char) = $cond_str =~ /^(!?)(\w?)$/;

            if ( defined($bit_char) ) {
               $bit_char = uc($bit_char);
               unless ( exists($SB_Nr{$bit_char}) ) {
                  push @$err, {
                     line  => $s->{line},
                     level => 'error',
                     text  => "invalid condition character '$bit_char'",
                  };
                  next;
               }

               $bin |= $SB_Nr{$bit_char} + 8 * ($neg ? 1 : 0);

            }

            $opc--;
         } elsif ( $opc != $instr->{OPCOUNT} + 1 ) {
            push @$err, {
               line  => $s->{line},
               level => 'error',
               text  => "wrong number of operands for $s->{mnemonic} got $opc expected "
                        . ($instr->{OPCOUNT} + 1),
            };
            next;
         }

         my @const;

         for my $i ( 0 .. $opc-1 ) {

            my $parsed;
            unless ( $parsed = _parse_op($s->{operands}[$i]) ) {
               push @$err, {
                  line  => $s->{line},
                  level => 'error',
                  text  => "syntax error in operand $i >>$s->{operands}[$i]<<",
               } ;
               next;
            }

            if ( $parsed->{const} ) {

               unless (
                  $parsed->{const} =~ /^0b[01]{1,${\INSTR_SIZE}}$/i         or
                  $parsed->{const} =~ /^0x[0-9a-f]{1,${\INSTR_SIZE_HEX}}$/i or
                  $parsed->{const} =~ /^\d{1,${\INSTR_SIZE_DEC}}$/i
               ) {

                  # perhaps a label --> keep for third pass
                  $substitute{sprintf(INSTR_FMT_HEX, $addr + @const + 1)} = {
                     line     => $s->{line},
                     label    => $parsed->{const},
                     relative => $s->{mnemonic} =~ /^R(?:BRA|SUB)/ || 0,
                  };

                  # preliminary code with 0
                  $parsed->{const} = '0x0';
               }

               push(@const, $parsed->{const});
            }

            my $op = $parsed->{reg} eq ''
                   ? 0x2f                   # for constants @R15++
                   : $parsed->{reg};

            if ( $parsed->{indirect} ) {
               if ( $parsed->{incr} ) {
                  $op |= 0x20;
               } elsif ( $parsed->{decr} ) {
                  $op |= 0x30;
               } else {
                  $op |= 0x10;
               }
            }

            $bin += $op << (6 * (1 - $i));
         }

         $bin |= $instr->{OPCODE} << 12;

         /^0/ and $_ = oct($_) for @const;
         write_bin(\%bin, $cmap, $s->{line}, \$addr, [$bin, @const]);
      }
   }

   # third pass: substitute label address as constant 
   for my $a ( keys(%substitute) ) {
      unless ( exists($labels{$substitute{$a}{label}}) ) {
         push @$err, {
            line  => $substitute{$a}{line},
            level => 'error',
            text  => "unknown label $substitute{$a}{label}",
         };
         next;
      }
      $bin{$a} 
         = $substitute{$a}{relative}
         ? sprintf(INSTR_FMT_HEX, (hex($labels{$substitute{$a}{label}}) - hex($a) - 1) & 0xffff)
         : $labels{$substitute{$a}{label}};
   }

   $_->{source} = $lines->[$_->{line} - 1] for @$err;

   foreach my $e ( @$err ) {
      return if $e->{level} eq 'error';
   }

   %$prg = %bin;

   return(1);
}


sub _parse_asm {
   my($lines, $err) = @_;

   my(@statements, %vars, %labels, $stmt);

   my $lc = 1;
   for my $org_line ( @$lines ) {

      my $line = $org_line;
      chomp($line);

      # waste removal
      $line =~ s/^\s+//;      # heading whitespace
      $line =~ s/[;*].*$//;   # comments

      $stmt = {};

      next unless $line =~ /\S/;  # skip empty lines

      $stmt->{line}     = $lc;
      $stmt->{operands} = [];

      # check for strings enclosed in '' as last parameter
      # if found replace whitespace with dummy string
      my ($head, $str) = $line =~ /^(.*?)'(.*)'\s*$/;
      if ( $str ) {
         $str =~ s/\s/$ws/g;
         $line = uc($head) . $str;
      }

      # split into parts
      my @parts = split(/[,\s]\s*/, $line);
      
      # process the splitted parts backwards
      # first get operands until mnemonic or directive found
      unshift(@{$stmt->{operands}}, pop(@parts))
         while @parts and !exists( $Instructions{$parts[-1]} )
                      and !exists( $Valid_Dir{$parts[-1]}  );

      unless ( @parts ) {
         push @$err, {
            line  => $lc,
            level => 'error',
            text  => "no instruction or directive found",
         };
         next;
      }

      if ( $Valid_Dir{ $parts[-1] } ) {

         # process directive statement
         # check basics (only one op per directive)
         unless ( (my $count = @{$stmt->{operands}}) == 1 ) {
            push @$err, {
               line  => $lc,
               level => 'error',
               text  => "wrong number of args got $count expected 1",
            };
            next;
         }

         $stmt->{directive} = pop(@parts);

      } else {

         # process operation
         $stmt->{mnemonic}  = pop(@parts);

      }

      # .EQU has to have a variable name
      # and it has to be unique
      if ( $stmt->{directive} and $stmt->{directive} eq '.EQU' ) {
         my $var = pop(@parts);
         push @$err, {
               line  => $lc,
               level => 'error',
               text  => '.EQU directive without variable name',
         } and next unless $var;

         if ( exists($vars{$var}) ) {
            push @$err, {
               line  => $lc,
               level => 'error',
               text  => "duplicate variable $var",
            };
            next;
         }

         $vars{$var} = $stmt->{operands}[0];

      } else {

         next unless @parts;

         # only labels left
         my $label = pop(@parts);

         # already there?
         if ( exists($labels{$label}) ) {
            push @$err, {
               line  => $lc,
               level => 'error',
               text  => "duplicate label $label",
            };
            next;
         }

         $labels{$label} = 1;
         $stmt->{label}  = $label;

      }

      # nothing legal left
      if ( @parts ) {
         push @$err, {
            line  => $lc,
            level => 'error',
            text  => "unexpected element(s) at begin of line",
         };
         next;
      }

   } continue {

      if ( $stmt->{operands} ) {
         OPER: for my $o ( @{$stmt->{operands}} ) {
            # substitute dummy with whitespace in operand strings
            $o =~ s/$ws/ /g;
            # substitute variables with values
            for my $v ( keys(%vars) )  {
               next OPER if $o =~ s/$v/$vars{$v}/;
            }
         }
      }

      # save parsed statement in array
      push(@statements, $stmt);
      ++$lc;
   }

   return(\@statements);
}


sub _parse_op {
   my($str) = @_;

   my %parsed;

   @parsed{qw/indirect decr reg incr const/} =
      $str =~ /^
         (\@)?                                         # 1. '@'
         (?:
            (?:
               (?(1)(\-\-)?)                           # 2. '--' if '@' in \1
               R([01]?(?(?<=1)[0-5]|[0-9]))            # 3. R0-R15 or R00-R15
               (?(1)(?(2)|(\+\+)?))                    # 4. '++' if '@' in \1 and not '--' in \2
            )
            |
            (?(1)|                                     # 5. if not '@' in \1
               (
                  (?:0b[01]{1,${\INSTR_SIZE}})         # dec, bin or hex number
                  |
                  (?:0x[0-9a-f]{1,${\INSTR_SIZE_HEX}}) # dec, bin or hex number
                  |
                  (?:\d{1,${\INSTR_SIZE_DEC}})         # dec, bin or hex number
                  |
                  (\S+?)                               # or non whitespace for labels
               )
            )
         )
      $/xi;

   my $ok = 0;
   $ok ||= defined($_) for values(%parsed);

   return unless $ok;

   defined($parsed{$_}) or $parsed{$_} = '' for keys(%parsed);

   return(\%parsed);
}


sub init_registers {
   my @regs;

   push(@regs, Bit::Vector->new_Hex(INSTR_SIZE, '0'))
      for 0..REGISTERS-1;

   $regs[0]  &= "0";
   $regs[14] |= "01000000";

   return(\@regs);
}


sub init_memory {
   my($size) = @_;
   croak('usage: init_memory(<size>)') unless $size;

   my @mem;
   push(@mem, Bit::Vector->new_Hex(INSTR_SIZE, '0'))
      for 0..$size-1;

   return(\@mem);
}


sub init_code {
   my($mem_ref) = @_;

   croak('usage: init_memory(<mem_aref>)')
      unless ref($mem_ref) eq 'ARRAY';

   my @code = map { '' } 0..$#{$mem_ref};

   return(\@code);
}


sub loadbin {
   my($mem_ref, $bin_ref) = @_;

   croak('usage: init_memory(<mem_aref>, <bin_aref>)')
      unless
         ref($mem_ref) eq 'ARRAY' and
         ref($bin_ref) eq 'ARRAY';

   chomp(@$bin_ref);

   my %loaded;
   for my $bin ( @$bin_ref ) {
      my($addr, $data) = split(/\s+/, $bin);
      next unless $data;
      $loaded{$addr} = $data;
      $addr =~ s/^0x//;
      $data =~ s/^0x//;
      $mem_ref->[hex($addr)]->from_Hex($data);
   }
   
   return(\%loaded);
}


sub _parse_instr {
   my($instr) = @_;

   my %pi;

   # parse instruction
   $pi{opcode} = $instr->Chunk_Read(4, 12);
   $pi{params} = [
      map { {
         addr => $instr->Chunk_Read(2, 10 - $_ * 6),
         reg  => $instr->Chunk_Read(4,  6 - $_ * 6),
      } } (0..1)
   ];

   # determine instruction type and operator count

   if ( $pi{opcode} == 0xD ) {
      $pi{op_name} = $Branch_Ops{$pi{params}[1]{addr}};
      $pi{negate}  = $pi{params}[1]{reg} & 0x8;
      $pi{cond}    = $Status_Bits[$pi{params}[1]{reg} & 0x7];
   } else {
      $pi{op_name} = $Opcode_Names{$pi{opcode}};
   }

   $pi{opcount}
      = $Instructions{$pi{op_name}}{OPCOUNT};

   return(\%pi);
}


sub write_bin {
    my($bin, $cmap, $line, $addr, $vref) = @_;
    
    for my $v ( @$vref ) {
       push(@{$cmap->{$line}}, sprintf(INSTR_FMT_HEX, $$addr)); 
       $bin->{sprintf(INSTR_FMT_HEX, $$addr++)} = sprintf(INSTR_FMT_HEX, $v);
    }    
}

sub _update_status_register {
    
}


1;

__END__