Subversion Repositories light8080

################################################################################
# uasm.pl : light8080 core microcode assembler
################################################################################
# Usage: perl uasm.pl <microcode file name> <command list>
# 
# The command list is a space-separated sequence of the following:
#
# -lst      : Shows a listing of the assembled microinstructions next to their
#             assembler source lines. Not very useful because it does not show 
#             assembler pragma, label or comment lines.
# -labels   : Shows a list of all defined labels with their address and the 
#             number of times they are used.
# -bitfields: Shows a list of all the different microinstructions generated, 
#             plus the number of times they are used. Might be useful to encode
#             the microinstructions and save rom bits.
# -instructions: Shows a list of all defined instructions with the address their
#             microcode starts at.
# -rom_bin  : Shows a raw list of all the binary microinstructions.
# -rom_vhdl : Shows a vhdl block containing the microcode rom declaration.
#
# If none of the above commands is given, the program just exits silently. Any 
# unrecognized command is silently ignored.
################################################################################
# Assembler format (informal definition, source is the ultimate reference!):
#
#<microinstruction line> := 
#    [<label>] | (*1)
#    <operand stage control> ; <ALU stage control> [; [<flag list>]] |
#    JSR <destination address>|TJSR <destination address>
#
#<label> := {':' immediately followed by a common identifier}
#<destination address> := {an identifier defined as label anywhere in the file}
#<operand stage control> :=  <op_reg> = <op_src> | NOP
#<op_reg> := T1 | T2
#<op_src> := <register> | DI | <IR register>
#<IR register> := {s}|{d}|{p}0|{p}1 (*3)
#<register> := _a|_b|_c|_d|_e|_h|_l|_f|_a|_ph|_pl|_x|_y|_z|_w|_sh|_sl|
#<ALU stage control> := <alu_dst> = <alu_op> | NOP 
#<alu_dst> := <register> | DO
#<alu_op> := add|adc|sub|sbb| and|orl|not|xrl| rla|rra|rlca|rrca| aaa|
#            t1|rst|daa|cpc|sec|psw
#<flag list> := <flag> [, <flag> ...] 
#<flag> := #decode|#di|#ei|#io|#auxcy|#clrt1|#halt|#end|#ret|#rd|#wr|#setacy 
#          #ld_al|#ld_addr|#fp_c|#fp_r|#fp_rc|#clr_cy_ac  (*2)
#
#  *1 Labels appear alone by themselves in a line
#  *2 There are some restrictions on the flags that can be used together
#  *3 Registers are specified by IR field
#
################################################################################
# ALU operations 
#
#Operation      Encoding    ALU result
#===============================================================================
#ADD            001100      T2 + T1
#ADC            001101      T2 + T1 + CY
#SUB            001110      T2 - T1
#SBB            001111      T2 – T1 - CY
#AND            000100      T1 AND T2
#ORL            000101      T1 OR T2
#NOT            000110      NOT T1 
#XRL            000111      T1 XOR T2
#RLA            000000      8080 RLC
#RRA            000001      8080 RRC
#RLCA           000010      8080 RAL
#RRCA           000011      8080 RAR
#T1             010111      T1
#RST            011111      8*IR(5..3), as per RST instruction
#DAA            101000      DAA T1 (but only after executing 2 in a row)
#CPC            101100      UNDEFINED     (CY complemented)
#SEC            101101      UNDEFINED     (CY set)
################################################################################
# Flags :
# --- Flags from group 1: use only one of these
# #decode :  Load address counter and IR with contents of data input lines,
#            thus starting opcode decoging.
# #ei :      Set interrupt enable register.
# #di :      Reset interrupt enable register.
# #io :      Activate io signal for 1st cycle.
# #auxcy :   Use aux carry instead of regular carry for this operation. 
# #clrt1 :   Clear T1 at the end of 1st cycle.
# #halt :    Jump to microcode address 0x07 without saving return value.
# 
# --- Flags from group 2: use only one of these
# #setacy :  Set aux carry at the start of 1st cycle (used for ++).
# #end :     Jump to microinstruction address 3 after the present m.i.
# #ret :     Jump to address saved by the last JST or TJSR m.i.
# #rd :      Activate rd signal for the 2nd cycle.
# #wr :      Activate wr signal for the 2nd cycle.
# --- Independent flags: no restrictions
# #ld_al :   Load AL register with register bank output as read by operation 1.
#            (used in memory and io access). 
# #ld_addr : Load address register (H byte = register bank output as read by 
#            operation 1, L byte = AL). 
#            Activate vma signal for 1st cycle.
# #clr_acy : Instruction clears CY and AC flags. Use with #fp_rc.
# --- PSW update flags: use only one of these
# #fp_r :    This instruction updates all PSW flags except for C.
# #fp_c :    This instruction updates only the C flag in the PSW.
# #fp_rc :   This instruction updates all the flags in the PSW.
################################################################################
# Read the design notes for a brief reference to the micromachine internal
# behavior, including implicit loads/erases.
################################################################################
 
$file = shift(@ARGV);
 
open(INFO, $file) or die "unable to open file '$file'\n";
@lines = <INFO>;
close(INFO);
 
$field2_nop = '0'.'0000'.'00'.'0'.'0'.'000000';
$field2_jsr = '0'.'0000'.'00'.'0'.'0'.'000000';
 
%field1_ops = 
  ( 'nop',        '000'.'000'.'00000'.'00'.'0000'.$field2_nop,
    'jsr',        '000'.'010'.'00000'.'00'.'0000'.$field2_jsr,
    'tjsr',       '000'.'100'.'00000'.'00'.'0000'.$field2_jsr,
 
    't1 = {s}',   '000'.'000'.'00101'.'01'.'0000'.$field2_nop,
    't1 = {d}',   '000'.'000'.'00101'.'10'.'0000'.$field2_nop,
    't1 = {p}0',  '000'.'000'.'00101'.'11'.'0000'.$field2_nop,
    't1 = {p}1',  '000'.'000'.'00101'.'11'.'0001'.$field2_nop,
    't1 = di',    '000'.'000'.'00100'.'00'.'0000'.$field2_nop,
    't1 = _b',    '000'.'000'.'00101'.'00'.'0000'.$field2_nop,
    't1 = _c',    '000'.'000'.'00101'.'00'.'0001'.$field2_nop,
    't1 = _d',    '000'.'000'.'00101'.'00'.'0010'.$field2_nop,
    't1 = _e',    '000'.'000'.'00101'.'00'.'0011'.$field2_nop,
    't1 = _h',    '000'.'000'.'00101'.'00'.'0100'.$field2_nop,
    't1 = _l',    '000'.'000'.'00101'.'00'.'0101'.$field2_nop,
    't1 = _a',    '000'.'000'.'00101'.'00'.'0111'.$field2_nop,
    't1 = _f',    '000'.'000'.'00101'.'00'.'0110'.$field2_nop,
    't1 = _ph',   '000'.'000'.'00101'.'00'.'1000'.$field2_nop,
    't1 = _pl',   '000'.'000'.'00101'.'00'.'1001'.$field2_nop,
    't1 = _x',    '000'.'000'.'00101'.'00'.'1010'.$field2_nop,
    't1 = _y',    '000'.'000'.'00101'.'00'.'1011'.$field2_nop,
    't1 = _z',    '000'.'000'.'00101'.'00'.'1100'.$field2_nop,
    't1 = _w',    '000'.'000'.'00101'.'00'.'1101'.$field2_nop,
    't1 = _sh',   '000'.'000'.'00101'.'00'.'1110'.$field2_nop,
    't1 = _sl',   '000'.'000'.'00101'.'00'.'1111'.$field2_nop,
 
    't2 = {s}',   '000'.'000'.'00011'.'01'.'0000'.$field2_nop,
    't2 = {d}',   '000'.'000'.'00011'.'10'.'0000'.$field2_nop,
    't2 = {p}0',  '000'.'000'.'00011'.'11'.'0000'.$field2_nop,
    't2 = {p}1',  '000'.'000'.'00011'.'11'.'0001'.$field2_nop,
    't2 = di',    '000'.'000'.'00010'.'00'.'0000'.$field2_nop,
    't2 = _b',    '000'.'000'.'00011'.'00'.'0000'.$field2_nop,
    't2 = _c',    '000'.'000'.'00011'.'00'.'0001'.$field2_nop,
    't2 = _d',    '000'.'000'.'00011'.'00'.'0010'.$field2_nop,
    't2 = _e',    '000'.'000'.'00011'.'00'.'0011'.$field2_nop,
    't2 = _h',    '000'.'000'.'00011'.'00'.'0100'.$field2_nop,
    't2 = _l',    '000'.'000'.'00011'.'00'.'0101'.$field2_nop,
    't2 = _a',    '000'.'000'.'00011'.'00'.'0111'.$field2_nop,
    't2 = _f',    '000'.'000'.'00011'.'00'.'0110'.$field2_nop,
    't2 = _ph',   '000'.'000'.'00011'.'00'.'1000'.$field2_nop,
    't2 = _pl',   '000'.'000'.'00011'.'00'.'1001'.$field2_nop,
    't2 = _x',    '000'.'000'.'00011'.'00'.'1010'.$field2_nop,
    't2 = _y',    '000'.'000'.'00011'.'00'.'1011'.$field2_nop,
    't2 = _z',    '000'.'000'.'00011'.'00'.'1100'.$field2_nop,
    't2 = _w',    '000'.'000'.'00011'.'00'.'1101'.$field2_nop,
    't2 = _sh',   '000'.'000'.'00011'.'00'.'1110'.$field2_nop,
    't2 = _sl',   '000'.'000'.'00011'.'00'.'1111'.$field2_nop
 
  );
 
 
$re_field1 = "(".join('|',keys %field1_ops).")";
$re_field1 =~ s/\[/\\\[/g;
$re_field1 =~ s/\]/\\\]/g;
 
%field2_ops = 
  ( 'add',    '001100',
    'adc',    '001101',
    'sub',    '001110',
    'sbb',    '001111',  
 
    'and',    '000100',
    'orl',    '000110',
    'not',    '000111',
    'xrl',    '000101',
 
    'rla',    '000000',
    'rra',    '000001',
    'rlca',   '000010',
    'rrca',   '000011',
 
    'aaa',    '111000',
 
    't1',     '010111',
    'rst',    '011111',
    'daa',    '101000',
    'cpc',    '101100',
    'sec',    '101101',
    'psw',    '110000'   
  );
 
 
$re_f2_ops = "(".join('|',keys %field2_ops).")";
$re_f2_ops =~ s/\[/\\\[/g;
$re_f2_ops =~ s/\]/\\\]/g;
 
# 'parse' command line flags into a string
$cmdline = join ':', @ARGV;
 
$num_line = 0;
$addr = 0;
 
%labels = ();                 # <label, address>
@label_uses = ();             # <label, [addresses in which it's used]>
@undefined_targets = ();      # array of <label, address in which it's used>
$num_errors = 0;
 
@bitfields = ();
 
@rom = ();
@asm = ();
@errors = ();
@num_lines = ();
 
%asm_to_uaddr = ();           # opcode asm -> uaddress
%uaddr_to_asm = ();           # uaddress -> opcode asm
 
%uaddr_to_pattern = ();       # uaddress -> pattern
%pattern_to_uaddr = ();       # pattern -> uaddress -- simulation, decoder
 
LINE: foreach $line (@lines) {
 
  $num_line++;
 
  $line =~ tr/A-Z/a-z/;
  $line =~ s/(--|\/\/).*//;
  $line =~ s/^\s*//g;
  $line =~ s/\s*\$//g;
  chomp($line);
 
  $uinst = {
    field_1 => '',
    src     => '',
    special => '',
    field_2 => '',
    field_0 => '000000',
    flags   => '',
    error   => '',
    asm     => $line
  };
 
 
  # if line is whitespace or comment (which has been changed to whitespace)
  # then skip to next line
  if($line eq ''){
    next;
  }
 
  # if $line is a label declaration, get it and skip to next line
  # note labels come alone in the line, unlike other assemblers
  # TODO it'd be simple to change this...
  if($line =~ /^\s*:(\w+)/){
    # subroutine label (labels are only used for jsrs)
    $labels{$1} = $addr;
    next;
  }
 
  # if line is a pragma, process it
  if($line =~ /^\s*__/){
    # TODO process pragmas __reset, __fetch, __int
 
    #if($line =~ /^\s*__code\s+"([0|1|s|d|p|a|r]+)"/){
      # we do nothing with the opcode byte; it's for reference only
      #printf "%04d # %s\n",$addr,$1;
    #}
    if($line =~ /^\s*__asm\s+(.*)/){      
      # save the start address for the CPU instruction
      # it will be used in the design of the decoder
      $asm_to_uaddr{$1} = $addr;
      $uaddr_to_asm{$addr} = $1;
    }
 
    if($line =~ /^\s*__code\s+"(.*)".*/){      
      # save the start address for the CPU instruction
      # it will be used in the design of the decoder
      $pattern_to_uaddr{$1} = $addr;
      $uaddr_to_pattern{$addr} = $1;
    }
 
 
    next;
  }
 
  # get flags field (all text following 1st '#' included)
  # remove it so we're left with 'field1 ; field2 [;]'
  $line = process_flags($line);  
 
  # break line in 1 or 2 fields
  @fields = split /;/, $line;
 
  # process 1st field...
  $done = process_field1($fields[0]);
 
  # ...and process 2nd field if there is one (depends on field1 format)
  # TODO check that there's no field2 when there shouldn't  
  if($done != 1){
    $done = process_field2($fields[1]);
  }  
 
  # finally, process extra flags produced by field1 assembly (jsr/tjsr)
  process_extra_flags();  
 
  # complete bitfield with flags...
  substr($uinst->{field1}, 0, 6) = $uinst->{field_0};
 
  # Now, we already have the bitfields.
 
  push(@rom, $uinst->{field1});
  push(@asm, substr($line,0,40));
  push(@num_lines, $num_line);
  if($uinst->{error} eq ''){
    push(@errors, '');
  }
  else{
    push(@errors, $uinst->{error});
  }  
 
  $addr++;  #addr++ even for error uinsts
 
}
continue {
}
 
# Line processing finished (1st pass). Start 2nd pass and do listings 
# if requested
 
# 2nd pass
 
# now we know the value of all labels, fill in address field of forward jumps
foreach $target (@undefined_targets){
  @item = @{$target};
  $value = to_bin($labels{$item[0]}, 8);
  $adr = $item[1]*1;
 
  substr($rom[$adr], 20,2, substr($value, 0,2));
  substr($rom[$adr], 26,6, substr($value, 2,6));
}
 
foreach $bf (@rom){
  push(@bitfields, $bf);
}
 
# listings
 
if($cmdline =~ /-lst/){
  $do_lst = 1;
}
 
$i = 0;
foreach $bf (@rom){
  if($do_lst){
    printf "%02x %32s :: %s\n", $i,  $bf, $asm[$i];
    if($errors[$i] ne ''){
      printf "     ERROR (%d): %s\n", $num_lines[$i], $errors[$i];
    }
  }
 
  $i++;
}
 
if($do_lst){
  # completion message
  printf "\nDone. %d uinsts, %d errors.\n", $addr, $num_errors;
}
 
# label listing
if($cmdline =~ /\-labels/){
  label_list();
}
 
# bitfield histogram
if($cmdline =~ /\-bitfields/){
  bitfield_histogram();
}
 
# show cpu instruction microcode addresses
if($cmdline =~ /\-instructions/){
  foreach $asm (sort {$asm_to_uaddr{$a} <=> $asm_to_uaddr{$b}}(keys %asm_to_uaddr)){
    $uaddress = $asm_to_uaddr{$asm};
    printf "%02x %s  %s\n", $uaddress, $uaddr_to_pattern{$uaddress}, $asm;
  }
}
 
if($cmdline =~ /\-rom_vhdl/){
  show_decoder_table('vhdl');
}
 
if($cmdline =~ /\-rom_bin/){
  show_decoder_table('bin');
}
 
# end of main program
 
 
################################################################################
 
 
sub show_decoder_table {
 
  my $fmat = shift(@_);
 
  # show decoder rom contents
  %decoder_hash = ();
  foreach $pat (keys %pattern_to_uaddr){
    $add = $pattern_to_uaddr{$pat};
    $pat =~ s/[a-z]/\[01\]/g;
    $decoder_hash{$pat} = $add;
  }
 
  @decoder_rom = ();
  for($i = 0; $i<256; $i++){
    $b = to_bin($i, 8);
    $val = 0;
    # We'll match the opcode to the pattern with the shortest length; that is,
    # the one with the less wildcards in it. Crude but effective in this case.
    $len_matched_pat = 1000;
    foreach $pat (keys %decoder_hash){
      if($b =~ /$pat/){
        if(length($pat) < $len_matched_pat){
          $val = $decoder_hash{$pat};
          $len_matched_pat = length($pat);
        }
        #last;
      }         
    }
    push @decoder_rom, $val;
  }
 
  if($fmat eq 'vhdl'){
    # print rom vhdl header...
    print "type t_rom is array (0 to 511) of std_logic_vector(31 downto 0);\n";
    print "signal rom : t_rom := (\n";
  } 
 
  # The 1st half of the uinst rom holds 256 uinstructions
  my $i=0;
  foreach $bf (@rom){
    if($fmat eq 'vhdl'){
      printf "\"%s\", -- %03x\n", $bf, $i;
    }
    else{
      printf "%s\n", $bf;
    }
    $i++;
  }
  # Fill remaining slots with ENDs 
  for(;$i<256;$i++){
    my $val = '00000100000000000000000000000000';
    if($fmat eq 'vhdl'){
      printf "\"%s\", -- %03x\n", $val, $i;
    }
    else{
       printf "%s\n", $val;
    }
  }
 
  # The 2nd half (upper 256 entries) of the ucode rom contains a jump table
  # with a jsr for each of the 256 opcodes, serving as cheap decoder:
  foreach $entry (@decoder_rom){
    my $val = to_bin($entry, 8);
    $val = '00001000000000000000'.substr($val,0,2).'0000'.substr($val,2,6);
    $i++;
    if($fmat eq 'vhdl'){
      printf "\"%s\"", $val;
      if($i<512){
        print ",";
      }
      else{
        print " ";
      }
      printf " -- %03x\n", ($i - 1);
    }
    else{
      printf "%s\n", $val;
    }
  }
 
  if($fmat eq 'vhdl'){
    # close vhdl declaration
    print "\n);\n";
  }
 
}
 
sub label_list {
  # label table listing 
  print "\nlabels:\n";
  print "---------------------------------\n";
  print "label                addr    uses\n";
  print "---------------------------------\n";
 
  %hist_labels;
  $hist_labels{$_}++ for @label_uses;
 
  foreach $label (keys %hist_labels){
    printf "%-20s %04x    %d\n", $label, $labels{$label}, $hist_labels{$label};
  }
}
 
sub bitfield_histogram {
 
  %hist_bitfields;
  $hist_bitfields{$_}++ for @bitfields;
  @unique_bitfields = keys %hist_bitfields;
 
  printf "\nbitfield usage (total: %d)\n", $#unique_bitfields;
  print "------------------------------------------------\n";
  print "bitfield                            uses\n";
  print "------------------------------------------------\n";
 
  foreach $bfield (sort sortFieldsByFrequency(keys %hist_bitfields)){
    printf "%-32s    %d\n", $bfield, $hist_bitfields{$bfield};
  }
}
 
sub sortFieldsByFrequency {
   $hist_bitfields{$b} <=> $hist_bitfields{$a};
}
 
sub process_extra_flags {
 
  $flags1 = '';
  $flags2 = '';
 
 
  # first, process flags produced by 1st field processing
  if($uinst->{flags} =~ /#jsr/){
    if($flags2 ne ''){$error = 'incompatible flags'};
    $flags2 = '010';
  }
  if($uinst->{flags} =~ /#tjsr/){
    if($flags2 ne ''){$error = 'incompatible flags'};
    $flags2 = '100';
  }
 
  $provisional_flags2 = substr($uinst->{field_0},3,3);
  if($flags2 ne ''){
    if($provisional_flags2 ne '000'){
      $error = "flags incompatible with jsr/tjsr operation: "
                                                      .$provisional_flags2;
      $num_errors++;                                                      
      $uinst->{error} = $error;
    }
    else{
      substr($uinst->{field_0},3,3) = $flags2;
    }
  }
 
  if($uinst->{flags} =~ /#ld_al/){
    substr($uinst->{field1},7,1) = '1';
  }
  if($uinst->{flags} =~ /#ld_addr/){
    substr($uinst->{field1},6,1) = '1';
  }
 
  if($uinst->{flags} =~ /#fp_c/){
    substr($uinst->{field1},22,2) = '01';
  }
  if($uinst->{flags} =~ /#fp_r/){
    substr($uinst->{field1},22,2) = '10';
  }
  if($uinst->{flags} =~ /#fp_rc/){
    substr($uinst->{field1},22,2) = '11';
  }
  if($uinst->{flags} =~ /#clr_acy/){
    substr($uinst->{field1},17,1) = '1';
  }
 
}
 
sub process_flags {
 
  my $line = shift(@_);  
 
  $line =~ s/#/##/;
  $line =~ /(.*)#(#.*)/;
 
  $flags1 = '';
  $flags2 = '';
 
 
  if($1 ne ''){
    $line_without_flags = $1;
    $flag_str = $2;
 
    @flags = split /,/, $flag_str;      
    $error = '';
 
    if($flag_str =~ /#end/){
      if($flags2 ne ''){$error = 'incompatible flags'};
      $flags2 = '001';
    }
    if($flag_str =~ /#ret/){
      if($flags2 ne ''){$error = 'incompatible flags'};
      $flags2 = '011';
    }
    if($flag_str =~ /#rd/){
      if($flags2 ne ''){$error = 'incompatible flags'};
      $flags2 = '101';
    }
    if($flag_str =~ /#wr/){
      if($flags2 ne ''){$error = 'incompatible flags'};
      $flags2 = '110';
    }
    if($flag_str =~ /#auxcy/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '101';
    }
 
    if($flag_str =~ /#decode/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '001';
    }
    if($flag_str =~ /#clrt1/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '110';
    }
    if($flag_str =~ /#halt/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '111';
    }
    if($flag_str =~ /#di/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '010';
    }
    if($flag_str =~ /#ei/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '011';
    }
    if($flag_str =~ /#io/){
      if($flags1 ne ''){$error = 'incompatible flags'};
      $flags1 = '100';
    }
    if($flag_str =~ /#setacy/){
      if($flags2 ne ''){$error = 'incompatible flags:'.$flags2};
      $flags2 = '111';
    }
 
    if($flags2 eq ''){ $flags2 = '000';};    
    if($flags1 eq ''){ $flags1 = '000';};
 
    $uinst->{field_0} = $flags1.$flags2;
 
    # Some of the flags must be processed after the rest of the uinst
    # has been assembled; save them into $uinst->{flags} for later.
 
    if($flag_str =~ /#ld_al/){
      $uinst->{flags} = $uinst->{flags}." #ld_al";
    }
    if($flag_str =~ /#ld_addr/){
      $uinst->{flags} = $uinst->{flags}." #ld_addr";
    }
    if($flag_str =~ /#fp_c/){
      $uinst->{flags} = $uinst->{flags}." #fp_c";
    }
    if($flag_str =~ /#fp_r/){
      $uinst->{flags} = $uinst->{flags}." #fp_r";
    }
    if($flag_str =~ /#fp_rc/){
      $uinst->{flags} = $uinst->{flags}." #fp_rc";
    }
    if($flag_str =~ /#clr_acy/){
      $uinst->{flags} = $uinst->{flags}." #clr_acy";
    }
 
    if($error ne ''){
      $num_errors++;
      $uinst->{error} = $error;
    };
 
    return $line_without_flags;
  }
 
  return $line;
}
 
 
sub process_field2 {
  my $field = shift(@_).";";
 
  $field =~ s/^\s*//g;
  $field =~ s/\s*;//g;
  $field =~ s/\s+/ /g;
 
  $field =~ s/A-Z/a-z/g;
 
 
  # check for special field2 formats: nop
  if($field =~ /(nop)/){
    # field2 is nop by default
    return 0;
  }
 
 
  if($field =~ /(_\w+|{p}0|{p}1|{d}|{s}|do) = (\w+|t1)/){
 
    #check that dst address is the same as field1's src address
    #(since they end up being the same physical bits)
    @parts = split /=/, $field;
    $dst = $parts[0];
    $dst =~ s/\s//g;
    if(($dst ne $uinst->{src}) 
       && ($dst ne 'do') 
       && ($uinst->{src} ne 'di') 
       && ($uinst->{src} ne '')){
      # field mismatch
      $num_errors++;
      $uinst->{error} = "field source/destination address mismatch";
      return 1;
    }
    else{
      # build bitfield for field2, including those bits that overlap
      # bits from field 1
 
      if($dst eq 'do'){
        substr($uinst->{field1}, 24, 1) = '1'; #ld_do
      }
      else{
        substr($uinst->{field1}, 25, 1) = '1'; #ld_reg
 
        if($dst eq '{p}0'){
          substr($uinst->{field1}, 11, 2) = '11';  
          substr($uinst->{field1}, 13, 4) = '0000';                    
        }
        elsif($dst eq '{p}1'){
          substr($uinst->{field1}, 11, 2) = '11';  
          substr($uinst->{field1}, 13, 4) = '0001';                    
        }
        elsif($dst eq '{d}'){
          substr($uinst->{field1}, 11, 2) = '10';  
          substr($uinst->{field1}, 13, 4) = '0000';                    
        }
        elsif($dst eq '{s}'){
          substr($uinst->{field1}, 11, 2) = '01';  
          substr($uinst->{field1}, 13, 4) = '0000';          
        }
        else{
          %regs = ( '_b',0, '_c',1, '_d',2, '_e',3,
                    '_h',4, '_l',5, '_f',6, '_a',7,
                    '_ph',8, '_pl',9, '_x',10, '_y',11,
                    '_z',12, '_w',13, '_sh',14, '_sl',15);
 
          $val_reg = to_bin($regs{$dst},4);          
          substr($uinst->{field1}, 11, 2) = '00';  
          substr($uinst->{field1}, 13, 4) = $val_reg; # RD address; same as WR
        } 
 
      }
 
      # TODO deal with flag pattern 
      $parts[1] =~ s/\s//g;
      $src = $field2_ops{$parts[1]}.'';
      if($src eq ''){
        $num_errors++;
        $uinst->{error} = "field 2 operation unknown: [".$parts[1]."]";
        return 1;
      }
      else{
        substr($uinst->{field1},26,6) = $src;
        return 0;
      }
    }
 
  }
  elsif($field =~ /(sec|cpc)/){
    substr($uinst->{field1},26,6) = $field2_ops{$1};
  }
  else{
    # field2 empty or invalid
    $num_errors++;
    $uinst->{error} = "field 2 empty or invalid: ".$re_field2;
    return 1;
  }  
 
}
 
 
 
# return   !=0 when uinst is finished except for flags, 
#         0 when field2 has to be processed
 
sub process_field1 {
 
  my $field = shift(@_).";";
 
  $field =~ s/^\s*//g;
  $field =~ s/\s*;//g;
  $field =~ s/\s+/ /g;
 
  # look for special format uinsts: jsr, tjsr, nop
  if($field =~ /(jsr|tjsr)\s+([_\w]+)/){
    $opcode = $1;
    $target = $2;    
    # set flag 
    $uinst->{flags} = $uinst->{flags}." #".$opcode." ";
 
    # check that target is defined, otherwise tag it for 2nd pass
    $target_addr = $labels{$target};
 
    tag_label_use($target, $addr);    
 
    if($target_addr eq ''){
      push @undefined_targets, [$target, $addr];
      $code = $field1_ops{$opcode};
      $uinst->{field1} = $code;
    }
    else{
      # set up bitfield so we can fill the address in in 2nd pass
      $code = $field1_ops{$opcode};
      $a = to_bin($target_addr+0, 8);
      substr($code, 20,2, substr($a, 0,2));
      substr($code, 26,6, substr($a, 2,6));
      $uinst->{field1} = $code;
    }
    return 1;
  }
 
  if($field =~ /nop/){
    # TODO encode NOP as 1st field
    $uinst->{field1} = $field1_ops{'nop'};
    return 0;
  }
 
  # process regular field1 (register load): dst = src
 
  if($field =~ /$re_field1/){
    @parts = split /=/, $field;
 
    # if a src reg address literal is specified, it has to be the same 
    # address as for field2 dest; save it for later comparison.
 
    $src = $parts[1];
    $src =~ s/\s//g;    
 
    $d = $field1_ops{$field}.'';
 
    if($d eq ''){
      # unrecognized source that somehow matches pattern (e.g. _pl0)
      $error = "invalid source in uinst field 1";
      $uinst->{field1} = $field1_ops{'nop'};
      $uinst->{error} = $error;
      $num_errors++;
      $uinst->{src} = '?';
      return 1;
    }
    else{
      $uinst->{src} = $src;    
      $uinst->{field1} = $d;
    }
    return 0;
  }
  else{
    # field1 not recognized.
    $error = "uinst field 1 not recognized: '".$field."'";
    $uinst->{field1} = $field1_ops{'nop'};
    $uinst->{error} = $error;
    $num_errors++;
    return 1;
  }  
 
}
 
sub tag_label_use {
 
  my $label = shift(@_);
  my $address = shift(@_);
 
  push(@label_uses, $label); 
 
}
 
sub to_bin {
  my $number = shift(@_) * 1;
  my $length = shift(@_);
 
  $n = $number;
  $r = '';
  for( my $i=$length-1;$i>=0;$i--){
    $d = 2 ** $i;
 
    if($n >= $d){
      $r = $r.'1';
      $n = $n - $d;
    }
    else{
      $r = $r.'0';
    }
  }
 
  return $r;
}
 
# End of file