=head1 B<P6C::IMCC>

IMCC.pm is still a "ball of mud" at the moment, but context
propagation has been moved to Context.pm.  Next for refactoring is
symbol handling.

Context should not be propagated during code generation, as the
context propagation pass handles this.  This rule is broken for
hyper-operators, since I can't think of a good way to handle them
using context.

Code is generated by a depth-first recursive traversal of the op tree.
Each node type should define a C<val> function to be called by its
parent node.  This function should gather values from child nodes (by
calling their C<val> functions), then emit the code for the node's
operation (using C<P6C::Compiler::code>).  Code is appended to the
current function in the order in which it is generated, so subnodes
must be evaluated in the proper order.

C<val> should return one of the following:

=over

=item * undef if the node has no rvalue.

=item * a reference to an array of registers if called in tuple
context.

=item * the name of a PMC register holding the rvalue otherwise.

=back

Node types that can act as lvalues should define an C<assign> function
that takes an unevaluated rvalue tree and a context structure.  This
function should return a PMC register or array ref (like C<val>) if
(like an assignment) it serves as both an lvalue and an rvalue.

=head2 External interface

If C<P6C::IMCC> is imported with the ":external" flag, it will define
the following interface, used by the driver:

=over

=item B<init()>

Initialize or reset compiler state.  This should be called before
generating any code.  C<init> destroys all functions and globals,
resets the current function, and reinitializes builtins.

=item B<compile($top)>

Compile a tree based at $top, but do not emit any code.

=item B<emit()>

Emit IMCC code on standard output, including a header that calls
C<main>, and the code for any builtin functions (see
C<P6C::Builtins>).  C<emit> will fail if you have not defined C<main>.

=back

=cut

package P6C::IMCC;
use strict;
use vars '%OPT';
use Carp 'confess';
use P6C::Builtins;
use P6C::Util qw(diag warning unimp error);
use P6C::Context;
use P6C::Addcontext;

require P6C::IMCC::Sub;

# Map Perl types to IMCC parameter types:
my %paramtype = (int => 'int',
		 str => 'string',
		 num => 'float');
# Map Perl types to Parrot register types:
my %regtype   = (int => 'I',
		 str => 'S',
		 num => 'N');
sub regtype(*) {
    $regtype{$_[0]} || 'P';
}

sub paramtype(*) {
    $paramtype{$_[0]} || $_[0];
}

sub import {
    my ($class, $type) = @_;
    return 1 if @_ == 1; # use IMCC ();
    my @syms = qw(globalvar localvar paramvar findvar
		  add_localvar add_globalvar
		  declare_label goto_label emit_label
		  push_scope pop_scope
		  set_topic topic
		  gentmp genlabel newtmp genlocal newlocal mangled_name
		  code fixup_label
		  add_function set_function exists_function_def
		  exists_function_decl
		  gen_counted_loop scalar_in_context do_flatten_array
		  array_in_context tuple_in_context undef_in_context
		  primitive_in_context);
    my @external = qw(init compile emit);
    my $caller = caller;
    no strict 'refs';
    if ($type eq ':all') {
	foreach (@syms) {
	    *{$caller . '::' . $_} = \&$_;
	}
    } elsif ($type eq ':external') {
	foreach (@external) {
	    *{$caller . '::' . $_} = \&$_;
	}
    } else {
	shift;
	foreach (@_) {
	    *{$caller . '::' . $_} = \&$_;
	}
    }
    1;
}

use vars '$curfunc';		# currently compiling function
use vars '%funcs';		# all known functions
use vars '%globals';		# global variables
use vars '%labels';		# named labels
my $lastsym;
my $lasttmp;
my $lastlabel;

sub init {			# reset state
    %funcs = ();
    %globals = ();
    %labels = ();
    undef $curfunc;
    $lastsym = 0;
    $lasttmp = 0;
    $lastlabel = 0;
    P6C::Parser::Reset();
    P6C::Builtins::declare(\%funcs);
}

sub compile {			# compile input (don't emit)
    my $x = shift;
    my $ctx = new P6C::Context type => 'void';
    if (ref $x eq 'ARRAY') {
	# propagate context:
	P6C::Context::block_ctx($x, $ctx);
	# generate code:
	foreach my $stmt (@$x) {
	    $stmt->val;
	}
    } else {
	# probably single stmt.
	$x->ctx_right($ctx);
	$x->val;
    }
}

# P6C::IMCC::emit - emit all code
sub emit {
    die "Must define main" unless $funcs{main};
    print <<'END';
.sub __main @MAIN
	new_pad 0
	call __setup
END

    # XXX: This is hackish. The builtins should really be global multimethods,
    # and closures shouldn't be excluded by name. This'll do until it can be
    # refactored to use imcc lexicals and globals everywhere.

    foreach my $name (keys %funcs) {
	next if $name =~ /closure/;
        my $mangled_name = mangled_name($name);
        my $local_name = $name . "_sub";
        my $lexical_name = "&" . $name;
        print <<END;
	.local Sub $local_name
	newsub $local_name, .Sub, $mangled_name
	store_lex -1, "$lexical_name", $local_name
END
    }
    print <<'END';
        $P0 = new PerlHash
	main_sub($P0)
	pop_pad
	end
.end
END
    P6C::Builtins::add_code(\%funcs);
    while (my ($name, $sub) = each %funcs) {
	unless($sub->{code}) {
	    diag "Function $name has no code.  Builtin?"
		unless P6C::Builtins::is_builtin($name);
	    next;
	}
	$name = mangled_name($name);
        print "\n";
	print ".sub $name prototyped\n";
	$sub->emit;
	print ".end\n";
    }
    &P6C::Builtins::emit;
}

=head2 Internals

If C<P6C::IMCC> is imported with the ":all" flag, it exports an
internal interface.

The compiler maintains a "current function" (could be generalized to
"current scope") in which code is emitted, locals are declared, and
symbol lookups begin.  The following functions manipulate the current
function context.

=over

=item B<code($x)>

Append IMCC code C<$x> to the current function.

=cut

sub code {			# add code to current function
    die "Code must live within a function" unless defined $curfunc;
    my $to_add = join "\n", @_;
    $to_add .= "\n" unless substr($to_add, -1, 1) eq "\n";
    $funcs{$curfunc}->{code} .= $to_add;
}

=item B<add_function($name, [$sub_def])>

Create a new function stub for C<$name>.  If C<$name> exists, it will
be overwritten.  In such cases, a warning will be omitted unless the
{'weak'} flag is set.

=cut

sub add_function($$;@) {
    my ($f, $sub_def, %opts) = @_;
    if (exists $funcs{$f}) {
        # Do not override a non-weak function with a weak one.
        return 1 if ($opts{weak} && ! $funcs{$f}->{weak});

        if ($funcs{$f}->{'autodeclared'}) {
            diag "$f called too early to check prototype";
        } else {
            diag "Redefining function $f"
              unless $funcs{$f}->{'weak'};
        }
    }
    $funcs{$f} = new P6C::IMCC::Sub definition => $sub_def;
    $funcs{$f}->{'weak'} = 1 if $opts{'weak'};

    # NOTE: top-level closure will push a scope.
    return $funcs{$f};
}

=item B<exists_function_def($name)>

Return true if function C<$name> is defined (i.e. not just "declared").

=cut

sub exists_function_def($) {
    my $f = $funcs{+shift};
    return $f && $f->{code};
}

=item B<exists_function_decl($name)>

Return true if a stub exists for C<$name>, even if it has no code.

=cut

sub exists_function_decl($) {
    return $funcs{+shift} ? 1 : 0;
}

=item B<$oldfunc = set_function($name)>

Set the code insertion point to the end of function C<$name>,
returning the name of the previously active function.  Function
C<$name> should exist before this is called.

=cut

sub set_function($) {	       # switch to function, returning old one
    my $func = shift;
    my $ofunc = $curfunc;
    $curfunc = $func;
    return $ofunc;
}

=back

=head2 Name lookup

This is a primitive symbol table.  Which is okay, since Parrot doesn't
have stashes yet.  Hopefully the interface will be useful when things
get more complicated.

=over

=item B<$name = globalvar($var)>

Lookup a global variable.

=cut

sub globalvar($) {
    my $name = shift;
    if (!exists $globals{$name}) {
 	if ($OPT{strict}) {
	    warning "Reference to global $name";
 	}
	add_globalvar($name);
    }
    return 'global "'.mangled_name($name).'"';
}

=item B<add_globalvar($var [, $type])>

Declare global variable C<$var>.  Warns if C<$var> is already defined.
C<$var> will be initialized to a new PMC of type C<$type> (or
C<PerlUndef> if type is not given) before C<main> is called.

=cut

sub add_globalvar($;$) {
    my $name = shift;
    if (exists $globals{$name}) {
	warning "Re-adding global $name";
    }
    $globals{$name} = shift || 'PerlUndef';
    return 'global "'.mangled_name($name).'"';
}

=item B<$name = localvar($var)>

Find local variable C<$var>, returning its IMCC name.

=cut

sub localvar($) {
    my $var = shift;

    die "Local variable outside function" unless defined $curfunc;
    return $funcs{$curfunc}->localvar($var);
}

=item B<add_localvar($var, $type)>

Declare local variable C<$var> of type C<$type>.  Warns if C<$var> is
already defined.  If C<$type> is a PMC type, C<$var> will
automatically be initialized.

=cut

sub add_localvar {
    return $funcs{$curfunc}->add_localvar(@_, 1);
}

=item B<$name = paramvar($var)>

Find parameter C<$var>.

=cut

sub paramvar($) {
    my $var = shift;
    return mangled_name($var) if $funcs{$curfunc}->paramvar($var);
}

=item B<$name = findvar($var)>

=item B<($name, $isglobal) = findvar($var)>

Find variable C<$var>, a C<P6C::variable>, returning a PMC register
containing its value.  Currently C<findvar> looks at the active
function's parameters, then locals, then globals (which don't exist,
so it won't find anything there).  Returns undef if the variable is
not found.  C<$isglobal> is currently unused.

=cut

sub findvar($) {
    my ($var) = @_;
    my $name;
    my $isglobal;
    if ($name = paramvar($var) || localvar($var)) {
	$isglobal = 0;
    } else {
	$name = globalvar($var);
	$isglobal = 1;
    }
    return wantarray ? ($name, $isglobal) : $name;
}

=item B<push_scope()>

Push a scope within the current function.

=cut

sub push_scope {
    confess $curfunc unless $curfunc && $funcs{$curfunc};
    $funcs{$curfunc}->push_scope;
}

=item B<pop_scope()>

Pop a scope from the current function.

=cut

sub pop_scope {
    $funcs{$curfunc}->pop_scope;
}

=item B<mangled_name($thing)>

Mangle any kind of variable, function, or operator name.

Convert names like $foo to _SV_foo. If the name is prefixed with an
equals sign, then just pass the rest of the string through untouched
(so the mangled form of "=$#@!!" is "$#@!!".

=back

=cut

sub mangled_name($) {
    my $name = shift;
    return substr($name, 1) if $name =~ /^=/; # Passthru char
    my %mangle = (qw(! _BANG_
		     ^ IMPL_
		     $ SV_
		     @ AV_
		     % HV_
		     & CV_));
    $name =~ s/([\!\$\@\%\&\^])/$mangle{$1}/eg;
    return '_'.$name;
}

=head2 B<Labels>

Note that the "labels" here aren't necessarily simple addresses in the
code; while this may sometimes be the case, creating some labels may
involve taking a continuation, and jumping to labels may involve
throwing an exception and unwinding the call stack.

XXX: Labels and try/CATCH currently use different mechanisms, contrary
to Apocalypse 4.  Exceptions are implemented with continuations, and
are therefore much more expensive than labels, which use simple jumps.
Eventually, either continuations will have to become much
lighter-weight, or the compiler will have to determine when a jump is
sufficient, and when a continuation or exception is required.  This
implementation means that you can't mix gotos and exceptions without
Bad Things happening.

The C<name> argument is a label name, and may be undefined for typed
loop labels (e.g. "next").  The C<type> argument should be one of the
following:

=over

=item B<next>

=item B<redo>

=item B<last>

=item B<break>

=item B<continue>

=item B<skip>

=item B<return>

=back

Label handling functions:

=over

=item B<declare_label(name => $name, type => $type)>

Declare a label in the current scope.  Either C<name> or C<type> may
be omitted.

=cut

sub declare_label {
    return $funcs{$curfunc}->add_label(@_);
}

=item B<emit_label(name => $name, type => $type)>

Emit code for a label in the current scope.  Either C<name> or C<type>
may be omitted.

=cut

sub emit_label {
    die "Label outside function" unless defined $curfunc;
    my $name = $funcs{$curfunc}->label(@_);
    code(<<END);
$name:
END
}

=item B<goto_label(name => $name, type => $type)>

Branch to the appropriate version of a label.  Either C<name> or
C<type> may be omitted.

=cut

sub goto_label {
    die "Label outside function" unless defined $curfunc;
    my $name = $funcs{$curfunc}->label(@_);
    error "Undefined label (@_)" unless $name;
    code(<<END);
	goto $name
END
    return undef;
}

=item B<fixup_label(from,to)>

Do something intensely interesting that is extremely important for
you to understand.

=cut

sub fixup_label {
    my ($from, $to) = @_;
    die "Code must live within a function" unless defined $curfunc;
    $funcs{$curfunc}->{code} =~ s/\b$from\b/$to/g;
}

=back

=head2 B<Topic>

=over

=item B<set_topic($x)>

Sets the topic to C<$x> until the next call to C<set_topic>, or until
the end of the current scope, whichever is first.  Note that C<$x> is
a B<variable>, not a value.

=cut

sub set_topic {
    $funcs{$curfunc}->set_topic(@_);
}

=item B<topic()>

Get the current topic variable.

=cut

sub topic {
    my $t = $funcs{$curfunc}->topic;
    error "No topic in $curfunc" unless $t;
    return $t;
}

=back

=head2 Temporary names

=over

=item B<gensym([$str])>

Generate a unique identifier.  If C<$str> is given, include it as part
of the identifier.

=cut

sub gensym(;*) {
    'S'.$_[0] . ++$lastsym
}

sub _gentmp(*) {		# uninitialized temporary (internal)
    '$' . $_[0] . ++$lasttmp
}

=item B<gentmp([$type])>

Generate an uninitialized temporary register.

=cut

sub gentmp(;*) {			# uninitialized temporary
    my $t = $_[0] || 'PerlUndef';
    _gentmp(regtype($t));
}

=item B<genlocal($type,$name)>

Generate an uninitialized local variable with the given type and name.

=cut

sub genlocal ($$) {
    my ($type, $name) = @_;
    code(".local ".paramtype($type)." $name");
    return $name;
}

=item B<genlabel([$str])>

Generate a unique label containing C<$str>.

=cut

sub genlabel(;$) {		# new label (optionally annotated)
    my $n = shift;
    $n = '' unless defined $n;
    'L_'.$n. ++$lastlabel
}

=item B<newtmp([$type,[$comment]])>

Create a new temporary register to hold a value of type C<$type>,
which should be "int", "num", "str", or some PMC type.  If C<$type> is
a PMC type, the register will be initialized with a new value.  If
C<$type> is omitted, it default to C<PerlUndef>.

=cut

sub newtmp(;*$) {			# initialized temporary
    my $type = shift || 'PerlUndef';
    my $comment = shift || "";
    $comment = " $comment" if length $comment > 0;
    my $reg = regtype $type;
    my $name;
    if ($reg eq 'S') {
  	$name = _gentmp S;
	code(<<END);
	$name = ""$comment
END
    } elsif ($reg eq 'I' || $reg eq 'N') {
 	$name = _gentmp $reg;
	code(<<END);
	$name = 0$comment
END
    } else {
	$name = _gentmp P;
	code(<<END);
	$name = new $type$comment
END
    }
    return $name;
}

=item B<newlocal([$type])>

Generate a new local variable initialized with the default value for
its type.

=cut

sub newlocal($$) {			# initialized local var
    my ($type, $name) = @_;
    my $reg = regtype $type;
    code(".local ".paramtype($type)." $name");
    if ($reg eq 'S') {
	code(qq[\t$name = ""]);
    } elsif ($reg eq 'I' || $reg eq 'N') {
	code("\t$name = 0");
    } else {
	code("\t$name = new $type");
    }
    return $name;
}

=back

=head2 Code generation functions

The following functions generate useful and common pieces of code.

=over

=item B<gen_counted_loop($counter, $body)>

Generate a counted loop using C<$counter> as the repetition count.
The loop will iterate over values between 0 and $counter - 1,
inclusive.  C<$counter> will be used as the iteration variable, so it
can be used in indexing expressions in the loop body.

=cut

sub gen_counted_loop {
    my ($count, $body, $what) = @_;
    my $start = genlabel;
    my $end = genlabel;
    my $top_comment = "";
    my $bottom_comment = "";
    if ($what) {
        $top_comment = "# loop top ($what)\n";
        $bottom_comment = "# loop bottom ($what)\n";
    }
    return $top_comment . <<END . $bottom_comment;
	goto $end
$start:
	dec $count
$body
$end:
	if $count != 0 goto $start
END
}

=item B<scalar_in_context($val, $ctx)>

Emit the code to return a scalar C<$val> in the right way for context
C<$ctx>. In array context, that means create a single-element array
containing the scalar.

=cut

sub scalar_in_context {
    my ($x, $ctx) = @_;
    if ($ctx->type eq 'void') {
#	return undef;
	return $x; # XXX:
    } elsif ($ctx->is_array) {
	my $a = newtmp 'PerlArray';
	my $id = "scalar_in_context(array) from ".((caller 1)[3]);
	code(<<END);
# $id START
	$a = 1
	$a\[0] = $x
# $id END
END
	return $a;
    } elsif ($ctx->is_tuple) {
	if ($ctx->flatten && @{$ctx->type} == 1) {
	    my $ptmp = newtmp 'PerlArray';
	    code(<<END);
	$ptmp\[0] = $x
END
	    return [$ptmp];
	} else {
	    return [$x];
 	}
    } else {
	return $x;
    }
}

=item B<primitive_in_context($val, $primitive_type, $ctx)>

=cut

sub primitive_in_context {
    my ($x, $type, $ctx) = @_;
    if ($type eq $ctx->type) {
	return $x;
    } else {
	my $tmp = newtmp 'PerlUndef';
	my $id = 'primitive_in_context from '.((caller 1)[3]);
	code("\t$tmp = $x # $id");
	return scalar_in_context($tmp, $ctx);
    }
}

=item B<array_in_context($val, $ctx)>

Convert an array to the appropriate type for the given context. In
tuple context, pull out as many values as needed from the array. In
scalar context, return the length of the array.

=cut

sub array_in_context {
    my ($x, $ctx) = @_;
    if (!$ctx->type || $ctx->is_array) {
	return $x;
    } elsif ($ctx->type eq 'void') {
#	return undef;
	return $x;		# XXX:
    } elsif ($ctx->is_tuple) {
	my $len = gentmp 'int';
	my $end = genlabel;
	my @tuple = map { gentmp 'pmc' } 1..@{$ctx->type};
	my $max = $#tuple - ($ctx->flatten ? 1 : 0);
	code(<<END);
	$len = $x
END
	for my $i (0..$max) {
	    code(<<END);
	if $i == $len goto $end
	$tuple[$i] = $x\[$i]
END
	}
	if ($ctx->flatten) {
	    my $j = gentmp 'int';
	    my $k = gentmp 'int';
	    my $endcp = genlabel;
	    my $cploop = genlabel;
	    my $ptmp = gentmp 'pmc';
	    code(<<END);
	$tuple[$max] = new PerlArray
	$j = $max
	$k = 0
	goto $endcp
$cploop:
	$ptmp = $x\[$j]
	$tuple[$max]\[$k] = $ptmp
	inc $j
	inc $k
$endcp:
	if $j < $len goto $cploop
END
	}
	code(<<END);
$end:
END
	return \@tuple;
    } elsif ($ctx->is_scalar) {
	my $itmp = gentmp 'int';
	code(<<END);
	$itmp = $x
END
	return primitive_in_context($itmp, 'int', $ctx);
    } else {
	unimp "Return type ".$ctx->type;
    }
}

=item B<tuple_in_context(\@vals, $ctx)>

Convert a tuple to the appropriate type for the given context. In
tuple context, pad with PerlUndefs or truncate the array. In array
context, construct an array out of all of the values in the tuple. In
scalar context, return the first element in the tuple.

=cut

sub tuple_in_context {
    my ($x, $ctx) = @_;
    if ($ctx->type eq 'void') {
	return undef;
    } elsif ($ctx->is_tuple) {
	# Make sure we return enough items (XXX: is this necessary?)
	if ($ctx->flatten) {
	    die;
	} elsif (@$x <= @{$ctx->type}) {
	    return @{$x}[0..$#{$ctx->type}];
	} else {
	    my @ret = @$x;
	    for my $i (@ret .. @{$ctx->type} - 1) {
		push @ret, newtmp 'PerlUndef';
	    }
	    return [@ret];
	}
    } elsif ($ctx->is_array) {
	# XXX: do we need to flatten each element in flattening context?
	my $res = newtmp 'PerlArray';
	my $n = @$x;
	my $ptmp = gentmp 'pmc';
	code(<<END);
	$res = $n
END
	for my $i (0 .. $n - 1) {
	    code(<<END);
	$res\[$i] = $x->[$i]
END
	}
	return $res;
    } elsif ($ctx->is_scalar) {
	if (@$x == 0) {
	    return newtmp 'PerlUndef';
	} else {
	    my $ret = gentmp 'PerlUndef';
	    code(<<END);
	$ret = $x->[0]
END
	    return $ret;
	}
    } else {
	unimp "Return type ".$ctx->type;
    }
}

=item B<undef_in_context($ctx)>

Convert an undefined value to the appropriate type for the given
context. For example, an undefined value is an empty PerlArray. For
most types, it is a PerlUndef object.

=cut

sub undef_in_context {
    my $ctx = shift;
    if (!defined($ctx) || $ctx->type eq 'void') {
	return undef;
    } elsif ($ctx->is_tuple) {
	return [];
    } elsif ($ctx->is_array) {
	return newtmp 'PerlArray';
    } elsif ($ctx->is_scalar) {
	return newtmp 'PerlUndef';
    } else {
	unimp "Return type ".$ctx->type;
    }
}

=item B<do_flatten_array($vals)>

Emit code to evaluate each item in C<@$vals>, which are assumed to be
in list context.  The results are concatenated into a single array,
whose name is returned.

=cut

sub do_flatten_array {
    my ($vals, $off) = @_;
    $off ||= 0;
    $vals = [ @$vals[$off..$#$vals] ];

    # Optimization (for readability more than speed): if each of the
    # values is known to be a single scalar value, then the code to
    # generate the list can be much simpler.
    my $dynamic = 0;
    if (grep { ! $_->can("min_listlen") || $_->min_listlen != 1 } @$vals) {
        $dynamic = 1; # darn
    }
    if (! $dynamic && grep { ! $_->can("max_listlen") } @$vals) {
        $dynamic = 1; # darn
    }
    if (! $dynamic && grep { my $max = $_->max_listlen; ! defined $max || $max != 1 } @$vals) {
        $dynamic = 1; # darn
    }

    my $tmp = newtmp 'PerlArray';
    my $len = gentmp 'int';
    my $offset = $dynamic ? gentmp('int') : 0;
    my $ptmp = gentmp 'PerlUndef';
    code("# START array flattening.");
    code("\t$offset = 0") if $dynamic;
    foreach my $val (@$vals) {
	if ($val->isa('P6C::sv_literal')) {
	    my $itemval = $val->lval;
            code("\t$tmp\[$offset] = $itemval");
            code("\tinc $offset") if $dynamic;
	} else {
            $val->{ctx}->type('PerlUndef') if ! $dynamic;
	    my $item = $val->val;
            if ($dynamic) {
                do_append_array($tmp, $item);
                code("\t$len = $item");
                code("\t$offset = $offset + $len");
            } else {
                code("\t$tmp\[$offset] = $item");
            }
        }
        ++$offset if ! $dynamic;
    }
    code("# END array flattening\n");
    return $tmp;
}

=item B<do_append_array($dest, $src)>

Append one array to another. I would vastly prefer having an 'append'
opcode, but that can wait.

=cut

sub do_append_array {
    my ($dest, $src) = @_;
    my $len = gentmp 'int';
    my $tmp = newtmp 'PerlUndef';
    my $i = gentmp 'int';
    my $looptop = genlabel 'append_loop_top';
    my $loopend = genlabel 'append_loop_end';
    my $est = substr($dest, 1);
    my $rc = substr($src, 1);
    code(<<"END");
# append $src to the end of $dest ('push \@$est, *\@$rc')
	$i = 0
        $len = $src
$looptop:
        if $i >= $len goto $loopend
        $tmp = $src\[$i]
        push $dest, $tmp
        inc $i
        goto $looptop
$loopend:
END
}

=back

=cut

######################################################################
# Node-type code generation functions

##############################
package P6C::Register;

sub val {
    shift->reg;
}

##############################
package P6C::ValueList;
use Data::Dumper;
use P6C::IMCC ':all';
use P6C::Util ':all';

# XXX: ValueList::val returns an array-ref in tuple context.  This is
# inconsistent with other C<val> functions, which all return single
# values.  However, if you're creating a tuple context, you should
# know what to expect.

sub val {
    my $x = shift;
    my $ctx = $x->{ctx};

    if ($ctx->is_tuple) {
	# In N-tuple context, the list's value is its first N elements.
	my @ret;
	my $min = $ctx->nelem - ($ctx->flatten ? 1 : 0);
	$min = @{$x->vals} if @{$x->vals} < $ctx->nelem;

	for my $i (0..$min - 1) {
	    $ret[$i] = $x->vals($i)->val;
	}
	if ($ctx->flatten) {
	    # XXX: flatten has to come first.
	    # In flattening context, we have to build a new array out of
	    # the values.  All the values should have been evaluated in
	    # array context, so they will all be PerlArrays.
	    push @ret, do_flatten_array($x->vals, $min);
	} else {
	    for my $i ($min .. $#{$x->vals}) {
		$x->vals($i)->val;
	    }
	}
	return \@ret;

    } elsif ($ctx->is_array) {
	# In array context, the list's value is an array of all its
	# elements.
	code(<<END);
# ValueList in array context
END
	return do_flatten_array($x->vals, 0);
    } elsif ($ctx->is_sig) {
        my $type = $ctx->type;
	# FIXME: In signature context, for now we'll do something very
	# similar to tuple context. This has many gaps, but hopefully
	# we'll cover an interesting subset of cases.
	my @ret;
        my $i = 0;

        # Fill in all of the required positional args
        foreach (@{ $type->positional }) {
            if (! $x->vals($i)) {
                # Should be runtime exception
                die "not enough args: need " . @{ $type->positional } .
                  ", have " . @{$x->vals};
            }
            push @ret, $x->vals($i++)->val;
        }

        # Fill in as many optional args as we have
        foreach (@{ $type->optional }) {
            last if ! $x->vals($i);
            push @ret, $x->vals($i++)->val;
        }

        return \@ret if ! $x->vals($i);

        # The rest go into the slurpy array.
        if (! $type->slurpy_array) {
            die "too many args: got " . @{$x->vals} . ", max is " .
              (@{ $type->positional } + @{ $type->optional });
        }

        # Heh. I highly doubt this is correct. I don't see how it
        # flattens the list-returning pieces while still handling the
        # scalars correctly.
        push(@ret, $x->vals($i++)->val) while ($x->vals($i));
#        warn "Probable bug: gobbling slurpy array" unless $::boingie++;

        return \@ret;
    } elsif ($ctx->is_scalar || $ctx->type eq 'void') {
	# The value of a list in scalar context is its last value, but
	# we need to evaluate intermediate expressions for possible
	# side-effects.
	for (@{$x->vals}[0..$#{$x->vals} - 1]) {
	    $_->val;
	}
	return $x->vals($#{$x->vals})->val;

    } else {
	unimp "Can't handle context ".Dumper($ctx);
    }
}

##############################
package P6C::Binop;
use Carp 'cluck';
use P6C::IMCC::Binop ':all';
use P6C::IMCC::hype 'do_hyped';
use P6C::IMCC ':all';
use P6C::Util ':all';
use P6C::Context;


# '=' assignment op.
sub do_assign {
    my $x = shift;
    return $x->l->assign($x->r);
}

# ':=' binding op. This actually requires *much* deeper language
# support than is implemented here. This is just a cheap hack to avoid
# unnecessary 'clone' calls. (TODO)
sub do_bind {
    my $x = shift;
    return $x->l->bind($x->r);
}

# Handle a comma operator sequence.  Just flattens and calls off to
# C<P6C::ValueList>.
sub do_array {
    my $x = shift;
    cluck "Should provide context to comma operator" unless $x->{ctx};
    my @things = flatten_leftop($x, ',');
    my $vallist = P6C::ValueList->new(vals => \@things);
    $vallist->{ctx} = $x->{ctx};
    return $vallist->val;
}

sub do_reverse_match {
    $_[0]->{ctx}->type('bool');
    my $v = do_smartmatch($_[0]->l, $_[0]->r, $_[0]->{ctx});
    code(<<END);
	$v = ! $v
END
    return $v;
}

# Binary infix operators.
use vars '%ops';
BEGIN {
%ops =
(
 '+'	=> \&simple_binary,
 '-'	=> \&simple_binary,
 '*'	=> \&simple_binary,
 '/'	=> \&simple_binary,
 '%'	=> \&simple_binary,
 '**'	=> \&do_pow,

 '>>'	=> \&simple_binary,
 '<<'	=> \&simple_binary,
 '+&'	=> \&simple_binary,
 '~&'	=> \&simple_binary_pasm,
 '+|'	=> \&simple_binary,
 '~|'	=> \&simple_binary_pasm,
 '+^'	=> \&simple_binary,
 '~^'	=> \&simple_binary_pasm,

 ':='   => \&do_bind,

 '~'	=> \&do_concat,
 '='	=> \&do_assign,
 '||'	=> \&do_logor,
 '&&'	=> \&do_logand,
 '^^'	=> \&simple_binary,
 '//'	=> \&do_defined,
 ','	=> \&do_array,
 'x'	=> \&do_repeat,
 '..'	=> \&do_range,
 '=~'	=> sub { do_smartmatch($_[0]->l, $_[0]->r, $_[0]->{ctx}) },
 '!~'   => \&do_reverse_match,
);
}

use vars '%op_is_array';
BEGIN {
    my @arrayops = qw(= .. x // ^^ && || ~);
    push(@arrayops, ',');
    @op_is_array{@arrayops} = (1) x @arrayops;
}

sub val {
    my $x = shift;

    if (ref($x->op) eq 'P6C::hype') {
	check_assign_op($x->op->op);
	return do_hyped($x->op->op, $x->l, $x->r);
    }

    my $ret;
    my $op = $x->op;
    if ($ops{$op}) {
	$ret = $ops{$op}->($x);
    } else {
	check_assign_op($op);
	unimp "Unimplemented operator $op";
    }

    if (!$op_is_array{$op}) {
	return scalar_in_context($ret, $x->{ctx});
    }
    return $ret;
}

sub check_assign_op {
    my $op = shift;
    if($op =~ /^([^=]+)=$/ && $ops{$1}) {
        # XXX: This should probably be checked at an earler stage.
        die "Internal error -- assignment op `$op' snuck into IMCC.pm";
    }
    return 1;
}

######################################################################
package P6C::incr;
use P6C::IMCC ':all';
use P6C::Util 'is_scalar';

use vars '%inplace_op';
use vars '%outaplace_op';

BEGIN {
%inplace_op = ('++' => 'inc', '--' => 'dec');
%outaplace_op = ('++' => '+ 1', '--' => '- 1');
}

sub val {
    my $x = shift;
    my $ret;

    # XXX: I'm extra-cautious here because we may be incrementing a
    # temporary, in which case we have to copy it back.  If this can
    # never happen, then the assigns can be removed here.

    # Optimize post-increment in void context to a pre-increment.
    if ($x->post && !($x->{ctx}->type eq 'void')) {
	my $op = $outaplace_op{$x->op}
	    or die $x->op().' increment not understood';
	if ($x->thing->isa('P6C::variable') && is_scalar($x->thing->type)) {
	    my $val = $x->thing->val;
	    $ret = gentmp 'PerlUndef';
	    code(<<END);
	$ret = clone $val
	$val = $val $op
END
	} else {
	    my $val = $x->thing->val;
	    $ret = newtmp 'PerlUndef';
	    my $tmp2 = newtmp 'PerlUndef';
	    code(<<END);
	$ret = $val
	$tmp2 = $ret $op
END
	    $x->thing->assign(new P6C::Register reg => $tmp2,
			      type => 'PerlUndef');
	}
    } else {
	my $op = $inplace_op{$x->op}
	    or die $x->op().' increment not understood';
	my $tmp = $x->thing->val;

	if ($x->thing->isa('P6C::variable') && is_scalar($x->thing->type)) {
	    $ret = $tmp;
	    code(<<END);
	$ret = clone $ret
	$op $ret
END
	} else {
	    $op = $outaplace_op{$x->op};
	    $ret = newtmp 'PerlUndef';
	    code(<<END);
	$ret = $tmp $op
END
	    # Complex expression => can't just do increment.
	    my $desttype = $x->thing->can('type') ?
		$x->thing->type : 'PerlUndef';
	    $x->thing->assign(new P6C::Register reg => $ret,
			      type => $desttype);
	}
    }
    return scalar_in_context($ret, $x->{ctx});
}

######################################################################
package P6C::ternary;
use P6C::IMCC ':all';

# Ternary operator as an r-value.  Context-aware.
sub val {
    my $x = shift;
    my $tmp = newtmp 'PerlUndef';
    my ($thenlab, $endlab) = (genlabel("ternary_then"),
			      genlabel("ternary_end"));
    code(<<END);
# START TERNARY
END
    my $ifval = $x->if->val;
    code(<<END);
	if $ifval goto $thenlab
END
    my $elseval = $x->else->val;
    code(<<END);
	$tmp = $elseval
	goto $endlab
$thenlab:
END
    my $thenval = $x->then->val;
    code(<<END);
	$tmp = $thenval
$endlab:
# END TERNARY
END
    return $tmp;
}

# Ternary operator as an l-value.  Ignores incoming context.  However,
# the r-value to be assigned will be evaluated in the proper context
# for each branch.

# REMEMBER: since the two branches may have different contexts, they
# have different op-trees.

# REMEMBER: we haven't always been able to propagate context, so we
# fall back to just using the same op-tree for both sides.
sub assign {
    my ($x, $thing) = @_;
    my $tmp = newtmp 'PerlUndef';
    my ($thenlab, $endlab) = (genlabel("ternary_then"),
			      genlabel("ternary_end"));
    code(<<END);
# START TERNARY
END
    my $ifval = $x->if->val;
    code(<<END);
	if $ifval goto $thenlab
END
    my $elseval = $x->else->assign($x->{else_right} || $thing);
    code(<<END);
	$tmp = $elseval
	goto $endlab
$thenlab:
END
    my $thenval = $x->then->assign($x->{then_right} || $thing);
    code(<<END);
	$tmp = $thenval
$endlab:
# END TERNARY
END
    return $tmp;
}

######################################################################
package P6C::sv_literal;
use P6C::Util ':all';
use P6C::IMCC ':all';

sub val {

    my $x = shift;
    return undef if $x->{ctx}->type && $x->{ctx}->type eq 'void';
    my $type = $x->type;

    # XXX: these are actually _references_.  But we don't support them
    # anyways.
    unimp "Don't support ".$type if $type =~ /Perl(Hash|Array)/;
    return primitive_in_context($x->lval, $type, $x->{ctx});
}

######################################################################
# Prefix operators (see P6C/IMCC/prefix.pm)
package P6C::prefix;
use P6C::IMCC ':all';
use P6C::IMCC::prefix qw(%prefix_ops gen_sub_call);
use P6C::Util 'unimp';

sub val {
    my $x = shift;

    if (!defined $x->name) {
	# This operation has been squashed, e.g. we're creating a
	# catch block.  Do nothing.
    } elsif (exists_function_decl($x->name)) {
	return gen_sub_call($x->name, $x->args, $x->{ctx}, @_);
    } elsif (exists $P6C::IMCC::prefix::prefix_ops{$x->name}) {
	return $P6C::IMCC::prefix::prefix_ops{$x->name}->($x, @_);
    } else {
	return gen_sub_call($x->name, $x->args, $x->{ctx}, @_);
    }
}

######################################################################
# Guards
package P6C::guard;
use P6C::IMCC ':all';
use P6C::Util 'unimp';
use P6C::IMCC::guard qw(guard_if guard_while);

use vars '%guards';

%guards =
(
 'if' => \&guard_if,
 'unless' => \&guard_if,
 'while' => \&guard_while,
 'until' => \&guard_while,
);

sub val {
    my $x = shift;
    # XXX: temporary hack.
    if (exists $guards{$x->name}) {
	return $guards{$x->name}->($x);
    } else {
	unimp "Guard ".$x->name();
    }
}

######################################################################
# Chained comparisons
package P6C::compare;
use P6C::IMCC ':all';
use P6C::Util 'diag';

# XXX: since IMCC doesn't give us access to cmp, cmp_num, and
# cmp_string separately, we need to go through num and str temporaries
# to get the right kind of comparison.
#
# FIXME: The above is no longer correct.

use vars '%type';
BEGIN {
    $type{$_} = 'num' for qw(<= == >= < > !=);
    $type{$_} = 'str' for qw(eq ne ge le lt gt);
}

# remap operator names.
use vars '%imccop';
BEGIN {
    @imccop{qw(<= == >= < > !=)} = qw(<= == >= < > !=);
    @imccop{qw(le eq ge lt gt ne)} = qw(<= == >= < > !=);
}

# Generate one element of a comparison.  Unlike other places, $l and
# $r are already evaluated here (i.e. they may be recycled
# temporaries).  $fail is a label (defined elsewhere) to be branched
# to if the comparison fails.
sub gen_compare {
    my ($op, $l, $r, $fail) = @_;
    my $label = genlabel;
    $op = $imccop{$op};
    code(<<END);
	if $l $op $r goto $label
	goto $fail
$label:
END
}
use vars '%ops';
BEGIN {
    for my $op (qw(<= == >= < > != le eq ge lt gt ne)) {
	$ops{$op} = \&gen_compare;
    }
}

# Evaluate a comparison sequence from left to right.  If any
# comparison fails, it will branch to the end of the sequence.  Since
# only two values are active at once, we only need two PMC
# temporaries.  For each operator, look up the operator type, and put
# the operand values in appropriate N or S temporaries.  As an
# optimization, the type of the previous comparison is kept around,
# and the PMC value of the left operand is not re-fetched if it was
# used as a right operand for the same type of operator.

# NOTE: the typing we do here duplicates what's done during the
# context pass.  Eventually these should be combined.
sub val {
    my $self = shift;
    die "Nothing to compare" if $self->size == 0;
    my $x = $self->seq;
    my $result = gentmp 'int';
    my %tmps;
    my $res = newtmp;
    my $lasttype = '';
    my $fail = genlabel 'comparison';
    code("\t$result = 0\n");
    $tmps{0} = $x->[0]->val;
    for (my $i = 1; $i < $#{$x}; $i += 2) {
	my $op = $x->[$i];
	my $type = $type{$op} or die "No such op: $op";
	unless ($tmps{"$type 0"}) {
	    # Initialize temporaries for this type if we haven't already.
	    $tmps{"$type 0"} = gentmp $type;
	    $tmps{"$type 2"} = gentmp $type;
	}

	# Only recompute expression values if necessary
	my $ltmp = $tmps{$type.' '.(($i - 1) % 4)};
	my $rtmp = $tmps{$type.' '.(($i + 1) % 4)};
	if ($lasttype ne $type) {
	    code(<<END);
	$ltmp = $tmps{($i - 1) % 4}
END
	}
	$lasttype = $type;	# store type of right operand
	$tmps{(($i + 1) % 4)} = $x->[$i + 1]->val;
	code(<<END);
	$rtmp = $tmps{(($i + 1) % 4)}
END
	$ops{$op}->($op, $ltmp, $rtmp, $fail);
    }
    code(<<END);
	$result = 1
$fail:
	$res = $result
END
    return scalar_in_context($res, $self->{ctx});
}

######################################################################
sub P6C::sub_def::val {
    my $x = shift;

    if (exists_function_def($x)) {
	diag "Redefining function ".$x->name;
    }
    add_function($x->name, $x);
    my $ofunc = set_function($x->name);
    $x->closure->val;
    set_function($ofunc);
    return undef;
}

######################################################################
package P6C::closure;
use P6C::Util qw(unimp map_preorder);
use P6C::IMCC::prefix 'wrap_with_catch';
use P6C::IMCC ':all';

# A sub with no explicit parameter list gets (*@_).

sub default_signature {
    return $P6C::IMCC::DEFAULT_SIGNATURE ||=
      (P6C::Parser::parse_sig('*@_, *%_'))[0];
}

# Closure parameters might be explicitly specified, or gathered
# implicitly from curried variables, or perhaps grafted on from the
# extra rule params.
sub get_params {
    my ($x) = @_;

    my @params;
    my $add_on_slurpy_array;
    if (defined($x->params)) {
	if (UNIVERSAL::isa($x->params, 'P6C::signature')) {
            return $x->params;
        }

        # Explicit parameter list in "-> $foo, $bar { ... }"
        foreach (P6C::Util::flatten_leftop($x->params, ';')) {
            push @params, P6C::Util::flatten_leftop($_, ',');
        }
    } else {
	my %implicit;
	# Look for implicit param-vars like $^a:
	map_preorder {
	    if (UNIVERSAL::isa($_, 'P6C::variable')
		&& $_->implicit) {
		$implicit{$_->name} = $_;
	    }
	} $x->block;
	if (keys %implicit) {
	    @params = sort { $a->name cmp $b->name } values %implicit;
	}
        $add_on_slurpy_array = 1;
    }

    # Rules have a set of undeclared parameters.

    if ($x->is_rule) {
        unshift(@params, P6C::Rules::rule_vars());
    }

    my @sigparams = map { new P6C::sigparam var => $_,
                                            type => $_->type,
                                            zone => 'optional',
                        } @params;
    my $slurpy_array;
    if ($add_on_slurpy_array) {
        $slurpy_array = default_signature()->slurpy_array;
    }
    return new P6C::signature positional => \@sigparams,
                              slurpy_array => $slurpy_array;
}

# Generate the code to implement the body of a subroutine (or anything
# else that contains a closure). That includes grabbing arguments and
# binding them to parameters, and returning values.
sub val {
    my $x = shift;
    my $ctx = $x->{ctx};

    code("# ".$x->{comment}) if $x->{comment};

    my ($name, $ofunc);		# for closure return value.
    push_scope;
    if ($ctx->{is_anon_sub}) {
	# We need to create an anonymous sub.
	$name = genlabel 'closure';
	add_function($name, new P6C::sub_def closure => $x);
	$ofunc = set_function($name);
    }

    # Figure out params:
    $x->params(get_params($x));

    if ($x->is_rule) {
        P6C::Rules::adjust_rule_return($x);
    } elsif ($ctx->{noreturn}) {
	# Do nothing.
    } else {
        $x->rettype('PerlArray');
    }

    # If it's just a declaration, we're done:
    unless (defined $x->block) {
	pop_scope;
	return undef;
    }

    declare_label type => 'return' unless ($ctx->{noreturn});

    # Get a list of statements in the block. I'm not sure why this
    # isn't always in a predictable type. FIXME.
    my @stmts;
    if (UNIVERSAL::isa($x->block, 'ARRAY')) {
        @stmts = @{ $x->block };
    } else {
        @stmts = ($x->block);
    }

    my @catchers;
    foreach (@stmts) {
        if ($_->isa('P6C::prefix') && defined($_->name)
            && $_->name eq 'CATCH')
        {
            push @catchers, $_->args;
            $_->name(undef);
        }
    }

    my $ret;
    if (@catchers) {
        die "Only one catch block per block, please" if @catchers > 1;
        $ret = wrap_with_catch($x, $catchers[0]);
        die unless $ret || $ctx->{noreturn};
    } elsif (@stmts > 0) {
        foreach my $stmt (@stmts[0..$#stmts-1]) {
            $stmt->val;
        }
        $ret = $stmts[-1]->val;
        confess "missing return value for " . $stmts[-1]->render
          unless $ret || $ctx->{noreturn};
    } else {
        $ret = newtmp 'PerlUndef';
    }

    unless ($ctx->{noreturn}) {
        code("\t.pcc_begin_return");
        if ($x->is_rule) {
            # FIXME: The general return mechanism should be able to
            # handle this, but return tuples are not yet supported
            # properly.
            code("\t.return ".$_->val) foreach (@{ $ret->vals });
        } else {
            code("\t.return $ret # regular (non-rule) return");
	}
        code("\t.pcc_end_return");
        emit_label type => 'return' unless $ctx->{noreturn};
    } else {
        code("# noreturn");
    }

    if ($ctx->{is_anon_sub}) {
	# Create a closure.
	set_function($ofunc);
	$ret = newtmp 'Sub';
	code("\tnewsub $ret, .Sub, _$name");
	$ret = scalar_in_context($ret, $x->{ctx});
    }

    pop_scope;
    return $ret;
}

######################################################################
package P6C::variable;
use P6C::IMCC ':all';
use P6C::Context;
use P6C::Util qw(is_scalar is_scalar_expr same_type unimp is_pmc);

sub val_in_context {
    my ($v, $type, $ctx) = @_;
    if (is_scalar($type)) {
	return scalar_in_context($v, $ctx);
    } elsif ($type eq 'PerlArray') {
	return array_in_context($v, $ctx);
    } else {
	return $v;
    }
}

sub val {
    my $x = shift;
    my $ctx = $x->{ctx};
    die $x->name unless $ctx;
    my ($v, $global) = findvar($x->name);
    if ($global) {
	my $reg = gentmp 'PerlUndef';
	code(<<END);
	$reg = $v
END
	$v = $reg;
    }
    return val_in_context $v, $x->type, $x->{ctx};
}

sub need_cloning {
    my ($x, $other) = @_;
       # If $other is non-scalar and we're assigning to a scalar,
       # there's no need to clone (either we'll get something
       # like an array-length, or it will become an
       # auto-reference).
    return 0 if (is_scalar($x->type) &&
           ($other->can('type') && !is_scalar($other->type)));
    return 1;
}

# Horrible hack to get some incredibly trivial cases of bind (the
# C<:=> operator) to work.
sub bind {
    my ($x, $thing) = @_;
    return assign($x, $thing, 1);
}

sub assign {
    my ($x, $thing, $suppress_clone) = @_;
    my ($name, $global) = findvar($x->name);
    my $tmpv;
    my $do_clone = ! $suppress_clone && need_cloning($x, $thing);
    if (!$global && $thing->isa('P6C::sv_literal')) {
	$tmpv = $thing->lval;
	$do_clone = 0;
    } else {
	$tmpv = $thing->val;
    }
    if ($global) {
	my $clonev;
	if ($do_clone) {
	    $clonev = gentmp 'PerlUndef';
	    code(<<END)
	$clonev = clone $tmpv
	$name = $clonev
END
	} else {
	    $clonev = $tmpv;
	    code("\t$name = $tmpv");
	}
	return val_in_context $clonev, $x->type, $x->{ctx};

    } else {
	if ($do_clone) {
            my $desc = $x->name;
            $desc .= " (global)" if $global;
	    code("\t$name = clone $tmpv # ASSIGN TO $desc");
	} else {
	    # assign non-scalar to scalar => no need to clone.
	    code("\t$name = $tmpv");
	}
	return val_in_context $name, $x->type, $x->{ctx};
    }
}

######################################################################
# Variable declarations, which may have initializers
package P6C::decl;
use Carp 'cluck';
use P6C::IMCC ':all';
use P6C::Util 'unimp';
use P6C::Context;

sub vars_in_context {
    my ($vars, $ctx) = @_;
    return undef if $ctx->type eq 'void';
    my $vlist = new P6C::ValueList vals => $vars;
    $vlist->ctx_right($ctx);
    return $vlist->val;
}

sub val {
    my $x = shift;
    code("# " . $x->{comment}) if $x->{comment};
    if ($x->qual && $x->qual->scope ne 'my') {
	unimp 'global variables';
    }
    if (@{$x->props}) {
	unimp 'variable properties';
    }
    my $vars = $x->vars;
    $vars = [ $vars ] unless ref $vars eq 'ARRAY';
    add_localvar($_->name, $_->type) foreach @$vars;
    return vars_in_context($vars, $x->{ctx});
}

# A declaration with initializers shows up as assigning to a decl.
#
# XXX: The shenanigans with temporaries should go away, as they are
# the Wrong Way to make sure that the declared variable is not defined
# within its own initializer.
sub assign {
    my ($x, $thing) = @_;

    # optimize simple decls
    if ($thing->isa('P6C::sv_literal')) {
        add_localvar($x->vars->name, $x->vars->type);
	$x->vars->assign($thing);
	return vars_in_context([ $x->vars ], $thing->{ctx});
    }

    my $tmpv = $thing->val;

    if (ref $x->vars ne 'ARRAY') {
	if (ref($tmpv) eq 'ARRAY') {
	    cluck "shouldn't return tuple in scalar context\n";
	    $tmpv = $tmpv->[-1];
	}
	add_localvar($x->vars->name, $x->vars->type);
	$x->vars->assign(new P6C::Register reg => $tmpv,
			 type => $x->vars->type);
    } else {
	# If we are evaluating an expression in tuple context, the val
	# function must return an array ref.
	if (ref $tmpv ne 'ARRAY') {
	    cluck "Shouldn't pass single item to tuple\n";
	    $tmpv = [$tmpv];
	}
	my @vars = @{$x->vars};
	my $min = @$tmpv < @vars ? @$tmpv : @vars;
	for my $i (0.. $min - 1) {
	    add_localvar($vars[$i]->name, $vars[$i]->type);
	    $vars[$i]->assign(new P6C::Register reg => $tmpv->[$i],
			      type => $thing->{ctx}->type->[$i]);
	}

	# In case we had more variables than values (tuple rvalues can
	# do this), declare the rest of the variables.
	for my $i ($min .. $#vars) {
	    add_localvar($vars[$i]->name, $vars[$i]->type);
	}
    }
    return undef;
}

# HACK ALERT!
sub bind {
    my ($x, $thing) = @_;

    # optimize simple decls
    if ($thing->isa('P6C::sv_literal')) {
	add_localvar($x->vars->name, $x->vars->type);
	$x->vars->bind($thing);
	return undef;
    }

    my $tmpv = $thing->val; # FIXME

    if (ref $x->vars ne 'ARRAY') {
	if (ref($tmpv) eq 'ARRAY') {
	    cluck "shouldn't return tuple in scalar context\n";
	    $tmpv = $tmpv->[-1];
	}
	add_localvar($x->vars->name, $x->vars->type);
	$x->vars->bind(new P6C::Register reg => $tmpv,
                       type => $x->vars->type);
    } else {
	# If we are evaluating an expression in tuple context, the val
	# function must return an array ref.
	if (ref $tmpv ne 'ARRAY') {
	    cluck "Shouldn't pass single item to tuple\n";
	    $tmpv = [$tmpv];
	}
	my @vars = @{$x->vars};
	my $min = @$tmpv < @vars ? @$tmpv : @vars;
	for my $i (0.. $min - 1) {
	    add_localvar($vars[$i]->name, $vars[$i]->type);
	    $vars[$i]->bind(new P6C::Register reg => $tmpv->[$i],
                            type => $thing->{ctx}->type->[$i]);
	}

	# In case we had more variables than values (tuple rvalues can
	# do this), declare the rest of the variables.
	for my $i ($min .. $#vars) {
	    add_localvar($vars[$i]->name, $vars[$i]->type);
	}
    }
    return undef;
}

######################################################################

sub P6C::indices::val {
    my $x = shift;
    my $ctx = $x->{ctx};
    return $x->indices->val;
}

##############################
package P6C::subscript_exp;
use Data::Dumper;
use P6C::Util 'unimp';
use P6C::IMCC ':all';

# Temporary types for different slices:
use vars '%temptype';
BEGIN {
%temptype = (PerlArray => 'int',
             PerlHash => 'str');
}

# Slice value.  Probably doesn't handle every single case, but it
# should handle most.
sub val {
    my ($x) = @_;
    if (@{$x->subscripts} > 1) {
	# XXX: shouldn't be too hard -- just evaluate subscripts
	# recursively on temporaries.  Not sure how context would work.
	unimp "multi-level subscripting";
    }
    if ($x->subscripts(0)->type eq 'Sub') {
	# Function call : $f(...)
        my $ret = P6C::IMCC::prefix::gen_sub_call($x->thing,
                                                  $x->subscripts(0)->indices,
                                                  $x->{ctx});

	return array_in_context($ret, $x->{ctx});
    }
    code("# Base for indexing\n");
    my $thing = $x->thing->val;
    my $type = $x->subscripts(0)->type;
    code("# done; result in $thing\n");

    code("# Indexing expression\n");
    my $indexval = $x->subscripts(0)->val;
    code("# done; result in $indexval\n");

    my $ret;
    my $ctx = $x->{ctx};
    if ($ctx->is_scalar) {
	# Scalar context or single item => return last/only item.
	$ret = gentmp 'PerlUndef';
	my $itmp = gentmp $temptype{$type};
	$indexval = $indexval->[-1] if ref $indexval;
	code(<<END);
	$itmp = $indexval
	$ret = $thing\[$itmp]
END

    } elsif ($ctx->is_array || $ctx->flatten) {
	# Slice in array context.
	# XXX: slice in flattening context could be smarter?
	$ret = newtmp 'PerlArray';
	my $itmp = gentmp $temptype{$type};
	my $ptmp = gentmp 'PerlUndef';
	my $ret_index = gentmp 'int';
	code(<<END);
	$ret_index = $indexval # for i = slice.length
	$ret = $ret_index # preallocate dest
END
	code(gen_counted_loop($ret_index, <<END, "slice in array ctx"));
	$itmp = $indexval\[$ret_index]
	$ptmp = $thing\[$itmp]
	$ret\[$ret_index] = $ptmp  # dest[i] = src[slice[i]]
END
        code("# slice in array context complete");

    } elsif ($ctx->is_tuple) {
	my $itmp = gentmp $temptype{$type};
	my @ret;
	die unless ref $indexval eq 'ARRAY';

	for (@$indexval) {
	    my $rettmp = gentmp 'PerlUndef';
	    push @ret, $rettmp;
	    code(<<END);
	$itmp = $_
	$rettmp = $thing\[$itmp]
END
	}
	$ret = [@ret];

    } else {
	confess "slice in unsupported context ".Dumper($ctx);
    }
    return $ret;
}

sub assign {
    my ($x, $thing) = @_;
    if (@{$x->subscripts} > 1) {
	unimp "multi-level subscripting";
    }
    my $indexval = $x->subscripts(0)->val;
    my $type = $x->subscripts(0)->type;
    my $rhs = $thing->val;
    my $lhs = $x->thing->val;
    my $lctx = $thing->{ctx};

    if (!$lctx || $lctx->is_scalar) {
	# XXX: This isn't quite right, since we're taking lhs's
	# C<val>.  But it works for simple @arrays.
	my $itmp = gentmp $temptype{$type};
	$indexval = $indexval->[-1] if ref $indexval;
	code(<<END);
	$itmp = $indexval
	$lhs\[$itmp] = $rhs
END
	# XXX: should return $lhs[$itmp]...
	return scalar_in_context($rhs, $x->{ctx});

    } elsif ($lctx->is_tuple) {
	my $itmp = gentmp $temptype{$type};
	for my $i (0..$#{$indexval}) {
	    code(<<END);
	$itmp = $indexval->[$i]
	$lhs\[$itmp] = $rhs->[$i]
END
	}
	return tuple_in_context($rhs, $x->{ctx});

    } elsif ($lctx->is_array) {
	my $index = gentmp $temptype{$type};
	my $iter = gentmp 'int';
	my $long = gentmp 'int';
	my $short = gentmp 'int';
	my $ptmp = gentmp;
	my $start = genlabel 'slice_assign';
	my $start2 = genlabel 'cleanup';
	my $end2 = genlabel 'cleanup';
	# Figure out how many values to assign:
	code(<<END);
	$short = $indexval
	$long = $rhs
	if $short < $long goto $start
	$iter = $short
	$short = $long
	$long = $iter
$start:
	$iter = $short
END
	# Assign them:
	code(gen_counted_loop($iter, <<END, "slice assignment"));
	$index = $indexval\[$iter]
	$ptmp = $rhs\[$iter]
	$lhs\[$index] = $ptmp
END
	# If we have more values, assign undef to the rest of them:
	code(<<END);
	$ptmp = new PerlUndef
	goto $end2
$start2:
	$index = $indexval\[$short]
	$lhs\[$index] = $ptmp
	inc $short
$end2:
	if $short < $long goto $start2
END
	unimp 'rvalue of assignment to slice' unless $x->{ctx}->type eq 'void';
	return undef;
    } else {
	unimp 'Assignment to multi-element slice: '.Dumper($lctx);
    }
}

######################################################################
sub P6C::loop::val {
    my ($x) = @_;
    my $label = $x->{ctx}{label};
    my $start = genlabel 'loop';
    my $end = genlabel 'loop';

    push_scope;
    declare_label name => $label, type => $_ for qw(next redo last continue);
    $x->init->val if $x->init;
    code(<<END);
	goto $end
$start:
END
    emit_label name => $label, type => 'redo';

    $_->val for @{$x->block};

    emit_label name => $label, type => 'next';
    emit_label name => $label, type => 'continue';
    $x->incr->val if $x->incr;
    code(<<END);
$end:
END
    my $test = $x->test->val if $x->test;
    code(<<END);
	if $test goto $start
END
    emit_label name => $label, type => 'last';
    pop_scope;
    confess "cannot get type?" . Data::Dumper::Dumper($x->{ctx})
      unless UNIVERSAL::can($x->{ctx}, 'type');
    return undef_in_context($x->{ctx});
}

######################################################################
sub P6C::label::val {
    my ($x) = @_;
    declare_label name => $x->name;
    emit_label name => $x->name;
    return undef_in_context(undef);
}

######################################################################
sub P6C::debug_info::val {
    my $x = shift;
    my ($f, $l, $c, $txt) = @$x;
    code( qq{#line $l "$f"\n#@@@@ $txt\n}) if ($P6C::IMCC::curfunc);
    return undef;
}

######################################################################
sub P6C::context::val {
    my $x = shift;
    my $v = $x->thing->val;
    my $type = $P6C::context::names{$x->ctx};
    if ($type eq 'PerlArray') {
	return array_in_context($v, $x->{ctx});
    } elsif ($type eq 'PerlHash') {
	unimp 'hash context';
    } else {
	return scalar_in_context($v, $x->{ctx});
    }
}

######################################################################

=head2 P6C::rule

A node representing a rule.

=over

=cut

package P6C::rule;
use P6C::IMCC ':all';
require P6C::Util;

sub prepare_match_object {
    my $r = shift;
    my $ret = newtmp 'PerlHash';
    return $ret;
}

=item B<val()> : rule -> match obj

Generate code defining a rule

Rules take several arguments:
 mode     - 0 means try to match rule
            1 means backtrack into rule
 rx_pos   - position within input string to start matching
 rx_input - input string
 rx_stack - backtracking state stack
 params   - rule parameters array

and return two values:
 rx_pos   - position after applying rule (to match or backtrack)
 status   - 1 for success, 0 for failure

TODO: Rather than returning a status code, this really ought to just
invoke the appropriate continuation.

TODO: It would also be nice to have two different entry points rather
than the hokey C<mode> param.

=cut

sub val {
    my ($rule) = @_;

    # FIXME
    my $ctx = $rule->{ctx};

    # The generated regex will transfer control to one of the
    # following two labels:
    my $pass_label = genlabel 'match_passed';
    my $fail_label = genlabel 'match_failed';

    my $return = genlabel 'match_return';

    code("    # Regular expression (rule)", "");

    # We assume the existence of a local variable (parameter,
    # actually) called "rx_input". Also, "rx_pos" and "rx_stack".
    $ctx->{rx_input} = findvar("=rx_input");
    $ctx->{rx_starts} = newlocal('IntList', 'rx_starts'); # FIXME
    $ctx->{rx_ends} = newlocal('IntList', 'rx_ends'); # FIXME
    $ctx->{rx_stack} = findvar("=rx_stack");
    $ctx->{rx_pos} = findvar("=rx_pos");
    $ctx->{rx_len} = genlocal('int', 'rx_len');
    $ctx->{preserve_state} = 1;
    code("length $ctx->{rx_len}, $ctx->{rx_input}");

    if ($ENV{RX_DEBUG}) {
        code(<<"END");
print "Attempting to match <$rule> at "
print $ctx->{rx_pos}
print "\\n"
END
    }

    # This only creates the code, it does not emit it (except I think
    # it will emit local vars and things -- FIXME)
    my $regex =
      P6C::IMCC::Binop::generate_regex($rule, $pass_label, $fail_label, $ctx);

    code(<<"END");
    eq mode, 1, $regex->{lastback} # Mode: 0 => try to match, 1 => backtrack
END

    P6C::IMCC::ExtRegex::emit_extregex_code($regex->{code});
    my $status_var = gentmp('int');
    code(<<"END");
$pass_label:
    $status_var = 1
    branch $return
$fail_label:
    $status_var = 0
$return:
END

    return new P6C::ValueList
      vals => [ P6C::Register->new(reg => $status_var, type => 'int'),
                P6C::Register->new(reg => $ctx->{rx_pos}, type => 'int') ];
}

1;

=back

=head1 SEE ALSO

L<P6C::IMCC::prefix> for prefix operators (function calls, return
statements, if/for/while/given, etc.)
