#!/usr/bin/perl
# The P65 Assembler, v 1.0
# Copyright (c) 2001,2 Michael Martin
# All rights reserved.
#
# Redistribution and use, with or without modification, are permitted
# provided that the following conditions are met:
#
# - Redistributions of the code must retain the above copyright
#   notice, this list of conditions and the following disclaimer.
#
# - The name of Michael Martin may not be used to endorse or promote
#   products derived from this software without specific prior written
#   permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.

use strict;
use integer;

# Global variables

my $pc;            # Current program counter
my $linenum;       # Current line number
my $currentfile;   # Current file name
my @IR = ( );      # Intermediate Representation list
my @code = ( );    # Final binary

my $verbose;

# Error reporting routines

my $errorcount = 0;

sub asmerror {
    my $err = shift;
    print "ERROR: $currentfile:$linenum: $err\n";
    $errorcount++;
}

sub num_errors { return $errorcount; }

sub report_errors {
    my $errornum = $errorcount ? $errorcount : "No";
    my $errorname = ($errorcount == 1) ? "error" : "errors";
    print "$errornum $errorname\n";
}

# Argument Evaluation Routines

sub create_arg {
    my ($prefix, $type, $val, $offset) = @_;
    return [$prefix, $type, $val, $offset];
}

sub can_evaluate {
    my $arg = shift;
    my ($prefix, $type, $val, $offset) = @$arg;
    return ($type eq "num" || label_exists($val));
}

sub hardcoded_arg {
    my $arg = shift;
    my ($prefix, $type, $val, $offset) = @$arg;
    return ($type eq "num");
}

sub eval_arg {
    my $result = 0;
    my $arg = shift;
    my ($prefix, $type, $val, $offset) = @$arg;
    if ($type eq "num") {
	$result = $val; 
    } else {
	$result = label_value($val);
    }
    $result += $offset;
    if ($prefix eq "<") {
	return $result % 256;
    } elsif ($prefix eq ">") {
	return $result / 256;
    } else {
	return $result;
    }
}

sub arg_as_string {
    my $arg = shift;
    my ($prefix, $type, $val, $offset) = @$arg;

    my $sign = ($offset < 0) ? "" : "+";
    my $suffix = ($offset == 0) ? "" : "${sign}$offset";

    if ($prefix eq "") {
	return "${val}$suffix";
    } else {
	return "${prefix}${val}$suffix";
    }
}

1;

# The IR Walker

sub walk {
    my $dispatchtable = shift;
    $pc = 0;
    for (@IR) {
	($linenum, $currentfile) = @$_;
	my $node_type = $$_[2];
	if (exists $$dispatchtable{$node_type}) {
	    &{$$dispatchtable{$node_type}}($_);
	} elsif (exists $$dispatchtable{"UNKNOWN"}) {
	    &{$$dispatchtable{"UNKNOWN"}}($_);
	} else {
	    asmerror "Unknown IR type $node_type";
	}
    }
}

# Labels support

my %labels = ( );  # Label -> PC hash

sub label_exists {
    my $label = shift;
    return ((exists $labels{$label}) || ($label eq "^"));
}

sub label_value {
    my $label = shift;
    if ($label eq "^") {
	return $pc;
    } else {
	return $labels{$label};
    }
}

sub set_label {
    my ($label, $value) = @_;
    $labels{$label} = $value;
}

sub defined_labels { return keys %labels; }

# Lexer: breaks lines into tokens

my $instrs="-adc-and-asl-bcc-bcs-beq-bit-bmi-bne-bpl-brk-bvc-bvs-clc-cld-cli-clv-cmp-cpx-cpy-dec-dex-dey-eor-inc-inx-iny-jmp-jsr-lda-ldx-ldy-lsr-nop-ora-pha-php-pla-plp-rol-ror-rti-rts-sbc-sec-sed-sei-sta-stx-sty-tax-tay-tsx-txa-txs-tya-";

sub is_opcode {
    my $id = shift;
    return $instrs =~ /-$id-/;
}

sub interpret_token {
    my $tok = shift;
    my $firstchar = substr($tok, 0, 1);
    my $rest = substr($tok, 1);
    if ($tok eq "") {
	return ();
    } elsif ($firstchar eq '"') {
	return ["STRING", $rest];
    } elsif ($firstchar eq "\$") {
	if ($rest =~ /^[0-9a-f]+$/i) {
            my $result = hex $rest;
	    return ["NUM", $result];
        } else {
	    asmerror("Expected a hex value, not '$rest'");
	    return ["NUM", 0];
        }
    } elsif ($firstchar eq "\%") {
       	if ($rest =~ /^[01]+$/) {
     	    my $result = 0;
	    my @bits = split //, $rest;
	    for (@bits) {
	       	$result *= 2;
		$result += $_;
	    }
	    return ["NUM", $result];
	} else {
	    asmerror("Expected a binary value, not '$rest'");
	    return ["NUM", 0];
	}
    } elsif ($firstchar eq "0") {
	if ($tok =~ /^[0-7]+$/i) {
	    my $result = oct $tok;
	    return ["NUM", $result];
	} else {
	    asmerror("Expected an octal value, not '$rest'");
	    return ["NUM", 0];
	}
    } elsif ($firstchar =~ /[1-9]/) {
	if ($tok =~ /^[0-9]+$/i) {
	    my $result = int $tok;
	    return ["NUM", $result];
	} else {
	    asmerror("Expected a decimal value, not '$rest'");
	    return ["NUM", 0];
	}
    } elsif ($firstchar eq "'") {
	if (substr($rest,1) eq "") {
	    return ["NUM", ord $rest];
	} else {
	    asmerror("Expected a character, not '$rest'");
	    return ["NUM", 0];
	}
    } elsif ($firstchar =~ /[\#,<>():.+\-^*]/) {
	if ($rest ne "") { asmerror("lexer error: $tok can't happen"); }
	if ($firstchar eq "^") {
	    return ["LABEL", "^"]; 
	} else {
	    return [$firstchar];
	}
    } else {  # Label or opcode.
	my $id = lc($tok);
	if (is_opcode($id)) {
	    return (["OPCODE", $id]);
	} elsif ($id eq "x") {
	    return (["X"]);
	} elsif ($id eq "y") {
	    return (["Y"]);
	} else {
	    return (["LABEL", $id]);
	}
    }
}

sub interpret_EOL {
    return ["EOL"];
}

sub lex {
    my $input = shift;
    my @result = ();
    my $value = "";
    my ($quotemode, $backspacemode) = (0, 0);
    
    my @chars = split //, $input;
    
    for (@chars) {
	if ($backspacemode) {
	    $backspacemode = 0;
	    $value .= $_;
	} elsif ($_ eq "\\") {
	    $backspacemode = 1;
	} elsif ($quotemode) {
	    if ($_ eq '"') {
		$quotemode = 0;
	    } else {
		$value .= $_;
	    }
	} else {
	    if ($_ eq ";") {
		push @result, interpret_token($value);
		$value = "";
		last;
	    } elsif ($_ =~ /\s/) {
		push @result, interpret_token($value);
		$value = "";
	    } elsif ($_ =~ /[\#<>,():.+\-^*]/) {
		push @result, interpret_token($value);
		push @result, interpret_token($_);
		$value = "";
	    } elsif ($_ eq '"') {
		push @result, interpret_token($value);
		$value = '"';
		$quotemode = 1;
	    } else {
		$value .= $_;
	    }
	}
    }
    if ($backspacemode) { asmerror("Cannot end a line with a backspace"); }
    if ($quotemode) { asmerror("Unterminated string constant"); }

    push @result, interpret_token($value);    
    push @result, interpret_EOL();

    return @result;
}

# Opcode interpretation routines

my %opcodes = (
	       adc_imm  => 0x69,
	       adc_zp   => 0x65,
	       adc_zpx  => 0x75,
	       adc_abs  => 0x6D,
	       adc_absx => 0x7D,
	       adc_absy => 0x79,
	       adc_indx => 0x61,
	       adc_indy => 0x71,
	       and_imm  => 0x29,
	       and_zp   => 0x25,
	       and_zpx  => 0x35,
	       and_abs  => 0x2D,
	       and_absx => 0x3D,
	       and_absy => 0x39,
	       and_indx => 0x21,
	       and_indy => 0x31,
	       asl_imp  => 0x0A,
	       asl_zp   => 0x06,
	       asl_zpx  => 0x16,
	       asl_abs  => 0x0E,
	       asl_absx => 0x1E,
	       bcc_rel  => 0x90,
	       bcs_rel  => 0xB0,
	       beq_rel  => 0xF0,
	       bit_zp   => 0x24,
	       bit_abs  => 0x2C,
	       bmi_rel  => 0x30,
	       bne_rel  => 0xD0,
	       bpl_rel  => 0x10,
	       brk_imp  => 0x00,
	       bvc_rel  => 0x50,
	       bvs_rel  => 0x70,
	       clc_imp  => 0x18,
	       cld_imp  => 0xD8,
	       cli_imp  => 0x58,
	       clv_imp  => 0xB8,
	       cmp_imm  => 0xC9,
	       cmp_zp   => 0xC5,
	       cmp_zpx  => 0xD5,
	       cmp_abs  => 0xCD,
	       cmp_absx => 0xDD,
	       cmp_absy => 0xD9,
	       cmp_indx => 0xC1,
	       cmp_indy => 0xD1,
	       cpx_imm  => 0xE0,
	       cpx_zp   => 0xE4,
	       cpx_abs  => 0xEC,
	       cpy_imm  => 0xC0,
	       cpy_zp   => 0xC4,
	       cpy_abs  => 0xCC,
	       dec_zp   => 0xC6,
	       dec_zpx  => 0xD6,
	       dec_abs  => 0xCE,
	       dec_absx => 0xDE,
	       dex_imp  => 0xCA,
	       dey_imp  => 0x88,
	       eor_imm  => 0x49,
	       eor_zp   => 0x45,
	       eor_zpx  => 0x55,
	       eor_abs  => 0x4D,
	       eor_absx => 0x5D,
	       eor_absy => 0x59,
	       eor_indx => 0x41,
	       eor_indy => 0x51,
	       inc_zp   => 0xE6,
	       inc_zpx  => 0xF6,
	       inc_abs  => 0xEE,
	       inc_absx => 0xFE,
	       inx_imp  => 0xE8,
	       iny_imp  => 0xC8,
	       jmp_abs  => 0x4C,
	       jmp_ind  => 0x6C,
	       jsr_abs  => 0x20,
	       lda_imm  => 0xA9,
	       lda_zp   => 0xA5,
	       lda_zpx  => 0xB5,
	       lda_abs  => 0xAD,
	       lda_absx => 0xBD,
	       lda_absy => 0xB9,
	       lda_indx => 0xA1,
	       lda_indy => 0xB1,
	       ldx_imm  => 0xA2,
	       ldx_zp   => 0xA6,
	       ldx_zpy  => 0xB6,
	       ldx_abs  => 0xAE,
	       ldx_absy => 0xBE,
	       ldy_imm  => 0xA0,
	       ldy_zp   => 0xA4,
	       ldy_zpx  => 0xB4,
	       ldy_abs  => 0xAC,
	       ldy_absx => 0xBC,
	       lsr_imp  => 0x4A,
	       lsr_zp   => 0x46,
	       lsr_zpy  => 0x56,
	       lsr_abs  => 0x4E,
	       lsr_absy => 0x5E,
	       nop_imp  => 0xEA,
	       ora_imm  => 0x09,
	       ora_zp   => 0x05,
	       ora_zpx  => 0x15,
	       ora_abs  => 0x0D,
	       ora_absx => 0x1D,
	       ora_absy => 0x19,
	       ora_indx => 0x01,
	       ora_indy => 0x11,
	       pha_imp  => 0x48,
	       php_imp  => 0x08,
	       pla_imp  => 0x68,
	       plp_imp  => 0x28,
	       rol_imp  => 0x2A,
	       rol_zp   => 0x26,
	       rol_zpx  => 0x36,
	       rol_abs  => 0x2E,
	       rol_absx => 0x3E,
	       ror_imp  => 0x6A,
	       ror_zp   => 0x66,
	       ror_zpx  => 0x76,
	       ror_abs  => 0x6E,
	       ror_absx => 0x7E,
	       rti_imp  => 0x40,
	       rts_imp  => 0x60,
	       sbc_imm  => 0xE9,
	       sbc_zp   => 0xE5,
	       sbc_zpx  => 0xF5,
	       sbc_abs  => 0xED,
	       sbc_absx => 0xFD,
	       sbc_absy => 0xF9,
	       sbc_indx => 0xE1,
	       sbc_indy => 0xF1,
	       sec_imp  => 0x38,
	       sed_imp  => 0xF8,
	       sei_imp  => 0x78,
	       sta_zp   => 0x85,
	       sta_zpx  => 0x95,
	       sta_abs  => 0x8D,
	       sta_absx => 0x9D,
	       sta_absy => 0x99,
	       sta_indx => 0x81,
	       sta_indy => 0x91,
	       stx_zp   => 0x86,
	       stx_zpy  => 0x96,
	       stx_abs  => 0x8E,
	       sty_zp   => 0x84,
	       sty_zpx  => 0x94,
	       sty_abs  => 0x8C,
	       tax_imp  => 0xAA,
	       tay_imp  => 0xA8,
	       tya_imp  => 0x98,
	       tsx_imp  => 0xBA,
	       txa_imp  => 0x8A,
	       txs_imp  => 0x9A,
	       tya_imp  => 0x98
	       );

sub has_mode {
    my ($opcode, $mode) = @_;
    return exists $opcodes{"${opcode}_$mode"};
}

sub get_opcode {
    my ($opcode, $mode) = @_;
    return $opcodes{"${opcode}_$mode"};
}

# The parser

my @line;
my $temp_label_count;

# Pragma dispatch table

my %pragmas = (
	       address => \&pragma_word,
	       advance => \&pragma_advance,
	       alias   => \&pragma_alias,
	       ascii   => \&pragma_ascii,
	       byte    => \&pragma_byte,
	       word    => \&pragma_word,
	       include => \&pragma_include,
	       link    => \&pragma_link,
	       org     => \&pragma_org,
	       space   => \&pragma_space,
	       );

sub token_type {
    my $tok = shift;
    if ($tok) { return lc $$tok[0] };
}

sub token_value {
    my $tok = shift;
    if ($tok) { return $$tok[1] };
}

sub typematch {
    my ($token, $target) = @_;
    return (token_type($token) eq lc($target));
}

sub expect {
    my $actual = shift @line;
    for (@_) { if (typematch($actual, $_)) { return $actual; } }
    my $expected = join '", "', @_;
    asmerror "Expected \"$expected\"";
}

sub lookahead {
    my ($range, @targets) = @_;
    my $result = 0;

    if (@line > $range) {
	my $actual = $line[$range];
	for (@targets) {
	    if (typematch($actual, $_)) { return $actual; } 
	}
    }
}

sub add_IR {
    push @IR, [$linenum, $currentfile, @_];
}

sub parse_line {
    if (lookahead(0, "EOL")) { 
	return;
    } elsif (lookahead(1, ":")) {
	my $newlabel = token_value(expect("label"));
	expect ":";
	add_IR("LABEL", $newlabel, create_arg("","label","^",0));
	parse_line();
	return;
    } elsif (lookahead(0, ".")) {
	parse_pragma();
    } elsif (lookahead(0, "*")) {
	$temp_label_count++;
	expect "*";
	add_IR("LABEL", "\*$temp_label_count", create_arg("","label","^",0));
	parse_line();
    } else {
	parse_instr();
    }
    return;
}

sub parse_pragma {
    expect(".");
    my $pragma = token_value(expect("label"));
    if (exists $pragmas{$pragma}) {
	&{$pragmas{$pragma}}();
    } else {
	asmerror "Unknown pragma .$pragma";
    }
}

sub pragma_ascii {
    my $str = token_value(expect("string"));
    expect("EOL");
    my @data = map ord, split (//, $str);
    add_IR("BYTE", map {create_arg("","num",$_,0);} @data);
}

sub pragma_advance {
    my $target = parse_arg();
    expect("EOL");
    add_IR("ADVANCE", $target);
}

sub pragma_alias {
    my $newlabel = token_value(expect("label"));
    my $target = parse_arg();
    expect("EOL");
    add_IR("LABEL", $newlabel, $target);
}

sub pragma_byte {
    my $sep = ",";
    my @vals;
    while ($sep eq ",") {
	my $val = parse_arg();
	push @vals, $val;
	$sep = token_type(expect(",", "eol"));
    }
    add_IR("BYTE", @vals);
}

sub pragma_word {
    my $sep = ",";
    my @vals;
    while ($sep eq ",") {
	my $val = parse_arg();
	push @vals, $val;
	$sep = token_type(expect(",", "eol"));
    }
    add_IR("WORD", @vals);
}

sub pragma_include {
    my $file = token_value(expect("string"));
    expect("EOL");

    parsefile($file);
}

sub pragma_org {
    my $target = parse_arg();
    expect("EOL");
    add_IR("SETPC", $target);
}

sub pragma_link {
    my $file = token_value(expect("string"));
    my $target = parse_arg();
    expect("EOL");

    add_IR("SETPC", $target);
    parsefile($file);
}

sub pragma_space {
    my $newlabel = token_value(expect("label"));
    my $size = token_value(expect("num"));
    expect("EOL");

    add_IR("LABEL", $newlabel, create_arg("","label","^",0));
    add_IR("SETPC", create_arg("", "label", "^", $size));
}

sub parse_arg {
    my ($prefix, $arg, $offset) = ("", "", 0);
    if (lookahead(0, "<", ">")) {
	$prefix = token_type(expect("<", ">"));
    }
    my ($arg_type, $arg_val);
    if (lookahead(0, "+")) {
	my $target = $temp_label_count;
	$arg_type = "label";
	while(lookahead(0, "+") && !lookahead(1, "num")) {
	    expect("+");
	    $target++;
	}
	$arg_val = "\*$target";
    } elsif(lookahead(0, "-")) {
	my $target = $temp_label_count+1;
	$arg_type = "label";
	while(lookahead(0, "-") && !lookahead(1, "num")) {
	    expect("-");
	    $target--;
	}
	$arg_val = "\*$target";
    } else {
	my $arg = expect("num", "label");
	($arg_type, $arg_val) = (token_type($arg), token_value($arg));
    }
    if (lookahead(0, "+", "-")) {
	my $sign = token_type(expect("+", "-"));
	my $val = token_value(expect("num"));
	$offset = ($sign eq "+") ? $val : -$val;
    }
    return create_arg($prefix, $arg_type, $arg_val, $offset);
}

sub parse_instr {
    my $opcode = token_value(expect("opcode"));
    my ($mode, $arg);
    
    if (lookahead(0, "#")) {
	$mode = ("IMMEDIATE");
	expect("#");
	$arg = parse_arg;
	expect("EOL");
    } elsif (lookahead(0, "(")) {
	# Some indirect mode.
	expect("(");
	$arg = parse_arg;
	if (lookahead(0, ",")) {
	    $mode = ("INDIRECT-X");
	    expect(","); expect("X"); expect(")"); expect("EOL");
	} else {
	    expect(")");
	    my $tok = token_type(expect(",", "EOL"));
	    if ($tok eq "eol") {
		$mode = ("INDIRECT");
	    } else {
		$mode = ("INDIRECT-Y");
		expect("Y"); expect("EOL");
	    }
	}			
    } elsif (lookahead(0, "EOL")) {
	$mode = ("IMPLIED");
	expect("EOL");
    } else { # Zero page or absolute (possibly indexed) or relative.
	$arg = parse_arg; 
	my $tok = token_type(expect("EOL", ","));
	if ($tok eq ",") {
	    $tok = token_type(expect("x", "y"));
	    if ($tok eq "x") {
		$mode = "MEMORY-X";
	    } else {
		$mode = "MEMORY-Y";
	    }
	    expect("EOL");
	} else {
	    $mode = "MEMORY";
	}
    }

    add_IR($mode, $opcode, $arg);
}

sub parsefile {
    my $filename = shift;
    local *INPUT;
    
    my $oldfilename = $currentfile;
    my $oldlinenum = $linenum;

    $currentfile = $filename;
    $linenum = 0;

    open INPUT, $filename or die "Cannot open $filename.  Dying painful death";
    while (<INPUT>) {
	$linenum++;
	@line = lex($_);	
	parse_line;
    }

    $linenum = $oldlinenum;
    $currentfile = $oldfilename;
}

sub parse {
    my $basefile = shift;

    $temp_label_count = 0;
    
    parsefile($basefile);
}

# The various passes that walk over the IR

my $instructions_collapsed;

sub verify_IR {
    if ($verbose) { print "Commencing IR Verification phase.\n"; }
    init_labels();
    check_labels();
}

sub instruction_select {
    if ($verbose) { print "Commencing instruction selection phase.\n"; }
    $instructions_collapsed = 1;
    while ($instructions_collapsed)
    {
	update_labels();
	select_zero_page();
    }
    normalize_modes();
}

my %easy_dispatch = (
		  "MEMORY" => \&easy_flat,
		  "MEMORY-X" => \&easy_x,
		  "MEMORY-Y" => \&easy_y,
		  "UNKNOWN" => \&no_op
		  );

sub find_easy_addr_modes {
    if ($verbose) { print "Finding hardcoded addresses\n"; }
    walk(\%easy_dispatch);
}

my %init_dispatch = (
		  "SETPC" => \&init_setpc,
		  "LABEL" => \&init_label,
		  "ADVANCE" => \&init_advance,
		  "UNKNOWN" => \&no_op
		  );


sub init_labels {
    if ($verbose) { print "Verifying label definitions\n"; }
    walk(\%init_dispatch);
}

my %check_dispatch = (
		   "SETPC" => \&no_op,
		   "LABEL" => \&no_op,
		   "ADVANCE" => \&no_op,
		   "IMPLIED" => \&no_op,
		   "BYTE" => \&check_data,
		   "WORD" => \&check_data,
		   "UNKNOWN" => \&check_inst
		   );

sub check_labels {
    if ($verbose) { print "Verifying all expressions\n"; }
    walk(\%check_dispatch);
}

my %update_dispatch = (
		    "SETPC" => \&update_setpc,
		    "LABEL" => \&update_setlabel,
		    "ADVANCE" => \&update_setpc,
		    "BYTE" => \&update_byte,
		    "WORD" => \&update_word,
		    "IMMEDIATE" => \&update_2,
		    "IMPLIED" => \&update_1,
		    "INDIRECT" => \&update_3,
		    "INDIRECT-X" => \&update_2,
		    "INDIRECT-Y" => \&update_2,
		    "MEMORY-X" => \&update_3,
		    "MEMORY-Y" => \&update_3,
		    "MEMORY" => \&update_3,
		    "ABSOLUTE-X" => \&update_3,
		    "ABSOLUTE-Y" => \&update_3,
		    "ABSOLUTE" => \&update_3,
		    "ZERO-PAGE-X" => \&update_2,
		    "ZERO-PAGE-Y" => \&update_2,
		    "ZERO-PAGE" => \&update_2,
		    "RELATIVE" => \&update_2
		    );

sub update_labels {
    if ($verbose) { print "Computing label locations\n"; }
    walk(\%update_dispatch);
}

my %zp_dispatch = (
		   "MEMORY" => \&zp_collapse,
		   "MEMORY-X" => \&zp_collapse_x,
		   "MEMORY-Y" => \&zp_collapse_y,
		   "UNKNOWN" => \&no_op
		   );

sub select_zero_page {
    $instructions_collapsed = 0;
    if ($verbose) { print "Searching for zero page instructions\n"; }
    walk(\%zp_dispatch);
    if ($verbose) { print "$instructions_collapsed instructions found.\n"; }
}

my %norm_dispatch = (
		    "MEMORY" => \&norm_mode,
		    "MEMORY-X" => \&norm_mode_x,
		    "MEMORY-Y" => \&norm_mode_y,
		    "UNKNOWN" => \&no_op
		    );

sub normalize_modes {
    if ($verbose) { print "Canonicalizing addressing modes.\n"; }
    walk(\%norm_dispatch);
}

sub easy_flat {
    my $node = shift;
    my (undef, undef, undef, $opcode, $arg) = @$node;
    if (has_mode($opcode, "rel")) {
	$$node[2] = "RELATIVE";
    } elsif (hardcoded_arg($arg)) {
	my $target = eval_arg($arg);
	if (($target < 256) && has_mode($opcode, "zp")) {
	    $$node[2] = "ZERO-PAGE";
	} else {
	    $$node[2] = "ABSOLUTE";
	}
    }
}

sub easy_x {
    my $node = shift;
    my (undef, undef, undef, $opcode, $arg) = @$node;
    
    if (hardcoded_arg($arg)) {
	my $target = eval_arg($arg);
	if (($target < 256) && has_mode($opcode, "zpx")) {
	    $$node[2] = "ZERO-PAGE-X";
	} else {
	    $$node[2] = "ABSOLUTE-X";
	}
    }
}

sub easy_y {
    my $node = shift;
    my (undef, undef, undef, $opcode, $arg) = @$node;
    
    if (hardcoded_arg($arg)) {
	my $target = eval_arg($arg);
	if (($target < 256) && has_mode($opcode, "zpy")) {
	    $$node[2] = "ZERO-PAGE-Y";
	} else {
	    $$node[2] = "ABSOLUTE-Y";
	}
    }
}

sub no_op {
}

sub init_advance {
    my $node = shift;
    my $target;
    (undef, undef, undef, $target) = @$node;
    if (!can_evaluate($target)) {
	asmerror("Undefined or forward reference in .advance");
    }
}

sub init_setpc {
    my $node = shift;
    my $target;
    (undef, undef, undef, $target) = @$node;
    if (!can_evaluate($target)) {
	asmerror("Undefined or forward reference on program counter assign");
    }
}

sub init_label {
    my $node = shift;
    my (undef, undef, undef, $labelname, $labeltarget) = @$node;
    if (!can_evaluate($labeltarget)) {
	asmerror("Undefined or forward reference in .alias");
    }
    if (label_exists($labelname)) {
	asmerror("Duplicate label definition: $labelname");
    }
    set_label($labelname, 0);
}

sub check_inst {
    my $node = shift;
    my $arg = $$node[4];
    if (!can_evaluate($arg)) {
	my $badlabel = $$arg[2];
	asmerror("Undefined label '$badlabel'");
    }
}

sub check_data {
    my $node = shift;
    my @data;
    (undef, undef, undef, @data) = @$node;
    for (@data) {
	if (!can_evaluate($_)) {
	    my $badlabel = $$_[2];
	    asmerror("Undefined label '$badlabel'");
	}
    }
}

sub update_setpc {
    my $node = shift;
    my (undef, undef, undef, $target) = @$node;
    $pc = eval_arg($target);
}

sub update_byte {
    my $node = shift;
    my (undef, undef, undef, @data) = @$node;
    $pc += @data;
}

sub update_word {
    my $node = shift;
    my (undef, undef, undef, @data) = @$node;
    $pc += (@data*2);
}

sub update_1 {
    $pc++;
}

sub update_2 {
    $pc += 2;
}

sub update_3 {
    $pc += 3;
}

sub update_setlabel {
    my $node = shift;
    my (undef, undef, undef, $labelname, $labeltarget) = @$node;

    set_label($labelname, eval_arg($labeltarget));
}

sub zp_collapse {
    my $node = shift;
    my (undef, undef, undef, $opcode, $arg) = @$node;
    my $target = eval_arg($arg);
    if (($target < 256) && has_mode($opcode, "zp")) {
	$instructions_collapsed++;
	if ($verbose) { print "--> Collapsed instruction at $currentfile:$linenum.\n"; }
	$$node[2] = "ZERO-PAGE";
    }
}

sub zp_collapse_x {
    my $node = shift;
    my (undef, undef, undef, $opcode, $arg) = @$node;
    my $target = eval_arg($arg);
    if (($target < 256) && has_mode($opcode, "zpx")) {
	$instructions_collapsed++;
	if ($verbose) { print "--> Collapsed instruction at $currentfile:$linenum.\n"; }
	$$node[2] = "ZERO-PAGE-X";
    }
}

sub zp_collapse_y {
    my $node = shift;
    my (undef, undef, undef, $opcode, $arg) = @$node;
    my $target = eval_arg($arg);
    if (($target < 256) && has_mode($opcode, "zp")) {
	$instructions_collapsed++;
	if ($verbose) { print "--> Collapsed instruction at $currentfile:$linenum.\n"; }
	$$node[2] = "ZERO-PAGE-Y";
    }
}

sub norm_mode {
    my $node = shift;
    $$node[2] = "ABSOLUTE";
}

sub norm_mode_x {
    my $node = shift;
    $$node[2] = "ABSOLUTE-X";
}

sub norm_mode_y {
    my $node = shift;
    $$node[2] = "ABSOLUTE-Y";
}

# Assembler

my %assemble_dispatch = (
			 "BYTE" => \&assemble_byte,
			 "WORD" => \&assemble_word,
			 "SETPC" => \&assemble_setpc,
			 "ADVANCE" => \&assemble_advance,
			 "IMMEDIATE" => \&assemble_inst_2,
			 "IMPLIED" => \&assemble_inst_1,
			 "INDIRECT" => \&assemble_inst_3,
			 "INDIRECT-X" => \&assemble_inst_2,
			 "INDIRECT-Y" => \&assemble_inst_2,
			 "ABSOLUTE-X" => \&assemble_inst_3,
			 "ABSOLUTE-Y" => \&assemble_inst_3,
			 "ABSOLUTE" => \&assemble_inst_3,
			 "ZERO-PAGE-X" => \&assemble_inst_2,
			 "ZERO-PAGE-Y" => \&assemble_inst_2,
			 "ZERO-PAGE" => \&assemble_inst_2,
			 "RELATIVE" => \&assemble_inst_rel,
			 "LABEL" => \&no_op
			 );

my %addrmodes = (
		  "IMMEDIATE" => "imm",
		  "IMPLIED" => "imp",
		  "INDIRECT" => "ind",
		  "INDIRECT-X" => "indx",
		  "INDIRECT-Y" => "indy",
		  "ABSOLUTE-X" => "absx",
		  "ABSOLUTE-Y" => "absy",
		  "ABSOLUTE" => "abs",
		  "ZERO-PAGE-X" => "zpx",
		  "ZERO-PAGE-Y" => "zpy",
		  "ZERO-PAGE" => "zp",
		  "RELATIVE" => "rel"
		  );

sub assemble {
    if ($verbose) { print "Producing binary\n"; }
    walk(\%assemble_dispatch);
}

sub assemble_byte {
    my @data;
    my $node = shift;
    (undef, undef, undef, @data) = @$node;
    for (@data) {
	my $arg = eval_arg($_);
	if (($arg < 0) || ($arg > 0xff)) {
	    my $argstr = arg_as_string($arg);
	    asmerror "Constant $argstr out of range";
	} else {
	    push @code, $arg;
	}
    }
	
    $pc += @data;
}

sub assemble_word {
    my @data;
    my $node = shift;
    (undef, undef, undef, @data) = @$node;
    for (@data) {
	my $arg = eval_arg($_);
	if (($arg < 0) || ($arg > 0xffff)) {
	    my $argstr = arg_as_string($arg);
	    asmerror "Constant $argstr out of range";
	} else {
	    push @code, ($arg % 256), int($arg / 256);
	}
    }
	
    $pc += (2 * @data);
}

sub assemble_setpc {
    my $node = shift;
    my (undef, undef, undef, $target) = @$node;
    $pc = eval_arg($target);
}

sub assemble_advance {
    my $node = shift;
    my (undef, undef, undef, $arg) = @$node;
    my $target = eval_arg($arg);

    if ($target < $pc) {
	asmerror "Attempted to .advance backwards, from $pc to $target.";
    } else {
	push @code, (0) x ($target-$pc);
    }
    $pc = $target;
}

sub assemble_inst_1 {
    my $node = shift;
    my (undef, undef, $mode, $opcode) = @$node;

    my $modecode = $addrmodes{$mode};

    if(has_mode($opcode, $modecode)) {
	push @code, get_opcode($opcode, $modecode);
    } else {
	asmerror ("$opcode does not have addressing mode $mode");
    }
    $pc++;
}

sub assemble_inst_2 {
    my $node = shift;
    my (undef, undef, $mode, $opcode, $arg) = @$node;
    my $target = eval_arg($arg);
    my $modecode = $addrmodes{$mode};

    if(has_mode($opcode, $modecode)) {
	push @code, get_opcode($opcode, $modecode);
	if (($target < 0) || ($target > 0xff)) {
	    asmerror("Argument out of range (0-\$FF)");
	}
	push @code, $target;
    } else {
	asmerror ("$opcode does not have addressing mode $mode");
    }
    $pc += 2;
}

sub assemble_inst_3 {
    my $node = shift;
    my (undef, undef, $mode, $opcode, $arg) = @$node;
    my $target = eval_arg($arg);
    my $modecode = $addrmodes{$mode};

    if(has_mode($opcode, $modecode)) {
	push @code, get_opcode($opcode, $modecode);
	if (($target < 0) || ($target > 0xffff)) {
	    asmerror("Argument out of range (0-\$FFFF)");
	}
	push @code, $target % 256, int($target / 256);
    } else {
	asmerror ("$opcode does not have addressing mode $mode");
    }
    $pc += 3;
}

sub assemble_inst_rel {
    my $node = shift;
    my (undef, undef, $mode, $opcode, $arg) = @$node;
    my $target = eval_arg($arg);
    my $modecode = $addrmodes{$mode};

    if(has_mode($opcode, $modecode)) {
	push @code, get_opcode($opcode, $modecode);
	if (($target < 0) || ($target > 0xffff)) {
	    asmerror("Argument out of range (0-\$FFFF)");
	} else {
	    my $reltarget = $target - ($pc + 2);
	    if ($reltarget < -128 or $reltarget > 127) {
		asmerror "Branch out of range";
	    }
	    push @code, ($reltarget < 0) ? 256 + $reltarget : $reltarget;
	}
    } else {
	asmerror ("$opcode does not have addressing mode $mode");
    }
    $pc += 2;
}

my ($infile, $outfile);


sub parse_args {
    my $count = 0;
    $verbose = 0;
    for (@ARGV) {
	if ($_ eq "-v") {
	    $verbose = 1;
	} elsif ($_ =~ /^-/) {
	    usage();
	} elsif ($count == 0) {
	    $infile = $_;
	    $count++;
	} elsif ($count == 1) {
	    $outfile = $_;
	    $count++;
	} else {
	    usage();
	}
    }
    if ($count != 2) { usage(); }
}

sub usage() {
    print "\nUsage:\n    p65 [-v] basefile outfile\n";
    print "\n        -v: Verbose mode\n        basefile: Top-level source file";
    print "\n        outfile: Binary output file\n\n";
    exit;
}

sub write_file() {
    open OUTPUT, ">$outfile" or die "Failed to create $outfile";
    binmode OUTPUT;
    print OUTPUT pack "c*", @code;
}

sub print_binary() {
    my $count = 0;
    foreach (@code) {
	printf "%02x", $_;
	$count = ($count+1) % 16;
	if ($count == 8) { print '-'; }
	elsif ($count == 0) { print "\n"; }
	else { print ' '; }
    }
    print "\n";
}

# Main routine.

$verbose = 1;

my @passes = (\&find_easy_addr_modes, \&verify_IR, \&instruction_select, 
	      \&assemble, \&write_file);

parse_args();

parse($infile);

for (@passes) {
    if (num_errors == 0) {
	&$_();
    }
}

report_errors;