[app-scheme79asm.git] / lib / App / Scheme79asm.pm

package App::Scheme79asm;

use 5.014000;
use strict;
use warnings;
use re '/s';
use Carp qw/croak/;

use Data::Dumper qw/Dumper/;
use Data::SExpression qw/consp scalarp/;
use Scalar::Util qw/looks_like_number/;

our $VERSION = '0.005001';

our %TYPES = (
	LIST => 0,
	SYMBOL => 1,
	NUMBER => 1,
	VAR => 2,
	VARIABLE => 2,
	CLOSURE => 3,
	PROC => 4,
	PROCEDURE => 4,
	IF => 5,
	COND => 5,
	CONDITIONAL => 5,
	CALL => 6,
	QUOTE => 7,
	QUOTED => 7,

	MORE => 0,
	CAR => 1,
	CDR => 2,
	CONS => 3,
	ATOM => 4,
	PROGN => 5,
	'REVERSE-LIST' => 6,
	FUNCALL => 7,
);

*consp = *Data::SExpression::consp;
*scalarp = *Data::SExpression::scalarp;

sub process {
	my ($self, $sexp, $location) = @_;
	die 'Toplevel is not a list: ', Dumper($sexp), "\n" unless ref $sexp eq 'ARRAY';
	my ($type, @addrs) = @$sexp;
	my $addr;

	die 'Type of toplevel is not atom: '. Dumper($type), "\n" unless scalarp($type);

	if (@addrs > 1) {
		$addr = $self->{freeptr} + 1;
		$self->{freeptr} += @addrs;
		$self->process($addrs[$_], $addr + $_) for 0 .. $#addrs;
	} else {
		$addr = $addrs[0];
	}

	$addr = $self->process($addr) if ref $addr eq 'ARRAY';
	die 'Addr of toplevel is not atom: ', Dumper($addr), "\n" unless scalarp($addr);
	my ($comment_type, $comment_addr) = ($type, $addr);
	die 'Computed addr is not a number: ', Dumper($addr), "\n" unless looks_like_number $addr;

	if (!looks_like_number $type) {
		die "No such type: $type\n" unless exists $TYPES{$type};
		$type = $TYPES{$type};
	}

	$addr += (1 << $self->{addr_bits}) if $addr < 0;
	die "Type too large: $type\n" if $type >= (1 << $self->{type_bits});
	die "Addr too large: $addr\n" if $addr >= (1 << $self->{addr_bits});
	my $result = ($type << $self->{addr_bits}) + $addr;

	unless ($location) {
		$self->{freeptr}++;
		$location = $self->{freeptr}
	}
	$self->{memory}[$location] = $result;
	$self->{comment}[$location] = "$comment_type $comment_addr";
	$location
}

sub parse {
	my ($self, $string) = @_;
	my $ds = Data::SExpression->new({symbol_case => 'up', use_symbol_class => 1, fold_lists => 1});

	my $sexp;
	while () {
		last if $string =~ /^\s*$/;
		($sexp, $string) = $ds->read($string);
		$self->process($sexp)
	}
}

sub finish {
	my ($self) = @_;
	$self->{memory}[5] = $self->{memory}[$self->{freeptr}];
	$self->{comment}[5] = $self->{comment}[$self->{freeptr}];
	$self->{memory}[4] = $self->{freeptr};
	delete $self->{memory}[$self->{freeptr}]
}

sub new {
	my ($class, %args) = @_;
	$args{type_bits} //= 3;
	$args{addr_bits} //= 8;
	$args{freeptr} //= 6;
	$args{memory} //= [0, 0, (1<<$args{addr_bits}), (1<<$args{addr_bits}), 0, 0, 0];
	my @default_comments = ('(cdr part of NIL)', '(car part of NIL)', '(cdr part of T)', '(car part of T)', '(free storage pointer)', '', '(result of computation)');
	for (0 .. $#default_comments) {
		$args{comment}[$_] = $default_comments[$_]
	}
	bless \%args, $class
}

sub print_binary16 {
	my ($self, $fh) = @_;
	$fh //= \*STDOUT; # uncoverable condition right

	die "addr_bits + type_bits >= 16\n"if $self->{addr_bits} + $self->{type_bits} > 16;

	my $length = @{$self->{memory}};
	print $fh pack 'n', $length or croak "Failed to print memory size: $!"; # uncoverable branch true
	for (@{$self->{memory}}) {
		print $fh pack 'n', $_ or croak "Failed to print memory: $!" # uncoverable branch true
	}
}

sub print_verilog {
	my ($self, $fh) = @_;
	$fh //= \*STDOUT; # uncoverable condition right

	my $bits = $self->{type_bits} + $self->{addr_bits};
	my $index_length = length $#{$self->{memory}};
	my $index_format = '%' . $index_length . 'd';
	for my $index (0 .. $#{$self->{memory}}) {
		my $val = $self->{memory}[$index];
		my $comment = $self->{comment}[$index];
		if ($index == 4) {
			$val = "${bits}'d$val"
		} else {
			$val = $val ? sprintf "%d'b%0${bits}b", $bits, $val : '0';
		}
		my $spaces = ' ' x ($bits + 5 - (length $val));
		$index = sprintf $index_format, $index;

		my $string = "mem[$index] <= $val;";
		$string .= "$spaces // $comment" if defined $comment;
		say $fh $string or croak "Failed to print verilog: $!"; # uncoverable branch true
	}

}
sub parse_and_print_binary16 {
	my ($self, $string, $fh) = @_;
	$self->parse($string);
	$self->finish;
	$self->print_binary16($fh);
}

sub parse_and_print_verilog {
	my ($self, $string, $fh) = @_;
	$self->parse($string);
	$self->finish;
	$self->print_verilog($fh);
}

1;
__END__

=encoding utf-8

=head1 NAME

App::Scheme79asm - assemble sexp to Verilog ROM for SIMPLE processor

=head1 SYNOPSIS

  use App::Scheme79asm;
  my $asm = App::Scheme79asm->new(type_bits => 3, addr_bits => 5);
  $asm->parse_and_print_verilog('(number 70)');

=head1 DESCRIPTION

SIMPLE is a LISP processor defined in the 1979
B<Design of LISP-Based Processors> paper by Steele and Sussman.

The SIMPLE processor expects input in a particular tagged-pointer
format. This module takes a string containing a sequence of
S-expressions. Each S-expression is a list of one of three types:

C<(tag value)>, for example C<(symbol 2)>, represents a value to be
put in memory (for example a number, or a symbol, or a variable
reference). The value must be a number.

C<(tag list)>, where C<list> is of one of these three types,
represents a tagged pointer. In this case, C<list> is (recursively)
laid out in memory as per these rules, and a pointer to that location
(and tagged C<tag>) is put somewhere in memory.

C<(tag list1 list2)>, where C<list1> and C<list2> are of one of these
three types (not necessarily the same type). In this case, C<list1>
and C<list2> are (recursively) laid out in memory such that C<list1>
is at position X and C<list2> is at position X+1, and a pointer of
type tag and value X is put somewhere in memory.

After this process the very last pointer placed in memory is moved to
the special location 5 (which is where SIMPLE expects to find the
expression to be evaluated).

In normal use a single S-expression will be supplied, representing an
entire program.

The C<tag> is either a number, a type, or a primitive.
The available types are:

=over

=item LIST

=item SYMBOL (syn. NUMBER)

=item VAR (syn. VARIABLE)

=item CLOSURE

=item PROC (syn. PROCEDURE)

=item IF (syn. COND, CONDITIONAL)

=item CALL

=item QUOTE (syn. QUOTED)

=back

The available primitives are:

=over

=item MORE

=item CAR

=item CDR

=item CONS

=item ATOM

=item PROGN

=item REVERSE-LIST

=item FUNCALL

=back

The following methods are available:

=over

=item App::Scheme79asm->B<new>([key => value, key => value, ...])

Create a new assembler object. Takes a list of keys and values, here
are the possible keys:

=over

=item type_bits

=item address_bits

A word is made of a type and an address, with the type occupying the
most significant C<type_bits> (default 3) bits, and the address
occupying the least significant C<address_bits> (default 8) bits.
Therefore the word size is C<type_bits + address_bits> (default 11).

=item freeptr

A pointer to the last used byte in memory (default 6). The program
will be laid out starting with location C<freeptr + 1>.

=item memory

The initial contents of the memory. Note that locations 4, 5, 6 will
be overwritten, as will every location larger than the value of
C<freeptr>.

=item comment

The initial comments for memory entries. C<< $comment->[$i] >> is the
comment for C<< $memory->[$i] >>. Note that the first 7 entries of
this array will be overwritten with the default comments. This is
useful when using custom initial memory contents and freeptr, because
this key can be used to provide comments for the extra reserved
locations in memory.

=back

=item $asm->B<parse>(I<$string>)

Parse a sequence of S-expressions and lay it out in memory.
Can be called multiple times to lay out multiple sequences of
S-expressions one after another.

=item $asm->B<process>(I<$sexp>)

Given an already-parsed sexp (meaning a
L<Data::SExpression> object), lay it out in memory.
Can be called multiple times to lay out multiple sequences of
S-expressions one after another.

=item $asm->B<finish>

Move the last pointer to position 5, and put the free pointer at
position 4. After all sequences of S-expressions have been given to
B<parse>, this method should be called.

=item $asm->B<print_binary16>([I<$fh>])

Print the length of the memory (as a big-endian 16-bit value),
followed by the memory contents as a sequence of big-endian 16-bit
values to the given filehandle (default STDOUT). Dies if
C<addr_bits + type_bits> is more than 16.

Big-endian 16-bit values can be decoded with C<unpack 'n', $value>.

=item $asm->B<print_verilog>([I<$fh>])

Print a block of Verilog code assigning the memory contents to an
array named C<mem> to the given filehandle (default STDOUT).

=item $asm->B<parse_and_print_binary16>(I<$string>[, I<$fh>])

Convenience method that calls B<parse>($string), B<finish>, and then
B<print_binary16>($fh).

=item $asm->B<parse_and_print_verilog>(I<$string>[, I<$fh>])

Convenience method that calls B<parse>($string), B<finish>, and then
B<print_verilog>($fh).

=back

=head1 SEE ALSO

L<http://repository.readscheme.org/ftp/papers/ai-lab-pubs/AIM-514.pdf>

=head1 AUTHOR

Marius Gavrilescu, E<lt>marius@ieval.roE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2018 by Marius Gavrilescu

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.3 or,
at your option, any later version of Perl 5 you may have available.


=cut
Commit	Line	Data
	1	package App::Scheme79asm;
	2
	3	use 5.014000;
	4	use strict;
	5	use warnings;
	6	use re '/s';
	7	use Carp qw/croak/;
	8
	9	use Data::Dumper qw/Dumper/;
	10	use Data::SExpression qw/consp scalarp/;
	11	use Scalar::Util qw/looks_like_number/;
	12
	13	our $VERSION = '0.005001';
	14
	15	our %TYPES = (
	16	LIST => 0,
	17	SYMBOL => 1,
	18	NUMBER => 1,
	19	VAR => 2,
	20	VARIABLE => 2,
	21	CLOSURE => 3,
	22	PROC => 4,
	23	PROCEDURE => 4,
	24	IF => 5,
	25	COND => 5,
	26	CONDITIONAL => 5,
	27	CALL => 6,
	28	QUOTE => 7,
	29	QUOTED => 7,
	30
	31	MORE => 0,
	32	CAR => 1,
	33	CDR => 2,
	34	CONS => 3,
	35	ATOM => 4,
	36	PROGN => 5,
	37	'REVERSE-LIST' => 6,
	38	FUNCALL => 7,
	39	);
	40
	41	consp = Data::SExpression::consp;
	42	scalarp = Data::SExpression::scalarp;
	43
	44	sub process {
	45	my ($self, $sexp, $location) = @_;
	46	die 'Toplevel is not a list: ', Dumper($sexp), "\n" unless ref $sexp eq 'ARRAY';
	47	my ($type, @addrs) = @$sexp;
	48	my $addr;
	49
	50	die 'Type of toplevel is not atom: '. Dumper($type), "\n" unless scalarp($type);
	51
	52	if (@addrs > 1) {
	53	$addr = $self->{freeptr} + 1;
	54	$self->{freeptr} += @addrs;
	55	$self->process($addrs[$_], $addr + $_) for 0 .. $#addrs;
	56	} else {
	57	$addr = $addrs[0];
	58	}
	59
	60	$addr = $self->process($addr) if ref $addr eq 'ARRAY';
	61	die 'Addr of toplevel is not atom: ', Dumper($addr), "\n" unless scalarp($addr);
	62	my ($comment_type, $comment_addr) = ($type, $addr);
	63	die 'Computed addr is not a number: ', Dumper($addr), "\n" unless looks_like_number $addr;
	64
	65	if (!looks_like_number $type) {
	66	die "No such type: $type\n" unless exists $TYPES{$type};
	67	$type = $TYPES{$type};
	68	}
	69
	70	$addr += (1 << $self->{addr_bits}) if $addr < 0;
	71	die "Type too large: $type\n" if $type >= (1 << $self->{type_bits});
	72	die "Addr too large: $addr\n" if $addr >= (1 << $self->{addr_bits});
	73	my $result = ($type << $self->{addr_bits}) + $addr;
	74
	75	unless ($location) {
	76	$self->{freeptr}++;
	77	$location = $self->{freeptr}
	78	}
	79	$self->{memory}[$location] = $result;
	80	$self->{comment}[$location] = "$comment_type $comment_addr";
	81	$location
	82	}
	83
	84	sub parse {
	85	my ($self, $string) = @_;
	86	my $ds = Data::SExpression->new({symbol_case => 'up', use_symbol_class => 1, fold_lists => 1});
	87
	88	my $sexp;
	89	while () {
	90	last if $string =~ /^\s*$/;
	91	($sexp, $string) = $ds->read($string);
	92	$self->process($sexp)
	93	}
	94	}
	95
	96	sub finish {
	97	my ($self) = @_;
	98	$self->{memory}[5] = $self->{memory}[$self->{freeptr}];
	99	$self->{comment}[5] = $self->{comment}[$self->{freeptr}];
	100	$self->{memory}[4] = $self->{freeptr};
	101	delete $self->{memory}[$self->{freeptr}]
	102	}
	103
	104	sub new {
	105	my ($class, %args) = @_;
	106	$args{type_bits} //= 3;
	107	$args{addr_bits} //= 8;
	108	$args{freeptr} //= 6;
	109	$args{memory} //= [0, 0, (1<<$args{addr_bits}), (1<<$args{addr_bits}), 0, 0, 0];
	110	my @default_comments = ('(cdr part of NIL)', '(car part of NIL)', '(cdr part of T)', '(car part of T)', '(free storage pointer)', '', '(result of computation)');
	111	for (0 .. $#default_comments) {
	112	$args{comment}[$_] = $default_comments[$_]
	113	}
	114	bless \%args, $class
	115	}
	116
	117	sub print_binary16 {
	118	my ($self, $fh) = @_;
	119	$fh //= \*STDOUT; # uncoverable condition right
	120
	121	die "addr_bits + type_bits >= 16\n"if $self->{addr_bits} + $self->{type_bits} > 16;
	122
	123	my $length = @{$self->{memory}};
	124	print $fh pack 'n', $length or croak "Failed to print memory size: $!"; # uncoverable branch true
	125	for (@{$self->{memory}}) {
	126	print $fh pack 'n', $_ or croak "Failed to print memory: $!" # uncoverable branch true
	127	}
	128	}
	129
	130	sub print_verilog {
	131	my ($self, $fh) = @_;
	132	$fh //= \*STDOUT; # uncoverable condition right
	133
	134	my $bits = $self->{type_bits} + $self->{addr_bits};
	135	my $index_length = length $#{$self->{memory}};
	136	my $index_format = '%' . $index_length . 'd';
	137	for my $index (0 .. $#{$self->{memory}}) {
	138	my $val = $self->{memory}[$index];
	139	my $comment = $self->{comment}[$index];
	140	if ($index == 4) {
	141	$val = "${bits}'d$val"
	142	} else {
	143	$val = $val ? sprintf "%d'b%0${bits}b", $bits, $val : '0';
	144	}
	145	my $spaces = ' ' x ($bits + 5 - (length $val));
	146	$index = sprintf $index_format, $index;
	147
	148	my $string = "mem[$index] <= $val;";
	149	$string .= "$spaces // $comment" if defined $comment;
	150	say $fh $string or croak "Failed to print verilog: $!"; # uncoverable branch true
	151	}
	152
	153	}
	154	sub parse_and_print_binary16 {
	155	my ($self, $string, $fh) = @_;
	156	$self->parse($string);
	157	$self->finish;
	158	$self->print_binary16($fh);
	159	}
	160
	161	sub parse_and_print_verilog {
	162	my ($self, $string, $fh) = @_;
	163	$self->parse($string);
	164	$self->finish;
	165	$self->print_verilog($fh);
	166	}
	167
	168	1;
	169	__END__
	170
	171	=encoding utf-8
	172
	173	=head1 NAME
	174
	175	App::Scheme79asm - assemble sexp to Verilog ROM for SIMPLE processor
	176
	177	=head1 SYNOPSIS
	178
	179	use App::Scheme79asm;
	180	my $asm = App::Scheme79asm->new(type_bits => 3, addr_bits => 5);
	181	$asm->parse_and_print_verilog('(number 70)');
	182
	183	=head1 DESCRIPTION
	184
	185	SIMPLE is a LISP processor defined in the 1979
	186	B<Design of LISP-Based Processors> paper by Steele and Sussman.
	187
	188	The SIMPLE processor expects input in a particular tagged-pointer
	189	format. This module takes a string containing a sequence of
	190	S-expressions. Each S-expression is a list of one of three types:
	191
	192	C<(tag value)>, for example C<(symbol 2)>, represents a value to be
	193	put in memory (for example a number, or a symbol, or a variable
	194	reference). The value must be a number.
	195
	196	C<(tag list)>, where C<list> is of one of these three types,
	197	represents a tagged pointer. In this case, C<list> is (recursively)
	198	laid out in memory as per these rules, and a pointer to that location
	199	(and tagged C<tag>) is put somewhere in memory.
	200
	201	C<(tag list1 list2)>, where C<list1> and C<list2> are of one of these
	202	three types (not necessarily the same type). In this case, C<list1>
	203	and C<list2> are (recursively) laid out in memory such that C<list1>
	204	is at position X and C<list2> is at position X+1, and a pointer of
	205	type tag and value X is put somewhere in memory.
	206
	207	After this process the very last pointer placed in memory is moved to
	208	the special location 5 (which is where SIMPLE expects to find the
	209	expression to be evaluated).
	210
	211	In normal use a single S-expression will be supplied, representing an
	212	entire program.
	213
	214	The C<tag> is either a number, a type, or a primitive.
	215	The available types are:
	216
	217	=over
	218
	219	=item LIST
	220
	221	=item SYMBOL (syn. NUMBER)
	222
	223	=item VAR (syn. VARIABLE)
	224
	225	=item CLOSURE
	226
	227	=item PROC (syn. PROCEDURE)
	228
	229	=item IF (syn. COND, CONDITIONAL)
	230
	231	=item CALL
	232
	233	=item QUOTE (syn. QUOTED)
	234
	235	=back
	236
	237	The available primitives are:
	238
	239	=over
	240
	241	=item MORE
	242
	243	=item CAR
	244
	245	=item CDR
	246
	247	=item CONS
	248
	249	=item ATOM
	250
	251	=item PROGN
	252
	253	=item REVERSE-LIST
	254
	255	=item FUNCALL
	256
	257	=back
	258
	259	The following methods are available:
	260
	261	=over
	262
	263	=item App::Scheme79asm->B<new>([key => value, key => value, ...])
	264
	265	Create a new assembler object. Takes a list of keys and values, here
	266	are the possible keys:
	267
	268	=over
	269
	270	=item type_bits
	271
	272	=item address_bits
	273
	274	A word is made of a type and an address, with the type occupying the
	275	most significant C<type_bits> (default 3) bits, and the address
	276	occupying the least significant C<address_bits> (default 8) bits.
	277	Therefore the word size is C<type_bits + address_bits> (default 11).
	278
	279	=item freeptr
	280
	281	A pointer to the last used byte in memory (default 6). The program
	282	will be laid out starting with location C<freeptr + 1>.
	283
	284	=item memory
	285
	286	The initial contents of the memory. Note that locations 4, 5, 6 will
	287	be overwritten, as will every location larger than the value of
	288	C<freeptr>.
	289
	290	=item comment
	291
	292	The initial comments for memory entries. C<< $comment->[$i] >> is the
	293	comment for C<< $memory->[$i] >>. Note that the first 7 entries of
	294	this array will be overwritten with the default comments. This is
	295	useful when using custom initial memory contents and freeptr, because
	296	this key can be used to provide comments for the extra reserved
	297	locations in memory.
	298
	299	=back
	300
	301	=item $asm->B<parse>(I<$string>)
	302
	303	Parse a sequence of S-expressions and lay it out in memory.
	304	Can be called multiple times to lay out multiple sequences of
	305	S-expressions one after another.
	306
	307	=item $asm->B<process>(I<$sexp>)
	308
	309	Given an already-parsed sexp (meaning a
	310	L<Data::SExpression> object), lay it out in memory.
	311	Can be called multiple times to lay out multiple sequences of
	312	S-expressions one after another.
	313
	314	=item $asm->B<finish>
	315
	316	Move the last pointer to position 5, and put the free pointer at
	317	position 4. After all sequences of S-expressions have been given to
	318	B<parse>, this method should be called.
	319
	320	=item $asm->B<print_binary16>([I<$fh>])
	321
	322	Print the length of the memory (as a big-endian 16-bit value),
	323	followed by the memory contents as a sequence of big-endian 16-bit
	324	values to the given filehandle (default STDOUT). Dies if
	325	C<addr_bits + type_bits> is more than 16.
	326
	327	Big-endian 16-bit values can be decoded with C<unpack 'n', $value>.
	328
	329	=item $asm->B<print_verilog>([I<$fh>])
	330
	331	Print a block of Verilog code assigning the memory contents to an
	332	array named C<mem> to the given filehandle (default STDOUT).
	333
	334	=item $asm->B<parse_and_print_binary16>(I<$string>[, I<$fh>])
	335
	336	Convenience method that calls B<parse>($string), B<finish>, and then
	337	B<print_binary16>($fh).
	338
	339	=item $asm->B<parse_and_print_verilog>(I<$string>[, I<$fh>])
	340
	341	Convenience method that calls B<parse>($string), B<finish>, and then
	342	B<print_verilog>($fh).
	343
	344	=back
	345
	346	=head1 SEE ALSO
	347
	348	L<http://repository.readscheme.org/ftp/papers/ai-lab-pubs/AIM-514.pdf>
	349
	350	=head1 AUTHOR
	351
	352	Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
	353
	354	=head1 COPYRIGHT AND LICENSE
	355
	356	Copyright (C) 2018 by Marius Gavrilescu
	357
	358	This library is free software; you can redistribute it and/or modify
	359	it under the same terms as Perl itself, either Perl version 5.24.3 or,
	360	at your option, any later version of Perl 5 you may have available.
	361
	362
	363	=cut