#!/usr/bin/env perl

# Script to convert M6800 source code to non-optimal M6809 source code.
# By Joel Matthew Rees, Amagasaki, Japan, September 2018.
# Copyright 2018 Joel Matthew Rees
# 
# Permission to use current version for personal research, entertainment, 
# and other non-commercial purposes hereby granted, 
# on condition that authorship and copyright notice are left intact.
# For other uses, contact the author on social media.

  use v5.010.000;
  use warnings;
  use strict;

#  print $ARGV[ 1 ];

# Including stuff we don't need, in case I get ambitious.
# Not including 6801 at this point.

# Branches are completely unchanged going from 6800 to 6809:
my $branchlist = "BCC|BCS|BEQ|BGE|BGT|BHI|BLE|BLS|BLT|BMI|BNE|BPL|BRA|BVC|BVS";

# These implicit ops are unchanged from 6800 to 6809:
my $implist = "DAA|NOP|RTS";

# 16-bit pseudo-binary, unchanged from 6800 to 6809:
my $jumplist ="JMP|JSR";

# 8-bit binary ops are unchanged going from 6800 to 6809,
# but we'll eliminate optional space for sociability:
my $binop8list = "ADC|ADD|AND|BIT|CMP|EOR|SBC|SUB";

# 8-bit unary ops are unchanged going from 6800to 6809,
# but we'll eliminate optional space for sociability:
my $unoplist = "ASL|ASR|CLR|COM|DEC|INC|LSR|LSL|NEG|ROL|ROR|TST";

# These binary 8-bits have one too many As from 6800 to 6809:
my $binopLDORST8list = "LDA|ORA|STA";

# These loads and stores are unchanged from 6800 to 6809,
# except for optional space:
my $binopLDST16list = "LDS|LDX|STS|STX";

# Form changes to CMPX
my $binop16list = "CPX";

# Push and pop (pull) are generalized:
# (6800 had no pshx! -- But fixed in 6801.)
my $pushmepullyoulist = "PSH|PUL";

# Transfers are generalized:
my $transferlist = "TAB|TAP|TBA|TPA|TSX|TXS";

# These convert to LEA instructions:
my $lealist = "DES|DEX|INS|INX";

# Processor status bit handling is generalized:
# my $flaghandlerlist = "CLC|CLI|CLV|SEC|SEI|SEV";
my $flaghandleroplist = "CL|SE";
my $flaghandlerbitlist = "[CIV]";

# Special handling for inter-accumulator:
my $b2alist = "ABA|CBA|SBA";

# Interrupt stuff, form remains the same, different register set, 
# flag working on by hand:
my $interruptstufflist = "RTI|SWI";

# Interrupt wait, form changes, semantics change,
# flag for working on by hand:
my $waitstufflist = "WAI";

while ( my $line = <> )
{
  if ( $line =~ m/^(\w*)\s+FCC\s+(\d+),(.*)$/ )
  {
    my $label = $1;
    my $symlength = $2;
    my $strfield = $3;
    my $symbol = substr( $strfield, 0, $symlength );
    my $leftovers = substr( $strfield, $symlength );
    my $strlength = length( $symbol );
    if ( $strlength < $symlength )
    {
      print "$label\tFCC error\t'$symbol' not complete to "
            . "$symlength characters (only $strlength). ****error***";
    }
    else
    {
      my $fullsymbol = $symbol;
      if ( $leftovers =~ m/^(\S+)(.*)$/ )
      {
        $fullsymbol .= $1;
        $leftovers = $2;
      }
      print "$label\tFCC\t'$symbol'\t; '$fullsymbol'";
    }
    
    if ( length( $leftovers ) > 0 )
    {
      print " : $leftovers";
    }
    print "\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${pushmepullyoulist})\s*(A|B)\s*(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;
    my $comments = $4;
    print "$label\t${operator}S $operand\t; $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${binopLDORST8list})\s*(A|B)\s+(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;
    my $comments = $4; # Fudging, comments includes memory operand.
    my $op2letter = substr( $operator, 0, 2 );
    print "$label\t${op2letter}$operand $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${lealist})(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $comments = $3;
    if ( $operator =~ m/IN(\w)/ )
    { $operator = "LEA$1 1,$1";
    }
    elsif ( $operator =~ m/DE(\w)/ )
    { $operator = "LEA$1 -1,$1";
    }
    print "$label\t${operator}\t; $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${unoplist})\s*(A|B)(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;
    my $comments = $4;
    print "$label\t$operator$operand\t;$comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${unoplist})\s+(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;	# Fudging, operand includes any comments.
    print "$label\t$operator $operand\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${b2alist})(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $comments = $3;
    my $realoperator = $operator;
    print "$label\tPSHS B\t; ** emulating $operator:\n";
    if ( $operator eq "ABA" ) 
    { $realoperator = "ADDA";
    }
    elsif ( $operator eq "CBA" ) 
    { $realoperator = "CMPA";
    }
    elsif ( $operator eq "SBA" )
    { $realoperator = "SUBA";
    }
    print "\t$realoperator ,S+\t; $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${binop8list})\s*(A|B)\s+(.+)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;
    my $comments = $4; # Fudging, comments includes memory operand.
    print "$label\t${operator}$operand $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${transferlist})(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $comments = $3;
    my $source = substr( $operator, 1, 1 );
    my $destination = substr( $operator, 2, 1 );
    if ( $source eq "P" )
    { $source = "CCR";
    }
    if ( $destination eq "P" )
    { $destination = "CCR";
    }
    print "$label\tTFR $source,$destination\t; $operator : $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${flaghandleroplist})($flaghandlerbitlist)(.*)$/ )
  { # Bits: EFHINZVC, thus I is 0x10, V is 0x02, and C is 0x01.
    my $label = $1;
    my $operator = $2;
    my $bit = $3;
    my $comments = $4;
    my $realbits = 
         ( $bit eq "C" )
         ? "\$01"
         : ( $bit eq "V" )
           ? "\$02" 
           : ( $bit eq "I" )
             ? "\$10"
             : $bit;
    my $realoperator = $operator;
    if ( $operator eq "CL" )
    { $realoperator = "ANDCC";
      $realbits = "~" . $realbits;
    }
    elsif ( $operator eq "SE" )
    { $realoperator = "ORCC"
    }
    print "$label\t$realoperator #$realbits\t; ${operator}${bit} : $comments\n";
  }
  elsif ( $line =~ m/^(\w*)\s+($binop16list)\s+(.+)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;	# Fudging, operand includes any comments.
    my $reg16bit = substr( $operator, 2, 1 );
    print "$label\tCMP$reg16bit\t$operand\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${branchlist})\s+(\*[+-]\$?[0-9A-Fa-f]+)(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;
    my $comments = $4;
    print "$label\t$operator $operand\t; $comments\n"
          . "\t****WARNING**** HARD OFFSET: $operand ****\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${interruptstufflist})(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;	# Fudging, operand includes any comments.
    print "$label\t$operator$operand\n"
          . "\t****WARNING**** Interrupt routines must change!! ****\n";
  }
  elsif ( $line =~ m/^(\w*)\s+(${waitstufflist})(.*)$/ )
  {
    my $label = $1;
    my $operator = $2;
    my $operand = $3;	# Fudging, operand includes any comments.
    print "$label\tC$operator #\$EF\t; $operand\n"
          . "\t****WARNING**** WAI must change to CWAI!! ****\n";
  }
  else
  {
    print $line;
  }
}

