# $Id: Memory.pm,v 1.4 2011/03/24 16:46:11 Paulo Exp $

package CPU::Z80::Disassembler::Memory;

#------------------------------------------------------------------------------

=head1 NAME

CPU::Z80::Disassembler::Memory - Memory representation for Z80 disassembler

=cut

#------------------------------------------------------------------------------

use strict;
use warnings;

use Carp; our @CARP_NOT;		# do not report errors in this package
use File::Slurp;
use Bit::Vector;

use CPU::Z80::Disassembler::Format;

our $VERSION = '0.04';

#------------------------------------------------------------------------------

=head1 SYNOPSIS

  use CPU::Z80::Disassembler::Memory;
  $mem = CPU::Z80::Disassembler::Memory->new;
  
  $mem->load_file($file_name, $addr, $opt_skip_bytes, $opt_length);
  $it = $mem->loaded_iter(); while (($min,$max) = $it->()) {}
  
  $byte = $mem->peek8u($addr); $byte = $mem->peek($addr);
  $byte = $mem->peek8s($addr);
  
  $word = $mem->peek16u($addr);
  $word = $mem->peek16s($addr);
  
  $str = $mem->peek_str( $addr, $length);
  $str = $mem->peek_strz($addr);
  $str = $mem->peek_str7($addr);
  
  $mem->poke8u($addr, $byte); $mem->poke($addr, $byte);
  $mem->poke8s($addr, $byte);
  
  $mem->poke16u($addr, $word);
  $mem->poke16s($addr, $word);
  
  $mem->poke_str( $addr, $str);
  $mem->poke_strz($addr, $str);
  $mem->poke_str7($addr, $str);

=head1 DESCRIPTION

This module represents a memory segment being diassembled. 

=head1 FUNCTIONS

=head2 new

Creates a new empty object.

=cut

#------------------------------------------------------------------------------
use Class::XSAccessor {
	constructor	=> '_new',
	accessors => [ 
		'_mem',			# string of 64 Kbytes
		'_loaded',		# Bit::Vector, one bit per address, 1 if byte loaded
	],
};

sub new {
	my($class) = @_;
	my $loaded = Bit::Vector->new(0x10000);
	my $mem = "\0" x $loaded->Size;
	return $class->_new(_mem => $mem, _loaded => $loaded);
}

#------------------------------------------------------------------------------
# check ranges

sub _check_addr {
	my($self, $addr) = @_;
	croak("address ".format_hex($addr)." out of range") 
		if ($addr < 0 || $addr >= $self->_loaded->Size);
}

sub _check_value8u {
	my($self, $byte) = @_;
	croak("unsigned byte ".format_hex($byte)." out of range") 
		if ($byte < 0 || $byte > 0xFF);
}

sub _check_value8s {
	my($self, $byte) = @_;
	croak("signed byte ".format_hex($byte)." out of range") 
		if ($byte < -0x80 || $byte > 0x7F);
}

sub _check_value16u {
	my($self, $word) = @_;
	croak("unsigned word ".format_hex($word)." out of range") 
		if ($word < 0 || $word > 0xFFFF);
}

sub _check_value16s {
	my($self, $word) = @_;
	croak("signed word ".format_hex($word)." out of range") 
		if ($word < -0x8000 || $word > 0x7FFF);
}

sub _check_strz {
	my($self, $str) = @_;
	croak("invalid zero character in string") 
		if $str =~ /\0/;
}

sub _check_str7 {
	my($self, $str) = @_;
	croak("invalid empty string") if length($str) < 1;
	croak("invalid bit-7 set character in string") 
		if $str =~ /[\x80-\xFF]/;
}

#------------------------------------------------------------------------------

=head2 load_file

Loads a binary file to the memory. 
The argument C<$addr> indicates where in the memory to load the file, and defaults to 0.
The argument C<$opt_skip_bytes> indicates how many bytes to skip from the start 
of the binary file and defaults to 0. 
This is useful to read C<.SNA> ZX Spectrum Snapshot Files which have a header of 27 bytes.
The argument C<$opt_length> limits the number of bytes to read to memory and
defaults to all the file after the header.

=cut

#------------------------------------------------------------------------------
sub load_file {
	my($self, $file_name, $addr, $opt_skip_bytes, $opt_length) = @_;
	
	my $bytes = read_file($file_name, binmode => ':raw');
	$addr			||= 0;
	$opt_skip_bytes ||= 0;
	$opt_length		||= length($bytes) - $opt_skip_bytes;
	
	$self->poke_str($addr, substr($bytes, $opt_skip_bytes, $opt_length));
}
#------------------------------------------------------------------------------

=head2 loaded_iter

Returns an iterator to return each block of consecutive loaded addresses. 
C<$min> is the first address of the consecutive block, C<$max> is last address
of the block.

=cut

#------------------------------------------------------------------------------
sub loaded_iter {
	my($self) = @_;
	my $loaded = $self->_loaded;
	my $start = 0;
	
	return sub {
		while ( $start < $loaded->Size &&
				(my($min,$max) = $loaded->Interval_Scan_inc($start)) ) {
			$start = $max + 2;	# start after the 0 after $max
			return ($min, $max);
		}
		return ();		# no more blocks
    };
}
#------------------------------------------------------------------------------

=head2 peek, peek8u

Retrieves the byte (0 .. 255) from the given address. 
Returns C<undef> if the memory at that address was not loaded.

=cut

#------------------------------------------------------------------------------
sub peek8u {
	my($self, $addr) = @_;
	$self->_check_addr($addr);
	return $self->_loaded->bit_test($addr) ?
				ord(substr($self->{_mem}, $addr, 1)) :
				undef;
}
sub peek { goto &peek8u }
#------------------------------------------------------------------------------

=head2 peek8s

Same as C<peek8u>, but treats byte as signed (-128 .. 127).

=cut

#------------------------------------------------------------------------------
sub peek8s {
	my($self, $addr) = @_;
	my $byte = $self->peek8u($addr);
	return undef unless defined $byte;
	$byte -= 0x100 if $byte & 0x80;
	return $byte;
}
#------------------------------------------------------------------------------

=head2 peek16u

Retrieves the two-byte word (0 .. 65535) from the given address, least 
significant first (little-endian).
Returns C<undef> if the memory at any of the two addresses was not loaded.

=cut

#------------------------------------------------------------------------------
sub peek16u {
	my($self, $addr) = @_;
	my $lo = $self->peek($addr++); return undef unless defined $lo;
	my $hi = $self->peek($addr++); return undef unless defined $hi;
	return ($hi << 8) | $lo;
}
#------------------------------------------------------------------------------

=head2 peek16s

Same as C<peek16u>, but treats word as signed (-32768 .. 32767).

=cut

#------------------------------------------------------------------------------
sub peek16s {
	my($self, $addr) = @_;
	my $word = $self->peek16u($addr);
	return undef unless defined $word;
	$word -= 0x10000 if $word & 0x8000;
	return $word;
}
#------------------------------------------------------------------------------

=head2 peek_str

Retrieves a string from the given address with the given length.
Returns C<undef> if the memory at any of the addresses was not loaded.

=cut

#------------------------------------------------------------------------------
sub peek_str {
	my($self, $addr, $length) = @_;
	croak("invalid length $length") if $length < 1;
	my $str = "";
	while ($length-- > 0) {
		my $byte = $self->peek8u($addr++);
		return undef unless defined $byte;
		$str .= chr($byte);
	}
	return $str;
}
#------------------------------------------------------------------------------

=head2 peek_strz

Retrieves a zero-terminated string from the given address. The returned string
does not include the final zero byte.
Returns C<undef> if the memory at any of the addresses was not loaded.

=cut

#------------------------------------------------------------------------------
sub peek_strz {
	my($self, $addr) = @_;
	my $str = "";
	while (1) {
		my $byte = $self->peek8u($addr++);
		return undef unless defined $byte;
		return $str if $byte == 0;
		$str .= chr($byte);
	}
}
#------------------------------------------------------------------------------

=head2 peek_str7

Retrieves a bit-7-set-terminated string from the given address. 
This string has all characters with bit 7 reset, execept the last character, 
where bit 7 is set. The returned string has bit 7 reset in all characters.
Returns C<undef> if the memory at any of the addresses was not loaded.

=cut

#------------------------------------------------------------------------------
sub peek_str7 {
	my($self, $addr) = @_;
	my $str = "";
	while (1) {
		my $byte = $self->peek8u($addr++);
		return undef unless defined $byte;
		$str .= chr($byte & 0x7F);		# clear bit 7
		return $str if $byte & 0x80;	# bit 7 set
	}
}
#------------------------------------------------------------------------------

=head2 poke, poke8u

Stores the unsigned byte (0 .. 255) at the given address, 
and signals that the address was loaded.

=cut

#------------------------------------------------------------------------------
sub poke8u {
	my($self, $addr, $byte) = @_;
	$self->_check_addr($addr);
	$self->_check_value8u($byte);
	substr($self->{_mem}, $addr, 1) = chr($byte);
	$self->_loaded->Bit_On($addr);
}
sub poke { goto &poke8u }
#------------------------------------------------------------------------------

=head2 poke8s

Same as C<poke8u>, but treats byte as signed (-128 .. 127).

=cut

#------------------------------------------------------------------------------
sub poke8s {
	my($self, $addr, $byte) = @_;
	$self->_check_value8s($byte);
	$self->poke8u($addr, $byte & 0xFF);
}
#------------------------------------------------------------------------------

=head2 poke16u

Stores the two-byte word (0 .. 65535) at the given address, least 
significant first (little-endian), 
and signals that the address was loaded.

=cut

#------------------------------------------------------------------------------
sub poke16u {
	my($self, $addr, $word) = @_;
	$self->_check_addr($addr);
	$self->_check_value16u($word);
	$self->poke8u($addr++, $word & 0xFF);
	$self->poke8u($addr++, ($word >> 8) & 0xFF);
}
#------------------------------------------------------------------------------

=head2 poke16s

Same as C<poke16u>, but treats word as signed (-32768 .. 32767).

=cut

#------------------------------------------------------------------------------
sub poke16s {
	my($self, $addr, $word) = @_;
	$self->_check_value16s($word);
	$self->poke16u($addr, $word & 0xFFFF);
}
#------------------------------------------------------------------------------

=head2 poke_str

Stores the string at the given start address, 
and signals that the addresser were loaded.

=cut

#------------------------------------------------------------------------------
sub poke_str {
	my($self, $addr, $str) = @_;
	$self->_check_addr($addr);

	if (length($str) > 0) {
		my $end_addr = $addr + length($str) - 1;
		$self->_check_addr($end_addr);
	
		substr($self->{_mem}, $addr, length($str)) = $str;
		$self->_loaded->Interval_Fill($addr, $end_addr);
	}
}
#------------------------------------------------------------------------------

=head2 poke_strz

Stores the string at the given start address, and adds a zero byte, 
and signals that the addresses were loaded.

=cut

#------------------------------------------------------------------------------
sub poke_strz {
	my($self, $addr, $str) = @_;
	$self->_check_strz($str);
	$self->poke_str($addr, $str.chr(0));
}
#------------------------------------------------------------------------------

=head2 poke_str7

Stores the string at the given start address and sets the bit 7 of the
last character, 
and signals that the addresses were loaded.

=cut

#------------------------------------------------------------------------------
sub poke_str7 {
	my($self, $addr, $str) = @_;
	$self->_check_str7($str);
	substr($str, -1, 1) = chr(ord(substr($str, -1, 1)) | 0x80);		# set bit 7
	$self->poke_str($addr, $str);
}
#------------------------------------------------------------------------------

=head1 AUTHOR, BUGS, FEEDBACK, LICENSE AND COPYRIGHT

See L<CPU::Z80::Disassembler|CPU::Z80::Disassembler>.

=cut

#------------------------------------------------------------------------------

1;