File Coverage

blib/lib/App/Scheme79asm/Compiler.pm

Criterion	Covered	Total	%
statement	115	116	99.1
branch	43	44	97.7
condition			n/a
subroutine	27	27	100.0
pod	0	15	0.0
total	185	202	91.5

package App::Scheme79asm::Compiler;

use 5.014000;
use strict;
use warnings;

our $VERSION = '0.005001';

use Carp qw/croak/;
use Data::Dumper qw/Dumper/;
use Scalar::Util qw/looks_like_number/;

use Data::SExpression qw/cons consp scalarp/;
use List::MoreUtils qw/firstidx/;

our @PRIMOPS = qw/car cdr cons atom progn reverse-list/;

sub make_symbol { Data::SExpression::Symbol->new(shift) }

# types
our $LIST   = make_symbol 'LIST';
our $SYMBOL = make_symbol 'SYMBOL';
our $VAR    = make_symbol 'VAR';
# no need for closures
our $PROC   = make_symbol 'PROC';
our $IF     = make_symbol 'IF';
our $CALL   = make_symbol 'CALL';
# no need for quoted constants

# primitives
our $MORE    = make_symbol 'MORE';
our $FUNCALL = make_symbol 'FUNCALL';

BEGIN {
	*cons    = *Data::SExpression::cons;
	*consp   = *Data::SExpression::consp;
	*scalarp = *Data::SExpression::scalarp;
}

# list processing routines
sub append {
	my ($expr, $rest) = @_;
	if (defined $expr) {
		cons $expr->car, append($expr->cdr, $rest)
	} else {
		$rest
	}
}

sub mapcar (&@);

sub mapcar (&@) {
	my ($block, $expr) = @_;
	if (defined $expr) {
		my $result;
		do {
			local $_ = $expr->car;
			$result = $block->()
		};
		cons $result, mapcar { $block->($_) } $expr->cdr
	} else {
		undef
	}
}

sub revacc {
	my ($expr, $acc) = @_;
	if (defined $expr) {
		revacc ($expr->cdr, cons($expr->car, $acc))
	} else {
		$acc
	}
}

sub rev {
	my ($expr) = @_;
	revacc $expr, undef;
}

sub positionacc {
	my ($expr, $list, $acc) = @_;
	if (!defined $list) {
		undef
	} elsif ($list->car eq $expr) {
		$acc
	} else {
		positionacc($expr, $list->cdr, $acc + 1)
	}
}

sub position {
	my ($expr, $list) = @_;
	positionacc $expr, $list, 0
}
# end list processing routines

sub new {
	my ($class) = @_;
	my %self = (
		symbols => ['', '', 'T'],
		nsymbols => 3,
		symbol_map => {T => 2},
	);
	bless \%self, $class;
}

sub process_quoted {
	my ($self, $expr) = @_;
	if (!defined $expr) { # nil
		[$LIST => 0]
	} elsif (scalarp $expr) {
		$expr = uc $expr;
		if ($expr eq 'NIL') {
			return [$LIST => 0]
		}
		if (!exists $self->{symbol_map}{$expr}) {
			$self->{symbol_map}{$expr} = $self->{nsymbols};
			$self->{nsymbols}++;
			push @{$self->{symbols}}, $expr;
		}
		[$SYMBOL => $self->{symbol_map}{$expr}]
	} elsif (consp $expr) {
		[$LIST => $self->process_quoted($expr->cdr), $self->process_quoted($expr->car)]
	} else {
		croak 'argument to process_quoted is not a scalar, cons, or nil: ', Dumper($expr);
	}
}

sub process_proc {
	my ($self, $func_name, $func_args, $func_body, $env) = @_;
	my $new_env = append cons($func_name, rev $func_args), $env;
	$self->process_toplevel($func_body, $new_env)
}

sub rest_of_funcall {
	my ($self, $func, $args) = @_;
	if (!defined $args) {
		$func
	} else {
		[$MORE => $self->rest_of_funcall($func, $args->cdr), $args->car]
	}
}

sub process_funcall {
	my ($self, $func_name, $func_args, $env) = @_;
	my $prim_idx = firstidx { uc $_ eq uc $func_name } @PRIMOPS;
	my $processed_args =
	  mapcar { $self->process_toplevel($_, $env) } $func_args;
	if ($prim_idx > -1) {
		if (!defined $processed_args) {
			croak "Cannot call primitive $func_name with no arguments";
		}
		[$CALL => $self->rest_of_funcall([make_symbol(uc $func_name), 0], $processed_args->cdr), $processed_args->car]
	} else {
		my $final_args = append $processed_args, cons ($self->process_toplevel($func_name, $env), undef);
		[$CALL => $self->rest_of_funcall([$FUNCALL => 0], $final_args->cdr), $final_args->car]
	}
}

sub process_toplevel {
	my ($self, $expr, $env) = @_;
	if (!defined $expr) {
		[$LIST => 0]
	} elsif (scalarp $expr) {
		if (looks_like_number $expr) {
			$self->process_quoted($expr);
		} elsif (uc $expr eq 'T') {
			[$SYMBOL => 2]
		} elsif (uc $expr eq 'NIL') {
			[$LIST => 0]
		} else {
			my $position = position $expr, $env;
			if (defined $position) {
				[$VAR => -1 - $position]
			} else {
				croak "Variable $expr not in environment";
			}
		}
	} else {
		my $func = uc $expr->car;
		if ($func eq 'QUOTE') {
			$self->process_quoted($expr->cdr->car)
		} elsif ($func eq 'LAMBDA') {
			my $func_name = $expr->cdr->car;
			my $func_args = $expr->cdr->cdr->car;
			my $func_body = $expr->cdr->cdr->cdr->car; ## no critic (ProhibitLongChainsOfMethodCalls)
			[$PROC => $self->process_proc($func_name, $func_args, $func_body, $env)]
		} elsif ($func eq 'IF') {
			my ($if_cond, $if_then, $if_else) =
			  map { $self->process_toplevel($_, $env) }
			  ($expr->cdr->car, $expr->cdr->cdr->car, $expr->cdr->cdr->cdr->car); ## no critic (ProhibitLongChainsOfMethodCalls)
			[$IF => [$LIST => $if_else, $if_then], $if_cond]
		} else {
			$self->process_funcall($expr->car, $expr->cdr, $env)
		}
	}
}

sub compile_sexp {
	my ($self, $expr) = @_;
	$self->process_toplevel($expr, undef)
}

sub compile_string {
	my ($self, $string) = @_;
	my $sexp = Data::SExpression->new(
		{fold_lists => 0, use_symbol_class => 1}
	);
	my $expr = $sexp->read($string);
	$self->compile_sexp($expr)
}

1;
__END__