#!/usr/bin/perl
#
#  Orgasm 8052 Assembler
#
#  Current web site:  http://www.ecstaticlyrics.com/electronics/8052/orgasm/
#
#  If all else fails, search for "Orgasm 8052 Assembler" with the quotes.
#

#$dump = 'true';

# Information is always nice to have...

  if (@ARGV == 0) {
    print STDERR "Usage:  ./orgasm.pl source.asm ...possibly more source files...\r\n";
    print STDERR "Output files are now specified with 'output' in the source files.\r\n";
    exit 1;
  };


# Create a hash of reserved words for easy lookups.

  foreach $peanut ('output', 'section', 'range', 'namespace', 'goto', 'data', 'bytes', 'flags', 'replace') {
    $peanuts{$peanut} = '';
  };


# Read that supercool opcodes file.  Without it we know nothing!

  foreach $line (split /\*/, '00 nop*02 jp xxxx*03 ror*04 inc a*05 inc [xx]*06 inc [r0]*07 inc [r1]*08 inc r0*09 inc r1*0A inc r2*0B inc r3*0C inc r4*0D inc r5*0E inc r6*0F inc r7*10 jisc bt rr*12 call xxxx*13 rcr*14 dec a*15 dec [xx]*16 dec [r0]*17 dec [r1]*18 dec r0*19 dec r1*1A dec r2*1B dec r3*1C dec r4*1D dec r5*1E dec r6*1F dec r7*20 jis bt rr*22 ret*23 rol*24 add xx*25 add [xx]*26 add [r0]*27 add [r1]*28 add r0*29 add r1*2A add r2*2B add r3*2C add r4*2D add r5*2E add r6*2F add r7*30 jic bt rr*32 reti*33 rcl*34 adc xx*35 adc [xx]*36 adc [r0]*37 adc [r1]*38 adc r0*39 adc r1*3A adc r2*3B adc r3*3C adc r4*3D adc r5*3E adc r6*3F adc r7*40 jc rr*42 or [xx] a*43 or [xx] xx*44 or xx*45 or [xx]*46 or [r0]*47 or [r1]*48 or r0*49 or r1*4A or r2*4B or r3*4C or r4*4D or r5*4E or r6*4F or r7*50 jnc rr*52 and [xx] a*53 and [xx] xx*54 and xx*55 and [xx]*56 and [r0]*57 and [r1]*58 and r0*59 and r1*5A and r2*5B and r3*5C and r4*5D and r5*5E and r6*5F and r7*60 jz rr*62 xor [xx] a*63 xor [xx] xx*64 xor xx*65 xor [xx]*66 xor [r0]*67 xor [r1]*68 xor r0*69 xor r1*6A xor r2*6B xor r3*6C xor r4*6D xor r5*6E xor r6*6F xor r7*70 jnz rr*72 ior bt*73 sel*74 mov a xx*75 mov [xx] xx*76 mov [r0] xx*77 mov [r1] xx*78 mov r0 xx*79 mov r1 xx*7A mov r2 xx*7B mov r3 xx*7C mov r4 xx*7D mov r5 xx*7E mov r6 xx*7F mov r7 xx*80 jr rr*82 iand bt*83 tab pc*84 div*85 mov [xx] [xx]*86 mov [xx] [r0]*87 mov [xx] [r1]*88 mov [xx] r0*89 mov [xx] r1*8A mov [xx] r2*8B mov [xx] r3*8C mov [xx] r4*8D mov [xx] r5*8E mov [xx] r6*8F mov [xx] r7*90 mov dp xxxx*92 imov bt c*93 tab dp*94 sbc xx*95 sbc [xx]*96 sbc [r0]*97 sbc [r1]*98 sbc r0*99 sbc r1*9A sbc r2*9B sbc r3*9C sbc r4*9D sbc r5*9E sbc r6*9F sbc r7*A0 iori bt*A2 imov c bt*A3 inc dp*A4 mul*A6 mov [r0] [xx]*A7 mov [r1] [xx]*A8 mov r0 [xx]*A9 mov r1 [xx]*AA mov r2 [xx]*AB mov r3 [xx]*AC mov r4 [xx]*AD mov r5 [xx]*AE mov r6 [xx]*AF mov r7 [xx]*B0 iandi bt*B2 inot bt*B3 inot c*B4 cjne a xx rr*B5 cjne a [xx] rr*B6 cjne [r0] xx rr*B7 cjne [r1] xx rr*B8 cjne r0 xx rr*B9 cjne r1 xx rr*BA cjne r2 xx rr*BB cjne r3 xx rr*BC cjne r4 xx rr*BD cjne r5 xx rr*BE cjne r6 xx rr*BF cjne r7 xx rr*C0 push [xx]*C2 iclr bt*C3 iclr c*C4 swap*C5 xch [xx]*C6 xch [r0]*C7 xch [r1]*C8 xch r0*C9 xch r1*CA xch r2*CB xch r3*CC xch r4*CD xch r5*CE xch r6*CF xch r7*D0 pop [xx]*D2 iset bt*D3 iset c*D4 daa*D5 djnz [xx] rr*D6 xchd [r0]*D7 xchd [r1]*D8 djnz r0 rr*D9 djnz r1 rr*DA djnz r2 rr*DB djnz r3 rr*DC djnz r4 rr*DD djnz r5 rr*DE djnz r6 rr*DF djnz r7 rr*E0 in dp*E2 in r0*E3 in r1*E4 clr a*E5 mov a [xx]*E6 mov a [r0]*E7 mov a [r1]*E8 mov a r0*E9 mov a r1*EA mov a r2*EB mov a r3*EC mov a r4*ED mov a r5*EE mov a r6*EF mov a r7*F0 out dp*F2 out r0*F3 out r1*F4 not a*F5 mov [xx] a*F6 mov [r0] a*F7 mov [r1] a*F8 mov r0 a*F9 mov r1 a*FA mov r2 a*FB mov r3 a*FC mov r4 a*FD mov r5 a*FE mov r6 a*FF mov r7 a') {

    $line =~ s/[\r\n]//g;   # Strip out line terminators.
    $line =~ s/\#.*//g;     # Remove comments.
    $line =~ s/[ \t]+/ /g;  # Change whitespaces to single spaces.
    $line =~ s/^ +//g;      # Remove leading spaces.
    $line =~ s/ +$//g;      # Remove trailing spaces.
    next if $line eq '';    # Skip empty lines.

    # Record the opcode encoding in a hash...

    ($hex, $ops) = $line =~ /([0-9A-F]+) (.+)/;
    die "Opcodes File Error:  Duplicate Entry for '$ops'\r\n" if exists $opcodes{$ops};
    $opcodes{$ops} = pack 'H' . length($hex), $hex;

    # Create a list of reserved terms, e.g. 'bc', 'de', 'hl', etc.

    @eggs = split / /, $ops;
    foreach $egg (@eggs) {
      $eggs{$egg}='';
    };

  };


# Read the substitutions file, because this CPU has way too many constants.

  foreach $line (split /\*/, '[$00] s0r0*[$01] s0r1*[$02] s0r2*[$03] s0r3*[$04] s0r4*[$05] s0r5*[$06] s0r6*[$07] s0r7*[$08] s1r0*[$09] s1r1*[$0A] s1r2*[$0B] s1r3*[$0C] s1r4*[$0D] s1r5*[$0E] s1r6*[$0F] s1r7*[$10] s2r0*[$11] s2r1*[$12] s2r2*[$13] s2r3*[$14] s2r4*[$15] s2r5*[$16] s2r6*[$17] s2r7*[$18] s3r0*[$19] s3r1*[$1A] s3r2*[$1B] s3r3*[$1C] s3r4*[$1D] s3r5*[$1E] s3r6*[$1F] s3r7*[$80] p0*[$81] sp*[$82] dpl*[$83] dph*[$82] dp0l*[$83] dp0h*[$84] dp1l*[$85] dp1h*[$87] pcon*[$88] tcon*[$89] tmod*[$8A] tl0*[$8B] tl1*[$8C] th0*[$8D] th1*[$8E] auxr*[$90] p1*[$98] scon*[$99] sbuf*[$A0] p2*[$A2] auxr1*[$A6] wdtrst*[$A8] ie*[$B0] p3*[$B8] ip*[$C8] t2con*[$C9] t2mod*[$CA] rcap2l*[$CB] rcap2h*[$CC] tl2*[$CD] th2*[$D0] psw*[$E0] acc*[$F0] b*$80 p0.0*$81 p0.1*$82 p0.2*$83 p0.3*$84 p0.4*$85 p0.5*$86 p0.6*$87 p0.7*$90 p1.0*$91 p1.1*$92 p1.2*$93 p1.3*$94 p1.4*$95 p1.5*$96 p1.6*$97 p1.7*$A0 p2.0*$A1 p2.1*$A2 p2.2*$A3 p2.3*$A4 p2.4*$A5 p2.5*$A6 p2.6*$A7 p2.7*$B0 p3.0*$B1 p3.1*$B2 p3.2*$B3 p3.3*$B4 p3.4*$B5 p3.5*$B6 p3.6*$B7 p3.7*$C8 cp_rl2*$C9 c_t2*$CA tr2*$CB exen2*$CC tclk*$CD rclk*$CE exf2*$CF tf2*$A8 ex0*$A9 et0*$AA ex1*$AB et1*$AC es*$AD et2*$AF ea*$D0 p*$D1 f1*$D2 ov*$D3 rs0*$D4 rs1*$D5 f0*$D6 ac*$D7 cy*$88 it0*$89 ie0*$8A it1*$8B ie1*$8C tr0*$8D tf0*$8E tr1 *$8F tf1*$98 ri*$99 ti*$9A rb8*$9B tb8*$9C ren*$9D sm2*$9E sm1*$9F sm0*$B8 px0*$B9 pt0*$BA px1*$BB pt1*$BC ps*$E0 a.0*$E1 a.1*$E2 a.2*$E3 a.3*$E4 a.4*$E5 a.5*$E6 a.6*$E7 a.7*$F0 b.0*$F1 b.1*$F2 b.2*$F3 b.3*$F4 b.4*$F5 b.5*$F6 b.6*$F7 b.7') {

    $line =~ s/[\r\n]//g;   # Strip out line terminators.
    $line =~ s/\#.*//g;     # Remove comments.
    $line =~ s/[ \t]+/ /g;  # Change whitespaces to single spaces.
    $line =~ s/^ +//g;      # Remove leading spaces.
    $line =~ s/ +$//g;      # Remove trailing spaces.
    next if $line eq '';    # Skip empty lines.

    # Record the substitutions in a hash...

    ($code, $constant) = split / /, $line;
    $substitutions{$constant} = $code;

  };


# Verify that the source files exist and are files...

  foreach $sourcefile (@ARGV) {
    if (-e $sourcefile) {
      unless (-f $sourcefile or -l $sourcefile) {
        if (-d $sourcefile) {
          print STDERR "Source file '$sourcefile' isn't a file at all.\r\n"; $fatal = 'unfortunately';
        } else {
          print STDERR "Source file '$sourcefile' isn't a normal file.\r\n"; $fatal = 'unfortunately';
        };
      };
    } else {
      print STDERR "Source file '$sourcefile' does not exist.\r\n"; $fatal = 'unfortunately';
    };
  };

  exit(1) if $fatal;


# Read the source files...

  foreach $sourcefile (@ARGV) {

    if (open SOURCE, "<", "$sourcefile") {
      $source = join '', <SOURCE>; close SOURCE;
      @specials = $source =~ /\# verbose\: ([a-z \-]+?)[\x00\x0A\x0D]/;
      foreach $special (@specials) {
        foreach $item (split / /, $special) {
          print "verbose item: '$item'\r\n";
          $debug{$item} = '';
        };
      };
    } else {
      print STDERR "Error opening '$sourcefile' for input: $!\r\n"; $fatal = 'unfortunately';
    };

    # Convert all line endings to null characters for portability...
    $source =~ s/\r\n/\x00/g;
    $source =~ s/\n(\x00*)\r/\x00$1/g;
    $source =~ s/\n/\x00/g;
    $source =~ s/\r/\x00/g;
    $source .= "\x00" unless $source =~ /\x00$/;

    if (exists $debug{'line-terminators'}) {
      $number = 1;
      foreach $line (split /\x00/, $source) {
        print "Line $number: '$line'\r\n"; $number++;
      };
    };

    push @sources, $sourcefile;
    $sources{$sourcefile} = $source;

  };

  exit if exists $debug{'line-terminators'};

  exit(1) if $fatal;


# Parse the source files...
# (Yes, there are some things that cannot be done with regular expressions.)
#
# This part of Orgasm removes comments from the source, and formats it nicely
# so that the rest of the code has no problem parsing it.  It ensures that
# strings are properly quoted, that square brackets are used correctly,
# it removes unnecessary spaces, and it splits multiple instructions on a line
# into multiple lines, making a note of where each piece of code came from
# in case any error messages are necessary later.

  foreach $sourcefile (@sources) {
    $source = $sources{$sourcefile};

    $line = 1; $part = 1; $string = ''; $quote = ''; $start = 0; @code = ();

    for ($c = 0; $c < length($source); $c++) {
      $character = substr($source, $c, 1);

      $identifier = $sourcefile . ': ' . (($part eq 1) ? ($line) : ($line . '.' . $part));

      $comment = '' if $character eq "\x00";

      if ($character eq "\x00" and $quote ne '') {
        print "$identifier -- $string...\r\n -- Unterminated String\r\n";
        $fatal = 'unfortunately'; $quote = '';
      };

      if ($character eq "\x00" and $bracket ne '') {
        print "$identifier -- $string\r\n -- Unclosed Square Bracket Set\r\n";
        $fatal = 'unfortunately'; $bracket = '';
      };

      if ($comment) {
        # Orgasm is the awesomest assembler ever!
      } elsif ($character eq "\x00") {
        $string =~ s/\s*$//;
        push @code, [$sourcefile . ': ' . (($part eq 1) ? ($line) : ($line . '.' . $part)), $string] if $string;
        if (exists $debug{'parser'}) {
          print $sourcefile . ': ' . (($part eq 1) ? ($line) : ($line . '.' . $part)) . ": '$string'\r\n";
        };
        $line++; $part = 1; $string = '';
      } elsif ($quote eq '"') {
        $string .= $character;
        if ( substr($source, $c+1, 1) =~ /^[\s\,\x00]?$/ ) {
          $quote = '' if $character eq $quote;
        };
      } elsif ($quote eq "'") {
        $string .= $character;
        if ( substr($source, $c+1, 1) =~ /^[\s\,\x00]?$/ ) {
          $quote = '' if $character eq $quote;
        };
      } elsif ($character eq '#') {
        $comment = '#';
      } elsif ($character eq ';') {
        if ($bracket) {
          print "$identifier -- $string\r\n -- Square Bracket Error\r\n";
          $fatal = 'unfortunately'; $bracket = '';
        };
        $string =~ s/\s*$//;
        push @code, [$sourcefile . ': ' . $line . '.' . $part, $string] if $string;
        if (exists $debug{'parser'}) {
          print $sourcefile . ': ' . (($part eq 1) ? ($line) : ($line . '.' . $part)) . ": '$string'\r\n";
        };
        $part++; $string = '';
      } elsif ($bracket) {
        $string .= $character if $character !~ /[\s\,]/;
        $bracket = '' if $character eq $bracket;
      } elsif ($character =~ /[\'\"]/) {
        $string .= $character;
        $quote = $character;
      } elsif ($character eq '[') {
        $string .= ' ' if substr($string, -1) ne ' ';
        $string .= $character;
        $bracket = ']';
      } elsif ($character eq ']') {
        $string .= $character;
        print "$identifier -- $string...\r\n -- Unopened Square Bracket Set\r\n"; $fatal = 'unfortunately';
      } elsif ($character =~ /[\s\,]/) {
        $string .= ' ' if $string !~ /\s$/ and $string ne '';
      } else {
        $string .= $character;
      };

      substr($string, -1, 0) = ' ' if ($string =~ /\].$/ and $string !~ / $/);

    };

    @{$codes{$sourcefile}} = @code;
  };

  exit(1) if $fatal;

  exit if exists $debug{'parser'};


# Here we look for things like "mov a -6 + label" and turn them into
# "mov a -6+label"  It's tricky because we don't combine just anything.
# Stuff in quotes has to be left alone, register names, instruction names
# and reserved words cannot be formed into an equation, and negative symbols
# have to be distinguished from subtraction.  Finally, consecuative
# '+' or '-' symbols are reduced to a single symbol.

  foreach $sourcefile (@sources) {

    for ($i = 0; $i < @{$codes{$sourcefile}}; $i++) {
      $temp = ${$codes{$sourcefile}}[$i][1];

      print '=' x 72 . "\r\nOld Line: $temp\r\n" if exists $debug{'plus-minus'} or exists $debug{'plus-minus-words'};

      @temp = split / /, $temp; $new = '';

      foreach $word (@temp) {

        if ($scratch) {
          $scratch .= ' ' . $word;
          if (length($scratch) > 1 and substr($scratch, 0, 1) eq substr($scratch, -1)) {
            $new .= ' ' . $scratch; $scratch = '';
          }; next;
        } elsif ( $word =~ /^[\'\"]/ ) {
          $scratch = $word;
          if (length($scratch) > 1 and substr($scratch, 0, 1) eq substr($scratch, -1)) {
            $new .= ' ' . $scratch; $scratch = '';
          }; next;
        };

        while ($word =~ /[\+\-][\+\-]/) {
          $word =~ s/\+\-/\-/g while $word =~ /\+\-/;
          $word =~ s/\-\+/\-/g while $word =~ /\-\+/;
          $word =~ s/\-\-/\+/g while $word =~ /\-\-/;
          $word =~ s/\++/\+/g;
        };

        print "Word: '$word'\r\n" if exists $debug{'plus-minus-words'};

        if (
          exists($peanuts{$word}) or exists($peanuts{(split / /, $new)[-1]}) or
          exists($eggs{$word}) or exists($eggs{(split / /, $new)[-1]}) or
          $word =~ /^\[.*\]$/ or (split / /, $new)[-1] =~ /^\[.*\]$/
        ) {
          $word =~ s/^\+//;
          $new .= ' ' . $word;
        } elsif ($new =~ /[\+\-]$/ or $word =~ /^[\+\-]$/) {
          $new .= $word;
        } else {
          $word =~ s/^\+//;
          $new .= ' ' . $word;
        };

        while ($new =~ /[\+\-][\+\-]/) {
          $new =~ s/\+\-/\-/g while $new =~ /\+\-/;
          $new =~ s/\-\+/\-/g while $new =~ /\-\+/;
          $new =~ s/\-\-/\+/g while $new =~ /\-\-/;
          $new =~ s/\++/\+/g;
        };

      };

      $new =~ s/^ +//g; $new =~ s/ +$//g;

      print "New Line: $new\r\n" if exists $debug{'plus-minus'} or exists $debug{'plus-minus-words'};

      ${$codes{$sourcefile}}[$i][1] = $new;

      if ($scratch) {
        $fatal = 1; $scratch = '';
        print STDERR ${$codes{$sourcefile}}[$i][0] . ": Well, fuck...\r\n";
      };

    };

  };

  if ($fatal) {
    print STDERR "Please submit the above error messages and relevant lines of source code to the\r\n";
    print STDERR "developer so that this annoying motherfucking bug can be fixed.  Thank you.\r\n";
    exit(1);
  };
  exit if exists $debug{'plus-minus'};
  exit if exists $debug{'plus-minus-words'};

# Function:  errormsg($text)
#
# This function displays an error message.  It displays the line number,
# part number, and part text, unless this information is the same as for
# the previous error, in which case it doesn't.

  sub errormsg {
    $lineparttext = "$$piece[0] -- $$piece[1]\r\n";
    print $lineparttext unless $lastlineparttext eq $lineparttext;
    $errortext = " -- $_[0]\r\n";
    print $errortext unless $lastlineparttext eq $lineparttext and $lasterrortext eq $errortext;
    $lastlineparttext = $lineparttext; $lasterrortext = $errortext;
  };

# Function: address($number)
#
# Converts a number to a displayable hex number, e.g. "$51AC"

  sub address {
    my ($temp);
    if ($_[0] >= 0) {
      $temp = uc(unpack('H*', reverse pack('l', $_[0])));
    } else {
      $temp = uc(unpack('H*', reverse pack('l', -$_[0])));
    };
    $temp =~ s/^0+//;
    $temp = substr('0000' . $temp, -4) if length($temp) < 4;
    $temp = '$' . $temp;
    if ($_[0] >= 0) {
      return $temp;
    } else {
      return "-$temp";
    };
  };

# Function:  addcode($data)
#
# This function adds assembled code or data to the memory image in the current
# section, and warns if the addition exceeds the section limit.

  sub addcode {
    if ($section eq '') {
      unless (exists $exceeded{"$section.$sourcefile"}) {
        if (keys %sec) {
          errormsg "You must first select a memory range with the 'section' directive.";
        } else {
          errormsg "You must first describe a memory range with the 'range' directive,";
          errormsg "then select that memory range with the 'section' directive.";
        };
        $exceeded{"$section.$sourcefile"} = ''; $fatal = 'unfortunately';
      };
    } else {
      if ($pass == 2 and $dump) {
        my ($i, $line);
        $line = substr(address($sec{$section}[2]), 1);
        for ($i = 0; $i < length($_[0]); $i++) {
          $line .= " " . uc(unpack('H*', substr($_[0], $i, 1)));
        };
        if (length($line) < 16) {
          $line .= ' ' x (16 - length($line));
        };
        print $line . $$piece[1] . "\n";
      };
      substr $memory, $sec{$section}[2], length $_[0], $_[0];
      $sec{$section}[2] += length $_[0];
      if ( $sec{$section}[2] > $sec{$section}[1] ) {
        unless (exists $exceeded{$section}) {
          errormsg "Limit of $sec{$section}[3] '$section' exceeded.";
          $exceeded{$section} = ''; $fatal = 'unfortunately';
        };
      };
    };
  };

# Function:  solve($datatype, $equation)
#
# This function solves equations such as "label + 12" and such, returning
# the specified data type.  'xxxx' is a word, 'xx' is a byte, 'rr' is a
# signed byte relative to the current code pointer, and 'word' is a word
# used by Orgasm which isn't assembled into code.
# Type 'word' returns a number, everything else returns binary data.

  sub solve {
    $equation = $_[1]; @cludge = ();

    if (($pass == 2 and $_[1] ne '') or $_[0] eq 'word') {

      while ($equation ne '') {
        ($whatever) = $equation =~ /([\+\-]?[^\+\-]+)/;
        substr($equation, 0, length($whatever)) = '';
        push @cludge, $whatever;
      };

      $value = 0; $unsolvable = '';
      foreach $term (@cludge) {
        ($math, $term) = $term =~ /([\+\-])?(.*)/;
        if ($term =~ /\./) {
          if ($term =~ /^\./) {
            $term = substr($term, 1);
            if (exists $labels{"$namespace.$prefix.$term"}) {
              $junk = $labels{"$namespace.$prefix.$term"};
            } else {
              errormsg "Local label '.$term' does not exist under prefix '$prefix'."; $fatal = 'unfortunately';
              $unsolvable = 'true';
            };
          } else {
            if (exists $labels{"$namespace.$term"}) {
              $junk = $labels{"$namespace.$term"};
            } elsif (exists $labels{"$term."}) {
              $junk = $labels{"$term."};
            } else {
              $double = $term;
              $double =~ s/\./\.\./g;
              if (exists $labels{$double}) {
                $junk = $labels{"$double"};
              } else {
                errormsg "Label '$term' does not exist in namespace '$namespace',"; $fatal = 'unfortunately';
                ($space, $label) = $term =~ /(.*?)\.(.*)/;
                if (exists $namespaces{$space}) {
                  errormsg "nor does label '$label' exist in namespace '$space'.";
                } else {
                  errormsg "nor is there a namespace '$space' for label '$label' to exist in.";
                };
                $unsolvable = 'true';
              };
            };
          };
        } elsif (exists $labels{"$namespace.$term."}) {
          $junk = $labels{"$namespace.$term."};
        } elsif (exists $labels{"$namespace..$term"}) {
          $junk = $labels{"$namespace..$term"};
        } elsif (exists $labels{".$term."}) {
          $junk = $labels{".$term."};
        } elsif ($term eq '$') {
          $junk = $sec{$section}[2];
        } elsif ($term =~ /^\$[0-9A-Fa-f]+$/) {
          $junk = hex substr($term, 1);
        } elsif ($term =~ /^0x[0-9A-Fa-f]+$/) {
          $junk = hex substr($term, 2);
        } elsif ($term =~ /^[0-9]+/) {
          $junk = $term;
        } else {
          errormsg "I cannot figure out how to turn '$term' into a number.";
          $fatal = 'unfortunately'; $unsolvable = 'true';
        };
        if ($math eq '-') {
          $value -= $junk;
        } else {
          $value += $junk;
        };
      };

    } else {
      # We don't know the value of labels in pass one, so always return zero.
      $value = 0; $value = $sec{$section}[2] if $_[0] eq 'rr';
    };

    if ($_[0] eq 'xxxx') {
      if ($value > 65535 or $value < -32768) {
        errormsg "Value $value does not fit into a word."; $fatal = 'unfortunately';
      }; $value += 65536 if $value < 0;
      return pack 'v', $value;
    } elsif ($_[0] eq 'xx') {
      if ($value > 255 or $value < -128) {
        errormsg "Value $value does not fit into a byte."; $fatal = 'unfortunately';
      }; $value += 256 if $value < 0;
      return pack 'C', $value;
    } elsif ($_[0] eq 'rr') {
      $size = '';
      $size = 2 if $cream =~ /^(jc|jnc|jz|jnz|jr) /;
      $size = 3 if $cream =~ /^(jisc|jis|jic|cjne) /;
      $size = 2 if $cream =~ /^djnz r[0-7] /;
      $size = 2 if $cream =~ /^djnz \[r[0-7]\] /;
      $size = 3 if $cream =~ /^djnz \[xx\] /;
      unless ($size ne '') {
        die "I'm a broken assembler!  Details: unknown cream: '$cream'\n";
      };
      $value = ($value - $sec{$section}[2] - $size) & 65535;
      $value -= 65536 if $value > 32767;
      if (($value > 127 or $value < -128) and $unsolvable ne 'true') {
        $value = '+' . $value if $value >= 0;
        errormsg "A relative location $value bytes away is too far."; $fatal = 'unfortunately';
      };
      return pack 'c', $value;
    } elsif ($_[0] eq 'word') {
      return $value;
    };

  };


# The assembler!!!  Yes, this is where the fun happens!
#
# Assembly is done in two passes.  The first pass is just to determine the
# value of labels, the second pass does the final assembly.

  %namespaces = ();
  foreach $pass (1,2) {
    %sec = (); $memory = "\x00" x 65536;

    foreach $sourcefile (@sources) {
      @code = @{$codes{$sourcefile}};
      if ($sourcefile =~ /\./) {
        ($namespace) = $sourcefile =~ /(.*)\./;
      } else {
        $namespace = $sourcefile;
      };
      $namespaces{$namespace} = '';
      $section = ''; $prefix = '';

      foreach $piece (@code) {
        if ($$piece[1] =~ /^output .* \S+ \S+$/) {
          @ops = $$piece[1] =~ /^output (.*) (\S+) (\S+)$/;
          $base = solve('word', $ops[1]);
          $limit = solve('word', $ops[2]);
          $size = $limit - $base + 1;
          if ($ops[0] =~ /^[\'\"].*[\'\"]$/ and substr($ops[0], 0, 1) eq substr($ops[0], -1)) {
            $ops[0] = substr($ops[0], 1, length($ops[0]) - 2);
          };
          if ($pass == 2) {
            if (open OUTPUT, ">", $ops[0]) {
              print OUTPUT substr($memory, $base, $size); close OUTPUT;
              $successfuloutput = 'true' unless $successfuloutput eq 'false';
            } else {
              select STDERR;
              errormsg "Error opening '$ops[0]' for output: $!";
              select STDOUT;
              $fatal = 'unfortunately'; $successfuloutput = 'false';
            };
          };
        } elsif ($$piece[1] =~ /^(range) \S+ \S+ \S+$/) {
          @ops = $$piece[1] =~ /^(range) (\S+) (\S+) (\S+)$/;
          $base = solve('word', $ops[2]);
          $limit = solve('word', $ops[3]) + 1;
          if ($base eq 'whatever' or $limit eq 'whatever') {
            errormsg "Each $ops[0] value must be solvable in pass one, which means that any";
            errormsg "labels used in the definition must appear before the $ops[0] declaration.";
            $fatal = 'unfortunately'; $base = 0; $limit = 65535;
          };
          foreach $item (keys %namespaces) {
            if (exists $labels{"$item..$ops[1]"}) {
              errormsg "Label '$ops[1]' is also defined at " . $definitions{"$item..$ops[1]"}; $fatal = 'unfortunately';
            } elsif (exists $labels{"$item.$ops[1].."}) {
              errormsg "Label '$ops[1]' is also defined at " . $definitions{"$item.$ops[1]."}; $fatal = 'unfortunately';
            };
          };
          if (exists $sec{$ops[1]}) {
            unless ($sec{$ops[1]}[0] == $base and $sec{$ops[1]}[1] == $limit) {
              errormsg "This definition of '$ops[1]' differs from the original definition which is";
              errormsg "located at " . $definitions{"section.$ops[1]"}; $fatal = 'unfortunately';
            };
          } else {
            $sec{$ops[1]}[0] = $base;
            $sec{$ops[1]}[1] = $limit;
            if ($base < 0) {
              errormsg "A base address of " . address($base) . " is too negative."; $fatal = 'unfortunately';
              $sec{$ops[1]}[0] = 0;
              $sec{$ops[1]}[1] = 65535;
            };
            if ($base > 65535) {
              errormsg "A base address of " . address($base) . " exceeds the 64k address space."; $fatal = 'unfortunately';
              $sec{$ops[1]}[0] = 0;
              $sec{$ops[1]}[1] = 65535;
            };
            if ($limit < $base) {
              errormsg "The base address must be less than or equal to the limit address."; $fatal = 'unfortunately';
              $sec{$ops[1]}[0] = 0;
              $sec{$ops[1]}[1] = 65535;
            };
            if ($limit > 65536) {
              errormsg "A limit address of " . address($limit - 1) . " is beyond the 64k address space."; $fatal = 'unfortunately';
              $sec{$ops[1]}[0] = 0;
              $sec{$ops[1]}[1] = 65535;
            };
            $sec{$ops[1]}[2] = $sec{$ops[1]}[0];
            $sec{$ops[1]}[3] = $ops[0];
            $labels{".$ops[1]."} = $sec{$ops[1]}[0];
            $definitions{".$ops[1]."} = $$piece[0];
          };
        } elsif ($$piece[1] =~ /^(section) \S+$/) {
          @ops = $$piece[1] =~ /^(section) (\S+)$/;
          $section = $ops[1];
          unless (exists $sec{$section}) {
            errormsg "Please define $ops[0] '$section' before using it."; $fatal = 'unfortunately';
            $sec{$section}[0] = 0;
            $sec{$section}[1] = 65535;
            $sec{$section}[2] = $sec{$section}[0];
            $sec{$section}[3] = $ops[0];
            $labels{".$section."} = $sec{$section}[0];
            $definitions{".$section."} = "...well, it was used before it was defined, so, nowhere.";
          };
        } elsif ($$piece[1] =~ /^namespace \S+$/) {
          @ops = $$piece[1] =~ /^namespace (\S+)$/;
          $namespace = $ops[0]; $namespaces{$namespace} = ''; $prefix = '';
        } elsif ($$piece[1] =~ /^goto \S+$/) {
          @ops = $$piece[1] =~ /^goto (\S+)$/;
          $address = solve('word', $ops[0]);
          if ($sec{$section}[0] <= $address and $sec{$section}[1] >= $address) {
            $sec{$section}[2] = $address; delete $exceeded{$section};
          } elsif ($address eq 'whatever') {
            errormsg "Arguments to the 'goto' directive must be solvable in pass one."; $fatal = 'unfortunately';
          } else {
            errormsg "Address " . address($address) . " is not in $sec{$section}[3] $section, which ranges from " . address($sec{$section}[0]) . " to " . address($sec{$section}[1] - 1) . "."; $fatal = 'unfortunately';
          };
        } elsif ($$piece[1] =~ /^bits \S+/) {
          @ops = split / /, $$piece[1];
          shift @ops;
          foreach $word (@ops) {
            if ($pass == 1) {
              if (exists $labels{"$namespace..$word"}) {
                errormsg "Label '$word' is also defined at " . $definitions{"$namespace..$word"}; $fatal = 'unfortunately';
              } elsif (exists $labels{"$namespace.$word.."}) {
                errormsg "Label '$word' is also defined at " . $definitions{"$namespace.$word."}; $fatal = 'unfortunately';
              } elsif (exists $labels{".$word."}) {
                errormsg "Label '$word' is also defined at " . $definitions{".$word."}; $fatal = 'unfortunately';
              } else {
                if ($allocated_bits >= 128) {
                  errormsg "There are no more bits left to allocate."; $fatal = 'unfortunately';
                };
                $labels{"$namespace..$word"} = $allocated_bits++;
                $definitions{"$namespace..$word"} = $$piece[0];
              };
            };
          };
        } elsif ($$piece[1] =~ /^bytes \S+/) {
          @ops = split / /, $$piece[1];
          shift @ops;
          foreach $word (@ops) {
            if ($pass == 1) {
              if (exists $labels{"$namespace..$word"}) {
                errormsg "Label '$word' is also defined at " . $definitions{"$namespace..$word"}; $fatal = 'unfortunately';
              } elsif (exists $labels{"$namespace.$word.."}) {
                errormsg "Label '$word' is also defined at " . $definitions{"$namespace.$word."}; $fatal = 'unfortunately';
              } elsif (exists $labels{".$word."}) {
                errormsg "Label '$word' is also defined at " . $definitions{".$word."}; $fatal = 'unfortunately';
              } else {
                if ($allocated_bytes + 48 >= 128) {
                  errormsg "There are no more bytes left to allocate."; $fatal = 'unfortunately';
                };
                $labels{"$namespace..$word"} = $allocated_bytes++ + 48;
                $definitions{"$namespace..$word"} = $$piece[0];
              };
            };
          };
        } elsif ($$piece[1] =~ /^data \S+/) {
          @ops = split / /, $$piece[1];
          shift @ops;
          foreach $word (@ops) {
            if ($quote ne '') {
              $scratch .= ' ' . $word;
              if ($quote eq substr($word, -1)) {
                $word = $scratch;
                $quote = ''; $scratch = '';
              };
            } elsif ($word =~ /^[\'\"]/) {
              if ($word !~ /^\'.*\'$/ and $word !~ /^\".*\"$/) {
                $scratch = $word;
                ($quote) = $word =~ /^([\'\"])/;
              };
            };
            if ($quote eq '') {
              if ($word =~ /^\$[0-9A-Fa-f]{2}$/) {
                $data = pack "C", hex substr($word, 1, 2);
                addcode $data;
              } elsif ($word =~ /^\$[0-9A-Fa-f]{4}$/) {
                $data = pack "v", hex substr($word, 1, 4);
                addcode $data;
              } elsif ($word =~ /^\!([0-9A-Fa-f]{2})+$/) {
                $len = (length $word) - 1;
                $data = pack "H$len", substr($word, 1);
                addcode $data;
              } elsif ($word =~ /^\".*\"$/ or $word =~ /^\'.*\'$/) {
                $len = (length $word) - 2;
                $data = substr($word, 1, $len);
                addcode $data;
              } else {
                errormsg "Data statement requires numbers in the form of \$xx or \$xxxx."; $fatal = 'unfortunately';
              };
            };
          };
        } elsif ($$piece[1] =~ /^replace \S+ \S+/) {
          @ops = split / /, $$piece[1];
          shift @ops; $symbol = shift @ops;
          $replacements{$symbol} = [@ops];
        } elsif (exists $peanuts{(split / /, $$piece[1])[0]}) {
          errormsg "Incorrect number of operands for this directive."; $fatal = 'unfortunately';
        } elsif (exists $opcodes{$$piece[1]}) {
          addcode $opcodes{$$piece[1]};
        } elsif (exists $eggs{$$piece[1]}) {
          errormsg "Instruction of form '$$piece[1]' not found in opcodes list."; $fatal = 'unfortunately';
        } else {
          @temp = split / /, $$piece[1];
          $cream = shift @temp;
          $index = 0; while ($index < @temp) {
            if (exists $replacements{$temp[$index]}) {
              $next = $index + @{$replacements{$temp[$index]}};
              splice @temp, $index, 1, @{$replacements{$temp[$index]}};
              $index = $next;
            } else {
              $index++;
            };
          };
          if (@temp) {
            $toast = ''; $first = ''; $second = ''; $third = '';
            for ($t = 0; $t < @temp; $t++) {
              $temp[$t] = $substitutions{$temp[$t]} if exists $substitutions{$temp[$t]};
              if (exists $eggs{$temp[$t]}) {
                $cream .= ' ' . $temp[$t];
              } elsif ($temp[$t] =~ /^\[.*\]$/) {
                $cream .= ' [xx]';
                $first .= solve('xx', $temp[$t] =~ /^\[(.*)\]$/);
              } elsif ($cream =~ /^(jisc|jis|jic)\b/ and $t == 0) {
                $cream .= ' bt';
                $second = solve('xx', $temp[$t]);
              } elsif ($cream =~ /^(jisc|jis|jic|cjne)\b/ and $t == @temp - 1) {
                $cream .= ' rr';
                $third = solve('rr', $temp[$t]);
              } else {
                $cream .= ' ***'; $toast = $temp[$t];
              };
            };
            if ($toast eq '') {
              if (exists $opcodes{$cream}) {
                addcode $opcodes{$cream} . reverse($first) . reverse($second) . reverse($third);
              } else {
                errormsg "Instruction of form '$cream' not found in opcodes list."; $fatal = 'unfortunately';
              };
            } else {
              ($xxxx = $cream) =~ s/\*\*\*/xxxx/;
              ($xx = $cream) =~ s/\*\*\*/xx/;
              ($rr = $cream) =~ s/\*\*\*/rr/;
              ($bt = $cream) =~ s/\*\*\*/bt/;
              if (exists $opcodes{$xxxx}) {
                $second = solve('xxxx', $toast);
                addcode $opcodes{$xxxx} . reverse($first) . reverse($second) . reverse($third);
              } elsif (exists $opcodes{$xx}) {
                $second = solve('xx', $toast);
                addcode $opcodes{$xx} . reverse($first) . reverse($second) . reverse($third);
              } elsif (exists $opcodes{$rr}) {
                $second = solve('rr', $toast);
                addcode $opcodes{$rr} . reverse($first) . reverse($second) . reverse($third);
              } elsif (exists $opcodes{$bt}) {
                $second = solve('xx', $toast);
                addcode $opcodes{$bt} . reverse($first) . reverse($second) . reverse($third);
              } else {
                errormsg "Instruction of form '$cream' not found in opcodes list."; $fatal = 'unfortunately';
              };
            };
          } else {
            if ($cream !~ /\./) {
              $prefix = $cream; $suffix = '';
            } elsif ($cream =~ /^\.[^\.]+$/) {
              $suffix = substr($cream, 1);
            } elsif ($cream =~ /^[^\.]+\.[^\.]+$/) {
              ($prefix, $suffix) = $cream =~ /([^\.]+)\.([^\.]+)/;
            } elsif ($cream =~ /^[^\.]+\.$/) {
              $prefix = substr($cream, 0, -1); $suffix = '';
            } else {
              errormsg "Label names may contain only one period.";
              $suffix = "\x00" . $hate++;  $fatal = 'unfortunately';
            };
            if ($pass == 1) {
              if (exists $labels{"$namespace..$prefix"} and $cream eq '') {
                errormsg "Label '$prefix' is also defined at " . $definitions{"$namespace..$prefix"}; $fatal = 'unfortunately';
              } elsif (exists $labels{"$namespace.$prefix.$suffix"}) {
                errormsg "Label '$cream' is also at " . $definitions{"$namespace.$prefix.$suffix"}; $fatal = 'unfortunately';
              } elsif (exists $labels{".$prefix."} and $cream eq '') {
                errormsg "Label '$prefix' is also defined at " . $definitions{".$prefix."}; $fatal = 'unfortunately';
              } else {
                if ($prefix ne '') {
                  $labels{"$namespace.$prefix.$suffix"} = $sec{$section}[2];
                  $definitions{"$namespace.$prefix.$suffix"} = $$piece[0];
                } else {
                  errormsg "This sub-label does not have a parent label."; $fatal = 'unfortunately';
                };
              };
            };
          };
        };
      };
    };

    exit(1) if $fatal;  # If pass one fails, skip pass two.
  };

# Well, with any luck...

  unless ($successfuloutput) {
    print STDERR "No errors, but a lack of any 'output' statement means a lack of any output.\r\n";
  };