File Coverage

blib/lib/Math/Symbolic/Custom/CCompiler.pm

Criterion	Covered	Total	%
statement	103	110	93.6
branch	9	16	56.2
condition	4	6	66.6
subroutine	18	18	100.0
pod	2	2	100.0
total	136	152	89.4

package Math::Symbolic::Custom::CCompiler;

use 5.006;
use strict;
use warnings;
use Inline;
use Carp qw/croak carp cluck confess/;

use Math::Symbolic::Custom::Base;
BEGIN {*import = \&Math::Symbolic::Custom::Base::aggregate_import}

use Math::Symbolic::ExportConstants qw/:all/;
our $VERSION = '1.04';

our $Aggregate_Export = [qw/to_c to_compiled_c/];

our @Operators_To_C = (
    # B_SUM
	'$_[0] + $_[1]',
    # B_DIFFERENCE
	'$_[0] - $_[1]',
    # B_PRODUCT
	'$_[0] * $_[1]',
    # B_DIVISION
	'$_[0] / $_[1]',
    # U_MINUS
	'-$_[0]',
    # U_P_DERIVATIVE
	'ERROR',
    # U_T_DERIVATIVE
	'ERROR',
    # B_EXP
	'pow($_[0], $_[1])',
    # B_LOG
	'log($_[1]) / log($_[0])',
    # U_SINE
	'sin($_[0])',
    # U_COSINE
	'cos($_[0])',
    # U_TANGENT
	'tan($_[0])',
    # U_COTANGENT
	'cos($_[0]) / sin($_[0])',
    # U_ARCSINE
	'asin($_[0])',
    # U_ARCCOSINE
	'acos($_[0])',
    # U_ARCTANGENT
	'atan($_[0])',
    # U_ARCCOTANGENT
	'atan2( 1 / $_[0], 1 )',
    # U_SINE_H
	'sinh($_[0])',
    # U_COSINE_H
	'cosh($_[0])',
    # U_AREASINE_H
	'log( $_[0] + sqrt( $_[0] * $_[0] + 1 ) )',
    # U_AREACOSINE_H
	'log( $_[0] + sqrt( $_[0] * $_[0] - 1 ) )',
    # B_ARCTANGENT_TWO
	'atan2($_[0], $_[1])',
);

sub to_compiled_c {
	my $tree = shift;
	my $order = shift || [];
	my $code = $tree->to_c($order);
	Math::Symbolic::Custom::CCompiler::_Compiled::compile($code);
	$code =~ /^\s*double\s*(\w+)\(/
		or croak "Compilation to C failed for unknown reasons.";
	my $f_name = $1;
	no strict 'refs';
	my $ref = *{"Math::Symbolic::Custom::CCompiler::_Compiled::$f_name"}{CODE};
	delete(${Math::Symbolic::Custom::CCompiler::_Compiled::}{$f_name});
	return $ref;
}

sub to_c {
	my $tree = shift;
	my $order = shift || [];
	my $count = 0;
	my %order = map { ( $_, $count++ ) } @$order;
	no warnings 'recursion';

	my $vars = [ $tree->explicit_signature() ];

	my %vars;
	my @not_placed;
	foreach (@$vars) {
		my $pos = $order{$_};
		if ( defined $pos ) {
			$vars{$_} = $pos;
		}
		else {
			push @not_placed, $_;
		}
	}

	$count = 0;
	foreach ( sort @not_placed ) {
		$vars{$_} = @$vars - @not_placed + $count++;
	}
	my @sorted_vars = sort {$vars{$a} <=> $vars{$b}} keys %vars;

	my $subname = _find_subname(
		'Math::Symbolic::Custom::CCompiler::_Compiled'
	);
	my $code = "double $subname(";
	my $first = 1;
	my @varmap;
	my $startvar = 'aaaaaa';
	foreach (@sorted_vars) {
		push @varmap, '_V'.$startvar;
		$code .= ', ' unless $first-- == 1;
		$code .= "double _V$startvar";
		$startvar++;
	}
	$code .= ") {\nreturn( ";

	no warnings 'recursion';

	$code .= _rec_ms_to_c($tree, \%vars, \@varmap);

	$code .= " );\n}\n";
	return $code;
}

sub _rec_ms_to_c {
    my $tree  = shift;
    my $vars  = shift;
    my $varmap = shift;

    my $code  = '';
    my $ttype = $tree->term_type();

    if ( $ttype == T_CONSTANT ) {
	my $value = $tree->value();
	$value .= '.' if $value !~ /\./;
        $code .= $value;
    }
    elsif ( $ttype == T_VARIABLE ) {
        $code .= ' ' . $varmap->[$vars->{ $tree->name() }] . ' ';
    }
    else {
        my $type  = $tree->type();
        my $otype = $Math::Symbolic::Operator::Op_Types[$type];
        my $app   = $otype->{application};
        if ( ref($app) eq 'CODE' ) {
		confess("Trying to compile differential operator to C.\n" .
			"This is not supported by " .
			"Math::Symbolic::Custom::CCompiler\n");
	}
        else {
	    $app = $Operators_To_C[$type];
            my @app = split /\$_\[(\d+)\]/, $app;
            if ( @app > 1 ) {
                for ( my $i = 1 ; $i < @app ; $i += 2 ) {
                    $app[$i] = '('
                      . _rec_ms_to_c( $tree->{operands}[ $app[$i] ],
                        $vars, $varmap )
                      . ')';
                }
            }
            $code .= join '', @app;
        }
    }
    return $code;
}

sub _find_subname {
	my $package = shift;
	my $min_length = shift || 5;
	no strict 'refs';
	my $ref = \%{$package.'::'};
	use strict 'refs';
	my $name = 'A'x$min_length;
	while (exists $ref->{$name}) {
		$name++;
	}
	return $name;
}

1;
package Math::Symbolic::Custom::CCompiler::_Compiled;
sub compile {
	my $code = shift;
	Inline->bind(C => $code);
}



1;
__END__