=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(warning unimp error);
use P6C::Context;
use P6C::Addcontext;

# 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 set_function_params set_function_return
		  gen_counted_loop scalar_in_context do_flatten_array
		  array_in_context tuple_in_context undef_in_context
		  primitive_in_context call_closure);
    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
	new_pad 0
	call __setup
END

    # emulate a sub main (@ARGS) { ... }, except don't pass in a named
    # argument hash. This is hopefully a temporary hack, until we can
    # find a better place to put all the named arguments.
    $funcs{main}->params((P6C::Builtins::parse_sig('@ARGS'))[0]);
    $funcs{main}->params->{no_named} = 1;

    # 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';
	.pcc_begin non_prototyped
        .arg P5
	.pcc_call main_sub
main_ret_label:
	.pcc_end
	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 ".pcc_sub $name non_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.

=item B<add_function($name)>

Create a new function stub for C<$name>.  If C<$name> exists, it will
be overwritten.

=item B<exists_function_def($name)>

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

=item B<exists_function_decl($name)>

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

=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.

=item B<set_function_params($signature)>

Set the parameter list for the current function.  The argument should
be a C<P6C::signature> object.

=item B<set_function_return($ret)>

=back

=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;
}

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;
}

sub add_function($) {
    my $f = shift;
    if (exists $funcs{$f}) {
        if ($funcs{$f}->{'autodeclared'}) {
            diag "$f called too early to check prototype";
        } else {
            diag "Redefining function $f";
        }
    }
    $funcs{$f} = new P6C::IMCC::Sub;
    # NOTE: top-level closure will push a scope.
    return 1;
}

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

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

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

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

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

=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 = 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.

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

Lookup a global variable.

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

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

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

Find parameter C<$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.

=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.

=item B<push_scope()>

Push a scope within the current function.

=item B<pop_scope()>

Pop a scope from the current function.

=item B<mangled_name($thing)>

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

=back

=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 thereforemuch 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.

=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.

=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.

=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.

=item B<topic()>

Get the current topic variable.

=back

=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).'"';
}

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

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

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

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

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

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;
}

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

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

# 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 "$#@!!".
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;
}

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

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

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;
}

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

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

=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

=over

The following functions generate useful and common pieces of code.

=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) = @_;
    my $start = genlabel;
    my $end = genlabel;
    return <<END;
	goto $end
$start:
	dec $count
$body
$end:
	if $count != 0 goto $start
END
    return undef;
}

=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;
    my $tmp = newtmp 'PerlArray';
    my $len = gentmp 'int';
    my $offset = gentmp 'int';
    my $tmpindex = gentmp 'int';
    my $ptmp = gentmp 'PerlUndef';
    code(<<END);
# START array flattening.
	$offset = 0
END
    for my $i ($off .. $#{$vals}) {
	if ($vals->[$i]->isa('P6C::sv_literal')) {
	    my $itemval = $vals->[$i]->lval;
	    code(<<END);
	$tmp\[$offset] = $itemval
	inc $offset
END
	} else {
	    my $item = $vals->[$i]->val;
	    code(<<END);
	$len = $item
END
	    code(gen_counted_loop($len, <<END));
	$ptmp = $item\[$len]
	$tmpindex = $offset + $len
	$tmp\[$tmpindex] = $ptmp
END
	    code(<<END);
	$len = $item
	$offset = $offset + $len
END
	}
    }
    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

# FIXME: This completely ignores the new signature-based calling
# stuff.
sub call_closure {
    my ($thing, $args) = @_;
    my $argval = $args ? $args->val : newtmp('PerlArray');
    my $func = $thing->val;
    my $dummy_named = newtmp 'PerlHash';
    my $ret_label = genlabel 'ret_label';
    my $ret = gentmp 'pmc';
    code(<<END);
	.pcc_begin non_prototyped # closure
	.arg	$dummy_named
	.arg	$argval
	.pcc_call $func
$ret_label:
	.result $ret
	.pcc_end
END
    return $ret;
}

=head2 P6C::IMCC::Sub

Stores IMCC code for a subroutine.

XXX: the fact that e.g. C<P6C::prefix> relies on this for argument
information is just wrong.  This information should be retrieved from
the parse tree structures instead.

=over

=item B<< $sub->{code} >>

The code (not including C<.local> definitions, etc).  Should be
appended to like C<< $func->{code} .= $thing >>.

=item B<emit($sub)>

Emit a complete function body, minus the C<.sub> directive.

=back

=cut

package P6C::IMCC::Sub;
use Class::Struct 'P6C::IMCC::Sub'
    => { scopes => '@',		# scope stack
	 params => '$',		# parameters passed
	 rettype => '$',	# return type (scalar, array, tuple)
       };
#	{scopelevel}		# current scope number
#	{oldscopes}		# other closed scopes in this sub.

use P6C::Util qw(diag error);
use P6C::IMCC qw(mangled_name genlabel);

sub _find {
    my ($x, $thing) = @_;
    for (@{$x->scopes}) {
	if (exists $_->{$thing}) {
	    return $_->{$thing};
	}
    }
    return undef;
}

sub localvar {
    my ($x, $var) = @_;
    my $res = $x->_find($var);
    if ($res) {
	return $res->[0];
    }
    return undef;
}

sub add_localvar {
    my ($x, $var, $type, $init) = @_;
    $x->{scopelevel} ||= 0;
    my $scopename = mangled_name($var).$x->{scopelevel};
    if ($x->scopes->[0]{$var}) {
	diag "Redeclaring lexical $var in $P6C::IMCC::curfunc";
    }
    $x->scopes->[0]{$var} ||= [$scopename, $type, $init];
    return $scopename;
}

sub label {
    my $x = shift;
    my %o = @_;
    $o{name} = '' unless defined $o{name};
    $o{type} = '' unless defined $o{type};
    my $mangled = "label:$o{name}:$o{type}";
    return $x->_find($mangled);
}

sub add_label {
    # XXX: note trickery here -- if the label has both a type and a
    # name, we just add ":type" and "name:type", not "name".  This is
    # deliberate -- the label statement itself will cause the "name"
    # to be emitted.
    my $x = shift;
    my %o = @_;
    my $lab = genlabel;
    if ($o{type}) {
	$x->scopes->[0]{"label::$o{type}"} = $lab;
	if ($o{name}) {
	    $x->scopes->[0]{"label:$o{name}:$o{type}"} = $lab;
	}
    } elsif ($o{name}) {
	$x->scopes->[0]{"label:$o{name}:"} = $lab;
    } else {
	die "internal error -- add_label() with neither type nor name";
    }
    return $lab;
}

sub topic {
    my $x = shift;
    return $x->_find('topic:');
}

sub set_topic {
    my ($x, $topic) = @_;
    $x->scopes->[0]{"topic:"} = $topic;
}

sub push_scope {
    my $x = shift;
    $x->{scopelevel}++;
    unshift @{$x->scopes}, { };
}

sub maybe_set_params {
    # XXX: hack to keep inner closures from mucking with our params.
    my ($x, $signature) = @_;
    unless ($x->{hasparam}) {
        $x->params($signature);
	$x->{hasparam} = 1;
    }
}

sub set_return {
    my ($x, $r) = @_;
    $x->rettype($r);
}

sub pop_scope {
    my $x = shift;
    push @{$x->{oldscopes}}, shift @{$x->scopes};
}

# P6C::IMCC::Sub::emit - print out the code for a subroutine body
#
# 1. Grab the parameters from the passed-in registers
# 2. Implement the subroutine code
# 3. call the continuation to "return"
#
# FIXME: Non-PMC arguments/params are not yet handled.
# FIXME: Pass-by-value only implemented
sub emit {
    my ($x, $prototyped) = @_;
    my $params = $x->params;

    # $positional_args is a PerlArray containing all of the non-named
    # args (including all positional args and the slurpy array, if
    # any) in the unprototyped case. In the prototyped case, the
    # required and positional args are passed directly.
    my $positional_args;
    if (! $prototyped || $params->slurpy_array) {
        $positional_args = P6C::IMCC::gensym("positionals");
    }
    my $known_named_args = P6C::IMCC::gensym("known_named");
    my $named_args = P6C::IMCC::gensym("unknown_named");

    print "\t.param PerlHash $named_args # named args\n"
      unless $params->{no_named};

    foreach my $param (@{ $params->positional }, @{ $params->optional }) {
        my ($ptype, $pvar) = ($param->type, $param->var);
        my $pname = $pvar->name;
        my $pname_mangled = P6C::IMCC::mangled_name($pname);
        print "\t.param $ptype $pname_mangled # Positional param $pname\n";
    }

    # The slurpy array, if any, is passed as an array PMC
    if ($params->slurpy_array) {
        my $slurpy = $params->slurpy_array->var->name;
        my $slurpy_name = mangled_name($slurpy);
        print "\t.param object $slurpy_name # slurpy array $slurpy_name\n";
    }

    # Create local variables for all the named arguments
    foreach my $param (@{ $params->required_named },
                       @{ $params->optional_named })
    {
        my ($ptype, $pvar) = ($param->type, $param->var);
        my $pname = $pvar->name;
        my $pname_mangled = P6C::IMCC::mangled_name($pname);
        print "\t.sym $ptype $pname_mangled # Named param $pname\n";
    }

    my $tmp = P6C::IMCC::gentmp 'int';
    my $got_params = genlabel "got_params";
    unless ($params->{no_named}) {
        print "# Argument handling\n";
        print "  if I0 goto $got_params\n";
        my $min_count = 2;
        foreach my $param (@{ $params->positional }) {
            my ($ptype, $pvar) = ($param->type, $param->var);
            my $pname = $pvar->name;
            my $pname_base = substr($pname, 1);
            my $pname_mangled = P6C::IMCC::mangled_name($pname);
            my $label = genlabel "skip_param_$pname_mangled";
            print "  if I1 >= $min_count goto $label\n";
            print "  exists $tmp, $named_args\[\"$pname_base\"]\n";
            print "  unless $tmp goto $label\n";
            print "  $pname_mangled = $named_args\[\"$pname_base\"]\n";
            print "  delete $named_args\[\"$pname_base\"]\n";
            print "$label:\n";
            $min_count++;
        }
        print "$got_params:\n";
    }

    # Grab out the named params
    foreach my $param (@{ $params->required_named },
                       @{ $params->optional_named })
    {
        my ($ptype, $pvar) = ($param->type, $param->var);
        my $pname = $pvar->name;
        my $pname_base = substr($pname, 1);
        my $pname_mangled = P6C::IMCC::mangled_name($pname);
        print "  $pname_mangled = $named_args\[\"$pname_base\"\]\n";
    }

    print "# Named locals:\n";
    for (@{$x->scopes}, @{$x->{oldscopes}}) {
	for my $v (values %$_) {
	    next unless ref($v) eq 'ARRAY';
	    my ($n, $t) = @$v;
	    $t = P6C::IMCC::paramtype($t);
	    print "\t.local $t $n\n";
	}
    }
    # Maybe constructors for locals:
    for (@{$x->scopes}, @{$x->{oldscopes}}) {
	for my $v (values %$_) {
	    next unless ref($v) eq 'ARRAY';
	    my ($n, $t, $init) = @$v;
	    print "\t$n = new $t\n"
		if P6C::IMCC::regtype($t) eq 'P' && $init;
	}
    }
    print $x->{code};
    print <<END;
        .pcc_begin_return
        .pcc_end_return
END
#    print <<END;
#	restoreall
#	invoke $saved_continuation
#	end
#END
}

######################################################################
# 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 $min = @{ $type->positional };
        die "not enough args: need $min, have " . @{$x->vals}
          if @{$x->vals} < $min; # Should be runtime exception?

	for my $i (0..$min - 1) {
	    push @ret, $x->vals($i)->val;
	}
	if ($type->slurpy_array) {
	    # 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 {
            my $opt = @{ $type->optional };
	    for my $i ($min .. $#{$x->vals}) {
                if ($i - $min < $opt) {
                    push @ret, $x->vals($i)->val;
                } else {
                    $x->vals($i)->val;
                }
	    }
	}
	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;

# Create generic code for $a op $b.
sub simple_binary {
    my $x = shift;
    my $ltmp = $x->l->val;
    my $rtmp = $x->r->val;
    my $dest = newtmp 'PerlUndef';
    my $op = $x->op;
    code("\t$dest = $ltmp $op $rtmp\n");
    return $dest;
}

# '=' assignment op.
sub do_assign {
    my $x = shift;
    return $x->l->assign($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,
 '~'	=> \&simple_binary,

# '_' => \&simple_binary, # PMC concat broken.
 '_'	=> \&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') {
	return do_hyped($x->op->op, $x->l, $x->r);
    }
    my $ret;
    my $op = $x->op;
    if ($ops{$op}) {
	$ret = $ops{$op}->($x);
    } elsif($op =~ /^([^=]+)=$/ && $ops{$1}) {
	# XXX:
	die "Internal error -- assignment op `$op' snuck into IMCC.pm";

	# Translate assignment operation into a binary operation.
	# XXX: Context propagation is broken for these, so we won't
	# ever do this.
	$op = $1;
	$ret = $ops{'='}->(new P6C::Binop op => '=', l => $x->l,
			   r => P6C::Binop->new(op => $op, l => $x->l,
						r => $x->r));
    } else {
	unimp $op;
    }

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

######################################################################
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 Data::Dumper;
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, @_);
    } elsif (exists $prefix_ops{$x->name}) {
	return $prefix_ops{$x->name}->($x, @_);
    } else {
	return gen_sub_call($x, @_);
#	unimp "Prefix operator ".$x->name();
    }
}

######################################################################
# 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.

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);
    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::Builtins::parse_sig('*@_'))[0];
}

# 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.
sub val {
    my $x = shift;
    my $ctx = $x->{ctx};
    my ($name, $ofunc);		# for closure return value.
    my @params;

    push_scope;
    if ($ctx->{is_anon_sub}) {
	# We need to create an anonymous sub.
	$name = genlabel 'closure';
	add_function($name);
	$ofunc = set_function($name);
    }

    # Figure out params:
    unless ($x->params) {
	$x->params(P6C::closure::default_signature());
    }

    set_function_params($x->params);

    if ($ctx->{noreturn}) {
	# Do nothing.
    } elsif (UNIVERSAL::isa($x->block, 'P6C::rule')) {
	set_function_return('PerlUndef');
    } else {
	set_function_return('PerlArray');
    }

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

    my $ret;
    unless ($ctx->{noreturn}) {
	declare_label type => 'return';
    }
    if (UNIVERSAL::isa($x->block, 'P6C::rule')) {
	$ret = $x->block->val;
	unless ($ctx->{noreturn}) {
	    code(<<END);
	.pcc_begin_return
	.return $ret
	.pcc_end_return
END
	    emit_label type => 'return';
	}
    } else {
	my @catchers;
	foreach (@{$x->block}) {
	    if ($_->isa('P6C::prefix') && defined($_->name)
		&& $_->name eq 'CATCH') {
		push @catchers, $_->args;
		$_->name(undef);
	    }
	}
	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 (@{$x->block} > 0) {
	    foreach my $stmt (@{$x->block}[0..$#{$x->block} - 1]) {
		$stmt->val;
	    }
	    $ret = $x->block->[-1]->val;
	    confess unless $ret || $ctx->{noreturn};
	} else {
	    $ret = newtmp 'PerlUndef';
	}

	unless ($ctx->{noreturn}) {
	    code(<<END);
	.pcc_begin_return
	.return $ret # regular (non-rule) sub return
	.pcc_end_return
END
	    emit_label type => 'return' unless $ctx->{noreturn};
	}
    }
    if ($ctx->{is_anon_sub}) {
	# Create a closure.
	set_function($ofunc);
	$ret = newtmp 'Sub';
	my $itmp = gentmp 'int';
	code(<<END);
	$itmp = addr _$name
	$ret = $itmp
END
	$ret = scalar_in_context($ret, $x->{ctx});
    }
    pop_scope;
    return $ret;
}

######################################################################
package P6C::variable;
use Data::Dumper;
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;
}

sub assign {
    my ($x, $thing) = @_;
    my ($name, $global) = findvar($x->name);
    my $tmpv;
    my $do_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(<<END);
	$name = $tmpv
END
	}
	return val_in_context $clonev, $x->type, $x->{ctx};

    } else {
	if ($do_clone) {
	    code(<<END);
# ASSIGN TO @{[$x->name(), $global ? " (global)" : ""]}
	$name = clone $tmpv
END
	} else {
	    # assign non-scalar to scalar => no need to clone.
	    code(<<END);
	$name = $tmpv
END
	}
	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 val {
    my $x = shift;
    if ($x->qual && $x->qual->scope ne 'my') {
	unimp 'global variables';
    }
    if (@{$x->props}) {
	unimp 'variable properties';
    }
    if (ref $x->vars eq 'ARRAY') {
	add_localvar($_->name, $_->type) for @{$x->vars};
    } else {
	add_localvar($x->vars->name, $x->vars->type);
    }
    return undef;
}

# 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 undef;
    }

    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;
}

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

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 = qw(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
	return array_in_context(call_closure($x->thing,
					     $x->subscripts(0)->indices),
				$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
	$ret = $ret_index
END
	code(gen_counted_loop($ret_index, <<END));
	$itmp = $indexval\[$ret_index]
	$ptmp = $thing\[$itmp]
	$ret\[$ret_index] = $ptmp
END

    } 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));
	$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 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});
    }
}

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

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

sub val {
    my $x = shift;
    my $fail = genlabel 'match_failed';
    my $precode;
    my $rxstr = gentmp 'str';
    my $rxpos = gentmp 'int';
    my $isback = gentmp 'int';
    my $fake_back = genlabel 'XXX';
    code(<<END);
	restore $rxstr
	rx_popindex $rxpos, $fake_back
END
    $x->{ctx}{rx_pos} = $rxpos;
    $x->{ctx}{rx_thing} = $rxstr;
    $x->{ctx}{rx_fail} = $fail;
    my $ret = $x->{ctx}{rx_matchobj} = $x->prepare_match_object;
    my $back = P6C::IMCC::rule::rx_val($x);
    my $end = genlabel 'end';
    fixup_label($fake_back, $back);
    code(<<END);
	rx_pushindex $rxpos
	goto $end
$fail:
	$ret = new PerlUndef
	rx_pushmark
$end:
END
    return scalar_in_context($ret, $x->{ctx});
}

1;
