#! /usr/bin/perl
use Python::Bytecode;
use Carp;

# Yeah, turns out that Python::Bytecode throws warnings. Ah, well,
# we'll assume our modules are all OK.
use strict;
use warnings;

#
# Turn a python bytecode file into a parrot imcc file
#
# Usage:
#
# translator pythonfile.pyc [parrotfile.imc]
#
# Without a destination filename, the source filename with a .imc
# extension instead of a .pyc filename is used

# Constants for opnames
use constant 'STOP_CODE' => 0;
use constant 'POP_TOP' => 1;
use constant 'ROT_TWO' => 2;
use constant 'ROT_THREE' => 3;
use constant 'DUP_TOP' => 4;
use constant 'ROT_FOUR' => 5;
use constant 'UNARY_POSITIVE' => 10;
use constant 'UNARY_NEGATIVE' => 11;
use constant 'UNARY_NOT' => 12;
use constant 'UNARY_CONVERT' => 13;
use constant 'UNARY_INVERT' => 15;
use constant 'BINARY_POWER' => 19;
use constant 'BINARY_MULTIPLY' => 20;
use constant 'BINARY_DIVIDE' => 21;
use constant 'BINARY_MODULO' => 22;
use constant 'BINARY_ADD' => 23;
use constant 'BINARY_SUBTRACT' => 24;
use constant 'BINARY_SUBSCR' => 25;
use constant 'BINARY_FLOOR_DIVIDE' => 26;
use constant 'BINARY_TRUE_DIVIDE' => 27;
use constant 'INPLACE_FLOOR_DIVIDE' => 28;
use constant 'INPLACE_TRUE_DIVIDE' => 29;
use constant 'SLICE_0' => 30;
use constant 'SLICE_1' => 31;
use constant 'SLICE_2' => 32;
use constant 'SLICE_3' => 33;
use constant 'STORE_SLICE_0' => 40;
use constant 'STORE_SLICE_1' => 41;
use constant 'STORE_SLICE_2' => 42;
use constant 'STORE_SLICE_3' => 43;
use constant 'DELETE_SLICE_0' => 50;
use constant 'DELETE_SLICE_1' => 51;
use constant 'DELETE_SLICE_2' => 52;
use constant 'DELETE_SLICE_3' => 53;
use constant 'INPLACE_ADD' => 55;
use constant 'INPLACE_SUBTRACT' => 56;
use constant 'INPLACE_MULTIPLY' => 57;
use constant 'INPLACE_DIVIDE' => 58;
use constant 'INPLACE_MODULO' => 59;
use constant 'STORE_SUBSCR' => 60;
use constant 'DELETE_SUBSCR' => 61;
use constant 'BINARY_LSHIFT' => 62;
use constant 'BINARY_RSHIFT' => 63;
use constant 'BINARY_AND' => 64;
use constant 'BINARY_XOR' => 65;
use constant 'BINARY_OR' => 66;
use constant 'INPLACE_POWER' => 67;
use constant 'GET_ITER' => 68;
use constant 'PRINT_EXPR' => 70;
use constant 'PRINT_ITEM' => 71;
use constant 'PRINT_NEWLINE' => 72;
use constant 'PRINT_ITEM_TO' => 73;
use constant 'PRINT_NEWLINE_TO' => 74;
use constant 'INPLACE_LSHIFT' => 75;
use constant 'INPLACE_RSHIFT' => 76;
use constant 'INPLACE_AND' => 77;
use constant 'INPLACE_XOR' => 78;
use constant 'INPLACE_OR' => 79;
use constant 'BREAK_LOOP' => 80;
use constant 'LOAD_LOCALS' => 82;
use constant 'RETURN_VALUE' => 83;
use constant 'IMPORT_STAR' => 84;
use constant 'EXEC_STMT' => 85;
use constant 'YIELD_VALUE' => 86;
use constant 'POP_BLOCK' => 87;
use constant 'END_FINALLY' => 88;
use constant 'BUILD_CLASS' => 89;
use constant 'STORE_NAME' => 90;
use constant 'DELETE_NAME' => 91;
use constant 'UNPACK_SEQUENCE' => 92;
use constant 'FOR_ITER' => 93;
use constant 'STORE_ATTR' => 95;
use constant 'DELETE_ATTR' => 96;
use constant 'STORE_GLOBAL' => 97;
use constant 'DELETE_GLOBAL' => 98;
use constant 'DUP_TOPX' => 99;
use constant 'LOAD_CONST' => 100;
use constant 'LOAD_NAME' => 101;
use constant 'BUILD_TUPLE' => 102;
use constant 'BUILD_LIST' => 103;
use constant 'BUILD_MAP' => 104;
use constant 'LOAD_ATTR' => 105;
use constant 'COMPARE_OP' => 106;
use constant 'IMPORT_NAME' => 107;
use constant 'IMPORT_FROM' => 108;
use constant 'JUMP_FORWARD' => 110;
use constant 'JUMP_IF_FALSE' => 111;
use constant 'JUMP_IF_TRUE' => 112;
use constant 'JUMP_ABSOLUTE' => 113;
use constant 'FOR_LOOP' => 114;
use constant 'LOAD_GLOBAL' => 116;
use constant 'CONTINUE_LOOP' => 119;
use constant 'SETUP_LOOP' => 120;
use constant 'SETUP_EXCEPT' => 121;
use constant 'SETUP_FINALLY' => 122;
use constant 'LOAD_FAST' => 124;
use constant 'STORE_FAST' => 125;
use constant 'DELETE_FAST' => 126;
use constant 'SET_LINENO' => 127;
use constant 'RAISE_VARARGS' => 130;
use constant 'CALL_FUNCTION' => 131;
use constant 'MAKE_FUNCTION' => 132;
use constant 'BUILD_SLICE' => 133;
use constant 'MAKE_CLOSURE' => 134;
use constant 'LOAD_CLOSURE' => 135;
use constant 'LOAD_DEREF' => 136;
use constant 'STORE_DEREF' => 137;
use constant 'CALL_FUNCTION_VAR' => 140;
use constant 'CALL_FUNCTION_KW' => 141;
use constant 'CALL_FUNCTION_VAR_KW' => 142;
use constant 'EXTENDED_ARG' => 143;



my ($infilename, $infile, $outfilename, $outfile);
$infilename = shift;
if (@ARGV) {
    $outfilename = shift;
} else {
    $outfilename = $infilename;
    $outfilename =~ s/\.pyc$/.imc/;
    if ($outfilename eq $infilename) {
	die "Need a .pyc extension for the input file";
    }
}

open $infile, "<$infilename" or die "Couldn't open $infilename, $!";
my $bytecode = Python::Bytecode->new($infile);
close $infile;

open $outfile, ">$outfilename" or die "Couldn't open $outfilename, $!";

# The global array (yes, evil, cope) that holds the opcode
# translation information. It's a table of functions, indexed by op,
# for the function that matches the op
my @opcodes;

my $namespace;
$infilename =~ /(\w+)\.py/;
$namespace = $1;

# Code to set up constants, for deferred code emission
my @constsetup;

# list 'o sub names so we can apply properties to them
my @subs;

# Constant table we're building
my %const_table;


init();

dump_preamble($outfile);

my (@code, @nextcode);
# Gotta start somewhere, so start with the main routine
push @nextcode, [$bytecode, '__main'];
# Do we have any code objects pending dumping?
my $codeconstcount = 0;
while (@nextcode) {
    # Move the pending objects to the list to be processed, and clear
    # out the pending list
    @code = @nextcode;
    undef @nextcode;

    # For each of the objects we're processing, dump 'em. They'll
    # return something that represents any code objects that have to
    # be dumped because of this.
    foreach my $codeobjentry (@code) {
	push @nextcode, dump_codeobj(@$codeobjentry, $outfile);	
    }

}

dump_postamble($outfile);

# This sub dumps out the preamble info for the file. Each python
# bytecode file has 'sub-less' code that must be run when the
# bytecode file is loaded, and this code does the actual
# initialization of the info in the file--puts in 
sub dump_preamble {
    my ($filehandle) = @_;
    # Code to build up a call frame
    my $call_main = build_frame(['main']);
    print $filehandle <<EOP;
.namespace ["$namespace"]

.pcc_sub __moduleload prototyped, \@LOAD
  .local pmc moduleinit
  moduleinit = find_global "$namespace", '__module_init'

  # Initialization needs to go in here
  moduleinit()

  # call the main routine
  .local pmc main
  main = find_global "$namespace", '__main'
  #main()
$call_main
  # Exit
  .pcc_begin_return
  .pcc_end_return
.end

# Dummy main routine. Does nothing
.pcc_sub __module_main \@MAIN
  .local pmc moduleinit
  moduleinit = find_global "$namespace", '__moduleinit'

  # Initialization needs to go in here
  moduleinit()

  # call the main routine
  .local pmc main
  main = find_global "$namespace", '__main'
#  main()
  $call_main
  end
.end
EOP

}

# Dump out any last-minute stuff. It 
sub dump_postamble {
    my $filehandle = shift;

    # Start the sub
    print $filehandle <<EOP;
.pcc_sub __moduleinit prototyped
  .local pmc co_constants
  co_constants = new ResizablePMCArray
  store_global "PyTranslate$namespace", 'co_constants', co_constants
EOP

    # Dump the constant setup
    print $filehandle join("\n", @constsetup), "\n";

    # Give each sub the right stuff
    foreach my $sub (@subs) {
	my ($subname, $subvars) = @$sub;
	my (@subvars) = @$subvars;
	print $filehandle "\$P0 = new FixedPMCArray\n";
	print $filehandle "\$P0 = ", scalar(@subvars), "\n";
	foreach (0..$#subvars) {
	    print $filehandle "\$P0[$_] = '",$subvars[$_], "'\n";
	}
	print $filehandle "\$P1 = find_global '$namespace', '$subname'\n";
	print $filehandle "setprop \$P1, 'localnames', \$P0\n";
    }

    # End the sub. Hopefully some actual... sub was in there somewhere
    print $filehandle <<EOP;
  .pcc_begin_return
  .pcc_end_return
.end
EOP
}

# Dump out a code object. Returns a list of arrayrefs [codeobj, name]
# that need dumping because of this
sub dump_codeobj {
    my ($codeobj, $objname, $filehandle) = @_;
    my @morecode;
    my @compile_stack;
    my @blockstack;

    push @subs, [$objname, $codeobj->varnames];

    # Go note all the constants for later use
    foreach my $constant (@{$codeobj->constants}) {
	my $thing_to_note;
	my $count = 0;
	$thing_to_note = add_a_constant($constant);
	if (defined $thing_to_note) {
	    push @morecode, $thing_to_note;
	}
    }

    print $filehandle ".pcc_sub $objname\n";
    print $filehandle ".param pmc localvars\n";
    print $filehandle ".local pmc codeobj\n";
    print $filehandle "codeobj = P0\n";
    print $filehandle ".local pmc co_constants\n";
    print $filehandle "co_constants = find_global 'PyTranslate$namespace', 'co_constants'\n";
    foreach my $op ($codeobj->disassemble) {
	# This first chunk of code is to generate a label. Jump
	# destinations have a >> prepended to their offset number,
	# which is as good a thing as any to use as a label
	my $label;
	$op->[0] =~ /^(>>)?\s*(\d+)/;
	$label = $2;
	my $islabel = $1;
	print $filehandle "offset$label: ";
	if (defined $islabel && $islabel eq '>>') {
	    undef @compile_stack; # Stack is always empty at labels
	}

	$opcodes[$op->[1]]->($op, $filehandle, \@compile_stack, $codeobj, \@blockstack);
    }

    print $filehandle ".end\n";


    return @morecode;
}

# A sub to initialize the world for us
sub init {
    # Initialize the parameter list stuff
    
    foreach my $opnum (0..143) {
	$opcodes[$opnum] = sub {die "can't handle opcode $opnum"};
    }

    $opcodes[STOP_CODE] = \&stop_code;
    $opcodes[POP_TOP] = \&pop_top;
    $opcodes[ROT_TWO] = \&rot_two;
    $opcodes[ROT_THREE] = \&rot_three;
    $opcodes[ROT_FOUR] = \&rot_four;
    $opcodes[DUP_TOP] = \&dup_top;
    $opcodes[UNARY_POSITIVE] = \&unary_positive;
    $opcodes[UNARY_NEGATIVE] = \&unary_negative;
    $opcodes[UNARY_NOT] = \&unary_not;
    $opcodes[UNARY_CONVERT] = \&unary_convert;
# skipped, not used in piethon
#    $opcodes[UNARY_INVERT  = \&unary_invert;
    $opcodes[GET_ITER]            = \&get_iter;
    $opcodes[BINARY_POWER]        = \&binary_power;
    $opcodes[BINARY_MULTIPLY]     = \&binary_multiply;
    $opcodes[BINARY_DIVIDE]       = \&binary_divide;
    $opcodes[BINARY_FLOOR_DIVIDE] = \&binary_floor_divide;
# Skipped, not used in piethon
#    $opcodes[BINARY_TRUE_DIVIDE]  = \&binary_true_divide;
    $opcodes[BINARY_MODULO]       = \&binary_modulo;
    $opcodes[BINARY_ADD]          = \&binary_add;
    $opcodes[BINARY_SUBTRACT]     = \&binary_subtract;
    $opcodes[BINARY_SUBSCR]       = \&binary_subscr;
    $opcodes[BINARY_LSHIFT]       = \&binary_lshift;
    $opcodes[BINARY_RSHIFT]       = \&binary_rshift;
    $opcodes[BINARY_ADD]          = \&binary_add;
    $opcodes[BINARY_XOR]          = \&binary_xor;
    $opcodes[BINARY_OR]           = \&binary_or;
    $opcodes[INPLACE_POWER]        = \&inplace_power;
    $opcodes[INPLACE_MULTIPLY]     = \&inplace_multiply;
    $opcodes[INPLACE_DIVIDE]       = \&inplace_divide;
    $opcodes[INPLACE_FLOOR_DIVIDE] = \&inplace_floor_divide;
# Skipped, not used in piethon
#    $opcodes[INPLACE_TRUE_DIVIDE]  = \&inplace_true_divide;
    $opcodes[INPLACE_MODULO]       = \&inplace_modulo;
    $opcodes[INPLACE_ADD]          = \&inplace_add;
    $opcodes[INPLACE_SUBTRACT]     = \&inplace_subtract;
    $opcodes[INPLACE_LSHIFT]       = \&inplace_lshift;
    $opcodes[INPLACE_RSHIFT]       = \&inplace_rshift;
    $opcodes[INPLACE_ADD]          = \&inplace_add;
    $opcodes[INPLACE_XOR]          = \&inplace_xor;
    $opcodes[INPLACE_OR]           = \&inplace_or;
    $opcodes[SLICE_0]              = \&slice_0;
    $opcodes[SLICE_1]              = \&slice_1;
    $opcodes[SLICE_2]              = \&slice_2;
    $opcodes[SLICE_3]              = \&slice_3;
    $opcodes[STORE_SLICE_0]        = \&store_slice_0;
    $opcodes[STORE_SLICE_1]        = \&store_slice_1;
    $opcodes[STORE_SLICE_2]        = \&store_slice_2;
    $opcodes[STORE_SLICE_3]        = \&store_slice_3;
    $opcodes[DELETE_SLICE_0]       = \&delete_slice_0;
    $opcodes[DELETE_SLICE_1]       = \&delete_slice_1;
    $opcodes[DELETE_SLICE_2]       = \&delete_slice_2;
    $opcodes[DELETE_SLICE_3]       = \&delete_slice_3;
    $opcodes[STORE_SUBSCR]         = \&store_subscr;
    $opcodes[DELETE_SUBSCR]        = \&delete_subscr;
    # We don't do this one
#   $opcodes[PRINT_EXPR]           = \&print_expr;
    $opcodes[PRINT_ITEM] = \&print_item;
    $opcodes[PRINT_ITEM_TO] = \&print_item_to;
    $opcodes[PRINT_NEWLINE] = \&print_newline;
    $opcodes[PRINT_NEWLINE_TO] = \&print_newline_to;
    $opcodes[BREAK_LOOP]   = \&break_loop;
    $opcodes[LOAD_LOCALS]  = \&load_locals;
    $opcodes[RETURN_VALUE] = \&return_value;
    $opcodes[YIELD_VALUE]  = \&yeild_value;
    # Not used in piethon
#    $opcodes[IMPORT_STAR]   = \&import_star;
#    $opcodes[EXEC_STMT]     = \&exec_stmt;
    $opcodes[POP_BLOCK]     = \&pop_block;
    $opcodes[END_FINALLY]   = \&end_finally;
    $opcodes[BUILD_CLASS]   = \&build_class;
    $opcodes[STORE_NAME]    = \&store_name;
    $opcodes[DELETE_NAME]   = \&delete_name;
    $opcodes[UNPACK_SEQUENCE] = \&unpack_sequence;
    $opcodes[DUP_TOPX]      = \&dup_topx;
    $opcodes[STORE_ATTR]    = \&store_attr;
    $opcodes[DELETE_ATTR]   = \&delete_attr;
    $opcodes[STORE_GLOBAL]  = \&store_global;
    $opcodes[DELETE_GLOBAL] = \&delete_global;
    $opcodes[LOAD_CONST]    = \&load_const;
    $opcodes[LOAD_NAME]     = \&load_name;
    $opcodes[BUILD_TUPLE]   = \&build_tuple;
    $opcodes[BUILD_LIST]    = \&build_list;
    $opcodes[BUILD_MAP]     = \&build_map;
    $opcodes[LOAD_ATTR]     = \&load_attr;
    $opcodes[COMPARE_OP]    = \&compare_op;
    $opcodes[IMPORT_NAME]   = \&import_name;
    $opcodes[IMPORT_FROM]   = \&import_from;
    $opcodes[JUMP_FORWARD]  = \&jump_forward;
    $opcodes[JUMP_IF_TRUE]  = \&jump_if_true;
    $opcodes[JUMP_IF_FALSE] = \&jump_if_false;
    $opcodes[JUMP_ABSOLUTE] = \&jump_absolute;
    $opcodes[FOR_ITER]      = \&for_iter;
    $opcodes[LOAD_GLOBAL]   = \&load_global;
    $opcodes[SETUP_LOOP]    = \&setup_loop;
    $opcodes[SETUP_EXCEPT]  = \&setup_except;
    $opcodes[SETUP_FINALLY] = \&setup_finally;
    $opcodes[LOAD_FAST]     = \&load_fast;
    $opcodes[STORE_FAST]    = \&store_fast;
    $opcodes[DELETE_FAST]   = \&delete_fast;
    $opcodes[SET_LINENO]    = \&set_lineno;

    $opcodes[CALL_FUNCTION] = \&call_function;
    $opcodes[MAKE_FUNCTION] = \&make_function;

    return;
}

{
    my $used_pmcs;
    sub new_stackslot {
	$used_pmcs++;
	return "\$P$used_pmcs";
    }
}

sub new_thing {
    my ($filehandle, $stack) = @_;
    my $pmc = new_stackslot();
    print $filehandle "$pmc = new Undef\n";
    unshift @{$stack}, $pmc;
    return $pmc;
}

sub stop_code {
    my ($op, $filehandle, $stack) = @_;
    print $filehandle "end\n";
    return;
}

sub pop_top {
    my ($op, $filehandle, $stack) = @_;
    shift @$stack;
    return;
}

sub rot_two {
    my ($op, $filehandle, $stack) = @_;
    ($stack->[1], $stack->[0]) = ($stack->[0], $stack->[1]);
    return;
}

sub rot_three {
    my ($op, $filehandle, $stack) = @_;
    ($stack->[0], $stack->[1], $stack->[2]) = ($stack->[1], $stack->[2], $stack->[0]);
    return;
}

sub rot_four {
    my ($op, $filehandle, $stack) = @_;
    ($stack->[0], $stack->[1], $stack->[2], $stack->[3]) = 
	($stack->[1], $stack->[2], $stack->[3], $stack->[0]);
    return;
}

sub dup_top {
    my ($op, $filehandle, $stack) = @_;
    my $thing = $stack->[0];
    unshift @$stack, $thing;
    return;
}

sub unary_positive {
    my ($op, $filehandle, $stack) = @_;
    print $filehandle "abs ", $stack->[0], "\n";
    return;
}

sub unary_negative {
    my ($op, $filehandle, $stack) = @_;
    my $thing = $stack->[0];
    print $filehandle "abs $thing\n";
    print $filehandle "$thing = $thing * -1\n";
    return;
}

sub unary_not {
    my ($op, $filehandle, $stack) = @_;
    my $thing = $stack->[0];
    my $newthing = new_stackslot();
    print $filehandle "istrue $\I0, $thing\n";
    print $filehandle "\$I0 = 1 - \$I0\n";
    print $filehandle "$newthing = new Boolean";
    print $filehandle "$newthing = \$I0\n";
    $stack->[0] = $newthing;

    return;
}

sub unary_convert {
    my ($op, $filehandle, $stack) = @_;
    my $thing = $stack->[0];
    my $dest = new_stackslot();
    print $filehandle "\$S0 = $thing\n$dest = new Undef\n$dest = \$S0\n";
    return;
}

sub get_iter {
    my ($op, $filehandle, $stack) = @_;
    my $thing = shift @$stack;
    my $iter = new_stackslot();
    print $filehandle "$iter = iter $thing";
    $stack->[0] = $iter;
    return;
}

sub binary_add {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left + $right\n";
    return;
}

sub binary_power {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left ** $right\n";
    return;
}

sub binary_multiply {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left * $right\n";
    return;
}

sub binary_divide {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left / $right\n";
    return;
}

sub binary_floor_divide {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left // $right\n";
    return;
}

sub binary_modulo {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left % $right\n";
    return;
}

sub binary_subtract {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left - $right\n";
    return;
}

sub binary_subscr {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left\[$right]\n";
    return;
}

sub binary_lshift {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left << $right\n";
    return;
}

sub binary_rshift {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left >> $right\n";
    return;
}

sub binary_and {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left & $right\n";
    return;
}

sub binary_or {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = $left |  $right\n";
    return;
}

sub binary_xor {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = shift @$stack;
    my $dest = new_thing($filehandle, $stack);
    print $filehandle "$dest = xor $left,  $right\n";
    return;
}

sub inplace_add {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left + $right\n";
    return;
}

sub inplace_power {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left ** $right\n";
    return;
}

sub inplace_multiply {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left * $right\n";
    return;
}

sub inplace_divide {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left / $right\n";
    return;
}

sub inplace_floor_divide {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left // $right\n";
    return;
}

sub inplace_modulo {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left % $right\n";
    return;
}

sub inplace_subtract {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left - $right\n";
    return;
}

sub inplace_lshift {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left << $right\n";
    return;
}

sub inplace_rshift {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left >> $right\n";
    return;
}

sub inplace_and {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left & $right\n";
    return;
}

sub inplace_or {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = $left |  $right\n";
    return;
}

sub inplace_xor {
    my ($op, $filehandle, $stack) = @_;
    my $right= shift @$stack;
    my $left = $stack->[0];
    print $filehandle "$left = xor $left,  $right\n";
    return;
}

sub slice_0 {
    my ($op, $filehandle, $stack) = @_;
    my $thing = shift @$stack;
    my $dest = new_stackslot();
    print $filehandle "$dest = slice $thing\[0 .. \]\n";
    return;
}

sub slice_1 {
    my ($op, $filehandle, $stack) = @_;
    my $from = shift @$stack;
    my $thing = shift @$stack;
    my $dest = new_stackslot();
    print $filehandle "$dest = slice $thing\[$from .. \], 1\n";
    return;
}

sub slice_2 {
    my ($op, $filehandle, $stack) = @_;
    my $to = shift @$stack;
    my $thing = shift @$stack;
    my $dest = new_stackslot();
    print $filehandle "$dest = slice $thing\[0 .. $to\], 1\n";
    return;
}

sub slice_3 {
    my ($op, $filehandle, $stack) = @_;
    my $to = shift @$stack;
    my $from = shift @$stack;
    my $thing = shift @$stack;
    my $dest = new_stackslot();
    print $filehandle "$dest = slice $thing\[$from .. $to \], 1\n";
    return;
}

sub store_slice_0 {
    my ($op, $filehandle, $stack) = @_;
    my $thing = shift @$stack;
    my $from = shift @$stack;
    print $filehandle "setslice $thing\[0 .. \], $from, 1\n";
    return;
}

sub store_slice_1 {
    my ($op, $filehandle, $stack) = @_;
    my $low = shift @$stack;
    my $thing = shift @$stack;
    my $from = shift @$stack;
    print $filehandle "setslice $thing\[$low .. \], $from, 1\n";
    return;
}

sub store_slice_2 {
    my ($op, $filehandle, $stack) = @_;
    my $high = shift @$stack;
    my $thing = shift @$stack;
    my $from = shift @$stack;
    print $filehandle "setslice $thing\[0 .. $high\], $from, 1\n";
    return;
}

sub store_slice_3 {
    my ($op, $filehandle, $stack) = @_;
    my $high = shift @$stack;
    my $low = shift @$stack;
    my $thing = shift @$stack;
    my $from = shift @$stack;
    print $filehandle "setslice $thing\[$low .. $high \], $from, 1\n";
    return;
}

sub delete_slice_0 {
    my ($op, $filehandle, $stack) = @_;
    my $thing = shift @$stack;
    print $filehandle "delslice $thing\[0 .. \]\n";
    return;
}

sub delete_slice_1 {
    my ($op, $filehandle, $stack) = @_;
    my $from = shift @$stack;
    my $thing = shift @$stack;
    print $filehandle "delslice $thing\[$from .. \], 1\n";
    return;
}

sub delete_slice_2 {
    my ($op, $filehandle, $stack) = @_;
    my $to = shift @$stack;
    my $thing = shift @$stack;
    print $filehandle "delslice $thing\[0 .. $to\], 1\n";
    return;
}

sub delete_slice_3 {
    my ($op, $filehandle, $stack) = @_;
    my $to = shift @$stack;
    my $from = shift @$stack;
    my $thing = shift @$stack;
    print $filehandle "delslice $thing\[$from .. $to \], 1\n";
    return;
}

sub store_subscr {
    my ($op, $filehandle, $stack) = @_;
    my $subscr = shift @$stack;
    my $thing = shift @$stack;
    my $from = shift @$stack;
    print $filehandle "$thing\[$subscr] = $from\n";
    return;
}

sub delete_subscr {
    my ($op, $filehandle, $stack) = @_;
    my $subscr = shift @$stack;
    my $thing = shift @$stack;
    print $filehandle "delete $thing\[$subscr]\n";
    return;
}

sub print_item {
    my ($op, $filehandle, $stack) = @_;
    my $item = shift @$stack;
    print $filehandle "print_item $item\n";
    return;
}

sub print_item_to {
    my ($op, $filehandle, $stack) = @_;
    my $file = shift @$stack;
    my $item = shift @$stack;
    print $filehandle "print_item $file, $item\n";
    return;
}

sub print_newline {
    my ($op, $filehandle, $stack) = @_;
    print $filehandle "print_newline\n";
    return;
}

sub print_newline_to {
    my ($op, $filehandle, $stack) = @_;
    my $file = shift @$stack;
    print $filehandle "print_newline $file\n";
    return;
}

sub dup_topx {
    my ($op, $filehandle, $stack) = @_;
    my $param = $op->[2];
    my @list;
    @list = map { $stack->[$_] } 1..$param;
    unshift @$stack, @list;
    return;
}

sub load_locals {
    my ($op, $filehandle, $stack) = @_;
    unshift @$stack, 'localvars';
    return;
}

sub return_value {
    my ($op, $filehandle, $stack) = @_;
    print $filehandle ".pcc_begin_return\n";
    print $filehandle ".return ", $stack->[0], "\n";
    print $filehandle ".pcc_end_return\n";
    return;
}

sub pop_block {
    my ($op, $filehanle, $stack, $codeobj, $blockstack) = @_;
    shift @$blockstack;
    return;
}

sub jump_if_false {
    my ($op, $filehandle, $stack) = @_;

    my $dest;
    $op->[0] =~ /to (\d+)/;
    $dest = $1;
    print $filehandle "unless ", $stack->[0], ", offset$dest\n";
    return;
}

sub jump_if_true {
    my ($op, $filehandle, $stack) = @_;

    my $dest;
    $op->[0] =~ /to (\d+)/;
    $dest = $1;
    print $filehandle "unless ", $stack->[0], ", offset$dest\n";
    return;
}

sub jump_forward {
    my ($op, $filehandle, $stack) = @_;

    my $dest;
    $op->[0] =~ /to (\d+)/;
    $dest = $1;
    print $filehandle "branch offset$dest\n";
    return;
}

sub jump_absolute {
    my ($op, $filehandle, $stack) = @_;

    my $dest;
    $dest = $op->[2];
    print $filehandle "branch offset$dest\n";
    return;
}

sub delete_name {
    my ($op, $filehandle, $stack) = @_;
    $op->[0] =~ /\[(.*)\]/;
    my $varname = $1;
    print $filehandle "delete localvars['$varname']\n";
    return;
}

sub store_name {
    my ($op, $filehandle, $stack) = @_;
    $op->[0] =~ /\[(.*)\]/;
    my $varname = $1;
    my $from = shift @$stack;
    print $filehandle "localvars['$varname'] = $from\n";
    return;
}

sub load_fast {
    my ($op, $filehandle, $stack) = @_;
    $op->[0] =~ /\((.*)\)/;
    my $varname = $1;
    my $to = new_stackslot;
    print $filehandle "$to = localvars['$varname']\n";
    unshift @$stack, $to;
    return;
}

sub store_fast {
    my ($op, $filehandle, $stack) = @_;
    $op->[0] =~ /\((.*)\)/;
    my $varname = $1;
    my $from = shift @$stack;
    print $filehandle "localvars['$varname'] = $from\n";
    return;
}

sub delete_fast {
    my ($op, $filehandle, $stack) = @_;
    $op->[0] =~ /\((.*)\)/;
    my $varname = $1;
    print $filehandle "delete localvars['$varname']\n";
    return;
}

sub unpack_sequence {
    my ($op, $filehandle, $stack) = @_;
    my $count = $op->[2];
    my $from = shift @$stack;
    foreach (reverse (0..$count-1)) {
	my $thing = new_stackslot();
	unshift @$stack, $thing;
	print $filehandle "$thing = $from\[$_]\n";
    }
    return;
}    

sub store_global {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    $op->[0] =~ /\[(.*)\]/;
    my $varname = $1;
    my $from = shift @$stack;
    print $filehandle "store_global '$namespace', '$varname', $from\n";
    return;
}

sub delete_global {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    $op->[0] =~ /\[(.*)\]/;
    my $varname = $1;
    print $filehandle "delete_global '$namespace', '$varname'\n";
    return;
}

{
    my $labelcount;

    sub load_name {
        my ($op, $filehandle, $stack, $codeobj) = @_;

        $op->[0] =~ /\[(.*)\]/;
	my $varname = $1;
	$labelcount++;
	my $to = new_stackslot();
	print $filehandle "I16 = exists localvars['$varname']\n";
	print $filehandle "unless I16, ln_checkglobal$labelcount\n";
	print $filehandle "$to = localvars['$varname']\n";
	print $filehandle "branch ln_donewith$labelcount\n";
	print $filehandle "ln_checkglobal$labelcount:\n";
	print $filehandle "$to = find_global '$namespace', '$varname'\n";
	print $filehandle "isnull $to, ln_isnull$labelcount\n";
	print $filehandle "branch ln_donewith$labelcount\n";
	print $filehandle "ln_isnull$labelcount:\n";
	print $filehandle "unless I16, ln_donewith$labelcount\n";
	print $filehandle "$to = find_global '$varname'\n";
	print $filehandle "ln_donewith$labelcount:\n";
	unshift @$stack, $to;
	return;
    }
}

sub build_tuple {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    my $thing = new_stackslot();
    my $count = $op->[2];

    print $filehandle "$thing = new FixedPMCArray\n";
    print $filehandle "$thing = $count\n";
    foreach (reverse(0..$count-1)) {
	my $elem = shift @$stack;
	print $filehandle "$thing\[$_] = $elem\n";
    }
    $stack->[0] = $thing;
    return;
}

sub build_list {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    my $thing = new_stackslot();
    my $count = $op->[2];

    print $filehandle "$thing = new ResizablePMCArray\n";
    print $filehandle "$thing = $count\n";
    foreach (reverse(0..$count-1)) {
	my $elem = shift @$stack;
	print $filehandle "$thing\[$_] = $elem\n";
    }
    $stack->[0] = $thing;
    return;
}

sub build_map {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    my $thing = new_stackslot();
    print $filehandle "$thing = new Hash\n";
    unshift @$stack, $thing;
    return;
}

sub load_attr {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    my $attrib = new_stackslot();
    my $thing = $stack->[0];
    $op->[0] =~ /[(\[](.*?)[)\]]/;
    my $name = $1;
    print $filehandle "$attrib = getprop '$name', $thing\n";
    $stack->[0] = $attrib;
    return;
}

sub compare_op {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    my $compare = $op->[2];
    my $cmpval = new_stackslot();
    my $right = shift @$stack;
    my $left = shift @$stack;
    unshift @$stack, $cmpval;
    print $filehandle "$cmpval = new Boolean\n";
    # <
    if ($compare == 0) {
	print $filehandle "islt \$I0, $left, $right\n";
    }
    # <=
    elsif ($compare == 1) {
	print $filehandle "isle \$I0, $left, $right\n";
    }
    # ==
    elsif ($compare == 2) {
	print $filehandle "iseq \$I0, $left, $right\n";
    }
    # !=
    elsif ($compare == 3) {
	print $filehandle "isne \$I0, $left, $right\n";
    }
    # >
    elsif ($compare == 4) {
	print $filehandle "isgt \$I0, $left, $right\n";
    }
    else {
	die "Can't do $compare yet";
    }
    print $filehandle "$cmpval = \$I0\n";
#    '<', '<=', '==', '!=', '>', '>=', 'in', 'not in', 'is', 'is not', 'exception match', 'BAD')
    
    return;
}

sub store_attr {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    my $obj = shift @$stack;
    my $prop = shift @$stack;

    $op->[0] =~ /[(\[](.*?)[)\]]/;
    my $name = $1;
    print $filehandle "setprop $obj, '$name', $prop\n";

    return;
}

sub delete_attr {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    my $obj = shift @$stack;
    $op->[0] =~ /[(\[](.*?)[)\]]/;
    my $name = $1;
    print $filehandle "delprop $obj, '$name'\n";

    return;
}

sub load_global {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    
    $op->[0] =~ /\[(.*)\]/;
    my $varname = $1;
    my $to = new_stackslot();
    print $filehandle "$to = find_global '$namespace', '$varname'\n";
    unshift @$stack, $to;
    return;
}

sub setup_loop {
    my ($op, $filehandle, $stack, $codeobj, $blockstack) = @_;

    unshift @$blockstack, $op;

    return;
}

sub for_iter {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    
    my $iter = $stack->[0];
    my $dest;
    $op->[0] =~ /to (\d+)/;
    $dest = $1;
    my $thing = new_stackslot();
    print $filehandle "$thing = shift $iter\n";
    print $filehandle "\$I0 = isnull $thing\n";
    print $filehandle "if \$I0 goto $dest\n";
    unshift @$stack, $thing;
    return;
}

sub set_lineno {
    my ($op, $filehandle) = @_;
    my $line = $op->[2];
    print $filehandle "setline $line\n";
    return;
}

sub load_const {
    my ($op, $filehandle, $stack, $codeobj) = @_;

    my $const = $op->[2];
    my $constobj = $codeobj->constants()->[$const];

    # Get back a thing for the constant
    my $codeconstant = find_a_constant($constobj);
    my $constpmc = new_stackslot($filehandle, $stack);
    print $filehandle "$constpmc = co_constants[$codeconstant]\n";
    unshift @$stack, $constpmc;
    return;
}
    
#This is a bit tricky, but luckily it's all statically analyzable
sub call_function {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    my $argcount = $op->[2];
    my $kw = $argcount >> 8;
    my $pa = $argcount & 255;
    
    # No args
    if (!$pa && !$kw) {
	my $thing = build_frame($stack, $codeobj);
	print $filehandle $thing;
    }
    # Positional only
    elsif ($pa && !$kw) {
	my $thing = build_frame_pos($stack, $pa, $codeobj);
	print $filehandle $thing;
    }
    # keyword only
    elsif  (!$pa && $kw) {
	my $thing = build_frame_kw($stack, $kw, $codeobj);
	print $filehandle $thing;
    } 
    # both
    else {
	die "Can't handle positional and keyword args, sorry";
    }

    return;
}

# Right now this doesn't do anything, since it doesn't have to. Code
# objects are full-fledged functions for parrot
sub make_function {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    my $defaults = $op->[2];
    if ($defaults) {
	die "Can't handle default params!";
    }
#    my $codeobj = $stack->[0];
    return;
}

sub template {
    my ($op, $filehandle, $stack, $codeobj) = @_;
    return;
}


sub find_a_constant {
    my $constobject = shift;
    my $stringrep = "$constobject";
    
    return $const_table{$stringrep};
}


# Add a constant to the constant table
{
    my $constcount;

    sub add_a_constant {
       my $constobject = shift;

       my $thing_to_return = undef;

       my $type = ref $constobject;
       $constcount++;
       $const_table{$constobject} = $constcount;
     SWITCH:
       foreach ($type) {
	   /Float/ && do {push @constsetup, "\$P1 = new Float\n\$P1 = ".$$constobject."\nco_constants[$constcount] = \$P1"; 
		          last SWITCH};
	   /Long/ && do {push @constsetup, "\$P1 = new Integer\n\$P1 = ".$$constobject."\nco_constants[$constcount] = \$P1";
		         last SWITCH};
   	   /Undef/ && do {push @constsetup, "\$P1 = new Undef\nco_constants[$constcount] = \$P1"; 
		          last SWITCH};
	   /String/ && do {push @constsetup, "\$P1 = new String\n\$P1 = \"".$$constobject."\"\nco_constants[$constcount] = \$P1";
			   last SWITCH};
	   /Codeobj/ && do {push @constsetup, "\$P1 = find_global '$namespace', '__codeconstant$constcount'\nco_constants[$constcount] = \$P1"; 
		  	    $thing_to_return = [$constobject, 
				 	        "__codeconstant$constcount"]; 
			    last SWITCH };
  	   confess "Can't handle something of type $type";
       }
       return $thing_to_return;    
   }
}

my $bf_counter;
sub build_frame {
    my ($stack, $codeobj) = @_;
    my @code;

    my $names = new_stackslot();
    my $frame = new_stackslot();
    my $temp = new_stackslot();
    my $subobj = $stack->[0];
    my $label = "bf_fillloop".++$bf_counter;
    push @code, "$names = getprop 'localnames', $subobj\n";
    push @code, "\$I0 = elements $names\n";
    push @code, "$frame = new PerlHash\n";
    push @code, "\$I1 = 0\n";
    push @code, "$label:\n";
    push @code, "if \$I0 == \$I1 goto done$label\n";
    push @code, "$temp = new Undef\n";
    push @code, "\$S0 = $names\[\$I1]\n";
    push @code, "$frame\[\$S0] = $temp\n";
    push @code, "inc \$I1\n";
    push @code, "branch $label\n";
    push @code, "done$label:\n";
    push @code, "$temp = $subobj($frame)\n";
    $stack->[0] = $temp;
    
    return join("", @code);
}

sub build_frame_pos {
    my ($stack, $pa, $codeobj) = @_;
    my @code;

    my $names = new_stackslot();
    my $frame = new_stackslot();
    my $temp = new_stackslot();
    my $subobj = $stack->[$pa];
    my $label = "bf_fillloop".++$bf_counter;
    push @code, "$names = getprop 'localnames', $subobj\n";
    push @code, "\$I0 = elements $names\n";
    push @code, "$frame = new PerlHash\n";

    foreach (0..$pa-1) {
	push @code, "\$S0 = $names\[$_]\n";
	my $thing = $stack->[$pa - ($_+1)];
	push @code, "$frame\[\$S0] = $thing\n";
    }
    
    # Now for the rest, empty
    push @code, "\$I1 = $pa\n";
    push @code, "$label:\n";
    push @code, "if \$I0 == \$I1 goto done$label\n";
    push @code, "$temp = new Undef\n";
    push @code, "\$S0 = $names\[\$I1]\n";
    push @code, "$frame\[\$S0] = $temp\n";
    push @code, "inc \$I1\n";
    push @code, "branch $label\n";
    push @code, "done$label:\n";
    push @code, "$temp = $subobj($frame)\n";
    $stack->[0] = $temp;
    
    return join("", @code);
}

sub build_frame_kw {
    my ($stack, $pa, $codeobj) = @_;
    my @code;

    return join(@code);
}