6800to6809.pl

   1 #!/usr/bin/env perl
   2
   3 # Script to convert M6800 source code to non-optimal M6809 source code.
   4 # By Joel Matthew Rees, Amagasaki, Japan, September 2018.
   5 # Copyright 2018 Joel Matthew Rees
   6 #
   7 # Permission to use current version for personal research, entertainment,
   8 # and other non-commercial purposes hereby granted,
   9 # on condition that authorship and copyright notice are left intact.
  10 # For other uses, contact the author on social media.
  11
  12   use v5.010.000;
  13   use warnings;
  14   use strict;
  15
  16 #  print $ARGV[ 1 ];
  17
  18 # Including stuff we don't need, in case I get ambitious.
  19 # Not including 6801 at this point.
  20
  21 # Branches are completely unchanged going from 6800 to 6809:
  22 my $branchlist = "BCC|BCS|BEQ|BGE|BGT|BHI|BLE|BLS|BLT|BMI|BNE|BPL|BRA|BVC|BVS";
  23
  24 # These implicit ops are unchanged from 6800 to 6809:
  25 my $implist = "DAA|NOP|RTS";
  26
  27 # 16-bit pseudo-binary, unchanged from 6800 to 6809:
  28 my $jumplist ="JMP|JSR";
  29
  30 # 8-bit binary ops are unchanged going from 6800 to 6809,
  31 # but we'll eliminate optional space for sociability:
  32 my $binop8list = "ADC|ADD|AND|BIT|CMP|EOR|SBC|SUB";
  33
  34 # 8-bit unary ops are unchanged going from 6800to 6809,
  35 # but we'll eliminate optional space for sociability:
  36 my $unoplist = "ASL|ASR|CLR|COM|DEC|INC|LSR|LSL|NEG|ROL|ROR|TST";
  37
  38 # These binary 8-bits have one too many As from 6800 to 6809:
  39 my $binopLDORST8list = "LDA|ORA|STA";
  40
  41 # These loads and stores are unchanged from 6800 to 6809,
  42 # except for optional space:
  43 my $binopLDST16list = "LDS|LDX|STS|STX";
  44
  45 # Form changes to CMPX
  46 my $binop16list = "CPX";
  47
  48 # Push and pop (pull) are generalized:
  49 # (6800 had no pshx! -- But fixed in 6801.)
  50 my $pushmepullyoulist = "PSH|PUL";
  51
  52 # Transfers are generalized:
  53 my $transferlist = "TAB|TAP|TBA|TPA|TSX|TXS";
  54
  55 # These convert to LEA instructions:
  56 my $lealist = "DES|DEX|INS|INX";
  57
  58 # Processor status bit handling is generalized:
  59 # my $flaghandlerlist = "CLC|CLI|CLV|SEC|SEI|SEV";
  60 my $flaghandleroplist = "CL|SE";
  61 my $flaghandlerbitlist = "[CIV]";
  62
  63 # Special handling for inter-accumulator:
  64 my $b2alist = "ABA|CBA|SBA";
  65
  66 # Interrupt stuff, form remains the same, different register set,
  67 # flag working on by hand:
  68 my $interruptstufflist = "RTI|SWI";
  69
  70 # Interrupt wait, form changes, semantics change,
  71 # flag for working on by hand:
  72 my $waitstufflist = "WAI";
  73
  74 while ( my $line = <> )
  75 {
  76   if ( $line =~ m/^(\w*)\s+FCC\s+(\d+),(.*)$/ )
  77   {
  78     my $label = $1;
  79     my $symlength = $2;
  80     my $strfield = $3;
  81     my $symbol = substr( $strfield, 0, $symlength );
  82     my $leftovers = substr( $strfield, $symlength );
  83     my $strlength = length( $symbol );
  84     if ( $strlength < $symlength )
  85     {
  86       print "$label\tFCC error\t'$symbol' not complete to "
  87             . "$symlength characters (only $strlength). ****error***";
  88     }
  89     else
  90     {
  91       my $fullsymbol = $symbol;
  92       if ( $leftovers =~ m/^(\S+)(.*)$/ )
  93       {
  94         $fullsymbol .= $1;
  95         $leftovers = $2;
  96       }
  97       print "$label\tFCC\t'$symbol'\t; '$fullsymbol'";
  98     }
  99
 100     if ( length( $leftovers ) > 0 )
 101     {
 102       print " : $leftovers";
 103     }
 104     print "\n";
 105   }
 106   elsif ( $line =~ m/^(\w*)\s+(${pushmepullyoulist})\s*(A|B)\s*(.*)$/ )
 107   {
 108     my $label = $1;
 109     my $operator = $2;
 110     my $operand = $3;
 111     my $comments = $4;
 112     print "$label\t${operator}S $operand\t; $comments\n";
 113   }
 114   elsif ( $line =~ m/^(\w*)\s+(${binopLDORST8list})\s*(A|B)\s+(.*)$/ )
 115   {
 116     my $label = $1;
 117     my $operator = $2;
 118     my $operand = $3;
 119     my $comments = $4; # Fudging, comments includes memory operand.
 120     my $op2letter = substr( $operator, 0, 2 );
 121     print "$label\t${op2letter}$operand $comments\n";
 122   }
 123   elsif ( $line =~ m/^(\w*)\s+(${lealist})(.*)$/ )
 124   {
 125     my $label = $1;
 126     my $operator = $2;
 127     my $comments = $3;
 128     if ( $operator =~ m/IN(\w)/ )
 129     { $operator = "LEA$1 1,$1";
 130     }
 131     elsif ( $operator =~ m/DE(\w)/ )
 132     { $operator = "LEA$1 -1,$1";
 133     }
 134     print "$label\t${operator}\t; $comments\n";
 135   }
 136   elsif ( $line =~ m/^(\w*)\s+(${unoplist})\s*(A|B)(.*)$/ )
 137   {
 138     my $label = $1;
 139     my $operator = $2;
 140     my $operand = $3;
 141     my $comments = $4;
 142     print "$label\t$operator$operand\t;$comments\n";
 143   }
 144   elsif ( $line =~ m/^(\w*)\s+(${unoplist})\s+(.*)$/ )
 145   {
 146     my $label = $1;
 147     my $operator = $2;
 148     my $operand = $3;   # Fudging, operand includes any comments.
 149     print "$label\t$operator $operand\n";
 150   }
 151   elsif ( $line =~ m/^(\w*)\s+(${b2alist})(.*)$/ )
 152   {
 153     my $label = $1;
 154     my $operator = $2;
 155     my $comments = $3;
 156     my $realoperator = $operator;
 157     print "$label\tPSHS B\t; ** emulating $operator:\n";
 158     if ( $operator eq "ABA" )
 159     { $realoperator = "ADDA";
 160     }
 161     elsif ( $operator eq "CBA" )
 162     { $realoperator = "CMPA";
 163     }
 164     elsif ( $operator eq "SBA" )
 165     { $realoperator = "SUBA";
 166     }
 167     print "\t$realoperator ,S+\t; $comments\n";
 168   }
 169   elsif ( $line =~ m/^(\w*)\s+(${binop8list})\s*(A|B)\s+(.+)$/ )
 170   {
 171     my $label = $1;
 172     my $operator = $2;
 173     my $operand = $3;
 174     my $comments = $4; # Fudging, comments includes memory operand.
 175     print "$label\t${operator}$operand $comments\n";
 176   }
 177   elsif ( $line =~ m/^(\w*)\s+(${transferlist})(.*)$/ )
 178   {
 179     my $label = $1;
 180     my $operator = $2;
 181     my $comments = $3;
 182     my $source = substr( $operator, 1, 1 );
 183     my $destination = substr( $operator, 2, 1 );
 184     if ( $source eq "P" )
 185     { $source = "CCR";
 186     }
 187     if ( $destination eq "P" )
 188     { $destination = "CCR";
 189     }
 190     print "$label\tTFR $source,$destination\t; $operator : $comments\n";
 191   }
 192   elsif ( $line =~ m/^(\w*)\s+(${flaghandleroplist})($flaghandlerbitlist)(.*)$/ )
 193   { # Bits: EFHINZVC, thus I is 0x10, V is 0x02, and C is 0x01.
 194     my $label = $1;
 195     my $operator = $2;
 196     my $bit = $3;
 197     my $comments = $4;
 198     my $realbits =
 199          ( $bit eq "C" )
 200          ? "\$01"
 201          : ( $bit eq "V" )
 202            ? "\$02"
 203            : ( $bit eq "I" )
 204              ? "\$10"
 205              : $bit;
 206     my $realoperator = $operator;
 207     if ( $operator eq "CL" )
 208     { $realoperator = "ANDCC";
 209       $realbits = "~" . $realbits;
 210     }
 211     elsif ( $operator eq "SE" )
 212     { $realoperator = "ORCC"
 213     }
 214     print "$label\t$realoperator #$realbits\t; ${operator}${bit} : $comments\n";
 215   }
 216   elsif ( $line =~ m/^(\w*)\s+($binop16list)\s+(.+)$/ )
 217   {
 218     my $label = $1;
 219     my $operator = $2;
 220     my $operand = $3;   # Fudging, operand includes any comments.
 221     my $reg16bit = substr( $operator, 2, 1 );
 222     print "$label\tCMP$reg16bit\t$operand\n";
 223   }
 224   elsif ( $line =~ m/^(\w*)\s+(${branchlist})\s+(\*[+-]\$?[0-9A-Fa-f]+)(.*)$/ )
 225   {
 226     my $label = $1;
 227     my $operator = $2;
 228     my $operand = $3;
 229     my $comments = $4;
 230     print "$label\t$operator $operand\t; $comments\n"
 231           . "\t****WARNING**** HARD OFFSET: $operand ****\n";
 232   }
 233   elsif ( $line =~ m/^(\w*)\s+(${interruptstufflist})(.*)$/ )
 234   {
 235     my $label = $1;
 236     my $operator = $2;
 237     my $operand = $3;   # Fudging, operand includes any comments.
 238     print "$label\t$operator$operand\n"
 239           . "\t****WARNING**** Interrupt routines must change!! ****\n";
 240   }
 241   elsif ( $line =~ m/^(\w*)\s+(${waitstufflist})(.*)$/ )
 242   {
 243     my $label = $1;
 244     my $operator = $2;
 245     my $operand = $3;   # Fudging, operand includes any comments.
 246     print "$label\tC$operator #\$EF\t; $operand\n"
 247           . "\t****WARNING**** WAI must change to CWAI!! ****\n";
 248   }
 249   else
 250   {
 251     print $line;
 252   }
 253 }
 254