File Coverage

blib/lib/Language/P/Toy/Opcodes.pm

Criterion	Covered	Total	%
statement	356	645	55.1
branch	50	110	45.4
condition	4	6	66.6
subroutine	63	100	63.0
pod	0	86	0.0
total	473	947	49.9

package Language::P::Toy::Opcodes;

use strict;
use warnings;
use Exporter 'import';

use Language::P::Toy::Value::StringNumber;
use Language::P::Toy::Value::Reference;
use Language::P::Toy::Value::Array;
use Language::P::Toy::Value::List;
use Language::P::ParseTree qw(:all);

use Language::P::Toy::Opcodes::Regex qw(:opcodes);

our @EXPORT_OK = qw(o);

sub o {
    my( $name, %args ) = @_;

    Carp::confess "Invalid opcode '$name'"
        unless defined $Language::P::Toy::Opcodes::{"o_$name"};
    my $fun = *{$Language::P::Toy::Opcodes::{"o_$name"}}{CODE};
    Carp::confess "Invalid opcode '$name'"
        unless defined $fun;

    return { %args,
             function => $fun,
             op_name  => $name,
             };
}

sub _context {
    my( $op, $runtime ) = @_;
    my $cxt = $op ? $op->{context} : 0;

    return $cxt if $cxt && $cxt != CXT_CALLER;
    return $runtime->{_stack}[$runtime->{_frame} - 2][2];
}

sub o_noop {
    my( $op, $runtime, $pc ) = @_;

    return $pc + 1;
}

sub o_dup {
    my( $op, $runtime, $pc ) = @_;
    my $value = $runtime->{_stack}->[-1];

    push @{$runtime->{_stack}}, $value;

    return $pc + 1;
}

sub o_swap {
    my( $op, $runtime, $pc ) = @_;
    my $t = $runtime->{_stack}->[-1];

    $runtime->{_stack}->[-1] = $runtime->{_stack}->[-2];
    $runtime->{_stack}->[-2] = $t;

    return $pc + 1;
}

sub o_pop {
    my( $op, $runtime, $pc ) = @_;

    pop @{$runtime->{_stack}};

    return $pc + 1;
}

sub o_print {
    my( $op, $runtime, $pc ) = @_;
    my $args = pop @{$runtime->{_stack}};

    my $fh = $args->get_item( 0 );
    for( my $iter = $args->iterator_from( 1 ); $iter->next; ) {
        $fh->write( $iter->item );
    }

    # HACK
    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { integer => 1 } );

    return $pc + 1;
}

sub o_constant {
    my( $op, $runtime, $pc ) = @_;
    push @{$runtime->{_stack}}, $op->{value};

    return $pc + 1;
}

sub o_fresh_string {
    my( $op, $runtime, $pc ) = @_;
    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new
                                    ( { string => $op->{value} } );

    return $pc + 1;
}

sub o_stringify {
    my( $op, $runtime, $pc ) = @_;
    my $v = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { string => $v->as_string } );

    return $pc + 1;
}

sub _make_binary_op {
    my( $op ) = @_;

    eval sprintf <<'EOT',
sub %s {
    my( $op, $runtime, $pc ) = @_;
    my $vr = pop @{$runtime->{_stack}};
    my $vl = pop @{$runtime->{_stack}};
    my $r = $vl->%s %s $vr->%s;

    push @{$runtime->{_stack}},
         Language::P::Toy::Value::StringNumber->new( { %s => $r } );

    return $pc + 1;
}
EOT
        $op->{name}, $op->{convert}, $op->{operator}, $op->{convert},
        $op->{new_type};
    die $@ if $@;
}

sub _make_binary_op_assign {
    my( $op ) = @_;

    eval sprintf <<'EOT',
sub %s {
    my( $op, $runtime, $pc ) = @_;
    my $vr = pop @{$runtime->{_stack}};
    my $vl = $runtime->{_stack}[-1];
    my $r = $vl->%s %s $vr->%s;

    $vl->{%s} = $r;

    return $pc + 1;
}
EOT
        $op->{name}, $op->{convert}, $op->{operator}, $op->{convert},
        $op->{new_type};
    die $@ if $@;
}

_make_binary_op( $_ ) foreach
  ( { name     => 'o_add',
      convert  => 'as_float',
      operator => '+',
      new_type => 'float',
      },
    { name     => 'o_subtract',
      convert  => 'as_float',
      operator => '-',
      new_type => 'float',
      },
    { name     => 'o_multiply',
      convert  => 'as_float',
      operator => '*',
      new_type => 'float',
      },
    { name     => 'o_divide',
      convert  => 'as_float',
      operator => '/',
      new_type => 'float',
      },
    { name     => 'o_modulus',
      convert  => 'as_integer',
      operator => '%',
      new_type => 'integer',
      },
    { name     => 'o_concat',
      convert  => 'as_string',
      operator => '.',
      new_type => 'string',
      },
    );

_make_binary_op_assign( $_ ) foreach
  ( { name     => 'o_concat_assign',
      convert  => 'as_string',
      operator => '.',
      new_type => 'string',
      },
    );

sub o_make_list {
    my( $op, $runtime, $pc ) = @_;
    my $st = $runtime->{_stack};

    # create the list
    my $list = Language::P::Toy::Value::List->new;
    if( $op->{count} ) {
        for( my $j = $#$st - $op->{count} + 1; $j <= $#$st; ++$j ) {
            $list->push( $st->[$j] );
        }
        # clear the stack
        $#$st -= $op->{count} - 1;
        $st->[-1] = $list;
    } else {
        push @$st, $list;
    }

    return $pc + 1;
}

sub o_end {
    my( $op, $runtime, $pc ) = @_;

    return -1;
}

sub o_want {
    my( $op, $runtime, $pc ) = @_;
    my $cxt = _context( undef, $runtime );
    my $v;

    if( $cxt == CXT_VOID ) {
        $v = Language::P::Toy::Value::StringNumber->new;
    } elsif( $cxt == CXT_SCALAR ) {
        $v = Language::P::Toy::Value::StringNumber->new( { string => '' } );
    } elsif( $cxt == CXT_LIST ) {
        $v = Language::P::Toy::Value::StringNumber->new( { integer => 1 } );
    } else {
        die "Unknow context $cxt";
    }
    push @{$runtime->{_stack}}, $v;

    return $pc + 1;
}

sub o_call {
    my( $op, $runtime, $pc ) = @_;
    my $sub = pop @{$runtime->{_stack}};

    $sub->call( $runtime, $pc, _context( $op, $runtime ) );

    return 0;
}

my $empty_list = Language::P::Toy::Value::List->new;

sub o_return {
    my( $op, $runtime, $pc ) = @_;
    my $cxt = _context( undef, $runtime );
    my $rv = $runtime->{_stack}->[-1];
    my $rpc = $runtime->call_return;

    if( $cxt == CXT_SCALAR ) {
        if( $rv->get_count > 0 ) {
            push @{$runtime->{_stack}}, $rv->get_item( $rv->get_count - 1 )
                                           ->as_scalar;
        } else {
            push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new;
        }
    } elsif( $cxt == CXT_LIST ) {
        push @{$runtime->{_stack}}, $rv;
    } elsif( $cxt == CXT_VOID ) {
        # it is easier to generate code if a subroutine
        # always returns a value (even if a dummy one)
        push @{$runtime->{_stack}}, $empty_list;
    }

    return $rpc + 1;
}

sub o_glob {
    my( $op, $runtime, $pc ) = @_;
    my $value = $runtime->symbol_table->get_symbol( $op->{name}, '*',
                                                    $op->{create} );

    push @{$runtime->{_stack}}, $value;

    return $pc + 1;
}

sub o_lexical {
    my( $op, $runtime, $pc ) = @_;
    my $value = $runtime->{_stack}->[$runtime->{_frame} - 3 - $op->{index}]
                  ||= Language::P::Toy::Value::StringNumber->new;

    push @{$runtime->{_stack}}, $value;

    return $pc + 1;
}

sub o_lexical_set {
    my( $op, $runtime, $pc ) = @_;
    my $value = pop @{$runtime->{_stack}};

    $runtime->{_stack}->[$runtime->{_frame} - 3 - $op->{index}] = $value;

    return $pc + 1;
}

sub o_lexical_clear {
    my( $op, $runtime, $pc ) = @_;

    $runtime->{_stack}->[$runtime->{_frame} - 3 - $op->{index}] = undef;

    return $pc + 1;
}

sub o_lexical_pad {
    my( $op, $runtime, $pc ) = @_;
    my $pad = $runtime->{_stack}->[$runtime->{_frame} - 1];

    push @{$runtime->{_stack}}, $pad->values->[$op->{index}];

    return $pc + 1;
}

sub o_lexical_pad_clear {
    my( $op, $runtime, $pc ) = @_;
    my $pad = $runtime->{_stack}->[$runtime->{_frame} - 1];

    $pad->values->[$op->{index}] = undef;

    return $pc + 1;
}

sub o_parameter_index {
    my( $op, $runtime, $pc ) = @_;
    my $value = $runtime->{_stack}->[$runtime->{_frame} - 3]->get_item( $op->{index} );

    push @{$runtime->{_stack}}, $value;

    return $pc + 1;
}

sub o_jump {
    my( $op, $runtime, $pc ) = @_;

    return $op->{to};
}

sub o_jump_if_eq_immed {
    my( $op, $runtime, $pc ) = @_;
    my $v1 = pop @{$runtime->{_stack}};

    return $v1 == $op->{value} ? $op->{to} : $pc + 1;
}

sub o_jump_if_false {
    my( $op, $runtime, $pc ) = @_;
    my $v1 = pop @{$runtime->{_stack}};

    return !$v1->as_boolean_int ? $op->{to} : $pc + 1;
}

sub o_jump_if_true {
    my( $op, $runtime, $pc ) = @_;
    my $v1 = pop @{$runtime->{_stack}};

    return $v1->as_boolean_int ? $op->{to} : $pc + 1;
}

sub o_jump_if_null {
    my( $op, $runtime, $pc ) = @_;
    my $v1 = pop @{$runtime->{_stack}};

    return !defined $v1 ? $op->{to} : $pc + 1;
}

sub _make_cond_jump {
    my( $op ) = @_;

    eval sprintf <<'EOT',
sub %s {
    my( $op, $runtime, $pc ) = @_;
    my $vr = pop @{$runtime->{_stack}};
    my $vl = pop @{$runtime->{_stack}};

    return $vl->%s %s $vr->%s ? $op->{to} : $pc + 1;
}
EOT
        $op->{name}, $op->{convert}, $op->{operator}, $op->{convert};
}

_make_cond_jump( $_ ) foreach
  ( { name     => 'o_jump_if_i_lt',
      convert  => 'as_integer',
      operator => '<',
      },
    { name     => 'o_jump_if_i_le',
      convert  => 'as_integer',
      operator => '<=',
      },
    { name     => 'o_jump_if_i_eq',
      convert  => 'as_integer',
      operator => '==',
      },
    { name     => 'o_jump_if_i_ge',
      convert  => 'as_integer',
      operator => '>=',
      },
    { name     => 'o_jump_if_i_gt',
      convert  => 'as_integer',
      operator => '>',
      },

    { name     => 'o_jump_if_f_lt',
      convert  => 'as_float',
      operator => '<',
      },
    { name     => 'o_jump_if_f_le',
      convert  => 'as_float',
      operator => '<=',
      },
    { name     => 'o_jump_if_f_eq',
      convert  => 'as_float',
      operator => '==',
      },
    { name     => 'o_jump_if_f_ge',
      convert  => 'as_float',
      operator => '>=',
      },
    { name     => 'o_jump_if_f_gt',
      convert  => 'as_float',
      operator => '>',
      },

    { name     => 'o_jump_if_s_eq',
      convert  => 'as_string',
      operator => 'eq',
      },
    { name     => 'o_jump_if_s_ne',
      convert  => 'as_string',
      operator => 'ne',
      },
    );

sub _make_compare {
    my( $op ) = @_;

    my $ret = $op->{new_type} eq 'int' ?
                  '$r' :
                  'Language::P::Toy::Value::StringNumber->new( { integer => $r } )';

    eval sprintf <<'EOT',
sub %s {
    my( $op, $runtime, $pc ) = @_;
    my $vr = pop @{$runtime->{_stack}};
    my $vl = pop @{$runtime->{_stack}};
    my $r = $vl->%s %s $vr->%s ? 1 : 0;

    push @{$runtime->{_stack}}, %s;

    return $pc + 1;
}
EOT
        $op->{name}, $op->{convert}, $op->{operator}, $op->{convert},
        $ret;
}

_make_compare( $_ ) foreach
  ( { name     => 'o_compare_i_lt_int',
      convert  => 'as_integer',
      operator => '<',
      new_type => 'int',
      },
    { name     => 'o_compare_i_le_int',
      convert  => 'as_integer',
      operator => '<=',
      new_type => 'int',
      },
    { name     => 'o_compare_i_eq_int',
      convert  => 'as_integer',
      operator => '==',
      new_type => 'int',
      },
    { name     => 'o_compare_i_ge_int',
      convert  => 'as_integer',
      operator => '>=',
      new_type => 'int',
      },
    { name     => 'o_compare_i_gt_int',
      convert  => 'as_integer',
      operator => '>',
      new_type => 'int',
      },

    { name     => 'o_compare_i_le_scalar',
      convert  => 'as_integer',
      operator => '<=',
      new_type => 'scalar',
      },
    { name     => 'o_compare_i_eq_scalar',
      convert  => 'as_integer',
      operator => '==',
      new_type => 'scalar',
      },
    { name     => 'o_compare_i_ne_scalar',
      convert  => 'as_integer',
      operator => '!=',
      new_type => 'scalar',
      },

    { name     => 'o_compare_f_lt_int',
      convert  => 'as_float',
      operator => '<',
      new_type => 'int',
      },
    { name     => 'o_compare_f_le_int',
      convert  => 'as_float',
      operator => '<=',
      new_type => 'int',
      },
    { name     => 'o_compare_f_eq_int',
      convert  => 'as_float',
      operator => '==',
      new_type => 'int',
      },
    { name     => 'o_compare_f_ge_int',
      convert  => 'as_float',
      operator => '>=',
      new_type => 'int',
      },
    { name     => 'o_compare_f_gt_int',
      convert  => 'as_float',
      operator => '>',
      new_type => 'int',
      },

    { name     => 'o_compare_f_le_scalar',
      convert  => 'as_float',
      operator => '<=',
      new_type => 'scalar',
      },
    { name     => 'o_compare_f_eq_scalar',
      convert  => 'as_float',
      operator => '==',
      new_type => 'scalar',
      },
    { name     => 'o_compare_f_ne_scalar',
      convert  => 'as_float',
      operator => '!=',
      new_type => 'scalar',
      },

    { name     => 'o_compare_s_eq_int',
      convert  => 'as_string',
      operator => 'eq',
      new_type => 'int',
      },
    { name     => 'o_compare_s_ne_int',
      convert  => 'as_string',
      operator => 'ne',
      new_type => 'int',
      },

    { name     => 'o_compare_s_eq_scalar',
      convert  => 'as_string',
      operator => 'eq',
      new_type => 'scalar',
      },
    { name     => 'o_compare_s_ne_scalar',
      convert  => 'as_string',
      operator => 'ne',
      new_type => 'scalar',
      },
    );

sub o_negate {
    my( $op, $runtime, $pc ) = @_;
    my $v = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { float => -$v->as_float } );

    return $pc + 1;
}

sub o_abs {
    my( $op, $runtime, $pc ) = @_;
    my $v = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { float => abs $v->as_float } );

    return $pc + 1;
}

sub o_not {
    my( $op, $runtime, $pc ) = @_;
    my $v = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { integer => !$v->as_boolean_int } );

    return $pc + 1;
}

sub o_assign {
    my( $op, $runtime, $pc ) = @_;
    my $vr = pop @{$runtime->{_stack}};
    my $vl = $runtime->{_stack}[-1];

    $vl->assign( $vr );

    return $pc + 1;
}

sub o_glob_slot_create {
    my( $op, $runtime, $pc ) = @_;
    my $glob = pop @{$runtime->{_stack}};
    my $slot = $op->{slot};

    push @{$runtime->{_stack}}, $glob->get_or_create_slot( $slot );

    return $pc + 1;
}

sub o_glob_slot {
    my( $op, $runtime, $pc ) = @_;
    my $glob = pop @{$runtime->{_stack}};
    my $slot = $op->{slot};

    push @{$runtime->{_stack}}, $glob->get_slot( $slot );

    return $pc + 1;
}

sub o_glob_slot_set {
    my( $op, $runtime, $pc ) = @_;

    my $value = pop @{$runtime->{_stack}};
    my $glob = pop @{$runtime->{_stack}};
    my $slot = $op->{slot};

    $glob->set_slot( $slot, $value );

    return $pc + 1;
}

sub o_unlink {
    my( $op, $runtime, $pc ) = @_;
    my $args = pop @{$runtime->{_stack}};
    my @args;

    for( my $it = $args->iterator; $it->next; ) {
        my $arg = $it->item;

        push @args, $arg->as_string;
    }

    my $ret = unlink @args;

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber( { integer => $ret } );
    return $pc + 1;
}

sub o_backtick {
    my( $op, $runtime, $pc ) = @_;
    my $arg = pop @{$runtime->{_stack}};
    my $command = $arg->as_string;

    # context
    my $ret = `$command`;

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { string => $ret } );

    return $pc + 1;
}

sub o_array_element {
    my( $op, $runtime, $pc ) = @_;
    my $array = pop @{$runtime->{_stack}};
    my $index = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, $array->get_item( $index->as_integer );

    return $pc + 1;
}

sub o_hash_element {
    my( $op, $runtime, $pc ) = @_;
    my $hash = pop @{$runtime->{_stack}};
    my $key = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, $hash->get_item( $key->as_string );

    return $pc + 1;
}

sub o_array_size {
    my( $op, $runtime, $pc ) = @_;
    my $array = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, Language::P::Toy::Value::StringNumber->new( { integer => $array->get_count - 1 } );

    return $pc + 1;
}

sub o_reference {
    my( $op, $runtime, $pc ) = @_;
    my $value = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, Language::P::Toy::Value::Reference->new( { reference => $value } );

    return $pc + 1;
}

sub o_dereference_scalar {
    my( $op, $runtime, $pc ) = @_;
    my $ref = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, $ref->dereference_scalar;

    return $pc + 1;
}

sub o_dereference_subroutine {
    my( $op, $runtime, $pc ) = @_;
    my $ref = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, $ref->dereference_subroutine;

    return $pc + 1;
}

sub o_defined {
    my( $op, $runtime, $pc ) = @_;
    my $value = pop @{$runtime->{_stack}};
    my $defined = $value->is_defined;

    push @{$runtime->{_stack}}, $defined ?
             Language::P::Toy::Value::StringNumber->new( { integer => 1 } ) :
             Language::P::Toy::Value::StringNumber->new( { string => '' } );

    return $pc + 1;
}

sub o_make_closure {
    my( $op, $runtime, $pc ) = @_;
    my $sub = pop @{$runtime->{_stack}};
    my $clone = Language::P::Toy::Value::Subroutine->new
                    ( { bytecode   => $sub->bytecode,
                        stack_size => $sub->stack_size,
                        outer      => $sub->outer,
                        lexicals   => $sub->lexicals->new_scope,
                        } );

    if( my $closed_values = $sub->closed ) {
        my $outer = $runtime->{_stack}->[$runtime->{_frame} - 1];
        my $pad = $clone->lexicals;

        foreach my $from_to ( @$closed_values ) {
            $pad->values->[$from_to->[1]] = $outer->values->[$from_to->[0]];
        }
    }

    push @{$runtime->{_stack}}, Language::P::Toy::Value::Reference->new
                                    ( { reference => $clone,
                                        } );

    return $pc + 1;
}

sub o_localize_glob_slot {
    my( $op, $runtime, $pc ) = @_;
    my $glob = $runtime->symbol_table->get_symbol( $op->{name}, '*', 1 );
    my $to_save = $glob->get_slot( $op->{slot} );
    my $saved = $to_save->localize;

    $runtime->{_stack}->[$runtime->{_frame} - 3 - $op->{index}] = $to_save;
    $glob->set_slot( $op->{slot}, $saved );
    push @{$runtime->{_stack}}, $saved;

    return $pc + 1;
}

sub o_restore_glob_slot {
    my( $op, $runtime, $pc ) = @_;
    my $glob = $runtime->symbol_table->get_symbol( $op->{name}, '*', 1 );
    my $saved = $runtime->{_stack}->[$runtime->{_frame} - 3 - $op->{index}];

    $glob->set_slot( $op->{slot}, $saved ) if $saved;
    $runtime->{_stack}->[$runtime->{_frame} - 3 - $op->{index}] = undef;

    return $pc + 1;
}

sub o_iterator {
    my( $op, $runtime, $pc ) = @_;
    my $list = pop @{$runtime->{_stack}};
    my $iter = $list->iterator;

    push @{$runtime->{_stack}}, $iter;

    return $pc + 1;
}

sub o_iterator_next {
    my( $op, $runtime, $pc ) = @_;
    my $iter = pop @{$runtime->{_stack}};

    push @{$runtime->{_stack}}, $iter->next ? $iter->item : undef;

    return $pc + 1;
}

1;